]> git.uio.no Git - u/mrichter/AliRoot.git/blame - PYTHIA6/pythia6150.f
git://git.uio.no / u / mrichter / AliRoot.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
fixed bug in AliSTARTTrigger
[u/mrichter/AliRoot.git] / PYTHIA6 / pythia6150.f
CommitLineData
952cc209 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* Physics Department, UC Davis **
20C* One Shields Avenue, Davis, CA 95616, USA **
21C* phone + 1 - 530 - 752 - 2661 **
22C* E-mail mrenna@physics.ucdavis.edu **
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* code for virtual photons mainly written by Christer Friberg **
28C* code for low-mass strings mainly written by Emanuel Norrbin **
29C* Bose-Einstein code mainly written by Leif Lonnblad **
30C* CTEQ parton distributions are by the CTEQ collaboration **
31C* GRV 94 parton distributions are by Glueck, Reya and Vogt **
32C* SaS photon parton distributions together with Gerhard Schuler **
33C* g + g and q + qbar -> t + tbar + H code by Zoltan Kunszt **
34C* MSSM Higgs mass calculation code by M. Carena, **
35C* J.R. Espinosa, M. Quiros and C.E.M. Wagner **
36C* PYGAUS adapted from CERN library (K.S. Kolbig) **
37C* **
38C* The latest program version and documentation is found on WWW **
39C* http://www.thep.lu.se/~torbjorn/Pythia.html **
40C* **
41C* Copyright Torbjorn Sjostrand, Lund 1997 **
42C* **
43C*********************************************************************
44C*********************************************************************
45C *
46C List of subprograms in order of appearance, with main purpose *
47C (S = subroutine, F = function, B = block data) *
48C *
49C B PYDATA to contain all default values *
50C S PYTEST to test the proper functioning of the package *
51C S PYHEPC to convert between /PYJETS/ and /HEPEVT/ records *
52C *
53C S PYINIT to administer the initialization procedure *
54C S PYEVNT to administer the generation of an event *
55C S PYSTAT to print cross-section and other information *
56C S PYINRE to initialize treatment of resonances *
57C S PYINBM to read in beam, target and frame choices *
58C S PYINKI to initialize kinematics of incoming particles *
59C S PYINPR to set up the selection of included processes *
60C S PYXTOT to give total, elastic and diffractive cross-sect. *
61C S PYMAXI to find differential cross-section maxima *
62C S PYPILE to select multiplicity of pileup events *
63C S PYSAVE to save alternatives for gamma-p and gamma-gamma *
64C S PYGAGA to handle lepton -> lepton + gamma branchings *
65C S PYRAND to select subprocess and kinematics for event *
66C S PYSCAT to set up kinematics and colour flow of event *
67C S PYSSPA to simulate initial state spacelike showers *
68C S PYRESD to perform resonance decays *
69C S PYMULT to generate multiple interactions *
70C S PYREMN to add on target remnants *
71C S PYDIFF to set up kinematics for diffractive events *
72C S PYDISG to set up kinematics, remnant and showers for DIS *
73C S PYDOCU to compute cross-sections and handle documentation *
74C S PYFRAM to perform boosts between different frames *
75C S PYWIDT to calculate full and partial widths of resonances *
76C S PYOFSH to calculate partial width into off-shell channels *
77C S PYRECO to handle colour reconnection in W+W- events *
78C S PYKLIM to calculate borders of allowed kinematical region *
79C S PYKMAP to construct value of kinematical variable *
80C S PYSIGH to calculate differential cross-sections *
81C S PYPDFU to evaluate parton distributions *
82C S PYPDFL to evaluate parton distributions at low x and Q^2 *
83C S PYPDEL to evaluate electron parton distributions *
84C S PYPDGA to evaluate photon parton distributions (generic) *
85C S PYGGAM to evaluate photon parton distributions (SaS sets) *
86C S PYGVMD to evaluate VMD part of photon parton distributions *
87C S PYGANO to evaluate anomalous part of photon pdf's *
88C S PYGBEH to evaluate Bethe-Heitler part of photon pdf's *
89C S PYGDIR to evaluate direct contribution to photon pdf's *
90C S PYPDPI to evaluate pion parton distributions *
91C S PYPDPR to evaluate proton parton distributions *
92C F PYCTEQ to evaluate the CTEQ 3 proton parton distributions *
93C S PYGRVL to evaluate the GRV 94L proton parton distributions *
94C S PYGRVM to evaluate the GRV 94M proton parton distributions *
95C S PYGRVD to evaluate the GRV 94D proton parton distributions *
96C F PYGRVV auxiliary to the PYGRV* routines *
97C F PYGRVW auxiliary to the PYGRV* routines *
98C F PYGRVS auxiliary to the PYGRV* routines *
99C F PYCT5L to evaluate the CTEQ 5L proton parton distributions *
100C F PYCT5M to evaluate the CTEQ 5M1 proton parton distributions *
101C S PYPDPO to evaluate old proton parton distributions *
102C F PYHFTH to evaluate threshold factor for heavy flavour *
103C S PYSPLI to find flavours left in hadron when one removed *
104C F PYGAMM to evaluate ordinary Gamma function Gamma(x) *
105C S PYWAUX to evaluate auxiliary functions W1(s) and W2(s) *
106C S PYI3AU to evaluate auxiliary function I3(s,t,u,v) *
107C F PYSPEN to evaluate Spence (dilogarithm) function Sp(x) *
108C S PYQQBH to evaluate matrix element for g + g -> Q + Qbar + H *
109C *
110C S PYMSIN to initialize the supersymmetry simulation *
111C S PYAPPS to determine MSSM parameters from SUGRA input *
112C F PYRNMQ to determine running quark masses *
113C F PYRNMT to determine running top mass *
114C S PYTHRG to calculate sfermion third-gen. mass eigenstates *
115C S PYINOM to calculate neutralino/chargino mass eigenstates *
116C F PYRNM3 to determine running M3, gluino mass *
117C S PYEIG4 to calculate eigenvalues and -vectors in 4*4 matrix *
118C S PYHGGM to determine Higgs mass spectrum *
119C S PYSUBH to determine Higgs masses in the MSSM *
120C S PYPOLE to determine Higgs masses in the MSSM *
121C S PYVACU to determine Higgs masses in the MSSM *
122C S PYRGHM auxiliary to PYVACU *
123C S PYGFXX auxiliary to PYRGHM *
124C F PYFINT auxiliary to PYVACU *
125C F PYFISB auxiliary to PYFINT *
126C S PYSFDC to calculate sfermion decay partial widths *
127C S PYGLUI to calculate gluino decay partial widths *
128C S PYTBBN to calculate 3-body decay of gluino to neutralino *
129C S PYTBBC to calculate 3-body decay of gluino to chargino *
130C S PYNJDC to calculate neutralino decay partial widths *
131C S PYCJDC to calculate chargino decay partial widths *
132C F PYXXZ5 auxiliary for neutralino 3-body decay *
133C F PYXXW5 auxiliary for ino charge change 3-body decay *
134C F PYXXGA auxiliary for ino -> ino + gamma decay *
135C F PYX2XG auxiliary for ino -> ino + gauge boson decay *
136C F PYX2XH auxiliary for ino -> ino + Higgs decay *
137C F PYXXZ2 auxiliary for chargino 3-body decay *
138C S PYHEXT to calculate non-SM Higgs decay partial widths *
139C F PYH2XX auxiliary for H -> ino + ino decay *
140C F PYGAUS to perform Gaussian integration *
141C F PYSIMP to perform Simpson integration *
142C F PYLAMF to evaluate the lambda kinematics function *
143C S PYTBDY to perform 3-body decay of gauginos *
144C S PYTECM to calculate techni_rho/omega masses *
145C S PYEICG to calculate eigenvalues of a 4*4 complex matrix *
146C *
147C S PY1ENT to fill one entry (= parton or particle) *
148C S PY2ENT to fill two entries *
149C S PY3ENT to fill three entries *
150C S PY4ENT to fill four entries *
151C S PY2FRM to interface to generic two-fermion generator *
152C S PY4FRM to interface to generic four-fermion generator *
153C S PY6FRM to interface to generic six-fermion generator *
154C S PY4JET to generate a shower from a given 4-parton config *
155C S PY4JTW to evaluate the weight od a shower history for above *
156C S PY4JTS to set up the parton configuration for above *
157C S PYJOIN to connect entries with colour flow information *
158C S PYGIVE to fill (or query) commonblock variables *
159C S PYEXEC to administrate fragmentation and decay chain *
160C S PYPREP to rearrange showered partons along strings *
161C S PYSTRF to do string fragmentation of jet system *
162C S PYINDF to do independent fragmentation of one or many jets *
163C S PYDECY to do the decay of a particle *
164C S PYDCYK to select parton and hadron flavours in decays *
165C S PYKFDI to select parton and hadron flavours in fragm *
166C S PYNMES to select number of popcorn mesons *
167C S PYKFIN to calculate falvour prod. ratios from input params. *
168C S PYPTDI to select transverse momenta in fragm *
169C S PYZDIS to select longitudinal scaling variable in fragm *
170C S PYSHOW to do timelike parton shower evolution *
171C S PYBOEI to include Bose-Einstein effects (crudely) *
172C S PYBESQ auxiliary to PYBOEI *
173C F PYMASS to give the mass of a particle or parton *
174C F PYMRUN to give the running MSbar mass of a quark *
175C S PYNAME to give the name of a particle or parton *
176C F PYCHGE to give three times the electric charge *
177C F PYCOMP to compress standard KF flavour code to internal KC *
178C S PYERRM to write error messages and abort faulty run *
179C F PYALEM to give the alpha_electromagnetic value *
180C F PYALPS to give the alpha_strong value *
181C F PYANGL to give the angle from known x and y components *
182C F PYR to provide a random number generator *
183C S PYRGET to save the state of the random number generator *
184C S PYRSET to set the state of the random number generator *
185C S PYROBO to rotate and/or boost an event *
186C S PYEDIT to remove unwanted entries from record *
187C S PYLIST to list event record or particle data *
188C S PYLOGO to write a logo *
189C S PYUPDA to update particle data *
190C F PYK to provide integer-valued event information *
191C F PYP to provide real-valued event information *
192C S PYSPHE to perform sphericity analysis *
193C S PYTHRU to perform thrust analysis *
194C S PYCLUS to perform three-dimensional cluster analysis *
195C S PYCELL to perform cluster analysis in (eta, phi, E_T) *
196C S PYJMAS to give high and low jet mass of event *
197C S PYFOWO to give Fox-Wolfram moments *
198C S PYTABU to analyze events, with tabular output *
199C *
200C S PYEEVT to administrate the generation of an e+e- event *
201C S PYXTEE to give the total cross-section at given CM energy *
202C S PYRADK to generate initial state photon radiation *
203C S PYXKFL to select flavour of primary qqbar pair *
204C S PYXJET to select (matrix element) jet multiplicity *
205C S PYX3JT to select kinematics of three-jet event *
206C S PYX4JT to select kinematics of four-jet event *
207C S PYXDIF to select angular orientation of event *
208C S PYONIA to perform generation of onium decay to gluons *
209C *
210C S PYBOOK to book a histogram *
211C S PYFILL to fill an entry in a histogram *
212C S PYFACT to multiply histogram contents by a factor *
213C S PYOPER to perform operations between histograms *
214C S PYHIST to print and reset all histograms *
215C S PYPLOT to print a single histogram *
216C S PYNULL to reset contents of a single histogram *
217C S PYDUMP to dump histogram contents onto a file *
218C *
219C S PYKCUT dummy routine for user kinematical cuts *
220C S PYEVWT dummy routine for weighting events *
221C S PYUPIN dummy routine to initialize a user process *
222C S PYUPEV dummy routine to generate a user process event *
223C S PDFSET dummy routine to be removed when using PDFLIB *
224C S STRUCTM dummy routine to be removed when using PDFLIB *
225C S STRUCTP dummy routine to be removed when using PDFLIB *
226C S PYTAUD dummy routine for interface to tau decay libraries *
227C S PYTIME dummy routine for giving date and time *
228C *
229C*********************************************************************
230
fd658fdb 231C*********************************************************************
232
952cc209 233C...PYDATA
234C...Default values for switches and parameters,
235C...and particle, decay and process data.
236
237 BLOCK DATA PYDATA
238
239C...Double precision and integer declarations.
240 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
241 IMPLICIT INTEGER(I-N)
242 INTEGER PYK,PYCHGE,PYCOMP
243C...Commonblocks.
244 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
245 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
246 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
247 COMMON/PYDAT4/CHAF(500,2)
248 CHARACTER CHAF*16
249 COMMON/PYDATR/MRPY(6),RRPY(100)
250 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
251 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
252 COMMON/PYINT1/MINT(400),VINT(400)
253 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
254 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
255 COMMON/PYINT4/MWID(500),WIDS(500,5)
256 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
257 COMMON/PYINT6/PROC(0:500)
258 CHARACTER PROC*28
259 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
260 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
261 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
262 &SFMIX(16,4)
263 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
264 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,/PYSUBS/,
265 &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
266 &/PYINT6/,/PYINT7/,/PYMSSM/,/PYSSMT/,/PYBINS/
267
268C...PYDAT1, containing status codes and most parameters.
269 DATA MSTU/
270 & 0, 0, 0, 4000,10000, 500, 4000, 0, 0, 2,
271 1 6, 1, 1, 0, 1, 1, 0, 0, 0, 0,
272 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
273 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
274 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
275 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
276 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
277 7 30*0,
278 1 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
279 2 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
280 & 80*0/
281 DATA (PARU(I),I=1,100)/
282 & 3.141592653589793D0, 6.283185307179586D0,
283 & 0.197327D0, 5.06773D0, 0.389380D0, 2.56819D0, 4*0D0,
284 1 0.001D0, 0.09D0, 0.01D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
285 2 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
286 3 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
287 4 2.0D0, 1.0D0, 0.25D0, 2.5D0, 0.05D0,
288 4 0D0, 0D0, 0.0001D0, 0D0, 0D0,
289 5 2.5D0,1.5D0,7.0D0,1.0D0,0.5D0,2.0D0,3.2D0, 0D0, 0D0, 0D0,
290 6 40*0D0/
291 DATA (PARU(I),I=101,200)/
292 & 0.00729735D0, 0.232D0, 0.007764D0, 1.0D0, 1.16639D-5,
293 & 0D0, 0D0, 0D0, 0D0, 0D0,
294 1 0.20D0, 0.25D0, 1.0D0, 4.0D0, 10D0, 0D0, 0D0, 0D0, 0D0, 0D0,
295 2 -0.693D0, -1.0D0, 0.387D0, 1.0D0, -0.08D0,
296 2 -1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,
297 3 1.0D0,-1.0D0, 1.0D0,-1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
298 4 5.0D0, 1.0D0, 1.0D0, 0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0,
299 5 1.0D0, 0D0, 0D0, 0D0, 1000D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0,0D0,
300 6 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
301 7 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
302 8 1.0D0, 1.0D0, 1.0D0, 0.0D0, 0.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
303 9 0D0, 0D0, 0D0, 0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0/
304 DATA MSTJ/
305 & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
306 1 4, 2, 0, 1, 0, 2, 2, 0, 0, 0,
307 2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0,
308 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
309 4 2, 2, 4, 2, 5, 3, 3, 0, 0, 3,
310 5 0, 3, 0, 2, 0, 0, 1, 0, 0, 0,
311 6 40*0,
312 & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2,
313 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
314 2 80*0/
315 DATA PARJ/
316 & 0.10D0, 0.30D0, 0.40D0, 0.05D0, 0.50D0,
317 & 0.50D0, 0.50D0, 0.6D0, 1.2D0, 0.6D0,
318 1 0.50D0,0.60D0,0.75D0, 0D0, 0D0, 0D0, 0D0, 1.0D0, 1.0D0, 0D0,
319 2 0.36D0, 1.0D0,0.01D0, 2.0D0,1.0D0,0.4D0, 0D0, 0D0, 0D0, 0D0,
320 3 0.10D0, 1.0D0, 0.8D0, 1.5D0,0D0,2.0D0,0.2D0, 0D0,0.08D0,0D0,
321 4 0.3D0, 0.58D0, 0.5D0, 0.9D0,0.5D0,1.0D0,1.0D0,1.0D0,0D0,0D0,
322 5 0.77D0, 0.77D0, 0.77D0, -0.05D0, -0.005D0,
323 5 -0.00001D0, -0.00001D0, -0.00001D0, 1.0D0, 0D0,
324 6 4.5D0, 0.7D0, 0D0,0.003D0, 0.5D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
325 7 10D0, 1000D0, 100D0, 1000D0, 0D0, 0.7D0,10D0, 0D0, 0D0, 0D0,
326 8 0.29D0, 1.0D0, 1.0D0, 0D0, 10D0, 10D0, 0D0, 0D0, 0D0,1D-4,
327 9 0.02D0, 1.0D0, 0.2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
328 & 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
329 1 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
330 2 1.0D0, 0.25D0,91.187D0,2.489D0, 0.01D0,
331 2 2.0D0, 1.0D0, 0.25D0,0.002D0, 0D0,
332 3 0D0, 0D0, 0D0, 0D0, 0.01D0, 0.99D0, 0D0, 0D0, 0.2D0, 0D0,
333 4 10*0D0,
334 5 10*0D0,
335 6 10*0D0,
336 7 0D0, 200D0, 200D0, .333D0, .05D0, 0D0, 0D0, 0D0, 0D0, -0.693D0,
337 8 -1.0D0, 0.387D0, 1.0D0, -0.08D0, -1.0D0,
338 8 1.0D0, 1.0D0, -0.693D0, -1.0D0, 0.387D0,
339 9 1.0D0, -0.08D0, -1.0D0, 1.0D0, 1.0D0,
340 9 5*0D0/
341
342C...PYDAT2, with particle data and flavour treatment parameters.
343 DATA (KCHG(I,1),I= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
344 &-3,0,-3,6*0,3,9*0,3,2*0,3,0,-1,12*0,3,2*0,3,5*0,2*6,3,20*0,2,-1,
345 &20*0,4*3,8*0,3*3,4*0,3*3,3*0,3*3,7*0,3*3,3*0,3*3,3*0,-2,-3,2*1,
346 &3*0,4,3*3,6,2*-2,2*-3,0,2*1,2*0,2*3,-2,2*-3,2*0,-3,2*1,2*0,3,0,
347 &2*4,2*3,2*6,3,2*1,2*0,2*3,2*0,4,2*3,2*6,2*3,6,2*-2,2*-3,0,-3,0,
348 &2*1,2*0,2*3,0,3,2*-2,2*-3,2*0,2*-3,0,2*1,2*0,2*3,2*0,2*3,-2,2*-3,
349 &2*0,2*-3,2*0,-3,2*0,2*3,4*0,2*3,2*0,2*3,2*0,2*3,4*0,2*3,2*0,2*3,
350 &3*0,3,2*0,3,0,3,0,3,2*0,3,0,3,3*0,-1,2,-1,2,-1,2,-3,0,-3,0,-3,
351 &4*0,3,2*0,3,0,-1,2,-1,2,-1,2,-3,0,-3,0,-3,0,-1,2,-3,164*0/
352 DATA (KCHG(I,2),I= 1, 500)/8*1,12*0,2,16*0,2,1,113*0,-1,0,2*-1,
353 &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,
354 &-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,
355 &6*1,6*0,2*1,165*0/
356 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,
357 &11*0,1,2*0,1,5*0,6*1,15*0,1,0,2*1,20*0,4*1,5*0,6*1,4*0,9*1,4*0,
358 &12*1,3*0,102*1,2*0,2*1,2*0,4*1,2*0,6*1,2*0,8*1,3*0,1,0,2*1,0,3*1,
359 &0,4*1,3*0,12*1,3*0,1,2*0,1,0,16*1,163*0/
360 DATA (KCHG(I,4),I= 1, 293)/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,
361 &16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,
362 &37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,
363 &58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,
364 &79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,
365 &100,110,111,113,115,130,210,211,213,215,220,221,223,225,310,311,
366 &313,315,321,323,325,330,331,333,335,411,413,415,421,423,425,431,
367 &433,435,440,441,443,445,511,513,515,521,523,525,531,533,535,541,
368 &543,545,551,553,555,1103,1114,2101,2103,2110,2112,2114,2203,2210,
369 &2212,2214,2224,3101,3103,3112,3114,3122,3201,3203,3212,3214,3222,
370 &3224,3303,3312,3314,3322,3324,3334,4101,4103,4112,4114,4122,4132,
371 &4201,4203,4212,4214,4222,4224,4232,4301,4303,4312,4314,4322,4324,
372 &4332,4334,4403,4412,4414,4422,4424,4432,4434,4444,5101,5103,5112,
373 &5114,5122,5132,5142,5201,5203,5212,5214,5222,5224,5232,5242,5301,
374 &5303,5312,5314,5322,5324,5332,5334,5342,5401,5403,5412,5414,5422,
375 &5424,5432,5434,5442,5444,5503,5512,5514,5522,5524,5532,5534,5542,
376 &5544,5554,10111,10113,10211,10213,10221,10223,10311,10313,10321,
377 &10323,10331,10333,10411,10413,10421,10423,10431,10433,10441,
378 &10443,10511,10513,10521,10523,10531,10533,10541,10543,10551,
379 &10553,20113,20213,20223,20313,20323,20333,20413,20423,20433/
380 DATA (KCHG(I,4),I= 294, 500)/20443,20513,20523,20533,20543,20553,
381 &100443,100553,1000001,1000002,1000003,1000004,1000005,1000006,
382 &1000011,1000012,1000013,1000014,1000015,1000016,1000021,1000022,
383 &1000023,1000024,1000025,1000035,1000037,1000039,2000001,2000002,
384 &2000003,2000004,2000005,2000006,2000011,2000012,2000013,2000014,
385 &2000015,2000016,4000001,4000002,4000011,4000012,163*0/
386 DATA (PMAS(I,1),I= 1, 211)/0.33D0,0.33D0,0.50D0,1.50D0,
387 &4.80D0,175D0,2*400D0,2*0D0,0.00051D0,0D0,0.10566D0,0D0,1.777D0,
388 &0D0,400D0,5*0D0,91.187D0,80.33D0,80D0,6*0D0,500D0,900D0,500D0,
389 &3*300D0,350D0,200D0,5000D0,10*0D0,3*110D0,3*210D0,4*0D0,2*200D0,
390 &4*750D0,16*0D0,1D0,2D0,5D0,16*0D0,0.13498D0,0.7685D0,1.318D0,
391 &0.49767D0,0D0,0.13957D0,0.7669D0,1.318D0,0D0,0.54745D0,0.78194D0,
392 &1.275D0,2*0.49767D0,0.8961D0,1.432D0,0.4936D0,0.8916D0,1.425D0,
393 &0D0,0.95777D0,1.0194D0,1.525D0,1.8693D0,2.01D0,2.46D0,1.8645D0,
394 &2.0067D0,2.46D0,1.9685D0,2.1124D0,2.5735D0,0D0,2.9798D0,
395 &3.09688D0,3.5562D0,5.2792D0,5.3248D0,5.83D0,5.2789D0,5.3248D0,
396 &5.83D0,5.3693D0,5.4163D0,6.07D0,6.594D0,6.602D0,7.35D0,9.4D0,
397 &9.4603D0,9.9132D0,0.77133D0,1.234D0,0.57933D0,0.77133D0,0D0,
398 &0.93957D0,1.233D0,0.77133D0,0D0,0.93827D0,1.232D0,1.231D0,
399 &0.80473D0,0.92953D0,1.19744D0,1.3872D0,1.11568D0,0.80473D0,
400 &0.92953D0,1.19255D0,1.3837D0,1.18937D0,1.3828D0,1.09361D0,
401 &1.3213D0,1.535D0,1.3149D0,1.5318D0,1.67245D0,1.96908D0,2.00808D0,
402 &2.4521D0,2.5D0,2.2849D0,2.4703D0,1.96908D0,2.00808D0,2.4535D0,
403 &2.5D0,2.4529D0,2.5D0,2.4656D0,2.15432D0,2.17967D0,2.55D0,2.63D0,
404 &2.55D0,2.63D0,2.704D0,2.8D0,3.27531D0,3.59798D0,3.65648D0,
405 &3.59798D0,3.65648D0,3.78663D0,3.82466D0,4.91594D0,5.38897D0/
406 DATA (PMAS(I,1),I= 212, 500)/5.40145D0,5.8D0,5.81D0,5.641D0,
407 &5.84D0,7.00575D0,5.38897D0,5.40145D0,5.8D0,5.81D0,5.8D0,5.81D0,
408 &5.84D0,7.00575D0,5.56725D0,5.57536D0,5.96D0,5.97D0,5.96D0,5.97D0,
409 &6.12D0,6.13D0,7.19099D0,6.67143D0,6.67397D0,7.03724D0,7.0485D0,
410 &7.03724D0,7.0485D0,7.21101D0,7.219D0,8.30945D0,8.31325D0,
411 &10.07354D0,10.42272D0,10.44144D0,10.42272D0,10.44144D0,
412 &10.60209D0,10.61426D0,11.70767D0,11.71147D0,15.11061D0,0.9835D0,
413 &1.231D0,0.9835D0,1.231D0,1D0,1.17D0,1.429D0,1.29D0,1.429D0,
414 &1.29D0,2*1.4D0,2.272D0,2.424D0,2.272D0,2.424D0,2.5D0,2.536D0,
415 &3.4151D0,3.46D0,5.68D0,5.73D0,5.68D0,5.73D0,5.92D0,5.97D0,7.25D0,
416 &7.3D0,9.8598D0,9.875D0,2*1.23D0,1.282D0,2*1.402D0,1.427D0,
417 &2*2.372D0,2.56D0,3.5106D0,2*5.78D0,6.02D0,7.3D0,9.8919D0,3.686D0,
418 &10.0233D0,32*500D0,4*400D0,163*0D0/
419 DATA (PMAS(I,2),I= 1, 500)/5*0D0,1.39883D0,16*0D0,2.48009D0,
420 &2.07002D0,0.00237D0,6*0D0,14.54848D0,0D0,16.6708D0,8.42842D0,
421 &4.92026D0,5.75967D0,0.10158D0,0.39162D0,417.4648D0,10*0D0,
422 &0.04104D0,0.0105D0,0.02807D0,0.82101D0,0.64973D0,0.1575D0,4*0D0,
423 &0.88161D0,0.88001D0,19.33905D0,39*0D0,0.151D0,0.107D0,3*0D0,
424 &0.149D0,0.107D0,2*0D0,0.00843D0,0.185D0,2*0D0,0.0505D0,0.109D0,
425 &0D0,0.0498D0,0.098D0,0D0,0.0002D0,0.00443D0,0.076D0,2*0D0,
426 &0.023D0,2*0D0,0.023D0,2*0D0,0.015D0,0D0,0.0013D0,0D0,0.002D0,
427 &2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,4*0D0,0.12D0,
428 &4*0D0,0.12D0,3*0D0,2*0.12D0,3*0D0,0.0394D0,4*0D0,0.036D0,0D0,
429 &0.0358D0,2*0D0,0.0099D0,0D0,0.0091D0,74*0D0,0.06D0,0.142D0,
430 &0.06D0,0.142D0,0D0,0.36D0,0.287D0,0.09D0,0.287D0,0.09D0,0.25D0,
431 &0.08D0,0.05D0,0.02D0,0.05D0,0.02D0,0.05D0,0D0,0.014D0,0.01D0,
432 &8*0.05D0,0D0,0.01D0,2*0.4D0,0.025D0,2*0.174D0,0.053D0,3*0.05D0,
433 &0.0009D0,4*0.05D0,3*0D0,19*1D0,0D0,7*1D0,0D0,1D0,0D0,1D0,0D0,
434 &2.65171D0,2.65499D0,0.42901D0,0.41917D0,163*0D0/
435 DATA (PMAS(I,3),I= 1, 500)/5*0D0,13.98835D0,16*0D0,24.8009D0,
436 &20.70015D0,0.02369D0,6*0D0,145.48484D0,0D0,166.70801D0,
437 &84.28416D0,49.20256D0,57.59671D0,1.0158D0,3.91624D0,4174.64797D0,
438 &10*0D0,0.41042D0,0.10504D0,0.28068D0,8.21005D0,6.49728D0,
439 &1.57496D0,4*0D0,8.81606D0,8.80013D0,193.39048D0,39*0D0,0.4D0,
440 &0.25D0,3*0D0,0.4D0,0.25D0,2*0D0,0.1D0,0.17D0,2*0D0,0.2D0,0.12D0,
441 &0D0,0.2D0,0.12D0,0D0,0.002D0,0.015D0,0.2D0,2*0D0,0.12D0,2*0D0,
442 &0.12D0,2*0D0,0.05D0,0D0,0.005D0,0D0,0.01D0,2*0D0,0.05D0,2*0D0,
443 &0.05D0,2*0D0,0.05D0,2*0D0,0.05D0,4*0D0,0.14D0,4*0D0,0.14D0,3*0D0,
444 &2*0.14D0,3*0D0,0.04D0,4*0D0,0.035D0,0D0,0.035D0,2*0D0,0.05D0,0D0,
445 &0.05D0,74*0D0,0.05D0,0.25D0,0.05D0,0.25D0,0D0,0.2D0,0.4D0,
446 &0.005D0,0.4D0,0.01D0,0.35D0,0.001D0,0.1D0,0.08D0,0.1D0,0.08D0,
447 &0.1D0,0D0,0.05D0,0.02D0,6*0.1D0,0.05D0,0.1D0,0D0,0.02D0,2*0.3D0,
448 &0.05D0,2*0.3D0,0.02D0,2*0.1D0,0.03D0,0.001D0,4*0.1D0,3*0D0,
449 &19*10D0,0.00001D0,7*10D0,0.00001D0,10D0,0.00001D0,10D0,0.00001D0,
450 &26.51715D0,26.54994D0,4.29011D0,4.19173D0,163*0D0/
451 DATA (PMAS(I,4),I= 1, 500)/12*0D0,658654D0,0D0,0.0872D0,68*0D0,
452 &0.1D0,0.387D0,16*0D0,0.00003D0,2*0D0,15500D0,0D0,7804.5D0,6*0D0,
453 &26.762D0,3*0D0,3709D0,6*0D0,0.317D0,2*0D0,0.1244D0,2*0D0,0.14D0,
454 &6*0D0,0.468D0,2*0D0,0.462D0,2*0D0,0.483D0,2*0D0,0.15D0,19*0D0,
455 &44.34D0,0D0,78.88D0,4*0D0,23.96D0,2*0D0,49.1D0,0D0,87.1D0,0D0,
456 &24.6D0,4*0D0,0.0618D0,0.029D0,6*0D0,0.106D0,6*0D0,0.019D0,2*0D0,
457 &7*0.1D0,4*0D0,0.342D0,2*0.387D0,6*0D0,2*0.387D0,6*0D0,0.387D0,
458 &0D0,0.387D0,2*0D0,8*0.387D0,0D0,9*0.387D0,83*0D0,163*0D0/
459 DATA PARF/
460 & 0.5D0,0.25D0, 0.5D0,0.25D0, 1D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
461 1 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
462 2 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
463 3 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
464 4 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
465 5 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
466 6 0.75D0, 0.5D0, 0D0,0.1667D0,0.0833D0,0.1667D0,0D0,0D0,0D0, 0D0,
467 7 0D0, 0D0, 1D0,0.3333D0,0.6667D0,0.3333D0,0D0,0D0,0D0, 0D0,
468 8 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
469 9 0.0099D0, 0.0056D0, 0.199D0, 1.35D0, 4.5D0, 5*0D0,
470 & 0.325D0,0.325D0,0.5D0,1.6D0, 5.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
471 1 0D0,0.11D0,0.16D0,0.048D0,0.50D0,0.45D0,0.55D0,0.60D0,0D0,0D0,
472 2 0.2D0, 0.1D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
473 3 60*0D0,
474 4 0.2D0, 0.5D0, 8*0D0,
475 5 1800*0D0/
476 DATA ((VCKM(I,J),J=1,4),I=1,4)/
477 & 0.95113D0, 0.04884D0, 0.00003D0, 0.00000D0,
478 & 0.04884D0, 0.94940D0, 0.00176D0, 0.00000D0,
479 & 0.00003D0, 0.00176D0, 0.99821D0, 0.00000D0,
480 & 0.00000D0, 0.00000D0, 0.00000D0, 1.00000D0/
481
482C...PYDAT3, with particle decay parameters and data.
483 DATA (MDCY(I,1),I= 1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,
484 &7*1,10*0,6*1,4*0,3*1,19*0,3*1,16*0,3*1,3*0,2*1,0,7*1,0,2*1,0,
485 &12*1,0,18*1,0,1,4*0,1,3*0,2*1,2*0,3*1,2*0,4*1,0,5*1,2*0,4*1,2*0,
486 &5*1,2*0,6*1,0,7*1,2*0,5*1,2*0,6*1,2*0,7*1,2*0,8*1,0,75*1,0,7*1,0,
487 &1,0,1,0,4*1,163*0/
488 DATA (MDCY(I,2),I= 1, 500)/1,9,17,25,33,41,56,66,2*0,76,80,82,
489 &87,89,143,145,150,2*0,153,162,174,190,210,6*0,289,0,311,334,416,
490 &496,523,526,527,10*0,536,544,550,558,582,608,4*0,632,639,646,
491 &19*0,658,659,663,16*0,672,674,679,688,0,697,699,701,0,708,716,
492 &722,731,733,735,738,748,754,757,0,768,774,785,791,854,857,865,
493 &926,928,936,969,971,0,975,976,979,981,1017,1018,1026,1062,1063,
494 &1071,1110,1111,1115,1146,1147,1151,1152,1161,0,1163,4*0,1164,3*0,
495 &1167,1170,2*0,1171,1173,1176,2*0,1180,1181,1184,1187,0,1190,1195,
496 &1197,1200,1202,2*0,1206,1207,1208,1284,2*0,1288,1289,1290,1291,
497 &1292,2*0,1296,1297,1299,1300,1302,1306,0,1307,1311,1315,1319,
498 &1323,1327,1331,2*0,1335,1336,1337,1354,1363,2*0,1372,1373,1374,
499 &1375,1376,1385,2*0,1394,1395,1396,1397,1398,1407,1408,2*0,1417,
500 &1426,1435,1444,1453,1462,1471,1480,0,1489,1498,1507,1516,1525,
501 &1534,1543,1552,1561,1570,1571,1572,1573,1574,1579,1582,1584,1589,
502 &1591,1596,1603,1607,1609,1611,1613,1615,1617,1619,1621,1622,1624,
503 &1626,1628,1630,1632,1634,1636,1638,1640,1641,1643,1645,1659,1661,
504 &1663,1667,1669,1671,1673,1675,1677,1679,1681,1683,1685,1696,1710,
505 &1722,1734,1746,1758,1770,1785,1796,1807,1818,1829,1840,1851,1912,
506 &1919,2021,2077,2195,2329,0,2400,2416,2432,2448,2464,2480,2496,0,
507 &2511,0,2526,0,2541,2545,2549,2552,163*0/
508 DATA (MDCY(I,3),I= 1, 500)/5*8,15,2*10,2*0,4,2,5,2,54,2,5,3,
509 &2*0,9,12,16,20,79,6*0,22,0,23,82,80,27,3,1,9,10*0,8,6,8,24,26,24,
510 &4*0,2*7,12,19*0,1,4,9,16*0,2,5,2*9,0,2*2,7,0,8,6,9,2*2,3,10,6,3,
511 &11,0,6,11,6,63,3,8,61,2,8,33,2,4,0,1,3,2,36,1,8,36,1,8,39,1,4,31,
512 &1,4,1,9,2,0,1,4*0,3,3*0,3,1,2*0,2,3,4,2*0,1,3*3,0,5,2,3,2,4,2*0,
513 &2*1,76,4,2*0,4*1,4,2*0,1,2,1,2,4,1,0,7*4,2*0,2*1,17,2*9,2*0,4*1,
514 &2*9,2*0,4*1,9,1,9,2*0,8*9,0,9*9,4*1,5,3,2,5,2,5,7,4,7*2,1,9*2,1,
515 &2*2,14,2*2,4,9*2,11,14,5*12,15,6*11,61,7,102,56,118,134,71,0,
516 &6*16,15,0,15,0,15,0,2*4,3,2,163*0/
517 DATA (MDME(I,1),I= 1,4000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
518 &7*1,-1,1,7*-1,8*1,2*-1,8*1,2*-1,73*1,-1,2*1,-1,5*1,0,2*-1,6*1,0,
519 &2*-1, 3*1,-1,6*1,2*-1,6*1,2*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,-1,6*1,
520 &2*-1,3*1,-1,5*1,62*1,6*1,2*-1,6*1,8*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,
521 &4*-1,6*1,2*-1,3*1,-1,8*1,62*1,6*1,2*-1,3*1,-1,6*1,62*1,3*1,-1,
522 &3*1,-1,1,18*1,8*1,2*-1,2*1,-1,36*1,2*-1,6*1,2*-1,9*1,-1,3*1,-1,
523 &3*1,5*-1,3*1,-1,14*1,2*-1,6*1,2*-1,1151*1,2*-1,132*1,2*-1,635*1,
524 &1447*0/
525 DATA (MDME(I,2),I= 1,4000)/43*102,4*0,102,0,6*53,3*102,4*0,102,
526 &2*0,3*102,4*0,102,2*0,6*102,42,6*102,2*42,2*0,8*41,2*0,36*41,
527 &8*102,0,102,0,102,2*0,21*102,8*32,8*0,16*32,4*0,8*32,9*0,62*53,
528 &8*32,14*0,16*32,7*0,8*32,12*0,62*53,8*32,10*0,62*53,4*32,5*0,
529 &18*53,3*32,0,6*32,3*0,4*32,3*0,4*32,3*0,4*32,3*0,32,8*0,8*32,
530 &14*0,16*32,12*0,8*32,22*0,9*32,3*0,12,2*42,2*11,9*42,0,2,3,15*0,
531 &4*42,5*0,3,12*0,2,3*0,1,0,3,16*0,2*3,15*0,2*42,2*3,18*0,2*3,3*0,
532 &1,11*0,22*42,41*0,2*3,9*0,16*42,45*0,3,10*0,10*42,20*0,2*13,6*0,
533 &12,2*0,12,0,12,14*42,16*0,48,3*13,2*42,9*0,14*42,16*0,48,3*13,
534 &2*42,9*0,14*42,19*0,48,3*13,2*42,6*0,2*11,28*42,5*0,32,3*0,4*32,
535 &2*4,0,32,45*0,14*42,52*0,10*13,2*42,2*11,4*0,2*42,2*11,6*0,2*42,
536 &2*11,0,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,
537 &2*11,2*42,2*11,2*0,3*42,8*0,48,3*13,20*42,4*0,18*42,4*0,9*42,0,
538 &162*42,50*0,2*12,17*0,2*32,33*0,12,9*0,32,2*0,12,11*0,4*32,2*4,
539 &5*0,832*53,1459*0/
540 DATA (BRAT(I) ,I= 1, 348)/43*0D0,0.00003D0,0.001765D0,
541 &0.998205D0,35*0D0,1D0,6*0D0,0.1783D0,0.1735D0,0.1131D0,0.2494D0,
542 &0.003D0,0.09D0,0.0027D0,0.01D0,0.0014D0,0.0012D0,2*0.00025D0,
543 &0.0071D0,0.012D0,0.0004D0,0.00075D0,0.00006D0,2*0.00078D0,
544 &0.0034D0,0.08D0,0.011D0,0.0191D0,0.00006D0,0.005D0,0.0133D0,
545 &0.0067D0,0.0005D0,0.0035D0,0.0006D0,0.0015D0,0.00021D0,0.0002D0,
546 &0.00075D0,0.0001D0,0.0002D0,0.0011D0,3*0.0002D0,0.00022D0,
547 &0.0004D0,0.0001D0,2*0.00205D0,2*0.00069D0,0.00025D0,0.00051D0,
548 &0.00025D0,35*0D0,0.154075D0,0.119483D0,0.154072D0,0.119346D0,
549 &0.152196D0,3*0D0,0.033549D0,0.066752D0,0.033549D0,0.066752D0,
550 &0.033473D0,0.066752D0,2*0D0,0.321502D0,0.016502D0,2*0D0,
551 &0.016509D0,0.320778D0,2*0D0,0.00001D0,0.000591D0,6*0D0,
552 &2*0.108062D0,0.107983D0,0D0,0.000001D0,0D0,0.000327D0,0.053489D0,
553 &0.852249D0,4*0D0,0.000244D0,0.06883D0,0D0,0.023981D0,0.000879D0,
554 &65*0D0,0.145869D0,0.113303D0,0.145869D0,0.113298D0,0.14581D0,
555 &0.049013D0,2*0D0,0.032007D0,0.063606D0,0.032007D0,0.063606D0,
556 &0.032004D0,0.063606D0,8*0D0,0.251276D0,0.012903D0,0.000006D0,0D0,
557 &0.012903D0,0.250816D0,0.00038D0,0D0,0.000008D0,0.000465D0,
558 &0.215459D0,5*0D0,2*0.085262D0,0.08526D0,7*0D0,0.000046D0,
559 &0.000754D0,5*0D0,0.000074D0,0D0,0.000439D0,0.000015D0,0.000061D0/
560 DATA (BRAT(I) ,I= 349, 642)/0.306171D0,0.68864D0,0D0,0.003799D0,
561 &66*0D0,0.000079D0,0.001292D0,5*0D0,0.000126D0,0D0,0.002256D0,
562 &0.00001D0,0.000002D0,2*0D0,0.996233D0,63*0D0,0.000013D0,
563 &0.067484D0,2*0D0,0.00001D0,0.002701D0,0D0,0.929792D0,18*0D0,
564 &0.452899D0,0D0,0.547101D0,1D0,2*0.215134D0,0.215133D0,0.214738D0,
565 &2*0D0,2*0.06993D0,0D0,0.000225D0,0.036777D0,0.596654D0,2*0D0,
566 &0.000177D0,0.050055D0,0.316112D0,0.041762D0,0.90916D0,2*0D0,
567 &0.000173D0,0.048905D0,0.000328D0,0.053776D0,0.872444D0,2*0D0,
568 &0.000259D0,0.073192D0,0D0,0.153373D0,2*0.342801D0,0D0,0.086867D0,
569 &0.03128D0,0.001598D0,0.000768D0,0.004789D0,0.006911D0,0.004789D0,
570 &0.006911D0,0.004789D0,3*0D0,0.003077D0,0.00103D0,0.003077D0,
571 &0.00103D0,0.003077D0,0.00103D0,2*0D0,0.138845D0,0.474102D0,
572 &0.176299D0,0D0,0.109767D0,0.008161D0,0.028584D0,0.001468D0,2*0D0,
573 &0.001468D0,0.02853D0,0.000007D0,0D0,0.000001D0,0.000053D0,
574 &0.003735D0,5*0D0,2*0.009661D0,0.00966D0,0D0,0.163019D0,
575 &0.004003D0,0.45294D0,0.008334D0,2*0.038042D0,0.001999D0,0D0,
576 &0.017733D0,0.045908D0,0.017733D0,0.045908D0,0.017733D0,3*0D0,
577 &0.038354D0,0.011181D0,0.038354D0,0.011181D0,0.038354D0,
578 &0.011181D0,2*0D0,0.090264D0,2*0.001805D0,0.090264D0,0.001805D0,
579 &0.81225D0,0.001806D0,0.090428D0,0.001809D0,0.001808D0,0.090428D0/
580 DATA (BRAT(I) ,I= 643, 803)/0.001808D0,0.81372D0,0D0,0.325914D0,
581 &0.016735D0,0.000009D0,0.016736D0,0.32532D0,0.000554D0,0.00001D0,
582 &0.000603D0,0.314118D0,3*0D0,1D0,2*0.08D0,0.76D0,0.08D0,2*0.105D0,
583 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,0.988D0,
584 &0.012D0,0.998739D0,0.00079D0,0.00038D0,0.000046D0,0.000045D0,
585 &2*0.34725D0,0.144D0,0.104D0,0.0245D0,2*0.01225D0,0.0028D0,
586 &0.0057D0,0.2112D0,0.1256D0,2*0.1939D0,2*0.1359D0,0.002D0,0.001D0,
587 &0.0006D0,0.999877D0,0.000123D0,0.99955D0,0.00045D0,2*0.34725D0,
588 &0.144D0,0.104D0,0.049D0,0.0028D0,0.0057D0,0.3923D0,0.321D0,
589 &0.2317D0,0.0478D0,0.0049D0,0.0013D0,0.0003D0,0.0007D0,0.89D0,
590 &0.08693D0,0.0221D0,0.00083D0,2*0.00007D0,0.564D0,0.282D0,0.072D0,
591 &0.028D0,0.023D0,2*0.0115D0,0.005D0,0.003D0,0.6861D0,0.3139D0,
592 &2*0.5D0,0.665D0,0.333D0,0.002D0,0.333D0,0.166D0,0.168D0,0.084D0,
593 &0.087D0,0.043D0,0.059D0,2*0.029D0,0.002D0,0.6352D0,0.2116D0,
594 &0.0559D0,0.0173D0,0.0482D0,0.0318D0,0.666D0,0.333D0,0.001D0,
595 &0.332D0,0.166D0,0.168D0,0.084D0,0.086D0,0.043D0,0.059D0,
596 &2*0.029D0,2*0.002D0,0.437D0,0.208D0,0.302D0,0.0302D0,0.0212D0,
597 &0.0016D0,0.48947D0,0.34D0,3*0.043D0,0.027D0,0.0126D0,0.0013D0,
598 &0.0003D0,0.00025D0,0.00008D0,0.444D0,2*0.222D0,0.104D0,2*0.004D0,
599 &0.07D0,0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,0.07D0,0.065D0/
600 DATA (BRAT(I) ,I= 804, 977)/2*0.005D0,2*0.011D0,5*0.001D0,
601 &0.026D0,0.019D0,0.066D0,0.041D0,0.045D0,0.076D0,0.0073D0,
602 &2*0.0047D0,0.026D0,0.001D0,0.0006D0,0.0066D0,0.005D0,2*0.003D0,
603 &2*0.0006D0,2*0.001D0,0.006D0,0.005D0,0.012D0,0.0057D0,0.067D0,
604 &0.008D0,0.0022D0,0.027D0,0.004D0,0.019D0,0.012D0,0.002D0,0.009D0,
605 &0.0218D0,0.001D0,0.022D0,0.087D0,0.001D0,0.0019D0,0.0015D0,
606 &0.0028D0,0.683D0,0.306D0,0.011D0,0.3D0,0.15D0,0.16D0,0.08D0,
607 &0.13D0,0.06D0,0.08D0,0.04D0,0.034D0,0.027D0,2*0.002D0,2*0.004D0,
608 &2*0.002D0,0.034D0,0.027D0,2*0.002D0,2*0.004D0,2*0.002D0,0.0365D0,
609 &0.045D0,0.073D0,0.062D0,3*0.021D0,0.0061D0,0.015D0,0.025D0,
610 &0.0088D0,0.074D0,0.0109D0,0.0041D0,0.002D0,0.0035D0,0.0011D0,
611 &0.001D0,0.0027D0,2*0.0016D0,0.0018D0,0.011D0,0.0063D0,0.0052D0,
612 &0.018D0,0.016D0,0.0034D0,0.0036D0,0.0009D0,0.0006D0,0.015D0,
613 &0.0923D0,0.018D0,0.022D0,0.0077D0,0.009D0,0.0075D0,0.024D0,
614 &0.0085D0,0.067D0,0.0511D0,0.017D0,0.0004D0,0.0028D0,0.619D0,
615 &0.381D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,
616 &0.01D0,2*0.02D0,0.03D0,2*0.005D0,2*0.02D0,0.03D0,2*0.005D0,
617 &0.015D0,0.037D0,0.028D0,0.079D0,0.095D0,0.052D0,0.0078D0,
618 &4*0.001D0,0.028D0,0.033D0,0.026D0,0.05D0,0.01D0,4*0.005D0,0.25D0,
619 &0.0952D0,0.94D0,0.06D0,2*0.4D0,2*0.1D0,1D0,0.0602D0,0.0601D0/
620 DATA (BRAT(I) ,I= 978,1136)/0.8797D0,0.135D0,0.865D0,0.02D0,
621 &0.055D0,2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,2*0.005D0,
622 &0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,0.0055D0,0.0042D0,
623 &0.009D0,0.018D0,0.015D0,0.0185D0,0.0135D0,0.025D0,0.0004D0,
624 &0.0007D0,0.0008D0,0.0014D0,0.0019D0,0.0025D0,0.4291D0,0.08D0,
625 &0.07D0,0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0,0.16D0,0.08D0,
626 &0.13D0,0.06D0,0.08D0,0.04D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
627 &0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,
628 &0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,
629 &0.0185D0,0.0135D0,0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,
630 &0.0019D0,0.0025D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,
631 &1D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,
632 &0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,
633 &2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,
634 &0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,0.0135D0,
635 &0.025D0,2*0.0002D0,0.0007D0,2*0.0004D0,0.0014D0,0.001D0,0.0009D0,
636 &0.0025D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,1D0,
637 &2*0.3D0,2*0.2D0,0.047D0,0.122D0,0.006D0,0.012D0,0.035D0,0.012D0,
638 &0.035D0,0.003D0,0.007D0,0.15D0,0.037D0,0.008D0,0.002D0,0.05D0,
639 &0.015D0,0.003D0,0.001D0,0.014D0,0.042D0,0.014D0,0.042D0,0.24D0/
640 DATA (BRAT(I) ,I=1137,1341)/0.065D0,0.012D0,0.003D0,0.001D0,
641 &0.002D0,0.001D0,0.002D0,0.014D0,0.003D0,1D0,2*0.3D0,2*0.2D0,1D0,
642 &0.0252D0,0.0248D0,0.0267D0,0.015D0,0.045D0,0.015D0,0.045D0,
643 &0.7743D0,0.029D0,0.22D0,0.78D0,1D0,0.331D0,0.663D0,0.006D0,
644 &0.663D0,0.331D0,0.006D0,1D0,0.999D0,0.001D0,0.88D0,2*0.06D0,
645 &0.639D0,0.358D0,0.002D0,0.001D0,1D0,0.88D0,2*0.06D0,0.516D0,
646 &0.483D0,0.001D0,0.88D0,2*0.06D0,0.9988D0,0.0001D0,0.0006D0,
647 &0.0004D0,0.0001D0,0.667D0,0.333D0,0.9954D0,0.0011D0,0.0035D0,
648 &0.333D0,0.667D0,0.676D0,0.234D0,0.085D0,0.005D0,2*1D0,0.018D0,
649 &2*0.005D0,0.003D0,0.002D0,2*0.006D0,0.018D0,2*0.005D0,0.003D0,
650 &0.002D0,2*0.006D0,0.0066D0,0.025D0,0.016D0,0.0088D0,2*0.005D0,
651 &0.0058D0,0.005D0,0.0055D0,4*0.004D0,2*0.002D0,2*0.004D0,0.003D0,
652 &0.002D0,2*0.003D0,3*0.002D0,2*0.001D0,0.002D0,2*0.001D0,
653 &2*0.002D0,0.0013D0,0.0018D0,5*0.001D0,4*0.003D0,2*0.005D0,
654 &2*0.002D0,2*0.001D0,2*0.002D0,2*0.001D0,0.2432D0,0.057D0,
655 &2*0.035D0,0.15D0,2*0.075D0,0.03D0,2*0.015D0,2*0.08D0,0.76D0,
656 &0.08D0,4*1D0,2*0.08D0,0.76D0,0.08D0,1D0,2*0.5D0,1D0,2*0.5D0,
657 &2*0.08D0,0.76D0,0.08D0,1D0,2*0.08D0,0.76D0,3*0.08D0,0.76D0,
658 &3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,
659 &3*0.08D0,0.76D0,0.08D0,2*1D0,2*0.105D0,0.04D0,0.0077D0,0.02D0/
660 DATA (BRAT(I) ,I=1342,1522)/0.0235D0,0.0285D0,0.0435D0,0.0011D0,
661 &0.0022D0,0.0044D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,
662 &2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,
663 &2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,
664 &4*1D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,
665 &0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,
666 &0.005D0,4*1D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
667 &0.015D0,0.005D0,1D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
668 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
669 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
670 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
671 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
672 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
673 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
674 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
675 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
676 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
677 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
678 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
679 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0/
680 DATA (BRAT(I) ,I=1523,2548)/0.015D0,0.005D0,2*0.105D0,0.04D0,
681 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
682 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
683 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
684 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
685 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,0.52D0,0.26D0,
686 &0.11D0,2*0.055D0,0.333D0,0.334D0,0.333D0,0.667D0,0.333D0,0.28D0,
687 &0.14D0,0.313D0,0.157D0,0.11D0,0.667D0,0.333D0,0.28D0,0.14D0,
688 &0.313D0,0.157D0,0.11D0,0.36D0,0.18D0,0.03D0,2*0.015D0,2*0.2D0,
689 &4*0.25D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,
690 &0.333D0,4*0.5D0,0.007D0,0.993D0,1D0,0.667D0,0.333D0,0.667D0,
691 &0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,8*0.5D0,0.02D0,0.98D0,
692 &1D0,4*0.5D0,3*0.146D0,3*0.05D0,0.15D0,2*0.05D0,4*0.024D0,0.066D0,
693 &0.667D0,0.333D0,0.667D0,0.333D0,4*0.25D0,0.667D0,0.333D0,0.667D0,
694 &0.333D0,2*0.5D0,0.273D0,0.727D0,0.667D0,0.333D0,0.667D0,0.333D0,
695 &4*0.5D0,0.35D0,0.65D0,2*0.0083D0,0.1866D0,0.324D0,0.184D0,
696 &0.027D0,0.001D0,0.093D0,0.087D0,0.078D0,0.0028D0,3*0.014D0,
697 &0.008D0,0.024D0,0.008D0,0.024D0,0.425D0,0.02D0,0.185D0,0.088D0,
698 &0.043D0,0.067D0,0.066D0,831*0D0,0.85422D0,0.005292D0,0.044039D0,
699 &0.096449D0,0.853165D0,0.021144D0,0.029361D0,0.096329D0/
700 DATA (BRAT(I) ,I=2549,4000)/0.294414D0,0.109437D0,0.596149D0,
701 &0.389861D0,0.610139D0,1447*0D0/
702 DATA (KFDP(I,1),I= 1, 374)/21,22,23,4*-24,25,21,22,23,4*24,25,
703 &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
704 &4*24,25,37,1000022,1000023,1000025,1000035,1000021,1000039,21,22,
705 &23,4*-24,25,2*-37,21,22,23,4*24,25,2*37,22,23,-24,25,23,24,-12,
706 &22,23,-24,25,23,24,-12,-14,48*16,22,23,-24,25,23,24,22,23,-24,25,
707 &-37,23,24,37,1,2,3,4,5,6,7,8,21,1,2,3,4,5,6,7,8,11,13,15,17,1,2,
708 &3,4,5,6,7,8,11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,-13,
709 &-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1000022,
710 &2*1000023,3*1000025,4*1000035,2*1000024,2*1000037,1000001,
711 &2000001,1000001,-1000001,1000002,2000002,1000002,-1000002,
712 &1000003,2000003,1000003,-1000003,1000004,2000004,1000004,
713 &-1000004,1000005,2000005,1000005,-1000005,1000006,2000006,
714 &1000006,-1000006,1000011,2000011,1000011,-1000011,1000012,
715 &2000012,1000012,-1000012,1000013,2000013,1000013,-1000013,
716 &1000014,2000014,1000014,-1000014,1000015,2000015,1000015,
717 &-1000015,1000016,2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,12,
718 &13,14,15,16,17,18,24,37,2*23,25,35,4*-1,4*-3,4*-5,4*-7,-11,-13,
719 &-15,-17,3*24,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,25,36,
720 &1000022,2*1000023,3*1000025,4*1000035,2*1000024,2*1000037,
721 &1000001,2000001,1000001,-1000001,1000002,2000002,1000002/
722 DATA (KFDP(I,1),I= 375, 587)/-1000002,1000003,2000003,1000003,
723 &-1000003,1000004,2000004,1000004,-1000004,1000005,2000005,
724 &1000005,-1000005,1000006,2000006,1000006,-1000006,1000011,
725 &2000011,1000011,-1000011,1000012,2000012,1000012,-1000012,
726 &1000013,2000013,1000013,-1000013,1000014,2000014,1000014,
727 &-1000014,1000015,2000015,1000015,-1000015,1000016,2000016,
728 &1000016,-1000016,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,
729 &1000022,2*1000023,3*1000025,4*1000035,2*1000024,2*1000037,
730 &1000001,2000001,1000001,-1000001,1000002,2000002,1000002,
731 &-1000002,1000003,2000003,1000003,-1000003,1000004,2000004,
732 &1000004,-1000004,1000005,2000005,1000005,-1000005,1000006,
733 &2000006,1000006,-1000006,1000011,2000011,1000011,-1000011,
734 &1000012,2000012,1000012,-1000012,1000013,2000013,1000013,
735 &-1000013,1000014,2000014,1000014,-1000014,1000015,2000015,
736 &1000015,-1000015,1000016,2000016,1000016,-1000016,-1,-3,-5,-7,
737 &-11,-13,-15,-17,24,2*1000022,2*1000023,2*1000025,2*1000035,
738 &1000006,2000006,1000006,2000006,-1000001,-1000003,-1000011,
739 &-1000013,-1000015,-2000015,5,6,21,2,1,2,3,4,5,6,11,13,15,3,4,5,6,
740 &11,13,15,21,2*4,24,-11,-13,-15,3,4,5,6,11,13,15,21,2*24,2*52,
741 &2*22,2*23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,2*24,3*52,24/
742 DATA (KFDP(I,1),I= 588, 979)/4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,
743 &22,23,22,23,24,52,24,52,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,
744 &3*-11,2*-13,-15,24,3*-11,2*-13,-15,63,3*-1,3*-3,3*-5,-11,-13,-15,
745 &82,-11,-13,2*2,-12,-14,-16,2*-2,2*-4,-2,-4,2*22,211,111,221,13,
746 &11,213,-213,221,223,321,130,310,111,331,111,211,-12,12,-14,14,
747 &211,111,22,-13,-11,2*211,213,113,221,223,321,211,331,22,111,211,
748 &2*22,211,22,111,211,22,211,221,111,11,211,111,2*211,321,130,310,
749 &221,111,211,111,130,310,321,2*311,321,311,323,313,323,313,321,
750 &3*311,-13,3*211,12,14,311,2*321,311,321,313,323,313,323,311,
751 &4*321,211,111,3*22,111,321,130,-213,113,213,211,22,111,11,13,211,
752 &321,130,310,221,211,111,11*-11,11*-13,-311,-313,-311,-313,-20313,
753 &2*-311,-313,-311,-313,2*111,2*221,2*331,2*113,2*223,2*333,-311,
754 &-313,2*-321,211,-311,-321,333,-311,-313,-321,211,2*-321,2*-311,
755 &-321,211,113,421,2*411,421,411,423,413,423,413,421,411,8*-11,
756 &8*-13,-321,-323,-321,-323,-311,2*-313,-311,-313,2*-311,-321,
757 &-10323,-321,-323,-321,-311,2*-313,211,111,333,3*-321,-311,-313,
758 &-321,-313,310,333,211,2*-321,-311,-313,-311,211,-321,3*-311,211,
759 &113,321,2*421,411,421,413,423,413,423,411,421,-15,5*-11,5*-13,
760 &221,331,333,221,331,333,10221,211,213,211,213,321,323,321,323,
761 &2212,221,331,333,221,2*2,2*431,421,411,423,413,82,11,13,82,443/
762 DATA (KFDP(I,1),I= 980,1419)/82,6*12,6*14,2*16,3*-411,3*-413,
763 &2*-411,2*-413,2*441,2*443,2*20443,2*2,2*4,2,4,511,521,511,523,
764 &513,523,513,521,511,6*12,6*14,2*16,3*-421,3*-423,2*-421,2*-423,
765 &2*441,2*443,2*20443,2*2,2*4,2,4,521,511,521,513,523,513,523,511,
766 &521,6*12,6*14,2*16,3*-431,3*-433,2*-431,2*-433,3*441,3*443,
767 &3*20443,2*2,2*4,2,4,531,521,511,523,513,16,2*4,2*12,2*14,2*16,
768 &4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,2*-1,541,511,521,513,
769 &523,21,11,13,15,1,2,3,4,21,22,553,21,2112,2212,2*2112,2212,2112,
770 &2*2212,2112,-12,3122,3212,3112,2212,2*2112,-12,2*3122,3222,3112,
771 &2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,3322,3312,
772 &2*3122,3212,3322,3312,3122,3322,3312,-12,2*4122,7*-11,7*-13,
773 &2*2224,2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,
774 &3324,2*2224,7*2212,5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,
775 &2*3222,2*3224,4*2,3,2*2,1,2*2,-11,-13,2*2,4*4122,-11,-13,2*2,
776 &3*4132,3*4232,-11,-13,2*2,4332,-11,-13,2*2,-11,-13,2*2,-11,-13,
777 &2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,2*5122,-12,
778 &-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
779 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,4*5122,-12,-14,-16,2*-2,
780 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,2*5132,2*5232,-12,-14,-16,
781 &2*-2,2*-4,-2,-4,5332,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16/
782 DATA (KFDP(I,1),I=1420,1739)/2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
783 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
784 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
785 &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
786 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
787 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
788 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
789 &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,221,223,221,
790 &223,211,111,321,130,310,213,113,-213,321,311,321,311,323,313,
791 &2*311,321,311,321,313,323,321,211,111,321,130,310,2*211,313,-313,
792 &323,-323,421,411,423,413,411,421,413,423,411,421,423,413,443,
793 &2*82,521,511,523,513,511,521,513,523,521,511,523,513,511,521,513,
794 &523,553,2*21,213,-213,113,213,10211,10111,-10211,2*221,213,2*113,
795 &-213,2*321,2*311,113,323,2*313,323,313,-313,323,-323,423,2*413,
796 &2*423,413,443,82,523,2*513,2*523,2*513,523,553,21,11,13,82,4*443,
797 &10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,10551,20553,555,
798 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
799 &1000002,2000002,1000002,2000002,1000021,1000039,1000024,1000037,
800 &1000022,1000023,1000025,1000035,1000001,2000001,1000001,2000001,
801 &1000021,1000039,-1000024,-1000037,1000022,1000023,1000025/
802 DATA (KFDP(I,1),I=1740,1907)/1000035,1000004,2000004,1000004,
803 &2000004,1000021,1000039,1000024,1000037,1000022,1000023,1000025,
804 &1000035,1000003,2000003,1000003,2000003,1000021,1000039,-1000024,
805 &-1000037,1000022,1000023,1000025,1000035,1000006,2000006,1000006,
806 &2000006,1000021,1000039,1000024,1000037,1000022,1000023,1000025,
807 &1000035,1000005,2000005,1000005,2000005,1000021,1000022,1000016,
808 &-1000015,1000039,-1000024,-1000037,1000022,1000023,1000025,
809 &1000035,1000012,2000012,1000012,2000012,1000039,1000024,1000037,
810 &1000022,1000023,1000025,1000035,1000011,2000011,1000011,2000011,
811 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
812 &1000014,2000014,1000014,2000014,1000039,1000024,1000037,1000022,
813 &1000023,1000025,1000035,1000013,2000013,1000013,2000013,1000039,
814 &-1000024,-1000037,1000022,1000023,1000025,1000035,1000016,
815 &2000016,1000016,2000016,1000039,1000024,1000037,1000022,1000023,
816 &1000025,1000035,1000015,2000015,1000015,2000015,1000039,1000001,
817 &-1000001,2000001,-2000001,1000002,-1000002,2000002,-2000002,
818 &1000003,-1000003,2000003,-2000003,1000004,-1000004,2000004,
819 &-2000004,1000005,-1000005,2000005,-2000005,1000006,-1000006,
820 &2000006,-2000006,6*1000022,6*1000023,6*1000025,6*1000035,1000024,
821 &-1000024,1000024,-1000024,1000024,-1000024,1000037,-1000037/
822 DATA (KFDP(I,1),I=1908,2126)/1000037,-1000037,1000037,-1000037,
823 &5*1000039,4,1,5*1000039,16*1000022,1000024,-1000024,1000024,
824 &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
825 &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037,
826 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,
827 &1000024,-1000024,1000037,-1000037,1000001,-1000001,2000001,
828 &-2000001,1000002,-1000002,2000002,-2000002,1000003,-1000003,
829 &2000003,-2000003,1000004,-1000004,2000004,-2000004,1000005,
830 &-1000005,2000005,-2000005,1000006,-1000006,2000006,-2000006,
831 &1000011,-1000011,2000011,-2000011,1000012,-1000012,2000012,
832 &-2000012,1000013,-1000013,2000013,-2000013,1000014,-1000014,
833 &2000014,-2000014,1000015,-1000015,2000015,-2000015,1000016,
834 &-1000016,2000016,-2000016,5*1000021,2*1000039,6*1000022,
835 &6*1000023,6*1000025,6*1000035,1000022,1000023,1000025,1000035,
836 &1000002,2000002,-1000001,-2000001,1000004,2000004,-1000003,
837 &-2000003,1000006,2000006,-1000005,-2000005,1000012,2000012,
838 &-1000011,-2000011,1000014,2000014,-1000013,-2000013,1000016,
839 &2000016,-1000015,-2000015,2*1000021,5*1000039,16*1000022,
840 &16*1000023,1000024,-1000024,1000024,-1000024,1000024,-1000024,
841 &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000037/
842 DATA (KFDP(I,1),I=2127,2315)/-1000037,1000037,-1000037,1000037,
843 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,
844 &1000024,-1000024,1000037,-1000037,1000001,-1000001,2000001,
845 &-2000001,1000002,-1000002,2000002,-2000002,1000003,-1000003,
846 &2000003,-2000003,1000004,-1000004,2000004,-2000004,1000005,
847 &-1000005,2000005,-2000005,1000006,-1000006,2000006,-2000006,
848 &1000011,-1000011,2000011,-2000011,1000012,-1000012,2000012,
849 &-2000012,1000013,-1000013,2000013,-2000013,1000014,-1000014,
850 &2000014,-2000014,1000015,-1000015,2000015,-2000015,1000016,
851 &-1000016,2000016,-2000016,5*1000021,5*1000039,16*1000022,
852 &16*1000023,16*1000025,1000024,-1000024,1000024,-1000024,1000024,
853 &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
854 &1000037,-1000037,1000037,-1000037,1000037,-1000037,1000037,
855 &-1000037,1000037,-1000037,1000037,-1000037,1000024,-1000024,
856 &1000037,-1000037,1000001,-1000001,2000001,-2000001,1000002,
857 &-1000002,2000002,-2000002,1000003,-1000003,2000003,-2000003,
858 &1000004,-1000004,2000004,-2000004,1000005,-1000005,2000005,
859 &-2000005,1000006,-1000006,2000006,-2000006,1000011,-1000011,
860 &2000011,-2000011,1000012,-1000012,2000012,-2000012,1000013,
861 &-1000013,2000013,-2000013,1000014,-1000014,2000014,-2000014/
862 DATA (KFDP(I,1),I=2316,2516)/1000015,-1000015,2000015,-2000015,
863 &1000016,-1000016,2000016,-2000016,5*1000021,2*1000039,15*1000024,
864 &6*1000022,6*1000023,6*1000025,6*1000035,1000022,1000023,1000025,
865 &1000035,1000002,2000002,-1000001,-2000001,1000004,2000004,
866 &-1000003,-2000003,1000006,2000006,-1000005,-2000005,1000012,
867 &2000012,-1000011,-2000011,1000014,2000014,-1000013,-2000013,
868 &1000016,2000016,-1000015,-2000015,2*1000021,1000039,-1000024,
869 &-1000037,1000022,1000023,1000025,1000035,4*1000001,1000002,
870 &2000002,1000002,2000002,1000021,1000039,1000024,1000037,1000022,
871 &1000023,1000025,1000035,4*1000002,1000001,2000001,1000001,
872 &2000001,1000021,1000039,-1000024,-1000037,1000022,1000023,
873 &1000025,1000035,4*1000003,1000004,2000004,1000004,2000004,
874 &1000021,1000039,1000024,1000037,1000022,1000023,1000025,1000035,
875 &4*1000004,1000003,2000003,1000003,2000003,1000021,1000039,
876 &-1000024,-1000037,1000022,1000023,1000025,1000035,4*1000005,
877 &1000006,2000006,1000006,2000006,1000021,1000039,1000024,1000037,
878 &1000022,1000023,1000025,1000035,4*1000006,1000005,2000005,
879 &1000005,2000005,1000021,1000039,-1000024,-1000037,1000022,
880 &1000023,1000025,1000035,4*1000011,1000012,2000012,1000012,
881 &2000012,1000039,-1000024,-1000037,1000022,1000023,1000025/
882 DATA (KFDP(I,1),I=2517,4000)/1000035,4*1000013,1000014,2000014,
883 &1000014,2000014,1000039,-1000024,-1000037,1000022,1000023,
884 &1000025,1000035,4*1000015,1000016,2000016,1000016,2000016,21,22,
885 &23,-24,21,22,23,24,22,23,-24,23,24,1447*0/
886 DATA (KFDP(I,2),I= 1, 339)/3*1,2,4,6,8,1,3*2,1,3,5,7,2,3*3,2,4,
887 &6,8,3,3*4,1,3,5,7,4,3*5,2,4,6,8,5,3*6,1,3,5,7,6,5,6*1000006,3*7,
888 &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,
889 &13,11,13,-211,-213,-211,-213,-211,-213,-211,-213,2*-211,-321,
890 &-323,-321,2*-323,3*-321,4*-211,-213,-211,-213,-211,-213,-211,
891 &-213,-211,-213,3*-211,-213,4*-211,-323,-321,2*-211,2*-321,3*-211,
892 &2*15,16,15,16,15,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,
893 &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,
894 &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,
895 &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,
896 &-24,2*1000022,1000023,1000022,1000023,1000025,1000022,1000023,
897 &1000025,1000035,-1000024,-1000037,-1000024,-1000037,-1000001,
898 &2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
899 &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
900 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
901 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
902 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
903 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
904 &-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,22,25,2*36,2,4,6,8,
905 &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/
906 DATA (KFDP(I,2),I= 340, 526)/-7,-8,-11,-13,-15,-17,21,22,2*23,
907 &-24,2*25,36,2*1000022,1000023,1000022,1000023,1000025,1000022,
908 &1000023,1000025,1000035,-1000024,-1000037,-1000024,-1000037,
909 &-1000001,2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
910 &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
911 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
912 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
913 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
914 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
915 &-7,-8,-11,-13,-15,-17,21,22,2*23,-24,25,2*1000022,1000023,
916 &1000022,1000023,1000025,1000022,1000023,1000025,1000035,-1000024,
917 &-1000037,-1000024,-1000037,-1000001,2*-2000001,2000001,-1000002,
918 &2*-2000002,2000002,-1000003,2*-2000003,2000003,-1000004,
919 &2*-2000004,2000004,-1000005,2*-2000005,2000005,-1000006,
920 &2*-2000006,2000006,-1000011,2*-2000011,2000011,-1000012,
921 &2*-2000012,2000012,-1000013,2*-2000013,2000013,-1000014,
922 &2*-2000014,2000014,-1000015,2*-2000015,2000015,-1000016,
923 &2*-2000016,2000016,2,4,6,8,12,14,16,18,25,1000024,1000037,
924 &1000024,1000037,1000024,1000037,1000024,1000037,2*-1000005,
925 &2*-2000005,1000002,1000004,1000012,1000014,2*1000016,-5,-6,21,11/
926 DATA (KFDP(I,2),I= 527, 931)/-3,-4,-5,-6,-7,-8,-13,-15,-17,-3,-4,
927 &-5,-6,-11,-13,-15,21,-3,-5,5,12,14,16,-3,-4,-5,-6,-11,-13,-15,21,
928 &-24,-52,-24,-52,51,53,51,53,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,
929 &-14,-15,-16,-17,-18,23,51,23,51,22,53,2,4,6,8,2,4,6,8,2,4,6,8,2,
930 &4,6,8,12,14,16,18,2*51,2*53,-52,2*-24,-52,-1,-2,-3,-4,-5,-6,-7,
931 &-8,-11,-12,-13,-14,-15,-16,-17,-18,-11,-13,-15,-13,2*-15,24,-11,
932 &-13,-15,-13,2*-15,63,2,4,6,2,4,6,2,4,6,64,65,66,-82,12,14,-1,-3,
933 &11,13,15,1,4,3,4,1,3,22,11,-211,2*22,-13,-11,-211,211,111,211,
934 &-321,130,310,22,2*111,-211,11,-11,13,-13,-211,111,22,14,12,111,
935 &22,111,3*211,-311,22,211,22,111,-211,211,11,-211,13,22,-211,111,
936 &-211,22,111,-11,-211,111,2*-211,-321,130,310,221,111,-211,111,
937 &2*0,-211,111,22,-211,111,-211,111,-211,211,-213,113,223,221,14,
938 &111,211,111,-11,-13,211,111,22,211,111,211,111,2*211,213,113,223,
939 &221,22,-211,111,113,223,22,111,-321,310,211,111,2*-211,221,22,
940 &-11,-13,-211,-321,130,310,221,-211,111,11*12,11*14,2*211,2*213,
941 &211,20213,2*321,2*323,211,213,211,213,211,213,211,213,211,213,
942 &211,213,3*211,213,211,2*321,8*211,2*113,3*211,111,22,211,111,211,
943 &111,4*211,8*12,8*14,2*211,2*213,2*111,221,2*113,223,333,20213,
944 &211,2*321,323,2*311,313,-211,111,113,2*211,321,2*211,311,321,310,
945 &211,-211,4*211,321,4*211,113,2*211,-321,111,22,-211,111,-211,111/
946 DATA (KFDP(I,2),I= 932,1317)/-211,211,-211,211,16,5*12,5*14,
947 &3*211,3*213,211,2*111,2*113,2*-311,2*-313,-2112,3*321,323,2*-1,
948 &22,111,321,311,321,311,-82,-11,-13,-82,22,-82,6*-11,6*-13,2*-15,
949 &211,213,20213,211,213,20213,431,433,431,433,311,313,311,313,311,
950 &313,-1,-4,-3,-4,-1,-3,22,-211,111,-211,111,-211,211,-211,211,
951 &6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,433,431,433,
952 &321,323,321,323,321,323,-1,-4,-3,-4,-1,-3,22,211,111,211,111,
953 &4*211,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,433,431,
954 &433,221,331,333,221,331,333,221,331,333,-1,-4,-3,-4,-1,-3,22,
955 &-321,-311,-321,-311,-15,-3,-1,2*-11,2*-13,2*-15,-1,-4,-3,-4,-3,
956 &-4,-1,-4,2*12,2*14,2,3,2,3,2*12,2*14,2,1,22,411,421,411,421,21,
957 &-11,-13,-15,-1,-2,-3,-4,2*21,22,21,2*-211,111,22,111,211,22,211,
958 &-211,11,2*-211,111,-211,111,22,11,22,111,-211,211,111,211,22,211,
959 &111,211,-211,22,11,13,11,-211,2*111,2*22,111,211,-321,-211,111,
960 &11,2*-211,7*12,7*14,-321,-323,-311,-313,-311,-313,211,213,211,
961 &213,211,213,111,221,331,113,223,111,221,113,223,321,323,321,-211,
962 &-213,111,221,331,113,223,333,10221,111,221,331,113,223,211,213,
963 &211,213,321,323,321,323,321,323,311,313,311,313,2*-1,-3,-1,2203,
964 &3201,3203,2203,2101,2103,12,14,-1,-3,2*111,2*211,12,14,-1,-3,22,
965 &111,2*22,111,22,12,14,-1,-3,22,12,14,-1,-3,12,14,-1,-3,12,14,-1/
966 DATA (KFDP(I,2),I=1318,1756)/-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,
967 &-3,12,14,-1,-3,2*-211,11,13,15,-211,-213,-20213,-431,-433,3*3122,
968 &1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,2*111,
969 &2*211,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,4*22,11,13,15,1,
970 &4,3,4,1,3,22,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,
971 &1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,
972 &4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,
973 &3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,
974 &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,
975 &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,
976 &3,2*111,2*211,-211,111,-321,130,310,-211,111,211,-211,111,-213,
977 &113,-211,111,223,211,111,213,113,211,111,223,-211,111,-321,130,
978 &310,2*-211,-311,311,-321,321,211,111,211,111,-211,111,-211,111,
979 &311,2*321,311,22,2*-82,-211,111,-211,111,211,111,211,111,-321,
980 &-311,-321,-311,411,421,411,421,22,2*21,-211,2*211,111,-211,111,
981 &2*211,111,-211,211,111,211,-321,2*-311,-321,22,-211,111,211,111,
982 &-311,311,-321,321,211,111,-211,111,321,311,22,-82,-211,111,211,
983 &111,-321,-311,411,421,22,21,-11,-13,-82,211,111,221,111,4*22,-11,
984 &-13,-15,-1,-2,-3,-4,2*21,211,111,3*22,1,2*2,4*1,2*-24,2*-37,1,2,
985 &2*1,4*2,2*24,2*37,2,3,2*4,4*3,2*-24,2*-37,3,4,2*3,4*4,2*24,2*37/
986 DATA (KFDP(I,2),I=1757,2220)/4,5,2*6,4*5,2*-24,2*-37,5,6,2*5,4*6,
987 &2*24,2*37,6,4,-15,16,11,2*12,4*11,2*-24,2*-37,12,2*11,4*12,2*24,
988 &2*37,13,2*14,4*13,2*-24,2*-37,14,2*13,4*14,2*24,2*37,15,2*16,
989 &4*15,2*-24,2*-37,16,2*15,4*16,2*24,2*37,21,-1,1,-1,1,-2,2,-2,2,
990 &-3,3,-3,3,-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,1,3,5,2,4,6,1,3,5,2,4,6,
991 &1,3,5,2,4,6,1,3,5,2,4,6,1,-1,3,-3,5,-5,1,-1,3,-3,5,-5,22,23,25,
992 &35,36,-1,-3,22,23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,
993 &35,36,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,
994 &15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,
995 &4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,
996 &-13,13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,24,37,
997 &24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,
998 &24,-11,-13,-15,-1,-3,4*37,2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,
999 &2*-13,2*14,2*-15,2*16,-1,-3,22,23,25,35,36,22,23,11,13,15,12,14,
1000 &16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,
1001 &-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,
1002 &-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,
1003 &-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13,
1004 &13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,22,23,25,
1005 &35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15/
1006 DATA (KFDP(I,2),I=2221,4000)/12,14,16,1,3,5,2,4,25,35,36,22,23,
1007 &11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,-11,13,-13,15,-15,
1008 &1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,
1009 &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,
1010 &-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,14,-15,15,-15,15,
1011 &-16,16,-16,16,1,3,5,2,4,24,37,23,11,13,15,12,14,16,1,3,5,2,4,25,
1012 &35,36,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,
1013 &-1,-3,24,-11,-13,-15,-1,-3,4*37,2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,
1014 &2*12,2*-13,2*14,2*-15,2*16,-1,-3,1,2*2,4*1,23,25,35,36,2*-24,
1015 &2*-37,1,2,2*1,4*2,23,25,35,36,2*24,2*37,2,3,2*4,4*3,23,25,35,36,
1016 &2*-24,2*-37,3,4,2*3,4*4,23,25,35,36,2*24,2*37,4,5,2*6,4*5,23,25,
1017 &35,36,2*-24,2*-37,5,6,2*5,4*6,23,25,35,36,2*24,2*37,6,11,2*12,
1018 &4*11,23,25,35,36,2*-24,2*-37,13,2*14,4*13,23,25,35,36,2*-24,
1019 &2*-37,15,2*16,4*15,23,25,35,36,2*-24,2*-37,3*1,4*2,1,2*11,2*12,
1020 &11,1447*0/
1021 DATA (KFDP(I,3),I= 1,1134)/81*0,14,6*0,2*16,2*0,6*111,310,130,
1022 &2*0,3*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,
1023 &2*113,221,2*113,2*213,-213,113,2*111,310,130,310,130,2*310,130,
1024 &407*0,-5,112*0,4*3,4*4,1,4,3,2*2,0,-11,8*0,-211,5*0,2*111,211,
1025 &-211,211,-211,10*0,111,4*0,2*111,-211,-11,11,-13,22,111,3*0,22,
1026 &3*0,111,211,4*0,111,11*0,111,-211,6*0,-211,3*111,7*0,111,-211,
1027 &5*0,2*221,3*0,111,5*0,111,11*0,-311,-313,-311,-321,-313,-323,111,
1028 &221,331,113,223,-311,-313,-311,-321,-313,-323,111,221,331,113,
1029 &223,22*0,111,113,2*211,-211,-311,211,111,3*211,-211,7*211,7*0,
1030 &111,-211,111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,
1031 &-323,-311,-321,-313,-323,-211,-213,22*0,111,113,-311,2*-211,211,
1032 &-211,310,-211,2*111,211,2*-211,-321,-211,2*211,-211,111,-211,
1033 &2*211,6*0,111,-211,111,-211,0,221,331,333,321,311,221,331,333,
1034 &321,311,20*0,3,13*0,-411,-413,-10413,-10411,-20413,-415,-411,
1035 &-413,-10413,-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,
1036 &5*0,111,-211,111,-211,-421,-423,-10423,-10421,-20423,-425,-421,
1037 &-423,-10423,-10421,-20423,-425,-421,-423,16*0,-4,-1,-4,-3,2*-2,
1038 &5*0,111,-211,111,-211,-431,-433,-10433,-10431,-20433,-435,-431,
1039 &-433,-10433,-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,-3,2*-2,
1040 &8*0,441,443,441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,533,531/
1041 DATA (KFDP(I,3),I=1135,2233)/533,3,2,3,2,511,513,511,513,1,2,
1042 &13*0,2*21,11*0,2112,6*0,2212,12*0,2*3122,3212,10*0,3322,2*0,3122,
1043 &3212,3214,2112,2114,2212,2112,3122,3212,3214,2112,2114,2212,2112,
1044 &52*0,3*3,1,6*0,4*3,4*0,4*3,6*0,4*3,0,28*3,2*0,3*4122,8*0,4,1,4,3,
1045 &2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*0,4*4,1,4,3,2*2,4*4,1,4,3,2*2,
1046 &4*0,4*4,1,4,3,2*2,0,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,
1047 &4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,
1048 &3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,
1049 &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,
1050 &3,2*2,4*4,1,4,3,2*2,31*0,211,111,45*0,-211,2*111,-211,3*111,-211,
1051 &111,211,30*0,-211,111,13*0,2*21,-211,111,76*0,2*5,91*0,-1,-3,-5,
1052 &-2,-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,
1053 &-2,2,-4,4,-6,6,-2,2,-4,4,-6,6,5*0,11,12,7*0,-11,-13,-15,-12,-14,
1054 &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
1055 &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,3*0,12,14,16,2,4,0,
1056 &12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,28*0,2,4,7*0,-11,-13,
1057 &-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,
1058 &-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,-14,14,
1059 &-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,7*0,-11,-13,-15,-12,-14,-16,
1060 &-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0/
1061 DATA (KFDP(I,3),I=2234,4000)/-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,
1062 &-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,-14,14,-16,16,
1063 &-2,2,-4,4,52*0,-1,-3,-5,-2,-4,3*0,-11,-13,-15,-12,-14,-16,-1,-3,
1064 &-5,-2,-4,4*0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,
1065 &16,2,4,28*0,2,4,1601*0/
1066 DATA (KFDP(I,4),I= 1,4000)/94*0,4*111,6*0,111,2*0,-211,0,-211,
1067 &3*0,111,2*-211,0,111,0,2*111,113,221,2*111,-213,-211,211,113,
1068 &6*111,310,2*130,520*0,13*81,41*0,-11,10*0,111,-211,4*0,111,62*0,
1069 &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,
1070 &-211,2*211,2*-211,13*0,-211,111,-211,111,4*0,-211,111,-211,111,
1071 &34*0,111,-211,3*111,3*-211,2*111,3*-211,14*0,-321,-311,3*0,-321,
1072 &-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,
1073 &2*-5,67*0,-211,111,5*0,-211,111,52*0,2101,2103,2*2101,6*0,4*81,
1074 &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,
1075 &162*81,31*0,-211,111,2398*0/
1076 DATA (KFDP(I,5),I= 1,4000)/96*0,2*111,17*0,111,7*0,2*111,0,
1077 &3*111,0,111,715*0,-211,2*111,-211,111,-211,111,65*0,111,-211,
1078 &3*111,-211,111,3075*0/
1079
1080C...PYDAT4, with particle names (character strings).
1081 DATA (CHAF(I,1),I= 1, 185)/'d','u','s','c','b','t','b''','t''',
1082 &2*' ','e-','nu_e','mu-','nu_mu','tau-','nu_tau','tau''-',
1083 &'nu''_tau',2*' ','g','gamma','Z0','W+','h0',2*' ','reggeon',
1084 &'pomeron',2*' ','Z''0','Z"0','W''+','H0','A0','H+','eta_tech0',
1085 &'LQ_ue','R0',10*' ','pi_tech0','pi_tech+','pi''_tech0',
1086 &'rho_tech0','rho_tech+','omega_tech',4*' ','H_L++','H_R++',
1087 &'W_R+','nu_Re','nu_Rmu','nu_Rtau',14*' ','specflav','rndmflav',
1088 &'phasespa','c-hadron','b-hadron',5*' ','cluster','string',
1089 &'indep.','CMshower','SPHEaxis','THRUaxis','CLUSjet','CELLjet',
1090 &'table',' ','rho_diff0','pi0','rho0','a_20','K_L0','pi_diffr+',
1091 &'pi+','rho+','a_2+','omega_di','eta','omega','f_2','K_S0','K0',
1092 &'K*0','K*_20','K+','K*+','K*_2+','phi_diff','eta''','phi',
1093 &'f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+','D*_s+',
1094 &'D*_2s+','J/psi_di','eta_c','J/psi','chi_2c','B0','B*0','B*_20',
1095 &'B+','B*+','B*_2+','B_s0','B*_s0','B*_2s0','B_c+','B*_c+',
1096 &'B*_2c+','eta_b','Upsilon','chi_2b','dd_1','Delta-','ud_0',
1097 &'ud_1','n_diffr0','n0','Delta0','uu_1','p_diffr+','p+','Delta+',
1098 &'Delta++','sd_0','sd_1','Sigma-','Sigma*-','Lambda0','su_0',
1099 &'su_1','Sigma0','Sigma*0','Sigma+','Sigma*+','ss_1','Xi-','Xi*-',
1100 &'Xi0','Xi*0','Omega-','cd_0','cd_1','Sigma_c0','Sigma*_c0'/
1101 DATA (CHAF(I,1),I= 186, 315)/'Lambda_c+','Xi_c0','cu_0','cu_1',
1102 &'Sigma_c+','Sigma*_c+','Sigma_c++','Sigma*_c++','Xi_c+','cs_0',
1103 &'cs_1','Xi''_c0','Xi*_c0','Xi''_c+','Xi*_c+','Omega_c0',
1104 &'Omega*_c0','cc_1','Xi_cc+','Xi*_cc+','Xi_cc++','Xi*_cc++',
1105 &'Omega_cc+','Omega*_cc+','Omega*_ccc++','bd_0','bd_1','Sigma_b-',
1106 &'Sigma*_b-','Lambda_b0','Xi_b-','Xi_bc0','bu_0','bu_1',
1107 &'Sigma_b0','Sigma*_b0','Sigma_b+','Sigma*_b+','Xi_b0','Xi_bc+',
1108 &'bs_0','bs_1','Xi''_b-','Xi*_b-','Xi''_b0','Xi*_b0','Omega_b-',
1109 &'Omega*_b-','Omega_bc0','bc_0','bc_1','Xi''_bc0','Xi*_bc0',
1110 &'Xi''_bc+','Xi*_bc+','Omega''_bc0','Omega*_bc0','Omega_bcc+',
1111 &'Omega*_bcc+','bb_1','Xi_bb-','Xi*_bb-','Xi_bb0','Xi*_bb0',
1112 &'Omega_bb-','Omega*_bb-','Omega_bbc0','Omega*_bbc0',
1113 &'Omega*_bbb-','a_00','b_10','a_0+','b_1+','f_0','h_1','K*_00',
1114 &'K_10','K*_0+','K_1+','f''_0','h''_1','D*_0+','D_1+','D*_00',
1115 &'D_10','D*_0s+','D_1s+','chi_0c','h_1c','B*_00','B_10','B*_0+',
1116 &'B_1+','B*_0s0','B_1s0','B*_0c+','B_1c+','chi_0b','h_1b','a_10',
1117 &'a_1+','f_1','K*_10','K*_1+','f''_1','D*_1+','D*_10','D*_1s+',
1118 &'chi_1c','B*_10','B*_1+','B*_1s0','B*_1c+','chi_1b','psi''',
1119 &'Upsilon''','~d_L','~u_L','~s_L','~c_L','~b_1','~t_1','~e_L-',
1120 &'~nu_eL','~mu_L-','~nu_muL','~tau_1-','~nu_tauL','~g','~chi_10'/
1121 DATA (CHAF(I,1),I= 316, 500)/'~chi_20','~chi_1+','~chi_30',
1122 &'~chi_40','~chi_2+','~gravitino','~d_R','~u_R','~s_R','~c_R',
1123 &'~b_2','~t_2','~e_R-','~nu_eR','~mu_R-','~nu_muR','~tau_2-',
1124 &'~nu_tauR','d*','u*','e*-','nu*_e0',163*' '/
1125 DATA (CHAF(I,2),I= 1, 198)/'dbar','ubar','sbar','cbar','bbar',
1126 &'tbar','b''bar','t''bar',2*' ','e+','nu_ebar','mu+','nu_mubar',
1127 &'tau+','nu_taubar','tau''+','nu''_taubar',5*' ','W-',9*' ',
1128 &'W''-',2*' ','H-',' ','LQ_uebar','Rbar0',11*' ','pi_tech-',2*' ',
1129 &'rho_tech-',5*' ','H_L--','H_R--','W_R-','nu_Rebar','nu_Rmubar',
1130 &'nu_Rtaubar',15*' ','rndmflavbar',' ','c-hadronbar',
1131 &'b-hadronbar',20*' ','pi_diffr-','pi-','rho-','a_2-',5*' ',
1132 &'Kbar0','K*bar0','K*_2bar0','K-','K*-','K*_2-',4*' ','D-','D*-',
1133 &'D*_2-','Dbar0','D*bar0','D*_2bar0','D_s-','D*_s-','D*_2s-',
1134 &4*' ','Bbar0','B*bar0','B*_2bar0','B-','B*-','B*_2-','B_sbar0',
1135 &'B*_sbar0','B*_2sbar0','B_c-','B*_c-','B*_2c-',3*' ','dd_1bar',
1136 &'Deltabar+','ud_0bar','ud_1bar','n_diffrbar0','nbar0',
1137 &'Deltabar0','uu_1bar','p_diffrbar-','pbar-','Deltabar-',
1138 &'Deltabar--','sd_0bar','sd_1bar','Sigmabar+','Sigma*bar+',
1139 &'Lambdabar0','su_0bar','su_1bar','Sigmabar0','Sigma*bar0',
1140 &'Sigmabar-','Sigma*bar-','ss_1bar','Xibar+','Xi*bar+','Xibar0',
1141 &'Xi*bar0','Omegabar+','cd_0bar','cd_1bar','Sigma_cbar0',
1142 &'Sigma*_cbar0','Lambda_cbar-','Xi_cbar0','cu_0bar','cu_1bar',
1143 &'Sigma_cbar-','Sigma*_cbar-','Sigma_cbar--','Sigma*_cbar--',
1144 &'Xi_cbar-','cs_0bar','cs_1bar','Xi''_cbar0','Xi*_cbar0'/
1145 DATA (CHAF(I,2),I= 199, 308)/'Xi''_cbar-','Xi*_cbar-',
1146 &'Omega_cbar0','Omega*_cbar0','cc_1bar','Xi_ccbar-','Xi*_ccbar-',
1147 &'Xi_ccbar--','Xi*_ccbar--','Omega_ccbar-','Omega*_ccbar-',
1148 &'Omega*_cccbar-','bd_0bar','bd_1bar','Sigma_bbar+',
1149 &'Sigma*_bbar+','Lambda_bbar0','Xi_bbar+','Xi_bcbar0','bu_0bar',
1150 &'bu_1bar','Sigma_bbar0','Sigma*_bbar0','Sigma_bbar-',
1151 &'Sigma*_bbar-','Xi_bbar0','Xi_bcbar-','bs_0bar','bs_1bar',
1152 &'Xi''_bbar+','Xi*_bbar+','Xi''_bbar0','Xi*_bbar0','Omega_bbar+',
1153 &'Omega*_bbar+','Omega_bcbar0','bc_0bar','bc_1bar','Xi''_bcbar0',
1154 &'Xi*_bcbar0','Xi''_bcbar-','Xi*_bcbar-','Omega''_bcba',
1155 &'Omega*_bcbar0','Omega_bccbar-','Omega*_bccbar-','bb_1bar',
1156 &'Xi_bbbar+','Xi*_bbbar+','Xi_bbbar0','Xi*_bbbar0','Omega_bbbar+',
1157 &'Omega*_bbbar+','Omega_bbcbar0','Omega*_bbcbar0',
1158 &'Omega*_bbbbar+',2*' ','a_0-','b_1-',2*' ','K*_0bar0','K_1bar0',
1159 &'K*_0-','K_1-',2*' ','D*_0-','D_1-','D*_0bar0','D_1bar0',
1160 &'D*_0s-','D_1s-',2*' ','B*_0bar0','B_1bar0','B*_0-','B_1-',
1161 &'B*_0sbar0','B_1sbar0','B*_0c-','B_1c-',3*' ','a_1-',' ',
1162 &'K*_1bar0','K*_1-',' ','D*_1-','D*_1bar0','D*_1s-',' ',
1163 &'B*_1bar0','B*_1-','B*_1sbar0','B*_1c-',3*' ','~d_Lbar',
1164 &'~u_Lbar','~s_Lbar','~c_Lbar','~b_1bar','~t_1bar','~e_L+'/
1165 DATA (CHAF(I,2),I= 309, 500)/'~nu_eLbar','~mu_L+','~nu_muLbar',
1166 &'~tau_1+','~nu_tauLbar',3*' ','~chi_1-',2*' ','~chi_2-',' ',
1167 &'~d_Rbar','~u_Rbar','~s_Rbar','~c_Rbar','~b_2bar','~t_2bar',
1168 &'~e_R+','~nu_eRbar','~mu_R+','~nu_muRbar','~tau_2+',
1169 &'~nu_tauRbar','d*bar','u*bar','e*bar+','nu*_ebar0',163*' '/
1170
1171C...PYDATR, with initial values for the random number generator.
1172 DATA MRPY/19780503,0,0,97,33,0/
1173
1174C...Default values for allowed processes and kinematics constraints.
1175 DATA MSEL/1/
1176 DATA MSUB/500*0/
1177 DATA ((KFIN(I,J),J=-40,40),I=1,2)/16*0,4*1,4*0,6*1,5*0,5*1,0,
1178 &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,
1179 &6*1,4*0,4*1,16*0/
1180 DATA CKIN/
1181 & 2.0D0, -1.0D0, 0.0D0, -1.0D0, 1.0D0,
1182 & 1.0D0, -10D0, 10D0, -40D0, 40D0,
1183 1 -40D0, 40D0, -40D0, 40D0, -40D0,
1184 1 40D0, -1.0D0, 1.0D0, -1.0D0, 1.0D0,
1185 2 0.0D0, 1.0D0, 0.0D0, 1.0D0, -1.0D0,
1186 2 1.0D0, -1.0D0, 1.0D0, 0D0, 0D0,
1187 3 2.0D0, -1.0D0, 0D0, 0D0, 0.0D0,
1188 3 -1.0D0, 0.0D0, -1.0D0, 4.0D0, -1.0D0,
1189 4 12.0D0, -1.0D0, 12.0D0, -1.0D0, 12.0D0,
1190 4 -1.0D0, 12.0D0, -1.0D0, 0D0, 0D0,
1191 5 0.0D0, -1.0D0, 0.0D0, -1.0D0, 0.0D0,
1192 5 -1.0D0, 0D0, 0D0, 0D0, 0D0,
1193 6 0.0001D0, 0.99D0, 0.0001D0, 0.99D0, 0D0,
1194 6 -1D0, 0D0, -1D0, 0D0, -1D0,
1195 7 0D0, -1D0, 0.0001D0, 0.99D0, 0.0001D0,
1196 7 0.99D0, 2D0, -1D0, 0D0, 0D0,
1197 8 120*0D0/
1198
1199C...Default values for main switches and parameters. Reset information.
1200 DATA (MSTP(I),I=1,100)/
1201 & 3, 1, 2, 0, 0, 0, 0, 0, 0, 0,
1202 1 1, 0, 1, 30, 0, 1, 4, 3, 4, 3,
1203 2 1, 0, 1, 0, 0, 0, 0, 0, 0, 1,
1204 3 1, 8, 0, 1, 0, 2, 1, 5, 2, 0,
1205 4 1, 1, 3, 7, 3, 1, 1, 0, 1, 0,
1206 5 4, 1, 3, 1, 5, 1, 1, 5, 1, 7,
1207 6 1, 3, 2, 2, 1, 5, 2, 1, 0, 0,
1208 7 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1209 8 1, 1, 100, 0, 0, 2, 0, 0, 0, 0,
1210 9 1, 3, 1, 3, 0, 0, 0, 0, 0, 0/
1211 DATA (MSTP(I),I=101,200)/
1212 & 3, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1213 1 1, 1, 1, 0, 0, 0, 0, 0, 0, 0,
1214 2 0, 1, 2, 1, 1, 50, 0, 0, 10, 0,
1215 3 0, 4, 0, 1, 0, 0, 0, 0, 0, 0,
1216 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1217 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1218 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1219 7 0, 2, 0, 0, 0, 0, 0, 0, 0, 0,
1220 8 6, 150, 2000, 06, 30, 0, 0, 0, 0, 0,
1221 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1222 DATA (PARP(I),I=1,100)/
1223 & 0.25D0, 10D0, 8*0D0,
1224 1 0D0, 0D0, 1.0D0, 0.01D0, 0.5D0, 1.0D0, 1.0D0, 0.4D0, 2*0D0,
1225 2 10*0D0,
1226 3 1.5D0,2.0D0,0.075D0,1.0D0,0.2D0,0D0,2.0D0,0.70D0,0.006D0,0D0,
1227 4 0.02D0,2.0D0,0.10D0,1000D0,2054D0, 123D0, 246D0, 50D0, 2*0D0,
1228 5 10*0D0,
1229 6 0.25D0, 1.0D0,0.25D0, 1.0D0, 2.0D0,1D-3, 1.0D0,1D-3,2*0D0,
1230 7 4.0D0, 0.25D0, 8*0D0,
1231 8 1.90D0, 2.10D0, 0.5D0, 0.2D0, 0.33D0,
1232 8 0.66D0, 0.7D0, 0.5D0, 1000D0, 0.16D0,
1233 9 1.0D0,0.40D0,5.0D0,1.0D0,0D0,3.0D0,1.0D0,0.75D0,1.0D0,5.0D0/
1234 DATA (PARP(I),I=101,200)/
1235 & 0.5D0, 0.28D0, 1.0D0, 0.8D0, 6*0D0,
1236 1 2.0D0, 3*0D0, 1.5D0, 0.5D0, 0.6D0, 2.5D0, 2.0D0, 1.0D0,
1237 2 1.0D0, 0.4D0, 8*0D0,
1238 3 0.01D0, 8*0D0, 0D0,
1239 4 0.33333D0, 82D0, 1.33333D0, 4D0, 1D0,
1240 4 1D0, .0182D0, 1D0, 0D0, 1.33333D0,
1241 5 0D0, 0D0, 0D0, 0D0, 6*0D0,
1242 6 2.20D0, 23.6D0, 18.4D0, 11.5D0, 0.5D0, 0D0, 0D0, 0D0, 2*0D0,
1243 7 0D0, 0D0, 0D0, 1.0D0, 6*0D0,
1244 8 0.1D0, 0.01D0, 0.01D0, 0.01D0, 0.1D0, 0.01D0, 0.01D0, 0.01D0,
1245 8 0.3D0, 0.64D0,
1246 9 0.64D0, 5.0D0, 8*0D0/
1247 DATA MSTI/200*0/
1248 DATA PARI/200*0D0/
1249 DATA MINT/400*0/
1250 DATA VINT/400*0D0/
1251
1252C...Constants for the generation of the various processes.
1253 DATA (ISET(I),I=1,100)/
1254 & 1, 1, 1, -1, 3, -1, -1, 3, -2, 2,
1255 1 2, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1256 2 -1, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1257 3 2, 2, 2, 2, 2, 2, -1, -1, -1, -1,
1258 4 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
1259 5 -1, -1, 2, 2, -1, -1, -1, 2, -1, -1,
1260 6 -1, -1, -1, -1, -1, -1, -1, 2, 2, 2,
1261 7 4, 4, 4, -1, -1, 4, 4, -1, -1, 2,
1262 8 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1263 9 0, 0, 0, 0, 0, 9, -2, -2, 8, -2/
1264 DATA (ISET(I),I=101,200)/
1265 & -1, 1, 1, 1, 1, 2, 2, 2, -2, 2,
1266 1 2, 2, 2, 2, 2, -1, -1, -1, -2, -2,
1267 2 5, 5, 5, 5, -2, -2, -2, -2, -2, -2,
1268 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1269 4 1, 1, 1, 1, 1, 1, 1, 1, 1, -2,
1270 5 1, 1, 1, -2, -2, 1, 1, 1, -2, -2,
1271 6 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1272 7 2, 2, 5, 5, -2, 2, 2, 5, 5, -2,
1273 8 5, 5, -2, -2, -2, 5, 5, -2, -2, -2,
1274 9 1, 1, 1, 2, 2, -2, -2, -2, -2, -2/
1275 DATA (ISET(I),I=201,300)/
1276 & 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1277 1 2, 2, 2, 2, -2, 2, 2, 2, 2, 2,
1278 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1279 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1280 4 2, 2, 2, 2, -1, 2, 2, 2, 2, 2,
1281 5 2, 2, 2, 2, -1, 2, -1, 2, 2, -2,
1282 6 2, 2, 2, 2, 2, -1, -1, -1, -1, -1,
1283 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1284 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1285 9 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
1286 DATA (ISET(I),I=301,500)/
1287 & 2, 39*-2,
1288 4 1, 1, 2, 2, 2, 2, 2, 2, 2, 2,
1289 5 5, 5, -1, -1, -1, -1, -1, -1, -1, -1,
1290 6 2, 2, 2, 2, 2, 2, 2, 2, -1, 2,
1291 7 2, 2, 2, 2, 2, 2, 2, -1, -1, -1,
1292 8 120*-2/
1293 DATA ((KFPR(I,J),J=1,2),I=1,50)/
1294 & 23, 0, 24, 0, 25, 0, 24, 0, 25, 0,
1295 & 24, 0, 23, 0, 25, 0, 0, 0, 0, 0,
1296 1 0, 0, 0, 0, 21, 21, 21, 22, 21, 23,
1297 1 21, 24, 21, 25, 22, 22, 22, 23, 22, 24,
1298 2 22, 25, 23, 23, 23, 24, 23, 25, 24, 24,
1299 2 24, 25, 25, 25, 0, 21, 0, 22, 0, 23,
1300 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1301 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1302 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1303 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23/
1304 DATA ((KFPR(I,J),J=1,2),I=51,100)/
1305 5 0, 24, 0, 25, 0, 0, 0, 0, 0, 0,
1306 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1307 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1308 6 0, 0, 0, 0, 21, 21, 24, 24, 23, 24,
1309 7 23, 23, 24, 24, 23, 24, 23, 25, 22, 22,
1310 7 23, 23, 24, 24, 24, 25, 25, 25, 0, 211,
1311 8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1312 8 443, 21,10441, 21,20443, 21, 445, 21, 0, 0,
1313 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1314 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1315 DATA ((KFPR(I,J),J=1,2),I=101,150)/
1316 & 23, 0, 25, 0, 25, 0,10441, 0, 445, 0,
1317 & 443, 22, 443, 21, 443, 22, 0, 0, 22, 25,
1318 1 21, 25, 0, 25, 21, 25, 22, 22, 21, 22,
1319 1 22, 23, 23, 23, 24, 24, 0, 0, 0, 0,
1320 2 25, 6, 25, 6, 25, 0, 25, 0, 0, 0,
1321 2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1322 3 0, 21, 0, 21, 0, 22, 0, 22, 0, 0,
1323 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1324 4 32, 0, 34, 0, 37, 0, 40, 0, 39, 0,
1325 4 4000011, 0, 4000001, 0, 4000002, 0, 38, 0, 0, 0/
1326 DATA ((KFPR(I,J),J=1,2),I=151,200)/
1327 5 35, 0, 35, 0, 35, 0, 0, 0, 0, 0,
1328 5 36, 0, 36, 0, 36, 0, 0, 0, 0, 0,
1329 6 6, 37, 39, 0, 39, 39, 39, 39, 11, 0,
1330 6 11, 0, 0, 4000001, 0, 4000002, 0, 4000011, 0, 0,
1331 7 23, 35, 24, 35, 35, 0, 35, 0, 0, 0,
1332 7 23, 36, 24, 36, 36, 0, 36, 0, 0, 0,
1333 8 35, 6, 35, 6, 0, 0, 0, 0, 0, 0,
1334 8 36, 6, 36, 6, 0, 0, 0, 0, 0, 0,
1335 9 54, 0, 55, 0, 56, 0, 11, 0, 11, 0,
1336 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1337 DATA ((KFPR(I,J),J=1,2),I=201,250)/
1338 & 1000011, 1000011, 2000011, 2000011, 1000011,
1339 & 2000011, 1000013, 1000013, 2000013, 2000013,
1340 & 1000013, 2000013, 1000015, 1000015, 2000015,
1341 & 2000015, 1000015, 2000015, 1000011, 1000012,
1342 1 1000015, 1000016, 2000015, 1000016, 1000012,
1343 1 1000012, 1000016, 1000016, 0, 0,
1344 1 1000022, 1000022, 1000023, 1000023, 1000025,
1345 1 1000025, 1000035, 1000035, 1000022, 1000023,
1346 2 1000022, 1000025, 1000022, 1000035, 1000023,
1347 2 1000025, 1000023, 1000035, 1000025, 1000035,
1348 2 1000024, 1000024, 1000037, 1000037, 1000024,
1349 2 1000037, 1000022, 1000024, 1000023, 1000024,
1350 3 1000025, 1000024, 1000035, 1000024, 1000022,
1351 3 1000037, 1000023, 1000037, 1000025, 1000037,
1352 3 1000035, 1000037, 1000021, 1000022, 1000021,
1353 3 1000023, 1000021, 1000025, 1000021, 1000035,
1354 4 1000021, 1000024, 1000021, 1000037, 1000021,
1355 4 1000021, 1000021, 1000021, 0, 0,
1356 4 1000002, 1000022, 2000002, 1000022, 1000002,
1357 4 1000023, 2000002, 1000023, 1000002, 1000025/
1358 DATA ((KFPR(I,J),J=1,2),I=251,300)/
1359 5 2000002, 1000025, 1000002, 1000035, 2000002,
1360 5 1000035, 1000001, 1000024, 2000005, 1000024,
1361 5 1000001, 1000037, 2000005, 1000037, 1000002,
1362 5 1000021, 2000002, 1000021, 0, 0,
1363 6 1000006, 1000006, 2000006, 2000006, 1000006,
1364 6 2000006, 1000006, 1000006, 2000006, 2000006,
1365 6 0, 0, 0, 0, 0,
1366 6 0, 0, 0, 0, 0,
1367 7 1000002, 1000002, 2000002, 2000002, 1000002,
1368 7 2000002, 1000002, 1000002, 2000002, 2000002,
1369 7 1000002, 2000002, 1000002, 1000002, 2000002,
1370 7 2000002, 1000002, 1000002, 2000002, 2000002,
1371 8 1000005, 1000002, 2000005, 2000002, 1000005,
1372 8 2000002, 1000005, 1000002, 2000005, 2000002,
1373 8 1000005, 2000002, 1000005, 1000005, 2000005,
1374 8 2000005, 1000005, 1000005, 2000005, 2000005,
1375 9 1000005, 1000005, 2000005, 2000005, 1000005,
1376 9 2000005, 1000005, 1000021, 2000005, 1000021,
1377 9 1000005, 2000005, 37, 25, 37,
1378 9 35, 36, 25, 36, 35/
1379 DATA ((KFPR(I,J),J=1,2),I=301,500)/
1380 & 37, 37, 78*0,
1381 4 61, 0, 62, 0, 61,
1382 4 11, 62, 11, 61, 13,
1383 4 62, 13, 61, 15, 62,
1384 4 15, 61, 61, 62, 62,
1385 5 61, 0, 62, 0, 0,
1386 5 0, 0, 0, 0, 0,
1387 5 0, 0, 0, 0, 0,
1388 5 0, 0, 0, 0, 0,
1389 6 24, 24, 24, 52, 52,
1390 6 52, 22, 51, 22, 53,
1391 6 23, 51, 23, 53, 24,
1392 6 52, 0, 0, 24, 23,
1393 7 24, 51, 52, 23, 52,
1394 7 51, 22, 52, 23, 52,
1395 7 24, 51, 24, 53, 0,
1396 7 0, 0, 0, 0, 0,
1397 8 240*0/
1398 DATA COEF/10000*0D0/
1399 DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/
1400 &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,
1401 &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,
1402 &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,
1403 &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,
1404 &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,
1405 &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,
1406 &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,
1407 &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,
1408 &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,
1409 &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/
1410
1411C...Treatment of resonances.
1412 DATA (MWID(I) ,I= 1, 500)/5*0,3*1,8*0,1,5*0,3*1,6*0,1,0,7*1,
1413 &10*0,6*1,4*0,3*1,238*0,19*2,0,7*2,0,2,0,2,0,4*1,163*0/
1414
1415C...Character constants: name of processes.
1416 DATA PROC(0)/ 'All included subprocesses '/
1417 DATA (PROC(I),I=1,20)/
1418 &'f + fbar -> gamma*/Z0 ', 'f + fbar'' -> W+/- ',
1419 &'f + fbar -> h0 ', 'gamma + W+/- -> W+/- ',
1420 &'Z0 + Z0 -> h0 ', 'Z0 + W+/- -> W+/- ',
1421 &' ', 'W+ + W- -> h0 ',
1422 &' ', 'f + f'' -> f + f'' (QFD) ',
1423 1'f + f'' -> f + f'' (QCD) ','f + fbar -> f'' + fbar'' ',
1424 1'f + fbar -> g + g ', 'f + fbar -> g + gamma ',
1425 1'f + fbar -> g + Z0 ', 'f + fbar'' -> g + W+/- ',
1426 1'f + fbar -> g + h0 ', 'f + fbar -> gamma + gamma ',
1427 1'f + fbar -> gamma + Z0 ', 'f + fbar'' -> gamma + W+/- '/
1428 DATA (PROC(I),I=21,40)/
1429 2'f + fbar -> gamma + h0 ', 'f + fbar -> Z0 + Z0 ',
1430 2'f + fbar'' -> Z0 + W+/- ', 'f + fbar -> Z0 + h0 ',
1431 2'f + fbar -> W+ + W- ', 'f + fbar'' -> W+/- + h0 ',
1432 2'f + fbar -> h0 + h0 ', 'f + g -> f + g ',
1433 2'f + g -> f + gamma ', 'f + g -> f + Z0 ',
1434 3'f + g -> f'' + W+/- ', 'f + g -> f + h0 ',
1435 3'f + gamma -> f + g ', 'f + gamma -> f + gamma ',
1436 3'f + gamma -> f + Z0 ', 'f + gamma -> f'' + W+/- ',
1437 3'f + gamma -> f + h0 ', 'f + Z0 -> f + g ',
1438 3'f + Z0 -> f + gamma ', 'f + Z0 -> f + Z0 '/
1439 DATA (PROC(I),I=41,60)/
1440 4'f + Z0 -> f'' + W+/- ', 'f + Z0 -> f + h0 ',
1441 4'f + W+/- -> f'' + g ', 'f + W+/- -> f'' + gamma ',
1442 4'f + W+/- -> f'' + Z0 ', 'f + W+/- -> f'' + W+/- ',
1443 4'f + W+/- -> f'' + h0 ', 'f + h0 -> f + g ',
1444 4'f + h0 -> f + gamma ', 'f + h0 -> f + Z0 ',
1445 5'f + h0 -> f'' + W+/- ', 'f + h0 -> f + h0 ',
1446 5'g + g -> f + fbar ', 'g + gamma -> f + fbar ',
1447 5'g + Z0 -> f + fbar ', 'g + W+/- -> f + fbar'' ',
1448 5'g + h0 -> f + fbar ', 'gamma + gamma -> f + fbar ',
1449 5'gamma + Z0 -> f + fbar ', 'gamma + W+/- -> f + fbar'' '/
1450 DATA (PROC(I),I=61,80)/
1451 6'gamma + h0 -> f + fbar ', 'Z0 + Z0 -> f + fbar ',
1452 6'Z0 + W+/- -> f + fbar'' ', 'Z0 + h0 -> f + fbar ',
1453 6'W+ + W- -> f + fbar ', 'W+/- + h0 -> f + fbar'' ',
1454 6'h0 + h0 -> f + fbar ', 'g + g -> g + g ',
1455 6'gamma + gamma -> W+ + W- ', 'gamma + W+/- -> Z0 + W+/- ',
1456 7'Z0 + Z0 -> Z0 + Z0 ', 'Z0 + Z0 -> W+ + W- ',
1457 7'Z0 + W+/- -> Z0 + W+/- ', 'Z0 + Z0 -> Z0 + h0 ',
1458 7'W+ + W- -> gamma + gamma ', 'W+ + W- -> Z0 + Z0 ',
1459 7'W+/- + W+/- -> W+/- + W+/- ', 'W+/- + h0 -> W+/- + h0 ',
1460 7'h0 + h0 -> h0 + h0 ', 'q + gamma -> q'' + pi+/- '/
1461 DATA (PROC(I),I=81,100)/
1462 8'q + qbar -> Q + Qbar, mass ', 'g + g -> Q + Qbar, massive ',
1463 8'f + q -> f'' + Q, massive ', 'g + gamma -> Q + Qbar, mass ',
1464 8'gamma + gamma -> F + Fbar, m', 'g + g -> J/Psi + g ',
1465 8'g + g -> chi_0c + g ', 'g + g -> chi_1c + g ',
1466 8'g + g -> chi_2c + g ', ' ',
1467 9'Elastic scattering ', 'Single diffractive (XB) ',
1468 9'Single diffractive (AX) ', 'Double diffractive ',
1469 9'Low-pT scattering ', 'Semihard QCD 2 -> 2 ',
1470 9' ', ' ',
1471 9'q + gamma* -> q ', ' '/
1472 DATA (PROC(I),I=101,120)/
1473 &'g + g -> gamma*/Z0 ', 'g + g -> h0 ',
1474 &'gamma + gamma -> h0 ', 'g + g -> chi_0c ',
1475 &'g + g -> chi_2c ', 'g + g -> J/Psi + gamma ',
1476 &'gamma + g -> J/Psi + g ', 'gamma+gamma -> J/Psi + gamma',
1477 &' ', 'f + fbar -> gamma + h0 ',
1478 1'f + fbar -> g + h0 ', 'q + g -> q + h0 ',
1479 1'g + g -> g + h0 ', 'g + g -> gamma + gamma ',
1480 1'g + g -> g + gamma ', 'g + g -> gamma + Z0 ',
1481 1'g + g -> Z0 + Z0 ', 'g + g -> W+ + W- ',
1482 1' ', ' '/
1483 DATA (PROC(I),I=121,140)/
1484 2'g + g -> Q + Qbar + h0 ', 'q + qbar -> Q + Qbar + h0 ',
1485 2'f + f'' -> f + f'' + h0 ',
1486 2'f + f'' -> f" + f"'' + h0 ',
1487 2' ', ' ',
1488 2' ', ' ',
1489 2' ', ' ',
1490 3'f + gamma*_T -> f + g ', 'f + gamma*_L -> f + g ',
1491 3'f + gamma*_T -> f + gamma ', 'f + gamma*_L -> f + gamma ',
1492 3'g + gamma*_T -> f + fbar ', 'g + gamma*_L -> f + fbar ',
1493 3'gamma*_T+gamma*_T -> f+fbar ', 'gamma*_T+gamma*_L -> f+fbar ',
1494 3'gamma*_L+gamma*_T -> f+fbar ', 'gamma*_L+gamma*_L -> f+fbar '/
1495 DATA (PROC(I),I=141,160)/
1496 4'f + fbar -> gamma*/Z0/Z''0 ', 'f + fbar'' -> W''+/- ',
1497 4'f + fbar'' -> H+/- ', 'f + fbar'' -> R ',
1498 4'q + l -> LQ ', 'e + gamma -> e* ',
1499 4'd + g -> d* ', 'u + g -> u* ',
1500 4'g + g -> eta_techni ', ' ',
1501 5'f + fbar -> H0 ', 'g + g -> H0 ',
1502 5'gamma + gamma -> H0 ', ' ',
1503 5' ', 'f + fbar -> A0 ',
1504 5'g + g -> A0 ', 'gamma + gamma -> A0 ',
1505 5' ', ' '/
1506 DATA (PROC(I),I=161,180)/
1507 6'f + g -> f'' + H+/- ', 'q + g -> LQ + lbar ',
1508 6'g + g -> LQ + LQbar ', 'q + qbar -> LQ + LQbar ',
1509 6'f + fbar -> f'' + fbar'' (g/Z)',
1510 6'f +fbar'' -> f" + fbar"'' (W) ',
1511 6'q + q'' -> q" + d* ', 'q + q'' -> q" + u* ',
1512 6'q + qbar -> e + e* ', ' ',
1513 7'f + fbar -> Z0 + H0 ', 'f + fbar'' -> W+/- + H0 ',
1514 7'f + f'' -> f + f'' + H0 ',
1515 7'f + f'' -> f" + f"'' + H0 ',
1516 7' ', 'f + fbar -> Z0 + A0 ',
1517 7'f + fbar'' -> W+/- + A0 ',
1518 7'f + f'' -> f + f'' + A0 ',
1519 7'f + f'' -> f" + f"'' + A0 ',
1520 7' '/
1521 DATA (PROC(I),I=181,200)/
1522 8'g + g -> Q + Qbar + H0 ', 'q + qbar -> Q + Qbar + H0 ',
1523 8' ', ' ',
1524 8' ', 'g + g -> Q + Qbar + A0 ',
1525 8'q + qbar -> Q + Qbar + A0 ', ' ',
1526 8' ', ' ',
1527 9'f + fbar -> rho_tech0 ', 'f + f'' -> rho_tech+/- ',
1528 9'f + fbar -> omega_tech0 ', 'f+fbar -> f''+fbar'' (ETC) ',
1529 9'f+fbar'' -> f"+fbar"'' (ETC)',' ',
1530 9' ', ' ',
1531 9' ', ' '/
1532 DATA (PROC(I),I=201,220)/
1533 &'f + fbar -> ~e_L + ~e_Lbar ', 'f + fbar -> ~e_R + ~e_Rbar ',
1534 &'f + fbar -> ~e_R + ~e_Lbar ', 'f + fbar -> ~mu_L + ~mu_Lbar',
1535 &'f + fbar -> ~mu_R + ~mu_Rbar', 'f + fbar -> ~mu_L + ~mu_Rbar',
1536 &'f+fbar -> ~tau_1 + ~tau_1bar', 'f+fbar -> ~tau_2 + ~tau_2bar',
1537 &'f+fbar -> ~tau_1 + ~tau_2bar', 'q + qbar'' -> ~l_L + ~nulbar ',
1538 1'q+qbar''-> ~tau_1 + ~nutaubar', 'q+qbar''-> ~tau_2 + ~nutaubar',
1539 1'f + fbar -> ~nul + ~nulbar ', 'f+fbar -> ~nutau + ~nutaubar',
1540 1' ', 'f + fbar -> ~chi1 + ~chi1 ',
1541 1'f + fbar -> ~chi2 + ~chi2 ', 'f + fbar -> ~chi3 + ~chi3 ',
1542 1'f + fbar -> ~chi4 + ~chi4 ', 'f + fbar -> ~chi1 + ~chi2 '/
1543 DATA (PROC(I),I=221,240)/
1544 2'f + fbar -> ~chi1 + ~chi3 ', 'f + fbar -> ~chi1 + ~chi4 ',
1545 2'f + fbar -> ~chi2 + ~chi3 ', 'f + fbar -> ~chi2 + ~chi4 ',
1546 2'f + fbar -> ~chi3 + ~chi4 ', 'f+fbar -> ~chi+-1 + ~chi-+1 ',
1547 2'f+fbar -> ~chi+-2 + ~chi-+2 ', 'f+fbar -> ~chi+-1 + ~chi-+2 ',
1548 2'q + qbar'' -> ~chi1 + ~chi+-1', 'q + qbar'' -> ~chi2 + ~chi+-1',
1549 3'q + qbar'' -> ~chi3 + ~chi+-1', 'q + qbar'' -> ~chi4 + ~chi+-1',
1550 3'q + qbar'' -> ~chi1 + ~chi+-2', 'q + qbar'' -> ~chi2 + ~chi+-2',
1551 3'q + qbar'' -> ~chi3 + ~chi+-2', 'q + qbar'' -> ~chi4 + ~chi+-2',
1552 3'q + qbar -> ~chi1 + ~g ', 'q + qbar -> ~chi2 + ~g ',
1553 3'q + qbar -> ~chi3 + ~g ', 'q + qbar -> ~chi4 + ~g '/
1554 DATA (PROC(I),I=241,260)/
1555 4'q + qbar'' -> ~chi+-1 + ~g ', 'q + qbar'' -> ~chi+-2 + ~g ',
1556 4'q + qbar -> ~g + ~g ', 'g + g -> ~g + ~g ',
1557 4' ', 'qj + g -> ~qj_L + ~chi1 ',
1558 4'qj + g -> ~qj_R + ~chi1 ', 'qj + g -> ~qj_L + ~chi2 ',
1559 4'qj + g -> ~qj_R + ~chi2 ', 'qj + g -> ~qj_L + ~chi3 ',
1560 5'qj + g -> ~qj_R + ~chi3 ', 'qj + g -> ~qj_L + ~chi4 ',
1561 5'qj + g -> ~qj_R + ~chi4 ', 'qj + g -> ~qk_L + ~chi+-1 ',
1562 5'qj + g -> ~qk_R + ~chi+-1 ', 'qj + g -> ~qk_L + ~chi+-2 ',
1563 5'qj + g -> ~qk_R + ~chi+-2 ', 'qj + g -> ~qj_L + ~g ',
1564 5'qj + g -> ~qj_R + ~g ', ' '/
1565 DATA (PROC(I),I=261,300)/
1566 6'f + fbar -> ~t_1 + ~t_1bar ', 'f + fbar -> ~t_2 + ~t_2bar ',
1567 6'f + fbar -> ~t_1 + ~t_2bar ', 'g + g -> ~t_1 + ~t_1bar ',
1568 6'g + g -> ~t_2 + ~t_2bar ', ' ',
1569 6' ', ' ',
1570 6' ', ' ',
1571 7'qi + qj -> ~qi_L + ~qj_L ', 'qi + qj -> ~qi_R + ~qj_R ',
1572 7'qi + qj -> ~qi_L + ~qj_R ', 'qi+qjbar -> ~qi_L + ~qj_Lbar',
1573 7'qi+qjbar -> ~qi_R + ~qj_Rbar', 'qi+qjbar -> ~qi_L + ~qj_Rbar',
1574 7'f + fbar -> ~qi_L + ~qi_Lbar', 'f + fbar -> ~qi_R + ~qi_Rbar',
1575 7'g + g -> ~qi_L + ~qi_Lbar ', 'g + g -> ~qi_R + ~qi_Rbar ',
1576 8'b + qj -> ~b_1 + ~qj_L ', 'b + qj -> ~b_2 + ~qj_R ',
1577 8'b + qj -> ~b_1 + ~qj_R ', 'b + qjbar -> ~b_1 + ~qj_Lbar',
1578 8'b + qjbar -> ~b_2 + ~qj_Rbar', 'b + qjbar -> ~b_1 + ~qj_Rbar',
1579 8'f + fbar -> ~b_1 + ~b_1bar ', 'f + fbar -> ~b_2 + ~b_2bar ',
1580 8'g + g -> ~b_1 + ~b_1bar ', 'g + g -> ~b_2 + ~b_2bar ',
1581 9'b + b -> ~b_1 + ~b_1 ', 'b + b -> ~b_2 + ~b_2 ',
1582 9'b + b -> ~b_1 + ~b_2 ', 'b + g -> ~b_1 + ~g ',
1583 9'b + g -> ~b_2 + ~g ', 'b + bbar -> ~b_1 + ~b_2bar ',
1584 9'f + fbar'' -> H+/- + h0 ', 'f + fbar -> H+/- + H0 ',
1585 9'f + fbar -> A0 + h0 ', 'f + fbar -> A0 + H0 '/
1586 DATA (PROC(I),I=301,340)/
1587 &'f + fbar -> H+ + H- ', 39*' '/
1588 DATA (PROC(I),I=341,500)/
1589 4'l + l -> H_L++/-- ', 'l + l -> H_R++/-- ',
1590 4'l + gamma -> H_L++/-- e-/+ ', 'l + gamma -> H_R++/-- e-/+ ',
1591 4'l + gamma -> H_L++/-- mu-/+ ', 'l + gamma -> H_R++/-- mu-/+ ',
1592 4'l + gamma -> H_L++/-- tau-/+', 'l + gamma -> H_R++/-- tau-/+',
1593 4'f + fbar -> H_L++ + H_L-- ', 'f + fbar -> H_R++ + H_R-- ',
1594 5'f + f -> f'' + f'' + H_L++/-- ',
1595 5'f + f -> f'' + f'' + H_R++/-- ', 7*' ',
1596 6' ', 'f + fbar -> W_L+ W_L- ',
1597 6'f + fbar -> W_L+/- pi_T-/+ ', 'f + fbar -> pi_T+ pi_T- ',
1598 6'f + fbar -> gamma pi_T0 ', 'f + fbar -> gamma pi_T0'' ',
1599 6'f + fbar -> Z0 pi_T0 ', 'f + fbar -> Z0 pi_T0'' ',
1600 6'f + fbar -> W+/- pi_T-/+ ', ' ',
1601 7'f + fbar'' -> W_L+/- Z_L0 ', 'f + fbar'' -> W_L+/- pi_T0 ',
1602 7'f + fbar'' -> pi_T+/- Z_L0 ', 'f + fbar'' -> pi_T+/- pi_T0 ',
1603 7'f + fbar'' -> gamma pi_T+/- ', 'f + fbar'' -> Z0 pi_T+/- ',
1604 7'f + fbar'' -> W+/- pi_T0 ',
1605 7'f + fbar'' -> W+/- pi_T0'' ',
1606 7' ',' ',
1607 8 121*' '/
1608
1609C...Cross sections and slope offsets.
1610 DATA SIGT/294*0D0/
1611
1612C...Supersymmetry switches and parameters.
1613 DATA IMSS/0,
1614 & 0, 0, 0, 1, 0, 0, 0, 1, 0, 0,
1615 1 89*0/
1616 DATA RMSS/0D0,
1617 & 80D0,160D0,500D0,800D0,2D0,250D0,200D0,800D0,700D0,800D0,
1618 1 700D0,500D0,250D0,200D0,800D0,400D0,0D0,0.1D0,850D0,0.041D0,
1619 2 1D0,800D0,1D4,1D4,1D4,0D0,0D0,0D0,24D17,0D0,
1620 3 69*0D0/
1621
1622C...Data for histogramming routines.
1623 DATA IHIST/1000,20000,55,1/
1624 DATA INDX/1000*0/
1625
1626 END
1627
952cc209 1628C...PYTEST
1629C...A simple program (disguised as subroutine) to run at installation
1630C...as a check that the program works as intended.
1631
1632 SUBROUTINE PYTEST(MTEST)
1633
1634C...Double precision and integer declarations.
1635 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
1636 IMPLICIT INTEGER(I-N)
1637 INTEGER PYK,PYCHGE,PYCOMP
1638C...Commonblocks.
1639 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
1640 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1641 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
1642 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
1643 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
1644 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
1645 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
1646C...Local arrays.
1647 DIMENSION PSUM(5),PINI(6),PFIN(6)
1648
1649C...Save defaults for values that are changed.
1650 MSTJ1=MSTJ(1)
1651 MSTJ3=MSTJ(3)
1652 MSTJ11=MSTJ(11)
1653 MSTJ42=MSTJ(42)
1654 MSTJ43=MSTJ(43)
1655 MSTJ44=MSTJ(44)
1656 PARJ17=PARJ(17)
1657 PARJ22=PARJ(22)
1658 PARJ43=PARJ(43)
1659 PARJ54=PARJ(54)
1660 MST101=MSTJ(101)
1661 MST104=MSTJ(104)
1662 MST105=MSTJ(105)
1663 MST107=MSTJ(107)
1664 MST116=MSTJ(116)
1665
1666C...First part: loop over simple events to be generated.
1667 IF(MTEST.GE.1) CALL PYTABU(20)
1668 NERR=0
1669 DO 180 IEV=1,500
1670
1671C...Reset parameter values. Switch on some nonstandard features.
1672 MSTJ(1)=1
1673 MSTJ(3)=0
1674 MSTJ(11)=1
1675 MSTJ(42)=2
1676 MSTJ(43)=4
1677 MSTJ(44)=2
1678 PARJ(17)=0.1D0
1679 PARJ(22)=1.5D0
1680 PARJ(43)=1D0
1681 PARJ(54)=-0.05D0
1682 MSTJ(101)=5
1683 MSTJ(104)=5
1684 MSTJ(105)=0
1685 MSTJ(107)=1
1686 IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3
1687
1688C...Ten events each for some single jets configurations.
1689 IF(IEV.LE.50) THEN
1690 ITY=(IEV+9)/10
1691 MSTJ(3)=-1
1692 IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2
1693 IF(ITY.EQ.1) CALL PY1ENT(1,1,15D0,0D0,0D0)
1694 IF(ITY.EQ.2) CALL PY1ENT(1,3101,15D0,0D0,0D0)
1695 IF(ITY.EQ.3) CALL PY1ENT(1,-2203,15D0,0D0,0D0)
1696 IF(ITY.EQ.4) CALL PY1ENT(1,-4,30D0,0D0,0D0)
1697 IF(ITY.EQ.5) CALL PY1ENT(1,21,15D0,0D0,0D0)
1698
1699C...Ten events each for some simple jet systems; string fragmentation.
1700 ELSEIF(IEV.LE.130) THEN
1701 ITY=(IEV-41)/10
1702 IF(ITY.EQ.1) CALL PY2ENT(1,1,-1,40D0)
1703 IF(ITY.EQ.2) CALL PY2ENT(1,4,-4,30D0)
1704 IF(ITY.EQ.3) CALL PY2ENT(1,2,2103,100D0)
1705 IF(ITY.EQ.4) CALL PY2ENT(1,21,21,40D0)
1706 IF(ITY.EQ.5) CALL PY3ENT(1,2101,21,-3203,30D0,0.6D0,0.8D0)
1707 IF(ITY.EQ.6) CALL PY3ENT(1,5,21,-5,40D0,0.9D0,0.8D0)
1708 IF(ITY.EQ.7) CALL PY3ENT(1,21,21,21,60D0,0.7D0,0.5D0)
1709 IF(ITY.EQ.8) CALL PY4ENT(1,2,21,21,-2,40D0,
1710 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
1711
1712C...Seventy events with independent fragmentation and momentum cons.
1713 ELSEIF(IEV.LE.200) THEN
1714 ITY=1+(IEV-131)/16
1715 MSTJ(2)=1+MOD(IEV-131,4)
1716 MSTJ(3)=1+MOD((IEV-131)/4,4)
1717 IF(ITY.EQ.1) CALL PY2ENT(1,4,-5,40D0)
1718 IF(ITY.EQ.2) CALL PY3ENT(1,3,21,-3,40D0,0.9D0,0.4D0)
1719 IF(ITY.EQ.3) CALL PY4ENT(1,2,21,21,-2,40D0,
1720 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
1721 IF(ITY.GE.4) CALL PY4ENT(1,2,-3,3,-2,40D0,
1722 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
1723
1724C...A hundred events with random jets (check invariant mass).
1725 ELSEIF(IEV.LE.300) THEN
1726 100 DO 110 J=1,5
1727 PSUM(J)=0D0
1728 110 CONTINUE
1729 NJET=2D0+6D0*PYR(0)
1730 DO 130 I=1,NJET
1731 KFL=21
1732 IF(I.EQ.1) KFL=INT(1D0+4D0*PYR(0))
1733 IF(I.EQ.NJET) KFL=-INT(1D0+4D0*PYR(0))
1734 EJET=5D0+20D0*PYR(0)
1735 THETA=ACOS(2D0*PYR(0)-1D0)
1736 PHI=6.2832D0*PYR(0)
1737 IF(I.LT.NJET) CALL PY1ENT(-I,KFL,EJET,THETA,PHI)
1738 IF(I.EQ.NJET) CALL PY1ENT(I,KFL,EJET,THETA,PHI)
1739 IF(I.EQ.1.OR.I.EQ.NJET) MSTJ(93)=1
1740 IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+PYMASS(KFL)
1741 DO 120 J=1,4
1742 PSUM(J)=PSUM(J)+P(I,J)
1743 120 CONTINUE
1744 130 CONTINUE
1745 IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT.
1746 & (PSUM(5)+PARJ(32))**2) GOTO 100
1747
1748C...Fifty e+e- continuum events with matrix elements.
1749 ELSEIF(IEV.LE.350) THEN
1750 MSTJ(101)=2
1751 CALL PYEEVT(0,40D0)
1752
1753C...Fifty e+e- continuum event with varying shower options.
1754 ELSEIF(IEV.LE.400) THEN
1755 MSTJ(42)=1+MOD(IEV,2)
1756 MSTJ(43)=1+MOD(IEV/2,4)
1757 MSTJ(44)=MOD(IEV/8,3)
1758 CALL PYEEVT(0,90D0)
1759
1760C...Fifty e+e- continuum events with coherent shower.
1761 ELSEIF(IEV.LE.450) THEN
1762 CALL PYEEVT(0,500D0)
1763
1764C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
1765 ELSE
1766 CALL PYONIA(5,9.46D0)
1767 ENDIF
1768
1769C...Generate event. Find total momentum, energy and charge.
1770 DO 140 J=1,4
1771 PINI(J)=PYP(0,J)
1772 140 CONTINUE
1773 PINI(6)=PYP(0,6)
1774 CALL PYEXEC
1775 DO 150 J=1,4
1776 PFIN(J)=PYP(0,J)
1777 150 CONTINUE
1778 PFIN(6)=PYP(0,6)
1779
1780C...Check conservation of energy, momentum and charge;
1781C...usually exact, but only approximate for single jets.
1782 MERR=0
1783 IF(IEV.LE.50) THEN
1784 IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.10D0)
1785 & MERR=MERR+1
1786 EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)
1787 IF(EPZREM.LT.0D0.OR.EPZREM.GT.2D0*PARJ(31)) MERR=MERR+1
1788 IF(ABS(PFIN(6)-PINI(6)).GT.2.1D0) MERR=MERR+1
1789 ELSE
1790 DO 160 J=1,4
1791 IF(ABS(PFIN(J)-PINI(J)).GT.0.0001D0*PINI(4)) MERR=MERR+1
1792 160 CONTINUE
1793 IF(ABS(PFIN(6)-PINI(6)).GT.0.1D0) MERR=MERR+1
1794 ENDIF
1795 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
1796 & (PFIN(J),J=1,4),PFIN(6)
1797
1798C...Check that all KF codes are known ones, and that partons/particles
1799C...satisfy energy-momentum-mass relation. Store particle statistics.
1800 DO 170 I=1,N
1801 IF(K(I,1).GT.20) GOTO 170
1802 IF(PYCOMP(K(I,2)).EQ.0) THEN
1803 WRITE(MSTU(11),5100) I
1804 MERR=MERR+1
1805 ENDIF
1806 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
1807 IF(ABS(PD).GT.MAX(0.1D0,0.001D0*P(I,4)**2).OR.P(I,4).LT.0D0)
1808 & THEN
1809 WRITE(MSTU(11),5200) I
1810 MERR=MERR+1
1811 ENDIF
1812 170 CONTINUE
1813 IF(MTEST.GE.1) CALL PYTABU(21)
1814
1815C...List all erroneous events and some normal ones.
1816 IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN
1817 IF(MERR.GE.1) WRITE(MSTU(11),6400)
1818 CALL PYLIST(2)
1819 ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN
1820 CALL PYLIST(1)
1821 ENDIF
1822
1823C...Stop execution if too many errors.
1824 IF(MERR.NE.0) NERR=NERR+1
1825 IF(NERR.GE.10) THEN
1826 WRITE(MSTU(11),6300)
1827 CALL PYLIST(1)
1828 STOP
1829 ENDIF
1830 180 CONTINUE
1831
1832C...Summarize result of run.
1833 IF(MTEST.GE.1) CALL PYTABU(22)
1834
1835C...Reset commonblock variables changed during run.
1836 MSTJ(1)=MSTJ1
1837 MSTJ(3)=MSTJ3
1838 MSTJ(11)=MSTJ11
1839 MSTJ(42)=MSTJ42
1840 MSTJ(43)=MSTJ43
1841 MSTJ(44)=MSTJ44
1842 PARJ(17)=PARJ17
1843 PARJ(22)=PARJ22
1844 PARJ(43)=PARJ43
1845 PARJ(54)=PARJ54
1846 MSTJ(101)=MST101
1847 MSTJ(104)=MST104
1848 MSTJ(105)=MST105
1849 MSTJ(107)=MST107
1850 MSTJ(116)=MST116
1851
1852C...Second part: complete events of various kinds.
1853C...Common initial values. Loop over initiating conditions.
1854 MSTP(122)=MAX(0,MIN(2,MTEST))
1855 MDCY(PYCOMP(111),1)=0
1856 DO 230 IPROC=1,8
1857
1858C...Reset process type, kinematics cuts, and the flags used.
1859 MSEL=0
1860 DO 190 ISUB=1,500
1861 MSUB(ISUB)=0
1862 190 CONTINUE
1863 CKIN(1)=2D0
1864 CKIN(3)=0D0
1865 MSTP(2)=1
1866 MSTP(11)=0
1867 MSTP(33)=0
1868 MSTP(81)=1
1869 MSTP(82)=1
1870 MSTP(111)=1
1871 MSTP(131)=0
1872 MSTP(133)=0
1873 PARP(131)=0.01D0
1874
1875C...Prompt photon production at fixed target.
1876 IF(IPROC.EQ.1) THEN
1877 PZSUM=300D0
1878 PESUM=SQRT(PZSUM**2+PYMASS(211)**2)+PYMASS(2212)
1879 PQSUM=2D0
1880 MSEL=10
1881 CKIN(3)=5D0
1882 CALL PYINIT('FIXT','pi+','p',PZSUM)
1883
1884C...QCD processes at ISR energies.
1885 ELSEIF(IPROC.EQ.2) THEN
1886 PESUM=63D0
1887 PZSUM=0D0
1888 PQSUM=2D0
1889 MSEL=1
1890 CKIN(3)=5D0
1891 CALL PYINIT('CMS','p','p',PESUM)
1892
1893C...W production + multiple interactions at CERN Collider.
1894 ELSEIF(IPROC.EQ.3) THEN
1895 PESUM=630D0
1896 PZSUM=0D0
1897 PQSUM=0D0
1898 MSEL=12
1899 CKIN(1)=20D0
1900 MSTP(82)=4
1901 MSTP(2)=2
1902 MSTP(33)=3
1903 CALL PYINIT('CMS','p','pbar',PESUM)
1904
1905C...W/Z gauge boson pairs + pileup events at the Tevatron.
1906 ELSEIF(IPROC.EQ.4) THEN
1907 PESUM=1800D0
1908 PZSUM=0D0
1909 PQSUM=0D0
1910 MSUB(22)=1
1911 MSUB(23)=1
1912 MSUB(25)=1
1913 CKIN(1)=200D0
1914 MSTP(111)=0
1915 MSTP(131)=1
1916 MSTP(133)=2
1917 PARP(131)=0.04D0
1918 CALL PYINIT('CMS','p','pbar',PESUM)
1919
1920C...Higgs production at LHC.
1921 ELSEIF(IPROC.EQ.5) THEN
1922 PESUM=15400D0
1923 PZSUM=0D0
1924 PQSUM=2D0
1925 MSUB(3)=1
1926 MSUB(102)=1
1927 MSUB(123)=1
1928 MSUB(124)=1
1929 PMAS(25,1)=300D0
1930 CKIN(1)=200D0
1931 MSTP(81)=0
1932 MSTP(111)=0
1933 CALL PYINIT('CMS','p','p',PESUM)
1934
1935C...Z' production at SSC.
1936 ELSEIF(IPROC.EQ.6) THEN
1937 PESUM=40000D0
1938 PZSUM=0D0
1939 PQSUM=2D0
1940 MSEL=21
1941 PMAS(32,1)=600D0
1942 CKIN(1)=400D0
1943 MSTP(81)=0
1944 MSTP(111)=0
1945 CALL PYINIT('CMS','p','p',PESUM)
1946
1947C...W pair production at 1 TeV e+e- collider.
1948 ELSEIF(IPROC.EQ.7) THEN
1949 PESUM=1000D0
1950 PZSUM=0D0
1951 PQSUM=0D0
1952 MSUB(25)=1
1953 MSUB(69)=1
1954 MSTP(11)=1
1955 CALL PYINIT('CMS','e+','e-',PESUM)
1956
1957C...Deep inelastic scattering at a LEP+LHC ep collider.
1958 ELSEIF(IPROC.EQ.8) THEN
1959 P(1,1)=0D0
1960 P(1,2)=0D0
1961 P(1,3)=8000D0
1962 P(2,1)=0D0
1963 P(2,2)=0D0
1964 P(2,3)=-80D0
1965 PESUM=8080D0
1966 PZSUM=7920D0
1967 PQSUM=0D0
1968 MSUB(10)=1
1969 CKIN(3)=50D0
1970 MSTP(111)=0
1971 CALL PYINIT('USER','p','e-',PESUM)
1972 ENDIF
1973
1974C...Generate 20 events of each required type.
1975 DO 220 IEV=1,20
1976 CALL PYEVNT
1977 PESUMM=PESUM
1978 IF(IPROC.EQ.4) PESUMM=MSTI(41)*PESUM
1979
1980C...Check conservation of energy/momentum/flavour.
1981 PINI(1)=0D0
1982 PINI(2)=0D0
1983 PINI(3)=PZSUM
1984 PINI(4)=PESUMM
1985 PINI(6)=PQSUM
1986 DO 200 J=1,4
1987 PFIN(J)=PYP(0,J)
1988 200 CONTINUE
1989 PFIN(6)=PYP(0,6)
1990 MERR=0
1991 DEVE=ABS(PFIN(4)-PINI(4))+ABS(PFIN(3)-PINI(3))
1992 DEVT=ABS(PFIN(1)-PINI(1))+ABS(PFIN(2)-PINI(2))
1993 DEVQ=ABS(PFIN(6)-PINI(6))
1994 IF(DEVE.GT.2D-3*PESUM.OR.DEVT.GT.MAX(0.01D0,1D-4*PESUM).OR.
1995 & DEVQ.GT.0.1D0) MERR=1
1996 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
1997 & (PFIN(J),J=1,4),PFIN(6)
1998
1999C...Check that all KF codes are known ones, and that partons/particles
2000C...satisfy energy-momentum-mass relation.
2001 DO 210 I=1,N
2002 IF(K(I,1).GT.20) GOTO 210
2003 IF(PYCOMP(K(I,2)).EQ.0) THEN
2004 WRITE(MSTU(11),5100) I
2005 MERR=MERR+1
2006 ENDIF
2007 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2*
2008 & SIGN(1D0,P(I,5))
2009 IF(ABS(PD).GT.MAX(0.1D0,0.002D0*P(I,4)**2,0.002D0*P(I,5)**2)
2010 & .OR.(P(I,5).GE.0D0.AND.P(I,4).LT.0D0)) THEN
2011 WRITE(MSTU(11),5200) I
2012 MERR=MERR+1
2013 ENDIF
2014 210 CONTINUE
2015
2016C...Listing of erroneous events, and first event of each type.
2017 IF(MERR.GE.1) NERR=NERR+1
2018 IF(NERR.GE.10) THEN
2019 WRITE(MSTU(11),6300)
2020 CALL PYLIST(1)
2021 STOP
2022 ENDIF
2023 IF(MTEST.GE.1.AND.(MERR.GE.1.OR.IEV.EQ.1)) THEN
2024 IF(MERR.GE.1) WRITE(MSTU(11),6400)
2025 CALL PYLIST(1)
2026 ENDIF
2027 220 CONTINUE
2028
2029C...List statistics for each process type.
2030 IF(MTEST.GE.1) CALL PYSTAT(1)
2031 230 CONTINUE
2032
2033C...Summarize result of run.
2034 IF(NERR.EQ.0) WRITE(MSTU(11),6500)
2035 IF(NERR.GT.0) WRITE(MSTU(11),6600) NERR
2036
2037C...Format statements for output.
2038 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
2039 &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X,
2040 &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X,
2041 &4(1X,F12.5),1X,F8.2)
2042 5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
2043 5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
2044 &'kinematics')
2045 6300 FORMAT(/5X,'This is the tenth error experienced! Something is ',
2046 &'wrong.'/5X,'Execution will be stopped after listing of event.')
2047 6400 FORMAT(5X,'Faulty event follows:')
2048 6500 FORMAT(//5X,'End result of PYTEST: no errors detected.')
2049 6600 FORMAT(//5X,'End result of PYTEST:',I2,' errors detected.'/
2050 &5X,'This should not have happened!')
2051
2052 RETURN
2053 END
2054
2055C*********************************************************************
2056
2057C...PYHEPC
2058C...Converts PYTHIA event record contents to or from
2059C...the standard event record commonblock.
2060
2061 SUBROUTINE PYHEPC(MCONV)
2062
2063C...Double precision and integer declarations.
2064 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2065 IMPLICIT INTEGER(I-N)
2066 INTEGER PYK,PYCHGE,PYCOMP
2067C...Commonblocks.
2068 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2069 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2070 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2071 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
2072C...HEPEVT commonblock.
2073 PARAMETER (NMXHEP=4000)
2074 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
2075 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
2076 DOUBLE PRECISION PHEP,VHEP
2077 SAVE /HEPEVT/
2078
2079C...Conversion from PYTHIA to standard, the easy part.
2080 IF(MCONV.EQ.1) THEN
2081 NEVHEP=0
2082 IF(N.GT.NMXHEP) CALL PYERRM(8,
2083 & '(PYHEPC:) no more space in /HEPEVT/')
2084 NHEP=MIN(N,NMXHEP)
2085 DO 140 I=1,NHEP
2086 ISTHEP(I)=0
2087 IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1
2088 IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2
2089 IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3
2090 IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1)
2091 IDHEP(I)=K(I,2)
2092 JMOHEP(1,I)=K(I,3)
2093 JMOHEP(2,I)=0
2094 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
2095 JDAHEP(1,I)=K(I,4)
2096 JDAHEP(2,I)=K(I,5)
2097 ELSE
2098 JDAHEP(1,I)=0
2099 JDAHEP(2,I)=0
2100 ENDIF
2101 DO 100 J=1,5
2102 PHEP(J,I)=P(I,J)
2103 100 CONTINUE
2104 DO 110 J=1,4
2105 VHEP(J,I)=V(I,J)
2106 110 CONTINUE
2107
2108C...Check if new event (from pileup).
2109 IF(I.EQ.1) THEN
2110 INEW=1
2111 ELSE
2112 IF(K(I,1).EQ.21.AND.K(I-1,1).NE.21) INEW=I
2113 ENDIF
2114
2115C...Fill in missing mother information.
2116 IF(I.GE.INEW+2.AND.K(I,1).EQ.21.AND.K(I,3).EQ.0) THEN
2117 IMO1=I-2
2118 IF(I.GE.INEW+3.AND.K(I-1,1).EQ.21.AND.K(I-1,3).EQ.0)
2119 & IMO1=IMO1-1
2120 JMOHEP(1,I)=IMO1
2121 JMOHEP(2,I)=IMO1+1
2122 ELSEIF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN
2123 I1=K(I,3)-1
2124 120 I1=I1+1
2125 IF(I1.GE.I) CALL PYERRM(8,
2126 & '(PYHEPC:) translation of inconsistent event history')
2127 IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 120
2128 KC=PYCOMP(K(I1,2))
2129 IF(I1.LT.I.AND.KC.EQ.0) GOTO 120
2130 IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 120
2131 JMOHEP(2,I)=I1
2132 ELSEIF(K(I,2).EQ.94) THEN
2133 NJET=2
2134 IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3
2135 IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4
2136 JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5))
2137 IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)=
2138 & MOD(K(I+1,4)/MSTU(5),MSTU(5))
2139 ENDIF
2140
2141C...Fill in missing daughter information.
2142 IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN
2143 DO 130 I1=JDAHEP(1,I),JDAHEP(2,I)
2144 I2=MOD(K(I1,4)/MSTU(5),MSTU(5))
2145 JDAHEP(1,I2)=I
2146 130 CONTINUE
2147 ENDIF
2148 IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 140
2149 I1=JMOHEP(1,I)
2150 IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 140
2151 IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 140
2152 IF(JDAHEP(1,I1).EQ.0) THEN
2153 JDAHEP(1,I1)=I
2154 ELSE
2155 JDAHEP(2,I1)=I
2156 ENDIF
2157 140 CONTINUE
2158 DO 150 I=1,NHEP
2159 IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 150
2160 IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I)
2161 150 CONTINUE
2162
2163C...Conversion from standard to PYTHIA, the easy part.
2164 ELSE
2165 IF(NHEP.GT.MSTU(4)) CALL PYERRM(8,
2166 & '(PYHEPC:) no more space in /PYJETS/')
2167 N=MIN(NHEP,MSTU(4))
2168 NKQ=0
2169 KQSUM=0
2170 DO 180 I=1,N
2171 K(I,1)=0
2172 IF(ISTHEP(I).EQ.1) K(I,1)=1
2173 IF(ISTHEP(I).EQ.2) K(I,1)=11
2174 IF(ISTHEP(I).EQ.3) K(I,1)=21
2175 K(I,2)=IDHEP(I)
2176 K(I,3)=JMOHEP(1,I)
2177 K(I,4)=JDAHEP(1,I)
2178 K(I,5)=JDAHEP(2,I)
2179 DO 160 J=1,5
2180 P(I,J)=PHEP(J,I)
2181 160 CONTINUE
2182 DO 170 J=1,4
2183 V(I,J)=VHEP(J,I)
2184 170 CONTINUE
2185 V(I,5)=0D0
2186 IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN
2187 I1=JDAHEP(1,I)
2188 IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))*
2189 & PHEP(5,I)/PHEP(4,I)
2190 ENDIF
2191
2192C...Fill in missing information on colour connection in jet systems.
2193 IF(ISTHEP(I).EQ.1) THEN
2194 KC=PYCOMP(K(I,2))
2195 KQ=0
2196 IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
2197 IF(KQ.NE.0) NKQ=NKQ+1
2198 IF(KQ.NE.2) KQSUM=KQSUM+KQ
2199 IF(KQ.NE.0.AND.KQSUM.NE.0) THEN
2200 K(I,1)=2
2201 ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN
2202 IF(K(I+1,2).EQ.21) K(I,1)=2
2203 ENDIF
2204 ENDIF
2205 180 CONTINUE
2206 IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL PYERRM(8,
2207 & '(PYHEPC:) input parton configuration not colour singlet')
2208 ENDIF
2209
2210 END
2211
2212C*********************************************************************
2213
2214C...PYINIT
2215C...Initializes the generation procedure; finds maxima of the
2216C...differential cross-sections to be used for weighting.
2217
2218 SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN)
2219
2220C...Double precision and integer declarations.
2221 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2222 IMPLICIT INTEGER(I-N)
2223 INTEGER PYK,PYCHGE,PYCOMP
2224C...Commonblocks.
2225 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2226 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2227 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
2228 COMMON/PYDAT4/CHAF(500,2)
2229 CHARACTER CHAF*16
2230 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2231 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2232 COMMON/PYINT1/MINT(400),VINT(400)
2233 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2234 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2235 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
2236 &/PYINT1/,/PYINT2/,/PYINT5/
2237C...Local arrays and character variables.
2238 DIMENSION ALAMIN(20),NFIN(20)
2239 CHARACTER*(*) FRAME,BEAM,TARGET
2240 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHLH(2)*6
2241
2242C...Interface to PDFLIB.
2243 COMMON/W50512/QCDL4,QCDL5
2244 SAVE /W50512/
2245 DOUBLE PRECISION VALUE(20),QCDL4,QCDL5
2246 CHARACTER*20 PARM(20)
2247 DATA VALUE/20*0D0/,PARM/20*' '/
2248
2249C...Data:Lambda and n_f values for parton distributions..
2250 DATA ALAMIN/0.177D0,0.239D0,0.247D0,0.2322D0,0.248D0,0.248D0,
2251 &0.192D0,0.326D0,2*0.2D0,0.2D0,0.2D0,0.29D0,0.2D0,0.4D0,5*0.2D0/,
2252 &NFIN/20*4/
2253 DATA CHLH/'lepton','hadron'/
2254
2255C...Reset MINT and VINT arrays. Write headers.
2256 DO 100 J=1,400
2257 MINT(J)=0
2258 VINT(J)=0D0
2259 100 CONTINUE
2260 IF(MSTU(12).GE.1) CALL PYLIST(0)
2261 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
2262
2263C...Maximum 4 generations; set maximum number of allowed flavours.
2264 MSTP(1)=MIN(4,MSTP(1))
2265 MSTU(114)=MIN(MSTU(114),2*MSTP(1))
2266 MSTP(58)=MIN(MSTP(58),2*MSTP(1))
2267
2268C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
2269 DO 120 I=-20,20
2270 VINT(180+I)=0D0
2271 IA=IABS(I)
2272 IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN
2273 DO 110 J=1,MSTP(1)
2274 IB=2*J-1+MOD(IA,2)
2275 IF(IB.GE.6.AND.MSTP(9).EQ.0) GOTO 110
2276 IPM=(5-ISIGN(1,I))/2
2277 IDC=J+MDCY(IA,2)+2
2278 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)=
2279 & VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2)
2280 110 CONTINUE
2281 ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN
2282 VINT(180+I)=1D0
2283 ENDIF
2284 120 CONTINUE
2285
2286C...Initialize parton distributions: PDFLIB.
2287 IF(MSTP(52).EQ.2) THEN
2288 PARM(1)='NPTYPE'
2289 VALUE(1)=1
2290 PARM(2)='NGROUP'
2291 VALUE(2)=MSTP(51)/1000
2292 PARM(3)='NSET'
2293 VALUE(3)=MOD(MSTP(51),1000)
2294 PARM(4)='TMAS'
2295 VALUE(4)=PMAS(6,1)
fd658fdb 2296C...ALICE
2297 CALL PDFSET_ALICE(PARM,VALUE)
952cc209 2298 MINT(93)=1000000+MSTP(51)
2299 ENDIF
2300
2301C...Choose Lambda value to use in alpha-strong.
2302 MSTU(111)=MSTP(2)
2303 IF(MSTP(3).GE.2) THEN
2304 ALAM=0.2D0
2305 NF=4
2306 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
2307 ALAM=ALAMIN(MSTP(51))
2308 NF=NFIN(MSTP(51))
2309 ELSEIF(MSTP(52).EQ.2) THEN
2310 ALAM=QCDL4
2311 NF=4
2312 ENDIF
2313 PARP(1)=ALAM
2314 PARP(61)=ALAM
2315 PARP(72)=ALAM
2316 PARU(112)=ALAM
2317 MSTU(112)=NF
2318 IF(MSTP(3).EQ.3) PARJ(81)=ALAM
2319 ENDIF
2320
2321C...Initialize the SUSY generation: couplings, masses,
2322C...decay modes, branching ratios, and so on.
2323 CALL PYMSIN
2324
2325C...Initialize widths and partial widths for resonances.
2326 CALL PYINRE
2327C...Set Z0 mass and width for e+e- routines.
2328 PARJ(123)=PMAS(23,1)
2329 PARJ(124)=PMAS(23,2)
2330
2331C...Identify beam and target particles and frame of process.
2332 CHFRAM=FRAME//' '
2333 CHBEAM=BEAM//' '
2334 CHTARG=TARGET//' '
2335 CALL PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
2336 IF(MINT(65).EQ.1) GOTO 170
2337
2338C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
2339C...For e-gamma allow 2 alternatives.
2340 MINT(121)=1
2341 IF(MSTP(14).EQ.10.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2342 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2343 & (IABS(MINT(11)).GE.28.OR.IABS(MINT(12)).GE.28)) MINT(121)=3
2344 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=6
2345 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2346 & (IABS(MINT(11)).EQ.11.OR.IABS(MINT(12)).EQ.11)) MINT(121)=2
2347 ELSEIF(MSTP(14).EQ.20.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2348 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2349 & (IABS(MINT(11)).GE.28.OR.IABS(MINT(12)).GE.28)) MINT(121)=3
2350 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=9
2351 ELSEIF(MSTP(14).EQ.25.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2352 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2353 & (IABS(MINT(11)).GE.28.OR.IABS(MINT(12)).GE.28)) MINT(121)=2
2354 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=4
2355 ELSEIF(MSTP(14).EQ.30.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2356 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2357 & (IABS(MINT(11)).GE.28.OR.IABS(MINT(12)).GE.28)) MINT(121)=4
2358 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=13
2359 ENDIF
2360 MINT(123)=MSTP(14)
2361 IF((MSTP(14).EQ.10.OR.MSTP(14).EQ.20.OR.MSTP(14).EQ.25.OR.
2362 &MSTP(14).EQ.30).AND.MSEL.NE.1.AND.MSEL.NE.2) MINT(123)=0
2363 IF(MSTP(14).GE.11.AND.MSTP(14).LE.19) THEN
2364 IF(MSTP(14).EQ.11) MINT(123)=0
2365 IF(MSTP(14).EQ.12.OR.MSTP(14).EQ.14) MINT(123)=5
2366 IF(MSTP(14).EQ.13.OR.MSTP(14).EQ.17) MINT(123)=6
2367 IF(MSTP(14).EQ.15) MINT(123)=2
2368 IF(MSTP(14).EQ.16.OR.MSTP(14).EQ.18) MINT(123)=7
2369 IF(MSTP(14).EQ.19) MINT(123)=3
2370 ELSEIF(MSTP(14).GE.21.AND.MSTP(14).LE.24) THEN
2371 IF(MSTP(14).EQ.21) MINT(123)=0
2372 IF(MSTP(14).EQ.22.OR.MSTP(14).EQ.23) MINT(123)=4
2373 IF(MSTP(14).EQ.24) MINT(123)=1
2374 ELSEIF(MSTP(14).GE.26.AND.MSTP(14).LE.29) THEN
2375 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28) MINT(123)=8
2376 IF(MSTP(14).EQ.27.OR.MSTP(14).EQ.29) MINT(123)=9
2377 ENDIF
2378
2379C...Set up kinematics of process.
2380 CALL PYINKI(0)
2381
2382C...Set up kinematics for photons inside leptons.
2383 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(1,WTGAGA)
2384
2385C...Precalculate flavour selection weights.
2386 CALL PYKFIN
2387
2388C...Loop over gamma-p or gamma-gamma alternatives.
2389 CKIN3=CKIN(3)
2390 MSAV48=0
2391 DO 160 IGA=1,MINT(121)
2392 CKIN(3)=CKIN3
2393 MINT(122)=IGA
2394
2395C...Select partonic subprocesses to be included in the simulation.
2396 CALL PYINPR
2397 MINT(101)=1
2398 MINT(102)=1
2399 MINT(103)=MINT(11)
2400 MINT(104)=MINT(12)
2401
2402C...Count number of subprocesses on.
2403 MINT(48)=0
2404 DO 130 ISUB=1,500
2405 IF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
2406 & MSUB(ISUB).EQ.1.AND.MINT(121).GT.1) THEN
2407 MSUB(ISUB)=0
2408 ELSEIF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
2409 & MSUB(ISUB).EQ.1) THEN
2410 WRITE(MSTU(11),5200) ISUB,CHLH(MINT(41)),CHLH(MINT(42))
2411 STOP
2412 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
2413 WRITE(MSTU(11),5300) ISUB
2414 STOP
2415 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
2416 WRITE(MSTU(11),5400) ISUB
2417 STOP
2418 ELSEIF(MSUB(ISUB).EQ.1) THEN
2419 MINT(48)=MINT(48)+1
2420 ENDIF
2421 130 CONTINUE
2422 IF(MINT(121).EQ.1.AND.MINT(48).EQ.0) THEN
2423 WRITE(MSTU(11),5500)
2424 STOP
2425 ENDIF
2426 MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94)
2427 MSAV48=MSAV48+MINT(48)
2428
2429C...Reset variables for cross-section calculation.
2430 DO 150 I=0,500
2431 DO 140 J=1,3
2432 NGEN(I,J)=0
2433 XSEC(I,J)=0D0
2434 140 CONTINUE
2435 150 CONTINUE
2436
2437C...Find parametrized total cross-sections.
2438 CALL PYXTOT
2439 VINT(318)=VINT(317)
2440
2441C...Maxima of differential cross-sections.
2442 IF(MSTP(121).LE.1) CALL PYMAXI
2443
2444C...Initialize possibility of pileup events.
2445 IF(MINT(121).GT.1) MSTP(131)=0
2446 IF(MSTP(131).NE.0) CALL PYPILE(1)
2447
2448C...Initialize multiple interactions with variable impact parameter.
2449 IF(MINT(50).EQ.1.AND.(MINT(49).NE.0.OR.MSTP(131).NE.0).AND.
2450 & MSTP(82).GE.2) CALL PYMULT(1)
2451
2452C...Save results for gamma-p and gamma-gamma alternatives.
2453 IF(MINT(121).GT.1) CALL PYSAVE(1,IGA)
2454 160 CONTINUE
2455
2456C...Initialization finished.
2457 IF(MSAV48.EQ.0) THEN
2458 WRITE(MSTU(11),5500)
2459 STOP
2460 ENDIF
2461 170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600)
2462
2463C...Formats for initialization information.
2464 5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ',
2465 &'routines',1X,17('*'))
2466 5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,
2467 &'-',A6,' interactions.'/1X,'Execution stopped!')
2468 5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/
2469 &1X,'Execution stopped!')
2470 5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/
2471 &1X,'Execution stopped!')
2472 5500 FORMAT(1X,'Error: no subprocess switched on.'/
2473 &1X,'Execution stopped.')
2474 5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X,
2475 &22('*'))
2476
2477 RETURN
2478 END
2479
2480C*********************************************************************
2481
2482C...PYEVNT
2483C...Administers the generation of a high-pT event via calls to
2484C...a number of subroutines.
2485
2486 SUBROUTINE PYEVNT
2487
2488C...Double precision and integer declarations.
2489 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2490 IMPLICIT INTEGER(I-N)
2491 INTEGER PYK,PYCHGE,PYCOMP
2492C...Commonblocks.
2493 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2494 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2495 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2496 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2497 COMMON/PYINT1/MINT(400),VINT(400)
2498 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2499 COMMON/PYINT4/MWID(500),WIDS(500,5)
2500 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2501 COMMON/PYUPPR/NUP,KUP(20,7),NFUP,IFUP(10,2),PUP(20,5),Q2UP(0:10)
2502 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,
2503 &/PYINT4/,/PYINT5/,/PYUPPR/
2504C...Local array.
2505 DIMENSION VTX(4)
2506
2507C...Initial values for some counters.
2508 N=0
2509 MINT(5)=MINT(5)+1
2510 MINT(7)=0
2511 MINT(8)=0
2512 MINT(83)=0
2513 MINT(84)=MSTP(126)
2514 MSTU(24)=0
2515 MSTU70=0
2516 MSTJ14=MSTJ(14)
2517
2518C...If variable energies: redo incoming kinematics and cross-section.
2519 MSTI(61)=0
2520 IF(MSTP(171).EQ.1) THEN
2521 CALL PYINKI(1)
2522 IF(MSTI(61).EQ.1) THEN
2523 MINT(5)=MINT(5)-1
2524 RETURN
2525 ENDIF
2526 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
2527 CALL PYXTOT
2528 ENDIF
2529
2530C...Loop over number of pileup events; check space left.
2531 IF(MSTP(131).LE.0) THEN
2532 NPILE=1
2533 ELSE
2534 CALL PYPILE(2)
2535 NPILE=MINT(81)
2536 ENDIF
2537 DO 260 IPILE=1,NPILE
2538 IF(MINT(84)+100.GE.MSTU(4)) THEN
2539 CALL PYERRM(11,
2540 & '(PYEVNT:) no more space in PYJETS for pileup events')
2541 IF(MSTU(21).GE.1) GOTO 270
2542 ENDIF
2543 MINT(82)=IPILE
2544
2545C...Generate variables of hard scattering.
2546 MINT(51)=0
2547 MSTI(52)=0
2548 100 CONTINUE
2549 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
2550 MINT(31)=0
2551 MINT(51)=0
2552 MINT(57)=0
2553 CALL PYRAND
2554 IF(MSTI(61).EQ.1) THEN
2555 MINT(5)=MINT(5)-1
2556 RETURN
2557 ENDIF
2558 IF(MINT(51).EQ.2) RETURN
2559 ISUB=MINT(1)
2560 IF(MSTP(111).EQ.-1) GOTO 250
2561
2562 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
2563C...Hard scattering (including low-pT):
2564C...reconstruct kinematics and colour flow of hard scattering.
2565 MINT31=MINT(31)
2566 110 MINT(31)=MINT31
2567 MINT(51)=0
2568 CALL PYSCAT
2569 IF(MINT(51).EQ.1) GOTO 100
2570 IPU1=MINT(84)+1
2571 IPU2=MINT(84)+2
2572 IF(ISUB.EQ.95) GOTO 130
2573
2574C...Showering of initial state partons (optional).
2575 ALAMSV=PARJ(81)
2576 PARJ(81)=PARP(72)
2577 IF(MSTP(61).GE.1.AND.MINT(47).GE.2) CALL PYSSPA(IPU1,IPU2)
2578 PARJ(81)=ALAMSV
2579 IF(MINT(51).EQ.1) GOTO 100
2580
2581C...Showering of final state partons (optional).
2582 ALAMSV=PARJ(81)
2583 PARJ(81)=PARP(72)
2584 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.2.AND.ISET(ISUB).LE.10)
2585 & THEN
2586 IPU3=MINT(84)+3
2587 IPU4=MINT(84)+4
2588 IF(ISET(ISUB).EQ.5) IPU4=-3
2589 QMAX=VINT(55)
2590 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
2591 CALL PYSHOW(IPU3,IPU4,QMAX)
2592 ELSEIF(MSTP(71).GE.1.AND.ISET(ISUB).EQ.11.AND.NFUP.GE.1) THEN
2593 DO 120 IUP=1,NFUP
2594 IPU3=IFUP(IUP,1)+MINT(84)
2595 IPU4=IFUP(IUP,2)+MINT(84)
2596 QMAX=SQRT(MAX(0D0,Q2UP(IUP)))
2597 CALL PYSHOW(IPU3,IPU4,QMAX)
2598 120 CONTINUE
2599 ENDIF
2600 PARJ(81)=ALAMSV
2601
2602C...Decay of final state resonances.
2603 MINT(32)=0
2604 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) CALL PYRESD(0)
2605 IF(MINT(51).EQ.1) GOTO 100
2606 MINT(52)=N
2607
2608C...Multiple interactions.
2609 IF(MSTP(81).GE.1.AND.MINT(50).EQ.1) CALL PYMULT(6)
2610 MINT(53)=N
2611
2612C...Hadron remnants and primordial kT.
2613 130 CALL PYREMN(IPU1,IPU2)
2614 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO 110
2615 IF(MINT(51).EQ.1) GOTO 100
2616
2617 ELSEIF(ISUB.NE.99) THEN
2618C...Diffractive and elastic scattering.
2619 CALL PYDIFF
2620
2621 ELSE
2622C...DIS scattering (photon flux external).
2623 CALL PYDISG
2624 IF(MINT(51).EQ.1) GOTO 100
2625 ENDIF
2626
2627C...Check that no odd resonance left undecayed.
2628 IF(MSTP(111).GE.1) THEN
2629 NFIX=N
2630 DO 140 I=MINT(84)+1,NFIX
2631 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
2632 & K(I,2).NE.22) THEN
2633 IF(MWID(PYCOMP(K(I,2))).NE.0) THEN
2634 CALL PYRESD(I)
2635 IF(MINT(51).EQ.1) GOTO 100
2636 ENDIF
2637 ENDIF
2638 140 CONTINUE
2639 ENDIF
2640
2641C...Boost hadronic subsystem to overall rest frame.
2642C..(Only relevant when photon inside lepton beam.)
2643 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
2644
2645C...Recalculate energies from momenta and masses (if desired).
2646 IF(MSTP(113).GE.1) THEN
2647 DO 150 I=MINT(83)+1,N
2648 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
2649 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
2650 150 CONTINUE
2651 NRECAL=N
2652 ENDIF
2653
2654C...Rearrange partons along strings, check invariant mass cuts.
2655 MSTU(28)=0
2656 IF(MSTP(111).LE.0) MSTJ(14)=-1
2657 CALL PYPREP(MINT(84)+1)
2658 MSTJ(14)=MSTJ14
2659 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
2660 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
2661 DO 180 I=MINT(84)+1,N
2662 IF(K(I,2).EQ.94) THEN
2663 DO 170 I1=I+1,MIN(N,I+3)
2664 IF(K(I1,3).EQ.I) THEN
2665 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
2666 IF(K(I1,3).EQ.0) THEN
2667 DO 160 II=MINT(84)+1,I-1
2668 IF(K(II,2).EQ.K(I1,2)) THEN
2669 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
2670 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
2671 ENDIF
2672 160 CONTINUE
2673 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
2674 ENDIF
2675 ENDIF
2676 170 CONTINUE
2677 ENDIF
2678 180 CONTINUE
2679 CALL PYEDIT(12)
2680 CALL PYEDIT(14)
2681 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
2682 IF(MSTP(125).EQ.0) MINT(4)=0
2683 DO 200 I=MINT(83)+1,N
2684 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
2685 DO 190 I1=I+1,N
2686 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
2687 IF(K(I1,3).EQ.I) K(I,5)=I1
2688 190 CONTINUE
2689 ENDIF
2690 200 CONTINUE
2691 ENDIF
2692
2693C...Introduce separators between sections in PYLIST event listing.
2694 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
2695 MSTU70=1
2696 MSTU(71)=N
2697 ELSEIF(IPILE.EQ.1) THEN
2698 MSTU70=3
2699 MSTU(71)=2
2700 MSTU(72)=MINT(4)
2701 MSTU(73)=N
2702 ENDIF
2703
2704C...Go back to lab frame (needed for vertices, also in fragmentation).
2705 CALL PYFRAM(1)
2706
2707C...Set nonvanishing production vertex (optional).
2708 IF(MSTP(151).EQ.1) THEN
2709 DO 210 J=1,4
2710 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
2711 & SIN(PARU(2)*PYR(0))
2712 210 CONTINUE
2713 DO 230 I=MINT(83)+1,N
2714 DO 220 J=1,4
2715 V(I,J)=V(I,J)+VTX(J)
2716 220 CONTINUE
2717 230 CONTINUE
2718 ENDIF
2719
2720C...Perform hadronization (if desired).
2721 IF(MSTP(111).GE.1) THEN
2722 CALL PYEXEC
2723 IF(MSTU(24).NE.0) GOTO 100
2724 ENDIF
2725 IF(MSTP(113).GE.1) THEN
2726 DO 240 I=NRECAL,N
2727 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
2728 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
2729 240 CONTINUE
2730 ENDIF
2731 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
2732
2733C...Store event information and calculate Monte Carlo estimates of
2734C...subprocess cross-sections.
2735 250 IF(IPILE.EQ.1) CALL PYDOCU
2736
2737C...Set counters for current pileup event and loop to next one.
2738 MSTI(41)=IPILE
2739 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
2740 IF(MSTU70.LT.10) THEN
2741 MSTU70=MSTU70+1
2742 MSTU(70+MSTU70)=N
2743 ENDIF
2744 MINT(83)=N
2745 MINT(84)=N+MSTP(126)
2746 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
2747 260 CONTINUE
2748
2749C...Generic information on pileup events. Reconstruct missing history.
2750 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
2751 PARI(91)=VINT(132)
2752 PARI(92)=VINT(133)
2753 PARI(93)=VINT(134)
2754 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
2755 ENDIF
2756 CALL PYEDIT(16)
2757
2758C...Transform to the desired coordinate frame.
2759 270 CALL PYFRAM(MSTP(124))
2760 MSTU(70)=MSTU70
2761 PARU(21)=VINT(1)
2762
2763 RETURN
2764 END
2765
2766C***********************************************************************
2767
2768C...PYSTAT
2769C...Prints out information about cross-sections, decay widths, branching
2770C...ratios, kinematical limits, status codes and parameter values.
2771
2772 SUBROUTINE PYSTAT(MSTAT)
2773
2774C...Double precision and integer declarations.
2775 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2776 IMPLICIT INTEGER(I-N)
2777 INTEGER PYK,PYCHGE,PYCOMP
2778C...Parameter statement to help give large particle numbers.
2779 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
2780C...Commonblocks.
2781 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2782 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2783 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
2784 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2785 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2786 COMMON/PYINT1/MINT(400),VINT(400)
2787 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2788 COMMON/PYINT4/MWID(500),WIDS(500,5)
2789 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2790 COMMON/PYINT6/PROC(0:500)
2791 CHARACTER PROC*28
2792 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
2793 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
2794 &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/
2795C...Local arrays, character variables and data.
2796 DIMENSION WDTP(0:200),WDTE(0:200,0:5)
2797 CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16,
2798 &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28,
2799 &PROGG9(13)*28,PROGG4(4)*28,PROGG2(2)*28,PROGP4(4)*28
2800 DATA PROGA/
2801 &'VMD/hadron * VMD ','VMD/hadron * direct ',
2802 &'VMD/hadron * anomalous ','direct * direct ',
2803 &'direct * anomalous ','anomalous * anomalous '/
2804 DATA DISGA/'e * VMD','e * anomalous'/
2805 DATA PROGG9/
2806 &'direct * direct ','direct * VMD ',
2807 &'direct * anomalous ','VMD * direct ',
2808 &'VMD * VMD ','VMD * anomalous ',
2809 &'anomalous * direct ','anomalous * VMD ',
2810 &'anomalous * anomalous ','DIS * VMD ',
2811 &'DIS * anomalous ','VMD * DIS ',
2812 &'anomalous * DIS '/
2813 DATA PROGG4/
2814 &'direct * direct ','direct * resolved ',
2815 &'resolved * direct ','resolved * resolved '/
2816 DATA PROGG2/
2817 &'direct * hadron ','resolved * hadron '/
2818 DATA PROGP4/
2819 &'VMD * hadron ','direct * hadron ',
2820 &'anomalous * hadron ','DIS * hadron '/
2821 DATA STATE/'----','off ','on ','on/+','on/-','on/1','on/2'/,
2822 &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
2823 &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ',
2824 &' y*_small ',' eta*_large ',' eta*_small ',
2825 &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ',
2826 &' x_2 ',' x_F ',' cos(theta_hard) ',
2827 &'m''_hard (GeV/c^2) ',' tau ',' y* ',
2828 &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ',
2829 &' tau'' '/
2830
2831C...Cross-sections.
2832 IF(MSTAT.LE.1) THEN
2833 IF(MINT(121).GT.1) CALL PYSAVE(5,0)
2834 WRITE(MSTU(11),5000)
2835 WRITE(MSTU(11),5100)
2836 WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)
2837 DO 100 I=1,500
2838 IF(MSUB(I).NE.1) GOTO 100
2839 WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)
2840 100 CONTINUE
2841 IF(MINT(121).GT.1) THEN
2842 WRITE(MSTU(11),5300)
2843 DO 110 IGA=1,MINT(121)
2844 CALL PYSAVE(3,IGA)
2845 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
2846 WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1),
2847 & XSEC(0,3)
2848 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
2849 WRITE(MSTU(11),5200) IGA,PROGG9(IGA),NGEN(0,3),NGEN(0,1),
2850 & XSEC(0,3)
2851 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.30) THEN
2852 WRITE(MSTU(11),5200) IGA,PROGP4(IGA),NGEN(0,3),NGEN(0,1),
2853 & XSEC(0,3)
2854 ELSEIF(MINT(121).EQ.4) THEN
2855 WRITE(MSTU(11),5200) IGA,PROGG4(IGA),NGEN(0,3),NGEN(0,1),
2856 & XSEC(0,3)
2857 ELSEIF(MINT(121).EQ.2) THEN
2858 WRITE(MSTU(11),5200) IGA,PROGG2(IGA),NGEN(0,3),NGEN(0,1),
2859 & XSEC(0,3)
2860 ELSE
2861 WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1),
2862 & XSEC(0,3)
2863 ENDIF
2864 110 CONTINUE
2865 CALL PYSAVE(5,0)
2866 ENDIF
2867 WRITE(MSTU(11),5400) 1D0-DBLE(NGEN(0,3))/
2868 & MAX(1D0,DBLE(NGEN(0,2)))
2869
2870C...Decay widths and branching ratios.
2871 ELSEIF(MSTAT.EQ.2) THEN
2872 WRITE(MSTU(11),5500)
2873 WRITE(MSTU(11),5600)
2874 DO 140 KC=1,500
2875 KF=KCHG(KC,4)
2876 CALL PYNAME(KF,CHKF)
2877 IOFF=0
2878 IF(KC.LE.22) THEN
2879 IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140
2880 IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140
2881 IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1
2882 IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1
2883 IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1
2884 ELSE
2885 IF(MWID(KC).LE.0) GOTO 140
2886 IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR.
2887 & KF/KSUSY1.EQ.2)) GOTO 140
2888 ENDIF
2889C...Off-shell branchings.
2890 IF(IOFF.EQ.1) THEN
2891 NGP=0
2892 IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2
2893 IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10),
2894 & PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0
2895 DO 120 J=1,MDCY(KC,3)
2896 IDC=J+MDCY(KC,2)-1
2897 NGP1=0
2898 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
2899 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
2900 NGP2=0
2901 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
2902 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
2903 CALL PYNAME(KFDP(IDC,1),CHD1)
2904 CALL PYNAME(KFDP(IDC,2),CHD2)
2905 IF(KFDP(IDC,3).EQ.0) THEN
2906 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
2907 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10),
2908 & CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
2909 ELSE
2910 CALL PYNAME(KFDP(IDC,3),CHD3)
2911 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
2912 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10),
2913 & CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
2914 ENDIF
2915 120 CONTINUE
2916C...On-shell decays.
2917 ELSE
2918 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
2919 BRFIN=1D0
2920 IF(WDTE(0,0).LE.0D0) BRFIN=0D0
2921 WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0,
2922 & STATE(MDCY(KC,1)),BRFIN
2923 DO 130 J=1,MDCY(KC,3)
2924 IDC=J+MDCY(KC,2)-1
2925 NGP1=0
2926 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
2927 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
2928 NGP2=0
2929 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
2930 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
2931 BRFIN=0D0
2932 IF(WDTE(0,0).GT.0D0) BRFIN=WDTE(J,0)/WDTE(0,0)
2933 CALL PYNAME(KFDP(IDC,1),CHD1)
2934 CALL PYNAME(KFDP(IDC,2),CHD2)
2935 IF(KFDP(IDC,3).EQ.0) THEN
2936 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
2937 & WRITE(MSTU(11),5800) IDC,CHD1(1:10),
2938 & CHD2(1:10),WDTP(J),WDTP(J)/WDTP(0),
2939 & STATE(MDME(IDC,1)),BRFIN
2940 ELSE
2941 CALL PYNAME(KFDP(IDC,3),CHD3)
2942 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
2943 & WRITE(MSTU(11),5900) IDC,CHD1(1:10),
2944 & CHD2(1:10),CHD3(1:10),WDTP(J),WDTP(J)/WDTP(0),
2945 & STATE(MDME(IDC,1)),BRFIN
2946 ENDIF
2947 130 CONTINUE
2948 ENDIF
2949 140 CONTINUE
2950 WRITE(MSTU(11),6000)
2951
2952C...Allowed incoming partons/particles at hard interaction.
2953 ELSEIF(MSTAT.EQ.3) THEN
2954 WRITE(MSTU(11),6100)
2955 CALL PYNAME(MINT(11),CHAU)
2956 CHIN(1)=CHAU(1:12)
2957 CALL PYNAME(MINT(12),CHAU)
2958 CHIN(2)=CHAU(1:12)
2959 WRITE(MSTU(11),6200) CHIN(1),CHIN(2)
2960 DO 150 I=-20,22
2961 IF(I.EQ.0) GOTO 150
2962 IA=IABS(I)
2963 IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150
2964 IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150
2965 CALL PYNAME(I,CHAU)
2966 WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU,
2967 & STATE(KFIN(2,I))
2968 150 CONTINUE
2969 WRITE(MSTU(11),6400)
2970
2971C...User-defined limits on kinematical variables.
2972 ELSEIF(MSTAT.EQ.4) THEN
2973 WRITE(MSTU(11),6500)
2974 WRITE(MSTU(11),6600)
2975 SHRMAX=CKIN(2)
2976 IF(SHRMAX.LT.0D0) SHRMAX=VINT(1)
2977 WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX
2978 PTHMIN=MAX(CKIN(3),CKIN(5))
2979 PTHMAX=CKIN(4)
2980 IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX
2981 WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX
2982 WRITE(MSTU(11),6900) CHKIN(3),CKIN(6)
2983 DO 160 I=4,14
2984 WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I)
2985 160 CONTINUE
2986 SPRMAX=CKIN(32)
2987 IF(SPRMAX.LT.0D0) SPRMAX=VINT(1)
2988 WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX
2989 WRITE(MSTU(11),7000)
2990
2991C...Status codes and parameter values.
2992 ELSEIF(MSTAT.EQ.5) THEN
2993 WRITE(MSTU(11),7100)
2994 WRITE(MSTU(11),7200)
2995 DO 170 I=1,100
2996 WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
2997 & PARP(100+I)
2998 170 CONTINUE
2999
3000C...List of all processes implemented in the program.
3001 ELSEIF(MSTAT.EQ.6) THEN
3002 WRITE(MSTU(11),7400)
3003 WRITE(MSTU(11),7500)
3004 DO 180 I=1,500
3005 IF(ISET(I).LT.0) GOTO 180
3006 WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2)
3007 180 CONTINUE
3008 WRITE(MSTU(11),7700)
3009 ENDIF
3010
3011C...Formats for printouts.
3012 5000 FORMAT('1',9('*'),1X,'PYSTAT: Statistics on Number of ',
3013 &'Events and Cross-sections',1X,9('*'))
3014 5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
3015 &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
3016 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
3017 &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
3018 &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
3019 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
3020 &'I',12X,'I')
3021 5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
3022 &D10.3,1X,'I')
3023 5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/
3024 &1X,'I',34X,'I',28X,'I',12X,'I')
3025 5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
3026 &1X,'********* Fraction of events that fail fragmentation ',
3027 &'cuts =',1X,F8.5,' *********'/)
3028 5500 FORMAT('1',27('*'),1X,'PYSTAT: Decay Widths and Branching ',
3029 &'Ratios',1X,27('*'))
3030 5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
3031 &1X,'I',5X,'Mother --> Branching/Decay Channel',8X,'I',1X,
3032 &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,
3033 &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
3034 &1X,98('='))
3035 5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
3036 &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X,
3037 &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I')
3038 5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X,
3039 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
3040 &1P,D10.3,0P,1X,'I')
3041 5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X,
3042 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
3043 &1P,D10.3,0P,1X,'I')
3044 6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('='))
3045 6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
3046 &'Particles at Hard Interaction',1X,7('*'))
3047 6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
3048 &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X,
3049 &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X,
3050 &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X,
3051 &78('=')/1X,'I',38X,'I',37X,'I')
3052 6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I')
3053 6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
3054 6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
3055 &'Kinematical Variables',1X,12('*'))
3056 6600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
3057 6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P,
3058 &16X,'I')
3059 6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A,
3060 &1X,'<',1X,1P,D10.3,0P,16X,'I')
3061 6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I')
3062 7000 FORMAT(1X,'I',76X,'I'/1X,78('='))
3063 7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
3064 &'Parameter Values',1X,12('*'))
3065 7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
3066 &'PARP(I)'/)
3067 7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3)
3068 7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes',
3069 &1X,13('*'))
3070 7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X,
3071 &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X,
3072 &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I')
3073 7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I')
3074 7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('='))
3075
3076 RETURN
3077 END
3078
3079C*********************************************************************
3080
3081C...PYINRE
3082C...Calculates full and effective widths of gauge bosons, stores
3083C...masses and widths, rescales coefficients to be used for
3084C...resonance production generation.
3085
3086 SUBROUTINE PYINRE
3087
3088C...Double precision and integer declarations.
3089 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3090 IMPLICIT INTEGER(I-N)
3091 INTEGER PYK,PYCHGE,PYCOMP
3092C...Parameter statement to help give large particle numbers.
3093 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
3094C...Commonblocks.
3095 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3096 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3097 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
3098 COMMON/PYDAT4/CHAF(500,2)
3099 CHARACTER CHAF*16
3100 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3101 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3102 COMMON/PYINT1/MINT(400),VINT(400)
3103 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3104 COMMON/PYINT4/MWID(500),WIDS(500,5)
3105 COMMON/PYINT6/PROC(0:500)
3106 CHARACTER PROC*28
3107 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
3108 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
3109 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/
3110C...Local arrays and data.
3111 DIMENSION WDTP(0:200),WDTE(0:200,0:5),WDTPM(0:200),
3112 &WDTEM(0:200,0:5),KCORD(500),PMORD(500)
3113
3114C...Born level couplings in MSSM Higgs doublet sector.
3115 XW=PARU(102)
3116 XWV=XW
3117 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
3118 XW1=1D0-XW
3119 IF(MSTP(4).EQ.2) THEN
3120 TANBE=PARU(141)
3121 RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2
3122 SQMZ=PMAS(23,1)**2
3123 SQMW=PMAS(24,1)**2
3124 SQMH=PMAS(25,1)**2
3125 SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH)
3126 SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE))
3127 SQMHC=SQMA+SQMW
3128 IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN
3129 WRITE(MSTU(11),5000)
3130 STOP
3131 ENDIF
3132 PMAS(35,1)=SQRT(SQMHP)
3133 PMAS(36,1)=SQRT(SQMA)
3134 PMAS(37,1)=SQRT(SQMHC)
3135 ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)*
3136 & (SQMA-SQMZ)))
3137 BESU=ATAN(TANBE)
3138 PARU(142)=1D0
3139 PARU(143)=1D0
3140 PARU(161)=-SIN(ALSU)/COS(BESU)
3141 PARU(162)=COS(ALSU)/SIN(BESU)
3142 PARU(163)=PARU(161)
3143 PARU(164)=SIN(BESU-ALSU)
3144 PARU(165)=PARU(164)
3145 PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW
3146 PARU(171)=COS(ALSU)/COS(BESU)
3147 PARU(172)=SIN(ALSU)/SIN(BESU)
3148 PARU(173)=PARU(171)
3149 PARU(174)=COS(BESU-ALSU)
3150 PARU(175)=PARU(174)
3151 PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)*
3152 & SIN(BESU+ALSU)
3153 PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU)
3154 PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW
3155 PARU(181)=TANBE
3156 PARU(182)=1D0/TANBE
3157 PARU(183)=PARU(181)
3158 PARU(184)=0D0
3159 PARU(185)=PARU(184)
3160 PARU(186)=COS(BESU-ALSU)
3161 PARU(187)=SIN(BESU-ALSU)
3162 PARU(188)=PARU(186)
3163 PARU(189)=PARU(187)
3164 PARU(190)=0D0
3165 PARU(195)=COS(BESU-ALSU)
3166 ENDIF
3167
3168C...Reset effective widths of gauge bosons.
3169 DO 110 I=1,500
3170 DO 100 J=1,5
3171 WIDS(I,J)=1D0
3172 100 CONTINUE
3173 110 CONTINUE
3174
3175C...Order resonances by increasing mass (except Z0 and W+/-).
3176 NRES=0
3177 DO 140 KC=1,500
3178 KF=KCHG(KC,4)
3179 IF(KF.EQ.0) GOTO 140
3180 IF(MWID(KC).EQ.0) GOTO 140
3181 IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN
3182 IF(MSTP(1).LE.3) GOTO 140
3183 ENDIF
3184 IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN
3185 IF(IMSS(1).LE.0) GOTO 140
3186 ENDIF
3187 NRES=NRES+1
3188 PMRES=PMAS(KC,1)
3189 IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0
3190 DO 120 I1=NRES-1,1,-1
3191 IF(PMRES.GE.PMORD(I1)) GOTO 130
3192 KCORD(I1+1)=KCORD(I1)
3193 PMORD(I1+1)=PMORD(I1)
3194 120 CONTINUE
3195 130 KCORD(I1+1)=KC
3196 PMORD(I1+1)=PMRES
3197 140 CONTINUE
3198
3199C...Loop over possible resonances.
3200 DO 180 I=1,NRES
3201 KC=KCORD(I)
3202 KF=KCHG(KC,4)
3203
3204C...Check that no fourth generation channels on by mistake.
3205 IF(MSTP(1).LE.3) THEN
3206 DO 150 J=1,MDCY(KC,3)
3207 IDC=J+MDCY(KC,2)-1
3208 KFA1=IABS(KFDP(IDC,1))
3209 KFA2=IABS(KFDP(IDC,2))
3210 IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR.
3211 & KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18)
3212 & MDME(IDC,1)=-1
3213 150 CONTINUE
3214 ENDIF
3215
3216C...Check that no supersymmetric channels on by mistake.
3217 IF(IMSS(1).LE.0) THEN
3218 DO 160 J=1,MDCY(KC,3)
3219 IDC=J+MDCY(KC,2)-1
3220 KFA1S=IABS(KFDP(IDC,1))/KSUSY1
3221 KFA2S=IABS(KFDP(IDC,2))/KSUSY1
3222 IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2)
3223 & MDME(IDC,1)=-1
3224 160 CONTINUE
3225 ENDIF
3226
3227C...Find mass and evaluate width.
3228 PMR=PMAS(KC,1)
3229 IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1
3230 IF(MWID(KC).EQ.3) MINT(63)=1
3231 CALL PYWIDT(KF,PMR**2,WDTP,WDTE)
3232 MINT(51)=0
3233
3234C...Evaluate suppression factors due to non-simulated channels.
3235 IF(KCHG(KC,3).EQ.0) THEN
3236 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+
3237 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
3238 & 2D0*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
3239 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
3240 WIDS(KC,3)=0D0
3241 WIDS(KC,4)=0D0
3242 WIDS(KC,5)=0D0
3243 ELSE
3244 IF(MWID(KC).EQ.3) MINT(63)=1
3245 CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM)
3246 MINT(51)=0
3247 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+
3248 & (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+
3249 & (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+
3250 & WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))/WDTP(0)**2
3251 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
3252 WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))/WDTP(0)
3253 WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+
3254 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
3255 & 2D0*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
3256 WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+
3257 & 2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+
3258 & 2D0*WDTEM(0,4)*WDTEM(0,5))/WDTP(0)**2
3259 ENDIF
3260
3261C...Set resonance widths and branching ratios;
3262C...also on/off switch for decays.
3263 IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN
3264 PMAS(KC,2)=WDTP(0)
3265 PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2))
3266 MDCY(KC,1)=MSTP(41)
3267 DO 170 J=1,MDCY(KC,3)
3268 IDC=J+MDCY(KC,2)-1
3269 BRAT(IDC)=0D0
3270 IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0)
3271 170 CONTINUE
3272 ENDIF
3273 180 CONTINUE
3274
3275C...Flavours of leptoquark: redefine charge and name.
3276 KFLQQ=KFDP(MDCY(39,2),1)
3277 KFLQL=KFDP(MDCY(39,2),2)
3278 KCHG(39,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+
3279 &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL)
3280 LL=1
3281 IF(IABS(KFLQL).EQ.13) LL=2
3282 IF(IABS(KFLQL).EQ.15) LL=3
3283 CHAF(39,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)//
3284 &CHAF(IABS(KFLQL),1)(1:LL)//' '
3285 CHAF(39,2)=CHAF(39,2)(1:4+LL)//'bar '
3286
3287C...Special cases in treatment of gamma*/Z0: redefine process name.
3288 IF(MSTP(43).EQ.1) THEN
3289 PROC(1)='f + fbar -> gamma*'
3290 PROC(15)='f + fbar -> g + gamma*'
3291 PROC(19)='f + fbar -> gamma + gamma*'
3292 PROC(30)='f + g -> f + gamma*'
3293 PROC(35)='f + gamma -> f + gamma*'
3294 ELSEIF(MSTP(43).EQ.2) THEN
3295 PROC(1)='f + fbar -> Z0'
3296 PROC(15)='f + fbar -> g + Z0'
3297 PROC(19)='f + fbar -> gamma + Z0'
3298 PROC(30)='f + g -> f + Z0'
3299 PROC(35)='f + gamma -> f + Z0'
3300 ELSEIF(MSTP(43).EQ.3) THEN
3301 PROC(1)='f + fbar -> gamma*/Z0'
3302 PROC(15)='f + fbar -> g + gamma*/Z0'
3303 PROC(19)='f + fbar -> gamma + gamma*/Z0'
3304 PROC(30)='f + g -> f + gamma*/Z0'
3305 PROC(35)='f + gamma -> f + gamma*/Z0'
3306 ENDIF
3307
3308C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
3309 IF(MSTP(44).EQ.1) THEN
3310 PROC(141)='f + fbar -> gamma*'
3311 ELSEIF(MSTP(44).EQ.2) THEN
3312 PROC(141)='f + fbar -> Z0'
3313 ELSEIF(MSTP(44).EQ.3) THEN
3314 PROC(141)='f + fbar -> Z''0'
3315 ELSEIF(MSTP(44).EQ.4) THEN
3316 PROC(141)='f + fbar -> gamma*/Z0'
3317 ELSEIF(MSTP(44).EQ.5) THEN
3318 PROC(141)='f + fbar -> gamma*/Z''0'
3319 ELSEIF(MSTP(44).EQ.6) THEN
3320 PROC(141)='f + fbar -> Z0/Z''0'
3321 ELSEIF(MSTP(44).EQ.7) THEN
3322 PROC(141)='f + fbar -> gamma*/Z0/Z''0'
3323 ENDIF
3324
3325C...Special cases in treatment of WW -> WW: redefine process name.
3326 IF(MSTP(45).EQ.1) THEN
3327 PROC(77)='W+ + W+ -> W+ + W+'
3328 ELSEIF(MSTP(45).EQ.2) THEN
3329 PROC(77)='W+ + W- -> W+ + W-'
3330 ELSEIF(MSTP(45).EQ.3) THEN
3331 PROC(77)='W+/- + W+/- -> W+/- + W+/-'
3332 ENDIF
3333
3334C...Format for error information.
3335 5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ',
3336 &'combination'/1X,'Execution stopped!')
3337
3338 RETURN
3339 END
3340
3341C*********************************************************************
3342
3343C...PYINBM
3344C...Identifies the two incoming particles and the choice of frame.
3345
3346 SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
3347
3348C...Double precision and integer declarations.
3349 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3350 IMPLICIT INTEGER(I-N)
3351 INTEGER PYK,PYCHGE,PYCOMP
3352C...Commonblocks.
3353 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3354 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3355 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3356 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3357 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3358 COMMON/PYINT1/MINT(400),VINT(400)
3359 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
3360C...Local arrays, character variables and data.
3361 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26,
3362 &CHIDNT(3)*12,CHTEMP*12,CHCDE(35)*12,CHINIT*76
3363 DIMENSION LEN(3),KCDE(35),PM(2)
3364 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
3365 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
3366 DATA CHCDE/ 'e- ','e+ ','nu_e ',
3367 &'nu_ebar ','mu- ','mu+ ','nu_mu ',
3368 &'nu_mubar ','tau- ','tau+ ','nu_tau ',
3369 &'nu_taubar ','pi+ ','pi- ','n0 ',
3370 &'nbar0 ','p+ ','pbar- ','gamma ',
3371 &'lambda0 ','sigma- ','sigma0 ','sigma+ ',
3372 &'xi- ','xi0 ','omega- ','pi0 ',
3373 &'reggeon ','pomeron ','gamma/e- ','gamma/e+ ',
3374 &'gamma/mu- ','gamma/mu+ ','gamma/tau- ','gamma/tau+ '/
3375 DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
3376 &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
3377 &3312,3322,3334,111,28,29,6*22/
3378
3379C...Store initial energy. Default frame.
3380 VINT(290)=WIN
3381 MINT(111)=0
3382
3383C...Convert character variables to lowercase and find their length.
3384 CHCOM(1)=CHFRAM
3385 CHCOM(2)=CHBEAM
3386 CHCOM(3)=CHTARG
3387 DO 130 I=1,3
3388 LEN(I)=12
3389 DO 110 LL=12,1,-1
3390 IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
3391 DO 100 LA=1,26
3392 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
3393 & CHALP(1)(LA:LA)
3394 100 CONTINUE
3395 110 CONTINUE
3396 CHIDNT(I)=CHCOM(I)
3397
3398C...Fix up bar, underscore and charge in particle name (if needed).
3399 DO 120 LL=1,10
3400 IF(CHIDNT(I)(LL:LL).EQ.'~') THEN
3401 CHTEMP=CHIDNT(I)
3402 CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:10)//' '
3403 ENDIF
3404 120 CONTINUE
3405 IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN
3406 CHTEMP=CHIDNT(I)
3407 CHIDNT(I)='nu_'//CHTEMP(3:7)
3408 ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN
3409 CHIDNT(I)(1:3)='n0 '
3410 ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN
3411 CHIDNT(I)(1:5)='nbar0'
3412 ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN
3413 CHIDNT(I)(1:3)='p+ '
3414 ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR.
3415 & CHIDNT(I)(1:2).EQ.'p-') THEN
3416 CHIDNT(I)(1:5)='pbar-'
3417 ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN
3418 CHIDNT(I)(7:7)='0'
3419 ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN
3420 CHIDNT(I)(1:7)='reggeon'
3421 ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN
3422 CHIDNT(I)(1:7)='pomeron'
3423 ENDIF
3424 130 CONTINUE
3425
3426C...Identify free initialization.
3427 IF(CHCOM(1)(1:2).EQ.'no') THEN
3428 MINT(65)=1
3429 RETURN
3430 ENDIF
3431
3432C...Identify incoming beam and target particles.
3433 DO 160 I=1,2
3434 DO 140 J=1,35
3435 IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J)
3436 140 CONTINUE
3437 PM(I)=PYMASS(MINT(10+I))
3438 VINT(2+I)=PM(I)
3439 MINT(140+I)=0
3440 IF(MINT(10+I).EQ.22.AND.CHIDNT(I+1)(6:6).EQ.'/') THEN
3441 CHTEMP=CHIDNT(I+1)(7:12)//' '
3442 DO 150 J=1,12
3443 IF(CHTEMP.EQ.CHCDE(J)) MINT(140+I)=KCDE(J)
3444 150 CONTINUE
3445 PM(I)=PYMASS(MINT(140+I))
3446 VINT(302+I)=PM(I)
3447 ENDIF
3448 160 CONTINUE
3449 IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2))
3450 IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3))
3451 IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) STOP
3452
3453C...Identify choice of frame and input energies.
3454 CHINIT=' '
3455
3456C...Events defined in the CM frame.
3457 IF(CHCOM(1)(1:2).EQ.'cm') THEN
3458 MINT(111)=1
3459 S=WIN**2
3460 IF(MSTP(122).GE.1) THEN
3461 IF(CHCOM(2)(1:1).NE.'e') THEN
3462 LOFFS=(31-(LEN(2)+LEN(3)))/2
3463 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
3464 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3465 & ' collider'//' '
3466 ELSE
3467 LOFFS=(30-(LEN(2)+LEN(3)))/2
3468 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
3469 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3470 & ' collider'//' '
3471 ENDIF
3472 WRITE(MSTU(11),5200) CHINIT
3473 WRITE(MSTU(11),5300) WIN
3474 ENDIF
3475
3476C...Events defined in fixed target frame.
3477 ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
3478 MINT(111)=2
3479 S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2)
3480 IF(MSTP(122).GE.1) THEN
3481 LOFFS=(29-(LEN(2)+LEN(3)))/2
3482 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
3483 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3484 & ' fixed target'//' '
3485 WRITE(MSTU(11),5200) CHINIT
3486 WRITE(MSTU(11),5400) WIN
3487 WRITE(MSTU(11),5500) SQRT(S)
3488 ENDIF
3489
3490C...Frame defined by user three-vectors.
3491 ELSEIF(CHCOM(1)(1:3).EQ.'use') THEN
3492 MINT(111)=3
3493 P(1,5)=PM(1)
3494 P(2,5)=PM(2)
3495 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
3496 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
3497 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
3498 & (P(1,3)+P(2,3))**2
3499 IF(MSTP(122).GE.1) THEN
3500 LOFFS=(22-(LEN(2)+LEN(3)))/2
3501 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
3502 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3503 & ' user configuration'//' '
3504 WRITE(MSTU(11),5200) CHINIT
3505 WRITE(MSTU(11),5600)
3506 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
3507 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
3508 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
3509 ENDIF
3510
3511C...Frame defined by user four-vectors.
3512 ELSEIF(CHCOM(1)(1:4).EQ.'four') THEN
3513 MINT(111)=4
3514 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
3515 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
3516 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
3517 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
3518 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
3519 & (P(1,3)+P(2,3))**2
3520 IF(MSTP(122).GE.1) THEN
3521 LOFFS=(22-(LEN(2)+LEN(3)))/2
3522 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
3523 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3524 & ' user configuration'//' '
3525 WRITE(MSTU(11),5200) CHINIT
3526 WRITE(MSTU(11),5600)
3527 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
3528 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
3529 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
3530 ENDIF
3531
3532C...Frame defined by user five-vectors.
3533 ELSEIF(CHCOM(1)(1:4).EQ.'five') THEN
3534 MINT(111)=5
3535 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
3536 & (P(1,3)+P(2,3))**2
3537 IF(MSTP(122).GE.1) THEN
3538 LOFFS=(22-(LEN(2)+LEN(3)))/2
3539 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
3540 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3541 & ' user configuration'//' '
3542 WRITE(MSTU(11),5200) CHINIT
3543 WRITE(MSTU(11),5600)
3544 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
3545 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
3546 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
3547 ENDIF
3548
3549C...Unknown frame. Error for too low CM energy.
3550 ELSE
3551 WRITE(MSTU(11),5800) CHFRAM(1:LEN(1))
3552 STOP
3553 ENDIF
3554 IF(S.LT.PARP(2)**2) THEN
3555 WRITE(MSTU(11),5900) SQRT(S)
3556 STOP
3557 ENDIF
3558
3559C...Formats for initialization and error information.
3560 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/
3561 &1X,'Execution stopped!')
3562 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/
3563 &1X,'Execution stopped!')
3564 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
3565 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
3566 &19X,'I'/1X,'I',76X,'I'/1X,78('='))
3567 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
3568 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
3569 &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
3570 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X,
3571 &'pz (GeV/c)',6X,'E (GeV)',9X,'I')
3572 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I')
3573 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/
3574 &1X,'Execution stopped!')
3575 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
3576 &'generation.'/1X,'Execution stopped!')
3577
3578 RETURN
3579 END
3580
3581C*********************************************************************
3582
3583C...PYINKI
3584C...Sets up kinematics, including rotations and boosts to/from CM frame.
3585
3586 SUBROUTINE PYINKI(MODKI)
3587
3588C...Double precision and integer declarations.
3589 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3590 IMPLICIT INTEGER(I-N)
3591 INTEGER PYK,PYCHGE,PYCOMP
3592C...Commonblocks.
3593 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3594 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3595 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3596 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3597 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3598 COMMON/PYINT1/MINT(400),VINT(400)
3599 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
3600
3601C...Set initial flavour state.
3602 N=2
3603 DO 100 I=1,2
3604 K(I,1)=1
3605 K(I,2)=MINT(10+I)
3606 IF(MINT(140+I).NE.0) K(I,2)=MINT(140+I)
3607 100 CONTINUE
3608
3609C...Reset boost. Do kinematics for various cases.
3610 DO 110 J=6,10
3611 VINT(J)=0D0
3612 110 CONTINUE
3613
3614C...Set up kinematics for events defined in CM frame.
3615 IF(MINT(111).EQ.1) THEN
3616 WIN=VINT(290)
3617 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
3618 S=WIN**2
3619 P(1,5)=VINT(3)
3620 P(2,5)=VINT(4)
3621 IF(MINT(141).NE.0) P(1,5)=VINT(303)
3622 IF(MINT(142).NE.0) P(2,5)=VINT(304)
3623 P(1,1)=0D0
3624 P(1,2)=0D0
3625 P(2,1)=0D0
3626 P(2,2)=0D0
3627 P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/
3628 & (4D0*S))
3629 P(2,3)=-P(1,3)
3630 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
3631 P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
3632
3633C...Set up kinematics for fixed target events.
3634 ELSEIF(MINT(111).EQ.2) THEN
3635 WIN=VINT(290)
3636 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
3637 P(1,5)=VINT(3)
3638 P(2,5)=VINT(4)
3639 IF(MINT(141).NE.0) P(1,5)=VINT(303)
3640 IF(MINT(142).NE.0) P(2,5)=VINT(304)
3641 P(1,1)=0D0
3642 P(1,2)=0D0
3643 P(2,1)=0D0
3644 P(2,2)=0D0
3645 P(1,3)=WIN
3646 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
3647 P(2,3)=0D0
3648 P(2,4)=P(2,5)
3649 S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4)
3650 VINT(10)=P(1,3)/(P(1,4)+P(2,4))
3651 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
3652
3653C...Set up kinematics for events in user-defined frame.
3654 ELSEIF(MINT(111).EQ.3) THEN
3655 P(1,5)=VINT(3)
3656 P(2,5)=VINT(4)
3657 IF(MINT(141).NE.0) P(1,5)=VINT(303)
3658 IF(MINT(142).NE.0) P(2,5)=VINT(304)
3659 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
3660 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
3661 DO 120 J=1,3
3662 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
3663 120 CONTINUE
3664 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
3665 VINT(7)=PYANGL(P(1,1),P(1,2))
3666 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
3667 VINT(6)=PYANGL(P(1,3),P(1,1))
3668 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
3669 S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
3670
3671C...Set up kinematics for events with user-defined four-vectors.
3672 ELSEIF(MINT(111).EQ.4) THEN
3673 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
3674 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
3675 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
3676 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
3677 DO 130 J=1,3
3678 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
3679 130 CONTINUE
3680 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
3681 VINT(7)=PYANGL(P(1,1),P(1,2))
3682 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
3683 VINT(6)=PYANGL(P(1,3),P(1,1))
3684 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
3685 S=(P(1,4)+P(2,4))**2
3686
3687C...Set up kinematics for events with user-defined five-vectors.
3688 ELSEIF(MINT(111).EQ.5) THEN
3689 DO 140 J=1,3
3690 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
3691 140 CONTINUE
3692 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
3693 VINT(7)=PYANGL(P(1,1),P(1,2))
3694 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
3695 VINT(6)=PYANGL(P(1,3),P(1,1))
3696 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
3697 S=(P(1,4)+P(2,4))**2
3698 ENDIF
3699
3700C...Return or error for too low CM energy.
3701 IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN
3702 IF(MSTP(172).LE.1) THEN
3703 CALL PYERRM(23,
3704 & '(PYINKI:) too low invariant mass in this event')
3705 ELSE
3706 MSTI(61)=1
3707 RETURN
3708 ENDIF
3709 ENDIF
3710
3711C...Save information on incoming particles.
3712 VINT(1)=SQRT(S)
3713 VINT(2)=S
3714 IF(MINT(111).GE.4) THEN
3715 IF(MINT(141).EQ.0) THEN
3716 VINT(3)=P(1,5)
3717 IF(MINT(11).EQ.22.AND.P(1,5).LT.0) VINT(307)=P(1,5)**2
3718 ELSE
3719 VINT(303)=P(1,5)
3720 ENDIF
3721 IF(MINT(142).EQ.0) THEN
3722 VINT(4)=P(2,5)
3723 IF(MINT(12).EQ.22.AND.P(2,5).LT.0) VINT(308)=P(2,5)**2
3724 ELSE
3725 VINT(304)=P(2,5)
3726 ENDIF
3727 ENDIF
3728 VINT(5)=P(1,3)
3729 IF(MODKI.EQ.0) VINT(289)=S
3730 DO 150 J=1,5
3731 V(1,J)=0D0
3732 V(2,J)=0D0
3733 VINT(290+J)=P(1,J)
3734 VINT(295+J)=P(2,J)
3735 150 CONTINUE
3736
3737C...Store pT cut-off and related constants to be used in generation.
3738 IF(MODKI.EQ.0) VINT(285)=CKIN(3)
3739 IF(MSTP(82).LE.1) THEN
3740 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
3741 ELSE
3742 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
3743 ENDIF
3744 VINT(149)=4D0*PTMN**2/S
3745 VINT(154)=PTMN
3746
3747 RETURN
3748 END
3749
3750C*********************************************************************
3751
3752C...PYINPR
3753C...Selects partonic subprocesses to be included in the simulation.
3754
3755 SUBROUTINE PYINPR
3756
3757C...Double precision and integer declarations.
3758 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3759 IMPLICIT INTEGER(I-N)
3760 INTEGER PYK,PYCHGE,PYCOMP
3761C...Commonblocks.
3762 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3763 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
3764 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3765 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3766 COMMON/PYINT1/MINT(400),VINT(400)
3767 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3768 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
3769
3770C...Reset processes to be included.
3771 IF(MSEL.NE.0) THEN
3772 DO 100 I=1,500
3773 MSUB(I)=0
3774 100 CONTINUE
3775 ENDIF
3776
3777C...Set running pTmin scale.
3778 IF(MSTP(82).LE.1) THEN
3779 PTMRUN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
3780 ELSE
3781 PTMRUN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
3782 ENDIF
3783
3784C...Begin by assuming incoming photon to enter subprocess.
3785 IF(MINT(11).EQ.22) MINT(15)=22
3786 IF(MINT(12).EQ.22) MINT(16)=22
3787
3788C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous.
3789 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
3790 MSUB(10)=1
3791 MINT(123)=MINT(122)+1
3792
3793C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30
3794C...allow mixture.
3795C...Here also set a few parameters otherwise normally not touched.
3796 ELSEIF(MINT(121).GT.1) THEN
3797
3798C...Parton distributions dampened at small Q2; go to low energies,
3799C...alpha_s <1; no minimum pT cut-off a priori.
3800 IF(MSTP(18).EQ.2) THEN
3801 MSTP(57)=3
3802 PARP(2)=2D0
3803 PARU(115)=1D0
3804 CKIN(5)=0.2D0
3805 CKIN(6)=0.2D0
3806 ENDIF
3807
3808C...Define pT cut-off parameters and whether run involves low-pT.
3809 PTMVMD=PTMRUN
3810 VINT(154)=PTMVMD
3811 PTMDIR=PTMVMD
3812 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
3813 PTMANO=PTMVMD
3814 IF(MSTP(15).EQ.5) PTMANO=0.60D0+
3815 & 0.125D0*LOG(1D0+0.10D0*VINT(1))**2
3816 IPTL=1
3817 IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0
3818 IF(MSEL.EQ.2) IPTL=1
3819
3820C...Set up for p/gamma * gamma; real or virtual photons.
3821 IF(MINT(121).EQ.3.OR.MINT(121).EQ.6.OR.(MINT(121).EQ.4.AND.
3822 & MSTP(14).EQ.30)) THEN
3823
3824C...Set up for p/VMD * VMD.
3825 IF(MINT(122).EQ.1) THEN
3826 MINT(123)=2
3827 MSUB(11)=1
3828 MSUB(12)=1
3829 MSUB(13)=1
3830 MSUB(28)=1
3831 MSUB(53)=1
3832 MSUB(68)=1
3833 IF(IPTL.EQ.1) MSUB(95)=1
3834 IF(MSEL.EQ.2) THEN
3835 MSUB(91)=1
3836 MSUB(92)=1
3837 MSUB(93)=1
3838 MSUB(94)=1
3839 ENDIF
3840 IF(IPTL.EQ.1) CKIN(3)=0D0
3841
3842C...Set up for p/VMD * direct gamma.
3843 ELSEIF(MINT(122).EQ.2) THEN
3844 MINT(123)=0
3845 IF(MINT(121).EQ.6) MINT(123)=5
3846 MSUB(131)=1
3847 MSUB(132)=1
3848 MSUB(135)=1
3849 MSUB(136)=1
3850 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
3851
3852C...Set up for p/VMD * anomalous gamma.
3853 ELSEIF(MINT(122).EQ.3) THEN
3854 MINT(123)=3
3855 IF(MINT(121).EQ.6) MINT(123)=7
3856 MSUB(11)=1
3857 MSUB(12)=1
3858 MSUB(13)=1
3859 MSUB(28)=1
3860 MSUB(53)=1
3861 MSUB(68)=1
3862 IF(IPTL.EQ.1) MSUB(95)=1
3863 IF(MSEL.EQ.2) THEN
3864 MSUB(91)=1
3865 MSUB(92)=1
3866 MSUB(93)=1
3867 MSUB(94)=1
3868 ENDIF
3869 IF(IPTL.EQ.1) CKIN(3)=0D0
3870
3871C...Set up for DIS * p.
3872 ELSEIF(MINT(122).EQ.4.AND.(IABS(MINT(11)).GE.28.OR.
3873 & IABS(MINT(12)).GE.28)) THEN
3874 MINT(123)=8
3875 IF(IPTL.EQ.1) MSUB(99)=1
3876
3877C...Set up for direct * direct gamma (switch off leptons).
3878 ELSEIF(MINT(122).EQ.4) THEN
3879 MINT(123)=0
3880 MSUB(137)=1
3881 MSUB(138)=1
3882 MSUB(139)=1
3883 MSUB(140)=1
3884 DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
3885 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
3886 110 CONTINUE
3887 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
3888
3889C...Set up for direct * anomalous gamma.
3890 ELSEIF(MINT(122).EQ.5) THEN
3891 MINT(123)=6
3892 MSUB(131)=1
3893 MSUB(132)=1
3894 MSUB(135)=1
3895 MSUB(136)=1
3896 IF(IPTL.EQ.1) CKIN(3)=PTMANO
3897
3898C...Set up for anomalous * anomalous gamma.
3899 ELSEIF(MINT(122).EQ.6) THEN
3900 MINT(123)=3
3901 MSUB(11)=1
3902 MSUB(12)=1
3903 MSUB(13)=1
3904 MSUB(28)=1
3905 MSUB(53)=1
3906 MSUB(68)=1
3907 IF(IPTL.EQ.1) MSUB(95)=1
3908 IF(MSEL.EQ.2) THEN
3909 MSUB(91)=1
3910 MSUB(92)=1
3911 MSUB(93)=1
3912 MSUB(94)=1
3913 ENDIF
3914 IF(IPTL.EQ.1) CKIN(3)=0D0
3915 ENDIF
3916
3917C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom.
3918 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
3919
3920C...Set up for direct * direct gamma (switch off leptons).
3921 IF(MINT(122).EQ.1) THEN
3922 MINT(123)=0
3923 MSUB(137)=1
3924 MSUB(138)=1
3925 MSUB(139)=1
3926 MSUB(140)=1
3927 DO 120 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
3928 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
3929 120 CONTINUE
3930 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
3931
3932C...Set up for direct * VMD and VMD * direct gamma.
3933 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.4) THEN
3934 MINT(123)=5
3935 MSUB(131)=1
3936 MSUB(132)=1
3937 MSUB(135)=1
3938 MSUB(136)=1
3939 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
3940
3941C...Set up for direct * anomalous and anomalous * direct gamma.
3942 ELSEIF(MINT(122).EQ.3.OR.MINT(122).EQ.7) THEN
3943 MINT(123)=6
3944 MSUB(131)=1
3945 MSUB(132)=1
3946 MSUB(135)=1
3947 MSUB(136)=1
3948 IF(IPTL.EQ.1) CKIN(3)=PTMANO
3949
3950C...Set up for VMD*VMD.
3951 ELSEIF(MINT(122).EQ.5) THEN
3952 MINT(123)=2
3953 MSUB(11)=1
3954 MSUB(12)=1
3955 MSUB(13)=1
3956 MSUB(28)=1
3957 MSUB(53)=1
3958 MSUB(68)=1
3959 IF(IPTL.EQ.1) MSUB(95)=1
3960 IF(MSEL.EQ.2) THEN
3961 MSUB(91)=1
3962 MSUB(92)=1
3963 MSUB(93)=1
3964 MSUB(94)=1
3965 ENDIF
3966 IF(IPTL.EQ.1) CKIN(3)=0D0
3967
3968C...Set up for VMD * anomalous and anomalous * VMD gamma.
3969 ELSEIF(MINT(122).EQ.6.OR.MINT(122).EQ.8) THEN
3970 MINT(123)=7
3971 MSUB(11)=1
3972 MSUB(12)=1
3973 MSUB(13)=1
3974 MSUB(28)=1
3975 MSUB(53)=1
3976 MSUB(68)=1
3977 IF(IPTL.EQ.1) MSUB(95)=1
3978 IF(MSEL.EQ.2) THEN
3979 MSUB(91)=1
3980 MSUB(92)=1
3981 MSUB(93)=1
3982 MSUB(94)=1
3983 ENDIF
3984 IF(IPTL.EQ.1) CKIN(3)=0D0
3985
3986C...Set up for anomalous * anomalous gamma.
3987 ELSEIF(MINT(122).EQ.9) THEN
3988 MINT(123)=3
3989 MSUB(11)=1
3990 MSUB(12)=1
3991 MSUB(13)=1
3992 MSUB(28)=1
3993 MSUB(53)=1
3994 MSUB(68)=1
3995 IF(IPTL.EQ.1) MSUB(95)=1
3996 IF(MSEL.EQ.2) THEN
3997 MSUB(91)=1
3998 MSUB(92)=1
3999 MSUB(93)=1
4000 MSUB(94)=1
4001 ENDIF
4002 IF(IPTL.EQ.1) CKIN(3)=0D0
4003
4004C...Set up for DIS * VMD and VMD * DIS gamma.
4005 ELSEIF(MINT(122).EQ.10.OR.MINT(122).EQ.12) THEN
4006 MINT(123)=8
4007 IF(IPTL.EQ.1) MSUB(99)=1
4008
4009C...Set up for DIS * anomalous and anomalous * DIS gamma.
4010 ELSEIF(MINT(122).EQ.11.OR.MINT(122).EQ.13) THEN
4011 MINT(123)=9
4012 IF(IPTL.EQ.1) MSUB(99)=1
4013 ENDIF
4014
4015C...Set up for gamma* * p; virtual photons = dir, res.
4016 ELSEIF(MINT(121).EQ.2) THEN
4017
4018C...Set up for direct * p.
4019 IF(MINT(122).EQ.1) THEN
4020 MINT(123)=0
4021 MSUB(131)=1
4022 MSUB(132)=1
4023 MSUB(135)=1
4024 MSUB(136)=1
4025 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4026
4027C...Set up for resolved * p.
4028 ELSEIF(MINT(122).EQ.2) THEN
4029 MINT(123)=1
4030 MSUB(11)=1
4031 MSUB(12)=1
4032 MSUB(13)=1
4033 MSUB(28)=1
4034 MSUB(53)=1
4035 MSUB(68)=1
4036 IF(IPTL.EQ.1) MSUB(95)=1
4037 IF(MSEL.EQ.2) THEN
4038 MSUB(91)=1
4039 MSUB(92)=1
4040 MSUB(93)=1
4041 MSUB(94)=1
4042 ENDIF
4043 IF(IPTL.EQ.1) CKIN(3)=0D0
4044 ENDIF
4045
4046C...Set up for gamma* * gamma*; virtual photons = dir, res.
4047 ELSEIF(MINT(121).EQ.4) THEN
4048
4049C...Set up for direct * direct gamma (switch off leptons).
4050 IF(MINT(122).EQ.1) THEN
4051 MINT(123)=0
4052 MSUB(137)=1
4053 MSUB(138)=1
4054 MSUB(139)=1
4055 MSUB(140)=1
4056 DO 130 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
4057 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
4058 130 CONTINUE
4059 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4060
4061C...Set up for direct * resolved and resolved * direct gamma.
4062 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.3) THEN
4063 MINT(123)=5
4064 MSUB(131)=1
4065 MSUB(132)=1
4066 MSUB(135)=1
4067 MSUB(136)=1
4068 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4069
4070C...Set up for resolved * resolved gamma.
4071 ELSEIF(MINT(122).EQ.4) THEN
4072 MINT(123)=2
4073 MSUB(11)=1
4074 MSUB(12)=1
4075 MSUB(13)=1
4076 MSUB(28)=1
4077 MSUB(53)=1
4078 MSUB(68)=1
4079 IF(IPTL.EQ.1) MSUB(95)=1
4080 IF(MSEL.EQ.2) THEN
4081 MSUB(91)=1
4082 MSUB(92)=1
4083 MSUB(93)=1
4084 MSUB(94)=1
4085 ENDIF
4086 IF(IPTL.EQ.1) CKIN(3)=0D0
4087 ENDIF
4088
4089C...End of special set up for gamma-p and gamma-gamma.
4090 ENDIF
4091 CKIN(1)=2D0*CKIN(3)
4092 ENDIF
4093
4094C...Flavour information for individual beams.
4095 DO 140 I=1,2
4096 MINT(40+I)=1
4097 IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2
4098 IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2
4099 IF(MINT(10+I).EQ.28.OR.MINT(10+I).EQ.29) MINT(40+I)=2
4100 MINT(44+I)=MINT(40+I)
4101 IF(MSTP(11).GE.1.AND.(IABS(MINT(10+I)).EQ.11.OR.
4102 & IABS(MINT(10+I)).EQ.13.OR.IABS(MINT(10+I)).EQ.15)) MINT(44+I)=3
4103 140 CONTINUE
4104
4105C...If two real gammas, whereof one direct, pick the first.
4106C...For two virtual photons, keep requested order.
4107 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
4108 IF(MSTP(14).LE.10.AND.MINT(123).GE.4.AND.MINT(123).LE.6) THEN
4109 MINT(41)=1
4110 MINT(45)=1
4111 ELSEIF(MSTP(14).EQ.12.OR.MSTP(14).EQ.13.OR.MSTP(14).EQ.22.OR.
4112 & MSTP(14).EQ.26.OR.MSTP(14).EQ.27) THEN
4113 MINT(41)=1
4114 MINT(45)=1
4115 ELSEIF(MSTP(14).EQ.14.OR.MSTP(14).EQ.17.OR.MSTP(14).EQ.23.OR.
4116 & MSTP(14).EQ.28.OR.MSTP(14).EQ.29) THEN
4117 MINT(42)=1
4118 MINT(46)=1
4119 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.2
4120 & .OR.MINT(122).EQ.3.OR.MINT(122).EQ.10.OR.MINT(122).EQ.11)) THEN
4121 MINT(41)=1
4122 MINT(45)=1
4123 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.4
4124 & .OR.MINT(122).EQ.7.OR.MINT(122).EQ.12.OR.MINT(122).EQ.13)) THEN
4125 MINT(42)=1
4126 MINT(46)=1
4127 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.2) THEN
4128 MINT(41)=1
4129 MINT(45)=1
4130 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.3) THEN
4131 MINT(42)=1
4132 MINT(46)=1
4133 ENDIF
4134 ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN
4135 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28.OR.MINT(122).EQ.4) THEN
4136 IF(MINT(11).EQ.22) THEN
4137 MINT(41)=1
4138 MINT(45)=1
4139 ELSE
4140 MINT(42)=1
4141 MINT(46)=1
4142 ENDIF
4143 ENDIF
4144 IF(MINT(123).GE.4.AND.MINT(123).LE.7) CALL PYERRM(26,
4145 & '(PYINPR:) unallowed MSTP(14) code for single photon')
4146 ENDIF
4147
4148C...Flavour information on combination of incoming particles.
4149 MINT(43)=2*MINT(41)+MINT(42)-2
4150 MINT(44)=MINT(43)
4151 IF(MINT(123).LE.0) THEN
4152 IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2
4153 IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1
4154 ELSEIF(MINT(123).LE.3) THEN
4155 IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2
4156 IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1
4157 ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
4158 MINT(43)=4
4159 MINT(44)=1
4160 ENDIF
4161 MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2
4162 IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5
4163 IF(MINT(45).EQ.1.AND.MINT(46).EQ.3) MINT(47)=6
4164 IF(MINT(45).EQ.3.AND.MINT(46).EQ.1) MINT(47)=7
4165 MINT(50)=0
4166 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) MINT(50)=1
4167 MINT(107)=0
4168 MINT(108)=0
4169 IF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
4170 IF((MINT(122).GE.4.AND.MINT(122).LE.6).OR.MINT(122).EQ.12)
4171 & MINT(107)=2
4172 IF((MINT(122).GE.7.AND.MINT(122).LE.9).OR.MINT(122).EQ.13)
4173 & MINT(107)=3
4174 IF(MINT(122).EQ.10.OR.MINT(122).EQ.11) MINT(107)=4
4175 IF(MINT(122).EQ.2.OR.MINT(122).EQ.5.OR.MINT(122).EQ.8.OR.
4176 & MINT(122).EQ.10) MINT(108)=2
4177 IF(MINT(122).EQ.3.OR.MINT(122).EQ.6.OR.MINT(122).EQ.9.OR.
4178 & MINT(122).EQ.11) MINT(108)=3
4179 IF(MINT(122).EQ.12.OR.MINT(122).EQ.13) MINT(108)=4
4180 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.25) THEN
4181 IF(MINT(122).GE.3) MINT(107)=1
4182 IF(MINT(122).EQ.2.OR.MINT(122).EQ.4) MINT(108)=1
4183 ELSEIF(MINT(121).EQ.2) THEN
4184 IF(MINT(122).EQ.2.AND.MINT(11).EQ.22) MINT(107)=1
4185 IF(MINT(122).EQ.2.AND.MINT(12).EQ.22) MINT(108)=1
4186 ELSE
4187 IF(MINT(11).EQ.22) THEN
4188 MINT(107)=MINT(123)
4189 IF(MINT(123).GE.4) MINT(107)=0
4190 IF(MINT(123).EQ.7) MINT(107)=2
4191 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.27) MINT(107)=4
4192 IF(MSTP(14).EQ.28) MINT(107)=2
4193 IF(MSTP(14).EQ.29) MINT(107)=3
4194 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
4195 & MINT(107)=4
4196 ENDIF
4197 IF(MINT(12).EQ.22) THEN
4198 MINT(108)=MINT(123)
4199 IF(MINT(123).GE.4) MINT(108)=MINT(123)-3
4200 IF(MINT(123).EQ.7) MINT(108)=3
4201 IF(MSTP(14).EQ.26) MINT(108)=2
4202 IF(MSTP(14).EQ.27) MINT(108)=3
4203 IF(MSTP(14).EQ.28.OR.MSTP(14).EQ.29) MINT(108)=4
4204 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
4205 & MINT(108)=4
4206 ENDIF
4207 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.(MSTP(14).EQ.14.OR.
4208 & MSTP(14).EQ.17.OR.MSTP(14).EQ.18.OR.MSTP(14).EQ.23)) THEN
4209 MINTTP=MINT(107)
4210 MINT(107)=MINT(108)
4211 MINT(108)=MINTTP
4212 ENDIF
4213 ENDIF
4214 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
4215 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
4216
4217C...Select default processes according to incoming beams
4218C...(already done for gamma-p and gamma-gamma with
4219C...MSTP(14) = 10, 20, 25 or 30).
4220 IF(MINT(121).GT.1) THEN
4221 ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN
4222
4223 IF(MINT(43).EQ.1) THEN
4224C...Lepton + lepton -> gamma/Z0 or W.
4225 IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
4226 IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
4227
4228 ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND.
4229 & (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN
4230C...Unresolved photon + lepton: Compton scattering.
4231 MSUB(133)=1
4232 MSUB(134)=1
4233
4234 ELSEIF((MINT(123).EQ.8.OR.MINT(123).EQ.9).AND.(MINT(11).EQ.22
4235 & .OR.MINT(12).EQ.22)) THEN
4236C...DIS as pure gamma* + f -> f process.
4237 MSUB(99)=1
4238
4239 ELSEIF(MINT(43).LE.3) THEN
4240C...Lepton + hadron: deep inelastic scattering.
4241 MSUB(10)=1
4242
4243 ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND.
4244 & MINT(12).EQ.22) THEN
4245C...Two unresolved photons: fermion pair production,
4246C...exclude lepton pairs.
4247 DO 150 ISUB=137,140
4248 MSUB(ISUB)=1
4249 150 CONTINUE
4250 DO 155 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
4251 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
4252 155 CONTINUE
4253 PTMDIR=PTMRUN
4254 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
4255 IF(CKIN(3).LT.PTMRUN.OR.MSEL.EQ.2) CKIN(3)=PTMDIR
4256 CKIN(1)=MAX(CKIN(1),2D0*CKIN(3))
4257
4258 ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22))
4259 & .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND.
4260 & MINT(12).EQ.22)) THEN
4261C...Unresolved photon + hadron: photon-parton scattering.
4262 DO 160 ISUB=131,136
4263 MSUB(ISUB)=1
4264 160 CONTINUE
4265
4266 ELSEIF(MSEL.EQ.1) THEN
4267C...High-pT QCD processes:
4268 MSUB(11)=1
4269 MSUB(12)=1
4270 MSUB(13)=1
4271 MSUB(28)=1
4272 MSUB(53)=1
4273 MSUB(68)=1
4274 PTMN=PTMRUN
4275 VINT(154)=PTMN
4276 IF(CKIN(3).LT.PTMN) MSUB(95)=1
4277 IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0
4278
4279 ELSE
4280C...All QCD processes:
4281 MSUB(11)=1
4282 MSUB(12)=1
4283 MSUB(13)=1
4284 MSUB(28)=1
4285 MSUB(53)=1
4286 MSUB(68)=1
4287 MSUB(91)=1
4288 MSUB(92)=1
4289 MSUB(93)=1
4290 MSUB(94)=1
4291 MSUB(95)=1
4292 ENDIF
4293
4294 ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
4295C...Heavy quark production.
4296 MSUB(81)=1
4297 MSUB(82)=1
4298 MSUB(84)=1
4299 DO 170 J=1,MIN(8,MDCY(21,3))
4300 MDME(MDCY(21,2)+J-1,1)=0
4301 170 CONTINUE
4302 MDME(MDCY(21,2)+MSEL-1,1)=1
4303 MSUB(85)=1
4304 DO 180 J=1,MIN(12,MDCY(22,3))
4305 MDME(MDCY(22,2)+J-1,1)=0
4306 180 CONTINUE
4307 MDME(MDCY(22,2)+MSEL-1,1)=1
4308
4309 ELSEIF(MSEL.EQ.10) THEN
4310C...Prompt photon production:
4311 MSUB(14)=1
4312 MSUB(18)=1
4313 MSUB(29)=1
4314
4315 ELSEIF(MSEL.EQ.11) THEN
4316C...Z0/gamma* production:
4317 MSUB(1)=1
4318
4319 ELSEIF(MSEL.EQ.12) THEN
4320C...W+/- production:
4321 MSUB(2)=1
4322
4323 ELSEIF(MSEL.EQ.13) THEN
4324C...Z0 + jet:
4325 MSUB(15)=1
4326 MSUB(30)=1
4327
4328 ELSEIF(MSEL.EQ.14) THEN
4329C...W+/- + jet:
4330 MSUB(16)=1
4331 MSUB(31)=1
4332
4333 ELSEIF(MSEL.EQ.15) THEN
4334C...Z0 & W+/- pair production:
4335 MSUB(19)=1
4336 MSUB(20)=1
4337 MSUB(22)=1
4338 MSUB(23)=1
4339 MSUB(25)=1
4340
4341 ELSEIF(MSEL.EQ.16) THEN
4342C...h0 production:
4343 MSUB(3)=1
4344 MSUB(102)=1
4345 MSUB(103)=1
4346 MSUB(123)=1
4347 MSUB(124)=1
4348
4349 ELSEIF(MSEL.EQ.17) THEN
4350C...h0 & Z0 or W+/- pair production:
4351 MSUB(24)=1
4352 MSUB(26)=1
4353
4354 ELSEIF(MSEL.EQ.18) THEN
4355C...h0 production; interesting processes in e+e-.
4356 MSUB(24)=1
4357 MSUB(103)=1
4358 MSUB(123)=1
4359 MSUB(124)=1
4360
4361 ELSEIF(MSEL.EQ.19) THEN
4362C...h0, H0 and A0 production; interesting processes in e+e-.
4363 MSUB(24)=1
4364 MSUB(103)=1
4365 MSUB(123)=1
4366 MSUB(124)=1
4367 MSUB(153)=1
4368 MSUB(171)=1
4369 MSUB(173)=1
4370 MSUB(174)=1
4371 MSUB(158)=1
4372 MSUB(176)=1
4373 MSUB(178)=1
4374 MSUB(179)=1
4375
4376 ELSEIF(MSEL.EQ.21) THEN
4377C...Z'0 production:
4378 MSUB(141)=1
4379
4380 ELSEIF(MSEL.EQ.22) THEN
4381C...W'+/- production:
4382 MSUB(142)=1
4383
4384 ELSEIF(MSEL.EQ.23) THEN
4385C...H+/- production:
4386 MSUB(143)=1
4387
4388 ELSEIF(MSEL.EQ.24) THEN
4389C...R production:
4390 MSUB(144)=1
4391
4392 ELSEIF(MSEL.EQ.25) THEN
4393C...LQ (leptoquark) production.
4394 MSUB(145)=1
4395 MSUB(162)=1
4396 MSUB(163)=1
4397 MSUB(164)=1
4398
4399 ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN
4400C...Production of one heavy quark (W exchange):
4401 MSUB(83)=1
4402 DO 190 J=1,MIN(8,MDCY(21,3))
4403 MDME(MDCY(21,2)+J-1,1)=0
4404 190 CONTINUE
4405 MDME(MDCY(21,2)+MSEL-31,1)=1
4406
4407CMRENNA++Define SUSY alternatives.
4408 ELSEIF(MSEL.EQ.39) THEN
4409C...Turn on all SUSY processes.
4410 IF(MINT(43).EQ.4) THEN
4411C...Hadron-hadron processes.
4412 DO 200 I=201,301
4413 IF(ISET(I).GE.0) MSUB(I)=1
4414 200 CONTINUE
4415 ELSEIF(MINT(43).EQ.1) THEN
4416C...Lepton-lepton processes: QED production of squarks.
4417 DO 210 I=201,214
4418 MSUB(I)=1
4419 210 CONTINUE
4420 MSUB(210)=0
4421 MSUB(211)=0
4422 MSUB(212)=0
4423 DO 220 I=216,228
4424 MSUB(I)=1
4425 220 CONTINUE
4426 DO 230 I=261,263
4427 MSUB(I)=1
4428 230 CONTINUE
4429 MSUB(277)=1
4430 MSUB(278)=1
4431 ENDIF
4432
4433 ELSEIF(MSEL.EQ.40) THEN
4434C...Gluinos and squarks.
4435 IF(MINT(43).EQ.4) THEN
4436 MSUB(243)=1
4437 MSUB(244)=1
4438 MSUB(258)=1
4439 MSUB(259)=1
4440 MSUB(261)=1
4441 MSUB(262)=1
4442 MSUB(264)=1
4443 MSUB(265)=1
4444 DO 240 I=271,296
4445 MSUB(I)=1
4446 240 CONTINUE
4447 ELSEIF(MINT(43).EQ.1) THEN
4448 MSUB(277)=1
4449 MSUB(278)=1
4450 ENDIF
4451
4452 ELSEIF(MSEL.EQ.41) THEN
4453C...Stop production.
4454 MSUB(261)=1
4455 MSUB(262)=1
4456 MSUB(263)=1
4457 IF(MINT(43).EQ.4) THEN
4458 MSUB(264)=1
4459 MSUB(265)=1
4460 ENDIF
4461
4462 ELSEIF(MSEL.EQ.42) THEN
4463C...Slepton production.
4464 DO 250 I=201,214
4465 MSUB(I)=1
4466 250 CONTINUE
4467 IF(MINT(43).NE.4) THEN
4468 MSUB(210)=0
4469 MSUB(211)=0
4470 MSUB(212)=0
4471 ENDIF
4472
4473 ELSEIF(MSEL.EQ.43) THEN
4474C...Neutralino/Chargino + Gluino/Squark.
4475 IF(MINT(43).EQ.4) THEN
4476 DO 260 I=237,242
4477 MSUB(I)=1
4478 260 CONTINUE
4479 DO 270 I=246,257
4480 MSUB(I)=1
4481 270 CONTINUE
4482 ENDIF
4483
4484 ELSEIF(MSEL.EQ.44) THEN
4485C...Neutralino/Chargino pair production.
4486 IF(MINT(43).EQ.4) THEN
4487 DO 280 I=216,236
4488 MSUB(I)=1
4489 280 CONTINUE
4490 ELSEIF(MINT(43).EQ.1) THEN
4491 DO 290 I=216,228
4492 MSUB(I)=1
4493 290 CONTINUE
4494 ENDIF
4495
4496 ELSEIF(MSEL.EQ.45) THEN
4497C...Sbottom production.
4498 MSUB(287)=1
4499 MSUB(288)=1
4500 IF(MINT(43).EQ.4) THEN
4501 DO 300 I=281,296
4502 MSUB(I)=1
4503 300 CONTINUE
4504 ENDIF
4505
4506 ELSEIF(MSEL.EQ.50) THEN
4507 DO 305 I=361,368
4508 MSUB(I)=1
4509 305 CONTINUE
4510 IF(MINT(43).EQ.4) THEN
4511 DO 307 I=370,377
4512 MSUB(I)=1
4513 307 CONTINUE
4514 ENDIF
4515
4516 ENDIF
4517
4518C...Find heaviest new quark flavour allowed in processes 81-84.
4519 KFLQM=1
4520 DO 310 I=1,MIN(8,MDCY(21,3))
4521 IDC=I+MDCY(21,2)-1
4522 IF(MDME(IDC,1).LE.0) GOTO 310
4523 KFLQM=I
4524 310 CONTINUE
4525 IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9))
4526 &KFLQM=MSTP(7)
4527 MINT(55)=KFLQM
4528 KFPR(81,1)=KFLQM
4529 KFPR(81,2)=KFLQM
4530 KFPR(82,1)=KFLQM
4531 KFPR(82,2)=KFLQM
4532 KFPR(83,1)=KFLQM
4533 KFPR(84,1)=KFLQM
4534 KFPR(84,2)=KFLQM
4535
4536C...Find heaviest new fermion flavour allowed in process 85.
4537 KFLFM=1
4538 DO 320 I=1,MIN(12,MDCY(22,3))
4539 IDC=I+MDCY(22,2)-1
4540 IF(MDME(IDC,1).LE.0) GOTO 320
4541 KFLFM=KFDP(IDC,1)
4542 320 CONTINUE
4543 IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND.
4544 &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7)
4545 MINT(56)=KFLFM
4546 KFPR(85,1)=KFLFM
4547 KFPR(85,2)=KFLFM
4548
4549 RETURN
4550 END
4551
4552C*********************************************************************
4553
4554C...PYXTOT
4555C...Parametrizes total, elastic and diffractive cross-sections
4556C...for different energies and beams. Donnachie-Landshoff for
4557C...total and Schuler-Sjostrand for elastic and diffractive.
4558C...Process code IPROC:
4559C...= 1 : p + p;
4560C...= 2 : pbar + p;
4561C...= 3 : pi+ + p;
4562C...= 4 : pi- + p;
4563C...= 5 : pi0 + p;
4564C...= 6 : phi + p;
4565C...= 7 : J/psi + p;
4566C...= 11 : rho + rho;
4567C...= 12 : rho + phi;
4568C...= 13 : rho + J/psi;
4569C...= 14 : phi + phi;
4570C...= 15 : phi + J/psi;
4571C...= 16 : J/psi + J/psi;
4572C...= 21 : gamma + p (DL);
4573C...= 22 : gamma + p (VDM).
4574C...= 23 : gamma + pi (DL);
4575C...= 24 : gamma + pi (VDM);
4576C...= 25 : gamma + gamma (DL);
4577C...= 26 : gamma + gamma (VDM).
4578
4579 SUBROUTINE PYXTOT
4580
4581C...Double precision and integer declarations.
4582 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4583 IMPLICIT INTEGER(I-N)
4584 INTEGER PYK,PYCHGE,PYCOMP
4585C...Commonblocks.
4586 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4587 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4588 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4589 COMMON/PYINT1/MINT(400),VINT(400)
4590 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
4591 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
4592 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/
4593C...Local arrays.
4594 DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20),
4595 &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8),
4596 &CEFFD(10,9),SIGTMP(6,0:5)
4597
4598C...Common constants.
4599 DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/,
4600 &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/,
4601 &FACDD/0.0084D0/
4602
4603C...Number of multiple processes to be evaluated (= 0 : undefined).
4604 DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
4605C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
4606 DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0,
4607 &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0,
4608 &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/
4609 DATA YPAR/
4610 &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0,
4611 &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0,
4612 &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/
4613
4614C...Beam and target hadron class:
4615C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
4616 DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
4617 DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/
4618C...Characteristic class masses, slope parameters, beta = sqrt(X).
4619 DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/
4620 DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
4621 DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/
4622
4623C...Fitting constants used in parametrizations of diffractive results.
4624 DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
4625 DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
4626 DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/
4627 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0,
4628 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0,
4629 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0,
4630 &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0,
4631 &0.267D0, 0.0D0, -0.46D0, 75D0, 0.267D0, 0.0D0, -0.46D0, 75D0,
4632 &0.232D0, 0.0D0, -0.46D0, 85D0, 0.267D0, 0.0D0, -0.48D0, 100D0,
4633 &0.115D0, 0.0D0, -0.50D0, 90D0, 0.267D0, 6.0D0, -0.56D0, 420D0,
4634 &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0,
4635 &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0,
4636 &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/
4637 DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/
4638 &3.11D0, -7.34D0, 9.71D0, 0.068D0, -0.42D0, 1.31D0,
4639 &-1.37D0, 35.0D0, 118D0, 3.11D0, -7.10D0, 10.6D0,
4640 &0.073D0, -0.41D0, 1.17D0, -1.41D0, 31.6D0, 95D0,
4641 &3.12D0, -7.43D0, 9.21D0, 0.067D0, -0.44D0, 1.41D0,
4642 &-1.35D0, 36.5D0, 132D0, 3.13D0, -8.18D0, -4.20D0,
4643 &0.056D0, -0.71D0, 3.12D0, -1.12D0, 55.2D0, 1298D0,
4644 &3.11D0, -6.90D0, 11.4D0, 0.078D0, -0.40D0, 1.05D0,
4645 &-1.40D0, 28.4D0, 78D0, 3.11D0, -7.13D0, 10.0D0,
4646 &0.071D0, -0.41D0, 1.23D0, -1.34D0, 33.1D0, 105D0,
4647 &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0, 2.72D0,
4648 &-1.13D0, 53.1D0, 995D0, 3.11D0, -7.39D0, 8.22D0,
4649 &0.065D0, -0.44D0, 1.45D0, -1.36D0, 38.1D0, 148D0,
4650 &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0, 3.32D0,
4651 &-1.12D0, 55.6D0, 1472D0, 4.18D0, -29.2D0, 56.2D0,
4652 &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/
4653
4654C...Parameters. Combinations of the energy.
4655 AEM=PARU(101)
4656 PMTH=PARP(102)
4657 S=VINT(2)
4658 SRT=VINT(1)
4659 SEPS=S**EPS
4660 SETA=S**ETA
4661 SLOG=LOG(S)
4662
4663C...Ratio of gamma/pi (for rescaling in parton distributions).
4664 VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/
4665 &(XPAR(5)*SEPS+YPAR(5)*SETA)
4666 VINT(317)=1D0
4667 IF(MINT(50).NE.1) RETURN
4668
4669C...Order flavours of incoming particles: KF1 < KF2.
4670 IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN
4671 KF1=IABS(MINT(11))
4672 KF2=IABS(MINT(12))
4673 IORD=1
4674 ELSE
4675 KF1=IABS(MINT(12))
4676 KF2=IABS(MINT(11))
4677 IORD=2
4678 ENDIF
4679 ISGN12=ISIGN(1,MINT(11)*MINT(12))
4680
4681C...Find process number (for lookup tables).
4682 IF(KF1.GT.1000) THEN
4683 IPROC=1
4684 IF(ISGN12.LT.0) IPROC=2
4685 ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN
4686 IPROC=3
4687 IF(ISGN12.LT.0) IPROC=4
4688 IF(KF1.EQ.111) IPROC=5
4689 ELSEIF(KF1.GT.100) THEN
4690 IPROC=11
4691 ELSEIF(KF2.GT.1000) THEN
4692 IPROC=21
4693 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=22
4694 ELSEIF(KF2.GT.100) THEN
4695 IPROC=23
4696 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=24
4697 ELSE
4698 IPROC=25
4699 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7) IPROC=26
4700 ENDIF
4701
4702C... Number of multiple processes to be stored; beam/target side.
4703 NPR=NPROC(IPROC)
4704 MINT(101)=1
4705 MINT(102)=1
4706 IF(NPR.EQ.3) THEN
4707 MINT(100+IORD)=4
4708 ELSEIF(NPR.EQ.6) THEN
4709 MINT(101)=4
4710 MINT(102)=4
4711 ENDIF
4712 N1=0
4713 IF(MINT(101).EQ.4) N1=4
4714 N2=0
4715 IF(MINT(102).EQ.4) N2=4
4716
4717C...Do not do any more for user-set or undefined cross-sections.
4718 IF(MSTP(31).LE.0) RETURN
4719 IF(NPR.EQ.0) CALL PYERRM(26,
4720 &'(PYXTOT:) cross section for this process not yet implemented')
4721
4722C...Parameters. Combinations of the energy.
4723 AEM=PARU(101)
4724 PMTH=PARP(102)
4725 S=VINT(2)
4726 SRT=VINT(1)
4727 SEPS=S**EPS
4728 SETA=S**ETA
4729 SLOG=LOG(S)
4730
4731C...Loop over multiple processes (for VDM).
4732 DO 110 I=1,NPR
4733 IF(NPR.EQ.1) THEN
4734 IPR=IPROC
4735 ELSEIF(NPR.EQ.3) THEN
4736 IPR=I+4
4737 IF(KF2.LT.1000) IPR=I+10
4738 ELSEIF(NPR.EQ.6) THEN
4739 IPR=I+10
4740 ENDIF
4741
4742C...Evaluate hadron species, mass, slope contribution and fit number.
4743 IHA=IHADA(IPR)
4744 IHB=IHADB(IPR)
4745 PMA=PMHAD(IHA)
4746 PMB=PMHAD(IHB)
4747 BHA=BHAD(IHA)
4748 BHB=BHAD(IHB)
4749 ISD=IFITSD(IPR)
4750 IDD=IFITDD(IPR)
4751
4752C...Skip if energy too low relative to masses.
4753 DO 100 J=0,5
4754 SIGTMP(I,J)=0D0
4755 100 CONTINUE
4756 IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110
4757
4758C...Total cross-section. Elastic slope parameter and cross-section.
4759 SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA
4760 BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0
4761 SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL
4762
4763C...Diffractive scattering A + B -> X + B.
4764 BSD=2D0*BHB
4765 SQML=(PMA+PMTH)**2
4766 SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2)
4767 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
4768 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
4769 BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
4770 SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/
4771 & (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
4772 SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2)
4773
4774C...Diffractive scattering A + B -> A + X.
4775 BSD=2D0*BHA
4776 SQML=(PMB+PMTH)**2
4777 SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6)
4778 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
4779 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
4780 BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
4781 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/
4782 & (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
4783 SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2)
4784
4785C...Order single diffractive correctly.
4786 IF(IORD.EQ.2) THEN
4787 SIGSAV=SIGTMP(I,2)
4788 SIGTMP(I,2)=SIGTMP(I,3)
4789 SIGTMP(I,3)=SIGSAV
4790 ENDIF
4791
4792C...Double diffractive scattering A + B -> X1 + X2.
4793 YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2)
4794 DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2
4795 SUM1=DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0)/(2D0*ALP)
4796 IF(YEFF.LE.0) SUM1=0D0
4797 SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2)
4798 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC))))
4799 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC))))
4800 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/
4801 & (2D0*ALP)
4802 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC))))
4803 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC))))
4804 SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/
4805 & (2D0*ALP)
4806 BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S
4807 SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB*PMRC)))
4808 SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*
4809 & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX)
4810 SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4)
4811
4812C...Non-diffractive by unitarity.
4813 SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)-
4814 & SIGTMP(I,4)
4815 110 CONTINUE
4816
4817C...Put temporary results in output array: only one process.
4818 IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN
4819 DO 120 J=0,5
4820 SIGT(0,0,J)=SIGTMP(1,J)
4821 120 CONTINUE
4822
4823C...Beam multiple processes.
4824 ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN
4825 IF(MINT(107).EQ.2) THEN
4826 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
4827 ELSE
4828 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
4829 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
4830 ENDIF
4831 IF(MSTP(20).GT.0) THEN
4832 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)))**MSTP(20)
4833 ENDIF
4834 DO 140 I=1,4
4835 IF(MINT(107).EQ.2) THEN
4836 CONV=(AEM/PARP(160+I))*VINT(317)
4837 ELSEIF(VINT(154).GT.PARP(15)) THEN
4838 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
4839 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
4840 ELSE
4841 CONV=0D0
4842 ENDIF
4843 I1=MAX(1,I-1)
4844 DO 130 J=0,5
4845 SIGT(I,0,J)=CONV*SIGTMP(I1,J)
4846 130 CONTINUE
4847 140 CONTINUE
4848 DO 150 J=0,5
4849 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
4850 150 CONTINUE
4851
4852C...Target multiple processes.
4853 ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN
4854 IF(MINT(108).EQ.2) THEN
4855 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
4856 ELSE
4857 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
4858 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
4859 ENDIF
4860 IF(MSTP(20).GT.0) THEN
4861 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(308)))**MSTP(20)
4862 ENDIF
4863 DO 170 I=1,4
4864 IF(MINT(108).EQ.2) THEN
4865 CONV=(AEM/PARP(160+I))*VINT(317)
4866 ELSEIF(VINT(154).GT.PARP(15)) THEN
4867 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
4868 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
4869 ELSE
4870 CONV=0D0
4871 ENDIF
4872 IV=MAX(1,I-1)
4873 DO 160 J=0,5
4874 SIGT(0,I,J)=CONV*SIGTMP(IV,J)
4875 160 CONTINUE
4876 170 CONTINUE
4877 DO 180 J=0,5
4878 SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J)
4879 180 CONTINUE
4880
4881C...Both beam and target multiple processes.
4882 ELSE
4883 IF(MINT(107).EQ.2) THEN
4884 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
4885 ELSE
4886 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
4887 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
4888 ENDIF
4889 IF(MINT(108).EQ.2) THEN
4890 VINT(317)=VINT(317)*(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
4891 ELSE
4892 VINT(317)=VINT(317)*16D0*PARP(15)**2*VINT(154)**2/
4893 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
4894 ENDIF
4895 IF(MSTP(20).GT.0) THEN
4896 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)+
4897 & VINT(308)))**MSTP(20)
4898 ENDIF
4899 DO 210 I1=1,4
4900 DO 200 I2=1,4
4901 IF(MINT(107).EQ.2) THEN
4902 CONV=(AEM/PARP(160+I1))*VINT(317)
4903 ELSEIF(VINT(154).GT.PARP(15)) THEN
4904 CONV=(AEM/PARU(1))*(KCHG(I1,1)/3D0)**2*PARP(18)**2*
4905 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
4906 ELSE
4907 CONV=0D0
4908 ENDIF
4909 IF(MINT(108).EQ.2) THEN
4910 CONV=CONV*(AEM/PARP(160+I2))
4911 ELSEIF(VINT(154).GT.PARP(15)) THEN
4912 CONV=CONV*(AEM/PARU(1))*(KCHG(I2,1)/3D0)**2*PARP(18)**2*
4913 & (1D0/PARP(15)**2-1D0/VINT(154)**2)
4914 ELSE
4915 CONV=0D0
4916 ENDIF
4917 IF(I1.LE.2) THEN
4918 IV=MAX(1,I2-1)
4919 ELSEIF(I2.LE.2) THEN
4920 IV=MAX(1,I1-1)
4921 ELSEIF(I1.EQ.I2) THEN
4922 IV=2*I1-2
4923 ELSE
4924 IV=5
4925 ENDIF
4926 DO 190 J=0,5
4927 JV=J
4928 IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J
4929 SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV)
4930 190 CONTINUE
4931 200 CONTINUE
4932 210 CONTINUE
4933 DO 230 J=0,5
4934 DO 220 I=1,4
4935 SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J)
4936 SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J)
4937 220 CONTINUE
4938 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
4939 230 CONTINUE
4940 ENDIF
4941
4942C...Scale up uniformly for Donnachie-Landshoff parametrization.
4943 IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN
4944 RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0)
4945 DO 260 I1=0,N1
4946 DO 250 I2=0,N2
4947 DO 240 J=0,5
4948 SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J)
4949 240 CONTINUE
4950 250 CONTINUE
4951 260 CONTINUE
4952 ENDIF
4953
4954 RETURN
4955 END
4956
4957C*********************************************************************
4958
4959C...PYMAXI
4960C...Finds optimal set of coefficients for kinematical variable selection
4961C...and the maximum of the part of the differential cross-section used
4962C...in the event weighting.
4963
4964 SUBROUTINE PYMAXI
4965
4966C...Double precision and integer declarations.
4967 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4968 IMPLICIT INTEGER(I-N)
4969 INTEGER PYK,PYCHGE,PYCOMP
4970C...Parameter statement to help give large particle numbers.
4971 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
4972C...Commonblocks.
4973 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4974 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4975 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
4976 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4977 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4978 COMMON/PYINT1/MINT(400),VINT(400)
4979 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4980 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
4981 COMMON/PYINT4/MWID(500),WIDS(500,5)
4982 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
4983 COMMON/PYINT6/PROC(0:500)
4984 CHARACTER PROC*28
4985 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
4986 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
4987 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/
4988C...Local arrays, character variables and data.
4989 CHARACTER CVAR(4)*4
4990 DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500),
4991 &NAREL(7),WTREL(7),WTMAT(7,7),WTRELN(7),COEFU(7),COEFO(7),
4992 &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2)
4993 DATA CVAR/'tau ','tau''','y* ','cth '/
4994 DATA SIGSSM/3*0D0/
4995
4996C...Initial values and loop over subprocesses.
4997 NPOSI=0
4998 VINT(143)=1D0
4999 VINT(144)=1D0
5000 XSEC(0,1)=0D0
5001 DO 460 ISUB=1,500
5002 MINT(1)=ISUB
5003 MINT(51)=0
5004
5005C...Find maximum weight factors for photon flux.
5006 IF(MSUB(ISUB).EQ.1.OR.(ISUB.GE.91.AND.ISUB.LE.100)) THEN
5007 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(2,WTGAGA)
5008 ENDIF
5009
5010C...Select subprocess to study: skip cases not applicable.
5011 IF(ISET(ISUB).EQ.11) THEN
5012 IF(MSUB(ISUB).NE.1) GOTO 460
5013 XSEC(ISUB,1)=1.00001D0*COEF(ISUB,1)
5014 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
5015 & WTGAGA*XSEC(ISUB,1)
5016 NPOSI=NPOSI+1
5017 GOTO 450
5018 ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN
5019 CALL PYSIGH(NCHN,SIGS)
5020 XSEC(ISUB,1)=SIGS
5021 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
5022 & WTGAGA*XSEC(ISUB,1)
5023 IF(MSUB(ISUB).NE.1) GOTO 460
5024 NPOSI=NPOSI+1
5025 GOTO 450
5026 ELSEIF(ISUB.EQ.99.AND.MSUB(ISUB).EQ.1) THEN
5027 CALL PYSIGH(NCHN,SIGS)
5028 XSEC(ISUB,1)=SIGS
5029 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
5030 & WTGAGA*XSEC(ISUB,1)
5031 IF(XSEC(ISUB,1).EQ.0D0) THEN
5032 MSUB(ISUB)=0
5033 ELSE
5034 NPOSI=NPOSI+1
5035 ENDIF
5036 GOTO 450
5037 ELSEIF(ISUB.EQ.96) THEN
5038 IF(MINT(50).EQ.0) GOTO 460
5039 IF(MSUB(95).NE.1.AND.MSTP(81).LE.0.AND.MSTP(131).LE.0)
5040 & GOTO 460
5041 IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460
5042 ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
5043 & ISUB.EQ.53.OR.ISUB.EQ.68) THEN
5044 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
5045 ELSE
5046 IF(MSUB(ISUB).NE.1) GOTO 460
5047 ENDIF
5048 ISTSB=ISET(ISUB)
5049 IF(ISUB.EQ.96) ISTSB=2
5050 IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB
5051 MWTXS=0
5052 IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+
5053 & MSUB(94)+MSUB(95).EQ.0) MWTXS=1
5054
5055C...Find resonances (explicit or implicit in cross-section).
5056 MINT(72)=0
5057 KFR1=0
5058 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
5059 KFR1=KFPR(ISUB,1)
5060 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165
5061 & .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
5062 KFR1=23
5063 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172
5064 & .OR.ISUB.EQ.177) THEN
5065 KFR1=24
5066 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
5067 KFR1=25
5068 IF(MSTP(46).EQ.5) THEN
5069 KFR1=30
5070 PMAS(30,1)=PARP(45)
5071 PMAS(30,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
5072 ENDIF
5073 ELSEIF(ISUB.EQ.194) THEN
5074 KFR1=54
5075 ELSEIF(ISUB.EQ.195) THEN
5076 KFR1=55
5077 ELSEIF(ISUB.GE.361.AND.ISUB.LE.368) THEN
5078 KFR1=54
5079 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
5080 KFR1=55
5081 ENDIF
5082 CKMX=CKIN(2)
5083 IF(CKMX.LE.0D0) CKMX=VINT(1)
5084 KCR1=PYCOMP(KFR1)
5085 IF(KFR1.NE.0) THEN
5086 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
5087 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
5088 ENDIF
5089 IF(KFR1.NE.0) THEN
5090 TAUR1=PMAS(KCR1,1)**2/VINT(2)
5091 IF(KFR1.EQ.54) THEN
5092 CALL PYTECM(S1,S2)
5093 TAUR1=S1/VINT(2)
5094 ENDIF
5095 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
5096 MINT(72)=1
5097 MINT(73)=KFR1
5098 VINT(73)=TAUR1
5099 VINT(74)=GAMR1
5100 ENDIF
5101 KFR2=0
5102 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.(ISUB.GE.364.AND.ISUB.LE.368))
5103 $ THEN
5104 KFR2=23
5105 IF(ISUB.EQ.194) THEN
5106 KFR2=56
5107 ELSEIF(ISUB.GE.364.AND.ISUB.LE.368) THEN
5108 KFR2=56
5109 ENDIF
5110 KCR2=PYCOMP(KFR2)
5111 TAUR2=PMAS(KCR2,1)**2/VINT(2)
5112 IF(KFR2.EQ.56) THEN
5113 CALL PYTECM(S1,S2)
5114 TAUR2=S2/VINT(2)
5115 ENDIF
5116 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
5117 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
5118 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
5119 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
5120 MINT(72)=2
5121 MINT(74)=KFR2
5122 VINT(75)=TAUR2
5123 VINT(76)=GAMR2
5124 ELSEIF(KFR2.NE.0) THEN
5125 KFR1=KFR2
5126 TAUR1=TAUR2
5127 GAMR1=GAMR2
5128 MINT(72)=1
5129 MINT(73)=KFR1
5130 VINT(73)=TAUR1
5131 VINT(74)=GAMR1
5132 KFR2=0
5133 ENDIF
5134 ENDIF
5135
5136C...Find product masses and minimum pT of process.
5137 SQM3=0D0
5138 SQM4=0D0
5139 MINT(71)=0
5140 VINT(71)=CKIN(3)
5141 VINT(80)=1D0
5142 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
5143 NBW=0
5144 DO 110 I=1,2
5145 PMMN(I)=0D0
5146 IF(KFPR(ISUB,I).EQ.0) THEN
5147 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
5148 & PARP(41)) THEN
5149 IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
5150 IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
5151 ELSE
5152 NBW=NBW+1
5153C...This prevents SUSY/t particles from becoming too light.
5154 KFLW=KFPR(ISUB,I)
5155 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
5156 KCW=PYCOMP(KFLW)
5157 PMMN(I)=PMAS(KCW,1)
5158 DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
5159 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
5160 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
5161 & PMAS(PYCOMP(KFDP(IDC,2)),1)
5162 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
5163 & PMAS(PYCOMP(KFDP(IDC,3)),1)
5164 PMMN(I)=MIN(PMMN(I),PMSUM)
5165 ENDIF
5166 100 CONTINUE
5167 ELSEIF(KFLW.EQ.6) THEN
5168 PMMN(I)=PMAS(24,1)+PMAS(5,1)
5169 ENDIF
5170 ENDIF
5171 110 CONTINUE
5172 IF(NBW.GE.1) THEN
5173 CKIN41=CKIN(41)
5174 CKIN43=CKIN(43)
5175 CKIN(41)=MAX(PMMN(1),CKIN(41))
5176 CKIN(43)=MAX(PMMN(2),CKIN(43))
5177 CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
5178 CKIN(41)=CKIN41
5179 CKIN(43)=CKIN43
5180 IF(MINT(51).EQ.1) THEN
5181 WRITE(MSTU(11),5100) ISUB
5182 MSUB(ISUB)=0
5183 GOTO 460
5184 ENDIF
5185 SQM3=PQM3**2
5186 SQM4=PQM4**2
5187 ENDIF
5188 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
5189 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
5190 IF(ISUB.EQ.96.AND.MSTP(82).LE.1) THEN
5191 VINT(71)=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
5192 ELSEIF(ISUB.EQ.96) THEN
5193 VINT(71)=0.08D0*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
5194 ENDIF
5195 ENDIF
5196 VINT(63)=SQM3
5197 VINT(64)=SQM4
5198
5199C...Prepare for additional variable choices in 2 -> 3.
5200 IF(ISTSB.EQ.5) THEN
5201 VINT(201)=0D0
5202 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
5203 VINT(206)=VINT(201)
5204 VINT(204)=PMAS(23,1)
5205 IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
5206 IF(ISUB.EQ.352) VINT(204)=PMAS(63,1)
5207 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182
5208 & .OR.ISUB.EQ.186.OR.ISUB.EQ.187) VINT(204)=VINT(201)
5209 VINT(209)=VINT(204)
5210 ENDIF
5211
5212C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
5213 NPTS(1)=2+2*MINT(72)
5214 IF(MINT(47).EQ.1) THEN
5215 IF(ISTSB.EQ.1.OR.ISTSB.EQ.2) NPTS(1)=1
5216 ELSEIF(MINT(47).GE.5) THEN
5217 IF(ISTSB.LE.2.OR.ISTSB.GT.5) NPTS(1)=NPTS(1)+1
5218 ENDIF
5219 NPTS(2)=1
5220 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
5221 IF(MINT(47).GE.2) NPTS(2)=2
5222 IF(MINT(47).GE.5) NPTS(2)=3
5223 ENDIF
5224 NPTS(3)=1
5225 IF(MINT(47).EQ.4.OR.MINT(47).EQ.5) THEN
5226 NPTS(3)=3
5227 IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1
5228 IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1
5229 ENDIF
5230 NPTS(4)=1
5231 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
5232 NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
5233
5234C...Reset coefficients of cross-section weighting.
5235 DO 120 J=1,20
5236 COEF(ISUB,J)=0D0
5237 120 CONTINUE
5238 COEF(ISUB,1)=1D0
5239 COEF(ISUB,8)=0.5D0
5240 COEF(ISUB,9)=0.5D0
5241 COEF(ISUB,13)=1D0
5242 COEF(ISUB,18)=1D0
5243 MCTH=0
5244 MTAUP=0
5245 METAUP=0
5246 VINT(23)=0D0
5247 VINT(26)=0D0
5248 SIGSAM=0D0
5249
5250C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
5251C...in grid of phase space points.
5252 CALL PYKLIM(1)
5253 METAU=MINT(51)
5254 NACC=0
5255 DO 150 ITRY=1,NTRY
5256 MINT(51)=0
5257 IF(METAU.EQ.1) GOTO 150
5258 IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
5259 MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
5260 IF(MTAU.GT.2+2*MINT(72)) MTAU=7
5261 RTAU=0.5D0
5262C...Special case when both resonances have same mass,
5263C...as is often the case in process 194.
5264 IF(MINT(72).EQ.2) THEN
5265 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
5266 & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
5267 IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
5268 RTAU=0.4D0
5269 ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
5270 RTAU=0.6D0
5271 ENDIF
5272 ENDIF
5273 ENDIF
5274 CALL PYKMAP(1,MTAU,RTAU)
5275 IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4)
5276 METAUP=MINT(51)
5277 ENDIF
5278 IF(METAUP.EQ.1) GOTO 150
5279 IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4))
5280 & .EQ.0) THEN
5281 MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
5282 CALL PYKMAP(4,MTAUP,0.5D0)
5283 ENDIF
5284 IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN
5285 CALL PYKLIM(2)
5286 MEYST=MINT(51)
5287 ENDIF
5288 IF(MEYST.EQ.1) GOTO 150
5289 IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
5290 MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
5291 IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5
5292 CALL PYKMAP(2,MYST,0.5D0)
5293 CALL PYKLIM(3)
5294 MECTH=MINT(51)
5295 ENDIF
5296 IF(MECTH.EQ.1) GOTO 150
5297 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
5298 MCTH=1+MOD(ITRY-1,NPTS(4))
5299 CALL PYKMAP(3,MCTH,0.5D0)
5300 ENDIF
5301 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2)
5302
5303C...Store position and limits.
5304 MINT(51)=0
5305 CALL PYKLIM(0)
5306 IF(MINT(51).EQ.1) GOTO 150
5307 NACC=NACC+1
5308 MVARPT(NACC,1)=MTAU
5309 MVARPT(NACC,2)=MTAUP
5310 MVARPT(NACC,3)=MYST
5311 MVARPT(NACC,4)=MCTH
5312 DO 130 J=1,30
5313 VINTPT(NACC,J)=VINT(10+J)
5314 130 CONTINUE
5315
5316C...Normal case: calculate cross-section.
5317 IF(ISTSB.NE.5) THEN
5318 CALL PYSIGH(NCHN,SIGS)
5319 IF(MWTXS.EQ.1) THEN
5320 CALL PYEVWT(WTXS)
5321 SIGS=WTXS*SIGS
5322 ENDIF
5323
5324C..2 -> 3: find highest value out of a number of tries.
5325 ELSE
5326 SIGS=0D0
5327 DO 140 IKIN3=1,MSTP(129)
5328 CALL PYKMAP(5,0,0D0)
5329 IF(MINT(51).EQ.1) GOTO 140
5330 CALL PYSIGH(NCHN,SIGTMP)
5331 IF(MWTXS.EQ.1) THEN
5332 CALL PYEVWT(WTXS)
5333 SIGTMP=WTXS*SIGTMP
5334 ENDIF
5335 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
5336 140 CONTINUE
5337 ENDIF
5338
5339C...Store cross-section.
5340 SIGSPT(NACC)=SIGS
5341 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
5342 IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP,
5343 & VINT(21),VINT(22),VINT(23),VINT(26),SIGS
5344 150 CONTINUE
5345 IF(NACC.EQ.0) THEN
5346 WRITE(MSTU(11),5100) ISUB
5347 MSUB(ISUB)=0
5348 GOTO 460
5349 ELSEIF(SIGSAM.EQ.0D0) THEN
5350 WRITE(MSTU(11),5300) ISUB
5351 MSUB(ISUB)=0
5352 GOTO 460
5353 ENDIF
5354 IF(ISUB.NE.96) NPOSI=NPOSI+1
5355
5356C...Calculate integrals in tau over maximal phase space limits.
5357 TAUMIN=VINT(11)
5358 TAUMAX=VINT(31)
5359 ATAU1=LOG(TAUMAX/TAUMIN)
5360 IF(NPTS(1).GE.2) THEN
5361 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
5362 ENDIF
5363 IF(NPTS(1).GE.4) THEN
5364 ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
5365 ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
5366 & GAMR1
5367 ENDIF
5368 IF(NPTS(1).GE.6) THEN
5369 ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
5370 ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
5371 & GAMR2
5372 ENDIF
5373 IF(NPTS(1).GT.2+2*MINT(72)) THEN
5374 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
5375 ENDIF
5376
5377C...Reset. Sum up cross-sections in points calculated.
5378 DO 320 IVAR=1,4
5379 IF(NPTS(IVAR).EQ.1) GOTO 320
5380 IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320
5381 NBIN=NPTS(IVAR)
5382 DO 170 J1=1,NBIN
5383 NAREL(J1)=0
5384 WTREL(J1)=0D0
5385 COEFU(J1)=0D0
5386 DO 160 J2=1,NBIN
5387 WTMAT(J1,J2)=0D0
5388 160 CONTINUE
5389 170 CONTINUE
5390 DO 180 IACC=1,NACC
5391 IBIN=MVARPT(IACC,IVAR)
5392 IF(IVAR.EQ.1.AND.IBIN.EQ.7) IBIN=3+2*MINT(72)
5393 IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4
5394 NAREL(IBIN)=NAREL(IBIN)+1
5395 WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
5396
5397C...Sum up tau cross-section pieces in points used.
5398 IF(IVAR.EQ.1) THEN
5399 TAU=VINTPT(IACC,11)
5400 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
5401 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
5402 IF(NBIN.GE.4) THEN
5403 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
5404 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
5405 & ((TAU-TAUR1)**2+GAMR1**2)
5406 ENDIF
5407 IF(NBIN.GE.6) THEN
5408 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
5409 WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
5410 & ((TAU-TAUR2)**2+GAMR2**2)
5411 ENDIF
5412 IF(NBIN.GT.2+2*MINT(72)) THEN
5413 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(ATAU1/ATAU7)*
5414 & TAU/MAX(2D-10,1D0-TAU)
5415 ENDIF
5416
5417C...Sum up tau' cross-section pieces in points used.
5418 ELSEIF(IVAR.EQ.2) THEN
5419 TAU=VINTPT(IACC,11)
5420 TAUP=VINTPT(IACC,16)
5421 TAUPMN=VINTPT(IACC,6)
5422 TAUPMX=VINTPT(IACC,26)
5423 ATAUP1=LOG(TAUPMX/TAUPMN)
5424 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
5425 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
5426 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*
5427 & (1D0-TAU/TAUP)**3/TAUP
5428 IF(NBIN.GE.3) THEN
5429 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
5430 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)*
5431 & TAUP/MAX(2D-10,1D0-TAUP)
5432 ENDIF
5433
5434C...Sum up y* cross-section pieces in points used.
5435 ELSEIF(IVAR.EQ.3) THEN
5436 YST=VINTPT(IACC,12)
5437 YSTMIN=VINTPT(IACC,2)
5438 YSTMAX=VINTPT(IACC,22)
5439 AYST0=YSTMAX-YSTMIN
5440 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
5441 AYST2=AYST1
5442 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
5443 WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
5444 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST)
5445 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
5446 IF(MINT(45).EQ.3) THEN
5447 TAUE=VINTPT(IACC,11)
5448 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
5449 YST0=-0.5D0*LOG(TAUE)
5450 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
5451 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
5452 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/
5453 & MAX(1D-10,1D0-EXP(YST-YST0))
5454 ENDIF
5455 IF(MINT(46).EQ.3) THEN
5456 TAUE=VINTPT(IACC,11)
5457 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
5458 YST0=-0.5D0*LOG(TAUE)
5459 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
5460 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
5461 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/
5462 & MAX(1D-10,1D0-EXP(-YST-YST0))
5463 ENDIF
5464
5465C...Sum up cos(theta-hat) cross-section pieces in points used.
5466 ELSE
5467 RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2)
5468 RSQM=1D0+RM34
5469 CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2)))
5470 CTHMIN=-CTHMAX
5471 IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/
5472 & (TAUMAX*VINT(2)))
5473 ACTH1=CTHMAX-CTHMIN
5474 ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
5475 ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
5476 ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
5477 ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
5478 CTH=VINTPT(IACC,13)
5479 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
5480 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
5481 & MAX(RM34,RSQM-CTH)
5482 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
5483 & MAX(RM34,RSQM+CTH)
5484 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
5485 & MAX(RM34,RSQM-CTH)**2
5486 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
5487 & MAX(RM34,RSQM+CTH)**2
5488 ENDIF
5489 180 CONTINUE
5490
5491C...Check that equation system solvable.
5492 IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
5493 MSOLV=1
5494 WTRELS=0D0
5495 DO 190 IBIN=1,NBIN
5496 IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
5497 & IRED=1,NBIN),WTREL(IBIN)
5498 IF(NAREL(IBIN).EQ.0) MSOLV=0
5499 WTRELS=WTRELS+WTREL(IBIN)
5500 190 CONTINUE
5501 IF(ABS(WTRELS).LT.1D-20) MSOLV=0
5502
5503C...Solve to find relative importance of cross-section pieces.
5504 IF(MSOLV.EQ.1) THEN
5505 DO 200 IBIN=1,NBIN
5506 WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
5507 200 CONTINUE
5508 DO 230 IRED=1,NBIN-1
5509 DO 220 IBIN=IRED+1,NBIN
5510 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
5511 MSOLV=0
5512 GOTO 260
5513 ENDIF
5514 RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
5515 WTREL(IBIN)=WTREL(IBIN)-RQT*WTREL(IRED)
5516 DO 210 ICOE=IRED,NBIN
5517 WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-RQT*WTMAT(IRED,ICOE)
5518 210 CONTINUE
5519 220 CONTINUE
5520 230 CONTINUE
5521 DO 250 IRED=NBIN,1,-1
5522 DO 240 ICOE=IRED+1,NBIN
5523 WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
5524 240 CONTINUE
5525 COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
5526 250 CONTINUE
5527 ENDIF
5528
5529C...Share evenly if failure.
5530 260 IF(MSOLV.EQ.0) THEN
5531 DO 270 IBIN=1,NBIN
5532 COEFU(IBIN)=1D0
5533 WTRELN(IBIN)=0.1D0
5534 IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0,
5535 & WTREL(IBIN)/WTRELS)
5536 270 CONTINUE
5537 ENDIF
5538
5539C...Normalize coefficients, with piece shared democratically.
5540 COEFSU=0D0
5541 WTRELS=0D0
5542 DO 280 IBIN=1,NBIN
5543 COEFU(IBIN)=MAX(0D0,COEFU(IBIN))
5544 COEFSU=COEFSU+COEFU(IBIN)
5545 WTRELS=WTRELS+WTRELN(IBIN)
5546 280 CONTINUE
5547 IF(COEFSU.GT.0D0) THEN
5548 DO 290 IBIN=1,NBIN
5549 COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0*
5550 & (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS)
5551 290 CONTINUE
5552 ELSE
5553 DO 300 IBIN=1,NBIN
5554 COEFO(IBIN)=1D0/NBIN
5555 300 CONTINUE
5556 ENDIF
5557 IF(IVAR.EQ.1) IOFF=0
5558 IF(IVAR.EQ.2) IOFF=17
5559 IF(IVAR.EQ.3) IOFF=7
5560 IF(IVAR.EQ.4) IOFF=12
5561 DO 310 IBIN=1,NBIN
5562 ICOF=IOFF+IBIN
5563 IF(IVAR.EQ.1.AND.IBIN.GT.2+2*MINT(72)) ICOF=7
5564 IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
5565 COEF(ISUB,ICOF)=COEFO(IBIN)
5566 310 CONTINUE
5567 IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR),
5568 & (COEFO(IBIN),IBIN=1,NBIN)
5569 320 CONTINUE
5570
5571C...Find two most promising maxima among points previously determined.
5572 DO 330 J=1,4
5573 IACCMX(J)=0
5574 SIGSMX(J)=0D0
5575 330 CONTINUE
5576 NMAX=0
5577 DO 390 IACC=1,NACC
5578 DO 340 J=1,30
5579 VINT(10+J)=VINTPT(IACC,J)
5580 340 CONTINUE
5581 IF(ISTSB.NE.5) THEN
5582 CALL PYSIGH(NCHN,SIGS)
5583 IF(MWTXS.EQ.1) THEN
5584 CALL PYEVWT(WTXS)
5585 SIGS=WTXS*SIGS
5586 ENDIF
5587 ELSE
5588 SIGS=0D0
5589 DO 350 IKIN3=1,MSTP(129)
5590 CALL PYKMAP(5,0,0D0)
5591 IF(MINT(51).EQ.1) GOTO 350
5592 CALL PYSIGH(NCHN,SIGTMP)
5593 IF(MWTXS.EQ.1) THEN
5594 CALL PYEVWT(WTXS)
5595 SIGTMP=WTXS*SIGTMP
5596 ENDIF
5597 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
5598 350 CONTINUE
5599 ENDIF
5600 IEQ=0
5601 DO 360 IMV=1,NMAX
5602 IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
5603 360 CONTINUE
5604 IF(IEQ.EQ.0) THEN
5605 DO 370 IMV=NMAX,1,-1
5606 IIN=IMV+1
5607 IF(SIGS.LE.SIGSMX(IMV)) GOTO 380
5608 IACCMX(IMV+1)=IACCMX(IMV)
5609 SIGSMX(IMV+1)=SIGSMX(IMV)
5610 370 CONTINUE
5611 IIN=1
5612 380 IACCMX(IIN)=IACC
5613 SIGSMX(IIN)=SIGS
5614 IF(NMAX.LE.1) NMAX=NMAX+1
5615 ENDIF
5616 390 CONTINUE
5617
5618C...Read out starting position for search.
5619 IF(MSTP(122).GE.2) WRITE(MSTU(11),5700)
5620 SIGSAM=SIGSMX(1)
5621 DO 440 IMAX=1,NMAX
5622 IACC=IACCMX(IMAX)
5623 MTAU=MVARPT(IACC,1)
5624 MTAUP=MVARPT(IACC,2)
5625 MYST=MVARPT(IACC,3)
5626 MCTH=MVARPT(IACC,4)
5627 VTAU=0.5D0
5628 VYST=0.5D0
5629 VCTH=0.5D0
5630 VTAUP=0.5D0
5631
5632C...Starting point and step size in parameter space.
5633 DO 430 IRPT=1,2
5634 DO 420 IVAR=1,4
5635 IF(NPTS(IVAR).EQ.1) GOTO 420
5636 IF(IVAR.EQ.1) VVAR=VTAU
5637 IF(IVAR.EQ.2) VVAR=VTAUP
5638 IF(IVAR.EQ.3) VVAR=VYST
5639 IF(IVAR.EQ.4) VVAR=VCTH
5640 IF(IVAR.EQ.1) MVAR=MTAU
5641 IF(IVAR.EQ.2) MVAR=MTAUP
5642 IF(IVAR.EQ.3) MVAR=MYST
5643 IF(IVAR.EQ.4) MVAR=MCTH
5644 IF(IRPT.EQ.1) VDEL=0.1D0
5645 IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0,
5646 & 0.98D0-VVAR))
5647 IF(IRPT.EQ.1) VMAR=0.02D0
5648 IF(IRPT.EQ.2) VMAR=0.002D0
5649 IMOV0=1
5650 IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
5651 DO 410 IMOV=IMOV0,8
5652
5653C...Define new point in parameter space.
5654 IF(IMOV.EQ.0) THEN
5655 INEW=2
5656 VNEW=VVAR
5657 ELSEIF(IMOV.EQ.1) THEN
5658 INEW=3
5659 VNEW=VVAR+VDEL
5660 ELSEIF(IMOV.EQ.2) THEN
5661 INEW=1
5662 VNEW=VVAR-VDEL
5663 ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
5664 & VVAR+2D0*VDEL.LT.1D0-VMAR) THEN
5665 VVAR=VVAR+VDEL
5666 SIGSSM(1)=SIGSSM(2)
5667 SIGSSM(2)=SIGSSM(3)
5668 INEW=3
5669 VNEW=VVAR+VDEL
5670 ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
5671 & VVAR-2D0*VDEL.GT.VMAR) THEN
5672 VVAR=VVAR-VDEL
5673 SIGSSM(3)=SIGSSM(2)
5674 SIGSSM(2)=SIGSSM(1)
5675 INEW=1
5676 VNEW=VVAR-VDEL
5677 ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
5678 VDEL=0.5D0*VDEL
5679 VVAR=VVAR+VDEL
5680 SIGSSM(1)=SIGSSM(2)
5681 INEW=2
5682 VNEW=VVAR
5683 ELSE
5684 VDEL=0.5D0*VDEL
5685 VVAR=VVAR-VDEL
5686 SIGSSM(3)=SIGSSM(2)
5687 INEW=2
5688 VNEW=VVAR
5689 ENDIF
5690
5691C...Convert to relevant variables and find derived new limits.
5692 ILERR=0
5693 IF(IVAR.EQ.1) THEN
5694 VTAU=VNEW
5695 CALL PYKMAP(1,MTAU,VTAU)
5696 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
5697 CALL PYKLIM(4)
5698 IF(MINT(51).EQ.1) ILERR=1
5699 ENDIF
5700 ENDIF
5701 IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
5702 & ILERR.EQ.0) THEN
5703 IF(IVAR.EQ.2) VTAUP=VNEW
5704 CALL PYKMAP(4,MTAUP,VTAUP)
5705 ENDIF
5706 IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
5707 CALL PYKLIM(2)
5708 IF(MINT(51).EQ.1) ILERR=1
5709 ENDIF
5710 IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
5711 IF(IVAR.EQ.3) VYST=VNEW
5712 CALL PYKMAP(2,MYST,VYST)
5713 CALL PYKLIM(3)
5714 IF(MINT(51).EQ.1) ILERR=1
5715 ENDIF
5716 IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
5717 & ILERR.EQ.0) THEN
5718 IF(IVAR.EQ.4) VCTH=VNEW
5719 CALL PYKMAP(3,MCTH,VCTH)
5720 ENDIF
5721 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
5722
5723C...Evaluate cross-section. Save new maximum. Final maximum.
5724 IF(ILERR.NE.0) THEN
5725 SIGS=0.
5726 ELSEIF(ISTSB.NE.5) THEN
5727 CALL PYSIGH(NCHN,SIGS)
5728 IF(MWTXS.EQ.1) THEN
5729 CALL PYEVWT(WTXS)
5730 SIGS=WTXS*SIGS
5731 ENDIF
5732 ELSE
5733 SIGS=0D0
5734 DO 400 IKIN3=1,MSTP(129)
5735 CALL PYKMAP(5,0,0D0)
5736 IF(MINT(51).EQ.1) GOTO 400
5737 CALL PYSIGH(NCHN,SIGTMP)
5738 IF(MWTXS.EQ.1) THEN
5739 CALL PYEVWT(WTXS)
5740 SIGTMP=WTXS*SIGTMP
5741 ENDIF
5742 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
5743 400 CONTINUE
5744 ENDIF
5745 SIGSSM(INEW)=SIGS
5746 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
5747 IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
5748 & IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
5749 410 CONTINUE
5750 420 CONTINUE
5751 430 CONTINUE
5752 440 CONTINUE
5753 IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
5754 XSEC(ISUB,1)=1.05D0*SIGSAM
5755 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
5756 & WTGAGA*XSEC(ISUB,1)
5757 450 CONTINUE
5758 IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
5759 & PARP(174)*XSEC(ISUB,1)
5760 IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
5761 460 CONTINUE
5762 MINT(51)=0
5763
5764C...Print summary table.
5765 IF(MINT(121).EQ.1.AND.NPOSI.EQ.0) THEN
5766 WRITE(MSTU(11),5900)
5767 STOP
5768 ENDIF
5769 IF(MSTP(122).GE.1) THEN
5770 WRITE(MSTU(11),6000)
5771 WRITE(MSTU(11),6100)
5772 DO 470 ISUB=1,500
5773 IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470
5774 IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470
5775 IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MSTP(81).LE.0) GOTO 470
5776 IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470
5777 IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13
5778 & .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470
5779 WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1)
5780 470 CONTINUE
5781 WRITE(MSTU(11),6300)
5782 ENDIF
5783
5784C...Format statements for maximization results.
5785 5000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
5786 &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X,
5787 &'cth',9X,'tau''',7X,'sigma')
5788 5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ',
5789 &'phase space.'/1X,'Process switched off!')
5790 5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4)
5791 5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ',
5792 &'cross-section.'/1X,'Process switched off!')
5793 5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
5794 5500 FORMAT(1X,1P,8D11.3)
5795 5600 FORMAT(1X,'Result for ',A4,':',7F9.4)
5796 5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
5797 &'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
5798 5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4)
5799 5900 FORMAT(1X,'Error: no requested process has non-vanishing ',
5800 &'cross-section.'/1X,'Execution stopped!')
5801 6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
5802 &'cross-section maximum search',1X,8('*'))
5803 6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ',
5804 &'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I',
5805 &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
5806 6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I')
5807 6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
5808
5809 RETURN
5810 END
5811
5812C*********************************************************************
5813
5814C...PYPILE
5815C...Initializes multiplicity distribution and selects mutliplicity
5816C...of pileup events, i.e. several events occuring at the same
5817C...beam crossing.
5818
5819 SUBROUTINE PYPILE(MPILE)
5820
5821C...Double precision and integer declarations.
5822 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5823 IMPLICIT INTEGER(I-N)
5824 INTEGER PYK,PYCHGE,PYCOMP
5825C...Commonblocks.
5826 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5827 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5828 COMMON/PYINT1/MINT(400),VINT(400)
5829 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
5830 SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
5831C...Local arrays and saved variables.
5832 DIMENSION WTI(0:200)
5833 SAVE IMIN,IMAX,WTI,WTS
5834
5835C...Sum of allowed cross-sections for pileup events.
5836 IF(MPILE.EQ.1) THEN
5837 VINT(131)=SIGT(0,0,5)
5838 IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
5839 IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
5840 IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
5841 IF(MSTP(133).LE.0) RETURN
5842
5843C...Initialize multiplicity distribution at maximum.
5844 XNAVE=VINT(131)*PARP(131)
5845 IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
5846 INAVE=MAX(1,MIN(200,NINT(XNAVE)))
5847 WTI(INAVE)=1D0
5848 WTS=WTI(INAVE)
5849 WTN=WTI(INAVE)*INAVE
5850
5851C...Find shape of multiplicity distribution below maximum.
5852 IMIN=INAVE
5853 DO 100 I=INAVE-1,1,-1
5854 IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
5855 IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
5856 IF(WTI(I).LT.1D-6) GOTO 110
5857 WTS=WTS+WTI(I)
5858 WTN=WTN+WTI(I)*I
5859 IMIN=I
5860 100 CONTINUE
5861
5862C...Find shape of multiplicity distribution above maximum.
5863 110 IMAX=INAVE
5864 DO 120 I=INAVE+1,200
5865 IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
5866 IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
5867 IF(WTI(I).LT.1D-6) GOTO 130
5868 WTS=WTS+WTI(I)
5869 WTN=WTN+WTI(I)*I
5870 IMAX=I
5871 120 CONTINUE
5872 130 VINT(132)=XNAVE
5873 VINT(133)=WTN/WTS
5874 IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
5875 & WTS/(WTS+WTI(1)/XNAVE)
5876 IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
5877 IF(MSTP(133).GE.2) VINT(134)=XNAVE
5878
5879C...Pick multiplicity of pileup events.
5880 ELSE
5881 IF(MSTP(133).LE.0) THEN
5882 MINT(81)=MAX(1,MSTP(134))
5883 ELSE
5884 WTR=WTS*PYR(0)
5885 DO 140 I=IMIN,IMAX
5886 MINT(81)=I
5887 WTR=WTR-WTI(I)
5888 IF(WTR.LE.0D0) GOTO 150
5889 140 CONTINUE
5890 150 CONTINUE
5891 ENDIF
5892 ENDIF
5893
5894C...Format statement for error message.
5895 5000 FORMAT(1X,'Warning: requested average number of events per bunch',
5896 &'crossing too large, ',1P,D12.4)
5897
5898 RETURN
5899 END
5900
5901C*********************************************************************
5902
5903C...PYSAVE
5904C...Saves and restores parameter and cross section values for the
5905C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alnternatives.
5906C...Also makes random choice between alternatives.
5907
5908 SUBROUTINE PYSAVE(ISAVE,IGA)
5909
5910C...Double precision and integer declarations.
5911 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5912 IMPLICIT INTEGER(I-N)
5913 INTEGER PYK,PYCHGE,PYCOMP
5914C...Commonblocks.
5915 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5916 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5917 COMMON/PYINT1/MINT(400),VINT(400)
5918 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5919 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5920 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
5921 SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/,/PYINT7/
5922C...Local arrays and saved variables.
5923 DIMENSION NCP(15),NSUBCP(15,20),MSUBCP(15,20),COEFCP(15,20,20),
5924 &NGENCP(15,0:20,3),XSECCP(15,0:20,3),SIGTCP(15,0:6,0:6,0:5),
5925 &INTCP(15,20),RECP(15,20)
5926 SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,SIGTCP,INTCP,RECP
5927
5928C...Save list of subprocesses and cross-section information.
5929 IF(ISAVE.EQ.1) THEN
5930 ICP=0
5931 DO 120 I=1,500
5932 IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
5933 ICP=ICP+1
5934 NSUBCP(IGA,ICP)=I
5935 MSUBCP(IGA,ICP)=MSUB(I)
5936 DO 100 J=1,20
5937 COEFCP(IGA,ICP,J)=COEF(I,J)
5938 100 CONTINUE
5939 DO 110 J=1,3
5940 NGENCP(IGA,ICP,J)=NGEN(I,J)
5941 XSECCP(IGA,ICP,J)=XSEC(I,J)
5942 110 CONTINUE
5943 120 CONTINUE
5944 NCP(IGA)=ICP
5945 DO 130 J=1,3
5946 NGENCP(IGA,0,J)=NGEN(0,J)
5947 XSECCP(IGA,0,J)=XSEC(0,J)
5948 130 CONTINUE
5949 DO 136 I1=0,6
5950 DO 134 I2=0,6
5951 DO 132 J=0,5
5952 SIGTCP(IGA,I1,I2,J)=SIGT(I1,I2,J)
5953 132 CONTINUE
5954 134 CONTINUE
5955 136 CONTINUE
5956
5957C...Save various common process variables.
5958 DO 140 J=1,10
5959 INTCP(IGA,J)=MINT(40+J)
5960 140 CONTINUE
5961 INTCP(IGA,11)=MINT(101)
5962 INTCP(IGA,12)=MINT(102)
5963 INTCP(IGA,13)=MINT(107)
5964 INTCP(IGA,14)=MINT(108)
5965 INTCP(IGA,15)=MINT(123)
5966 RECP(IGA,1)=CKIN(3)
5967 RECP(IGA,2)=VINT(318)
5968
5969C...Save cross-section information only.
5970 ELSEIF(ISAVE.EQ.2) THEN
5971 DO 160 ICP=1,NCP(IGA)
5972 I=NSUBCP(IGA,ICP)
5973 DO 150 J=1,3
5974 NGENCP(IGA,ICP,J)=NGEN(I,J)
5975 XSECCP(IGA,ICP,J)=XSEC(I,J)
5976 150 CONTINUE
5977 160 CONTINUE
5978 DO 170 J=1,3
5979 NGENCP(IGA,0,J)=NGEN(0,J)
5980 XSECCP(IGA,0,J)=XSEC(0,J)
5981 170 CONTINUE
5982
5983C...Choose between allowed alternatives.
5984 ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
5985 IF(ISAVE.EQ.4) THEN
5986 XSUMCP=0D0
5987 DO 180 IG=1,MINT(121)
5988 XSUMCP=XSUMCP+XSECCP(IG,0,1)
5989 180 CONTINUE
5990 XSUMCP=XSUMCP*PYR(0)
5991 DO 190 IG=1,MINT(121)
5992 IGA=IG
5993 XSUMCP=XSUMCP-XSECCP(IG,0,1)
5994 IF(XSUMCP.LE.0D0) GOTO 200
5995 190 CONTINUE
5996 200 CONTINUE
5997 ENDIF
5998
5999C...Restore cross-section information.
6000 DO 210 I=1,500
6001 MSUB(I)=0
6002 210 CONTINUE
6003 DO 240 ICP=1,NCP(IGA)
6004 I=NSUBCP(IGA,ICP)
6005 MSUB(I)=MSUBCP(IGA,ICP)
6006 DO 220 J=1,20
6007 COEF(I,J)=COEFCP(IGA,ICP,J)
6008 220 CONTINUE
6009 DO 230 J=1,3
6010 NGEN(I,J)=NGENCP(IGA,ICP,J)
6011 XSEC(I,J)=XSECCP(IGA,ICP,J)
6012 230 CONTINUE
6013 240 CONTINUE
6014 DO 250 J=1,3
6015 NGEN(0,J)=NGENCP(IGA,0,J)
6016 XSEC(0,J)=XSECCP(IGA,0,J)
6017 250 CONTINUE
6018 DO 256 I1=0,6
6019 DO 254 I2=0,6
6020 DO 252 J=0,5
6021 SIGT(I1,I2,J)=SIGTCP(IGA,I1,I2,J)
6022 252 CONTINUE
6023 254 CONTINUE
6024 256 CONTINUE
6025
6026C...Restore various common process variables.
6027 DO 260 J=1,10
6028 MINT(40+J)=INTCP(IGA,J)
6029 260 CONTINUE
6030 MINT(101)=INTCP(IGA,11)
6031 MINT(102)=INTCP(IGA,12)
6032 MINT(107)=INTCP(IGA,13)
6033 MINT(108)=INTCP(IGA,14)
6034 MINT(123)=INTCP(IGA,15)
6035 CKIN(3)=RECP(IGA,1)
6036 CKIN(1)=2D0*CKIN(3)
6037 VINT(318)=RECP(IGA,2)
6038
6039C...Sum up cross-section info (for PYSTAT).
6040 ELSEIF(ISAVE.EQ.5) THEN
6041 DO 270 I=1,500
6042 MSUB(I)=0
6043 NGEN(I,1)=0
6044 NGEN(I,3)=0
6045 XSEC(I,3)=0D0
6046 270 CONTINUE
6047 NGEN(0,1)=0
6048 NGEN(0,2)=0
6049 NGEN(0,3)=0
6050 XSEC(0,3)=0
6051 DO 290 IG=1,MINT(121)
6052 DO 280 ICP=1,NCP(IG)
6053 I=NSUBCP(IG,ICP)
6054 IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1
6055 NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1)
6056 NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3)
6057 XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3)
6058 280 CONTINUE
6059 NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1)
6060 NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2)
6061 NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3)
6062 XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3)
6063 290 CONTINUE
6064 ENDIF
6065
6066 RETURN
6067 END
6068
6069C*********************************************************************
6070
6071C...PYGAGA
6072C...For lepton beams it gives photon-hadron or photon-photon systems
6073C...to be treated with the ordinary machinery and combines this with a
6074C...description of the lepton -> lepton + photon branching.
6075
6076 SUBROUTINE PYGAGA(IGAGA,WTGAGA)
6077
6078C...Double precision and integer declarations.
6079 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6080 IMPLICIT INTEGER(I-N)
6081 INTEGER PYK,PYCHGE,PYCOMP
6082C...Commonblocks.
6083 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
6084 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6085 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6086 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
6087 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6088 COMMON/PYINT1/MINT(400),VINT(400)
6089 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6090 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
6091 &/PYINT5/
6092C...Local variables and data statement.
6093 DIMENSION PMS(2),XMIN(2),XMAX(2),Q2MIN(2),Q2MAX(2),PMC(3),
6094 &X(2),Q2(2),Y(2),THETA(2),PHI(2),PT(2),BETA(3)
6095 SAVE PMS,XMIN,XMAX,Q2MIN,Q2MAX,PMC,X,Q2,THETA,PHI,PT,W2MIN
6096 DATA EPS/1D-4/
6097
6098C...Initialize generation of photons inside leptons.
6099 IF(IGAGA.EQ.1) THEN
6100
6101C...Save quantities on incoming lepton system.
6102 VINT(301)=VINT(1)
6103 VINT(302)=VINT(2)
6104 PMS(1)=VINT(303)**2
6105 IF(MINT(141).EQ.0) PMS(1)=SIGN(VINT(3)**2,VINT(3))
6106 PMS(2)=VINT(304)**2
6107 IF(MINT(142).EQ.0) PMS(2)=SIGN(VINT(4)**2,VINT(4))
6108 PMC(3)=VINT(302)-PMS(1)-PMS(2)
6109 W2MIN=MAX(CKIN(77),2D0*CKIN(3),2D0*CKIN(5))**2
6110
6111C...Calculate range of x and Q2 values allowed in generation.
6112 DO 100 I=1,2
6113 PMC(I)=VINT(302)+PMS(I)-PMS(3-I)
6114 IF(MINT(140+I).NE.0) THEN
6115 XMIN(I)=MAX(CKIN(59+2*I),EPS)
6116 XMAX(I)=MIN(CKIN(60+2*I),1D0-2D0*VINT(301)*SQRT(PMS(I))/
6117 & PMC(I),1D0-EPS)
6118 YMIN=MAX(CKIN(71+2*I),EPS)
6119 YMAX=MIN(CKIN(72+2*I),1D0-EPS)
6120 IF(CKIN(64+2*I).GT.0D0) XMIN(I)=MAX(XMIN(I),
6121 & (YMIN*PMC(3)-CKIN(64+2*I))/PMC(I))
6122 XMAX(I)=MIN(XMAX(I),(YMAX*PMC(3)-CKIN(63+2*I))/PMC(I))
6123 THEMIN=MAX(CKIN(67+2*I),0D0)
6124 THEMAX=MIN(CKIN(68+2*I),PARU(1))
6125 IF(CKIN(68+2*I).LT.0D0) THEMAX=PARU(1)
6126 Q2MIN(I)=MAX(CKIN(63+2*I),XMIN(I)**2*PMS(I)/(1D0-XMIN(I))+
6127 & ((1D0-XMAX(I))*(VINT(302)-2D0*PMS(3-I))-
6128 & 2D0*PMS(I)/(1D0-XMAX(I)))*SIN(THEMIN/2D0)**2,0D0)
6129 Q2MAX(I)=XMAX(I)**2*PMS(I)/(1D0-XMAX(I))+
6130 & ((1D0-XMIN(I))*(VINT(302)-2D0*PMS(3-I))-
6131 & 2D0*PMS(I)/(1D0-XMIN(I)))*SIN(THEMAX/2D0)**2
6132 IF(CKIN(64+2*I).GT.0D0) Q2MAX(I)=MIN(CKIN(64+2*I),Q2MAX(I))
6133C...W limits when lepton on one side only.
6134 IF(MINT(143-I).EQ.0) THEN
6135 XMIN(I)=MAX(XMIN(I),(W2MIN-PMS(3-I))/PMC(I))
6136 IF(CKIN(78).GT.0D0) XMAX(I)=MIN(XMAX(I),
6137 & (CKIN(78)**2-PMS(3-I))/PMC(I))
6138 ENDIF
6139 ENDIF
6140 100 CONTINUE
6141
6142C...W limits when lepton on both sides.
6143 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
6144 IF(CKIN(78).GT.0D0) XMAX(1)=MIN(XMAX(1),
6145 & (CKIN(78)**2+PMC(3)-PMC(2)*XMIN(2))/PMC(1))
6146 IF(CKIN(78).GT.0D0) XMAX(2)=MIN(XMAX(2),
6147 & (CKIN(78)**2+PMC(3)-PMC(1)*XMIN(1))/PMC(2))
6148 IF(IABS(MINT(141)).NE.IABS(MINT(142))) THEN
6149 XMIN(1)=MAX(XMIN(1),(PMS(1)-PMS(2)+VINT(302)*(W2MIN-
6150 & PMS(1)-PMS(2))/(PMC(2)*XMAX(2)+PMS(1)-PMS(2)))/PMC(1))
6151 XMIN(2)=MAX(XMIN(2),(PMS(2)-PMS(1)+VINT(302)*(W2MIN-
6152 & PMS(1)-PMS(2))/(PMC(1)*XMAX(1)+PMS(2)-PMS(1)))/PMC(2))
6153 ELSE
6154 XMIN(1)=MAX(XMIN(1),W2MIN/(VINT(302)*XMAX(2)))
6155 XMIN(2)=MAX(XMIN(2),W2MIN/(VINT(302)*XMAX(1)))
6156 ENDIF
6157 ENDIF
6158
6159C...Q2 and W values and photon flux weight factors for initialization.
6160 ELSEIF(IGAGA.EQ.2) THEN
6161 ISUB=MINT(1)
6162 MINT(15)=0
6163 MINT(16)=0
6164
6165C...W value for photon on one or both sides, and for processes
6166C...with gamma-gamma cross section peaked at small shat.
6167 IF(MINT(141).NE.0.AND.MINT(142).EQ.0) THEN
6168 VINT(2)=VINT(302)+PMS(1)-PMC(1)*(1D0-XMAX(1))
6169 ELSEIF(MINT(141).EQ.0.AND.MINT(142).NE.0) THEN
6170 VINT(2)=VINT(302)+PMS(2)-PMC(2)*(1D0-XMAX(2))
6171 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
6172 VINT(2)=MAX(CKIN(77)**2,12D0*MAX(CKIN(3),CKIN(5))**2)
6173 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
6174 ELSE
6175 VINT(2)=XMAX(1)*XMAX(2)*VINT(302)
6176 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
6177 ENDIF
6178 VINT(1)=SQRT(MAX(0D0,VINT(2)))
6179
6180C...Upper estimate of photon flux weight factor.
6181C...Initialization Q2 scale. Flag incoming unresolved photon.
6182 WTGAGA=1D0
6183 DO 110 I=1,2
6184 IF(MINT(140+I).NE.0) THEN
6185 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
6186 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
6187 IF(ISUB.EQ.99.AND.MINT(106+I).EQ.4.AND.MINT(109-I).EQ.3)
6188 & THEN
6189 Q2INIT=5D0+Q2MIN(3-I)
6190 ELSEIF(ISUB.EQ.99.AND.MINT(106+I).EQ.4) THEN
6191 Q2INIT=PMAS(PYCOMP(113),1)**2+Q2MIN(3-I)
6192 ELSEIF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
6193 Q2INIT=MAX(CKIN(1),2D0*CKIN(3),2D0*CKIN(5))**2/3D0
6194 ELSEIF((ISUB.EQ.138.AND.I.EQ.2).OR.
6195 & (ISUB.EQ.139.AND.I.EQ.1)) THEN
6196 Q2INIT=VINT(2)/3D0
6197 ELSEIF(ISUB.EQ.140) THEN
6198 Q2INIT=VINT(2)/2D0
6199 ELSE
6200 Q2INIT=Q2MIN(I)
6201 ENDIF
6202 VINT(2+I)=-SQRT(MAX(Q2MIN(I),MIN(Q2MAX(I),Q2INIT)))
6203 IF(MSTP(14).EQ.0.OR.(ISUB.GE.131.AND.ISUB.LE.140))
6204 & MINT(14+I)=22
6205 VINT(306+I)=VINT(2+I)**2
6206 ENDIF
6207 110 CONTINUE
6208 VINT(320)=WTGAGA
6209
6210C...Update pTmin and cross section information.
6211 IF(MSTP(82).LE.1) THEN
6212 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
6213 ELSE
6214 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
6215 ENDIF
6216 VINT(149)=4D0*PTMN**2/VINT(2)
6217 VINT(154)=PTMN
6218 CALL PYXTOT
6219 VINT(318)=VINT(317)
6220
6221C...Generate photons inside leptons and
6222C...calculate photon flux weight factors.
6223 ELSEIF(IGAGA.EQ.3) THEN
6224 ISUB=MINT(1)
6225 MINT(15)=0
6226 MINT(16)=0
6227
6228C...Generate phase space point and check against cuts.
6229 LOOP=0
6230 120 LOOP=LOOP+1
6231 DO 130 I=1,2
6232 IF(MINT(140+I).NE.0) THEN
6233C...Pick x and Q2
6234 X(I)=XMIN(I)*(XMAX(I)/XMIN(I))**PYR(0)
6235 Q2(I)=Q2MIN(I)*(Q2MAX(I)/Q2MIN(I))**PYR(0)
6236C...Cuts on internal consistency in x and Q2.
6237 IF(Q2(I).LT.X(I)**2*PMS(I)/(1D0-X(I))) GOTO 120
6238 IF(Q2(I).GT.(1D0-X(I))*(VINT(302)-2D0*PMS(3-I))-
6239 & (2D0-X(I)**2)*PMS(I)/(1D0-X(I))) GOTO 120
6240C...Cuts on y and theta.
6241 Y(I)=(PMC(I)*X(I)+Q2(I))/PMC(3)
6242 IF(Y(I).LT.CKIN(71+2*I).OR.Y(I).GT.CKIN(72+2*I)) GOTO 120
6243 RAT=((1D0-X(I))*Q2(I)-X(I)**2*PMS(I))/
6244 & ((1D0-X(I))**2*(VINT(302)-2D0*PMS(3-I)-2D0*PMS(I)))
6245 THETA(I)=2D0*ASIN(SQRT(MAX(0D0,MIN(1D0,RAT))))
6246 IF(THETA(I).LT.CKIN(67+2*I)) GOTO 120
6247 IF(CKIN(68+2*I).GT.0D0.AND.THETA(I).GT.CKIN(68+2*I))
6248 & GOTO 120
6249
6250C...Phi angle isotropic. Reconstruct pT.
6251 PHI(I)=PARU(2)*PYR(0)
6252 PT(I)=SQRT(((1D0-X(I))*PMC(I))**2/(4D0*VINT(302))-
6253 & PMS(I))*SIN(THETA(I))
6254
6255C...Store info on variables selected, for documentation purposes.
6256 VINT(2+I)=-SQRT(Q2(I))
6257 VINT(304+I)=X(I)
6258 VINT(306+I)=Q2(I)
6259 VINT(308+I)=Y(I)
6260 VINT(310+I)=THETA(I)
6261 VINT(312+I)=PHI(I)
6262 ELSE
6263 VINT(304+I)=1D0
6264 VINT(306+I)=0D0
6265 VINT(308+I)=1D0
6266 VINT(310+I)=0D0
6267 VINT(312+I)=0D0
6268 ENDIF
6269 130 CONTINUE
6270
6271C...Cut on W combines info from two sides.
6272 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
6273 W2=-Q2(1)-Q2(2)+0.5D0*X(1)*PMC(1)*X(2)*PMC(2)/VINT(302)-
6274 & 2D0*PT(1)*PT(2)*COS(PHI(1)-PHI(2))+2D0*
6275 & SQRT((0.5D0*X(1)*PMC(1)/VINT(301))**2+Q2(1)-PT(1)**2)*
6276 & SQRT((0.5D0*X(2)*PMC(2)/VINT(301))**2+Q2(2)-PT(2)**2)
6277 IF(W2.LT.W2MIN) GOTO 120
6278 IF(CKIN(78).GT.0D0.AND.W2.GT.CKIN(78)**2) GOTO 120
6279 PMS1=-Q2(1)
6280 PMS2=-Q2(2)
6281 ELSEIF(MINT(141).NE.0) THEN
6282 W2=(VINT(302)+PMS(1))*X(1)+PMS(2)*(1D0-X(1))
6283 PMS1=-Q2(1)
6284 PMS2=PMS(2)
6285 ELSEIF(MINT(142).NE.0) THEN
6286 W2=(VINT(302)+PMS(2))*X(2)+PMS(1)*(1D0-X(2))
6287 PMS1=PMS(1)
6288 PMS2=-Q2(2)
6289 ENDIF
6290
6291C...Store kinematics info for photon(s) in subsystem cm frame.
6292 VINT(2)=W2
6293 VINT(1)=SQRT(W2)
6294 VINT(291)=0D0
6295 VINT(292)=0D0
6296 VINT(293)=0.5D0*SQRT((W2-PMS1-PMS2)**2-4D0*PMS1*PMS2)/VINT(1)
6297 VINT(294)=0.5D0*(W2+PMS1-PMS2)/VINT(1)
6298 VINT(295)=SIGN(SQRT(ABS(PMS1)),PMS1)
6299 VINT(296)=0D0
6300 VINT(297)=0D0
6301 VINT(298)=-VINT(293)
6302 VINT(299)=0.5D0*(W2+PMS2-PMS1)/VINT(1)
6303 VINT(300)=SIGN(SQRT(ABS(PMS2)),PMS2)
6304
6305C...Assign weight for photon flux; different for transverse and
6306C...longitudinal photons. Flag incoming unresolved photon.
6307 WTGAGA=1D0
6308 DO 140 I=1,2
6309 IF(MINT(140+I).NE.0) THEN
6310 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
6311 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
6312 IF(MSTP(16).EQ.0) THEN
6313 XY=X(I)
6314 ELSE
6315 WTGAGA=WTGAGA*X(I)/Y(I)
6316 XY=Y(I)
6317 ENDIF
6318 IF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
6319 WTGAGA=WTGAGA*(1D0-XY)
6320 ELSEIF(I.EQ.1.AND.(ISUB.EQ.139.OR.ISUB.EQ.140)) THEN
6321 WTGAGA=WTGAGA*(1D0-XY)
6322 ELSEIF(I.EQ.2.AND.(ISUB.EQ.138.OR.ISUB.EQ.140)) THEN
6323 WTGAGA=WTGAGA*(1D0-XY)
6324 ELSE
6325 WTGAGA=WTGAGA*(0.5D0*(1D0+(1D0-XY)**2)-
6326 & PMS(I)*XY**2/Q2(I))
6327 ENDIF
6328 IF(MINT(106+I).EQ.0) MINT(14+I)=22
6329 ENDIF
6330 140 CONTINUE
6331 VINT(319)=WTGAGA
6332 MINT(143)=LOOP
6333
6334C...Update pTmin and cross section information.
6335 IF(MSTP(82).LE.1) THEN
6336 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
6337 ELSE
6338 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
6339 ENDIF
6340 VINT(149)=4D0*PTMN**2/VINT(2)
6341 VINT(154)=PTMN
6342 CALL PYXTOT
6343
6344C...Reconstruct kinematics of photons inside leptons.
6345 ELSEIF(IGAGA.EQ.4) THEN
6346
6347C...Make place for incoming particles and scattered leptons.
6348 MOVE=3
6349 IF(MINT(141).NE.0.AND.MINT(142).NE.0) MOVE=4
6350 MINT(4)=MINT(4)+MOVE
6351 DO 160 I=MINT(84)-MOVE,MINT(83)+1,-1
6352 IF(K(I,1).EQ.21) THEN
6353 DO 150 J=1,5
6354 K(I+MOVE,J)=K(I,J)
6355 P(I+MOVE,J)=P(I,J)
6356 V(I+MOVE,J)=V(I,J)
6357 150 CONTINUE
6358 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
6359 & K(I+MOVE,3)=K(I,3)+MOVE
6360 IF(K(I,4).GT.MINT(83).AND.K(I,4).LE.MINT(84))
6361 & K(I+MOVE,4)=K(I,4)+MOVE
6362 IF(K(I,5).GT.MINT(83).AND.K(I,5).LE.MINT(84))
6363 & K(I+MOVE,5)=K(I,5)+MOVE
6364 ENDIF
6365 160 CONTINUE
6366 DO 170 I=MINT(84)+1,N
6367 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
6368 & K(I,3)=K(I,3)+MOVE
6369 170 CONTINUE
6370
6371C...Fill in incoming particles.
6372 DO 190 I=MINT(83)+1,MINT(83)+MOVE
6373 DO 180 J=1,5
6374 K(I,J)=0
6375 P(I,J)=0D0
6376 V(I,J)=0D0
6377 180 CONTINUE
6378 190 CONTINUE
6379 DO 200 I=1,2
6380 K(MINT(83)+I,1)=21
6381 IF(MINT(140+I).NE.0) THEN
6382 K(MINT(83)+I,2)=MINT(140+I)
6383 P(MINT(83)+I,5)=VINT(302+I)
6384 ELSE
6385 K(MINT(83)+I,2)=MINT(10+I)
6386 P(MINT(83)+I,5)=VINT(2+I)
6387 ENDIF
6388 P(MINT(83)+I,3)=0.5D0*SQRT((PMC(3)**2-4D0*PMS(1)*PMS(2))/
6389 & VINT(302))*(-1D0)**(I+1)
6390 P(MINT(83)+I,4)=0.5D0*PMC(I)/VINT(301)
6391 200 CONTINUE
6392
6393C...New mother-daughter relations in documentation section.
6394 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
6395 K(MINT(83)+1,4)=MINT(83)+3
6396 K(MINT(83)+1,5)=MINT(83)+5
6397 K(MINT(83)+2,4)=MINT(83)+4
6398 K(MINT(83)+2,5)=MINT(83)+6
6399 K(MINT(83)+3,3)=MINT(83)+1
6400 K(MINT(83)+5,3)=MINT(83)+1
6401 K(MINT(83)+4,3)=MINT(83)+2
6402 K(MINT(83)+6,3)=MINT(83)+2
6403 ELSEIF(MINT(141).NE.0) THEN
6404 K(MINT(83)+1,4)=MINT(83)+3
6405 K(MINT(83)+1,5)=MINT(83)+4
6406 K(MINT(83)+2,4)=MINT(83)+5
6407 K(MINT(83)+3,3)=MINT(83)+1
6408 K(MINT(83)+4,3)=MINT(83)+1
6409 K(MINT(83)+5,3)=MINT(83)+2
6410 ELSEIF(MINT(142).NE.0) THEN
6411 K(MINT(83)+1,4)=MINT(83)+4
6412 K(MINT(83)+2,4)=MINT(83)+3
6413 K(MINT(83)+2,5)=MINT(83)+5
6414 K(MINT(83)+3,3)=MINT(83)+2
6415 K(MINT(83)+4,3)=MINT(83)+1
6416 K(MINT(83)+5,3)=MINT(83)+2
6417 ENDIF
6418
6419C...Fill scattered lepton(s).
6420 DO 210 I=1,2
6421 IF(MINT(140+I).NE.0) THEN
6422 LSC=MINT(83)+MIN(I+2,MOVE)
6423 K(LSC,1)=21
6424 K(LSC,2)=MINT(140+I)
6425 P(LSC,1)=PT(I)*COS(PHI(I))
6426 P(LSC,2)=PT(I)*SIN(PHI(I))
6427 P(LSC,4)=(1D0-X(I))*P(MINT(83)+I,4)
6428 P(LSC,3)=SQRT(P(LSC,4)**2-PMS(I))*COS(THETA(I))*
6429 & (-1D0)**(I-1)
6430 P(LSC,5)=VINT(302+I)
6431 ENDIF
6432 210 CONTINUE
6433
6434C...Find incoming four-vectors to subprocess.
6435 K(N+1,1)=21
6436 IF(MINT(141).NE.0) THEN
6437 DO 220 J=1,4
6438 P(N+1,J)=P(MINT(83)+1,J)-P(MINT(83)+3,J)
6439 220 CONTINUE
6440 ELSE
6441 DO 230 J=1,4
6442 P(N+1,J)=P(MINT(83)+1,J)
6443 230 CONTINUE
6444 ENDIF
6445 K(N+2,1)=21
6446 IF(MINT(142).NE.0) THEN
6447 DO 240 J=1,4
6448 P(N+2,J)=P(MINT(83)+2,J)-P(MINT(83)+MOVE,J)
6449 240 CONTINUE
6450 ELSE
6451 DO 250 J=1,4
6452 P(N+2,J)=P(MINT(83)+2,J)
6453 250 CONTINUE
6454 ENDIF
6455
6456C...Define boost and rotation between hadronic subsystem and
6457C...collision rest frame; boost hadronic subsystem to this frame.
6458 DO 260 J=1,3
6459 BETA(J)=(P(N+1,J)+P(N+2,J))/(P(N+1,4)+P(N+2,4))
6460 260 CONTINUE
6461 CALL PYROBO(N+1,N+2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
6462 BPHI=PYANGL(P(N+1,1),P(N+1,2))
6463 CALL PYROBO(N+1,N+2,0D0,-BPHI,0D0,0D0,0D0)
6464 BTHETA=PYANGL(P(N+1,3),P(N+1,1))
6465 CALL PYROBO(MINT(83)+MOVE+1,N,BTHETA,BPHI,BETA(1),BETA(2),
6466 & BETA(3))
6467
6468C...Add on scattered leptons to final state.
6469 DO 280 I=1,2
6470 IF(MINT(140+I).NE.0) THEN
6471 LSC=MINT(83)+MIN(I+2,MOVE)
6472 N=N+1
6473 DO 270 J=1,5
6474 K(N,J)=K(LSC,J)
6475 P(N,J)=P(LSC,J)
6476 V(N,J)=V(LSC,J)
6477 270 CONTINUE
6478 K(N,1)=1
6479 K(N,3)=LSC
6480 ENDIF
6481 280 CONTINUE
6482 ENDIF
6483
6484 RETURN
6485 END
6486
6487C*********************************************************************
6488
6489C...PYRAND
6490C...Generates quantities characterizing the high-pT scattering at the
6491C...parton level according to the matrix elements. Chooses incoming,
6492C...reacting partons, their momentum fractions and one of the possible
6493C...subprocesses.
6494
6495 SUBROUTINE PYRAND
6496
6497C...Double precision and integer declarations.
6498 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6499 IMPLICIT INTEGER(I-N)
6500 INTEGER PYK,PYCHGE,PYCOMP
6501C...Parameter statement to help give large particle numbers.
6502 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
6503C...Commonblocks.
6504 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6505 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6506 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
6507 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
6508 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6509 COMMON/PYINT1/MINT(400),VINT(400)
6510 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
6511 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
6512 COMMON/PYINT4/MWID(500),WIDS(500,5)
6513 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6514 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
6515 COMMON/PYUPPR/NUP,KUP(20,7),NFUP,IFUP(10,2),PUP(20,5),Q2UP(0:10)
6516 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
6517 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
6518 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYUPPR/,/PYMSSM/
6519C...Local arrays.
6520 DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2)
6521
6522C...Parameters and data used in elastic/diffractive treatment.
6523 DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/,
6524 &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
6525
6526C...Initial values, specifically for (first) semihard interaction.
6527 MINT(10)=0
6528 MINT(17)=0
6529 MINT(18)=0
6530 VINT(143)=1D0
6531 VINT(144)=1D0
6532 VINT(157)=0D0
6533 VINT(158)=0D0
6534 MFAIL=0
6535 IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1
6536 ISUB=0
6537 LOOP=0
6538 100 LOOP=LOOP+1
6539 MINT(51)=0
6540 MINT(143)=1
6541
6542C...Start by assuming incoming photon is entering subprocess.
6543 IF(MINT(11).EQ.22) THEN
6544 MINT(15)=22
6545 VINT(307)=VINT(3)**2
6546 ENDIF
6547 IF(MINT(12).EQ.22) THEN
6548 MINT(16)=22
6549 VINT(308)=VINT(4)**2
6550 ENDIF
6551 MINT(103)=MINT(11)
6552 MINT(104)=MINT(12)
6553
6554C...Choice of process type - first event of pileup.
6555 INMULT=0
6556 IF(MINT(82).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96)) THEN
6557
6558C...For gamma-p or gamma-gamma first pick between alternatives.
6559 IGA=0
6560 IF(MINT(121).GT.1) CALL PYSAVE(4,IGA)
6561 MINT(122)=IGA
6562
6563C...For real gamma + gamma with different nature, flip at random.
6564 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
6565 & MSTP(14).LE.10.AND.PYR(0).GT.0.5D0) THEN
6566 MINTSV=MINT(41)
6567 MINT(41)=MINT(42)
6568 MINT(42)=MINTSV
6569 MINTSV=MINT(45)
6570 MINT(45)=MINT(46)
6571 MINT(46)=MINTSV
6572 MINTSV=MINT(107)
6573 MINT(107)=MINT(108)
6574 MINT(108)=MINTSV
6575 IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47)
6576 ENDIF
6577
6578C...Pick process type.
6579 RSUB=XSEC(0,1)*PYR(0)
6580 DO 110 I=1,500
6581 IF(MSUB(I).NE.1) GOTO 110
6582 ISUB=I
6583 RSUB=RSUB-XSEC(I,1)
6584 IF(RSUB.LE.0D0) GOTO 120
6585 110 CONTINUE
6586 120 IF(ISUB.EQ.95) ISUB=96
6587 IF(ISUB.EQ.96) INMULT=1
6588
6589C...Choice of inclusive process type - pileup events.
6590 ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
6591 RSUB=VINT(131)*PYR(0)
6592 ISUB=96
6593 IF(RSUB.GT.SIGT(0,0,5)) ISUB=94
6594 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93
6595 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92
6596 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2))
6597 & ISUB=91
6598 IF(ISUB.EQ.96) INMULT=1
6599 ENDIF
6600
6601C...Choice of photon energy and flux factor inside lepton.
6602 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
6603 CALL PYGAGA(3,WTGAGA)
6604 IF(ISUB.GE.131.AND.ISUB.LE.140) THEN
6605 CKIN(3)=MAX(VINT(285),VINT(154))
6606 CKIN(1)=2D0*CKIN(3)
6607 ENDIF
6608C...When necessary set direct/resolved photon by hand.
6609 ELSEIF(MINT(15).EQ.22.OR.MINT(16).EQ.22) THEN
6610 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
6611 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
6612 ENDIF
6613
6614C...Restrict direct*resolved processes to pTmin >= Q,
6615C...to avoid doublecounting with DIS.
6616 IF(MSTP(18).EQ.3.AND.ISUB.GE.131.AND.ISUB.LE.136) THEN
6617 IF(MINT(15).EQ.22) THEN
6618 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(3)))
6619 ELSE
6620 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(4)))
6621 ENDIF
6622 CKIN(1)=2D0*CKIN(3)
6623 ENDIF
6624
6625C...Set up for multiple interactions.
6626 IF(INMULT.EQ.1) CALL PYMULT(2)
6627
6628C...Loopback point for minimum bias in photon physics.
6629 LOOP2=0
6630 125 LOOP2=LOOP2+1
6631 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+MINT(143)
6632 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+MINT(143)
6633 IF(ISUB.EQ.96.AND.LOOP2.EQ.1.AND.MINT(82).EQ.1)
6634 &NGEN(97,1)=NGEN(97,1)+MINT(143)
6635 MINT(1)=ISUB
6636 ISTSB=ISET(ISUB)
6637
6638C...Random choice of flavour for some SUSY processes.
6639 IF(ISUB.GE.201.AND.ISUB.LE.301) THEN
6640C...~e_L ~nu_e or ~mu_L ~nu_mu.
6641 IF(ISUB.EQ.210) THEN
6642 KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0))
6643 KFPR(ISUB,2)=KFPR(ISUB,1)+1
6644C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
6645 ELSEIF(ISUB.EQ.213) THEN
6646 KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0))
6647 KFPR(ISUB,2)=KFPR(ISUB,1)
6648C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
6649 ELSEIF(ISUB.GE.246.AND.ISUB.LE.259) THEN
6650 IF(ISUB.GE.258) THEN
6651 RKF=4D0
6652 ELSE
6653 RKF=5D0
6654 ENDIF
6655 IF(MOD(ISUB,2).EQ.0) THEN
6656 KFPR(ISUB,1)=KSUSY1+1+INT(RKF*PYR(0))
6657 ELSE
6658 KFPR(ISUB,1)=KSUSY2+1+INT(RKF*PYR(0))
6659 ENDIF
6660C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
6661 ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN
6662 IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN
6663 KSU1=KSUSY1
6664 KSU2=KSUSY1
6665 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN
6666 KSU1=KSUSY2
6667 KSU2=KSUSY2
6668 ELSEIF(PYR(0).LT.0.5D0) THEN
6669 KSU1=KSUSY1
6670 KSU2=KSUSY2
6671 ELSE
6672 KSU1=KSUSY2
6673 KSU2=KSUSY1
6674 ENDIF
6675 KFPR(ISUB,1)=KSU1+1+INT(4D0*PYR(0))
6676 KFPR(ISUB,2)=KSU2+1+INT(4D0*PYR(0))
6677C...~q ~q(bar); ~q = ~d, ~u, ~s, or ~c.
6678 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN
6679 KFPR(ISUB,1)=KSUSY1+1+INT(4D0*PYR(0))
6680 KFPR(ISUB,2)=KFPR(ISUB,1)
6681 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN
6682 KFPR(ISUB,1)=KSUSY2+1+INT(4D0*PYR(0))
6683 KFPR(ISUB,2)=KFPR(ISUB,1)
6684C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
6685 ELSEIF(ISUB.GE.281.AND.ISUB.LE.286) THEN
6686 IF(ISUB.EQ.281.OR.ISUB.EQ.284) THEN
6687 KSU1=KSUSY1
6688 KSU2=KSUSY1
6689 ELSEIF(ISUB.EQ.282.OR.ISUB.EQ.285) THEN
6690 KSU1=KSUSY2
6691 KSU2=KSUSY2
6692 ELSEIF(PYR(0).LT.0.5D0) THEN
6693 KSU1=KSUSY1
6694 KSU2=KSUSY2
6695 ELSE
6696 KSU1=KSUSY2
6697 KSU2=KSUSY1
6698 ENDIF
6699 IF(ISUB.EQ.281.OR.ISUB.LE.283) THEN
6700 RKF=5D0
6701 ELSE
6702 RKF=4D0
6703 ENDIF
6704 KFPR(ISUB,2)=KSU2+1+INT(RKF*PYR(0))
6705 ENDIF
6706 ENDIF
6707
6708C...Find resonances (explicit or implicit in cross-section).
6709 MINT(72)=0
6710 KFR1=0
6711 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
6712 KFR1=KFPR(ISUB,1)
6713 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR.
6714 & ISUB.EQ.171.OR.ISUB.EQ.176) THEN
6715 KFR1=23
6716 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR.
6717 & ISUB.EQ.177) THEN
6718 KFR1=24
6719 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
6720 KFR1=25
6721 IF(MSTP(46).EQ.5) THEN
6722 KFR1=30
6723 PMAS(30,1)=PARP(45)
6724 PMAS(30,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
6725 ENDIF
6726 ELSEIF(ISUB.EQ.194) THEN
6727 KFR1=54
6728 ELSEIF(ISUB.EQ.195) THEN
6729 KFR1=55
6730 ELSEIF(ISUB.GE.361.AND.ISUB.LE.368) THEN
6731 KFR1=54
6732 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
6733 KFR1=55
6734 ENDIF
6735 CKMX=CKIN(2)
6736 IF(CKMX.LE.0D0) CKMX=VINT(1)
6737 KCR1=PYCOMP(KFR1)
6738 IF(KFR1.NE.0) THEN
6739 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
6740 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
6741 ENDIF
6742 IF(KFR1.NE.0) THEN
6743 TAUR1=PMAS(KCR1,1)**2/VINT(2)
6744 IF(KFR1.EQ.54) THEN
6745 CALL PYTECM(S1,S2)
6746 TAUR1=S1/VINT(2)
6747 ENDIF
6748 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
6749 MINT(72)=1
6750 MINT(73)=KFR1
6751 VINT(73)=TAUR1
6752 VINT(74)=GAMR1
6753 ENDIF
6754 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.(ISUB.GE.364.AND.ISUB.LE.368))
6755 $THEN
6756 KFR2=23
6757 IF(ISUB.EQ.194) THEN
6758 KFR2=56
6759 ELSEIF(ISUB.GE.364.AND.ISUB.LE.368) THEN
6760 KFR2=56
6761 ENDIF
6762 KCR2=PYCOMP(KFR2)
6763 TAUR2=PMAS(KCR2,1)**2/VINT(2)
6764 IF(KFR2.EQ.56) THEN
6765 CALL PYTECM(S1,S2)
6766 TAUR2=S2/VINT(2)
6767 ENDIF
6768 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
6769 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
6770 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
6771 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
6772 MINT(72)=2
6773 MINT(74)=KFR2
6774 VINT(75)=TAUR2
6775 VINT(76)=GAMR2
6776 ELSEIF(KFR2.NE.0) THEN
6777 KFR1=KFR2
6778 TAUR1=TAUR2
6779 GAMR1=GAMR2
6780 MINT(72)=1
6781 MINT(73)=KFR1
6782 VINT(73)=TAUR1
6783 VINT(74)=GAMR1
6784 ENDIF
6785 ENDIF
6786
6787C...Find product masses and minimum pT of process,
6788C...optionally with broadening according to a truncated Breit-Wigner.
6789 VINT(63)=0D0
6790 VINT(64)=0D0
6791 MINT(71)=0
6792 VINT(71)=CKIN(3)
6793 IF(MINT(82).GE.2) VINT(71)=0D0
6794 VINT(80)=1D0
6795 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
6796 NBW=0
6797 DO 140 I=1,2
6798 PMMN(I)=0D0
6799 IF(KFPR(ISUB,I).EQ.0) THEN
6800 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
6801 & PARP(41)) THEN
6802 VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
6803 ELSE
6804 NBW=NBW+1
6805C...This prevents SUSY/t particles from becoming too light.
6806 KFLW=KFPR(ISUB,I)
6807 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
6808 KCW=PYCOMP(KFLW)
6809 PMMN(I)=PMAS(KCW,1)
6810 DO 130 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
6811 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
6812 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
6813 & PMAS(PYCOMP(KFDP(IDC,2)),1)
6814 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
6815 & PMAS(PYCOMP(KFDP(IDC,3)),1)
6816 PMMN(I)=MIN(PMMN(I),PMSUM)
6817 ENDIF
6818 130 CONTINUE
6819 ELSEIF(KFLW.EQ.6) THEN
6820 PMMN(I)=PMAS(24,1)+PMAS(5,1)
6821 ENDIF
6822 ENDIF
6823 140 CONTINUE
6824 IF(NBW.GE.1) THEN
6825 CKIN41=CKIN(41)
6826 CKIN43=CKIN(43)
6827 CKIN(41)=MAX(PMMN(1),CKIN(41))
6828 CKIN(43)=MAX(PMMN(2),CKIN(43))
6829 CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
6830 CKIN(41)=CKIN41
6831 CKIN(43)=CKIN43
6832 IF(MINT(51).EQ.1) THEN
6833 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6834 IF(MFAIL.EQ.1) THEN
6835 MSTI(61)=1
6836 RETURN
6837 ENDIF
6838 GOTO 100
6839 ENDIF
6840 VINT(63)=PQM3**2
6841 VINT(64)=PQM4**2
6842 ENDIF
6843 IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
6844 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
6845 ENDIF
6846
6847C...Prepare for additional variable choices in 2 -> 3.
6848 IF(ISTSB.EQ.5) THEN
6849 VINT(201)=0D0
6850 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
6851 VINT(206)=VINT(201)
6852 VINT(204)=PMAS(23,1)
6853 IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
6854 IF(ISUB.EQ.352) VINT(204)=PMAS(63,1)
6855 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
6856 & ISUB.EQ.186.OR.ISUB.EQ.187) VINT(204)=VINT(201)
6857 VINT(209)=VINT(204)
6858 ENDIF
6859
6860C...Select incoming VDM particle (rho/omega/phi/J/psi).
6861 IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND.
6862 &(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7)) THEN
6863 VRN=PYR(0)*SIGT(0,0,5)
6864 IF(MINT(101).LE.1) THEN
6865 I1MN=0
6866 I1MX=0
6867 ELSE
6868 I1MN=1
6869 I1MX=MINT(101)
6870 ENDIF
6871 IF(MINT(102).LE.1) THEN
6872 I2MN=0
6873 I2MX=0
6874 ELSE
6875 I2MN=1
6876 I2MX=MINT(102)
6877 ENDIF
6878 DO 160 I1=I1MN,I1MX
6879 KFV1=110*I1+3
6880 DO 150 I2=I2MN,I2MX
6881 KFV2=110*I2+3
6882 VRN=VRN-SIGT(I1,I2,5)
6883 IF(VRN.LE.0D0) GOTO 170
6884 150 CONTINUE
6885 160 CONTINUE
6886 170 IF(MINT(101).GE.2) MINT(103)=KFV1
6887 IF(MINT(102).GE.2) MINT(104)=KFV2
6888 ENDIF
6889
6890 IF(ISTSB.EQ.0) THEN
6891C...Elastic scattering or single or double diffractive scattering.
6892
6893C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
6894 MINT(103)=MINT(11)
6895 MINT(104)=MINT(12)
6896 PMM(1)=VINT(3)
6897 PMM(2)=VINT(4)
6898 IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN
6899 JJ=ISUB-90
6900 VRN=PYR(0)*SIGT(0,0,JJ)
6901 IF(MINT(101).LE.1) THEN
6902 I1MN=0
6903 I1MX=0
6904 ELSE
6905 I1MN=1
6906 I1MX=MINT(101)
6907 ENDIF
6908 IF(MINT(102).LE.1) THEN
6909 I2MN=0
6910 I2MX=0
6911 ELSE
6912 I2MN=1
6913 I2MX=MINT(102)
6914 ENDIF
6915 DO 190 I1=I1MN,I1MX
6916 KFV1=110*I1+3
6917 DO 180 I2=I2MN,I2MX
6918 KFV2=110*I2+3
6919 VRN=VRN-SIGT(I1,I2,JJ)
6920 IF(VRN.LE.0D0) GOTO 200
6921 180 CONTINUE
6922 190 CONTINUE
6923 200 IF(MINT(101).GE.2) THEN
6924 MINT(103)=KFV1
6925 PMM(1)=PYMASS(KFV1)
6926 ENDIF
6927 IF(MINT(102).GE.2) THEN
6928 MINT(104)=KFV2
6929 PMM(2)=PYMASS(KFV2)
6930 ENDIF
6931 ENDIF
6932 VINT(67)=PMM(1)
6933 VINT(68)=PMM(2)
6934
6935C...Select mass for GVMD states (rejecting previous assignment).
6936 Q0S=4D0*PARP(15)**2
6937 Q1S=4D0*VINT(154)**2
6938 LOOP3=0
6939 202 LOOP3=LOOP3+1
6940 DO 208 JT=1,2
6941 IF(MINT(106+JT).EQ.3) THEN
6942 PS=VINT(2+JT)**2
6943 PMM(JT)=(Q0S+PS)*(Q1S+PS)/
6944 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
6945 IF(MINT(102+JT).GE.333) PMM(JT)=PMM(JT)-
6946 & PMAS(PYCOMP(113),1)+PMAS(PYCOMP(MINT(102+JT)),1)
6947 ENDIF
6948 208 CONTINUE
6949 IF(PMM(1)+PMM(2)+PARP(104).GE.VINT(1)) THEN
6950 IF(LOOP3.LT.100.AND.(MINT(107).EQ.3.OR.MINT(108).EQ.3))
6951 & GOTO 202
6952 GOTO 100
6953 ENDIF
6954
6955C...Side/sides of diffractive system.
6956 MINT(17)=0
6957 MINT(18)=0
6958 IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1
6959 IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1
6960
6961C...Find masses of particles and minimal masses of diffractive states.
6962 DO 210 JT=1,2
6963 PDIF(JT)=PMM(JT)
6964 VINT(68+JT)=PDIF(JT)
6965 IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102)
6966 210 CONTINUE
6967 SH=VINT(2)
6968 SQM1=PMM(1)**2
6969 SQM2=PMM(2)**2
6970 SQM3=PDIF(1)**2
6971 SQM4=PDIF(2)**2
6972 SMRES1=(PMM(1)+PMRC)**2
6973 SMRES2=(PMM(2)+PMRC)**2
6974
6975C...Find elastic slope and lower limit diffractive slope.
6976 IHA=MAX(2,IABS(MINT(103))/110)
6977 IF(IHA.GE.5) IHA=1
6978 IHB=MAX(2,IABS(MINT(104))/110)
6979 IF(IHB.GE.5) IHB=1
6980 IF(ISUB.EQ.91) THEN
6981 BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0
6982 ELSEIF(ISUB.EQ.92) THEN
6983 BMN=MAX(2D0,2D0*BHAD(IHB))
6984 ELSEIF(ISUB.EQ.93) THEN
6985 BMN=MAX(2D0,2D0*BHAD(IHA))
6986 ELSEIF(ISUB.EQ.94) THEN
6987 BMN=2D0*ALP*4D0
6988 ENDIF
6989
6990C...Determine maximum possible t range and coefficient of generation.
6991 SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2
6992 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
6993 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
6994 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
6995 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
6996 & (SQM1*SQM4-SQM2*SQM3)/SH
6997 THL=-0.5D0*(THA+THB)
6998 THU=THC/THL
6999 THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0
7000
7001C...Select diffractive mass/masses according to dm^2/m^2.
7002 LOOP3=0
7003 220 LOOP3=LOOP3+1
7004 DO 230 JT=1,2
7005 IF(MINT(16+JT).EQ.0) THEN
7006 PDIF(2+JT)=PDIF(JT)
7007 ELSE
7008 PMMIN=PDIF(JT)
7009 PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT))
7010 PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0)
7011 ENDIF
7012 230 CONTINUE
7013 SQM3=PDIF(3)**2
7014 SQM4=PDIF(4)**2
7015
7016C..Additional mass factors, including resonance enhancement.
7017 IF(PDIF(3)+PDIF(4).GE.VINT(1)) THEN
7018 IF(LOOP3.LT.100) GOTO 220
7019 GOTO 100
7020 ENDIF
7021 IF(ISUB.EQ.92) THEN
7022 FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3))
7023 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 220
7024 ELSEIF(ISUB.EQ.93) THEN
7025 FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4))
7026 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 220
7027 ELSEIF(ISUB.EQ.94) THEN
7028 FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/
7029 & (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))*
7030 & (1D0+CRES*SMRES2/(SMRES2+SQM4))
7031 IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 220
7032 ENDIF
7033
7034C...Select t according to exp(Bmn*t) and correct to right slope.
7035 TH=THU+LOG(1D0+THRND*PYR(0))/BMN
7036 IF(ISUB.GE.92) THEN
7037 IF(ISUB.EQ.92) THEN
7038 BADD=2D0*ALP*LOG(SH/SQM3)
7039 IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
7040 ELSEIF(ISUB.EQ.93) THEN
7041 BADD=2D0*ALP*LOG(SH/SQM4)
7042 IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
7043 ELSEIF(ISUB.EQ.94) THEN
7044 BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0)
7045 ENDIF
7046 IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 220
7047 ENDIF
7048
7049C...Check whether m^2 and t choices are consistent.
7050 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
7051 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
7052 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
7053 IF(THB.LE.1D-8) GOTO 220
7054 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
7055 & (SQM1*SQM4-SQM2*SQM3)/SH
7056 THLM=-0.5D0*(THA+THB)
7057 THUM=THC/THLM
7058 IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 220
7059
7060C...Information to output.
7061 VINT(21)=1D0
7062 VINT(22)=0D0
7063 VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB))
7064 VINT(45)=TH
7065 VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB
7066 VINT(63)=PDIF(3)**2
7067 VINT(64)=PDIF(4)**2
7068
7069C...Note: in the following, by In is meant the integral over the
7070C...quantity multiplying coefficient cn.
7071C...Choose tau according to h1(tau)/tau, where
7072C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
7073C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
7074C...I1/I5*c5*1/(tau+tau_R') +
7075C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
7076C...I1/I7*c7*tau/(1.-tau), and
7077C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
7078 ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN
7079 CALL PYKLIM(1)
7080 IF(MINT(51).NE.0) THEN
7081 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7082 IF(MFAIL.EQ.1) THEN
7083 MSTI(61)=1
7084 RETURN
7085 ENDIF
7086 GOTO 100
7087 ENDIF
7088 RTAU=PYR(0)
7089 MTAU=1
7090 IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
7091 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
7092 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
7093 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
7094 & MTAU=5
7095 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
7096 & COEF(ISUB,5)) MTAU=6
7097 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
7098 & COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7
7099 CALL PYKMAP(1,MTAU,PYR(0))
7100
7101C...2 -> 3, 4 processes:
7102C...Choose tau' according to h4(tau,tau')/tau', where
7103C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
7104C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
7105 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
7106 CALL PYKLIM(4)
7107 IF(MINT(51).NE.0) THEN
7108 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7109 IF(MFAIL.EQ.1) THEN
7110 MSTI(61)=1
7111 RETURN
7112 ENDIF
7113 GOTO 100
7114 ENDIF
7115 RTAUP=PYR(0)
7116 MTAUP=1
7117 IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2
7118 IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3
7119 CALL PYKMAP(4,MTAUP,PYR(0))
7120 ENDIF
7121
7122C...Choose y* according to h2(y*), where
7123C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
7124C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
7125C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
7126C...and c1 + c2 + c3 + c4 + c5 = 1.
7127 CALL PYKLIM(2)
7128 IF(MINT(51).NE.0) THEN
7129 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7130 IF(MFAIL.EQ.1) THEN
7131 MSTI(61)=1
7132 RETURN
7133 ENDIF
7134 GOTO 100
7135 ENDIF
7136 RYST=PYR(0)
7137 MYST=1
7138 IF(RYST.GT.COEF(ISUB,8)) MYST=2
7139 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
7140 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4
7141 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+
7142 & COEF(ISUB,11)) MYST=5
7143 CALL PYKMAP(2,MYST,PYR(0))
7144
7145C...2 -> 2 processes:
7146C...Choose cos(theta-hat) (cth) according to h3(cth), where
7147C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
7148C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
7149C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
7150C...and c0 + c1 + c2 + c3 + c4 = 1.
7151 CALL PYKLIM(3)
7152 IF(MINT(51).NE.0) THEN
7153 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7154 IF(MFAIL.EQ.1) THEN
7155 MSTI(61)=1
7156 RETURN
7157 ENDIF
7158 GOTO 100
7159 ENDIF
7160 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7161 RCTH=PYR(0)
7162 MCTH=1
7163 IF(RCTH.GT.COEF(ISUB,13)) MCTH=2
7164 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3
7165 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4
7166 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+
7167 & COEF(ISUB,16)) MCTH=5
7168 CALL PYKMAP(3,MCTH,PYR(0))
7169 ENDIF
7170
7171C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
7172 IF(ISTSB.EQ.5) THEN
7173 CALL PYKMAP(5,0,0D0)
7174 IF(MINT(51).NE.0) THEN
7175 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7176 IF(MFAIL.EQ.1) THEN
7177 MSTI(61)=1
7178 RETURN
7179 ENDIF
7180 GOTO 100
7181 ENDIF
7182 ENDIF
7183
7184C...DIS as f + gamma* -> f process: set dummy values.
7185 ELSEIF(ISTSB.EQ.8) THEN
7186 VINT(21)=0.9D0
7187 VINT(22)=0D0
7188 VINT(23)=0D0
7189 VINT(47)=0D0
7190 VINT(48)=0D0
7191
7192C...Low-pT or multiple interactions (first semihard interaction).
7193 ELSEIF(ISTSB.EQ.9) THEN
7194 CALL PYMULT(3)
7195 ISUB=MINT(1)
7196
7197C...Generate user-defined process: kinematics plus weight.
7198 ELSEIF(ISTSB.EQ.11) THEN
7199 MSTI(51)=0
7200 CALL PYUPEV(ISUB,SIGS)
7201 IF(NUP.LE.0) THEN
7202 MINT(51)=2
7203 MSTI(51)=1
7204 IF(MINT(82).EQ.1) THEN
7205 NGEN(0,1)=NGEN(0,1)-1
7206 NGEN(0,2)=NGEN(0,2)-1
7207 NGEN(ISUB,1)=NGEN(ISUB,1)-1
7208 ENDIF
7209 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7210 RETURN
7211 ENDIF
7212
7213C...Construct 'trivial' kinematical variables needed.
7214 KFL1=KUP(1,2)
7215 KFL2=KUP(2,2)
7216 VINT(41)=2D0*PUP(1,4)/VINT(1)
7217 VINT(42)=2D0*PUP(2,4)/VINT(1)
7218 VINT(21)=VINT(41)*VINT(42)
7219 VINT(22)=0.5D0*LOG(VINT(41)/VINT(42))
7220 VINT(44)=VINT(21)*VINT(2)
7221 VINT(43)=SQRT(MAX(0D0,VINT(44)))
7222 VINT(56)=Q2UP(0)
7223 VINT(55)=SQRT(MAX(0D0,VINT(56)))
7224
7225C...Construct other kinematical variables needed (approximately).
7226 VINT(23)=0D0
7227 VINT(26)=VINT(21)
7228 VINT(45)=-0.5D0*VINT(44)
7229 VINT(46)=-0.5D0*VINT(44)
7230 VINT(49)=VINT(43)
7231 VINT(50)=VINT(44)
7232 VINT(51)=VINT(55)
7233 VINT(52)=VINT(56)
7234 VINT(53)=VINT(55)
7235 VINT(54)=VINT(56)
7236 VINT(25)=0D0
7237 VINT(48)=0D0
7238 DO 240 IUP=3,NUP
7239 IF(KUP(IUP,1).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(IUP,5)**2+
7240 & PUP(IUP,1)**2+PUP(IUP,2)**2)/VINT(2)
7241 IF(KUP(IUP,1).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(IUP,1)**2+
7242 & PUP(IUP,2)**2)
7243 240 CONTINUE
7244 VINT(47)=SQRT(VINT(48))
7245
7246C...Calculate parton distribution weights.
7247 IF(MINT(47).GE.2) THEN
7248 DO 260 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
7249 MINT(105)=MINT(102+I)
7250 MINT(109)=MINT(106+I)
7251 VINT(120)=VINT(2+I)
fd658fdb 7252C.... ALICE
7253C.... Store side in MINT(124)
7254 MINT(124) = I
7255C....
952cc209 7256 IF(MSTP(57).LE.1) THEN
7257 CALL PYPDFU(MINT(10+I),VINT(40+I),Q2UP(0),XPQ)
7258 ELSE
7259 CALL PYPDFL(MINT(10+I),VINT(40+I),Q2UP(0),XPQ)
7260 ENDIF
7261 DO 250 KFL=-25,25
7262 XSFX(I,KFL)=XPQ(KFL)
7263 250 CONTINUE
7264 260 CONTINUE
7265 ENDIF
7266 ENDIF
7267
7268C...Choose azimuthal angle.
7269 VINT(24)=PARU(2)*PYR(0)
7270
7271C...Check against user cuts on kinematics at parton level.
7272 MINT(51)=0
7273 IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0)
7274 IF(MINT(51).NE.0) THEN
7275 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7276 IF(MFAIL.EQ.1) THEN
7277 MSTI(61)=1
7278 RETURN
7279 ENDIF
7280 GOTO 100
7281 ENDIF
7282 IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN
7283 MCUT=0
7284 IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
7285 & CALL PYKCUT(MCUT)
7286 IF(MCUT.NE.0) THEN
7287 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7288 IF(MFAIL.EQ.1) THEN
7289 MSTI(61)=1
7290 RETURN
7291 ENDIF
7292 GOTO 100
7293 ENDIF
7294 ENDIF
7295
7296C...Calculate differential cross-section for different subprocesses.
7297 IF(ISTSB.LE.10) CALL PYSIGH(NCHN,SIGS)
7298 SIGSOR=SIGS
7299 SIGLPT=SIGT(0,0,5)*VINT(315)*VINT(316)
7300
7301C...Multiply cross section by lepton -> photon flux factor.
7302 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
7303 SIGS=WTGAGA*SIGS
7304 DO 270 ICHN=1,NCHN
7305 SIGH(ICHN)=WTGAGA*SIGH(ICHN)
7306 270 CONTINUE
7307 SIGLPT=WTGAGA*SIGLPT
7308 ENDIF
7309
7310C...Multiply cross-section by user-defined weights.
7311 IF(MSTP(173).EQ.1) THEN
7312 SIGS=PARP(173)*SIGS
7313 DO 280 ICHN=1,NCHN
7314 SIGH(ICHN)=PARP(173)*SIGH(ICHN)
7315 280 CONTINUE
7316 SIGLPT=PARP(173)*SIGLPT
7317 ENDIF
7318 WTXS=1D0
7319 SIGSWT=SIGS
7320 VINT(99)=1D0
7321 VINT(100)=1D0
7322 IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN
7323 IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+
7324 & MSUB(95).EQ.0) CALL PYEVWT(WTXS)
7325 SIGSWT=WTXS*SIGS
7326 VINT(99)=WTXS
7327 IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS
7328 ENDIF
7329
7330C...Calculations for Monte Carlo estimate of all cross-sections.
7331 IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
7332 IF(MSTP(142).LE.1) THEN
7333 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
7334 ELSE
7335 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT
7336 ENDIF
7337 ELSEIF(MINT(82).EQ.1) THEN
7338 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
7339 ENDIF
7340 IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP2.EQ.1.AND.
7341 &MINT(82).EQ.1) XSEC(97,2)=XSEC(97,2)+SIGLPT
7342
7343C...Multiple interactions: store results of cross-section calculation.
7344 IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN
7345 VINT(153)=SIGSOR
7346 CALL PYMULT(4)
7347 ENDIF
7348
7349C...Check that weight not negative.
7350 VIOL=SIGSWT/XSEC(ISUB,1)
7351 IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174)
7352 IF(MSTP(123).LE.0) THEN
7353 IF(VIOL.LT.-1D-3) THEN
7354 WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1
7355 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
7356 & VINT(22),VINT(23),VINT(26)
7357 STOP
7358 ENDIF
7359 ELSE
7360 IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN
7361 VINT(109)=VIOL
7362 WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1
7363 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
7364 & VINT(22),VINT(23),VINT(26)
7365 ENDIF
7366 ENDIF
7367
7368C...Weighting using estimate of maximum of differential cross-section.
7369 IF(MFAIL.EQ.0.AND.ISUB.NE.95.AND.ISUB.NE.96) THEN
7370 IF(VIOL.LT.PYR(0)) THEN
7371 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7372 IF(ISUB.GE.91.AND.ISUB.LE.94) ISUB=0
7373 GOTO 100
7374 ENDIF
7375 ELSEIF(MFAIL.EQ.0) THEN
7376 RATND=SIGLPT/XSEC(95,1)
7377 IF(LOOP2.EQ.1.AND.RATND.LT.PYR(0)) THEN
7378 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7379 ISUB=0
7380 GOTO 100
7381 ENDIF
7382 VIOL=VIOL/RATND
7383 IF(VIOL.LT.PYR(0)) THEN
7384 GOTO 125
7385 ENDIF
7386 ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN
7387 IF(VIOL.LT.PYR(0)) THEN
7388 MSTI(61)=1
7389 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7390 RETURN
7391 ENDIF
7392 ELSE
7393 RATND=SIGLPT/XSEC(95,1)
7394 IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN
7395 MSTI(61)=1
7396 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7397 RETURN
7398 ENDIF
7399 VIOL=VIOL/RATND
7400 IF(VIOL.LT.PYR(0)) THEN
7401 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7402 GOTO 100
7403 ENDIF
7404 ENDIF
7405
7406C...Check for possible violation of estimated maximum of differential
7407C...cross-section used in weighting.
7408 IF(MSTP(123).LE.0) THEN
7409 IF(VIOL.GT.1D0) THEN
7410 WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1
7411 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
7412 & VINT(22),VINT(23),VINT(26)
7413 STOP
7414 ENDIF
7415 ELSEIF(MSTP(123).EQ.1) THEN
7416 IF(VIOL.GT.VINT(108)) THEN
7417 VINT(108)=VIOL
7418 IF(VIOL.GT.1D0) THEN
7419 MINT(10)=1
7420 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
7421 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
7422 & VINT(22),VINT(23),VINT(26)
7423 ENDIF
7424 ENDIF
7425 ELSEIF(VIOL.GT.VINT(108)) THEN
7426 VINT(108)=VIOL
7427 IF(VIOL.GT.1D0) THEN
7428 MINT(10)=1
7429 XDIF=XSEC(ISUB,1)*(VIOL-1D0)
7430 XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
7431 IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
7432 & XSEC(0,1)=XSEC(0,1)+XDIF
7433 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
7434 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
7435 & VINT(22),VINT(23),VINT(26)
7436 IF(ISUB.LE.9) THEN
7437 WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1)
7438 ELSEIF(ISUB.LE.99) THEN
7439 WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1)
7440 ELSE
7441 WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1)
7442 ENDIF
7443 VINT(108)=1D0
7444 ENDIF
7445 ENDIF
7446
7447C...Multiple interactions: choose impact parameter.
7448 VINT(148)=1D0
7449 IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.
7450 &MSTP(82).GE.3) THEN
7451 CALL PYMULT(5)
7452 IF(VINT(150).LT.PYR(0)) THEN
7453 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7454 IF(MFAIL.EQ.1) THEN
7455 MSTI(61)=1
7456 RETURN
7457 ENDIF
7458 GOTO 100
7459 ENDIF
7460 ENDIF
7461 IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1
7462 IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
7463 IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+MINT(143)
7464 IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
7465 ENDIF
7466 IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
7467
7468C...Choose flavour of reacting partons (and subprocess).
7469 IF(ISTSB.GE.11) GOTO 300
7470 RSIGS=SIGS*PYR(0)
7471 QT2=VINT(48)
7472 RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82)*
7473 &(VINT(1)/PARP(89))**PARP(90))**2))**2)
7474 IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
7475 &PYR(0).GT.RQQBAR)) THEN
7476 DO 290 ICHN=1,NCHN
7477 KFL1=ISIG(ICHN,1)
7478 KFL2=ISIG(ICHN,2)
7479 MINT(2)=ISIG(ICHN,3)
7480 RSIGS=RSIGS-SIGH(ICHN)
7481 IF(RSIGS.LE.0D0) GOTO 300
7482 290 CONTINUE
7483
7484C...Multiple interactions: choose qqbar preferentially at small pT.
7485 ELSEIF(ISUB.EQ.96) THEN
7486 MINT(105)=MINT(103)
7487 MINT(109)=MINT(107)
7488 CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
7489 MINT(105)=MINT(104)
7490 MINT(109)=MINT(108)
7491 CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
7492 MINT(1)=11
7493 MINT(2)=1
7494 IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2
7495
7496C...Low-pT: choose string drawing configuration.
7497 ELSE
7498 KFL1=21
7499 KFL2=21
7500 RSIGS=6D0*PYR(0)
7501 MINT(2)=1
7502 IF(RSIGS.GT.1D0) MINT(2)=2
7503 IF(RSIGS.GT.2D0) MINT(2)=3
7504 ENDIF
7505
7506C...Reassign QCD process. Partons before initial state radiation.
7507 300 IF(MINT(2).GT.10) THEN
7508 MINT(1)=MINT(2)/10
7509 MINT(2)=MOD(MINT(2),10)
7510 ENDIF
7511 IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)=
7512 &NGEN(MINT(1),2)+1
7513 MINT(15)=KFL1
7514 MINT(16)=KFL2
7515 MINT(13)=MINT(15)
7516 MINT(14)=MINT(16)
7517 VINT(141)=VINT(41)
7518 VINT(142)=VINT(42)
7519 VINT(151)=0D0
7520 VINT(152)=0D0
7521
7522C...Calculate x value of photon for parton inside photon inside e.
7523 DO 330 JT=1,2
7524 MINT(18+JT)=0
7525 VINT(154+JT)=0D0
7526 MSPLI=0
7527 IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1
7528 IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1
7529 IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1
7530 IF(MSPLI.EQ.2) THEN
7531 KFLH=MINT(14+JT)
7532 XHRD=VINT(140+JT)
7533 Q2HRD=VINT(54)
7534 MINT(105)=MINT(102+JT)
7535 MINT(109)=MINT(106+JT)
7536 VINT(120)=VINT(2+JT)
7537 IF(MSTP(57).LE.1) THEN
7538 CALL PYPDFU(22,XHRD,Q2HRD,XPQ)
7539 ELSE
7540 CALL PYPDFL(22,XHRD,Q2HRD,XPQ)
7541 ENDIF
7542 WTMX=4D0*XPQ(KFLH)
7543 IF(MSTP(13).EQ.2) THEN
7544 Q2PMS=Q2HRD/PMAS(11,1)**2
7545 WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2))
7546 ENDIF
7547 310 XE=XHRD**PYR(0)
7548 XG=MIN(1D0-1D-10,XHRD/XE)
7549 IF(MSTP(57).LE.1) THEN
7550 CALL PYPDFU(22,XG,Q2HRD,XPQ)
7551 ELSE
7552 CALL PYPDFL(22,XG,Q2HRD,XPQ)
7553 ENDIF
7554 WT=(1D0+(1D0-XE)**2)*XPQ(KFLH)
7555 IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2))
7556 IF(WT.LT.PYR(0)*WTMX) GOTO 310
7557 MINT(18+JT)=1
7558 VINT(154+JT)=XE
7559 DO 320 KFLS=-25,25
7560 XSFX(JT,KFLS)=XPQ(KFLS)
7561 320 CONTINUE
7562 ENDIF
7563 330 CONTINUE
7564
7565C...Pick scale where photon is resolved.
7566 Q0S=PARP(15)**2
7567 Q1S=VINT(154)**2
7568 VINT(283)=0D0
7569 IF(MINT(107).EQ.3) THEN
7570 IF(MSTP(66).EQ.1) THEN
7571 VINT(283)=Q0S*(VINT(54)/Q0S)**PYR(0)
7572 ELSEIF(MSTP(66).EQ.2) THEN
7573 PS=VINT(3)**2
7574 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
7575 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
7576 Q2INT=SQRT(Q0S*Q2EFF)
7577 VINT(283)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
7578 ELSEIF(MSTP(66).EQ.3) THEN
7579 VINT(283)=Q0S*(Q1S/Q0S)**PYR(0)
7580 ELSEIF(MSTP(66).GE.4) THEN
7581 PS=0.25D0*VINT(3)**2
7582 VINT(283)=(Q0S+PS)*(Q1S+PS)/
7583 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
7584 ENDIF
7585 ENDIF
7586 VINT(284)=0D0
7587 IF(MINT(108).EQ.3) THEN
7588 IF(MSTP(66).EQ.1) THEN
7589 VINT(284)=Q0S*(VINT(54)/Q0S)**PYR(0)
7590 ELSEIF(MSTP(66).EQ.2) THEN
7591 PS=VINT(4)**2
7592 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
7593 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
7594 Q2INT=SQRT(Q0S*Q2EFF)
7595 VINT(284)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
7596 ELSEIF(MSTP(66).EQ.3) THEN
7597 VINT(284)=Q0S*(Q1S/Q0S)**PYR(0)
7598 ELSEIF(MSTP(66).GE.4) THEN
7599 PS=0.25D0*VINT(4)**2
7600 VINT(284)=(Q0S+PS)*(Q1S+PS)/
7601 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
7602 ENDIF
7603 ENDIF
7604 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7605
7606C...Format statements for differential cross-section maximum violations.
7607 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
7608 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
7609 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
7610 &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
7611 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
7612 &'in event',1X,I7)
7613 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
7614 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
7615 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
7616 &'in event',1X,I7)
7617 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
7618 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
7619 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
7620
7621 RETURN
7622 END
7623
7624C*********************************************************************
7625
7626C...PYSCAT
7627C...Finds outgoing flavours and event type; sets up the kinematics
7628C...and colour flow of the hard scattering
7629
7630 SUBROUTINE PYSCAT
7631
7632C...Double precision and integer declarations
7633 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
7634 IMPLICIT INTEGER(I-N)
7635 INTEGER PYK,PYCHGE,PYCOMP
7636C...Parameter statement to help give large particle numbers.
7637 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
7638C...Commonblocks
7639 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
7640 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7641 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
7642 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
7643 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
7644 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
7645 COMMON/PYINT1/MINT(400),VINT(400)
7646 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
7647 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
7648 COMMON/PYINT4/MWID(500),WIDS(500,5)
7649 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
7650 COMMON/PYUPPR/NUP,KUP(20,7),NFUP,IFUP(10,2),PUP(20,5),Q2UP(0:10)
7651 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
7652 &SFMIX(16,4)
7653 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
7654 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYUPPR/,/PYSSMT/
7655C...Local arrays and saved variables
7656 DIMENSION WDTP(0:200),WDTE(0:200,0:5),PMQ(2),Z(2),CTHE(2),
7657 &PHI(2),KUPPO(20),VINTSV(41:66)
7658 SAVE VINTSV
7659
7660C...Read out process
7661 ISUB=MINT(1)
7662 ISUBSV=ISUB
7663
7664C...Restore information for low-pT processes
7665 IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN
7666 DO 100 J=41,66
7667 100 VINT(J)=VINTSV(J)
7668 ENDIF
7669
7670C...Convert H' or A process into equivalent H one
7671 IHIGG=1
7672 KFHIGG=25
7673 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
7674 &ISUB.LE.190)) THEN
7675 IHIGG=2
7676 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
7677 KFHIGG=33+IHIGG
7678 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
7679 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
7680 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
7681 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
7682 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
7683 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
7684 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
7685 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
7686 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
7687 ENDIF
7688
7689C...Choice of subprocess, number of documentation lines
7690 IDOC=6+ISET(ISUB)
7691 IF(ISUB.EQ.95) IDOC=8
7692 IF(ISET(ISUB).EQ.5) IDOC=9
7693 IF(ISET(ISUB).EQ.11) IDOC=4+NUP
7694 MINT(3)=IDOC-6
7695 IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2
7696 MINT(4)=IDOC
7697 IPU1=MINT(84)+1
7698 IPU2=MINT(84)+2
7699 IPU3=MINT(84)+3
7700 IPU4=MINT(84)+4
7701 IPU5=MINT(84)+5
7702 IPU6=MINT(84)+6
7703
7704C...Reset K, P and V vectors. Store incoming particles
7705 DO 120 JT=1,MSTP(126)+20
7706 I=MINT(83)+JT
7707 DO 110 J=1,5
7708 K(I,J)=0
7709 P(I,J)=0D0
7710 V(I,J)=0D0
7711 110 CONTINUE
7712 120 CONTINUE
7713 DO 140 JT=1,2
7714 I=MINT(83)+JT
7715 K(I,1)=21
7716 K(I,2)=MINT(10+JT)
7717 DO 130 J=1,5
7718 P(I,J)=VINT(285+5*JT+J)
7719 130 CONTINUE
7720 140 CONTINUE
7721 MINT(6)=2
7722 KFRES=0
7723
7724C...Store incoming partons in their CM-frame
7725 SH=VINT(44)
7726 SHR=SQRT(SH)
7727 SHP=VINT(26)*VINT(2)
7728 SHPR=SQRT(SHP)
7729 SHUSER=SHR
7730 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR
7731 DO 150 JT=1,2
7732 I=MINT(84)+JT
7733 K(I,1)=14
7734 K(I,2)=MINT(14+JT)
7735 K(I,3)=MINT(83)+2+JT
7736 P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1)
7737 P(I,4)=0.5D0*SHUSER
7738 150 CONTINUE
7739
7740C...Copy incoming partons to documentation lines
7741 DO 170 JT=1,2
7742 I1=MINT(83)+4+JT
7743 I2=MINT(84)+JT
7744 K(I1,1)=21
7745 K(I1,2)=K(I2,2)
7746 K(I1,3)=I1-2
7747 DO 160 J=1,5
7748 P(I1,J)=P(I2,J)
7749 160 CONTINUE
7750 170 CONTINUE
7751
7752C...Choose new quark/lepton flavour for relevant annihilation graphs
7753 IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58.OR.
7754 &(ISUB.GE.135.AND.ISUB.LE.140)) THEN
7755 IGLGA=21
7756 IF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) IGLGA=22
7757 CALL PYWIDT(IGLGA,SH,WDTP,WDTE)
7758 180 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
7759 DO 190 I=1,MDCY(IGLGA,3)
7760 KFLF=KFDP(I+MDCY(IGLGA,2)-1,1)
7761 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
7762 IF(RKFL.LE.0D0) GOTO 200
7763 190 CONTINUE
7764 200 CONTINUE
7765 IF(ISUB.EQ.12.AND.MSTP(5).EQ.1.AND.IABS(MINT(15)).LE.2.AND.
7766 & IABS(KFLF).GE.3) THEN
7767 FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/
7768 & VINT(44)**2
7769 FACCIB=VINT(46)**2/PARU(155)**4
7770 IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180
7771 ELSEIF(ISUB.EQ.54.OR.ISUB.EQ.135.OR.ISUB.EQ.136) THEN
7772 IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180
7773 ELSEIF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) THEN
7774 IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180
7775 ENDIF
7776 ENDIF
7777
7778C...Final state flavours and colour flow: default values
7779 JS=1
7780 MINT(21)=MINT(15)
7781 MINT(22)=MINT(16)
7782 MINT(23)=0
7783 MINT(24)=0
7784 KCC=20
7785 KCS=ISIGN(1,MINT(15))
7786
7787 IF(ISET(ISUB).EQ.11) THEN
7788C...User-defined processes: find products
7789 IRUP=0
7790 DO 210 IUP=3,NUP
7791 IF(KUP(IUP,1).NE.1) THEN
7792 ELSEIF(IRUP.LE.5) THEN
7793 IRUP=IRUP+1
7794 MINT(20+IRUP)=KUP(IUP,2)
7795 ENDIF
7796 210 CONTINUE
7797
7798 ELSEIF(ISUB.LE.10) THEN
7799 IF(ISUB.EQ.1) THEN
7800C...f + fbar -> gamma*/Z0
7801 KFRES=23
7802
7803 ELSEIF(ISUB.EQ.2) THEN
7804C...f + fbar' -> W+/-
7805 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7806 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7807 KFRES=ISIGN(24,KCH1+KCH2)
7808
7809 ELSEIF(ISUB.EQ.3) THEN
7810C...f + fbar -> h0 (or H0, or A0)
7811 KFRES=KFHIGG
7812
7813 ELSEIF(ISUB.EQ.4) THEN
7814C...gamma + W+/- -> W+/-
7815
7816 ELSEIF(ISUB.EQ.5) THEN
7817C...Z0 + Z0 -> h0
7818 XH=SH/SHP
7819 MINT(21)=MINT(15)
7820 MINT(22)=MINT(16)
7821 PMQ(1)=PYMASS(MINT(21))
7822 PMQ(2)=PYMASS(MINT(22))
7823 220 JT=INT(1.5D0+PYR(0))
7824 ZMIN=2D0*PMQ(JT)/SHPR
7825 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
7826 & (SHPR*(SHPR-PMQ(3-JT)))
7827 ZMAX=MIN(1D0-XH,ZMAX)
7828 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
7829 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
7830 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220
7831 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
7832 IF(SQC1.LT.1D-8) GOTO 220
7833 C1=SQRT(SQC1)
7834 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
7835 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
7836 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
7837 Z(3-JT)=1D0-XH/(1D0-Z(JT))
7838 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
7839 IF(SQC1.LT.1D-8) GOTO 220
7840 C1=SQRT(SQC1)
7841 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
7842 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
7843 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
7844 PHIR=PARU(2)*PYR(0)
7845 CPHI=COS(PHIR)
7846 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
7847 & SQRT(1D0-CTHE(2)**2)*CPHI
7848 Z1=2D0-Z(JT)
7849 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
7850 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
7851 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
7852 & PMQ(3-JT)**2/SHP))
7853 ZMIN=2D0*PMQ(3-JT)/SHPR
7854 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
7855 ZMAX=MIN(1D0-XH,ZMAX)
7856 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220
7857 KCC=22
7858 KFRES=25
7859
7860 ELSEIF(ISUB.EQ.6) THEN
7861C...Z0 + W+/- -> W+/-
7862
7863 ELSEIF(ISUB.EQ.7) THEN
7864C...W+ + W- -> Z0
7865
7866 ELSEIF(ISUB.EQ.8) THEN
7867C...W+ + W- -> h0
7868 XH=SH/SHP
7869 230 DO 260 JT=1,2
7870 I=MINT(14+JT)
7871 IA=IABS(I)
7872 IF(IA.LE.10) THEN
7873 RVCKM=VINT(180+I)*PYR(0)
7874 DO 240 J=1,MSTP(1)
7875 IB=2*J-1+MOD(IA,2)
7876 IPM=(5-ISIGN(1,I))/2
7877 IDC=J+MDCY(IA,2)+2
7878 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240
7879 MINT(20+JT)=ISIGN(IB,I)
7880 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
7881 IF(RVCKM.LE.0D0) GOTO 250
7882 240 CONTINUE
7883 ELSE
7884 IB=2*((IA+1)/2)-1+MOD(IA,2)
7885 MINT(20+JT)=ISIGN(IB,I)
7886 ENDIF
7887 250 PMQ(JT)=PYMASS(MINT(20+JT))
7888 260 CONTINUE
7889 JT=INT(1.5D0+PYR(0))
7890 ZMIN=2D0*PMQ(JT)/SHPR
7891 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
7892 & (SHPR*(SHPR-PMQ(3-JT)))
7893 ZMAX=MIN(1D0-XH,ZMAX)
7894 IF(ZMIN.GE.ZMAX) GOTO 230
7895 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
7896 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
7897 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230
7898 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
7899 IF(SQC1.LT.1D-8) GOTO 230
7900 C1=SQRT(SQC1)
7901 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
7902 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
7903 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
7904 Z(3-JT)=1D0-XH/(1D0-Z(JT))
7905 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
7906 IF(SQC1.LT.1D-8) GOTO 230
7907 C1=SQRT(SQC1)
7908 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
7909 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
7910 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
7911 PHIR=PARU(2)*PYR(0)
7912 CPHI=COS(PHIR)
7913 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
7914 & SQRT(1D0-CTHE(2)**2)*CPHI
7915 Z1=2D0-Z(JT)
7916 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
7917 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
7918 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
7919 & PMQ(3-JT)**2/SHP))
7920 ZMIN=2D0*PMQ(3-JT)/SHPR
7921 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
7922 ZMAX=MIN(1D0-XH,ZMAX)
7923 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230
7924 KCC=22
7925 KFRES=25
7926
7927 ELSEIF(ISUB.EQ.10) THEN
7928C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
7929 IF(MINT(2).EQ.1) THEN
7930 KCC=22
7931 ELSE
7932C...W exchange: need to mix flavours according to CKM matrix
7933 DO 280 JT=1,2
7934 I=MINT(14+JT)
7935 IA=IABS(I)
7936 IF(IA.LE.10) THEN
7937 RVCKM=VINT(180+I)*PYR(0)
7938 DO 270 J=1,MSTP(1)
7939 IB=2*J-1+MOD(IA,2)
7940 IPM=(5-ISIGN(1,I))/2
7941 IDC=J+MDCY(IA,2)+2
7942 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
7943 MINT(20+JT)=ISIGN(IB,I)
7944 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
7945 IF(RVCKM.LE.0D0) GOTO 280
7946 270 CONTINUE
7947 ELSE
7948 IB=2*((IA+1)/2)-1+MOD(IA,2)
7949 MINT(20+JT)=ISIGN(IB,I)
7950 ENDIF
7951 280 CONTINUE
7952 KCC=22
7953 ENDIF
7954 ENDIF
7955
7956 ELSEIF(ISUB.LE.20) THEN
7957 IF(ISUB.EQ.11) THEN
7958C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
7959 KCC=MINT(2)
7960 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
7961
7962 ELSEIF(ISUB.EQ.12) THEN
7963C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
7964 MINT(21)=ISIGN(KFLF,MINT(15))
7965 MINT(22)=-MINT(21)
7966 KCC=4
7967
7968 ELSEIF(ISUB.EQ.13) THEN
7969C...f + fbar -> g + g; th arbitrary
7970 MINT(21)=21
7971 MINT(22)=21
7972 KCC=MINT(2)+4
7973
7974 ELSEIF(ISUB.EQ.14) THEN
7975C...f + fbar -> g + gamma; th arbitrary
7976 IF(PYR(0).GT.0.5D0) JS=2
7977 MINT(20+JS)=21
7978 MINT(23-JS)=22
7979 KCC=17+JS
7980
7981 ELSEIF(ISUB.EQ.15) THEN
7982C...f + fbar -> g + Z0; th arbitrary
7983 IF(PYR(0).GT.0.5D0) JS=2
7984 MINT(20+JS)=21
7985 MINT(23-JS)=23
7986 KCC=17+JS
7987
7988 ELSEIF(ISUB.EQ.16) THEN
7989C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
7990 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7991 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7992 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
7993 MINT(20+JS)=21
7994 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
7995 KCC=17+JS
7996
7997 ELSEIF(ISUB.EQ.17) THEN
7998C...f + fbar -> g + h0; th arbitrary
7999 IF(PYR(0).GT.0.5D0) JS=2
8000 MINT(20+JS)=21
8001 MINT(23-JS)=25
8002 KCC=17+JS
8003
8004 ELSEIF(ISUB.EQ.18) THEN
8005C...f + fbar -> gamma + gamma; th arbitrary
8006 MINT(21)=22
8007 MINT(22)=22
8008
8009 ELSEIF(ISUB.EQ.19) THEN
8010C...f + fbar -> gamma + Z0; th arbitrary
8011 IF(PYR(0).GT.0.5D0) JS=2
8012 MINT(20+JS)=22
8013 MINT(23-JS)=23
8014
8015 ELSEIF(ISUB.EQ.20) THEN
8016C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
8017C...(p(fbar')-p(W+))**2
8018 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8019 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8020 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
8021 MINT(20+JS)=22
8022 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
8023 ENDIF
8024
8025 ELSEIF(ISUB.LE.30) THEN
8026 IF(ISUB.EQ.21) THEN
8027C...f + fbar -> gamma + h0; th arbitrary
8028 IF(PYR(0).GT.0.5D0) JS=2
8029 MINT(20+JS)=22
8030 MINT(23-JS)=25
8031
8032 ELSEIF(ISUB.EQ.22) THEN
8033C...f + fbar -> Z0 + Z0; th arbitrary
8034 MINT(21)=23
8035 MINT(22)=23
8036
8037 ELSEIF(ISUB.EQ.23) THEN
8038C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
8039 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8040 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8041 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
8042 MINT(20+JS)=23
8043 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
8044
8045 ELSEIF(ISUB.EQ.24) THEN
8046C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
8047 IF(PYR(0).GT.0.5D0) JS=2
8048 MINT(20+JS)=23
8049 MINT(23-JS)=KFHIGG
8050
8051 ELSEIF(ISUB.EQ.25) THEN
8052C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
8053 MINT(21)=-ISIGN(24,MINT(15))
8054 MINT(22)=-MINT(21)
8055
8056 ELSEIF(ISUB.EQ.26) THEN
8057C...f + fbar' -> W+/- + h0 (or H0, or A0);
8058C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
8059 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8060 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8061 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
8062 MINT(20+JS)=ISIGN(24,KCH1+KCH2)
8063 MINT(23-JS)=KFHIGG
8064
8065 ELSEIF(ISUB.EQ.27) THEN
8066C...f + fbar -> h0 + h0
8067
8068 ELSEIF(ISUB.EQ.28) THEN
8069C...f + g -> f + g; th = (p(f)-p(f))**2
8070 KCC=MINT(2)+6
8071 IF(MINT(15).EQ.21) KCC=KCC+2
8072 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
8073 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
8074
8075 ELSEIF(ISUB.EQ.29) THEN
8076C...f + g -> f + gamma; th = (p(f)-p(f))**2
8077 IF(MINT(15).EQ.21) JS=2
8078 MINT(23-JS)=22
8079 KCC=15+JS
8080 KCS=ISIGN(1,MINT(14+JS))
8081
8082 ELSEIF(ISUB.EQ.30) THEN
8083C...f + g -> f + Z0; th = (p(f)-p(f))**2
8084 IF(MINT(15).EQ.21) JS=2
8085 MINT(23-JS)=23
8086 KCC=15+JS
8087 KCS=ISIGN(1,MINT(14+JS))
8088 ENDIF
8089
8090 ELSEIF(ISUB.LE.40) THEN
8091 IF(ISUB.EQ.31) THEN
8092C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
8093 IF(MINT(15).EQ.21) JS=2
8094 I=MINT(14+JS)
8095 IA=IABS(I)
8096 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
8097 RVCKM=VINT(180+I)*PYR(0)
8098 DO 290 J=1,MSTP(1)
8099 IB=2*J-1+MOD(IA,2)
8100 IPM=(5-ISIGN(1,I))/2
8101 IDC=J+MDCY(IA,2)+2
8102 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290
8103 MINT(20+JS)=ISIGN(IB,I)
8104 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8105 IF(RVCKM.LE.0D0) GOTO 300
8106 290 CONTINUE
8107 300 KCC=15+JS
8108 KCS=ISIGN(1,MINT(14+JS))
8109
8110 ELSEIF(ISUB.EQ.32) THEN
8111C...f + g -> f + h0; th = (p(f)-p(f))**2
8112 IF(MINT(15).EQ.21) JS=2
8113 MINT(23-JS)=25
8114 KCC=15+JS
8115 KCS=ISIGN(1,MINT(14+JS))
8116
8117 ELSEIF(ISUB.EQ.33) THEN
8118C...f + gamma -> f + g; th=(p(f)-p(f))**2
8119 IF(MINT(15).EQ.22) JS=2
8120 MINT(23-JS)=21
8121 KCC=24+JS
8122 KCS=ISIGN(1,MINT(14+JS))
8123
8124 ELSEIF(ISUB.EQ.34) THEN
8125C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
8126 IF(MINT(15).EQ.22) JS=2
8127 KCC=22
8128 KCS=ISIGN(1,MINT(14+JS))
8129
8130 ELSEIF(ISUB.EQ.35) THEN
8131C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
8132 IF(MINT(15).EQ.22) JS=2
8133 MINT(23-JS)=23
8134 KCC=22
8135
8136 ELSEIF(ISUB.EQ.36) THEN
8137C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
8138 IF(MINT(15).EQ.22) JS=2
8139 I=MINT(14+JS)
8140 IA=IABS(I)
8141 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
8142 IF(IA.LE.10) THEN
8143 RVCKM=VINT(180+I)*PYR(0)
8144 DO 310 J=1,MSTP(1)
8145 IB=2*J-1+MOD(IA,2)
8146 IPM=(5-ISIGN(1,I))/2
8147 IDC=J+MDCY(IA,2)+2
8148 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310
8149 MINT(20+JS)=ISIGN(IB,I)
8150 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8151 IF(RVCKM.LE.0D0) GOTO 320
8152 310 CONTINUE
8153 ELSE
8154 IB=2*((IA+1)/2)-1+MOD(IA,2)
8155 MINT(20+JS)=ISIGN(IB,I)
8156 ENDIF
8157 320 KCC=22
8158
8159 ELSEIF(ISUB.EQ.37) THEN
8160C...f + gamma -> f + h0
8161
8162 ELSEIF(ISUB.EQ.38) THEN
8163C...f + Z0 -> f + g
8164
8165 ELSEIF(ISUB.EQ.39) THEN
8166C...f + Z0 -> f + gamma
8167
8168 ELSEIF(ISUB.EQ.40) THEN
8169C...f + Z0 -> f + Z0
8170 ENDIF
8171
8172 ELSEIF(ISUB.LE.50) THEN
8173 IF(ISUB.EQ.41) THEN
8174C...f + Z0 -> f' + W+/-
8175
8176 ELSEIF(ISUB.EQ.42) THEN
8177C...f + Z0 -> f + h0
8178
8179 ELSEIF(ISUB.EQ.43) THEN
8180C...f + W+/- -> f' + g
8181
8182 ELSEIF(ISUB.EQ.44) THEN
8183C...f + W+/- -> f' + gamma
8184
8185 ELSEIF(ISUB.EQ.45) THEN
8186C...f + W+/- -> f' + Z0
8187
8188 ELSEIF(ISUB.EQ.46) THEN
8189C...f + W+/- -> f' + W+/-
8190
8191 ELSEIF(ISUB.EQ.47) THEN
8192C...f + W+/- -> f' + h0
8193
8194 ELSEIF(ISUB.EQ.48) THEN
8195C...f + h0 -> f + g
8196
8197 ELSEIF(ISUB.EQ.49) THEN
8198C...f + h0 -> f + gamma
8199
8200 ELSEIF(ISUB.EQ.50) THEN
8201C...f + h0 -> f + Z0
8202 ENDIF
8203
8204 ELSEIF(ISUB.LE.60) THEN
8205 IF(ISUB.EQ.51) THEN
8206C...f + h0 -> f' + W+/-
8207
8208 ELSEIF(ISUB.EQ.52) THEN
8209C...f + h0 -> f + h0
8210
8211 ELSEIF(ISUB.EQ.53) THEN
8212C...g + g -> f + fbar; th arbitrary
8213 KCS=(-1)**INT(1.5D0+PYR(0))
8214 MINT(21)=ISIGN(KFLF,KCS)
8215 MINT(22)=-MINT(21)
8216 KCC=MINT(2)+10
8217
8218 ELSEIF(ISUB.EQ.54) THEN
8219C...g + gamma -> f + fbar; th arbitrary
8220 KCS=(-1)**INT(1.5D0+PYR(0))
8221 MINT(21)=ISIGN(KFLF,KCS)
8222 MINT(22)=-MINT(21)
8223 KCC=27
8224 IF(MINT(16).EQ.21) KCC=28
8225
8226 ELSEIF(ISUB.EQ.55) THEN
8227C...g + Z0 -> f + fbar
8228
8229 ELSEIF(ISUB.EQ.56) THEN
8230C...g + W+/- -> f + fbar'
8231
8232 ELSEIF(ISUB.EQ.57) THEN
8233C...g + h0 -> f + fbar
8234
8235 ELSEIF(ISUB.EQ.58) THEN
8236C...gamma + gamma -> f + fbar; th arbitrary
8237 KCS=(-1)**INT(1.5D0+PYR(0))
8238 MINT(21)=ISIGN(KFLF,KCS)
8239 MINT(22)=-MINT(21)
8240 KCC=21
8241
8242 ELSEIF(ISUB.EQ.59) THEN
8243C...gamma + Z0 -> f + fbar
8244
8245 ELSEIF(ISUB.EQ.60) THEN
8246C...gamma + W+/- -> f + fbar'
8247 ENDIF
8248
8249 ELSEIF(ISUB.LE.70) THEN
8250 IF(ISUB.EQ.61) THEN
8251C...gamma + h0 -> f + fbar
8252
8253 ELSEIF(ISUB.EQ.62) THEN
8254C...Z0 + Z0 -> f + fbar
8255
8256 ELSEIF(ISUB.EQ.63) THEN
8257C...Z0 + W+/- -> f + fbar'
8258
8259 ELSEIF(ISUB.EQ.64) THEN
8260C...Z0 + h0 -> f + fbar
8261
8262 ELSEIF(ISUB.EQ.65) THEN
8263C...W+ + W- -> f + fbar
8264
8265 ELSEIF(ISUB.EQ.66) THEN
8266C...W+/- + h0 -> f + fbar'
8267
8268 ELSEIF(ISUB.EQ.67) THEN
8269C...h0 + h0 -> f + fbar
8270
8271 ELSEIF(ISUB.EQ.68) THEN
8272C...g + g -> g + g; th arbitrary
8273 KCC=MINT(2)+12
8274 KCS=(-1)**INT(1.5D0+PYR(0))
8275
8276 ELSEIF(ISUB.EQ.69) THEN
8277C...gamma + gamma -> W+ + W-; th arbitrary
8278 MINT(21)=24
8279 MINT(22)=-24
8280 KCC=21
8281
8282 ELSEIF(ISUB.EQ.70) THEN
8283C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
8284 IF(MINT(15).EQ.22) MINT(21)=23
8285 IF(MINT(16).EQ.22) MINT(22)=23
8286 KCC=21
8287 ENDIF
8288
8289 ELSEIF(ISUB.LE.80) THEN
8290 IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
8291C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
8292 XH=SH/SHP
8293 MINT(21)=MINT(15)
8294 MINT(22)=MINT(16)
8295 PMQ(1)=PYMASS(MINT(21))
8296 PMQ(2)=PYMASS(MINT(22))
8297 330 JT=INT(1.5D0+PYR(0))
8298 ZMIN=2D0*PMQ(JT)/SHPR
8299 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
8300 & (SHPR*(SHPR-PMQ(3-JT)))
8301 ZMAX=MIN(1D0-XH,ZMAX)
8302 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
8303 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
8304 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330
8305 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
8306 IF(SQC1.LT.1D-8) GOTO 330
8307 C1=SQRT(SQC1)
8308 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
8309 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8310 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
8311 Z(3-JT)=1D0-XH/(1D0-Z(JT))
8312 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
8313 IF(SQC1.LT.1D-8) GOTO 330
8314 C1=SQRT(SQC1)
8315 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
8316 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8317 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
8318 PHIR=PARU(2)*PYR(0)
8319 CPHI=COS(PHIR)
8320 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
8321 & SQRT(1D0-CTHE(2)**2)*CPHI
8322 Z1=2D0-Z(JT)
8323 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
8324 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
8325 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
8326 & PMQ(3-JT)**2/SHP))
8327 ZMIN=2D0*PMQ(3-JT)/SHPR
8328 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
8329 ZMAX=MIN(1D0-XH,ZMAX)
8330 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330
8331 KCC=22
8332
8333 ELSEIF(ISUB.EQ.73) THEN
8334C...Z0 + W+/- -> Z0 + W+/-
8335 JS=MINT(2)
8336 XH=SH/SHP
8337 340 JT=3-MINT(2)
8338 I=MINT(14+JT)
8339 IA=IABS(I)
8340 IF(IA.LE.10) THEN
8341 RVCKM=VINT(180+I)*PYR(0)
8342 DO 350 J=1,MSTP(1)
8343 IB=2*J-1+MOD(IA,2)
8344 IPM=(5-ISIGN(1,I))/2
8345 IDC=J+MDCY(IA,2)+2
8346 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350
8347 MINT(20+JT)=ISIGN(IB,I)
8348 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8349 IF(RVCKM.LE.0D0) GOTO 360
8350 350 CONTINUE
8351 ELSE
8352 IB=2*((IA+1)/2)-1+MOD(IA,2)
8353 MINT(20+JT)=ISIGN(IB,I)
8354 ENDIF
8355 360 PMQ(JT)=PYMASS(MINT(20+JT))
8356 MINT(23-JT)=MINT(17-JT)
8357 PMQ(3-JT)=PYMASS(MINT(23-JT))
8358 JT=INT(1.5D0+PYR(0))
8359 ZMIN=2D0*PMQ(JT)/SHPR
8360 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
8361 & (SHPR*(SHPR-PMQ(3-JT)))
8362 ZMAX=MIN(1D0-XH,ZMAX)
8363 IF(ZMIN.GE.ZMAX) GOTO 340
8364 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
8365 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
8366 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340
8367 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
8368 IF(SQC1.LT.1D-8) GOTO 340
8369 C1=SQRT(SQC1)
8370 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
8371 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8372 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
8373 Z(3-JT)=1D0-XH/(1D0-Z(JT))
8374 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
8375 IF(SQC1.LT.1D-8) GOTO 340
8376 C1=SQRT(SQC1)
8377 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
8378 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8379 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
8380 PHIR=PARU(2)*PYR(0)
8381 CPHI=COS(PHIR)
8382 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
8383 & SQRT(1D0-CTHE(2)**2)*CPHI
8384 Z1=2D0-Z(JT)
8385 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
8386 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
8387 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
8388 & PMQ(3-JT)**2/SHP))
8389 ZMIN=2D0*PMQ(3-JT)/SHPR
8390 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
8391 ZMAX=MIN(1D0-XH,ZMAX)
8392 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
8393 KCC=22
8394
8395 ELSEIF(ISUB.EQ.74) THEN
8396C...Z0 + h0 -> Z0 + h0
8397
8398 ELSEIF(ISUB.EQ.75) THEN
8399C...W+ + W- -> gamma + gamma
8400
8401 ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
8402C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
8403 XH=SH/SHP
8404 370 DO 400 JT=1,2
8405 I=MINT(14+JT)
8406 IA=IABS(I)
8407 IF(IA.LE.10) THEN
8408 RVCKM=VINT(180+I)*PYR(0)
8409 DO 380 J=1,MSTP(1)
8410 IB=2*J-1+MOD(IA,2)
8411 IPM=(5-ISIGN(1,I))/2
8412 IDC=J+MDCY(IA,2)+2
8413 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380
8414 MINT(20+JT)=ISIGN(IB,I)
8415 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8416 IF(RVCKM.LE.0D0) GOTO 390
8417 380 CONTINUE
8418 ELSE
8419 IB=2*((IA+1)/2)-1+MOD(IA,2)
8420 MINT(20+JT)=ISIGN(IB,I)
8421 ENDIF
8422 390 PMQ(JT)=PYMASS(MINT(20+JT))
8423 400 CONTINUE
8424 JT=INT(1.5D0+PYR(0))
8425 ZMIN=2D0*PMQ(JT)/SHPR
8426 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
8427 & (SHPR*(SHPR-PMQ(3-JT)))
8428 ZMAX=MIN(1D0-XH,ZMAX)
8429 IF(ZMIN.GE.ZMAX) GOTO 370
8430 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
8431 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
8432 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370
8433 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
8434 IF(SQC1.LT.1D-8) GOTO 370
8435 C1=SQRT(SQC1)
8436 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
8437 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8438 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
8439 Z(3-JT)=1D0-XH/(1D0-Z(JT))
8440 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
8441 IF(SQC1.LT.1D-8) GOTO 370
8442 C1=SQRT(SQC1)
8443 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
8444 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8445 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
8446 PHIR=PARU(2)*PYR(0)
8447 CPHI=COS(PHIR)
8448 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
8449 & SQRT(1D0-CTHE(2)**2)*CPHI
8450 Z1=2D0-Z(JT)
8451 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
8452 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
8453 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
8454 & PMQ(3-JT)**2/SHP))
8455 ZMIN=2D0*PMQ(3-JT)/SHPR
8456 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
8457 ZMAX=MIN(1D0-XH,ZMAX)
8458 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370
8459 KCC=22
8460
8461 ELSEIF(ISUB.EQ.78) THEN
8462C...W+/- + h0 -> W+/- + h0
8463
8464 ELSEIF(ISUB.EQ.79) THEN
8465C...h0 + h0 -> h0 + h0
8466
8467 ELSEIF(ISUB.EQ.80) THEN
8468C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
8469 IF(MINT(15).EQ.22) JS=2
8470 I=MINT(14+JS)
8471 IA=IABS(I)
8472 MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I)
8473 IB=3-IA
8474 MINT(20+JS)=ISIGN(IB,I)
8475 KCC=22
8476 ENDIF
8477
8478 ELSEIF(ISUB.LE.90) THEN
8479 IF(ISUB.EQ.81) THEN
8480C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
8481 MINT(21)=ISIGN(MINT(55),MINT(15))
8482 MINT(22)=-MINT(21)
8483 KCC=4
8484
8485 ELSEIF(ISUB.EQ.82) THEN
8486C...g + g -> Q + Qbar; th arbitrary
8487 KCS=(-1)**INT(1.5D0+PYR(0))
8488 MINT(21)=ISIGN(MINT(55),KCS)
8489 MINT(22)=-MINT(21)
8490 KCC=MINT(2)+10
8491
8492 ELSEIF(ISUB.EQ.83) THEN
8493C...f + q -> f' + Q; th = (p(f) - p(f'))**2
8494 KFOLD=MINT(16)
8495 IF(MINT(2).EQ.2) KFOLD=MINT(15)
8496 KFAOLD=IABS(KFOLD)
8497 IF(KFAOLD.GT.10) THEN
8498 KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1
8499 ELSE
8500 RCKM=VINT(180+KFOLD)*PYR(0)
8501 IPM=(5-ISIGN(1,KFOLD))/2
8502 KFANEW=-MOD(KFAOLD+1,2)
8503 410 KFANEW=KFANEW+2
8504 IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2
8505 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN
8506 IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM-
8507 & VCKM(KFAOLD/2,(KFANEW+1)/2)
8508 IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM-
8509 & VCKM(KFANEW/2,(KFAOLD+1)/2)
8510 ENDIF
8511 IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410
8512 ENDIF
8513 IF(MINT(2).EQ.1) THEN
8514 MINT(21)=ISIGN(MINT(55),MINT(15))
8515 MINT(22)=ISIGN(KFANEW,MINT(16))
8516 ELSE
8517 MINT(21)=ISIGN(KFANEW,MINT(15))
8518 MINT(22)=ISIGN(MINT(55),MINT(16))
8519 JS=2
8520 ENDIF
8521 KCC=22
8522
8523 ELSEIF(ISUB.EQ.84) THEN
8524C...g + gamma -> Q + Qbar; th arbitary
8525 KCS=(-1)**INT(1.5D0+PYR(0))
8526 MINT(21)=ISIGN(MINT(55),KCS)
8527 MINT(22)=-MINT(21)
8528 KCC=27
8529 IF(MINT(16).EQ.21) KCC=28
8530
8531 ELSEIF(ISUB.EQ.85) THEN
8532C...gamma + gamma -> F + Fbar; th arbitary
8533 KCS=(-1)**INT(1.5D0+PYR(0))
8534 MINT(21)=ISIGN(MINT(56),KCS)
8535 MINT(22)=-MINT(21)
8536 KCC=21
8537
8538 ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN
8539C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
8540 MINT(21)=KFPR(ISUB,1)
8541 MINT(22)=KFPR(ISUB,2)
8542 KCC=24
8543 KCS=(-1)**INT(1.5D0+PYR(0))
8544 ENDIF
8545
8546 ELSEIF(ISUB.LE.100) THEN
8547 IF(ISUB.EQ.95) THEN
8548C...Low-pT ( = energyless g + g -> g + g)
8549 KCC=MINT(2)+12
8550 KCS=(-1)**INT(1.5D0+PYR(0))
8551
8552 ELSEIF(ISUB.EQ.96) THEN
8553C...Multiple interactions (should be reassigned to QCD process)
8554 ENDIF
8555
8556 ELSEIF(ISUB.LE.110) THEN
8557 IF(ISUB.EQ.101) THEN
8558C...g + g -> gamma*/Z0
8559 KCC=21
8560 KFRES=22
8561
8562 ELSEIF(ISUB.EQ.102) THEN
8563C...g + g -> h0 (or H0, or A0)
8564 KCC=21
8565 KFRES=KFHIGG
8566
8567 ELSEIF(ISUB.EQ.103) THEN
8568C...gamma + gamma -> h0 (or H0, or A0)
8569 KCC=21
8570 KFRES=KFHIGG
8571
8572 ELSEIF(ISUB.EQ.104.OR.ISUB.EQ.105) THEN
8573C...g + g -> chi_0c or chi_2c.
8574 KCC=21
8575 KFRES=KFPR(ISUB,1)
8576
8577 ELSEIF(ISUB.EQ.106) THEN
8578C...g + g -> J/Psi + gamma
8579 MINT(21)=KFPR(ISUB,1)
8580 MINT(22)=KFPR(ISUB,2)
8581 KCC=21
8582
8583 ELSEIF(ISUB.EQ.107) THEN
8584C...g + gamma -> J/Psi + g
8585 MINT(21)=KFPR(ISUB,1)
8586 MINT(22)=KFPR(ISUB,2)
8587 KCC=22
8588 IF(MINT(16).EQ.22) KCC=33
8589
8590 ELSEIF(ISUB.EQ.108) THEN
8591C...gamma + gamma -> J/Psi + gamma
8592 MINT(21)=KFPR(ISUB,1)
8593 MINT(22)=KFPR(ISUB,2)
8594
8595 ELSEIF(ISUB.EQ.110) THEN
8596C...f + fbar -> gamma + h0; th arbitrary
8597 IF(PYR(0).GT.0.5D0) JS=2
8598 MINT(20+JS)=22
8599 MINT(23-JS)=KFHIGG
8600 ENDIF
8601
8602 ELSEIF(ISUB.LE.120) THEN
8603 IF(ISUB.EQ.111) THEN
8604C...f + fbar -> g + h0; th arbitrary
8605 IF(PYR(0).GT.0.5D0) JS=2
8606 MINT(20+JS)=21
8607 MINT(23-JS)=25
8608 KCC=17+JS
8609
8610 ELSEIF(ISUB.EQ.112) THEN
8611C...f + g -> f + h0; th = (p(f) - p(f))**2
8612 IF(MINT(15).EQ.21) JS=2
8613 MINT(23-JS)=25
8614 KCC=15+JS
8615 KCS=ISIGN(1,MINT(14+JS))
8616
8617 ELSEIF(ISUB.EQ.113) THEN
8618C...g + g -> g + h0; th arbitrary
8619 IF(PYR(0).GT.0.5D0) JS=2
8620 MINT(23-JS)=25
8621 KCC=22+JS
8622 KCS=(-1)**INT(1.5D0+PYR(0))
8623
8624 ELSEIF(ISUB.EQ.114) THEN
8625C...g + g -> gamma + gamma; th arbitrary
8626 IF(PYR(0).GT.0.5D0) JS=2
8627 MINT(21)=22
8628 MINT(22)=22
8629 KCC=21
8630
8631 ELSEIF(ISUB.EQ.115) THEN
8632C...g + g -> g + gamma; th arbitrary
8633 IF(PYR(0).GT.0.5D0) JS=2
8634 MINT(23-JS)=22
8635 KCC=22+JS
8636 KCS=(-1)**INT(1.5D0+PYR(0))
8637
8638 ELSEIF(ISUB.EQ.116) THEN
8639C...g + g -> gamma + Z0
8640
8641 ELSEIF(ISUB.EQ.117) THEN
8642C...g + g -> Z0 + Z0
8643
8644 ELSEIF(ISUB.EQ.118) THEN
8645C...g + g -> W+ + W-
8646 ENDIF
8647
8648 ELSEIF(ISUB.LE.140) THEN
8649 IF(ISUB.EQ.121) THEN
8650C...g + g -> Q + Qbar + h0
8651 KCS=(-1)**INT(1.5D0+PYR(0))
8652 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
8653 MINT(22)=-MINT(21)
8654 KCC=11+INT(0.5D0+PYR(0))
8655 KFRES=KFHIGG
8656
8657 ELSEIF(ISUB.EQ.122) THEN
8658C...q + qbar -> Q + Qbar + h0
8659 MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15))
8660 MINT(22)=-MINT(21)
8661 KCC=4
8662 KFRES=KFHIGG
8663
8664 ELSEIF(ISUB.EQ.123) THEN
8665C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
8666C...inner process)
8667 KCC=22
8668 KFRES=KFHIGG
8669
8670 ELSEIF(ISUB.EQ.124) THEN
8671C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
8672C...inner process)
8673 DO 430 JT=1,2
8674 I=MINT(14+JT)
8675 IA=IABS(I)
8676 IF(IA.LE.10) THEN
8677 RVCKM=VINT(180+I)*PYR(0)
8678 DO 420 J=1,MSTP(1)
8679 IB=2*J-1+MOD(IA,2)
8680 IPM=(5-ISIGN(1,I))/2
8681 IDC=J+MDCY(IA,2)+2
8682 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420
8683 MINT(20+JT)=ISIGN(IB,I)
8684 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8685 IF(RVCKM.LE.0D0) GOTO 430
8686 420 CONTINUE
8687 ELSE
8688 IB=2*((IA+1)/2)-1+MOD(IA,2)
8689 MINT(20+JT)=ISIGN(IB,I)
8690 ENDIF
8691 430 CONTINUE
8692 KCC=22
8693 KFRES=KFHIGG
8694
8695 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
8696C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2
8697 IF(MINT(15).EQ.22) JS=2
8698 MINT(23-JS)=21
8699 KCC=24+JS
8700 KCS=ISIGN(1,MINT(14+JS))
8701
8702 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
8703C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2
8704 IF(MINT(15).EQ.22) JS=2
8705 KCC=22
8706 KCS=ISIGN(1,MINT(14+JS))
8707
8708 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
8709C...g + gamma*_(T,L) -> f + fbar; th arbitrary
8710 KCS=(-1)**INT(1.5D0+PYR(0))
8711 MINT(21)=ISIGN(KFLF,KCS)
8712 MINT(22)=-MINT(21)
8713 KCC=27
8714 IF(MINT(16).EQ.21) KCC=28
8715
8716 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
8717C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary
8718 KCS=(-1)**INT(1.5D0+PYR(0))
8719 MINT(21)=ISIGN(KFLF,KCS)
8720 MINT(22)=-MINT(21)
8721 KCC=21
8722
8723 ENDIF
8724
8725 ELSEIF(ISUB.LE.160) THEN
8726 IF(ISUB.EQ.141) THEN
8727C...f + fbar -> gamma*/Z0/Z'0
8728 KFRES=32
8729
8730 ELSEIF(ISUB.EQ.142) THEN
8731C...f + fbar' -> W'+/-
8732 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8733 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8734 KFRES=ISIGN(34,KCH1+KCH2)
8735
8736 ELSEIF(ISUB.EQ.143) THEN
8737C...f + fbar' -> H+/-
8738 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8739 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8740 KFRES=ISIGN(37,KCH1+KCH2)
8741
8742 ELSEIF(ISUB.EQ.144) THEN
8743C...f + fbar' -> R
8744 KFRES=ISIGN(40,MINT(15)+MINT(16))
8745
8746 ELSEIF(ISUB.EQ.145) THEN
8747C...q + l -> LQ (leptoquark)
8748 IF(IABS(MINT(16)).LE.8) JS=2
8749 KFRES=ISIGN(39,MINT(14+JS))
8750 KCC=28+JS
8751 KCS=ISIGN(1,MINT(14+JS))
8752
8753 ELSEIF(ISUB.EQ.146) THEN
8754C...e + gamma -> e* (excited lepton)
8755 IF(MINT(15).EQ.22) JS=2
8756 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
8757 KCC=22
8758
8759 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
8760C...q + g -> q* (excited quark)
8761 IF(MINT(15).EQ.21) JS=2
8762 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
8763 KCC=30+JS
8764 KCS=ISIGN(1,MINT(14+JS))
8765
8766 ELSEIF(ISUB.EQ.149) THEN
8767C...g + g -> eta_techni
8768 KFRES=38
8769 KCC=23
8770 KCS=(-1)**INT(1.5D0+PYR(0))
8771 ENDIF
8772
8773 ELSEIF(ISUB.LE.200) THEN
8774 IF(ISUB.EQ.161) THEN
8775C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
8776 IF(MINT(15).EQ.21) JS=2
8777 I=MINT(14+JS)
8778 IA=IABS(I)
8779 MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I)
8780 IB=IA+MOD(IA,2)-MOD(IA+1,2)
8781 MINT(20+JS)=ISIGN(IB,I)
8782 KCC=15+JS
8783 KCS=ISIGN(1,MINT(14+JS))
8784
8785 ELSEIF(ISUB.EQ.162) THEN
8786C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
8787 IF(MINT(15).EQ.21) JS=2
8788 MINT(20+JS)=ISIGN(39,MINT(14+JS))
8789 KFLQL=KFDP(MDCY(39,2),2)
8790 MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS))
8791 KCC=15+JS
8792 KCS=ISIGN(1,MINT(14+JS))
8793
8794 ELSEIF(ISUB.EQ.163) THEN
8795C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
8796 KCS=(-1)**INT(1.5D0+PYR(0))
8797 MINT(21)=ISIGN(39,KCS)
8798 MINT(22)=-MINT(21)
8799 KCC=MINT(2)+10
8800
8801 ELSEIF(ISUB.EQ.164) THEN
8802C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
8803 MINT(21)=ISIGN(39,MINT(15))
8804 MINT(22)=-MINT(21)
8805 KCC=4
8806
8807 ELSEIF(ISUB.EQ.165) THEN
8808C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
8809 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
8810 MINT(22)=-MINT(21)
8811
8812 ELSEIF(ISUB.EQ.166) THEN
8813C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
8814 IF(MOD(MINT(15),2).EQ.0) THEN
8815 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
8816 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
8817 ELSE
8818 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
8819 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
8820 ENDIF
8821
8822 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
8823C...q + q' -> q" + q* (excited quark)
8824 KFQSTR=KFPR(ISUB,2)
8825 KFQEXC=MOD(KFQSTR,KEXCIT)
8826 JS=MINT(2)
8827 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
8828 IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC)
8829 & MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
8830 KCC=22
8831
8832 ELSEIF(ISUB.EQ.169) THEN
8833C...q + qbar -> e + e* (excited lepton)
8834 KFQSTR=KFPR(ISUB,2)
8835 KFQEXC=MOD(KFQSTR,KEXCIT)
8836 JS=MINT(2)
8837 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
8838 MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
8839
8840 ELSEIF(ISUB.EQ.191) THEN
8841C...f + fbar -> rho_tech0.
8842 KFRES=54
8843
8844 ELSEIF(ISUB.EQ.192) THEN
8845C...f + fbar' -> rho_tech+/-
8846 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8847 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8848 KFRES=ISIGN(55,KCH1+KCH2)
8849
8850 ELSEIF(ISUB.EQ.193) THEN
8851C...f + fbar -> omega_tech0.
8852 KFRES=56
8853
8854 ELSEIF(ISUB.EQ.194) THEN
8855C...f + fbar -> f' + fbar' via mixture of s-channel
8856C...rho_tech and omega_tech; th=(p(f)-p(f'))**2
8857 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
8858 MINT(22)=-MINT(21)
8859
8860 ELSEIF(ISUB.EQ.195) THEN
8861C...f + fbar' -> f'' + fbar''' via s-channel
8862C...rho_tech+ th=(p(f)-p(f'))**2
8863C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
8864 IF(MOD(MINT(15),2).EQ.0) THEN
8865 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
8866 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
8867 ELSE
8868 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
8869 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
8870 ENDIF
8871 ENDIF
8872
8873CMRENNA++
8874 ELSEIF(ISUB.LE.215) THEN
8875 IF(ISUB.EQ.201) THEN
8876C...f + fbar -> ~e_L + ~e_Lbar
8877 MINT(21)=ISIGN(KSUSY1+11,KCS)
8878 MINT(22)=-MINT(21)
8879
8880 ELSEIF(ISUB.EQ.202) THEN
8881C...f + fbar -> ~e_R + ~e_Rbar
8882 MINT(21)=ISIGN(KSUSY2+11,KCS)
8883 MINT(22)=-MINT(21)
8884
8885 ELSEIF(ISUB.EQ.203) THEN
8886C...f + fbar -> ~e_R + ~e_Lbar
8887 KCSG=1
8888 IF(MINT(2).EQ.2) KCSG=-1
8889 MINT(21)=ISIGN(KSUSY1+11,KCSG)
8890 MINT(22)=-ISIGN(KSUSY2+11,KCSG)
8891
8892 ELSEIF(ISUB.EQ.204) THEN
8893C...f + fbar -> ~mu_L + ~mu_Lbar
8894 MINT(21)=ISIGN(KSUSY1+13,KCS)
8895 MINT(22)=-MINT(21)
8896
8897 ELSEIF(ISUB.EQ.205) THEN
8898C...f + fbar -> ~mu_R + ~mu_Rbar
8899 MINT(21)=ISIGN(KSUSY2+13,KCS)
8900 MINT(22)=-MINT(21)
8901
8902 ELSEIF(ISUB.EQ.206) THEN
8903C...f + fbar -> ~mu_L + ~mu_Rbar
8904 KCSG=1
8905 IF(MINT(2).EQ.2) KCSG=-1
8906 MINT(21)=ISIGN(KSUSY1+13,KCSG)
8907 MINT(22)=-ISIGN(KSUSY2+13,KCSG)
8908
8909 ELSEIF(ISUB.EQ.207) THEN
8910C...f + fbar -> ~tau_1 + ~tau_1bar
8911 MINT(21)=ISIGN(KSUSY1+15,KCS)
8912 MINT(22)=-MINT(21)
8913
8914 ELSEIF(ISUB.EQ.208) THEN
8915C...f + fbar -> ~tau_2 + ~tau_2bar
8916 MINT(21)=ISIGN(KSUSY2+15,KCS)
8917 MINT(22)=-MINT(21)
8918
8919 ELSEIF(ISUB.EQ.209) THEN
8920C...f + fbar -> ~tau_1 + ~tau_2bar
8921 KCSG=1
8922 IF(MINT(2).EQ.2) KCSG=-1
8923 MINT(21)=ISIGN(KSUSY1+15,KCSG)
8924 MINT(22)=-ISIGN(KSUSY2+15,KCSG)
8925
8926 ELSEIF(ISUB.EQ.210) THEN
8927C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
8928 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8929 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8930 MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2)
8931 MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2)
8932
8933 ELSEIF(ISUB.EQ.211) THEN
8934C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
8935 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8936 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8937 MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2)
8938 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
8939
8940 ELSEIF(ISUB.EQ.212) THEN
8941C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
8942 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8943 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8944 MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2)
8945 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
8946
8947 ELSEIF(ISUB.EQ.213) THEN
8948C...f + fbar -> ~nul + ~nulbar
8949 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
8950 MINT(22)=-MINT(21)
8951
8952 ELSEIF(ISUB.EQ.214) THEN
8953C...f + fbar -> ~nutau + ~nutaubar
8954 MINT(21)=ISIGN(KSUSY1+16,KCS)
8955 MINT(22)=-MINT(21)
8956 ENDIF
8957
8958 ELSEIF(ISUB.LE.225) THEN
8959 IF(ISUB.EQ.216) THEN
8960C...f + fbar -> ~chi01 + ~chi01
8961 MINT(21)=KSUSY1+22
8962 MINT(22)=KSUSY1+22
8963
8964 ELSEIF(ISUB.EQ.217) THEN
8965C...f + fbar -> ~chi02 + ~chi02
8966 MINT(21)=KSUSY1+23
8967 MINT(22)=KSUSY1+23
8968
8969 ELSEIF(ISUB.EQ.218 ) THEN
8970C...f + fbar -> ~chi03 + ~chi03
8971 MINT(21)=KSUSY1+25
8972 MINT(22)=KSUSY1+25
8973
8974 ELSEIF(ISUB.EQ.219 ) THEN
8975C...f + fbar -> ~chi04 + ~chi04
8976 MINT(21)=KSUSY1+35
8977 MINT(22)=KSUSY1+35
8978
8979 ELSEIF(ISUB.EQ.220 ) THEN
8980C...f + fbar -> ~chi01 + ~chi02
8981 IF(PYR(0).GT.0.5D0) JS=2
8982 MINT(20+JS)=KSUSY1+22
8983 MINT(23-JS)=KSUSY1+23
8984
8985 ELSEIF(ISUB.EQ.221 ) THEN
8986C...f + fbar -> ~chi01 + ~chi03
8987 IF(PYR(0).GT.0.5D0) JS=2
8988 MINT(20+JS)=KSUSY1+22
8989 MINT(23-JS)=KSUSY1+25
8990
8991 ELSEIF(ISUB.EQ.222) THEN
8992C...f + fbar -> ~chi01 + ~chi04
8993 IF(PYR(0).GT.0.5D0) JS=2
8994 MINT(20+JS)=KSUSY1+22
8995 MINT(23-JS)=KSUSY1+35
8996
8997 ELSEIF(ISUB.EQ.223) THEN
8998C...f + fbar -> ~chi02 + ~chi03
8999 IF(PYR(0).GT.0.5D0) JS=2
9000 MINT(20+JS)=KSUSY1+23
9001 MINT(23-JS)=KSUSY1+25
9002
9003 ELSEIF(ISUB.EQ.224) THEN
9004C...f + fbar -> ~chi02 + ~chi04
9005 IF(PYR(0).GT.0.5D0) JS=2
9006 MINT(20+JS)=KSUSY1+23
9007 MINT(23-JS)=KSUSY1+35
9008
9009 ELSEIF(ISUB.EQ.225) THEN
9010C...f + fbar -> ~chi03 + ~chi04
9011 IF(PYR(0).GT.0.5D0) JS=2
9012 MINT(20+JS)=KSUSY1+25
9013 MINT(23-JS)=KSUSY1+35
9014 ENDIF
9015
9016 ELSEIF(ISUB.LE.236) THEN
9017 IF(ISUB.EQ.226) THEN
9018C...f + fbar -> ~chi+-1 + ~chi-+1
9019C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
9020 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9021 MINT(21)=ISIGN(KSUSY1+24,KCH1)
9022 MINT(22)=-MINT(21)
9023
9024 ELSEIF(ISUB.EQ.227) THEN
9025C...f + fbar -> ~chi+-2 + ~chi-+2
9026 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9027 MINT(21)=ISIGN(KSUSY1+37,KCH1)
9028 MINT(22)=-MINT(21)
9029
9030 ELSEIF(ISUB.EQ.228) THEN
9031C...f + fbar -> ~chi+-1 + ~chi-+2
9032C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
9033C...js=1 if pyr<.5, js=2 if pyr>.5
9034C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
9035C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
9036C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
9037C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
9038 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9039C KCH1=ISIGN(1,MINT(15))
9040 KCH2=INT(1-KCH1)/2
9041 IF(MINT(2).EQ.1) THEN
9042 MINT(22-KCH2)= -(KSUSY1+24)
9043 MINT(21+KCH2)= KSUSY1+37
9044 IF(KCH2.EQ.0) JS=2
9045 ELSE
9046 MINT(21+KCH2)= KSUSY1+24
9047 MINT(22-KCH2)= -(KSUSY1+37)
9048 IF(KCH2.EQ.1) JS=2
9049 ENDIF
9050
9051 ELSEIF(ISUB.EQ.229) THEN
9052C...q + qbar' -> ~chi01 + ~chi+-1
9053C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
9054 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9055 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9056C...CHECK THIS
9057 IF(MOD(MINT(15),2).NE.0) JS=2
9058 MINT(20+JS)=KSUSY1+22
9059 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
9060
9061 ELSEIF(ISUB.EQ.230) THEN
9062C...q + qbar' -> ~chi02 + ~chi+-1
9063 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9064 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9065 IF(MOD(MINT(15),2).NE.0) JS=2
9066 MINT(20+JS)=KSUSY1+23
9067 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
9068
9069 ELSEIF(ISUB.EQ.231) THEN
9070C...q + qbar' -> ~chi03 + ~chi+-1
9071 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9072 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9073 IF(MOD(MINT(15),2).NE.0) JS=2
9074 MINT(20+JS)=KSUSY1+25
9075 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
9076
9077 ELSEIF(ISUB.EQ.232) THEN
9078C...q + qbar' -> ~chi04 + ~chi+-1
9079 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9080 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9081 IF(MOD(MINT(15),2).NE.0) JS=2
9082 MINT(20+JS)=KSUSY1+35
9083 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
9084
9085 ELSEIF(ISUB.EQ.233) THEN
9086C...q + qbar' -> ~chi01 + ~chi+-2
9087 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9088 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9089 IF(MOD(MINT(15),2).NE.0) JS=2
9090 MINT(20+JS)=KSUSY1+22
9091 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
9092
9093 ELSEIF(ISUB.EQ.234) THEN
9094C...q + qbar' -> ~chi02 + ~chi+-2
9095 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9096 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9097 IF(MOD(MINT(15),2).NE.0) JS=2
9098 MINT(20+JS)=KSUSY1+23
9099 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
9100
9101 ELSEIF(ISUB.EQ.235) THEN
9102C...q + qbar' -> ~chi03 + ~chi+-2
9103 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9104 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9105 IF(MOD(MINT(15),2).NE.0) JS=2
9106 MINT(20+JS)=KSUSY1+25
9107 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
9108
9109 ELSEIF(ISUB.EQ.236) THEN
9110C...q + qbar' -> ~chi04 + ~chi+-2
9111 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9112 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9113 IF(MOD(MINT(15),2).NE.0) JS=2
9114 MINT(20+JS)=KSUSY1+35
9115 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
9116 ENDIF
9117
9118 ELSEIF(ISUB.LE.245) THEN
9119 IF(ISUB.EQ.237) THEN
9120C...q + qbar -> ~chi01 + ~g
9121C...th arbitrary
9122 IF(PYR(0).GT.0.5D0) JS=2
9123 MINT(20+JS)=KSUSY1+21
9124 MINT(23-JS)=KSUSY1+22
9125 KCC=17+JS
9126
9127 ELSEIF(ISUB.EQ.238) THEN
9128C...q + qbar -> ~chi02 + ~g
9129C...th arbitrary
9130 IF(PYR(0).GT.0.5D0) JS=2
9131 MINT(20+JS)=KSUSY1+21
9132 MINT(23-JS)=KSUSY1+23
9133 KCC=17+JS
9134
9135 ELSEIF(ISUB.EQ.239) THEN
9136C...q + qbar -> ~chi03 + ~g
9137C...th arbitrary
9138 IF(PYR(0).GT.0.5D0) JS=2
9139 MINT(20+JS)=KSUSY1+21
9140 MINT(23-JS)=KSUSY1+25
9141 KCC=17+JS
9142
9143 ELSEIF(ISUB.EQ.240) THEN
9144C...q + qbar -> ~chi04 + ~g
9145C...th arbitrary
9146 IF(PYR(0).GT.0.5D0) JS=2
9147 MINT(20+JS)=KSUSY1+21
9148 MINT(23-JS)=KSUSY1+35
9149 KCC=17+JS
9150
9151 ELSEIF(ISUB.EQ.241) THEN
9152C...q + qbar' -> ~chi+-1 + ~g
9153C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
9154C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
9155C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
9156C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
9157C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
9158 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9159 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9160 JS=1
9161 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
9162 MINT(20+JS)=KSUSY1+21
9163 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
9164 KCC=17+JS
9165
9166 ELSEIF(ISUB.EQ.242) THEN
9167C...q + qbar' -> ~chi+-2 + ~g
9168C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
9169C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
9170C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
9171C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
9172C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
9173 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9174 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9175 JS=1
9176 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
9177 MINT(20+JS)=KSUSY1+21
9178 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
9179 KCC=17+JS
9180
9181 ELSEIF(ISUB.EQ.243) THEN
9182C...q + qbar -> ~g + ~g ; th arbitrary
9183 MINT(21)=KSUSY1+21
9184 MINT(22)=KSUSY1+21
9185 KCC=MINT(2)+4
9186
9187 ELSEIF(ISUB.EQ.244) THEN
9188C...g + g -> ~g + ~g ; th arbitrary
9189 KCC=MINT(2)+12
9190 KCS=(-1)**INT(1.5D0+PYR(0))
9191 MINT(21)=KSUSY1+21
9192 MINT(22)=KSUSY1+21
9193 ENDIF
9194
9195 ELSEIF(ISUB.LE.260) THEN
9196 IF(ISUB.EQ.246) THEN
9197C...qj + g -> ~qj_L + ~chi01
9198 IF(MINT(15).EQ.21) JS=2
9199 I=MINT(14+JS)
9200 IA=IABS(I)
9201 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
9202 MINT(23-JS)=KSUSY1+22
9203 KCC=15+JS
9204 KCS=ISIGN(1,MINT(14+JS))
9205
9206 ELSEIF(ISUB.EQ.247) THEN
9207C...qj + g -> ~qj_R + ~chi01
9208 IF(MINT(15).EQ.21) JS=2
9209 I=MINT(14+JS)
9210 IA=IABS(I)
9211 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
9212 MINT(23-JS)=KSUSY1+22
9213 KCC=15+JS
9214 KCS=ISIGN(1,MINT(14+JS))
9215
9216 ELSEIF(ISUB.EQ.248) THEN
9217C...qj + g -> ~qj_L + ~chi02
9218 IF(MINT(15).EQ.21) JS=2
9219 I=MINT(14+JS)
9220 IA=IABS(I)
9221 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
9222 MINT(23-JS)=KSUSY1+23
9223 KCC=15+JS
9224 KCS=ISIGN(1,MINT(14+JS))
9225
9226 ELSEIF(ISUB.EQ.249) THEN
9227C...qj + g -> ~qj_R + ~chi02
9228 IF(MINT(15).EQ.21) JS=2
9229 I=MINT(14+JS)
9230 IA=IABS(I)
9231 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
9232 MINT(23-JS)=KSUSY1+23
9233 KCC=15+JS
9234 KCS=ISIGN(1,MINT(14+JS))
9235
9236 ELSEIF(ISUB.EQ.250) THEN
9237C...qj + g -> ~qj_L + ~chi03
9238 IF(MINT(15).EQ.21) JS=2
9239 I=MINT(14+JS)
9240 IA=IABS(I)
9241 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
9242 MINT(23-JS)=KSUSY1+25
9243 KCC=15+JS
9244 KCS=ISIGN(1,MINT(14+JS))
9245
9246 ELSEIF(ISUB.EQ.251) THEN
9247C...qj + g -> ~qj_R + ~chi03
9248 IF(MINT(15).EQ.21) JS=2
9249 I=MINT(14+JS)
9250 IA=IABS(I)
9251 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
9252 MINT(23-JS)=KSUSY1+25
9253 KCC=15+JS
9254 KCS=ISIGN(1,MINT(14+JS))
9255
9256 ELSEIF(ISUB.EQ.252) THEN
9257C...qj + g -> ~qj_L + ~chi04
9258 IF(MINT(15).EQ.21) JS=2
9259 I=MINT(14+JS)
9260 IA=IABS(I)
9261 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
9262 MINT(23-JS)=KSUSY1+35
9263 KCC=15+JS
9264 KCS=ISIGN(1,MINT(14+JS))
9265
9266 ELSEIF(ISUB.EQ.253) THEN
9267C...qj + g -> ~qj_R + ~chi04
9268 IF(MINT(15).EQ.21) JS=2
9269 I=MINT(14+JS)
9270 IA=IABS(I)
9271 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
9272 MINT(23-JS)=KSUSY1+35
9273 KCC=15+JS
9274 KCS=ISIGN(1,MINT(14+JS))
9275
9276 ELSEIF(ISUB.EQ.254) THEN
9277C...qj + g -> ~qk_L + ~chi+-1
9278 IF(MINT(15).EQ.21) JS=2
9279 I=MINT(14+JS)
9280 IA=IABS(I)
9281 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
9282 IB=-IA+INT((IA+1)/2)*4-1
9283 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
9284 KCC=15+JS
9285 KCS=ISIGN(1,MINT(14+JS))
9286
9287 ELSEIF(ISUB.EQ.255) THEN
9288C...qj + g -> ~qk_L + ~chi+-1
9289 IF(MINT(15).EQ.21) JS=2
9290 I=MINT(14+JS)
9291 IA=IABS(I)
9292 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
9293 IB=-IA+INT((IA+1)/2)*4-1
9294 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
9295 KCC=15+JS
9296 KCS=ISIGN(1,MINT(14+JS))
9297
9298 ELSEIF(ISUB.EQ.256) THEN
9299C...qj + g -> ~qk_L + ~chi+-2
9300 IF(MINT(15).EQ.21) JS=2
9301 I=MINT(14+JS)
9302 IA=IABS(I)
9303 IB=-IA+INT((IA+1)/2)*4-1
9304 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
9305 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
9306 KCC=15+JS
9307 KCS=ISIGN(1,MINT(14+JS))
9308
9309 ELSEIF(ISUB.EQ.257) THEN
9310C...qj + g -> ~qk_R + ~chi+-2
9311 IF(MINT(15).EQ.21) JS=2
9312 I=MINT(14+JS)
9313 IA=IABS(I)
9314 IB=-IA+INT((IA+1)/2)*4-1
9315 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
9316 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
9317 KCC=15+JS
9318 KCS=ISIGN(1,MINT(14+JS))
9319
9320 ELSEIF(ISUB.EQ.258) THEN
9321C...qj + g -> ~qj_L + ~g
9322 IF(MINT(15).EQ.21) JS=2
9323 I=MINT(14+JS)
9324 IA=IABS(I)
9325 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
9326 MINT(23-JS)=KSUSY1+21
9327 KCC=MINT(2)+6
9328 IF(JS.EQ.2) KCC=KCC+2
9329 KCS=ISIGN(1,I)
9330
9331 ELSEIF(ISUB.EQ.259) THEN
9332C...qj + g -> ~qj_R + ~g
9333 IF(MINT(15).EQ.21) JS=2
9334 I=MINT(14+JS)
9335 IA=IABS(I)
9336 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
9337 MINT(23-JS)=KSUSY1+21
9338 KCC=MINT(2)+6
9339 IF(JS.EQ.2) KCC=KCC+2
9340 KCS=ISIGN(1,I)
9341 ENDIF
9342
9343 ELSEIF(ISUB.LE.270) THEN
9344 IF(ISUB.EQ.261) THEN
9345C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
9346 ISGN=1
9347 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
9348 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
9349 MINT(22)=-MINT(21)
9350C...Correct color combination
9351 IF(MINT(43).EQ.4) KCC=4
9352
9353 ELSEIF(ISUB.EQ.262) THEN
9354C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
9355 ISGN=1
9356 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
9357 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
9358 MINT(22)=-MINT(21)
9359C...Correct color combination
9360 IF(MINT(43).EQ.4) KCC=4
9361
9362 ELSEIF(ISUB.EQ.263) THEN
9363C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
9364 IF((KCS.GT.0.AND.MINT(2).EQ.1).OR.
9365 & (KCS.LT.0.AND.MINT(2).EQ.2)) THEN
9366 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
9367 MINT(22)=-ISIGN(KFPR(ISUB,2),KCS)
9368 ELSE
9369 JS=2
9370 MINT(21)=ISIGN(KFPR(ISUB,2),KCS)
9371 MINT(22)=-ISIGN(KFPR(ISUB,1),KCS)
9372 ENDIF
9373C...Correct color combination
9374 IF(MINT(43).EQ.4) KCC=4
9375
9376 ELSEIF(ISUB.EQ.264) THEN
9377C...g + g -> ~t_1 + ~t_1bar; th arbitrary
9378 KCS=(-1)**INT(1.5D0+PYR(0))
9379 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
9380 MINT(22)=-MINT(21)
9381 KCC=MINT(2)+10
9382
9383 ELSEIF(ISUB.EQ.265) THEN
9384C...g + g -> ~t_2 + ~t_2bar; th arbitrary
9385 KCS=(-1)**INT(1.5D0+PYR(0))
9386 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
9387 MINT(22)=-MINT(21)
9388 KCC=MINT(2)+10
9389 ENDIF
9390
9391 ELSEIF(ISUB.LE.296) THEN
9392 IF(ISUB.EQ.271.OR.ISUB.EQ.281.OR.ISUB.EQ.291) THEN
9393C...qi + qj -> ~qi_L + ~qj_L
9394 KCC=MINT(2)
9395 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
9396 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
9397 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
9398
9399 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.282.OR.ISUB.EQ.292) THEN
9400C...qi + qj -> ~qi_R + ~qj_R
9401 KCC=MINT(2)
9402 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
9403 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
9404 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
9405
9406 ELSEIF(ISUB.EQ.273.OR.ISUB.EQ.283.OR.ISUB.EQ.293) THEN
9407C...qi + qj -> ~qi_L + ~qj_R
9408 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9409 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
9410 KCC=MINT(2)
9411 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
9412
9413 ELSEIF(ISUB.EQ.274.OR.ISUB.EQ.284) THEN
9414C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
9415 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
9416 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
9417 KCC=MINT(2)
9418 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
9419
9420 ELSEIF(ISUB.EQ.275.OR.ISUB.EQ.285) THEN
9421C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
9422 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
9423 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
9424 KCC=MINT(2)
9425 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
9426
9427 ELSEIF(ISUB.EQ.276.OR.ISUB.EQ.286.OR.ISUB.EQ.296) THEN
9428C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
9429 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9430 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
9431 KCC=MINT(2)
9432 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
9433
9434 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.287) THEN
9435C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
9436 ISGN=1
9437 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
9438 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
9439 MINT(22)=-MINT(21)
9440 IF(MINT(43).EQ.4) KCC=4
9441
9442 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.288) THEN
9443C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
9444 ISGN=1
9445 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
9446 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
9447 MINT(22)=-MINT(21)
9448 IF(MINT(43).EQ.4) KCC=4
9449
9450 ELSEIF(ISUB.EQ.279.OR.ISUB.EQ.289) THEN
9451C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
9452C...pure LL + RR
9453 KCS=(-1)**INT(1.5D0+PYR(0))
9454 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
9455 MINT(22)=-MINT(21)
9456 KCC=MINT(2)+10
9457
9458 ELSEIF(ISUB.EQ.280.OR.ISUB.EQ.290) THEN
9459C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
9460 KCS=(-1)**INT(1.5D0+PYR(0))
9461 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
9462 MINT(22)=-MINT(21)
9463 KCC=MINT(2)+10
9464
9465 ELSEIF(ISUB.EQ.294) THEN
9466C...qj + g -> ~qj_L + ~g
9467 IF(MINT(15).EQ.21) JS=2
9468 I=MINT(14+JS)
9469 IA=IABS(I)
9470 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
9471 MINT(23-JS)=KSUSY1+21
9472 KCC=MINT(2)+6
9473 IF(JS.EQ.2) KCC=KCC+2
9474 KCS=ISIGN(1,I)
9475
9476 ELSEIF(ISUB.EQ.295) THEN
9477C...qj + g -> ~qj_R + ~g
9478 IF(MINT(15).EQ.21) JS=2
9479 I=MINT(14+JS)
9480 IA=IABS(I)
9481 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
9482 MINT(23-JS)=KSUSY1+21
9483 KCC=MINT(2)+6
9484 IF(JS.EQ.2) KCC=KCC+2
9485 KCS=ISIGN(1,I)
9486 ENDIF
9487
9488 ELSEIF(ISUB.LE.340) THEN
9489
9490 IF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
9491C...q + qbar' -> H+ + H0
9492 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9493 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9494 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
9495 MINT(20+JS)=ISIGN(37,KCH1+KCH2)
9496 MINT(23-JS)=KFPR(ISUB,2)
9497 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
9498C...f + fbar -> A0 + H0; th arbitrary
9499 IF(PYR(0).GT.0.5D0) JS=2
9500 MINT(20+JS)=KFPR(ISUB,1)
9501 MINT(23-JS)=KFPR(ISUB,2)
9502 ELSEIF(ISUB.EQ.301) THEN
9503C...f + fbar -> H+ H-
9504 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
9505 MINT(22)=-MINT(21)
9506 ENDIF
9507CMRENNA--
9508
9509 ELSEIF(ISUB.LE.360) THEN
9510
9511 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
9512C...l + l -> H_L++/--, H_R++/--
9513 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9514 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9515 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
9516
9517 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
9518C...l + gamma -> l' + H++/--; th=(p(l)-p(H))**2
9519 IF(MINT(15).EQ.22) JS=2
9520 MINT(20+JS)=ISIGN(KFPR(ISUB,1),-MINT(14+JS))
9521 MINT(23-JS)=ISIGN(KFPR(ISUB,2),-MINT(14+JS))
9522 KCC=22
9523
9524 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
9525C...f + fbar -> H++ + H--; th = (p(f)-p(H--))**2
9526 MINT(21)=-ISIGN(KFPR(ISUB,1),MINT(15))
9527 MINT(22)=-MINT(21)
9528
9529 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
9530C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/--
9531C...as inner process).
9532 DO 432 JT=1,2
9533 I=MINT(14+JT)
9534 IA=IABS(I)
9535 IF(IA.LE.10) THEN
9536 RVCKM=VINT(180+I)*PYR(0)
9537 DO 422 J=1,MSTP(1)
9538 IB=2*J-1+MOD(IA,2)
9539 IPM=(5-ISIGN(1,I))/2
9540 IDC=J+MDCY(IA,2)+2
9541 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 422
9542 MINT(20+JT)=ISIGN(IB,I)
9543 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
9544 IF(RVCKM.LE.0D0) GOTO 432
9545 422 CONTINUE
9546 ELSE
9547 IB=2*((IA+1)/2)-1+MOD(IA,2)
9548 MINT(20+JT)=ISIGN(IB,I)
9549 ENDIF
9550 432 CONTINUE
9551 KCC=22
9552 KFRES=ISIGN(KFPR(ISUB,1),MINT(15))
9553 IF(MOD(MINT(15),2).EQ.1) KFRES=-KFRES
9554
9555 ENDIF
9556
9557 ELSEIF(ISUB.LE.380) THEN
9558 IF(ISUB.LE.363.OR.ISUB.EQ.368) THEN
9559C...f + fbar -> pi+ pi-
9560 KSW=(-1)**INT(1.5D0+PYR(0))
9561 MINT(21)=ISIGN(KFPR(ISUB,1),KSW)
9562 MINT(22)=-ISIGN(KFPR(ISUB,2),KSW)
9563C...f + fbar -> neutral neutral
9564 ELSEIF(ISUB.LE.367) THEN
9565 MINT(21)=KFPR(ISUB,1)
9566 MINT(22)=KFPR(ISUB,2)
9567C...f + fbar' -> charged neutral
9568 ELSEIF(ISUB.EQ.374.OR.ISUB.EQ.375) THEN
9569 IN=1
9570 IC=2
9571 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9572 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9573 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
9574c MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
9575c MINT(23-JS)=KFPR(ISUB,IN)
9576 MINT(23-JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
9577 MINT(20+JS)=KFPR(ISUB,IN)
9578
9579 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
9580 IN=2
9581 IC=1
9582 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9583 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9584 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
9585 MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
9586 MINT(23-JS)=KFPR(ISUB,IN)
9587 ENDIF
9588 ENDIF
9589
9590 IF(ISET(ISUB).EQ.11) THEN
9591C...Store documentation for user-defined processes
9592 BEZUP=(PUP(1,4)-PUP(2,4))/(PUP(1,4)+PUP(2,4))
9593 KUPPO(1)=MINT(83)+5
9594 KUPPO(2)=MINT(83)+6
9595 I=MINT(83)+6
9596 DO 450 IUP=3,NUP
9597 KUPPO(IUP)=0
9598 IF(MSTP(128).GE.2.AND.KUP(IUP,3).NE.0) THEN
9599 IDOC=IDOC-1
9600 MINT(4)=MINT(4)-1
9601 GOTO 450
9602 ENDIF
9603 I=I+1
9604 KUPPO(IUP)=I
9605 K(I,1)=21
9606 K(I,2)=KUP(IUP,2)
9607 K(I,3)=0
9608 IF(KUP(IUP,3).NE.0) K(I,3)=KUPPO(KUP(IUP,3))
9609 K(I,4)=0
9610 K(I,5)=0
9611 DO 440 J=1,5
9612 P(I,J)=PUP(IUP,J)
9613 440 CONTINUE
9614 450 CONTINUE
9615 CALL PYROBO(MINT(83)+7,MINT(83)+4+NUP,0D0,VINT(24),0D0,0D0,
9616 & -BEZUP)
9617
9618C...Store final state partons for user-defined processes
9619 N=IPU2
9620 DO 470 IUP=3,NUP
9621 N=N+1
9622 K(N,1)=1
9623 IF(KUP(IUP,1).NE.1) K(N,1)=11
9624 K(N,2)=KUP(IUP,2)
9625 IF(MSTP(128).LE.0.OR.KUP(IUP,3).EQ.0) THEN
9626 K(N,3)=KUPPO(IUP)
9627 ELSE
9628 K(N,3)=MINT(84)+KUP(IUP,3)
9629 ENDIF
9630 K(N,4)=0
9631 K(N,5)=0
9632 DO 460 J=1,5
9633 P(N,J)=PUP(IUP,J)
9634 460 CONTINUE
9635 470 CONTINUE
9636 CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP)
9637
9638C...Arrange colour flow for user-defined processes
9639 N=MINT(84)
9640 DO 480 IUP=1,NUP
9641 N=N+1
9642 IF(KCHG(PYCOMP(K(N,2)),2).EQ.0) GOTO 480
9643 IF(K(N,1).EQ.1) K(N,1)=3
9644 IF(K(N,1).EQ.11) K(N,1)=14
9645 IF(KUP(IUP,4).NE.0) K(N,4)=K(N,4)+MSTU(5)*(KUP(IUP,4)+
9646 & MINT(84))
9647 IF(KUP(IUP,5).NE.0) K(N,5)=K(N,5)+MSTU(5)*(KUP(IUP,5)+
9648 & MINT(84))
9649 IF(KUP(IUP,6).NE.0) K(N,4)=K(N,4)+KUP(IUP,6)+MINT(84)
9650 IF(KUP(IUP,7).NE.0) K(N,5)=K(N,5)+KUP(IUP,7)+MINT(84)
9651 480 CONTINUE
9652
9653 ELSEIF(IDOC.EQ.7) THEN
9654C...Resonance not decaying; store kinematics
9655 I=MINT(83)+7
9656 K(IPU3,1)=1
9657 K(IPU3,2)=KFRES
9658 K(IPU3,3)=I
9659 P(IPU3,4)=SHUSER
9660 P(IPU3,5)=SHUSER
9661 K(I,1)=21
9662 K(I,2)=KFRES
9663 P(I,4)=SHUSER
9664 P(I,5)=SHUSER
9665 N=IPU3
9666 MINT(21)=KFRES
9667 MINT(22)=0
9668
9669C...Special cases: colour flow in coloured resonances
9670 KCRES=PYCOMP(KFRES)
9671 IF(KCHG(KCRES,2).NE.0) THEN
9672 K(IPU3,1)=3
9673 DO 490 J=1,2
9674 JC=J
9675 IF(KCS.EQ.-1) JC=3-J
9676 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
9677 & MINT(84)+ICOL(KCC,1,JC)
9678 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
9679 & MINT(84)+ICOL(KCC,2,JC)
9680 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
9681 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
9682 490 CONTINUE
9683 ELSE
9684 K(IPU1,4)=IPU2
9685 K(IPU1,5)=IPU2
9686 K(IPU2,4)=IPU1
9687 K(IPU2,5)=IPU1
9688 ENDIF
9689
9690 ELSEIF(IDOC.EQ.8) THEN
9691C...2 -> 2 processes: store outgoing partons in their CM-frame
9692 DO 500 JT=1,2
9693 I=MINT(84)+2+JT
9694 KCA=PYCOMP(MINT(20+JT))
9695 K(I,1)=1
9696 IF(KCHG(KCA,2).NE.0) K(I,1)=3
9697 K(I,2)=MINT(20+JT)
9698 K(I,3)=MINT(83)+IDOC+JT-2
9699 KFAA=IABS(K(I,2))
9700 IF(KFPR(ISUBSV,1+MOD(JS+JT,2)).NE.0) THEN
9701 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
9702 ELSE
9703 P(I,5)=PYMASS(K(I,2))
9704 ENDIF
9705 IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND.
9706 & P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2))
9707 500 CONTINUE
9708 IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
9709 KFA1=IABS(MINT(21))
9710 KFA2=IABS(MINT(22))
9711 IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
9712 & THEN
9713 MINT(51)=1
9714 RETURN
9715 ENDIF
9716 P(IPU3,5)=0D0
9717 P(IPU4,5)=0D0
9718 ENDIF
9719 P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
9720 P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2))
9721 P(IPU4,4)=SHR-P(IPU3,4)
9722 P(IPU4,3)=-P(IPU3,3)
9723 N=IPU4
9724 MINT(7)=MINT(83)+7
9725 MINT(8)=MINT(83)+8
9726
9727C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
9728 CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
9729
9730 ELSEIF(IDOC.EQ.9) THEN
9731C...2 -> 3 processes: store outgoing partons in their CM frame
9732 DO 510 JT=1,2
9733 I=MINT(84)+2+JT
9734 KCA=PYCOMP(MINT(20+JT))
9735 K(I,1)=1
9736 IF(KCHG(KCA,2).NE.0) K(I,1)=3
9737 K(I,2)=MINT(20+JT)
9738 K(I,3)=MINT(83)+IDOC+JT-3
9739 IF(IABS(K(I,2)).LE.22) THEN
9740 P(I,5)=PYMASS(K(I,2))
9741 ELSE
9742 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
9743 ENDIF
9744 PT=SQRT(MAX(0D0,VINT(197+5*JT)-P(I,5)**2+VINT(196+5*JT)**2))
9745 P(I,1)=PT*COS(VINT(198+5*JT))
9746 P(I,2)=PT*SIN(VINT(198+5*JT))
9747 510 CONTINUE
9748 K(IPU5,1)=1
9749 K(IPU5,2)=KFRES
9750 K(IPU5,3)=MINT(83)+IDOC
9751 P(IPU5,5)=SHR
9752 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
9753 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
9754 PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
9755 PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2
9756 PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2
9757 PMT3=SQRT(PMS3)
9758 P(IPU5,3)=PMT3*SINH(VINT(211))
9759 P(IPU5,4)=PMT3*COSH(VINT(211))
9760 PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2
9761 SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2
9762 IF(SQL12.LE.0D0) THEN
9763 MINT(51)=1
9764 RETURN
9765 ENDIF
9766 P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+
9767 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
9768 P(IPU4,3)=-P(IPU3,3)-P(IPU5,3)
9769 P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2)
9770 P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2)
9771 MINT(23)=KFRES
9772 N=IPU5
9773 MINT(7)=MINT(83)+7
9774 MINT(8)=MINT(83)+8
9775
9776 ELSEIF(IDOC.EQ.11) THEN
9777C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
9778 PHI(1)=PARU(2)*PYR(0)
9779 PHI(2)=PHI(1)-PHIR
9780 DO 520 JT=1,2
9781 I=MINT(84)+2+JT
9782 K(I,1)=1
9783 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
9784 K(I,2)=MINT(20+JT)
9785 K(I,3)=MINT(83)+IDOC+JT-2
9786 P(I,5)=PYMASS(K(I,2))
9787 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN
9788 MINT(51)=1
9789 RETURN
9790 ENDIF
9791 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
9792 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
9793 P(I,1)=PTABS*COS(PHI(JT))
9794 P(I,2)=PTABS*SIN(PHI(JT))
9795 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
9796 P(I,4)=0.5D0*SHPR*Z(JT)
9797 IZW=MINT(83)+6+JT
9798 K(IZW,1)=21
9799 K(IZW,2)=23
9800 IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT)))
9801 K(IZW,3)=IZW-2
9802 P(IZW,1)=-P(I,1)
9803 P(IZW,2)=-P(I,2)
9804 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
9805 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
9806 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
9807 520 CONTINUE
9808 I=MINT(83)+9
9809 K(IPU5,1)=1
9810 K(IPU5,2)=KFRES
9811 K(IPU5,3)=I
9812 P(IPU5,5)=SHR
9813 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
9814 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
9815 P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
9816 P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
9817 K(I,1)=21
9818 K(I,2)=KFRES
9819 DO 530 J=1,5
9820 P(I,J)=P(IPU5,J)
9821 530 CONTINUE
9822 N=IPU5
9823 MINT(23)=KFRES
9824
9825 ELSEIF(IDOC.EQ.12) THEN
9826C...Z0 and W+/- scattering: store bosons and outgoing partons
9827 PHI(1)=PARU(2)*PYR(0)
9828 PHI(2)=PHI(1)-PHIR
9829 JTRAN=INT(1.5D0+PYR(0))
9830 DO 540 JT=1,2
9831 I=MINT(84)+2+JT
9832 K(I,1)=1
9833 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
9834 K(I,2)=MINT(20+JT)
9835 K(I,3)=MINT(83)+IDOC+JT-2
9836 P(I,5)=PYMASS(K(I,2))
9837 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0
9838 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
9839 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
9840 P(I,1)=PTABS*COS(PHI(JT))
9841 P(I,2)=PTABS*SIN(PHI(JT))
9842 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
9843 P(I,4)=0.5D0*SHPR*Z(JT)
9844 IZW=MINT(83)+6+JT
9845 K(IZW,1)=21
9846 IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
9847 K(IZW,2)=23
9848 ELSE
9849 K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT)))
9850 ENDIF
9851 K(IZW,3)=IZW-2
9852 P(IZW,1)=-P(I,1)
9853 P(IZW,2)=-P(I,2)
9854 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
9855 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
9856 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
9857 IPU=MINT(84)+4+JT
9858 K(IPU,1)=3
9859 K(IPU,2)=KFPR(ISUB,JT)
9860 IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2)
9861 IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2)
9862 K(IPU,3)=MINT(83)+8+JT
9863 IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
9864 P(IPU,5)=PYMASS(K(IPU,2))
9865 ELSE
9866 P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
9867 ENDIF
9868 MINT(22+JT)=K(IPU,2)
9869 540 CONTINUE
9870C...Find rotation and boost for hard scattering subsystem
9871 I1=MINT(83)+7
9872 I2=MINT(83)+8
9873 BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
9874 BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
9875 BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
9876 GAMCM=(P(I1,4)+P(I2,4))/SHR
9877 BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
9878 PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM
9879 PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM
9880 PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM
9881 THECM=PYANGL(PZ,SQRT(PX**2+PY**2))
9882 PHICM=PYANGL(PX,PY)
9883C...Store hard scattering subsystem. Rotate and boost it
9884 SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2*
9885 & P(IPU6,5)**2
9886 PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH)))
9887 CTHWZ=VINT(23)
9888 STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2))
9889 PHIWZ=VINT(24)-PHICM
9890 P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
9891 P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
9892 P(IPU5,3)=PABS*CTHWZ
9893 P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
9894 P(IPU6,1)=-P(IPU5,1)
9895 P(IPU6,2)=-P(IPU5,2)
9896 P(IPU6,3)=-P(IPU5,3)
9897 P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
9898 CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM)
9899 DO 560 JT=1,2
9900 I1=MINT(83)+8+JT
9901 I2=MINT(84)+4+JT
9902 K(I1,1)=21
9903 K(I1,2)=K(I2,2)
9904 DO 550 J=1,5
9905 P(I1,J)=P(I2,J)
9906 550 CONTINUE
9907 560 CONTINUE
9908 N=IPU6
9909 MINT(7)=MINT(83)+9
9910 MINT(8)=MINT(83)+10
9911 ENDIF
9912
9913 IF(ISET(ISUB).EQ.11) THEN
9914 ELSEIF(IDOC.GE.8) THEN
9915C...Store colour connection indices
9916 DO 570 J=1,2
9917 JC=J
9918 IF(KCS.EQ.-1) JC=3-J
9919 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
9920 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
9921 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
9922 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
9923 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
9924 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
9925 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
9926 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
9927 570 CONTINUE
9928
9929C...Copy outgoing partons to documentation lines
9930 IMAX=2
9931 IF(IDOC.EQ.9) IMAX=3
9932 DO 590 I=1,IMAX
9933 I1=MINT(83)+IDOC-IMAX+I
9934 I2=MINT(84)+2+I
9935 K(I1,1)=21
9936 K(I1,2)=K(I2,2)
9937 IF(IDOC.LE.9) K(I1,3)=0
9938 IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
9939 DO 580 J=1,5
9940 P(I1,J)=P(I2,J)
9941 580 CONTINUE
9942 590 CONTINUE
9943
9944 ELSEIF(IDOC.EQ.9) THEN
9945C...Store colour connection indices
9946 DO 600 J=1,2
9947 JC=J
9948 IF(KCS.EQ.-1) JC=3-J
9949 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
9950 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+
9951 & MAX(0,MIN(1,ICOL(KCC,1,JC)-2))
9952 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
9953 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+
9954 & MAX(0,MIN(1,ICOL(KCC,2,JC)-2))
9955 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
9956 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
9957 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)=
9958 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
9959 600 CONTINUE
9960
9961C...Copy outgoing partons to documentation lines
9962 DO 620 I=1,3
9963 I1=MINT(83)+IDOC-3+I
9964 I2=MINT(84)+2+I
9965 K(I1,1)=21
9966 K(I1,2)=K(I2,2)
9967 K(I1,3)=0
9968 DO 610 J=1,5
9969 P(I1,J)=P(I2,J)
9970 610 CONTINUE
9971 620 CONTINUE
9972 ENDIF
9973
9974C...Low-pT events: remove gluons used for string drawing purposes
9975 IF(ISUB.EQ.95) THEN
9976 K(IPU3,1)=K(IPU3,1)+10
9977 K(IPU4,1)=K(IPU4,1)+10
9978 DO 630 J=41,66
9979 VINTSV(J)=VINT(J)
9980 VINT(J)=0D0
9981 630 CONTINUE
9982 DO 650 I=MINT(83)+5,MINT(83)+8
9983 DO 640 J=1,5
9984 P(I,J)=0D0
9985 640 CONTINUE
9986 650 CONTINUE
9987 ENDIF
9988
9989 RETURN
9990 END
9991
9992C*********************************************************************
9993
9994C...PYSSPA
9995C...Generates spacelike parton showers.
9996
9997 SUBROUTINE PYSSPA(IPU1,IPU2)
9998
9999C...Double precision and integer declarations.
10000 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
10001 IMPLICIT INTEGER(I-N)
10002 INTEGER PYK,PYCHGE,PYCOMP
10003C...Commonblocks.
10004 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
10005 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10006 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
10007 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
10008 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
10009 COMMON/PYINT1/MINT(400),VINT(400)
10010 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
10011 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
10012 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
10013 &/PYINT2/,/PYINT3/
10014C...Local arrays and data.
10015 DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2),
10016 &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25),
10017 &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),
10018 &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2),
10019 &THEFIS(2,2),ISFI(2)
10020 DATA IS/2*0/
10021
10022C...Read out basic information; set global Q^2 scale.
10023 IPUS1=IPU1
10024 IPUS2=IPU2
10025 ISUB=MINT(1)
10026 Q2MX=VINT(56)
10027 IF(ISET(ISUB).EQ.2) Q2MX=MIN(VINT(2),PARP(67)*VINT(56))
10028 MECOR=0
10029 IF(MSTP(68).EQ.1.AND.(ISUB.EQ.1.OR.ISUB.EQ.2.OR.
10030 &ISUB.EQ.141.OR.ISUB.EQ.142.OR.ISUB.EQ.144)) MECOR=1
10031 FCQ2MX=1D0
10032
10033C...Initialize QCD evolution and check phase space.
10034 Q2MNC=PARP(62)**2
10035 Q2MNCS(1)=Q2MNC
10036 Q2MNCS(2)=Q2MNC
10037 IF(MINT(107).EQ.2.AND.MSTP(66).EQ.2) THEN
10038 Q0S=PARP(15)**2
10039 PS=VINT(3)**2
10040 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
10041 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
10042 Q2INT=SQRT(Q0S*Q2EFF)
10043 Q2MNCS(1)=MAX(Q2MNC,Q2INT)
10044 ELSEIF(MINT(107).EQ.3.AND.MSTP(66).GE.1) THEN
10045 Q2MNCS(1)=MAX(Q2MNC,VINT(283))
10046 ENDIF
10047 IF(MINT(108).EQ.2.AND.MSTP(66).EQ.2) THEN
10048 Q0S=PARP(15)**2
10049 PS=VINT(4)**2
10050 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
10051 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
10052 Q2INT=SQRT(Q0S*Q2EFF)
10053 Q2MNCS(2)=MAX(Q2MNC,Q2INT)
10054 ELSEIF(MINT(108).EQ.3.AND.MSTP(66).GE.1) THEN
10055 Q2MNCS(2)=MAX(Q2MNC,VINT(284))
10056 ENDIF
10057 MCEV=0
10058 ALAMS=PARU(112)
10059 PARU(112)=PARP(61)
10060 FQ2C=1D0
10061 TCMX=0D0
10062 IF(MINT(47).GE.2.AND.(MINT(47).LT.5.OR.MSTP(12).GE.1)) THEN
10063 MCEV=1
10064 IF(MSTP(64).EQ.1) FQ2C=PARP(63)
10065 IF(MSTP(64).EQ.2) FQ2C=PARP(64)
10066 TCMX=LOG(FQ2C*Q2MX/PARP(61)**2)
10067 IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0)
10068 & MCEV=0
10069 ENDIF
10070
10071C...Initialize QED evolution and check phase space.
10072 MEEV=0
10073 XEE=1D-10
10074 SPME=PMAS(11,1)**2
10075 IF(IABS(MINT(11)).EQ.13.OR.IABS(MINT(12)).EQ.13)
10076 &SPME=PMAS(13,1)**2
10077 IF(IABS(MINT(11)).EQ.15.OR.IABS(MINT(12)).EQ.15)
10078 &SPME=PMAS(15,1)**2
10079 Q2MNE=MAX(PARP(68)**2,2D0*SPME)
10080 TEMX=0D0
10081 FWTE=10D0
10082 IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN
10083 MEEV=1
10084 TEMX=LOG(Q2MX/SPME)
10085 IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0
10086 ENDIF
10087 IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN
10088
10089C...Loopback point in case of failure to reconstruct kinematics.
10090 NS=N
10091 LOOP=0
10092 100 LOOP=LOOP+1
10093 IF(LOOP.GT.100) THEN
10094 MINT(51)=1
10095 RETURN
10096 ENDIF
10097 N=NS
10098
10099C...Initial values: flavours, momenta, virtualities.
10100 DO 120 JT=1,2
10101 MORE(JT)=1
10102 KFBEAM(JT)=MINT(10+JT)
10103 IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22
10104 KFLS(JT)=MINT(14+JT)
10105 KFLS(JT+2)=KFLS(JT)
10106 XS(JT)=VINT(40+JT)
10107 IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT)
10108 ZS(JT)=1D0
10109 Q2S(JT)=FCQ2MX*Q2MX
10110 TEVCSV(JT)=TCMX
10111 ALAM(JT)=PARP(61)
10112 THE2(JT)=1D0
10113 TEVESV(JT)=TEMX
10114 DO 110 KFL=-25,25
10115 XFS(JT,KFL)=XSFX(JT,KFL)
10116 110 CONTINUE
10117C...Special kinematics check for c/b quarks (that g -> c cbar or
10118C...b bbar kinematically possible).
10119 KFLCB=IABS(KFLS(JT))
10120 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
10121 IF(XS(JT).GT.0.9D0*Q2S(JT)/(PMAS(KFLCB,1)**2+Q2S(JT))) THEN
10122 MINT(51)=1
10123 RETURN
10124 ENDIF
10125 ENDIF
10126 120 CONTINUE
10127 DSH=VINT(44)
10128 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2)
10129
10130C...Find if interference with final state partons.
10131 MFIS=0
10132 IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67)
10133 IF(MFIS.NE.0) THEN
10134 DO 140 I=1,2
10135 KCFI(I)=0
10136 KCA=PYCOMP(IABS(KFLS(I)))
10137 IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I))
10138 NFIS(I)=0
10139 IF(KCFI(I).NE.0) THEN
10140 IF(I.EQ.1) IPFS=IPUS1
10141 IF(I.EQ.2) IPFS=IPUS2
10142 DO 130 J=1,2
10143 ICSI=MOD(K(IPFS,3+J),MSTU(5))
10144 IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND.
10145 & (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN
10146 NFIS(I)=NFIS(I)+1
10147 THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+
10148 & P(ICSI,2)**2))
10149 IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I))
10150 ENDIF
10151 130 CONTINUE
10152 ENDIF
10153 140 CONTINUE
10154 IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0
10155 ENDIF
10156
10157C...Pick up leg with highest virtuality.
10158 150 N=N+1
10159 JT=1
10160 IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
10161 IF(MORE(JT).EQ.0) JT=3-JT
10162 KFLB=KFLS(JT)
10163 XB=XS(JT)
10164 DO 160 KFL=-25,25
10165 XFB(KFL)=XFS(JT,KFL)
10166 160 CONTINUE
10167 DSHR=2D0*SQRT(DSH)
10168 DSHZ=DSH/ZS(JT)
10169
10170C...Check if allowed to branch.
10171 MCEV=0
10172 IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN
10173 MCEV=1
10174 XEC=MAX(PARP(65)*DSHR/VINT(2),XB*(1D0/(1D0-PARP(66))-1D0))
10175 IF(XB.GE.1D0-2D0*XEC) MCEV=0
10176 ENDIF
10177 MEEV=0
10178 IF(MINT(44+JT).EQ.3) THEN
10179 MEEV=1
10180 IF(XB.GE.1D0-2D0*XEE) MEEV=0
10181 IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC)
10182 & MEEV=0
10183C***Currently kill QED shower for resolved photoproduction.
10184 IF(MINT(18+JT).EQ.1) MEEV=0
10185C***Currently kill shower for W inside electron.
10186 IF(IABS(KFLB).EQ.24) THEN
10187 MCEV=0
10188 MEEV=0
10189 ENDIF
10190 ENDIF
10191 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
10192 Q2B=0D0
10193 GOTO 250
10194 ENDIF
10195
10196C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
10197 Q2B=Q2S(JT)
10198 TEVCB=TEVCSV(JT)
10199 TEVEB=TEVESV(JT)
10200 IF(MSTP(62).LE.1) THEN
10201 IF(ZS(JT).GT.0.99999D0) THEN
10202 Q2B=Q2S(JT)
10203 ELSE
10204 Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)*
10205 & (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+
10206 & 8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT))))
10207 ENDIF
10208 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
10209 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
10210 ENDIF
10211 IF(MCEV.EQ.1) THEN
10212 ALSDUM=PYALPS(FQ2C*Q2B)
10213 TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117))
10214 ALAM(JT)=PARU(117)
10215 B0=(33D0-2D0*MSTU(118))/6D0
10216 ENDIF
10217 TEVCBS=TEVCB
10218 TEVEBS=TEVEB
10219
10220C...Select side for interference with final state partons.
10221 IF(MFIS.GE.1.AND.N.LE.NS+2) THEN
10222 IFI=N-NS
10223 ISFI(IFI)=0
10224 IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN
10225 ISFI(IFI)=1
10226 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN
10227 IF(PYR(0).GT.0.5D0) ISFI(IFI)=1
10228 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN
10229 ISFI(IFI)=1
10230 IF(PYR(0).GT.0.5D0) ISFI(IFI)=2
10231 ENDIF
10232 ENDIF
10233
10234C...Calculate Altarelli-Parisi weights.
10235 DO 170 KFL=-25,25
10236 WTAPC(KFL)=0D0
10237 WTAPE(KFL)=0D0
10238 WTSF(KFL)=0D0
10239 170 CONTINUE
10240C...q -> q, g -> q.
10241 IF(IABS(KFLB).LE.10) THEN
10242 WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC)))
10243 WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC))
10244 IF(MECOR.EQ.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2))
10245 & WTAPC(21)=3D0*WTAPC(21)
10246C...f -> f, gamma -> f.
10247 ELSEIF(IABS(KFLB).LE.20) THEN
10248 WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE)))
10249 WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))
10250 WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2)
10251 IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE)
10252 IF(MECOR.EQ.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2))
10253 & WTAPE(22)=3D0*WTAPE(22)
10254C...f -> g, g -> g.
10255 ELSEIF(KFLB.EQ.21) THEN
10256 WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB))
10257 DO 180 KFL=1,MSTP(58)
10258 WTAPC(KFL)=WTAPQ
10259 WTAPC(-KFL)=WTAPQ
10260 180 CONTINUE
10261 WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC)
10262C...f -> gamma, W+, W-.
10263 ELSEIF(KFLB.EQ.22) THEN
10264 WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB
10265 WTAPE(11)=WTAPF
10266 WTAPE(-11)=WTAPF
10267 ELSEIF(KFLB.EQ.24) THEN
10268 WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
10269 & (XEE*(XB+XEE)))/XB
10270 ELSEIF(KFLB.EQ.-24) THEN
10271 WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
10272 & (XEE*(XB+XEE)))/XB
10273 ENDIF
10274
10275C...Calculate parton distribution weights and sum.
10276 NTRY=0
10277 190 NTRY=NTRY+1
10278 IF(NTRY.GT.500) THEN
10279 MINT(51)=1
10280 RETURN
10281 ENDIF
10282 WTSUMC=0D0
10283 WTSUME=0D0
10284 XFBO=MAX(1D-10,XFB(KFLB))
10285 DO 200 KFL=-25,25
10286 WTSF(KFL)=XFB(KFL)/XFBO
10287 WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL)
10288 WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL)
10289 200 CONTINUE
10290 WTSUMC=MAX(0.0001D0,WTSUMC)
10291 WTSUME=MAX(0.0001D0/FWTE,WTSUME)
10292
10293C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
10294 NTRY2=0
10295 210 NTRY2=NTRY2+1
10296 IF(NTRY2.GT.500) THEN
10297 MINT(51)=1
10298 RETURN
10299 ENDIF
10300 IF(MCEV.EQ.1) THEN
10301 IF(MSTP(64).LE.0) THEN
10302 TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC)
10303 ELSEIF(MSTP(64).EQ.1) THEN
10304 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC))
10305 ELSE
10306 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC)))
10307 ENDIF
10308 ENDIF
10309 IF(MEEV.EQ.1) THEN
10310 TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
10311 & (PARU(101)*FWTE*WTSUME*TEMX)))
10312 ENDIF
10313
10314C...Translate t into Q2 scale; choose between QCD and QED evolution.
10315 220 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C
10316 IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
10317C...Ensure that Q2 is above threshold for charm/bottom.
10318 KFLCB=IABS(KFLB)
10319 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
10320 &MCEV.EQ.1) THEN
10321 IF(Q2CB.LT.PMAS(KFLCB,1)**2) THEN
10322 Q2CB=1.1*PMAS(KFLCB,1)**2
10323 TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
10324 FCQ2MX=MIN(2D0,1.05D0*FCQ2MX)
10325 ENDIF
10326 ENDIF
10327 MCE=0
10328 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
10329 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN
10330 IF(Q2CB.GT.Q2MNCS(JT)) MCE=1
10331 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN
10332 IF(Q2EB.GT.Q2MNE) MCE=2
10333 ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN
10334 MCE=1
10335 IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2
10336 IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0
10337 ELSE
10338 MCE=2
10339 IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1
10340 IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0
10341 ENDIF
10342
10343C...Evolution possibly ended. Update t values.
10344 IF(MCE.EQ.0) THEN
10345 Q2B=0D0
10346 GOTO 250
10347 ELSEIF(MCE.EQ.1) THEN
10348 Q2B=Q2CB
10349 Q2REF=FQ2C*Q2B
10350 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
10351 ELSE
10352 Q2B=Q2EB
10353 Q2REF=Q2B
10354 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
10355 ENDIF
10356
10357C...Select flavour for branching parton.
10358 IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC
10359 IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME
10360 KFLA=-25
10361 230 KFLA=KFLA+1
10362 IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA)
10363 IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA)
10364 IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 230
10365 IF(KFLA.EQ.25) THEN
10366 Q2B=0D0
10367 GOTO 250
10368 ENDIF
10369
10370C...Choose z value and corrective weight.
10371 WTZ=0D0
10372C...q -> q + g.
10373 IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN
10374 Z=1D0-((1D0-XB-XEC)/(1D0-XEC))*
10375 & (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0)
10376 WTZ=0.5D0*(1D0+Z**2)
10377C...q -> g + q.
10378 ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN
10379 Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2
10380 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
10381C...f -> f + gamma.
10382 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
10383 IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN
10384 Z=1D0-((1D0-XB-XEE)/(1D0-XEE))*
10385 & (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0)
10386 ELSE
10387 Z=XB+XB*(XEE/(1D0-XEE))*
10388 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
10389 ENDIF
10390 WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB)
10391C...f -> gamma + f.
10392 ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) THEN
10393 Z=XB+XB*(XEE/(1D0-XEE))*
10394 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
10395 WTZ=0.5D0*(1D0+(1D0-Z)**2)*XB*(Z-XB)/Z
10396C...f -> W+- + f'.
10397 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) THEN
10398 Z=XB+XB*(XEE/(1D0-XEE))*
10399 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
10400 WTZ=0.5D0*(1D0+(1D0-Z)**2)*(XB*(Z-XB)/Z)*
10401 & (Q2B/(Q2B+PMAS(24,1)**2))
10402C...g -> q + qbar.
10403 ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN
10404 Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC))
10405 WTZ=1D0-2D0*Z*(1D0-Z)
10406C...g -> g + g.
10407 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
10408 Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0))
10409 WTZ=(1D0-Z*(1D0-Z))**2
10410C...gamma -> f + fbar.
10411 ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN
10412 Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE))
10413 WTZ=1D0-2D0*Z*(1D0-Z)
10414 ENDIF
10415 IF(MCE.EQ.2) WTZ=(WTZ/FWTE)*(TEVEB/TEMX)
10416
10417C...Option with resummation of soft gluon emission as effective z shift.
10418 IF(MCE.EQ.1) THEN
10419 IF(MSTP(65).GE.1) THEN
10420 RSOFT=6D0
10421 IF(KFLB.NE.21) RSOFT=8D0/3D0
10422 Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0))
10423 IF(Z.LE.XB) GOTO 210
10424 ENDIF
10425
10426C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
10427 IF(MSTP(64).GE.2) THEN
10428 IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 210
10429 ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z))
10430 IF(ALPRAT.LT.5D0*PYR(0)) GOTO 210
10431 IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0
10432 ENDIF
10433 ENDIF
10434
10435C...Remove kinematically impossible branchings.
10436 UHAT=Q2B-DSH*(1D0-Z)/Z
10437 IF(MSTP(68).GE.0.AND.UHAT.GT.0D0) GOTO 210
10438
10439C...Matrix-element corrections for s-channel resonance production.
10440 IF(MECOR.EQ.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
10441 SHAT=DSH/Z
10442 THAT=-Q2B
10443 IF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
10444 RMEPS=(THAT**2+UHAT**2+2D0*DSH*SHAT)/(SHAT**2+DSH**2)
10445 WTZ=WTZ*RMEPS
10446 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.IABS(KFLB).LE.20) THEN
10447 RMEPS=(SHAT**2+UHAT**2+2D0*DSH*THAT)/((SHAT-DSH)**2+DSH**2)
10448 WTZ=WTZ*RMEPS/3D0
10449 ENDIF
10450 ENDIF
10451
10452C...Impose angular constraint in first branching from interference
10453C...with final state partons.
10454 IF(MCE.EQ.1) THEN
10455 IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN
10456 THE2D=(4D0*Q2B)/(DSH*(1D0-Z))
10457 IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN
10458 IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 210
10459 ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN
10460 IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 210
10461 ENDIF
10462 ENDIF
10463
10464C...Option with angular ordering requirement.
10465 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN
10466 THE2T=(4D0*Z**2*Q2B)/(4D0*Z**2*Q2B+(1D0-Z)*XB**2*VINT(2))
10467 IF(THE2T.GT.THE2(JT)) GOTO 210
10468 ENDIF
10469 ENDIF
10470
10471C...Weighting with new parton distributions.
10472 MINT(105)=MINT(102+JT)
10473 MINT(109)=MINT(106+JT)
10474 VINT(120)=VINT(2+JT)
fd658fdb 10475C.... ALICE
10476C.... Store side in MINT(124)
10477 MINT(124)=JT
10478C....
10479C.... ALICE
10480C.... Store side in MINT(124)
10481 MINT(124)=JT
10482C....
952cc209 10483 IF(MSTP(57).LE.1) THEN
10484 CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN)
10485 ELSE
10486 CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN)
10487 ENDIF
10488 XFBN=XFN(KFLB)
10489 IF(XFBN.LT.1D-20) THEN
10490 IF(KFLA.EQ.KFLB) THEN
10491 TEVCB=TEVCBS
10492 TEVEB=TEVEBS
10493 WTAPC(KFLB)=0D0
10494 WTAPE(KFLB)=0D0
10495 GOTO 190
10496 ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN
10497 TEVCB=0.5D0*(TEVCBS+TEVCB)
10498 GOTO 220
10499 ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN
10500 TEVEB=0.5D0*(TEVEBS+TEVEB)
10501 GOTO 220
10502 ELSE
10503 XFBN=1D-10
10504 XFN(KFLB)=XFBN
10505 ENDIF
10506 ENDIF
10507 DO 240 KFL=-25,25
10508 XFB(KFL)=XFN(KFL)
10509 240 CONTINUE
10510 XA=XB/Z
fd658fdb 10511C.... ALICE
10512C.... Store side in MINT(124)
10513 MINT(124) = JT
10514C....
952cc209 10515 IF(MSTP(57).LE.1) THEN
10516 CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA)
10517 ELSE
10518 CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA)
10519 ENDIF
10520 XFAN=XFA(KFLA)
10521 IF(XFAN.LT.1D-20) GOTO 190
10522 WTSFA=WTSF(KFLA)
10523 IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 190
10524
10525C...Define two hard scatterers in their CM-frame.
10526 250 IF(N.EQ.NS+2) THEN
10527 DQ2(JT)=Q2B
10528 DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
10529 DO 270 JR=1,2
10530 I=NS+JR
10531 IF(JR.EQ.1) IPO=IPUS1
10532 IF(JR.EQ.2) IPO=IPUS2
10533 DO 260 J=1,5
10534 K(I,J)=0
10535 P(I,J)=0D0
10536 V(I,J)=0D0
10537 260 CONTINUE
10538 K(I,1)=14
10539 K(I,2)=KFLS(JR+2)
10540 K(I,4)=IPO
10541 K(I,5)=IPO
10542 P(I,3)=DPLCM*(-1)**(JR+1)
10543 P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
10544 P(I,5)=-SQRT(DQ2(JR))
10545 K(IPO,1)=14
10546 K(IPO,3)=I
10547 K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
10548 K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
10549 270 CONTINUE
10550
10551C...Find maximum allowed mass of timelike parton.
10552 ELSEIF(N.GT.NS+2) THEN
10553 JR=3-JT
10554 DQ2(3)=Q2B
10555 DPC(1)=P(IS(1),4)
10556 DPC(2)=P(IS(2),4)
10557 DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
10558 DPD(1)=DSH+DQ2(JR)+DQ2(JT)
10559 DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
10560 DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
10561 DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
10562 IKIN=0
10563 IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE.
10564 & 1D-10*DPD(1)) IKIN=1
10565 IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))*
10566 & (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
10567 IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/
10568 & (2D0*DQ2(JR))-DQ2(JT)-DQ2(3)
10569
10570C...Generate timelike parton shower (if required).
10571 IT=N
10572 DO 280 J=1,5
10573 K(IT,J)=0
10574 P(IT,J)=0D0
10575 V(IT,J)=0D0
10576 280 CONTINUE
10577C...f -> f + g (gamma).
10578 IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN
10579 K(IT,2)=21
10580 IF(IABS(KFLB).GE.11) K(IT,2)=22
10581C...f -> g (gamma, W+-) + f.
10582 ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN
10583 K(IT,2)=KFLB
10584 IF(KFLS(JT+2).EQ.24) THEN
10585 K(IT,2)=-12
10586 ELSEIF(KFLS(JT+2).EQ.-24) THEN
10587 K(IT,2)=12
10588 ENDIF
10589C...g (gamma) -> f + fbar, g + g.
10590 ELSE
10591 K(IT,2)=-KFLS(JT+2)
10592 IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2)
10593 ENDIF
10594 K(IT,1)=3
10595 IF((IABS(K(IT,2)).GE.11.AND.IABS(K(IT,2)).LE.18).OR.
10596 & IABS(K(IT,2)).EQ.22) K(IT,1)=1
10597 P(IT,5)=PYMASS(K(IT,2))
10598 IF(DMSMA.LE.P(IT,5)**2) GOTO 100
10599 IF(MSTP(63).GE.1.AND.MCE.EQ.1) THEN
10600 MSTJ48=MSTJ(48)
10601 PARJ85=PARJ(85)
10602 P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
10603 P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
10604 IF(MSTP(63).EQ.1) THEN
10605 Q2TIM=DMSMA
10606 ELSEIF(MSTP(63).EQ.2) THEN
10607 Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT))
10608 ELSE
10609 Q2TIM=DMSMA
10610 MSTJ(48)=1
10611 IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
10612 IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)*
10613 & DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2)
10614 PARJ(85)=SQRT(MAX(0D0,DPT2))*
10615 & (1D0/P(IT,4)+1D0/P(IS(JT),4))
10616 ENDIF
10617 CALL PYSHOW(IT,0,SQRT(Q2TIM))
10618 MSTJ(48)=MSTJ48
10619 PARJ(85)=PARJ85
10620 IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
10621 ENDIF
10622
10623C...Reconstruct kinematics of branching: timelike parton shower.
10624 DMS=P(IT,5)**2
10625 IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
10626 IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+
10627 & 0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/
10628 & (4D0*DSH*DPC(3)**2)
10629 IF(DPT2.LT.0D0) GOTO 100
10630 DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
10631 & DSHR)/DPC(3)-DPC(3)
10632 P(IT,1)=SQRT(DPT2)
10633 P(IT,3)=DPB(1)*(-1)**(JT+1)
10634 P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS)
10635 IF(N.GE.IT+1) THEN
10636 DPB(1)=SQRT(DPB(1)**2+DPT2)
10637 DPB(2)=SQRT(DPB(1)**2+DMS)
10638 DPB(3)=P(IT+1,3)
10639 DPB(4)=SQRT(DPB(3)**2+DMS)
10640 DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
10641 & DPB(1))
10642 CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ)
10643 THE=PYANGL(P(IT,3),P(IT,1))
10644 CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0)
10645 ENDIF
10646
10647C...Reconstruct kinematics of branching: spacelike parton.
10648 DO 290 J=1,5
10649 K(N+1,J)=0
10650 P(N+1,J)=0D0
10651 V(N+1,J)=0D0
10652 290 CONTINUE
10653 K(N+1,1)=14
10654 K(N+1,2)=KFLB
10655 P(N+1,1)=P(IT,1)
10656 P(N+1,3)=P(IT,3)+P(IS(JT),3)
10657 P(N+1,4)=P(IT,4)+P(IS(JT),4)
10658 P(N+1,5)=-SQRT(DQ2(3))
10659
10660C...Define colour flow of branching.
10661 K(IS(JT),3)=N+1
10662 K(IT,3)=N+1
10663 IM1=N+1
10664 IM2=N+1
10665C...f -> f + gamma (Z, W).
10666 IF(IABS(K(IT,2)).GE.22) THEN
10667 K(IT,1)=1
10668 ID1=IS(JT)
10669 ID2=IS(JT)
10670C...f -> gamma (Z, W) + f.
10671 ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN
10672 ID1=IT
10673 ID2=IT
10674C...gamma -> q + qbar, g + g.
10675 ELSEIF(K(N+1,2).EQ.22) THEN
10676 ID1=IS(JT)
10677 ID2=IT
10678 IM1=ID2
10679 IM2=ID1
10680C...q -> q + g.
10681 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN
10682 ID1=IT
10683 ID2=IS(JT)
10684C...q -> g + q.
10685 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN
10686 ID1=IS(JT)
10687 ID2=IT
10688C...qbar -> qbar + g.
10689 ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN
10690 ID1=IS(JT)
10691 ID2=IT
10692C...qbar -> g + qbar.
10693 ELSEIF(K(N+1,2).LT.0) THEN
10694 ID1=IT
10695 ID2=IS(JT)
10696C...g -> g + g; g -> q + qbar.
10697 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
10698 ID1=IS(JT)
10699 ID2=IT
10700 ELSE
10701 ID1=IT
10702 ID2=IS(JT)
10703 ENDIF
10704 IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1
10705 IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2
10706 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
10707 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
10708 IF(ID1.NE.ID2) THEN
10709 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
10710 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
10711 ENDIF
10712 N=N+1
10713
10714C...Boost to new CM-frame.
10715 DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4))
10716 DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4))
10717 IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100
10718 CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ)
10719 IR=N+(JT-1)*(IS(1)-N)
10720 CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),PARU(2)*PYR(0),
10721 & 0D0,0D0,0D0)
10722 ENDIF
10723
10724C...Update kinematics variables.
10725 IS(JT)=N
10726 DQ2(JT)=Q2B
10727 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THE2(JT)=THE2T
10728 DSH=DSHZ
10729
10730C...Save quantities; loop back.
10731 Q2S(JT)=Q2B
10732 IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR.
10733 &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN
10734 KFLS(JT+2)=KFLS(JT)
10735 KFLS(JT)=KFLA
10736 XS(JT)=XA
10737 ZS(JT)=Z
10738 DO 300 KFL=-25,25
10739 XFS(JT,KFL)=XFA(KFL)
10740 300 CONTINUE
10741 TEVCSV(JT)=TEVCB
10742 TEVESV(JT)=TEVEB
10743 ELSE
10744 MORE(JT)=0
10745 IF(JT.EQ.1) IPU1=N
10746 IF(JT.EQ.2) IPU2=N
10747 ENDIF
10748 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
10749 CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS')
10750 IF(MSTU(21).GE.1) N=NS
10751 IF(MSTU(21).GE.1) RETURN
10752 ENDIF
10753 IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150
10754
10755C...Boost hard scattering partons to frame of shower initiators.
10756 DO 310 J=1,3
10757 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
10758 310 CONTINUE
10759 K(N+2,1)=1
10760 DO 320 J=1,5
10761 P(N+2,J)=P(NS+1,J)
10762 320 CONTINUE
10763 CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5))
10764 ROBO(2)=PYANGL(P(N+2,1),P(N+2,2))
10765 ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
10766 CALL PYROBO(MINT(83)+5,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),
10767 &ROBO(5))
10768
10769C...Store user information. Reset Lambda value.
10770 K(IPU1,3)=MINT(83)+3
10771 K(IPU2,3)=MINT(83)+4
10772 DO 330 JT=1,2
10773 MINT(12+JT)=KFLS(JT)
10774 VINT(140+JT)=XS(JT)
10775 IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT)
10776 330 CONTINUE
10777 PARU(112)=ALAMS
10778
10779 RETURN
10780 END
10781
10782C*********************************************************************
10783
10784C...PYRESD
10785C...Allows resonances to decay (including parton showers for hadronic
10786C...channels).
10787
10788 SUBROUTINE PYRESD(IRES)
10789
10790C...Double precision and integer declarations.
10791 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
10792 IMPLICIT INTEGER(I-N)
10793 INTEGER PYK,PYCHGE,PYCOMP
10794C...Parameter statement to help give large particle numbers.
10795 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
10796C...Commonblocks.
10797 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
10798 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10799 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
10800 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
10801 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
10802 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
10803 COMMON/PYINT1/MINT(400),VINT(400)
10804 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
10805 COMMON/PYINT4/MWID(500),WIDS(500,5)
10806 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
10807 &/PYINT1/,/PYINT2/,/PYINT4/
10808C...Local arrays and complex and character variables.
10809 DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
10810 &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(3),ILIN(6),
10811 &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3),
10812 &PHI(3),WDTP(0:200),WDTE(0:200,0:5),DBEZQQ(3),DPMO(5),XM(5),
10813 &VDCY(4)
10814 COMPLEX FGK,HA(6,6),HC(6,6)
10815 REAL TIR,UIR
10816 CHARACTER CODE*9,MASS*9
10817
10818C...The F, Xi and Xj functions of Gunion and Kunszt
10819C...(Phys. Rev. D33, 665, plus errata from the authors).
10820 FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
10821 &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
10822 DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/
10823 &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34))
10824 DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU-
10825 &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+
10826 &2D0*(D34/D56+D56/D34))
10827
10828C...Some general constants.
10829 XW=PARU(102)
10830 XWV=XW
10831 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
10832 XW1=1D0-XW
10833 SQMZ=PMAS(23,1)**2
10834 GMMZ=PMAS(23,1)*PMAS(23,2)
10835 SQMW=PMAS(24,1)**2
10836 GMMW=PMAS(24,1)*PMAS(24,2)
10837 SH=VINT(44)
10838
10839C...Reset original resonance configuration.
10840 DO 100 JT=1,8
10841 IREF(1,JT)=0
10842 100 CONTINUE
10843
10844C...Define initial one, two or three objects for subprocess.
10845 IF(IRES.EQ.0) THEN
10846 ISUB=MINT(1)
10847 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
10848 IREF(1,1)=MINT(84)+2+ISET(ISUB)
10849 IREF(1,4)=MINT(83)+6+ISET(ISUB)
10850 JTMAX=1
10851 ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
10852 IREF(1,1)=MINT(84)+1+ISET(ISUB)
10853 IREF(1,2)=MINT(84)+2+ISET(ISUB)
10854 IREF(1,4)=MINT(83)+5+ISET(ISUB)
10855 IREF(1,5)=MINT(83)+6+ISET(ISUB)
10856 JTMAX=2
10857 ELSEIF(ISET(ISUB).EQ.5) THEN
10858 IREF(1,1)=MINT(84)+3
10859 IREF(1,2)=MINT(84)+4
10860 IREF(1,3)=MINT(84)+5
10861 IREF(1,4)=MINT(83)+7
10862 IREF(1,5)=MINT(83)+8
10863 IREF(1,6)=MINT(83)+9
10864 JTMAX=3
10865 ENDIF
10866
10867C...Define original resonance for odd cases.
10868 ELSE
10869 ISUB=0
10870 IREF(1,1)=IRES
10871 JTMAX=1
10872 ENDIF
10873
10874C...Check if initial resonance has been moved (in resonance + jet).
10875 DO 120 JT=1,3
10876 IF(IREF(1,JT).GT.0) THEN
10877 IF(K(IREF(1,JT),1).GT.10) THEN
10878 KFA=IABS(K(IREF(1,JT),2))
10879 IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN
10880 DO 110 I=IREF(1,JT)+1,N
10881 IF(K(I,1).LE.10.AND.K(I,2).EQ.K(IREF(1,JT),2))
10882 & IREF(1,JT)=I
10883 110 CONTINUE
10884 ELSE
10885 KDA=MOD(K(IREF(1,JT),4),MSTU(4))
10886 IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA
10887 ENDIF
10888 ENDIF
10889 ENDIF
10890 120 CONTINUE
10891
10892C.....Set decay vertex for initial resonances
10893 DO 140 JT=1,JTMAX
10894 DO 130 I=1,4
10895 V(IREF(1,JT),I)=0D0
10896 130 CONTINUE
10897 140 CONTINUE
10898
10899C...Loop over decay history.
10900 NP=1
10901 IP=0
10902 150 IP=IP+1
10903 NINH=0
10904 JTMAX=2
10905 IF(IREF(IP,2).EQ.0) JTMAX=1
10906 IF(IREF(IP,3).NE.0) JTMAX=3
10907 IT4=0
10908 NSAV=N
10909
10910C...Start treatment of one, two or three resonances in parallel.
10911 160 N=NSAV
10912 DO 250 JT=1,JTMAX
10913 ID=IREF(IP,JT)
10914 KDCY(JT)=0
10915 KFL1(JT)=0
10916 KFL2(JT)=0
10917 KFL3(JT)=0
10918 KEQL(JT)=0
10919 NSD(JT)=ID
10920
10921C...Check whether particle can/is allowed to decay.
10922 IF(ID.EQ.0) GOTO 240
10923 KFA=IABS(K(ID,2))
10924 KCA=PYCOMP(KFA)
10925 IF(MWID(KCA).EQ.0) GOTO 240
10926 IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 240
10927 IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR.
10928 & KFA.EQ.18) IT4=IT4+1
10929 K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5))
10930 K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5))
10931
10932C...Choose lifetime and determine decay vertex.
10933 IF(K(ID,1).EQ.5) THEN
10934 V(ID,5)=0D0
10935 ELSEIF(K(ID,1).NE.4) THEN
10936 V(ID,5)=-PMAS(KCA,4)*LOG(PYR(0))
10937 ENDIF
10938 DO 170 J=1,4
10939 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
10940 170 CONTINUE
10941
10942C...Determine whether decay allowed or not.
10943 MOUT=0
10944 IF(MSTJ(22).EQ.2) THEN
10945 IF(PMAS(KCA,4).GT.PARJ(71)) MOUT=1
10946 ELSEIF(MSTJ(22).EQ.3) THEN
10947 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
10948 ELSEIF(MSTJ(22).EQ.4) THEN
10949 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
10950 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
10951 ENDIF
10952 IF(MOUT.EQ.1.AND.K(ID,1).NE.5) THEN
10953 K(ID,1)=4
10954 GOTO 240
10955 ENDIF
10956
10957C...Info for selection of decay channel: sign, pairings.
10958 IF(KCHG(KCA,3).EQ.0) THEN
10959 IPM=2
10960 ELSE
10961 IPM=(5-ISIGN(1,K(ID,2)))/2
10962 ENDIF
10963 KFB=0
10964 IF(JTMAX.EQ.2) THEN
10965 KFB=IABS(K(IREF(IP,3-JT),2))
10966 ELSEIF(JTMAX.EQ.3) THEN
10967 JT2=JT+1-3*(JT/3)
10968 KFB=IABS(K(IREF(IP,JT2),2))
10969 IF(KFB.NE.KFA) THEN
10970 JT2=JT+2-3*((JT+1)/3)
10971 KFB=IABS(K(IREF(IP,JT2),2))
10972 ENDIF
10973 ENDIF
10974
10975C...Select decay channel.
10976 IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.
10977 & ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1
10978 CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE)
10979 WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4)
10980 IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5)
10981 IF(WDTE0S.LE.0D0) GOTO 240
10982 RKFL=WDTE0S*PYR(0)
10983 IDL=0
10984 180 IDL=IDL+1
10985 IDC=IDL+MDCY(KCA,2)-1
10986 RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4))
10987 IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5)
10988 IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 180
10989
10990C...Read out flavours and colour charges of decay channel chosen.
10991 KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2))
10992 IF(KCQM(JT).EQ.-2) KCQM(JT)=2
10993 KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
10994 KFC1A=PYCOMP(IABS(KFL1(JT)))
10995 IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT))
10996 KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT))
10997 IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2
10998 KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
10999 KFC2A=PYCOMP(IABS(KFL2(JT)))
11000 IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT))
11001 KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT))
11002 IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2
11003 KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2))
11004 IF(KFL3(JT).NE.0) THEN
11005 KFC3A=PYCOMP(IABS(KFL3(JT)))
11006 IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT))
11007 KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT))
11008 IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2
11009 ENDIF
11010
11011C...Set/save further info on channel.
11012 KDCY(JT)=1
11013 IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1)
11014 NSD(JT)=N
11015 HGZ(JT,1)=VINT(111)
11016 HGZ(JT,2)=VINT(112)
11017 HGZ(JT,3)=VINT(114)
11018 JTZ=JT
11019
11020C...Select masses; to begin with assume resonances narrow.
11021 DO 200 I=1,3
11022 P(N+I,5)=0D0
11023 PMMN(I)=0D0
11024 IF(I.EQ.1) THEN
11025 KFLW=IABS(KFL1(JT))
11026 KCW=KFC1A
11027 ELSEIF(I.EQ.2) THEN
11028 KFLW=IABS(KFL2(JT))
11029 KCW=KFC2A
11030 ELSEIF(I.EQ.3) THEN
11031 IF(KFL3(JT).EQ.0) GOTO 200
11032 KFLW=IABS(KFL3(JT))
11033 KCW=KFC3A
11034 ENDIF
11035 P(N+I,5)=PMAS(KCW,1)
11036CMRENNA++
11037C...This prevents SUSY/t particles from becoming too light.
11038 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
11039 PMMN(I)=PMAS(KCW,1)
11040 DO 190 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
11041 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
11042 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
11043 & PMAS(PYCOMP(KFDP(IDC,2)),1)
11044 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
11045 & PMAS(PYCOMP(KFDP(IDC,3)),1)
11046 PMMN(I)=MIN(PMMN(I),PMSUM)
11047 ENDIF
11048 190 CONTINUE
11049CMRENNA--
11050 ELSEIF(KFLW.EQ.6) THEN
11051 PMMN(I)=PMAS(24,1)+PMAS(5,1)
11052 ENDIF
11053 200 CONTINUE
11054
11055C...Check which two out of three are widest.
11056 IWID1=1
11057 IWID2=2
11058 PWID1=PMAS(KFC1A,2)
11059 PWID2=PMAS(KFC2A,2)
11060 KFLW1=IABS(KFL1(JT))
11061 KFLW2=IABS(KFL2(JT))
11062 IF(KFL3(JT).NE.0) THEN
11063 PWID3=PMAS(KFC3A,2)
11064 IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN
11065 IWID1=3
11066 PWID1=PWID3
11067 KFLW1=IABS(KFL3(JT))
11068 ELSEIF(PWID3.GT.PWID2) THEN
11069 IWID2=3
11070 PWID2=PWID3
11071 KFLW2=IABS(KFL3(JT))
11072 ENDIF
11073 ENDIF
11074
11075C...If all narrow then only check that masses consistent.
11076 IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND.
11077 & PWID2.LT.PARP(41))) THEN
11078CMRENNA++
11079C....Handle near degeneracy cases.
11080 IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN
11081 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
11082 P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0
11083 IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0
11084 ENDIF
11085 ENDIF
11086CMRENNA--
11087 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
11088 CALL PYERRM(13,'(PYRESD:) daughter masses too large')
11089 MINT(51)=1
11090 RETURN
11091 ELSEIF(P(N+1,5)+P(N+2,5)+P(N+3,5)+PARJ(64).GT.P(ID,5)) THEN
11092 CALL PYERRM(3,'(PYRESD:) daughter masses too large')
11093 MINT(51)=1
11094 RETURN
11095 ENDIF
11096
11097C...For three wide resonances select narrower of three
11098C...according to BW decoupled from rest.
11099 ELSE
11100 PMTOT=P(ID,5)
11101 IF(KFL3(JT).NE.0) THEN
11102 IWID3=6-IWID1-IWID2
11103 KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))-
11104 & KFLW1-KFLW2
11105 LOOP=0
11106 210 LOOP=LOOP+1
11107 P(N+IWID3,5)=PYMASS(KFLW3)
11108 IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 210
11109 PMTOT=PMTOT-P(N+IWID3,5)
11110 ENDIF
11111C...Select other two correlated within remaining phase space.
11112 IF(IP.EQ.1) THEN
11113 CKIN45=CKIN(45)
11114 CKIN47=CKIN(47)
11115 CKIN(45)=MAX(PMMN(IWID1),CKIN(45))
11116 CKIN(47)=MAX(PMMN(IWID2),CKIN(47))
11117 CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
11118 & P(N+IWID2,5))
11119 CKIN(45)=CKIN45
11120 CKIN(47)=CKIN47
11121 ELSE
11122 CKIN(49)=PMMN(IWID1)
11123 CKIN(50)=PMMN(IWID2)
11124 CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
11125 & P(N+IWID2,5))
11126 CKIN(49)=0D0
11127 CKIN(50)=0D0
11128 ENDIF
11129 IF(MINT(51).EQ.1) RETURN
11130 ENDIF
11131
11132C...Begin fill decay products, with colour flow for coloured objects.
11133 MSTU10=MSTU(10)
11134 MSTU(10)=1
11135 MSTU(19)=1
11136
11137CMRENNA++
11138C...1) Three-body decays of SUSY particles (plus special case top).
11139 IF(KFL3(JT).NE.0) THEN
11140 DO 230 I=N+1,N+3
11141 DO 220 J=1,5
11142 K(I,J)=0
11143C V(I,J)=0D0
11144 220 CONTINUE
11145 230 CONTINUE
11146 XM(1)=P(N+1,5)
11147 XM(2)=P(N+2,5)
11148 XM(3)=P(N+3,5)
11149 XM(5)=P(ID,5)
11150 CALL PYTBDY(XM)
11151 K(N+1,1)=1
11152 K(N+1,2)=KFL1(JT)
11153 K(N+2,1)=1
11154 K(N+2,2)=KFL2(JT)
11155 K(N+3,1)=1
11156 K(N+3,2)=KFL3(JT)
11157
11158C...Set colour flow for t -> W + b + Z.
11159 IF(KFA.EQ.6) THEN
11160 K(N+2,1)=3
11161 ISID=4
11162 IF(KCQM(JT).EQ.-1) ISID=5
11163 IDAU=N+2
11164 K(ID,ISID)=K(ID,ISID)+IDAU
11165 K(IDAU,ISID)=MSTU(5)*ID
11166
11167C...Set colour flow in three-body decays - programmed as special cases.
11168 ELSEIF(KFC2A.LE.6) THEN
11169 K(N+2,1)=3
11170 K(N+3,1)=3
11171 ISID=4
11172 IF(KFL2(JT).LT.0) ISID=5
11173 K(N+2,ISID)=MSTU(5)*(N+3)
11174 K(N+3,9-ISID)=MSTU(5)*(N+2)
11175 ENDIF
11176 IF(KFL1(JT).EQ.KSUSY1+21) THEN
11177 K(N+1,1)=3
11178 K(N+2,1)=3
11179 K(N+3,1)=3
11180 ISID=4
11181 IF(KFL2(JT).LT.0) ISID=5
11182 K(N+1,ISID)=MSTU(5)*(N+2)
11183 K(N+1,9-ISID)=MSTU(5)*(N+3)
11184 K(N+2,ISID)=MSTU(5)*(N+1)
11185 K(N+3,9-ISID)=MSTU(5)*(N+1)
11186 ENDIF
11187 IF(KFA.EQ.KSUSY1+21) THEN
11188 K(N+2,1)=3
11189 K(N+3,1)=3
11190 ISID=4
11191 IF(KFL2(JT).LT.0) ISID=5
11192 K(ID,ISID)=K(ID,ISID)+(N+2)
11193 K(ID,9-ISID)=K(ID,9-ISID)+(N+3)
11194 K(N+2,ISID)=MSTU(5)*ID
11195 K(N+3,9-ISID)=MSTU(5)*ID
11196 ENDIF
11197 N=N+3
11198CMRENNA--
11199
11200C...2) Everything else two-body decay.
11201 ELSE
11202 CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
11203C...First set colour flow as if mother colour singlet.
11204 IF(KCQ1(JT).NE.0) THEN
11205 K(N-1,1)=3
11206 IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N
11207 IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N
11208 ENDIF
11209 IF(KCQ2(JT).NE.0) THEN
11210 K(N,1)=3
11211 IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1)
11212 IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1)
11213 ENDIF
11214C...Then redirect colour flow if mother (anti)triplet.
11215 IF(KCQM(JT).EQ.0) THEN
11216 ELSEIF(KCQM(JT).NE.2) THEN
11217 ISID=4
11218 IF(KCQM(JT).EQ.-1) ISID=5
11219 IDAU=N-1
11220 IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N
11221 K(ID,ISID)=K(ID,ISID)+IDAU
11222 K(IDAU,ISID)=MSTU(5)*ID
11223C...Then redirect colour flow if mother octet.
11224 ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN
11225 IDAU=N-1
11226 IF(KCQ1(JT).EQ.0) IDAU=N
11227 K(ID,4)=K(ID,4)+IDAU
11228 K(ID,5)=K(ID,5)+IDAU
11229 K(IDAU,4)=MSTU(5)*ID
11230 K(IDAU,5)=MSTU(5)*ID
11231 ELSE
11232 ISID=4
11233 IF(KCQ1(JT).EQ.-1) ISID=5
11234 IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0))
11235 K(ID,ISID)=K(ID,ISID)+(N-1)
11236 K(ID,9-ISID)=K(ID,9-ISID)+N
11237 K(N-1,ISID)=MSTU(5)*ID
11238 K(N,9-ISID)=MSTU(5)*ID
11239 ENDIF
11240 ENDIF
11241
11242C...End loop over resonances for daughter flavour and mass selection.
11243 MSTU(10)=MSTU10
11244 240 IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0))
11245 & NINH=NINH+1
11246 IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.KFL1(JT).EQ.0) THEN
11247 WRITE(CODE,'(I9)') K(ID,2)
11248 WRITE(MASS,'(F9.3)') P(ID,5)
11249 CALL PYERRM(3,'(PYRESD:) Failed to decay particle'//
11250 & CODE//' with mass'//MASS)
11251 MINT(51)=1
11252 RETURN
11253 ENDIF
11254 250 CONTINUE
11255
11256C...Check for allowed combinations. Skip if no decays.
11257 IF(JTMAX.EQ.1) THEN
11258 IF(KDCY(1).EQ.0) GOTO 620
11259 ELSEIF(JTMAX.EQ.2) THEN
11260 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 620
11261 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 160
11262 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 160
11263 ELSEIF(JTMAX.EQ.3) THEN
11264 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 620
11265 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 160
11266 IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 160
11267 IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 160
11268 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 160
11269 IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 160
11270 IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 160
11271 ENDIF
11272
11273C...Special case: matrix element option for Z0 decay to quarks.
11274 IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND.
11275 &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN
11276
11277C...Check consistency of MSTJ options set.
11278 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
11279 CALL PYERRM(6,
11280 & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
11281 MSTJ(110)=1
11282 ENDIF
11283 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
11284 CALL PYERRM(6,
11285 & '(PYRESD) MSTJ(109) value requires MSTJ(111) = 0')
11286 MSTJ(111)=0
11287 ENDIF
11288
11289C...Select alpha_strong behaviour.
11290 MST111=MSTU(111)
11291 PAR112=PARU(112)
11292 MSTU(111)=MSTJ(108)
11293 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
11294 & MSTU(111)=1
11295 PARU(112)=PARJ(121)
11296 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
11297
11298C...Find axial fraction in total cross section for scalar gluon model.
11299 PARJ(171)=0D0
11300 IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR.
11301 & (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN
11302 POLL=1D0-PARJ(131)*PARJ(132)
11303 SFF=1D0/(16D0*XW*XW1)
11304 SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+
11305 & (PARJ(123)*PARJ(124))**2)
11306 SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2)
11307 VE=4D0*XW-1D0
11308 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
11309 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*
11310 & (PARJ(132)-PARJ(131)))
11311 KFLC=IABS(KFL1(1))
11312 PMQ=PYMASS(KFLC)
11313 QF=KCHG(KFLC,1)/3D0
11314 VQ=1D0
11315 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,
11316 & 1D0-(2D0*PMQ/P(ID,5))**2))
11317 VF=SIGN(1D0,QF)-4D0*QF*XW
11318 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+
11319 & VF**2*HF1W)+VQ**3*HF1W
11320 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
11321 ENDIF
11322
11323C...Choice of jet configuration.
11324 CALL PYXJET(P(ID,5),NJET,CUT)
11325 KFLC=IABS(KFL1(1))
11326 KFLN=21
11327 IF(NJET.EQ.4) THEN
11328 CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14)
11329 ELSEIF(NJET.EQ.3) THEN
11330 CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3)
11331 ELSE
11332 MSTJ(120)=1
11333 ENDIF
11334
11335C...Fill jet configuration; return if incorrect kinematics.
11336 NC=N-2
11337 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN
11338 CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5))
11339 ELSEIF(NJET.EQ.2) THEN
11340 CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5))
11341 ELSEIF(NJET.EQ.3) THEN
11342 CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3)
11343 ELSEIF(KFLN.EQ.21) THEN
11344 CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
11345 & X12,X14)
11346 ELSE
11347 CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
11348 & X12,X14)
11349 ENDIF
11350 IF(MSTU(24).NE.0) THEN
11351 MINT(51)=1
11352 MSTU(111)=MST111
11353 PARU(112)=PAR112
11354 RETURN
11355 ENDIF
11356
11357C...Angular orientation according to matrix element.
11358 IF(MSTJ(106).EQ.1) THEN
11359 CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHIZ,THEZ,PHIZ)
11360 IF(MINT(11).LT.0) THEZ=PARU(1)-THEZ
11361 CTHE(1)=COS(THEZ)
11362 CALL PYROBO(NC+1,N,0D0,CHIZ,0D0,0D0,0D0)
11363 CALL PYROBO(NC+1,N,THEZ,PHIZ,0D0,0D0,0D0)
11364 ENDIF
11365
11366C...Boost partons to Z0 rest frame.
11367 CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4),
11368 & P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
11369
11370C...Mark decayed resonance and add documentation lines,
11371 K(ID,1)=K(ID,1)+10
11372 IDOC=MINT(83)+MINT(4)
11373 DO 270 I=NC+1,N
11374 I1=MINT(83)+MINT(4)+1
11375 K(I,3)=I1
11376 IF(MSTP(128).GE.1) K(I,3)=ID
11377 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
11378 MINT(4)=MINT(4)+1
11379 K(I1,1)=21
11380 K(I1,2)=K(I,2)
11381 K(I1,3)=IREF(IP,4)
11382 DO 260 J=1,5
11383 P(I1,J)=P(I,J)
11384 260 CONTINUE
11385 ENDIF
11386 270 CONTINUE
11387
11388C...Generate parton shower.
11389 IF(MSTJ(101).EQ.5) CALL PYSHOW(N-1,N,P(ID,5))
11390
11391C... End special case for Z0: skip ahead.
11392 MSTU(111)=MST111
11393 PARU(112)=PAR112
11394 GOTO 610
11395 ENDIF
11396
11397C...Order incoming partons and outgoing resonances.
11398 IF(JTMAX.EQ.2.AND.ISUB.NE.0.AND.MSTP(47).GE.1.AND.
11399 &NINH.EQ.0) THEN
11400 ILIN(1)=MINT(84)+1
11401 IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
11402 IF(K(ILIN(1),2).EQ.21.OR.K(ILIN(1),2).EQ.22)
11403 & ILIN(1)=2*MINT(84)+3-ILIN(1)
11404 ILIN(2)=2*MINT(84)+3-ILIN(1)
11405 IMIN=1
11406 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
11407 & .EQ.36) IMIN=3
11408 IMAX=2
11409 IORD=1
11410 IF(K(IREF(IP,1),2).EQ.23) IORD=2
11411 IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
11412 IAKIPD=IABS(K(IREF(IP,IORD),2))
11413 IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD
11414 IF(KDCY(IORD).EQ.0) IORD=3-IORD
11415
11416C...Order decay products of resonances.
11417 DO 280 JT=IORD,3-IORD,3-2*IORD
11418 IF(KDCY(JT).EQ.0) THEN
11419 ILIN(IMAX+1)=NSD(JT)
11420 IMAX=IMAX+1
11421 ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
11422 ILIN(IMAX+1)=N+2*JT-1
11423 ILIN(IMAX+2)=N+2*JT
11424 IMAX=IMAX+2
11425 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
11426 K(N+2*JT,2)=K(NSD(JT)+2,2)
11427 ELSE
11428 ILIN(IMAX+1)=N+2*JT
11429 ILIN(IMAX+2)=N+2*JT-1
11430 IMAX=IMAX+2
11431 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
11432 K(N+2*JT,2)=K(NSD(JT)+2,2)
11433 ENDIF
11434 280 CONTINUE
11435
11436C...Find charge, isospin, left- and righthanded couplings.
11437 DO 300 I=IMIN,IMAX
11438 DO 290 J=1,4
11439 COUP(I,J)=0D0
11440 290 CONTINUE
11441 KFA=IABS(K(ILIN(I),2))
11442 IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 300
11443 COUP(I,1)=KCHG(KFA,1)/3D0
11444 COUP(I,2)=(-1)**MOD(KFA,2)
11445 COUP(I,4)=-2D0*COUP(I,1)*XWV
11446 COUP(I,3)=COUP(I,2)+COUP(I,4)
11447 300 CONTINUE
11448
11449C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
11450 IF(ISUB.EQ.22) THEN
11451 DO 330 I=3,5,2
11452 I1=IORD
11453 IF(I.EQ.5) I1=3-IORD
11454 DO 320 J1=1,2
11455 DO 310 J2=1,2
11456 CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/
11457 & 16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)*
11458 & COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)*
11459 & COUP(I,J2+2)**2
11460 310 CONTINUE
11461 320 CONTINUE
11462 330 CONTINUE
11463 COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
11464 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2))
11465 COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))*
11466 & (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2))
11467 IF(COWT12.LT.PYR(0)*COMX12) GOTO 160
11468 ENDIF
11469 ENDIF
11470
11471C...Select angular orientation type - Z'/W' only.
11472 MZPWP=0
11473 IF(ISUB.EQ.141) THEN
11474 IF(PYR(0).LT.PARU(130)) MZPWP=1
11475 IF(IP.EQ.2) THEN
11476 IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2
11477 IAKIR=IABS(K(IREF(2,2),2))
11478 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
11479 IF(IAKIR.LE.20) MZPWP=2
11480 ENDIF
11481 IF(IP.GE.3) MZPWP=2
11482 ELSEIF(ISUB.EQ.142) THEN
11483 IF(PYR(0).LT.PARU(136)) MZPWP=1
11484 IF(IP.EQ.2) THEN
11485 IAKIR=IABS(K(IREF(2,2),2))
11486 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
11487 IF(IAKIR.LE.20) MZPWP=2
11488 ENDIF
11489 IF(IP.GE.3) MZPWP=2
11490 ENDIF
11491
11492C...Select random angles (begin of weighting procedure).
11493 340 DO 350 JT=1,JTMAX
11494 IF(KDCY(JT).EQ.0) GOTO 350
11495 IF(JTMAX.EQ.1.AND.ISUB.NE.0) THEN
11496 CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0)
11497 IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
11498 PHI(JT)=VINT(24)
11499 ELSE
11500 CTHE(JT)=2D0*PYR(0)-1D0
11501 PHI(JT)=PARU(2)*PYR(0)
11502 ENDIF
11503 350 CONTINUE
11504
11505 IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
11506C...Construct massless four-vectors.
11507 DO 370 I=N+1,N+4
11508 K(I,1)=1
11509 DO 360 J=1,5
11510 P(I,J)=0D0
11511C V(I,J)=0D0
11512 360 CONTINUE
11513 370 CONTINUE
11514 DO 380 JT=1,JTMAX
11515 IF(KDCY(JT).EQ.0) GOTO 380
11516 ID=IREF(IP,JT)
11517 P(N+2*JT-1,3)=0.5D0*P(ID,5)
11518 P(N+2*JT-1,4)=0.5D0*P(ID,5)
11519 P(N+2*JT,3)=-0.5D0*P(ID,5)
11520 P(N+2*JT,4)=0.5D0*P(ID,5)
11521 CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
11522 & P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
11523 380 CONTINUE
11524
11525C...Store incoming and outgoing momenta, with random rotation to
11526C...avoid accidental zeroes in HA expressions.
11527 IF(ISUB.NE.0) THEN
11528 DO 400 I=1,IMAX
11529 K(N+4+I,1)=1
11530 P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+
11531 & P(ILIN(I),3)**2+P(ILIN(I),5)**2)
11532 P(N+4+I,5)=P(ILIN(I),5)
11533 DO 390 J=1,3
11534 P(N+4+I,J)=P(ILIN(I),J)
11535 390 CONTINUE
11536 400 CONTINUE
11537 410 THERR=ACOS(2D0*PYR(0)-1D0)
11538 PHIRR=PARU(2)*PYR(0)
11539 CALL PYROBO(N+5,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
11540 DO 430 I=1,IMAX
11541 IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*P(N+4+I,4)**2)
11542 & GOTO 410
11543 DO 420 J=1,4
11544 PK(I,J)=P(N+4+I,J)
11545 420 CONTINUE
11546 430 CONTINUE
11547 ENDIF
11548
11549C...Calculate internal products.
11550 IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR.
11551 & ISUB.EQ.142) THEN
11552 DO 450 I1=IMIN,IMAX-1
11553 DO 440 I2=I1+1,IMAX
11554 HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+
11555 & PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))*
11556 & CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))-
11557 & SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
11558 & (1D-20+PK(I2,1)**2+PK(I2,2)**2)))*
11559 & CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2)))
11560 HC(I1,I2)=CONJG(HA(I1,I2))
11561 IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
11562 IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
11563 HA(I2,I1)=-HA(I1,I2)
11564 HC(I2,I1)=-HC(I1,I2)
11565 440 CONTINUE
11566 450 CONTINUE
11567 ENDIF
11568
11569C...Calculate four-products.
11570 IF(ISUB.NE.0) THEN
11571 DO 470 I=1,2
11572 DO 460 J=1,4
11573 PK(I,J)=-PK(I,J)
11574 460 CONTINUE
11575 470 CONTINUE
11576 DO 490 I1=IMIN,IMAX-1
11577 DO 480 I2=I1+1,IMAX
11578 PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
11579 & PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
11580 PKK(I2,I1)=PKK(I1,I2)
11581 480 CONTINUE
11582 490 CONTINUE
11583 ENDIF
11584 ENDIF
11585
11586 KFAGM=IABS(IREF(IP,7))
11587 IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN
11588C...Isotropic decay selected by user.
11589 WT=1D0
11590 WTMAX=1D0
11591
11592 ELSEIF(JTMAX.EQ.3) THEN
11593C...Isotropic decay when three mother particles.
11594 WT=1D0
11595 WTMAX=1D0
11596
11597 ELSEIF(IT4.GE.1) THEN
11598C... Isotropic decay t -> b + W etc for 4th generation q and l.
11599 WT=1D0
11600 WTMAX=1D0
11601
11602 ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.
11603 & IREF(IP,7).EQ.36) THEN
11604C...Angular weight for h0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
11605 IF(IP.EQ.1) WTMAX=SH**2
11606 IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4
11607 KFA=IABS(K(IREF(IP,1),2))
11608 IF(KFA.EQ.23) THEN
11609 KFLF1A=IABS(KFL1(1))
11610 EF1=KCHG(KFLF1A,1)/3D0
11611 AF1=SIGN(1D0,EF1+0.1D0)
11612 VF1=AF1-4D0*EF1*XWV
11613 KFLF2A=IABS(KFL1(2))
11614 EF2=KCHG(KFLF2A,1)/3D0
11615 AF2=SIGN(1D0,EF2+0.1D0)
11616 VF2=AF2-4D0*EF2*XWV
11617 VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)*(VF2**2+AF2**2))
11618 WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+
11619 & 8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5)
11620 ELSEIF(KFA.EQ.24) THEN
11621 WT=16D0*PKK(3,5)*PKK(4,6)
11622 ELSE
11623 WT=WTMAX
11624 ENDIF
11625
11626 ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR.
11627 & KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24)
11628 & THEN
11629C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
11630 I1=IREF(IP,8)
11631 IF(MOD(KFAGM,2).EQ.0) THEN
11632 I2=N+1
11633 I3=N+2
11634 ELSE
11635 I2=N+2
11636 I3=N+1
11637 ENDIF
11638 I4=IREF(IP,2)
11639 WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
11640 & P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)-
11641 & P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3))
11642 WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0
11643
11644 ELSEIF(ISUB.EQ.1) THEN
11645C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
11646 EI=KCHG(IABS(MINT(15)),1)/3D0
11647 AI=SIGN(1D0,EI+0.1D0)
11648 VI=AI-4D0*EI*XWV
11649 EF=KCHG(IABS(KFL1(1)),1)/3D0
11650 AF=SIGN(1D0,EF+0.1D0)
11651 VF=AF-4D0*EF*XWV
11652 RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH)
11653 WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
11654 & (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2)
11655 WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
11656 & (VI**2+AI**2)*VINT(114)*VF**2)
11657 WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+
11658 & 4D0*VI*AI*VINT(114)*VF*AF)
11659 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
11660 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
11661 WTMAX=2D0*(WT1+ABS(WT3))
11662
11663 ELSEIF(ISUB.EQ.2) THEN
11664C...Angular weight for W+/- -> 2 quarks/leptons.
11665 WT=(1D0+CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2
11666 WTMAX=4D0
11667
11668 ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
11669C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
11670C...-> gluon/gamma + 2 quarks/leptons.
11671 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
11672 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
11673 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
11674 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
11675 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
11676 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
11677 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
11678 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
11679 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
11680 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
11681 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
11682 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
11683 WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+
11684 & (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2)
11685 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
11686 & ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
11687
11688 ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
11689C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
11690C...-> gluon/gamma + 2 quarks/leptons.
11691 WT=PKK(1,3)**2+PKK(2,4)**2
11692 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
11693
11694 ELSEIF(ISUB.EQ.22) THEN
11695C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
11696 S34=P(IREF(IP,IORD),5)**2
11697 S56=P(IREF(IP,3-IORD),5)**2
11698 TI=PKK(1,3)+PKK(1,4)+S34
11699 UI=PKK(1,5)+PKK(1,6)+S56
11700 TIR=REAL(TI)
11701 UIR=REAL(UI)
11702 FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2
11703 FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2
11704 FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2
11705 FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2
11706 FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2
11707 FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2
11708 FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2
11709 FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2
11710 WT=
11711 & CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+
11712 & CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+
11713 & CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+
11714 & CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264
11715 WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
11716 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56*
11717 & ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+
11718 & 1D0/UI**2))
11719
11720 ELSEIF(ISUB.EQ.23) THEN
11721C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
11722 D34=P(IREF(IP,IORD),5)**2
11723 D56=P(IREF(IP,3-IORD),5)**2
11724 DT=PKK(1,3)+PKK(1,4)+D34
11725 DU=PKK(1,5)+PKK(1,6)+D56
11726 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
11727 CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
11728 CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
11729 FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+
11730 & REAL(CBWZ)*FGK(1,2,5,6,3,4))
11731 FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+
11732 & REAL(CBWZ)*FGK(1,2,6,5,3,4))
11733 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
11734 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
11735 & DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
11736
11737 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
11738C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
11739C...(or H0, or A0).
11740 WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
11741 & PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
11742 & COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
11743 WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
11744 & (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
11745
11746 ELSEIF(ISUB.EQ.25) THEN
11747C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
11748 D34=P(IREF(IP,IORD),5)**2
11749 D56=P(IREF(IP,3-IORD),5)**2
11750 DT=PKK(1,3)+PKK(1,4)+D34
11751 DU=PKK(1,5)+PKK(1,6)+D56
11752 FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2)
11753 CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH
11754 CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT
11755 CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU
11756 CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH
11757 FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)-
11758 & REAL(CBWW)*FGK(1,2,5,6,3,4))
11759 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
11760 WT=FGK135**2+(CCWW*FGK253)**2
11761 WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-CAWW*
11762 & CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
11763
11764 ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN
11765C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
11766C...(or H0, or A0).
11767 WT=PKK(1,3)*PKK(2,4)
11768 WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
11769
11770 ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN
11771C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
11772C...-> f + 2 quarks/leptons.
11773 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
11774 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
11775 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
11776 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
11777 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
11778 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
11779 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
11780 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
11781 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
11782 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
11783 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
11784 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
11785 IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+
11786 & PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2)
11787 IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+
11788 & PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2)
11789 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
11790 & ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
11791
11792 ELSEIF(ISUB.EQ.31.OR.ISUB.EQ.36) THEN
11793C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions.
11794 IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
11795 IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
11796 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
11797
11798 ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.
11799 & ISUB.EQ.77) THEN
11800C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
11801 WT=16D0*PKK(3,5)*PKK(4,6)
11802 WTMAX=SH**2
11803
11804 ELSEIF(ISUB.EQ.110) THEN
11805C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
11806 WT=1D0
11807 WTMAX=1D0
11808
11809 ELSEIF(ISUB.EQ.141) THEN
11810 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
11811C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
11812C...Couplings of incoming flavour.
11813 KFAI=IABS(MINT(15))
11814 EI=KCHG(KFAI,1)/3D0
11815 AI=SIGN(1D0,EI+0.1D0)
11816 VI=AI-4D0*EI*XWV
11817 KFAIC=1
11818 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
11819 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
11820 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
11821 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
11822 VPI=PARU(119+2*KFAIC)
11823 API=PARU(120+2*KFAIC)
11824 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
11825 VPI=PARJ(178+2*KFAIC)
11826 API=PARJ(179+2*KFAIC)
11827 ELSE
11828 VPI=PARJ(186+2*KFAIC)
11829 API=PARJ(187+2*KFAIC)
11830 ENDIF
11831C...Couplings of final flavour.
11832 KFAF=IABS(KFL1(1))
11833 EF=KCHG(KFAF,1)/3D0
11834 AF=SIGN(1D0,EF+0.1D0)
11835 VF=AF-4D0*EF*XWV
11836 KFAFC=1
11837 IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2
11838 IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3
11839 IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4
11840 IF(KFAF.LE.2.OR.KFAF.EQ.11.OR.KFAF.EQ.12) THEN
11841 VPF=PARU(119+2*KFAFC)
11842 APF=PARU(120+2*KFAFC)
11843 ELSEIF(KFAF.LE.4.OR.KFAF.EQ.13.OR.KFAF.EQ.14) THEN
11844 VPF=PARJ(178+2*KFAFC)
11845 APF=PARJ(179+2*KFAFC)
11846 ELSE
11847 VPF=PARJ(186+2*KFAFC)
11848 APF=PARJ(187+2*KFAFC)
11849 ENDIF
11850C...Asymmetry and weight.
11851 ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+
11852 & 4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)*
11853 & (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/
11854 & (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
11855 & EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
11856 & (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+
11857 & (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2))
11858 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
11859 WTMAX=2D0+ABS(ASYM)
11860 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN
11861C...Angular weight for f + fbar -> Z' -> W+ + W-.
11862 RM1=P(NSD(1)+1,5)**2/SH
11863 RM2=P(NSD(1)+2,5)**2/SH
11864 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
11865 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
11866 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
11867 & (RM2-RM1)**2)
11868 WT=CFLAT+CCOS2*CTHE(1)**2
11869 WTMAX=CFLAT+MAX(0D0,CCOS2)
11870 ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR.
11871 & IABS(KFL1(1)).EQ.37)) THEN
11872C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
11873 WT=1D0-CTHE(1)**2
11874 WTMAX=1D0
11875 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
11876C...Angular weight for f + fbar -> Z' -> Z0 + h0.
11877 RM1=P(NSD(1)+1,5)**2/SH
11878 RM2=P(NSD(1)+2,5)**2/SH
11879 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
11880 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
11881 WTMAX=1D0+FLAM2/(8D0*RM1)
11882 ELSEIF(MZPWP.EQ.0) THEN
11883C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
11884C...(W:s like if intermediate Z).
11885 D34=P(IREF(IP,IORD),5)**2
11886 D56=P(IREF(IP,3-IORD),5)**2
11887 DT=PKK(1,3)+PKK(1,4)+D34
11888 DU=PKK(1,5)+PKK(1,6)+D56
11889 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
11890 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
11891 WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2
11892 WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)*
11893 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
11894 ELSEIF(MZPWP.EQ.1) THEN
11895C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
11896C...(W:s approximately longitudinal, like if intermediate H).
11897 WT=16D0*PKK(3,5)*PKK(4,6)
11898 WTMAX=SH**2
11899 ELSE
11900C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
11901C...H0 + A0 -> 4 quarks/leptons, t + tbar -> b + W+ + bbar + W- .
11902 WT=1D0
11903 WTMAX=1D0
11904 ENDIF
11905
11906 ELSEIF(ISUB.EQ.142) THEN
11907 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
11908C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
11909 KFAI=IABS(MINT(15))
11910 KFAIC=1
11911 IF(KFAI.GT.10) KFAIC=2
11912 VI=PARU(129+2*KFAIC)
11913 AI=PARU(130+2*KFAIC)
11914 KFAF=IABS(KFL1(1))
11915 KFAFC=1
11916 IF(KFAF.GT.10) KFAFC=2
11917 VF=PARU(129+2*KFAFC)
11918 AF=PARU(130+2*KFAFC)
11919 ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2))
11920 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
11921 WTMAX=2D0+ABS(ASYM)
11922 ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN
11923C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
11924 RM1=P(NSD(1)+1,5)**2/SH
11925 RM2=P(NSD(1)+2,5)**2/SH
11926 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
11927 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
11928 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
11929 & (RM2-RM1)**2)
11930 WT=CFLAT+CCOS2*CTHE(1)**2
11931 WTMAX=CFLAT+MAX(0D0,CCOS2)
11932 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
11933C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
11934 RM1=P(NSD(1)+1,5)**2/SH
11935 RM2=P(NSD(1)+2,5)**2/SH
11936 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
11937 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
11938 WTMAX=1D0+FLAM2/(8D0*RM1)
11939 ELSEIF(MZPWP.EQ.0) THEN
11940C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
11941C...(W/Z like if intermediate W).
11942 D34=P(IREF(IP,IORD),5)**2
11943 D56=P(IREF(IP,3-IORD),5)**2
11944 DT=PKK(1,3)+PKK(1,4)+D34
11945 DU=PKK(1,5)+PKK(1,6)+D56
11946 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
11947 FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4))
11948 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
11949 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*
11950 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
11951 ELSEIF(MZPWP.EQ.1) THEN
11952C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
11953C...(W/Z approximately longitudinal, like if intermediate H).
11954 WT=16D0*PKK(3,5)*PKK(4,6)
11955 WTMAX=SH**2
11956 ELSE
11957C...Angular weight for f + fbar -> W' -> W + h0 -> whatever,
11958C...t + bbar -> t + W + bbar.
11959 WT=1D0
11960 WTMAX=1D0
11961 ENDIF
11962
11963 ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164)
11964 & THEN
11965C...Isotropic decay of leptoquarks (assumed spin 0).
11966 WT=1D0
11967 WTMAX=1D0
11968
11969 ELSEIF(ISUB.GE.146.AND.ISUB.LE.148) THEN
11970C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-).
11971 SIDE=1D0
11972 IF(MINT(16).EQ.21.OR.MINT(16).EQ.22) SIDE=-1D0
11973 IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN
11974 WT=1D0+SIDE*CTHE(1)
11975 WTMAX=2D0
11976 ELSEIF(IP.EQ.1) THEN
11977 RM1=P(NSD(1)+1,5)**2/SH
11978 WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
11979 WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
11980 ELSE
11981C...W/Z decay assumed isotropic, since not known.
11982 WT=1D0
11983 WTMAX=1D0
11984 ENDIF
11985
11986 ELSEIF(ISUB.EQ.149) THEN
11987C...Isotropic decay of techni-eta.
11988 WT=1D0
11989 WTMAX=1D0
11990
11991 ELSEIF(ISUB.EQ.191) THEN
11992 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
11993C...Angular weight for f + fbar -> rho_tech0 -> W+ W-,
11994C...W+ pi_tech-, pi_tech+ W- or pi_tech+ pi_tech-.
11995 WT=1D0-CTHE(1)**2
11996 WTMAX=1D0
11997 ELSEIF(IP.EQ.1) THEN
11998C...Angular weight for f + fbar -> rho_tech0 -> f fbar.
11999 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
12000 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
12001 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
12002 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
12003 KFAI=IABS(MINT(15))
12004 EI=KCHG(KFAI,1)/3D0
12005 AI=SIGN(1D0,EI+0.1D0)
12006 VI=AI-4D0*EI*XWV
12007 VALI=0.5D0*(VI+AI)
12008 VARI=0.5D0*(VI-AI)
12009 ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2
12010 ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2
12011 KFAF=IABS(KFL1(1))
12012 EF=KCHG(KFAF,1)/3D0
12013 AF=SIGN(1D0,EF+0.1D0)
12014 VF=AF-4D0*EF*XWV
12015 VALF=0.5D0*(VF+AF)
12016 VARF=0.5D0*(VF-AF)
12017 ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2
12018 ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2
12019 ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF
12020 AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF
12021 WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2
12022 WTMAX=4D0*MAX(ASAME,AFLIP)
12023 ELSE
12024C...Isotropic decay of W/pi_tech produced in rho_tech decay.
12025 WT=1D0
12026 WTMAX=1D0
12027 ENDIF
12028
12029 ELSEIF(ISUB.EQ.192) THEN
12030 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
12031C...Angular weight for f + fbar' -> rho_tech+ -> W+ Z0,
12032C...W+ pi_tech0, pi_tech+ Z0 or pi_tech+ pi_tech0.
12033 WT=1D0-CTHE(1)**2
12034 WTMAX=1D0
12035 ELSEIF(IP.EQ.1) THEN
12036C...Angular weight for f + fbar' -> rho_tech+ -> f fbar'.
12037 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
12038 WT=(1D0+CTHESG)**2
12039 WTMAX=4D0
12040 ELSE
12041C...Isotropic decay of W/Z/pi_tech produced in rho_tech+ decay.
12042 WT=1D0
12043 WTMAX=1D0
12044 ENDIF
12045
12046 ELSEIF(ISUB.EQ.193) THEN
12047 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
12048C...Angular weight for f + fbar -> omega_tech0 ->
12049C...gamma pi_tech0 or Z0 pi_tech0.
12050 WT=1D0+CTHE(1)**2
12051 WTMAX=2D0
12052 ELSEIF(IP.EQ.1) THEN
12053C...Angular weight for f + fbar -> omega_tech0 -> f fbar.
12054 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
12055 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
12056 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
12057 KFAI=IABS(MINT(15))
12058 EI=KCHG(KFAI,1)/3D0
12059 AI=SIGN(1D0,EI+0.1D0)
12060 VI=AI-4D0*EI*XWV
12061 VALI=0.5D0*(VI+AI)
12062 VARI=0.5D0*(VI-AI)
12063 BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2
12064 BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2
12065 KFAF=IABS(KFL1(1))
12066 EF=KCHG(KFAF,1)/3D0
12067 AF=SIGN(1D0,EF+0.1D0)
12068 VF=AF-4D0*EF*XWV
12069 VALF=0.5D0*(VF+AF)
12070 VARF=0.5D0*(VF-AF)
12071 BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2
12072 BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2
12073 BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF
12074 BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF
12075 WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2
12076 WTMAX=4D0*MAX(BSAME,BFLIP)
12077 ELSE
12078C...Isotropic decay of Z/pi_tech produced in omega_tech decay.
12079 WT=1D0
12080 WTMAX=1D0
12081 ENDIF
12082
12083C...Obtain correct angular distribution by rejection techniques.
12084 ELSE
12085 WT=1D0
12086 WTMAX=1D0
12087 ENDIF
12088 IF(WT.LT.PYR(0)*WTMAX) GOTO 340
12089
12090C...Construct massive four-vectors using angles chosen.
12091 500 DO 600 JT=1,JTMAX
12092 IF(KDCY(JT).EQ.0) GOTO 600
12093 ID=IREF(IP,JT)
12094 DO 510 J=1,5
12095 DPMO(J)=P(ID,J)
12096 510 CONTINUE
12097 DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2)
12098CMRENNA++
12099 IF(KFL3(JT).EQ.0) THEN
12100 CALL PYROBO(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT),
12101 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
12102 N0=NSD(JT)+2
12103 ELSE
12104 CALL PYROBO(NSD(JT)+1,NSD(JT)+3,ACOS(CTHE(JT)),PHI(JT),
12105 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
12106 N0=NSD(JT)+3
12107 ENDIF
12108
12109 DO 520 J=1,4
12110 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
12111 520 CONTINUE
12112C...Fill in position of decay vertex.
12113 DO 540 I=NSD(JT)+1,N0
12114 DO 530 J=1,4
12115 V(I,J)=VDCY(J)
12116 530 CONTINUE
12117 V(I,5)=0D0
12118 540 CONTINUE
12119CMRENNA--
12120
12121C...Mark decayed resonances; trace history.
12122 K(ID,1)=K(ID,1)+10
12123 KFA=IABS(K(ID,2))
12124 KCA=PYCOMP(KFA)
12125 IF(KCQM(JT).NE.0) THEN
12126C...Do not kill colour flow through coloured resonance!
12127 ELSE
12128 K(ID,4)=NSD(JT)+1
12129 K(ID,5)=NSD(JT)+2
12130 IF(KFL3(JT).NE.0) K(ID,5)=NSD(JT)+3
12131 ENDIF
12132
12133C...Add documentation lines.
12134 IF(ISUB.NE.0) THEN
12135 IDOC=MINT(83)+MINT(4)
12136CMRENNA+++
12137 IHI=NSD(JT)+2
12138 IF(KFL3(JT).NE.0) IHI=IHI+1
12139 DO 560 I=NSD(JT)+1,IHI
12140CMRENNA---
12141 I1=MINT(83)+MINT(4)+1
12142 K(I,3)=I1
12143 IF(MSTP(128).GE.1) K(I,3)=ID
12144 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
12145 MINT(4)=MINT(4)+1
12146 K(I1,1)=21
12147 K(I1,2)=K(I,2)
12148 K(I1,3)=IREF(IP,JT+3)
12149 DO 550 J=1,5
12150 P(I1,J)=P(I,J)
12151 550 CONTINUE
12152 ENDIF
12153 560 CONTINUE
12154 ELSE
12155 K(NSD(JT)+1,3)=ID
12156 K(NSD(JT)+2,3)=ID
12157 IF(KFL3(JT).NE.0) K(NSD(JT)+3,3)=ID
12158 ENDIF
12159
12160C...Do showering if any of the two/three products can shower.
12161 NSHBEF=N
12162 IF(MSTP(71).GE.1) THEN
12163 ISHOW1=0
12164 KFL1A=IABS(KFL1(JT))
12165 IF(KFL1A.LE.22) ISHOW1=1
12166 ISHOW2=0
12167 KFL2A=IABS(KFL2(JT))
12168 IF(KFL2A.LE.22) ISHOW2=1
12169 ISHOW3=0
12170 IF(KFL3(JT).NE.0) THEN
12171 KFL3A=IABS(KFL3(JT))
12172 IF(KFL3A.LE.22) ISHOW3=1
12173 ENDIF
12174 IF(ISHOW1.EQ.0.AND.ISHOW2.EQ.0.AND.ISHOW3.EQ.0) THEN
12175 ELSEIF(KFL3(JT).EQ.0) THEN
12176 CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
12177 ELSE
12178 NSD1=NSD(JT)+1
12179 NSD2=NSD(JT)+2
12180 IF(ISHOW1.EQ.0.AND.ISHOW3.NE.0) THEN
12181 NSD1=NSD(JT)+3
12182 ELSEIF(ISHOW2.EQ.0.AND.ISHOW3.NE.0) THEN
12183 NSD2=NSD(JT)+3
12184 ENDIF
12185 PMSHOW=SQRT(MAX(0D0,(P(NSD1,4)+P(NSD2,4))**2-
12186 & (P(NSD1,1)+P(NSD2,1))**2-(P(NSD1,2)+P(NSD2,2))**2-
12187 & (P(NSD1,3)+P(NSD2,3))**2))
12188 CALL PYSHOW(NSD1,NSD2,PMSHOW)
12189 ENDIF
12190 ENDIF
12191 NSHAFT=N
12192 IF(JT.EQ.1) NAFT1=N
12193
12194C...Check if decay products moved by shower.
12195 NSD1=NSD(JT)+1
12196 NSD2=NSD(JT)+2
12197 NSD3=NSD(JT)+3
12198 IF(NSHAFT.GT.NSHBEF) THEN
12199 IF(K(NSD1,1).GT.10) THEN
12200 DO 570 I=NSHBEF+1,NSHAFT
12201 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
12202 570 CONTINUE
12203 ENDIF
12204 IF(K(NSD2,1).GT.10) THEN
12205 DO 580 I=NSHBEF+1,NSHAFT
12206 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
12207 & I.NE.NSD1) NSD2=I
12208 580 CONTINUE
12209 ENDIF
12210 IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
12211 DO 590 I=NSHBEF+1,NSHAFT
12212 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND.
12213 & I.NE.NSD1.AND.I.NE.NSD2) NSD3=I
12214 590 CONTINUE
12215 ENDIF
12216 ENDIF
12217
12218C...Store decay products for further treatment.
12219 NP=NP+1
12220 IREF(NP,1)=NSD1
12221 IREF(NP,2)=NSD2
12222 IREF(NP,3)=0
12223 IF(KFL3(JT).NE.0) IREF(NP,3)=NSD3
12224 IREF(NP,4)=IDOC+1
12225 IREF(NP,5)=IDOC+2
12226 IREF(NP,6)=0
12227 IF(KFL3(JT).NE.0) IREF(NP,6)=IDOC+3
12228 IREF(NP,7)=K(IREF(IP,JT),2)
12229 IREF(NP,8)=IREF(IP,JT)
12230 600 CONTINUE
12231
12232C...Fill information for 2 -> 1 -> 2.
12233 610 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN
12234 MINT(7)=MINT(83)+6+2*ISET(ISUB)
12235 MINT(8)=MINT(83)+7+2*ISET(ISUB)
12236 MINT(25)=KFL1(1)
12237 MINT(26)=KFL2(1)
12238 VINT(23)=CTHE(1)
12239 RM3=P(N-1,5)**2/SH
12240 RM4=P(N,5)**2/SH
12241 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
12242 VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1))
12243 VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1))
12244 VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2)
12245 VINT(47)=SQRT(VINT(48))
12246 ENDIF
12247
12248C...Possibility of colour rearrangement in W+W- events.
12249 IF((ISUB.EQ.25.OR.ISUB.EQ.22).AND.MSTP(115).GE.1) THEN
12250 IAKF1=IABS(KFL1(1))
12251 IAKF2=IABS(KFL1(2))
12252 IAKF3=IABS(KFL2(1))
12253 IAKF4=IABS(KFL2(2))
12254 IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
12255 & MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
12256 & PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
12257 ENDIF
12258
12259C...Loop back if needed.
12260 620 IF(IP.LT.NP) GOTO 150
12261
12262 RETURN
12263 END
12264
12265C*********************************************************************
12266
12267C...PYMULT
12268C...Initializes treatment of multiple interactions, selects kinematics
12269C...of hardest interaction if low-pT physics included in run, and
12270C...generates all non-hardest interactions.
12271
12272 SUBROUTINE PYMULT(MMUL)
12273
12274C...Double precision and integer declarations.
12275 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12276 IMPLICIT INTEGER(I-N)
12277 INTEGER PYK,PYCHGE,PYCOMP
12278C...Commonblocks.
12279 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12280 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12281 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
12282 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
12283 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12284 COMMON/PYINT1/MINT(400),VINT(400)
12285 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
12286 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
12287 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
12288 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
12289 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
12290 &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
12291C...Local arrays and saved variables.
12292 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
12293 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM
12294
12295C...Initialization of multiple interaction treatment.
12296 IF(MMUL.EQ.1) THEN
12297 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
12298 ISUB=96
12299 MINT(1)=96
12300 VINT(63)=0D0
12301 VINT(64)=0D0
12302 VINT(143)=1D0
12303 VINT(144)=1D0
12304
12305C...Loop over phase space points: xT2 choice in 20 bins.
12306 100 SIGSUM=0D0
12307 DO 120 IXT2=1,20
12308 NMUL(IXT2)=MSTP(83)
12309 SIGM(IXT2)=0D0
12310 DO 110 ITRY=1,MSTP(83)
12311 RSCA=0.05D0*((21-IXT2)-PYR(0))
12312 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
12313 XT2=MAX(0.01D0*VINT(149),XT2)
12314 VINT(25)=XT2
12315
12316C...Choose tau and y*. Calculate cos(theta-hat).
12317 IF(PYR(0).LE.COEF(ISUB,1)) THEN
12318 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
12319 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
12320 ELSE
12321 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
12322 ENDIF
12323 VINT(21)=TAU
12324 CALL PYKLIM(2)
12325 RYST=PYR(0)
12326 MYST=1
12327 IF(RYST.GT.COEF(ISUB,8)) MYST=2
12328 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
12329 CALL PYKMAP(2,MYST,PYR(0))
12330 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
12331
12332C...Calculate differential cross-section.
12333 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
12334 CALL PYSIGH(NCHN,SIGS)
12335 SIGM(IXT2)=SIGM(IXT2)+SIGS
12336 110 CONTINUE
12337 SIGSUM=SIGSUM+SIGM(IXT2)
12338 120 CONTINUE
12339 SIGSUM=SIGSUM/(20D0*MSTP(83))
12340
12341C...Reject result if sigma(parton-parton) is smaller than hadronic one.
12342 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
12343 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
12344 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
12345 PARP(82)=0.9D0*PARP(82)
12346 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
12347 & VINT(2)
12348 GOTO 100
12349 ENDIF
12350 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
12351 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
12352
12353C...Start iteration to find k factor.
12354 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
12355 SO=0.5D0
12356 XI=0D0
12357 YI=0D0
12358 XF=0D0
12359 YF=0D0
12360 XK=0.5D0
12361 IIT=0
12362 130 IF(IIT.EQ.0) THEN
12363 XK=2D0*XK
12364 ELSEIF(IIT.EQ.1) THEN
12365 XK=0.5D0*XK
12366 ELSE
12367 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
12368 ENDIF
12369
12370C...Evaluate overlap integrals.
12371 IF(MSTP(82).EQ.2) THEN
12372 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
12373 SOP=SP/PARU(1)
12374 ELSE
12375 IF(MSTP(82).EQ.3) DELTAB=0.02D0
12376 IF(MSTP(82).EQ.4) DELTAB=MIN(0.01D0,0.05D0*PARP(84))
12377 SP=0D0
12378 SOP=0D0
12379 B=-0.5D0*DELTAB
12380 140 B=B+DELTAB
12381 IF(MSTP(82).EQ.3) THEN
12382 OV=EXP(-B**2)/PARU(2)
12383 ELSE
12384 CQ2=PARP(84)**2
12385 OV=((1D0-PARP(83))**2*EXP(-MIN(50D0,B**2))+
12386 & 2D0*PARP(83)*(1D0-PARP(83))*2D0/(1D0+CQ2)*
12387 & EXP(-MIN(50D0,B**2*2D0/(1D0+CQ2)))+
12388 & PARP(83)**2/CQ2*EXP(-MIN(50D0,B**2/CQ2)))/PARU(2)
12389 ENDIF
12390 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
12391 SP=SP+PARU(2)*B*DELTAB*PACC
12392 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
12393 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
12394 ENDIF
12395 YK=PARU(1)*XK*SO/SP
12396
12397C...Continue iteration until convergence.
12398 IF(YK.LT.YKE) THEN
12399 XI=XK
12400 YI=YK
12401 IF(IIT.EQ.1) IIT=2
12402 ELSE
12403 XF=XK
12404 YF=YK
12405 IF(IIT.EQ.0) IIT=1
12406 ENDIF
12407 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
12408
12409C...Store some results for subsequent use.
12410 VINT(145)=SIGSUM
12411 VINT(146)=SOP/SO
12412 VINT(147)=SOP/SP
12413
12414C...Initialize iteration in xT2 for hardest interaction.
12415 ELSEIF(MMUL.EQ.2) THEN
12416 IF(MSTP(82).LE.0) THEN
12417 ELSEIF(MSTP(82).EQ.1) THEN
12418 XT2=1D0
12419 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
12420 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
12421 & VINT(317)/(VINT(318)*VINT(320))
12422 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
12423 ELSEIF(MSTP(82).EQ.2) THEN
12424 XT2=1D0
12425 XT2FAC=VINT(146)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
12426 & VINT(149)*(1D0+VINT(149))
12427 ELSE
12428 XC2=4D0*CKIN(3)**2/VINT(2)
12429 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
12430 ENDIF
12431
12432 ELSEIF(MMUL.EQ.3) THEN
12433C...Low-pT or multiple interactions (first semihard interaction):
12434C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
12435C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
12436 ISUB=MINT(1)
12437 IF(MSTP(82).LE.0) THEN
12438 XT2=0D0
12439 ELSEIF(MSTP(82).EQ.1) THEN
12440 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
12441 ELSEIF(MSTP(82).EQ.2) THEN
12442 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
12443 & VINT(149)))).GT.PYR(0)) XT2=1D0
12444 IF(XT2.GE.1D0) THEN
12445 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
12446 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
12447 & VINT(149)
12448 ELSE
12449 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
12450 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
12451 & VINT(149)
12452 ENDIF
12453 XT2=MAX(0.01D0*VINT(149),XT2)
12454 ELSE
12455 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
12456 & PYR(0)*(1D0-XC2))-VINT(149)
12457 XT2=MAX(0.01D0*VINT(149),XT2)
12458 ENDIF
12459 VINT(25)=XT2
12460
12461C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
12462 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
12463 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-1
12464 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-1
12465 ISUB=95
12466 MINT(1)=ISUB
12467 VINT(21)=0.01D0*VINT(149)
12468 VINT(22)=0D0
12469 VINT(23)=0D0
12470 VINT(25)=0.01D0*VINT(149)
12471
12472 ELSE
12473C...Multiple interactions (first semihard interaction).
12474C...Choose tau and y*. Calculate cos(theta-hat).
12475 IF(PYR(0).LE.COEF(ISUB,1)) THEN
12476 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
12477 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
12478 ELSE
12479 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
12480 ENDIF
12481 VINT(21)=TAU
12482 CALL PYKLIM(2)
12483 RYST=PYR(0)
12484 MYST=1
12485 IF(RYST.GT.COEF(ISUB,8)) MYST=2
12486 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
12487 CALL PYKMAP(2,MYST,PYR(0))
12488 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
12489 ENDIF
12490 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
12491
12492C...Store results of cross-section calculation.
12493 ELSEIF(MMUL.EQ.4) THEN
12494 ISUB=MINT(1)
12495 XTS=VINT(25)
12496 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
12497 IF(ISET(ISUB).EQ.2)
12498 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
12499 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
12500 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
12501 & (XTS+VINT(149))))
12502 IRBIN=INT(1D0+20D0*RBIN)
12503 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
12504 NMUL(IRBIN)=NMUL(IRBIN)+1
12505 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
12506 ENDIF
12507
12508C...Choose impact parameter.
12509 ELSEIF(MMUL.EQ.5) THEN
12510 ISUB=MINT(1)
12511 145 IF(MSTP(82).EQ.3) THEN
12512 VINT(148)=PYR(0)/(PARU(2)*VINT(147))
12513 ELSE
12514 RTYPE=PYR(0)
12515 CQ2=PARP(84)**2
12516 IF(RTYPE.LT.(1D0-PARP(83))**2) THEN
12517 B2=-LOG(PYR(0))
12518 ELSEIF(RTYPE.LT.1D0-PARP(83)**2) THEN
12519 B2=-0.5D0*(1D0+CQ2)*LOG(PYR(0))
12520 ELSE
12521 B2=-CQ2*LOG(PYR(0))
12522 ENDIF
12523 VINT(148)=((1D0-PARP(83))**2*EXP(-MIN(50D0,B2))+2D0*PARP(83)*
12524 & (1D0-PARP(83))*2D0/(1D0+CQ2)*EXP(-MIN(50D0,B2*2D0/(1D0+CQ2)))+
12525 & PARP(83)**2/CQ2*EXP(-MIN(50D0,B2/CQ2)))/(PARU(2)*VINT(147))
12526 ENDIF
12527
12528C...Multiple interactions (variable impact parameter) : reject with
12529C...probability exp(-overlap*cross-section above pT/normalization).
12530 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
12531 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
12532 DO 150 IBIN=IRBIN+1,20
12533 RNCOR=RNCOR+NMUL(IBIN)
12534 SIGCOR=SIGCOR+SIGM(IBIN)
12535 150 CONTINUE
12536 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
12537 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
12538 VINT(150)=EXP(-MIN(50D0,VINT(146)*VINT(148)*
12539 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
12540 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
12541 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
12542 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
12543 IF(VINT(150).LT.PYR(0)) GOTO 145
12544 VINT(150)=1D0
12545 ENDIF
12546
12547C...Generate additional multiple semihard interactions.
12548 ELSEIF(MMUL.EQ.6) THEN
12549 ISUBSV=MINT(1)
12550 DO 160 J=11,80
12551 VINTSV(J)=VINT(J)
12552 160 CONTINUE
12553 ISUB=96
12554 MINT(1)=96
12555 VINT(151)=0D0
12556 VINT(152)=0D0
12557
12558C...Reconstruct strings in hard scattering.
12559 NMAX=MINT(84)+4
12560 IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2
12561 IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3)
12562 NSTR=0
12563 DO 180 I=MINT(84)+1,NMAX
12564 KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
12565 IF(KCS.EQ.0) GOTO 180
12566 DO 170 J=1,4
12567 IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 170
12568 IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 170
12569 IF(J.LE.2) THEN
12570 IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
12571 ELSE
12572 IST=MOD(K(I,J+1),MSTU(5))
12573 ENDIF
12574 IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 170
12575 IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 170
12576 NSTR=NSTR+1
12577 IF(J.EQ.1.OR.J.EQ.4) THEN
12578 KSTR(NSTR,1)=I
12579 KSTR(NSTR,2)=IST
12580 ELSE
12581 KSTR(NSTR,1)=IST
12582 KSTR(NSTR,2)=I
12583 ENDIF
12584 170 CONTINUE
12585 180 CONTINUE
12586
12587C...Set up starting values for iteration in xT2.
12588 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
12589 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
12590 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
12591 & ISUBSV.NE.96)) THEN
12592 XT2=(1D0-VINT(141))*(1D0-VINT(142))
12593 ELSE
12594 XT2=VINT(25)
12595 IF(ISET(ISUBSV).EQ.1) XT2=VINT(21)
12596 IF(ISET(ISUBSV).EQ.2)
12597 & XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
12598 IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26)
12599 ENDIF
12600 IF(MSTP(82).LE.1) THEN
12601 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
12602 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
12603 & VINT(317)/(VINT(318)*VINT(320))
12604 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
12605 ELSE
12606 XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/
12607 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
12608 ENDIF
12609 VINT(63)=0D0
12610 VINT(64)=0D0
12611 VINT(143)=1D0-VINT(141)
12612 VINT(144)=1D0-VINT(142)
12613
12614C...Iterate downwards in xT2.
12615 190 IF(MSTP(82).LE.1) THEN
12616 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
12617 IF(XT2.LT.VINT(149)) GOTO 240
12618 ELSE
12619 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 240
12620 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
12621 & LOG(PYR(0)))-VINT(149)
12622 IF(XT2.LE.0D0) GOTO 240
12623 XT2=MAX(0.01D0*VINT(149),XT2)
12624 ENDIF
12625 VINT(25)=XT2
12626
12627C...Choose tau and y*. Calculate cos(theta-hat).
12628 IF(PYR(0).LE.COEF(ISUB,1)) THEN
12629 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
12630 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
12631 ELSE
12632 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
12633 ENDIF
12634 VINT(21)=TAU
12635 CALL PYKLIM(2)
12636 RYST=PYR(0)
12637 MYST=1
12638 IF(RYST.GT.COEF(ISUB,8)) MYST=2
12639 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
12640 CALL PYKMAP(2,MYST,PYR(0))
12641 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
12642
12643C...Check that x not used up. Accept or reject kinematical variables.
12644 X1M=SQRT(TAU)*EXP(VINT(22))
12645 X2M=SQRT(TAU)*EXP(-VINT(22))
12646 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 190
12647 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
12648 CALL PYSIGH(NCHN,SIGS)
12649 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
12650 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 190
12651
12652C...Reset K, P and V vectors. Select some variables.
12653 DO 210 I=N+1,N+2
12654 DO 200 J=1,5
12655 K(I,J)=0
12656 P(I,J)=0D0
12657 V(I,J)=0D0
12658 200 CONTINUE
12659 210 CONTINUE
12660 RFLAV=PYR(0)
12661 PT=0.5D0*VINT(1)*SQRT(XT2)
12662 PHI=PARU(2)*PYR(0)
12663 CTH=VINT(23)
12664
12665C...Add first parton to event record.
12666 K(N+1,1)=3
12667 K(N+1,2)=21
12668 IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
12669 & 1+INT((2D0+PARJ(2))*PYR(0))
12670 P(N+1,1)=PT*COS(PHI)
12671 P(N+1,2)=PT*SIN(PHI)
12672 P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH))
12673 P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH))
12674 P(N+1,5)=0D0
12675
12676C...Add second parton to event record.
12677 K(N+2,1)=3
12678 K(N+2,2)=21
12679 IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
12680 P(N+2,1)=-P(N+1,1)
12681 P(N+2,2)=-P(N+1,2)
12682 P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH))
12683 P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH))
12684 P(N+2,5)=0D0
12685
12686 IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
12687C....Choose relevant string pieces to place gluons on.
12688 DO 230 I=N+1,N+2
12689 DMIN=1D8
12690 DO 220 ISTR=1,NSTR
12691 I1=KSTR(ISTR,1)
12692 I2=KSTR(ISTR,2)
12693 DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
12694 & P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
12695 & P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
12696 & P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
12697 IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
12698 DMIN=DIST
12699 IST1=I1
12700 IST2=I2
12701 ISTM=ISTR
12702 ENDIF
12703 220 CONTINUE
12704
12705C....Colour flow adjustments, new string pieces.
12706 IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
12707 & MOD(K(IST1,4),MSTU(5))
12708 IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
12709 & MSTU(5)*(K(IST1,5)/MSTU(5))+I
12710 K(I,5)=MSTU(5)*IST1
12711 K(I,4)=MSTU(5)*IST2
12712 IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
12713 & MOD(K(IST2,5),MSTU(5))
12714 IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
12715 & MSTU(5)*(K(IST2,4)/MSTU(5))+I
12716 KSTR(ISTM,2)=I
12717 KSTR(NSTR+1,1)=I
12718 KSTR(NSTR+1,2)=IST2
12719 NSTR=NSTR+1
12720 230 CONTINUE
12721
12722C...String drawing and colour flow for gluon loop.
12723 ELSEIF(K(N+1,2).EQ.21) THEN
12724 K(N+1,4)=MSTU(5)*(N+2)
12725 K(N+1,5)=MSTU(5)*(N+2)
12726 K(N+2,4)=MSTU(5)*(N+1)
12727 K(N+2,5)=MSTU(5)*(N+1)
12728 KSTR(NSTR+1,1)=N+1
12729 KSTR(NSTR+1,2)=N+2
12730 KSTR(NSTR+2,1)=N+2
12731 KSTR(NSTR+2,2)=N+1
12732 NSTR=NSTR+2
12733
12734C...String drawing and colour flow for qqbar pair.
12735 ELSE
12736 K(N+1,4)=MSTU(5)*(N+2)
12737 K(N+2,5)=MSTU(5)*(N+1)
12738 KSTR(NSTR+1,1)=N+1
12739 KSTR(NSTR+1,2)=N+2
12740 NSTR=NSTR+1
12741 ENDIF
12742
12743C...Update remaining energy; iterate.
12744 N=N+2
12745 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
12746 CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
12747 IF(MSTU(21).GE.1) RETURN
12748 ENDIF
12749 MINT(31)=MINT(31)+1
12750 VINT(151)=VINT(151)+VINT(41)
12751 VINT(152)=VINT(152)+VINT(42)
12752 VINT(143)=VINT(143)-VINT(41)
12753 VINT(144)=VINT(144)-VINT(42)
12754 IF(MINT(31).LT.240) GOTO 190
12755 240 CONTINUE
12756 MINT(1)=ISUBSV
12757 DO 250 J=11,80
12758 VINT(J)=VINTSV(J)
12759 250 CONTINUE
12760 ENDIF
12761
12762C...Format statements for printout.
12763 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
12764 &'actions for MSTP(82) =',I2,' ******')
12765 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
12766 &D9.2,' mb: rejected')
12767 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
12768 &D9.2,' mb: accepted')
12769
12770 RETURN
12771 END
12772
12773C*********************************************************************
12774
12775C...PYREMN
12776C...Adds on target remnants (one or two from each side) and
12777C...includes primordial kT for hadron beams.
12778
12779 SUBROUTINE PYREMN(IPU1,IPU2)
12780
12781C...Double precision and integer declarations.
12782 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12783 IMPLICIT INTEGER(I-N)
12784 INTEGER PYK,PYCHGE,PYCOMP
12785C...Commonblocks.
12786 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12787 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12788 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
12789 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12790 COMMON/PYINT1/MINT(400),VINT(400)
12791 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
12792C...Local arrays.
12793 DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
12794 &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
12795
12796C...Find event type and remaining energy.
12797 ISUB=MINT(1)
12798 NS=N
12799 IF(MINT(50).EQ.0.OR.MSTP(81).LE.0) THEN
12800 VINT(143)=1D0-VINT(141)
12801 VINT(144)=1D0-VINT(142)
12802 ENDIF
12803
12804C...Define initial partons.
12805 NTRY=0
12806 100 NTRY=NTRY+1
12807 DO 130 JT=1,2
12808 I=MINT(83)+JT+2
12809 IF(JT.EQ.1) IPU=IPU1
12810 IF(JT.EQ.2) IPU=IPU2
12811 K(I,1)=21
12812 K(I,2)=K(IPU,2)
12813 K(I,3)=I-2
12814 PMS(JT)=0D0
12815 VINT(156+JT)=0D0
12816 VINT(158+JT)=0D0
12817 IF(MINT(47).EQ.1) THEN
12818 DO 110 J=1,5
12819 P(I,J)=P(I-2,J)
12820 110 CONTINUE
12821 ELSEIF(ISUB.EQ.95) THEN
12822 K(I,2)=21
12823 ELSE
12824 P(I,5)=P(IPU,5)
12825
12826C...No primordial kT, or chosen according to truncated Gaussian or
12827C...exponential, or (for photon) predetermined or power law.
12828 120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
12829 IF(MSTP(91).LE.0) THEN
12830 PT=0D0
12831 ELSEIF(MSTP(91).EQ.1) THEN
12832 PT=PARP(91)*SQRT(-LOG(PYR(0)))
12833 ELSE
12834 RPT1=PYR(0)
12835 RPT2=PYR(0)
12836 PT=-PARP(92)*LOG(RPT1*RPT2)
12837 ENDIF
12838 IF(PT.GT.PARP(93)) GOTO 120
12839 ELSEIF(MINT(106+JT).EQ.3) THEN
12840 PTA=SQRT(VINT(282+JT))
12841 PTB=0D0
12842 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
12843 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
12844 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
12845 RPT1=PYR(0)
12846 RPT2=PYR(0)
12847 PTB=-PARP(99)*LOG(RPT1*RPT2)
12848 ENDIF
12849 IF(PTB.GT.PARP(100)) GOTO 120
12850 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
12851 PT=PT*0.8D0**MINT(57)
12852 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
12853 ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN
12854 IF(MSTP(93).LE.0) THEN
12855 PT=0D0
12856 ELSEIF(MSTP(93).EQ.1) THEN
12857 PT=PARP(99)*SQRT(-LOG(PYR(0)))
12858 ELSEIF(MSTP(93).EQ.2) THEN
12859 RPT1=PYR(0)
12860 RPT2=PYR(0)
12861 PT=-PARP(99)*LOG(RPT1*RPT2)
12862 ELSEIF(MSTP(93).EQ.3) THEN
12863 HA=PARP(99)**2
12864 HB=PARP(100)**2
12865 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
12866 ELSE
12867 HA=PARP(99)**2
12868 HB=PARP(100)**2
12869 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
12870 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
12871 ENDIF
12872 IF(PT.GT.PARP(100)) GOTO 120
12873 ELSE
12874 PT=0D0
12875 ENDIF
12876 VINT(156+JT)=PT
12877 PHI=PARU(2)*PYR(0)
12878 P(I,1)=PT*COS(PHI)
12879 P(I,2)=PT*SIN(PHI)
12880 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
12881 ENDIF
12882 130 CONTINUE
12883 IF(MINT(47).EQ.1) RETURN
12884
12885C...Kinematics construction for initial partons.
12886 I1=MINT(83)+3
12887 I2=MINT(83)+4
12888 IF(ISUB.EQ.95) THEN
12889 SHS=0D0
12890 SHR=0D0
12891 ELSE
12892 SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+
12893 & (P(I1,2)+P(I2,2))**2
12894 SHR=SQRT(MAX(0D0,SHS))
12895 IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100
12896 P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR)
12897 P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1)))
12898 P(I2,4)=SHR-P(I1,4)
12899 P(I2,3)=-P(I1,3)
12900
12901C...Transform partons to overall CM-frame.
12902 ROBO(3)=(P(I1,1)+P(I2,1))/SHR
12903 ROBO(4)=(P(I1,2)+P(I2,2))/SHR
12904 CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0)
12905 ROBO(2)=PYANGL(P(I1,1),P(I1,2))
12906 CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0)
12907 ROBO(1)=PYANGL(P(I1,3),P(I1,1))
12908 CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0)
12909 CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0)
12910 ROBO(5)=(VINT(141)-VINT(142))/(VINT(141)+VINT(142))
12911 CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5))
12912 ENDIF
12913
12914C...Optionally fix up x and Q2 definitions for leptoproduction.
12915 IDISXQ=0
12916 IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND.
12917 &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1
12918 IF(IDISXQ.EQ.1) THEN
12919
12920C...Find where incoming and outgoing leptons/partons are sitting.
12921 LESD=1
12922 IF(MINT(42).EQ.1) LESD=2
12923 LPIN=MINT(83)+3-LESD
12924 LEIN=MINT(84)+LESD
12925 LQIN=MINT(84)+3-LESD
12926 LEOUT=MINT(84)+2+LESD
12927 LQOUT=MINT(84)+5-LESD
12928 IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3)
12929 IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3)
12930 LSCMS=0
12931 DO 140 I=MINT(84)+5,N
12932 IF(K(I,2).EQ.94) THEN
12933 LSCMS=I
12934 LEOUT=I+LESD
12935 LQOUT=I+3-LESD
12936 ENDIF
12937 140 CONTINUE
12938 LQBG=IPU1
12939 IF(LESD.EQ.1) LQBG=IPU2
12940
12941C...Calculate actual and wanted momentum transfer.
12942 XNOM=VINT(43-LESD)
12943 Q2NOM=-VINT(45)
12944 HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)-
12945 & P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))*
12946 & (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4))
12947 HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK)))
12948 FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2))
12949 P(N+1,1)=FAC*P(LEOUT,1)
12950 P(N+1,2)=FAC*P(LEOUT,2)
12951 P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)-
12952 & Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1)
12953 P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+
12954 & P(N+1,3)**2)
12955 DO 150 J=1,4
12956 QOLD(J)=P(LEIN,J)-P(LEOUT,J)
12957 QNEW(J)=P(LEIN,J)-P(N+1,J)
12958 150 CONTINUE
12959
12960C...Boost outgoing electron and daughters.
12961 IF(LSCMS.EQ.0) THEN
12962 DO 160 J=1,4
12963 P(LEOUT,J)=P(N+1,J)
12964 160 CONTINUE
12965 ELSE
12966 DO 170 J=1,3
12967 P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4))
12968 170 CONTINUE
12969 PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2)
12970 DO 180 J=1,3
12971 DBE(J)=PINV*P(N+2,J)
12972 180 CONTINUE
12973 DO 200 I=LSCMS+1,N
12974 IORIG=I
12975 190 IORIG=K(IORIG,3)
12976 IF(IORIG.GT.LEOUT) GOTO 190
12977 IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT)
12978 & CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3))
12979 200 CONTINUE
12980 ENDIF
12981
12982C...Copy shower initiator and all outgoing partons.
12983 NCOP=N+1
12984 K(NCOP,3)=LQBG
12985 DO 210 J=1,5
12986 P(NCOP,J)=P(LQBG,J)
12987 210 CONTINUE
12988 DO 240 I=MINT(84)+1,N
12989 ICOP=0
12990 IF(K(I,1).GT.10) GOTO 240
12991 IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN
12992 ICOP=I
12993 ELSE
12994 IORIG=I
12995 220 IORIG=K(IORIG,3)
12996 IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN
12997 ICOP=IORIG
12998 ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN
12999 GOTO 220
13000 ENDIF
13001 ENDIF
13002 IF(ICOP.NE.0) THEN
13003 NCOP=NCOP+1
13004 K(NCOP,3)=I
13005 DO 230 J=1,5
13006 P(NCOP,J)=P(I,J)
13007 230 CONTINUE
13008 ENDIF
13009 240 CONTINUE
13010
13011C...Calculate relative rescaling factors.
13012 SLC=3-2*LESD
13013 PLCSUM=0D0
13014 DO 250 I=N+2,NCOP
13015 PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3))
13016 250 CONTINUE
13017 DO 260 I=N+2,NCOP
13018 V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM
13019 260 CONTINUE
13020
13021C...Transfer extra three-momentum of current.
13022 DO 280 I=N+2,NCOP
13023 DO 270 J=1,3
13024 P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J))
13025 270 CONTINUE
13026 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
13027 280 CONTINUE
13028
13029C...Iterate change of initiator momentum to get energy right.
13030 ITER=0
13031 290 ITER=ITER+1
13032 PEEX=-P(N+1,4)-QNEW(4)
13033 PEMV=-P(N+1,3)/P(N+1,4)
13034 DO 300 I=N+2,NCOP
13035 PEEX=PEEX+P(I,4)
13036 PEMV=PEMV+V(I,1)*P(I,3)/P(I,4)
13037 300 CONTINUE
13038 IF(ABS(PEMV).LT.1D-10) THEN
13039 MINT(51)=1
13040 MINT(57)=MINT(57)+1
13041 RETURN
13042 ENDIF
13043 PZCH=-PEEX/PEMV
13044 P(N+1,3)=P(N+1,3)+PZCH
13045 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)
13046 DO 310 I=N+2,NCOP
13047 P(I,3)=P(I,3)+V(I,1)*PZCH
13048 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
13049 310 CONTINUE
13050 IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290
13051
13052C...Modify momenta in event record.
13053 HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/
13054 & ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2)
13055 IF(ABS(HBE).GE.1D0) THEN
13056 MINT(51)=1
13057 MINT(57)=MINT(57)+1
13058 RETURN
13059 ENDIF
13060 I=MINT(83)+5-LESD
13061 CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE)
13062 DO 330 I=N+1,NCOP
13063 ICOP=K(I,3)
13064 DO 320 J=1,4
13065 P(ICOP,J)=P(I,J)
13066 320 CONTINUE
13067 330 CONTINUE
13068 ENDIF
13069
13070C...Check minimum invariant mass of remnant system(s).
13071 PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152))
13072 PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152))
13073 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
13074 PMIN(0)=SQRT(PMS(0))
13075 DO 340 JT=1,2
13076 PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT)
13077 PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1)
13078 PMIN(JT)=0D0
13079 IF(MINT(44+JT).EQ.1) GOTO 340
13080 MINT(105)=MINT(102+JT)
13081 MINT(109)=MINT(106+JT)
13082 CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
13083 IF(MINT(51).NE.0) THEN
13084 MINT(57)=MINT(57)+1
13085 RETURN
13086 ENDIF
13087 IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT))
13088 IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT))
13089 IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111)
13090 PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+
13091 & P(MINT(83)+JT+2,2)**2)
13092 340 CONTINUE
13093 IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND.
13094 &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT.
13095 &PSYS(2,4))) THEN
13096 MINT(51)=1
13097 MINT(57)=MINT(57)+1
13098 RETURN
13099 ENDIF
13100
13101C...Loop over two remnants; skip if none there.
13102 I=NS
13103 DO 410 JT=1,2
13104 ISN(JT)=0
13105 IF(MINT(44+JT).EQ.1) GOTO 410
13106 IF(JT.EQ.1) IPU=IPU1
13107 IF(JT.EQ.2) IPU=IPU2
13108
13109C...Store first remnant parton.
13110 I=I+1
13111 IS(JT)=I
13112 ISN(JT)=1
13113 DO 350 J=1,5
13114 K(I,J)=0
13115 P(I,J)=0D0
13116 V(I,J)=0D0
13117 350 CONTINUE
13118 K(I,1)=1
13119 K(I,2)=KFLSP(JT)
13120 K(I,3)=MINT(83)+JT
13121 P(I,5)=PYMASS(K(I,2))
13122
13123C...First parton colour connections and kinematics.
13124 KCOL=KCHG(PYCOMP(KFLSP(JT)),2)
13125 IF(KCOL.EQ.2) THEN
13126 K(I,1)=3
13127 K(I,4)=MSTU(5)*IPU+IPU
13128 K(I,5)=MSTU(5)*IPU+IPU
13129 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
13130 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
13131 ELSEIF(KCOL.NE.0) THEN
13132 K(I,1)=3
13133 KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2
13134 K(I,KFLS+3)=IPU
13135 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
13136 ENDIF
13137 IF(KFLCH(JT).EQ.0) THEN
13138 P(I,1)=-P(MINT(83)+JT+2,1)
13139 P(I,2)=-P(MINT(83)+JT+2,2)
13140 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
13141 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
13142 P(I,3)=PSYS(JT,3)
13143 P(I,4)=PSYS(JT,4)
13144
13145C...When extra remnant parton or hadron: store extra remnant.
13146 ELSE
13147 I=I+1
13148 ISN(JT)=2
13149 DO 360 J=1,5
13150 K(I,J)=0
13151 P(I,J)=0D0
13152 V(I,J)=0D0
13153 360 CONTINUE
13154 K(I,1)=1
13155 K(I,2)=KFLCH(JT)
13156 K(I,3)=MINT(83)+JT
13157 P(I,5)=PYMASS(K(I,2))
13158
13159C...Find parton colour connections of extra remnant.
13160 KCOL=KCHG(PYCOMP(KFLCH(JT)),2)
13161 IF(KCOL.EQ.2) THEN
13162 K(I,1)=3
13163 K(I,4)=MSTU(5)*IPU+IPU
13164 K(I,5)=MSTU(5)*IPU+IPU
13165 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
13166 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
13167 ELSEIF(KCOL.NE.0) THEN
13168 K(I,1)=3
13169 KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2
13170 K(I,KFLS+3)=IPU
13171 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
13172 ENDIF
13173
13174C...Relative transverse momentum when two remnants.
13175 LOOP=0
13176 370 LOOP=LOOP+1
13177 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
13178 IF(IABS(MINT(10+JT)).LT.20) THEN
13179 P(I-1,1)=0D0
13180 P(I-1,2)=0D0
13181 ELSE
13182 P(I-1,1)=P(I-1,1)-0.5D0*P(MINT(83)+JT+2,1)
13183 P(I-1,2)=P(I-1,2)-0.5D0*P(MINT(83)+JT+2,2)
13184 ENDIF
13185 PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
13186 P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
13187 P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
13188 PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
13189
13190C...Meson or baryon; photon as meson. For splitup below.
13191 IMB=1
13192 IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
13193
13194C***Relative distribution for electron into two electrons. Temporary!
13195 IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT))
13196 & THEN
13197 CHI(JT)=PYR(0)
13198
13199C...Relative distribution of electron energy into electron plus parton.
13200 ELSEIF(IABS(MINT(10+JT)).LT.20) THEN
13201 XHRD=VINT(140+JT)
13202 XE=VINT(154+JT)
13203 CHI(JT)=(XE-XHRD)/(1D0-XHRD)
13204
13205C...Relative distribution of energy for particle into two jets.
13206 ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
13207 CHIK=PARP(92+2*IMB)
13208 IF(MSTP(92).LE.1) THEN
13209 IF(IMB.EQ.1) CHI(JT)=PYR(0)
13210 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
13211 ELSEIF(MSTP(92).EQ.2) THEN
13212 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK))
13213 ELSEIF(MSTP(92).EQ.3) THEN
13214 CUT=2D0*0.3D0/VINT(1)
13215 380 CHI(JT)=PYR(0)**2
13216 IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0*
13217 & (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380
13218 ELSEIF(MSTP(92).EQ.4) THEN
13219 CUT=2D0*0.3D0/VINT(1)
13220 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
13221 390 CHIR=CUT*CUTR**PYR(0)
13222 CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR)
13223 IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390
13224 ELSE
13225 CUT=2D0*0.3D0/VINT(1)
13226 CUTA=CUT**(1D0-PARP(98))
13227 CUTB=(1D0+CUT)**(1D0-PARP(98))
13228 400 CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
13229 IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))**
13230 & (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400
13231 ENDIF
13232
13233C...Relative distribution of energy for particle into jet plus particle.
13234 ELSE
13235 IF(MSTP(94).LE.1) THEN
13236 IF(IMB.EQ.1) CHI(JT)=PYR(0)
13237 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
13238 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
13239 ELSEIF(MSTP(94).EQ.2) THEN
13240 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
13241 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
13242 ELSEIF(MSTP(94).EQ.3) THEN
13243 CALL PYZDIS(1,0,PMS(JT+4),ZZ)
13244 CHI(JT)=ZZ
13245 ELSE
13246 CALL PYZDIS(1000,0,PMS(JT+4),ZZ)
13247 CHI(JT)=ZZ
13248 ENDIF
13249 ENDIF
13250
13251C...Construct total transverse mass; reject if too large.
13252 CHI(JT)=MAX(1D-8,MIN(1D0-1D-8,CHI(JT)))
13253 PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT))
13254 IF(PMS(JT).GT.PSYS(JT,4)**2) THEN
13255 IF(LOOP.LT.10) THEN
13256 GOTO 370
13257 ELSE
13258 MINT(51)=1
13259 MINT(57)=MINT(57)+1
13260 RETURN
13261 ENDIF
13262 ENDIF
13263 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
13264 VINT(158+JT)=CHI(JT)
13265
13266C...Subdivide longitudinal momentum according to value selected above.
13267 PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3)))
13268 P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1)
13269 P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
13270 P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4)
13271 P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3)
13272 ENDIF
13273 410 CONTINUE
13274 N=I
13275
13276C...Check if longitudinal boosts needed - if so pick two systems.
13277 PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+
13278 &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3))
13279 IF(PDEV.LE.1D-6*VINT(1)) RETURN
13280 IF(ISN(1).EQ.0) THEN
13281 IR=0
13282 IL=2
13283 ELSEIF(ISN(2).EQ.0) THEN
13284 IR=1
13285 IL=0
13286 ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN
13287 IR=1
13288 IL=2
13289 ELSEIF(VINT(143).GT.0.2D0) THEN
13290 IR=1
13291 IL=0
13292 ELSEIF(VINT(144).GT.0.2D0) THEN
13293 IR=0
13294 IL=2
13295 ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN
13296 IR=1
13297 IL=0
13298 ELSE
13299 IR=0
13300 IL=2
13301 ENDIF
13302 IG=3-IR-IL
13303
13304C...E+-pL wanted for system to be modified.
13305 IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN
13306 PPB=VINT(1)
13307 PNB=VINT(1)
13308 ELSE
13309 PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3))
13310 PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3))
13311 ENDIF
13312
13313C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
13314 IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN
13315 PMTB=PPB*PNB
13316 PMTR=PMS(IR)
13317 PMTL=PMS(IL)
13318 SQLAM=SQRT(MAX(0D0,(PMTB-PMTR-PMTL)**2-4D0*PMTR*PMTL))
13319 SQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
13320 RKR=(PMTB+PMTR-PMTL+SQLAM*SQSGN)/(2D0*(PSYS(IR,4)+PSYS(IR,3))
13321 & *PNB)
13322 RKL=(PMTB+PMTL-PMTR+SQLAM*SQSGN)/(2D0*(PSYS(IL,4)-PSYS(IL,3))
13323 & *PPB)
13324 BER=(RKR**2-1D0)/(RKR**2+1D0)
13325 BEL=-(RKL**2-1D0)/(RKL**2+1D0)
13326 PPB=PPB-(PSYS(0,4)+PSYS(0,3))
13327 PNB=PNB-(PSYS(0,4)-PSYS(0,3))
13328 DO 420 J=1,4
13329 PSYS(0,J)=0D0
13330 420 CONTINUE
13331 DO 450 I=MINT(84)+1,NS
13332 IF(K(I,1).GT.10) GOTO 450
13333 INCL=0
13334 IORIG=I
13335 430 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
13336 IORIG=K(IORIG,3)
13337 IF(IORIG.GT.LPIN) GOTO 430
13338 IF(INCL.EQ.0) GOTO 450
13339 DO 440 J=1,4
13340 PSYS(0,J)=PSYS(0,J)+P(I,J)
13341 440 CONTINUE
13342 450 CONTINUE
13343 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
13344 PPB=PPB+(PSYS(0,4)+PSYS(0,3))
13345 PNB=PNB+(PSYS(0,4)-PSYS(0,3))
13346 ENDIF
13347
13348C...Construct longitudinal boosts.
13349 DPMTB=PPB*PNB
13350 DPMTR=PMS(IR)
13351 DPMTL=PMS(IL)
13352 DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL))
13353 IF(DSQLAM.LE.1D-6*DPMTB) THEN
13354 MINT(51)=1
13355 MINT(57)=MINT(57)+1
13356 RETURN
13357 ENDIF
13358 DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
13359 DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/
13360 &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB)
13361 DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/
13362 &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB)
13363 DBER=(DRKR**2-1D0)/(DRKR**2+1D0)
13364 DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0)
13365
13366C...Perform longitudinal boosts.
13367 IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN
13368 P(IS(1),3)=0D0
13369 P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2)
13370 ELSEIF(IR.EQ.1) THEN
13371 CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER)
13372 ELSEIF(IDISXQ.EQ.1) THEN
13373 DO 470 I=I1,NS
13374 INCL=0
13375 IORIG=I
13376 460 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
13377 IORIG=K(IORIG,3)
13378 IF(IORIG.GT.LPIN) GOTO 460
13379 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER)
13380 470 CONTINUE
13381 ELSE
13382 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER)
13383 ENDIF
13384 IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN
13385 P(IS(2),3)=0D0
13386 P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2)
13387 ELSEIF(IL.EQ.2) THEN
13388 CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL)
13389 ELSEIF(IDISXQ.EQ.1) THEN
13390 DO 490 I=I1,NS
13391 INCL=0
13392 IORIG=I
13393 480 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
13394 IORIG=K(IORIG,3)
13395 IF(IORIG.GT.LPIN) GOTO 480
13396 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL)
13397 490 CONTINUE
13398 ELSE
13399 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL)
13400 ENDIF
13401
13402C...Final check that energy-momentum conservation worked.
13403 PESUM=0D0
13404 PZSUM=0D0
13405 DO 500 I=MINT(84)+1,N
13406 IF(K(I,1).GT.10) GOTO 500
13407 PESUM=PESUM+P(I,4)
13408 PZSUM=PZSUM+P(I,3)
13409 500 CONTINUE
13410 PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM)
13411 IF(PDEV.GT.1D-4*VINT(1)) THEN
13412 MINT(51)=1
13413 MINT(57)=MINT(57)+1
13414 RETURN
13415 ENDIF
13416
13417C...Calculate rotation and boost from overall CM frame to
13418C...hadronic CM frame in leptoproduction.
13419 MINT(91)=0
13420 IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
13421 MINT(91)=1
13422 LESD=1
13423 IF(MINT(42).EQ.1) LESD=2
13424 LPIN=MINT(83)+3-LESD
13425
13426C...Sum upp momenta of everything not lepton or photon to define boost.
13427 DO 510 J=1,4
13428 PSUM(J)=0D0
13429 510 CONTINUE
13430 DO 530 I=1,N
13431 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
13432 IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
13433 IF(K(I,2).EQ.22) GOTO 530
13434 DO 520 J=1,4
13435 PSUM(J)=PSUM(J)+P(I,J)
13436 520 CONTINUE
13437 530 CONTINUE
13438 VINT(223)=-PSUM(1)/PSUM(4)
13439 VINT(224)=-PSUM(2)/PSUM(4)
13440 VINT(225)=-PSUM(3)/PSUM(4)
13441
13442C...Boost incoming hadron to hadronic CM frame to determine rotations.
13443 K(N+1,1)=1
13444 DO 540 J=1,5
13445 P(N+1,J)=P(LPIN,J)
13446 V(N+1,J)=V(LPIN,J)
13447 540 CONTINUE
13448 CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
13449 VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
13450 CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
13451 IF(LESD.EQ.2) THEN
13452 VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
13453 ELSE
13454 VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
13455 ENDIF
13456 ENDIF
13457
13458 RETURN
13459 END
13460
13461C*********************************************************************
13462
13463C...PYDIFF
13464C...Handles diffractive and elastic scattering.
13465
13466 SUBROUTINE PYDIFF
13467
13468C...Double precision and integer declarations.
13469 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
13470 IMPLICIT INTEGER(I-N)
13471 INTEGER PYK,PYCHGE,PYCOMP
13472C...Commonblocks.
13473 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
13474 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13475 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13476 COMMON/PYINT1/MINT(400),VINT(400)
13477 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
13478
13479C...Reset K, P and V vectors. Store incoming particles.
13480 DO 110 JT=1,MSTP(126)+10
13481 I=MINT(83)+JT
13482 DO 100 J=1,5
13483 K(I,J)=0
13484 P(I,J)=0D0
13485 V(I,J)=0D0
13486 100 CONTINUE
13487 110 CONTINUE
13488 N=MINT(84)
13489 MINT(3)=0
13490 MINT(21)=0
13491 MINT(22)=0
13492 MINT(23)=0
13493 MINT(24)=0
13494 MINT(4)=4
13495 DO 130 JT=1,2
13496 I=MINT(83)+JT
13497 K(I,1)=21
13498 K(I,2)=MINT(10+JT)
13499 DO 120 J=1,5
13500 P(I,J)=VINT(285+5*JT+J)
13501 120 CONTINUE
13502 130 CONTINUE
13503 MINT(6)=2
13504
13505C...Subprocess; kinematics.
13506 SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64)
13507 PZ=SQRT(SQLAM)/(2D0*VINT(1))
13508 DO 200 JT=1,2
13509 I=MINT(83)+JT
13510 PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1))
13511 KFH=MINT(102+JT)
13512
13513C...Elastically scattered particle. (Except elastic GVMD states.)
13514 IF(MINT(16+JT).LE.0.AND.(MINT(10+JT).NE.22.OR.
13515 & MINT(106+JT).NE.3)) THEN
13516 N=N+1
13517 K(N,1)=1
13518 K(N,2)=KFH
13519 K(N,3)=I+2
13520 P(N,3)=PZ*(-1)**(JT+1)
13521 P(N,4)=PE
13522 P(N,5)=SQRT(VINT(62+JT))
13523
13524C...Decay rho from elastic scattering of gamma with sin**2(theta)
13525C...distribution of decay products (in rho rest frame).
13526 IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN
13527 NSAV=N
13528 DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2)
13529 P(N,3)=0D0
13530 P(N,4)=P(N,5)
13531 CALL PYDECY(NSAV)
13532 IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN
13533 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
13534 CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0)
13535 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
13536 CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0)
13537 140 CTHE=2D0*PYR(0)-1D0
13538 IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140
13539 CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0)
13540 ENDIF
13541 CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ)
13542 ENDIF
13543
13544C...Diffracted particle: low-mass system to two particles.
13545 ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN
13546 N=N+2
13547 K(N-1,1)=1
13548 K(N,1)=1
13549 K(N-1,3)=I+2
13550 K(N,3)=I+2
13551 PMMAS=SQRT(VINT(62+JT))
13552 NTRY=0
13553 150 NTRY=NTRY+1
13554 IF(NTRY.LT.20) THEN
13555 MINT(105)=MINT(102+JT)
13556 MINT(109)=MINT(106+JT)
13557 CALL PYSPLI(KFH,21,KFL1,KFL2)
13558 CALL PYKFDI(KFL1,0,KFL3,KF1)
13559 IF(KF1.EQ.0) GOTO 150
13560 CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2)
13561 IF(KF2.EQ.0) GOTO 150
13562 ELSE
13563 KF1=KFH
13564 KF2=111
13565 ENDIF
13566 PM1=PYMASS(KF1)
13567 PM2=PYMASS(KF2)
13568 IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150
13569 K(N-1,2)=KF1
13570 K(N,2)=KF2
13571 P(N-1,5)=PM1
13572 P(N,5)=PM2
13573 PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2-
13574 & 4D0*PM1**2*PM2**2))/(2D0*PMMAS)
13575 P(N-1,3)=PZP
13576 P(N,3)=-PZP
13577 P(N-1,4)=SQRT(PM1**2+PZP**2)
13578 P(N,4)=SQRT(PM2**2+PZP**2)
13579 CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0),
13580 & 0D0,0D0,0D0)
13581 DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2)
13582 CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ)
13583
13584C...Diffracted particle: valence quark kicked out.
13585 ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT.
13586 & PARP(101))) THEN
13587 N=N+2
13588 K(N-1,1)=2
13589 K(N,1)=1
13590 K(N-1,3)=I+2
13591 K(N,3)=I+2
13592 MINT(105)=MINT(102+JT)
13593 MINT(109)=MINT(106+JT)
13594 CALL PYSPLI(KFH,21,K(N,2),K(N-1,2))
13595 P(N-1,5)=PYMASS(K(N-1,2))
13596 P(N,5)=PYMASS(K(N,2))
13597 SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
13598 & 4D0*P(N-1,5)**2*P(N,5)**2
13599 P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
13600 & P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1)
13601 P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
13602 P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
13603 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
13604
13605C...Diffracted particle: gluon kicked out.
13606 ELSE
13607 N=N+3
13608 K(N-2,1)=2
13609 K(N-1,1)=2
13610 K(N,1)=1
13611 K(N-2,3)=I+2
13612 K(N-1,3)=I+2
13613 K(N,3)=I+2
13614 MINT(105)=MINT(102+JT)
13615 MINT(109)=MINT(106+JT)
13616 CALL PYSPLI(KFH,21,K(N,2),K(N-2,2))
13617 K(N-1,2)=21
13618 P(N-2,5)=PYMASS(K(N-2,2))
13619 P(N-1,5)=0D0
13620 P(N,5)=PYMASS(K(N,2))
13621C...Energy distribution for particle into two jets.
13622 160 IMB=1
13623 IF(MOD(KFH/1000,10).NE.0) IMB=2
13624 CHIK=PARP(92+2*IMB)
13625 IF(MSTP(92).LE.1) THEN
13626 IF(IMB.EQ.1) CHI=PYR(0)
13627 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
13628 ELSEIF(MSTP(92).EQ.2) THEN
13629 CHI=1D0-PYR(0)**(1D0/(1D0+CHIK))
13630 ELSEIF(MSTP(92).EQ.3) THEN
13631 CUT=2D0*0.3D0/VINT(1)
13632 170 CHI=PYR(0)**2
13633 IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT.
13634 & PYR(0)) GOTO 170
13635 ELSEIF(MSTP(92).EQ.4) THEN
13636 CUT=2D0*0.3D0/VINT(1)
13637 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
13638 180 CHIR=CUT*CUTR**PYR(0)
13639 CHI=(CHIR**2-CUT**2)/(2D0*CHIR)
13640 IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180
13641 ELSE
13642 CUT=2D0*0.3D0/VINT(1)
13643 CUTA=CUT**(1D0-PARP(98))
13644 CUTB=(1D0+CUT)**(1D0-PARP(98))
13645 190 CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
13646 IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))**
13647 & (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
13648 ENDIF
13649 IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/
13650 & VINT(62+JT)) GOTO 160
13651 SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI
13652 PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
13653 & (2D0*VINT(62+JT))
13654 PEI=SQRT(PZI**2+SQM)
13655 PQQP=(1D0-CHI)*(PEI+PZI)
13656 P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
13657 P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
13658 P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
13659 P(N-1,3)=P(N-1,4)*(-1)**JT
13660 P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
13661 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
13662 ENDIF
13663
13664C...Documentation lines.
13665 K(I+2,1)=21
13666 IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
13667 IF(MINT(16+JT).NE.0.OR.(MINT(10+JT).EQ.22.AND.
13668 & MINT(106+JT).EQ.3)) K(I+2,2)=10*(KFH/10)
13669 K(I+2,3)=I
13670 P(I+2,3)=PZ*(-1)**(JT+1)
13671 P(I+2,4)=PE
13672 P(I+2,5)=SQRT(VINT(62+JT))
13673 200 CONTINUE
13674
13675C...Rotate outgoing partons/particles using cos(theta).
13676 IF(VINT(23).LT.0.9D0) THEN
13677 CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
13678 ELSE
13679 CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
13680 ENDIF
13681
13682 RETURN
13683 END
13684
13685C*********************************************************************
13686
13687C...PYDISG
13688C...Set up a DIS process as gamma* + f -> f, with beam remnant
13689C...and showering added consecutively. Photon flux by the PYGAGA
13690C...routine (if at all).
13691
13692 SUBROUTINE PYDISG
13693
13694C...Double precision and integer declarations.
13695 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
13696 IMPLICIT INTEGER(I-N)
13697 INTEGER PYK,PYCHGE,PYCOMP
13698C...Parameter statement to help give large particle numbers.
13699 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
13700C...Commonblocks.
13701 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
13702 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13703 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
13704 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
13705 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13706 COMMON/PYINT1/MINT(400),VINT(400)
13707 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
13708C...Local arrays.
13709 DIMENSION PMS(4)
13710
13711C...Choice of subprocess, number of documentation lines
13712 IDOC=7
13713 MINT(3)=IDOC-6
13714 MINT(4)=IDOC
13715 IPU1=MINT(84)+1
13716 IPU2=MINT(84)+2
13717 IPU3=MINT(84)+3
13718 ISIDE=1
13719 IF(MINT(107).EQ.4) ISIDE=2
13720
13721C...Reset K, P and V vectors. Store incoming particles
13722 DO 120 JT=1,MSTP(126)+20
13723 I=MINT(83)+JT
13724 DO 110 J=1,5
13725 K(I,J)=0
13726 P(I,J)=0D0
13727 V(I,J)=0D0
13728 110 CONTINUE
13729 120 CONTINUE
13730 DO 140 JT=1,2
13731 I=MINT(83)+JT
13732 K(I,1)=21
13733 K(I,2)=MINT(10+JT)
13734 DO 130 J=1,5
13735 P(I,J)=VINT(285+5*JT+J)
13736 130 CONTINUE
13737 140 CONTINUE
13738 MINT(6)=2
13739
13740C...Store incoming partons in hadronic CM-frame
13741 DO 150 JT=1,2
13742 I=MINT(84)+JT
13743 K(I,1)=14
13744 K(I,2)=MINT(14+JT)
13745 K(I,3)=MINT(83)+2+JT
13746 150 CONTINUE
13747 IF(MINT(15).EQ.22) THEN
13748 P(MINT(84)+1,3)=0.5D0*(VINT(1)+VINT(307)/VINT(1))
13749 P(MINT(84)+1,4)=0.5D0*(VINT(1)-VINT(307)/VINT(1))
13750 P(MINT(84)+1,5)=-SQRT(VINT(307))
13751 P(MINT(84)+2,3)=-0.5D0*VINT(307)/VINT(1)
13752 P(MINT(84)+2,4)=0.5D0*VINT(307)/VINT(1)
13753 KFRES=MINT(16)
13754 ISIDE=2
13755 ELSE
13756 P(MINT(84)+1,3)=0.5D0*VINT(308)/VINT(1)
13757 P(MINT(84)+1,4)=0.5D0*VINT(308)/VINT(1)
13758 P(MINT(84)+2,3)=-0.5D0*(VINT(1)+VINT(308)/VINT(1))
13759 P(MINT(84)+2,4)=0.5D0*(VINT(1)-VINT(308)/VINT(1))
13760 P(MINT(84)+1,5)=-SQRT(VINT(308))
13761 KFRES=MINT(15)
13762 ISIDE=1
13763 ENDIF
13764 SIDESG=(-1D0)**(ISIDE-1)
13765
13766C...Copy incoming partons to documentation lines.
13767 DO 170 JT=1,2
13768 I1=MINT(83)+4+JT
13769 I2=MINT(84)+JT
13770 K(I1,1)=21
13771 K(I1,2)=K(I2,2)
13772 K(I1,3)=I1-2
13773 DO 160 J=1,5
13774 P(I1,J)=P(I2,J)
13775 160 CONTINUE
13776
13777C...Second copy for partons before ISR shower, since no such.
13778 I1=MINT(83)+2+JT
13779 K(I1,1)=21
13780 K(I1,2)=K(I2,2)
13781 K(I1,3)=I1-2
13782 DO 165 J=1,5
13783 P(I1,J)=P(I2,J)
13784 165 CONTINUE
13785 170 CONTINUE
13786
13787C...Define initial partons.
13788 NTRY=0
13789 200 NTRY=NTRY+1
13790 IF(NTRY.GT.100) THEN
13791 MINT(51)=1
13792 RETURN
13793 ENDIF
13794
13795C...Scattered quark in hadronic CM frame.
13796 I=MINT(83)+7
13797 K(IPU3,1)=3
13798 K(IPU3,2)=KFRES
13799 K(IPU3,3)=I
13800 P(IPU3,5)=PYMASS(KFRES)
13801 P(IPU3,3)=P(IPU1,3)+P(IPU2,3)
13802 P(IPU3,4)=P(IPU1,4)+P(IPU2,4)
13803 P(IPU3,5)=0D0
13804 K(I,1)=21
13805 K(I,2)=KFRES
13806 K(I,3)=MINT(83)+4+ISIDE
13807 P(I,3)=P(IPU3,3)
13808 P(I,4)=P(IPU3,4)
13809 P(I,5)=P(IPU3,5)
13810 N=IPU3
13811 MINT(21)=KFRES
13812 MINT(22)=0
13813
13814C...No primordial kT, or chosen according to truncated Gaussian or
13815C...exponential, or (for photon) predetermined or power law.
13816 220 IF(MINT(40+ISIDE).EQ.2.AND.MINT(10+ISIDE).NE.22) THEN
13817 IF(MSTP(91).LE.0) THEN
13818 PT=0D0
13819 ELSEIF(MSTP(91).EQ.1) THEN
13820 PT=PARP(91)*SQRT(-LOG(PYR(0)))
13821 ELSE
13822 RPT1=PYR(0)
13823 RPT2=PYR(0)
13824 PT=-PARP(92)*LOG(RPT1*RPT2)
13825 ENDIF
13826 IF(PT.GT.PARP(93)) GOTO 220
13827 ELSEIF(MINT(106+ISIDE).EQ.3) THEN
13828 PTA=SQRT(VINT(282+ISIDE))
13829 PTB=0D0
13830 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
13831 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
13832 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
13833 RPT1=PYR(0)
13834 RPT2=PYR(0)
13835 PTB=-PARP(99)*LOG(RPT1*RPT2)
13836 ENDIF
13837 IF(PTB.GT.PARP(100)) GOTO 220
13838 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
13839 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
13840 ELSEIF(IABS(MINT(14+ISIDE)).LE.8.OR.MINT(14+ISIDE).EQ.21) THEN
13841 IF(MSTP(93).LE.0) THEN
13842 PT=0D0
13843 ELSEIF(MSTP(93).EQ.1) THEN
13844 PT=PARP(99)*SQRT(-LOG(PYR(0)))
13845 ELSEIF(MSTP(93).EQ.2) THEN
13846 RPT1=PYR(0)
13847 RPT2=PYR(0)
13848 PT=-PARP(99)*LOG(RPT1*RPT2)
13849 ELSEIF(MSTP(93).EQ.3) THEN
13850 HA=PARP(99)**2
13851 HB=PARP(100)**2
13852 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
13853 ELSE
13854 HA=PARP(99)**2
13855 HB=PARP(100)**2
13856 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
13857 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
13858 ENDIF
13859 IF(PT.GT.PARP(100)) GOTO 220
13860 ELSE
13861 PT=0D0
13862 ENDIF
13863 VINT(156+ISIDE)=PT
13864 PHI=PARU(2)*PYR(0)
13865 P(IPU3,1)=PT*COS(PHI)
13866 P(IPU3,2)=PT*SIN(PHI)
13867 P(IPU3,4)=SQRT(P(IPU3,5)**2+PT**2+P(IPU3,3)**2)
13868 PMS(3-ISIDE)=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
13869 PCP=P(IPU3,4)+ABS(P(IPU3,3))
13870
13871C...Find one or two beam remnants.
13872 MINT(105)=MINT(102+ISIDE)
13873 MINT(109)=MINT(106+ISIDE)
13874 CALL PYSPLI(MINT(10+ISIDE),MINT(12+ISIDE),KFLCH,KFLSP)
13875 IF(MINT(51).NE.0) THEN
13876 MINT(51)=0
13877 GOTO 200
13878 ENDIF
13879
13880C...Store first remnant parton, with colour info and kinematics.
13881 I=N+1
13882 K(I,1)=1
13883 K(I,2)=KFLSP
13884 K(I,3)=MINT(83)+ISIDE
13885 P(I,5)=PYMASS(K(I,2))
13886 KCOL=KCHG(PYCOMP(KFLSP),2)
13887 IF(KCOL.NE.0) THEN
13888 K(I,1)=3
13889 KFLS=(3-KCOL*ISIGN(1,KFLSP))/2
13890 K(I,KFLS+3)=MSTU(5)*IPU3
13891 K(IPU3,6-KFLS)=MSTU(5)*I
13892 ICOLR=I
13893 ENDIF
13894 IF(KFLCH.EQ.0) THEN
13895 P(I,1)=-P(IPU3,1)
13896 P(I,2)=-P(IPU3,2)
13897 PMS(ISIDE)=P(I,5)**2+P(I,1)**2+P(I,2)**2
13898 P(I,3)=-P(IPU3,3)
13899 P(I,4)=SQRT(PMS(ISIDE)+P(I,3)**2)
13900 PRP=P(I,4)+ABS(P(I,3))
13901
13902C...When extra remnant parton or hadron: store extra remnant.
13903 ELSE
13904 I=I+1
13905 K(I,1)=1
13906 K(I,2)=KFLCH
13907 K(I,3)=MINT(83)+ISIDE
13908 P(I,5)=PYMASS(K(I,2))
13909 KCOL=KCHG(PYCOMP(KFLCH),2)
13910 IF(KCOL.NE.0) THEN
13911 K(I,1)=3
13912 KFLS=(3-KCOL*ISIGN(1,KFLCH))/2
13913 K(I,KFLS+3)=MSTU(5)*IPU3
13914 K(IPU3,6-KFLS)=MSTU(5)*I
13915 ICOLR=I
13916 ENDIF
13917
13918C...Relative transverse momentum when two remnants.
13919 LOOP=0
13920 370 LOOP=LOOP+1
13921 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
13922 P(I-1,1)=P(I-1,1)-0.5D0*P(IPU3,1)
13923 P(I-1,2)=P(I-1,2)-0.5D0*P(IPU3,2)
13924 PMS(3)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
13925 P(I,1)=-P(IPU3,1)-P(I-1,1)
13926 P(I,2)=-P(IPU3,2)-P(I-1,2)
13927 PMS(4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
13928
13929C...Relative distribution of energy for particle into jet plus particle.
13930 IMB=1
13931 IF(MOD(MINT(10+ISIDE)/1000,10).NE.0) IMB=2
13932 IF(MSTP(94).LE.1) THEN
13933 IF(IMB.EQ.1) CHI=PYR(0)
13934 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
13935 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
13936 ELSEIF(MSTP(94).EQ.2) THEN
13937 CHI=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
13938 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
13939 ELSEIF(MSTP(94).EQ.3) THEN
13940 CALL PYZDIS(1,0,PMS(4),ZZ)
13941 CHI=ZZ
13942 ELSE
13943 CALL PYZDIS(1000,0,PMS(4),ZZ)
13944 CHI=ZZ
13945 ENDIF
13946
13947C...Construct total transverse mass; reject if too large.
13948 CHI=MAX(1D-8,MIN(1D0-1D-8,CHI))
13949 PMS(ISIDE)=PMS(4)/CHI+PMS(3)/(1D0-CHI)
13950 IF(PMS(ISIDE).GT.P(IPU3,4)**2) THEN
13951 IF(LOOP.LT.10) GOTO 370
13952 GOTO 200
13953 ENDIF
13954 VINT(158+ISIDE)=CHI
13955
13956C...Subdivide longitudinal momentum according to value selected above.
13957 PRP=SQRT(PMS(ISIDE)+P(IPU3,3)**2)+ABS(P(IPU3,3))
13958 PW1=(1D0-CHI)*PRP
13959 P(I-1,4)=0.5D0*(PW1+PMS(3)/PW1)
13960 P(I-1,3)=0.5D0*(PW1-PMS(3)/PW1)*SIDESG
13961 PW2=CHI*PRP
13962 P(I,4)=0.5D0*(PW2+PMS(4)/PW2)
13963 P(I,3)=0.5D0*(PW2-PMS(4)/PW2)*SIDESG
13964 ENDIF
13965 N=I
13966
13967C...Boost current and remnant systems to correct frame.
13968 IF(SQRT(PMS(1))+SQRT(PMS(2)).GT.0.99D0*VINT(1)) GOTO 200
13969 DSQLAM=SQRT(MAX(0D0,(VINT(2)-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2)))
13970 DRKC=(VINT(2)+PMS(3-ISIDE)-PMS(ISIDE)+DSQLAM)/
13971 &(2D0*VINT(1)*PCP)
13972 DRKR=(VINT(2)+PMS(ISIDE)-PMS(3-ISIDE)+DSQLAM)/
13973 &(2D0*VINT(1)*PRP)
13974 DBEC=-SIDESG*(DRKC**2-1D0)/(DRKC**2+1D0)
13975 DBER=SIDESG*(DRKR**2-1D0)/(DRKR**2+1D0)
13976 CALL PYROBO(IPU3,IPU3,0D0,0D0,0D0,0D0,DBEC)
13977 CALL PYROBO(IPU3+1,N,0D0,0D0,0D0,0D0,DBER)
13978
13979C...Let current quark shower; recoil but no showering by colour partner.
13980 QMAX=SQRT(VINT(309-ISIDE))
13981 MSTJ48=MSTJ(48)
13982 MSTJ(48)=1
13983 PARJ86=PARJ(86)
13984 PARJ(86)=0D0
13985 IF(MSTP(71).EQ.1) CALL PYSHOW(IPU3,ICOLR,QMAX)
13986 MSTJ(48)=MSTJ48
13987 PARJ(86)=PARJ86
13988
13989 RETURN
13990 END
13991
13992C*********************************************************************
13993
13994C...PYDOCU
13995C...Handles the documentation of the process in MSTI and PARI,
13996C...and also computes cross-sections based on accumulated statistics.
13997
13998 SUBROUTINE PYDOCU
13999
14000C...Double precision and integer declarations.
14001 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14002 IMPLICIT INTEGER(I-N)
14003 INTEGER PYK,PYCHGE,PYCOMP
14004C...Commonblocks.
14005 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14006 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14007 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14008 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
14009 COMMON/PYINT1/MINT(400),VINT(400)
14010 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
14011 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
14012 SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
14013 &/PYINT5/
14014
14015C...Calculate Monte Carlo estimates of cross-sections.
14016 ISUB=MINT(1)
14017 IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
14018 NGEN(0,3)=NGEN(0,3)+1
14019 XSEC(0,3)=0D0
14020 DO 100 I=1,500
14021 IF(I.EQ.96.OR.I.EQ.97) THEN
14022 XSEC(I,3)=0D0
14023 ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
14024 & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
14025 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
14026 & DBLE(NGEN(96,2)))
14027 ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
14028 XSEC(I,3)=0D0
14029 ELSEIF(NGEN(I,2).EQ.0) THEN
14030 XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))*
14031 & DBLE(NGEN(0,2)))
14032 ELSE
14033 XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))*
14034 & DBLE(NGEN(I,2)))
14035 ENDIF
14036 XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
14037 100 CONTINUE
14038
14039C...Rescale to known low-pT cross-section for standard QCD processes.
14040 IF(MSUB(95).EQ.1) THEN
14041 XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
14042 & XSEC(68,3)+XSEC(95,3)
14043 XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
14044 IF(XSECH.GT.1D-20.AND.XSECW.GT.1D-20) THEN
14045 FAC=XSECW/XSECH
14046 XSEC(11,3)=FAC*XSEC(11,3)
14047 XSEC(12,3)=FAC*XSEC(12,3)
14048 XSEC(13,3)=FAC*XSEC(13,3)
14049 XSEC(28,3)=FAC*XSEC(28,3)
14050 XSEC(53,3)=FAC*XSEC(53,3)
14051 XSEC(68,3)=FAC*XSEC(68,3)
14052 XSEC(95,3)=FAC*XSEC(95,3)
14053 XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
14054 ENDIF
14055 ENDIF
14056
14057C...Save information for gamma-p and gamma-gamma.
14058 IF(MINT(121).GT.1) THEN
14059 IGA=MINT(122)
14060 CALL PYSAVE(2,IGA)
14061 CALL PYSAVE(5,0)
14062 ENDIF
14063
14064C...Reset information on hard interaction.
14065 DO 110 J=1,200
14066 MSTI(J)=0
14067 PARI(J)=0D0
14068 110 CONTINUE
14069
14070C...Copy integer valued information from MINT into MSTI.
14071 DO 120 J=1,32
14072 MSTI(J)=MINT(J)
14073 120 CONTINUE
14074 IF(MINT(121).GT.1) MSTI(9)=MINT(122)
14075
14076C...Store cross-section variables in PARI.
14077 PARI(1)=XSEC(0,3)
14078 PARI(2)=XSEC(0,3)/MINT(5)
14079 PARI(9)=VINT(99)
14080 PARI(10)=VINT(100)
14081 VINT(98)=VINT(98)+VINT(100)
14082 IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
14083
14084C...Store kinematics variables in PARI.
14085 PARI(11)=VINT(1)
14086 PARI(12)=VINT(2)
14087 IF(ISUB.NE.95) THEN
14088 DO 130 J=13,26
14089 PARI(J)=VINT(30+J)
14090 130 CONTINUE
14091 PARI(31)=VINT(141)
14092 PARI(32)=VINT(142)
14093 PARI(33)=VINT(41)
14094 PARI(34)=VINT(42)
14095 PARI(35)=PARI(33)-PARI(34)
14096 PARI(36)=VINT(21)
14097 PARI(37)=VINT(22)
14098 PARI(38)=VINT(26)
14099 PARI(39)=VINT(157)
14100 PARI(40)=VINT(158)
14101 PARI(41)=VINT(23)
14102 PARI(42)=2D0*VINT(47)/VINT(1)
14103 ENDIF
14104
14105C...Store information on scattered partons in PARI.
14106 IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
14107 DO 140 IS=7,8
14108 I=MINT(IS)
14109 PARI(36+IS)=P(I,3)/VINT(1)
14110 PARI(38+IS)=P(I,4)/VINT(1)
14111 PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
14112 PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
14113 & SQRT(PR),1D20)),P(I,3))
14114 PR=MAX(1D-20,P(I,1)**2+P(I,2)**2)
14115 PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
14116 & SQRT(PR),1D20)),P(I,3))
14117 PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2)
14118 PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
14119 PARI(48+IS)=PYANGL(P(I,1),P(I,2))
14120 140 CONTINUE
14121 ENDIF
14122
14123C...Store sum up transverse and longitudinal momenta.
14124 PARI(65)=2D0*PARI(17)
14125 IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
14126 DO 150 I=MSTP(126)+1,N
14127 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
14128 PT=SQRT(P(I,1)**2+P(I,2)**2)
14129 PARI(69)=PARI(69)+PT
14130 IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
14131 IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
14132 150 CONTINUE
14133 PARI(67)=PARI(68)
14134 PARI(71)=VINT(151)
14135 PARI(72)=VINT(152)
14136 PARI(73)=VINT(151)
14137 PARI(74)=VINT(152)
14138 ELSE
14139 PARI(66)=PARI(65)
14140 PARI(69)=PARI(65)
14141 ENDIF
14142
14143C...Store various other pieces of information into PARI.
14144 PARI(61)=VINT(148)
14145 PARI(75)=VINT(155)
14146 PARI(76)=VINT(156)
14147 PARI(77)=VINT(159)
14148 PARI(78)=VINT(160)
14149 PARI(81)=VINT(138)
14150
14151C...Store information on lepton -> lepton + gamma in PYGAGA.
14152 MSTI(71)=MINT(141)
14153 MSTI(72)=MINT(142)
14154 PARI(101)=VINT(301)
14155 PARI(102)=VINT(302)
14156 DO 160 I=103,114
14157 PARI(I)=VINT(I+202)
14158 160 CONTINUE
14159
14160C...Set information for PYTABU.
14161 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
14162 MSTU(161)=MINT(21)
14163 MSTU(162)=0
14164 ELSEIF(ISET(ISUB).EQ.5) THEN
14165 MSTU(161)=MINT(23)
14166 MSTU(162)=0
14167 ELSE
14168 MSTU(161)=MINT(21)
14169 MSTU(162)=MINT(22)
14170 ENDIF
14171
14172 RETURN
14173 END
14174
14175C*********************************************************************
14176
14177C...PYFRAM
14178C...Performs transformations between different coordinate frames.
14179
14180 SUBROUTINE PYFRAM(IFRAME)
14181
14182C...Double precision and integer declarations.
14183 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14184 IMPLICIT INTEGER(I-N)
14185 INTEGER PYK,PYCHGE,PYCOMP
14186C...Commonblocks.
14187 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14188 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14189 COMMON/PYINT1/MINT(400),VINT(400)
14190 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
14191
14192C...Check that transformation can and should be done.
14193 IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
14194 &MINT(91).EQ.1)) THEN
14195 IF(IFRAME.EQ.MINT(6)) RETURN
14196 ELSE
14197 WRITE(MSTU(11),5000) IFRAME,MINT(6)
14198 RETURN
14199 ENDIF
14200
14201 IF(MINT(6).EQ.1) THEN
14202C...Transform from fixed target or user specified frame to
14203C...overall CM frame.
14204 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
14205 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
14206 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
14207 ELSEIF(MINT(6).EQ.3) THEN
14208C...Transform from hadronic CM frame in DIS to overall CM frame.
14209 CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
14210 & -VINT(225))
14211 ENDIF
14212
14213 IF(IFRAME.EQ.1) THEN
14214C...Transform from overall CM frame to fixed target or user specified
14215C...frame.
14216 CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
14217 ELSEIF(IFRAME.EQ.3) THEN
14218C...Transform from overall CM frame to hadronic CM frame in DIS.
14219 CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
14220 CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
14221 CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
14222 ENDIF
14223
14224C...Set information about new frame.
14225 MINT(6)=IFRAME
14226 MSTI(6)=IFRAME
14227
14228 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
14229 &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
14230 &1X,I5)
14231
14232 RETURN
14233 END
14234
14235C*********************************************************************
14236
14237C...PYWIDT
14238C...Calculates full and partial widths of resonances.
14239
14240 SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
14241
14242C...Double precision and integer declarations.
14243 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14244 IMPLICIT INTEGER(I-N)
14245 INTEGER PYK,PYCHGE,PYCOMP
14246C...Parameter statement to help give large particle numbers.
14247 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
14248C...Commonblocks.
14249 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14250 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14251 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
14252 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
14253 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14254 COMMON/PYINT1/MINT(400),VINT(400)
14255 COMMON/PYINT4/MWID(500),WIDS(500,5)
14256 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
14257 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
14258 &SFMIX(16,4)
14259 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
14260 &/PYINT4/,/PYMSSM/,/PYSSMT/
14261C...Local arrays and saved variables.
14262 DIMENSION WDTP(0:200),WDTE(0:200,0:5),MOFSV(3,2),WIDWSV(3,2),
14263 &WID2SV(3,2),WDTPP(0:200),WDTEP(0:200,0:5)
14264 SAVE MOFSV,WIDWSV,WID2SV
14265 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
14266
14267C...Compressed code and sign; mass.
14268 KFLA=IABS(KFLR)
14269 KFLS=ISIGN(1,KFLR)
14270 KC=PYCOMP(KFLA)
14271 SHR=SQRT(SH)
14272 PMR=PMAS(KC,1)
14273
14274C...Reset width information.
14275 DO 110 I=0,200
14276 WDTP(I)=0D0
14277 DO 100 J=0,5
14278 WDTE(I,J)=0D0
14279 100 CONTINUE
14280 110 CONTINUE
14281
14282C...Not to be treated as a resonance: return.
14283 IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND.
14284 &KFLA.NE.22) THEN
14285 WDTP(0)=1D0
14286 WDTE(0,0)=1D0
14287 MINT(61)=0
14288 MINT(62)=0
14289 MINT(63)=0
14290 RETURN
14291
14292C...Treatment as a resonance based on tabulated branching ratios.
14293 ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN
14294C...Loop over possible decay channels; skip irrelevant ones.
14295 DO 120 I=1,MDCY(KC,3)
14296 IDC=I+MDCY(KC,2)-1
14297 IF(MDME(IDC,1).LT.0) GOTO 120
14298
14299C...Read out decay products and nominal masses.
14300 KFD1=KFDP(IDC,1)
14301 KFC1=PYCOMP(KFD1)
14302 IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1
14303 PM1=PMAS(KFC1,1)
14304 KFD2=KFDP(IDC,2)
14305 KFC2=PYCOMP(KFD2)
14306 IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2
14307 PM2=PMAS(KFC2,1)
14308 KFD3=KFDP(IDC,3)
14309 PM3=0D0
14310 IF(KFD3.NE.0) THEN
14311 KFC3=PYCOMP(KFD3)
14312 IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3
14313 PM3=PMAS(KFC3,1)
14314 ENDIF
14315
14316C...Naive partial width and alternative threshold factors.
14317 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)
14318 IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND.
14319 & PM1+PM2+PM3.GE.SHR) THEN
14320 WDTP(I)=0D0
14321 ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN
14322 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2-
14323 & 4D0*PM1**2*PM2**2))/SH
14324 ELSEIF(MDME(IDC,2).EQ.52) THEN
14325 PMA=MAX(PM1,PM2,PM3)
14326 PMC=MIN(PM1,PM2,PM3)
14327 PMB=PM1+PM2+PM3-PMA-PMC
14328 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC)
14329 PMAN=PMA**2/SH
14330 PMBN=PMB**2/SH
14331 PMCN=PMC**2/SH
14332 PMBCN=PMBC**2/SH
14333 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,
14334 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
14335 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
14336 & ((SHR-PMA)**2-(PMB+PMC)**2)*
14337 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
14338 & ((1D0-PMBCN)*PMBCN*SH)
14339 ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
14340 WDTP(I)=WDTP(I)*SQRT(
14341 & MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/
14342 & MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2))
14343 ELSEIF(MDME(IDC,2).EQ.53) THEN
14344 PMA=MAX(PM1,PM2,PM3)
14345 PMC=MIN(PM1,PM2,PM3)
14346 PMB=PM1+PM2+PM3-PMA-PMC
14347 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC)
14348 PMAN=PMA**2/SH
14349 PMBN=PMB**2/SH
14350 PMCN=PMC**2/SH
14351 PMBCN=PMBC**2/SH
14352 FACACT=SQRT(MAX(0D0,
14353 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
14354 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
14355 & ((SHR-PMA)**2-(PMB+PMC)**2)*
14356 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
14357 & ((1D0-PMBCN)*PMBCN*SH)
14358 PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
14359 PMAN=PMA**2/PMR**2
14360 PMBN=PMB**2/PMR**2
14361 PMCN=PMC**2/PMR**2
14362 PMBCN=PMBC**2/PMR**2
14363 FACNOM=SQRT(MAX(0D0,
14364 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
14365 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
14366 & ((PMR-PMA)**2-(PMB+PMC)**2)*
14367 & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
14368 & ((1D0-PMBCN)*PMBCN*PMR**2)
14369 WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM)
14370 ENDIF
14371 WDTP(0)=WDTP(0)+WDTP(I)
14372
14373C...Calculate secondary width (at most two identical/opposite).
14374 WID2=1D0
14375 IF(MDME(IDC,1).GT.0) THEN
14376 IF(KFD2.EQ.KFD1) THEN
14377 IF(KCHG(KFC1,3).EQ.0) THEN
14378 WID2=WIDS(KFC1,1)
14379 ELSEIF(KFD1.GT.0) THEN
14380 WID2=WIDS(KFC1,4)
14381 ELSE
14382 WID2=WIDS(KFC1,5)
14383 ENDIF
14384 IF(KFD3.GT.0) THEN
14385 WID2=WID2*WIDS(KFC3,2)
14386 ELSEIF(KFD3.LT.0) THEN
14387 WID2=WID2*WIDS(KFC3,3)
14388 ENDIF
14389 ELSEIF(KFD2.EQ.-KFD1) THEN
14390 WID2=WIDS(KFC1,1)
14391 IF(KFD3.GT.0) THEN
14392 WID2=WID2*WIDS(KFC3,2)
14393 ELSEIF(KFD3.LT.0) THEN
14394 WID2=WID2*WIDS(KFC3,3)
14395 ENDIF
14396 ELSEIF(KFD3.EQ.KFD1) THEN
14397 IF(KCHG(KFC1,3).EQ.0) THEN
14398 WID2=WIDS(KFC1,1)
14399 ELSEIF(KFD1.GT.0) THEN
14400 WID2=WIDS(KFC1,4)
14401 ELSE
14402 WID2=WIDS(KFC1,5)
14403 ENDIF
14404 IF(KFD2.GT.0) THEN
14405 WID2=WID2*WIDS(KFC2,2)
14406 ELSEIF(KFD2.LT.0) THEN
14407 WID2=WID2*WIDS(KFC2,3)
14408 ENDIF
14409 ELSEIF(KFD3.EQ.-KFD1) THEN
14410 WID2=WIDS(KFC1,1)
14411 IF(KFD2.GT.0) THEN
14412 WID2=WID2*WIDS(KFC2,2)
14413 ELSEIF(KFD2.LT.0) THEN
14414 WID2=WID2*WIDS(KFC2,3)
14415 ENDIF
14416 ELSEIF(KFD3.EQ.KFD2) THEN
14417 IF(KCHG(KFC2,3).EQ.0) THEN
14418 WID2=WIDS(KFC2,1)
14419 ELSEIF(KFD2.GT.0) THEN
14420 WID2=WIDS(KFC2,4)
14421 ELSE
14422 WID2=WIDS(KFC2,5)
14423 ENDIF
14424 IF(KFD1.GT.0) THEN
14425 WID2=WID2*WIDS(KFC1,2)
14426 ELSEIF(KFD1.LT.0) THEN
14427 WID2=WID2*WIDS(KFC1,3)
14428 ENDIF
14429 ELSEIF(KFD3.EQ.-KFD2) THEN
14430 WID2=WIDS(KFC2,1)
14431 IF(KFD1.GT.0) THEN
14432 WID2=WID2*WIDS(KFC1,2)
14433 ELSEIF(KFD1.LT.0) THEN
14434 WID2=WID2*WIDS(KFC1,3)
14435 ENDIF
14436 ELSE
14437 IF(KFD1.GT.0) THEN
14438 WID2=WIDS(KFC1,2)
14439 ELSE
14440 WID2=WIDS(KFC1,3)
14441 ENDIF
14442 IF(KFD2.GT.0) THEN
14443 WID2=WID2*WIDS(KFC2,2)
14444 ELSE
14445 WID2=WID2*WIDS(KFC2,3)
14446 ENDIF
14447 IF(KFD3.GT.0) THEN
14448 WID2=WID2*WIDS(KFC3,2)
14449 ELSEIF(KFD3.LT.0) THEN
14450 WID2=WID2*WIDS(KFC3,3)
14451 ENDIF
14452 ENDIF
14453
14454C...Store effective widths according to case.
14455 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
14456 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
14457 WDTE(I,0)=WDTE(I,MDME(IDC,1))
14458 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
14459 ENDIF
14460 120 CONTINUE
14461C...Return.
14462 MINT(61)=0
14463 MINT(62)=0
14464 MINT(63)=0
14465 RETURN
14466 ENDIF
14467
14468C...Here begins detailed dynamical calculation of resonance widths.
14469C...Shared treatment of Higgs states.
14470 KFHIGG=25
14471 IHIGG=1
14472 IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN
14473 KFHIGG=KFLA
14474 IHIGG=KFLA-33
14475 ENDIF
14476
14477C...Common electroweak and strong constants.
14478 XW=PARU(102)
14479 XWV=XW
14480 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
14481 XW1=1D0-XW
14482 AEM=PYALEM(SH)
14483 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
14484 AS=PYALPS(SH)
14485 RADC=1D0+AS/PARU(1)
14486
14487 IF(KFLA.EQ.6) THEN
14488C...t quark.
14489 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
14490 RADCT=1D0-2.5D0*AS/PARU(1)
14491 DO 130 I=1,MDCY(KC,3)
14492 IDC=I+MDCY(KC,2)-1
14493 IF(MDME(IDC,1).LT.0) GOTO 130
14494 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
14495 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
14496 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130
14497 WID2=1D0
14498 IF(I.GE.4.AND.I.LE.7) THEN
14499C...t -> W + q; including approximate QCD correction factor.
14500 WDTP(I)=FAC*VCKM(3,I-3)*RADCT*
14501 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
14502 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
14503 IF(KFLR.GT.0) THEN
14504 WID2=WIDS(24,2)
14505 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
14506 ELSE
14507 WID2=WIDS(24,3)
14508 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
14509 ENDIF
14510 ELSEIF(I.EQ.9) THEN
14511C...t -> H + b.
14512 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
14513 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
14514 WID2=WIDS(37,2)
14515 IF(KFLR.LT.0) WID2=WIDS(37,3)
14516CMRENNA++
14517 ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN
14518C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
14519 BETA=ATAN(RMSS(5))
14520 SINB=SIN(BETA)
14521 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
14522 ET=KCHG(6,1)/3D0
14523 T3L=SIGN(0.5D0,ET)
14524 KFC1=PYCOMP(KFDP(IDC,1))
14525 KFC2=PYCOMP(KFDP(IDC,2))
14526 PMNCHI=PMAS(KFC1,1)
14527 PMSTOP=PMAS(KFC2,1)
14528 IF(SHR.GT.PMNCHI+PMSTOP) THEN
14529 IZ=I-9
14530 AL=SHR*ZMIX(IZ,4)/(2.0D0*PMAS(24,1)*SINB)
14531 AR=-ET*ZMIX(IZ,1)*TANW
14532 BL=T3L*(ZMIX(IZ,2)-ZMIX(IZ,1)*TANW)-AR
14533 BR=AL
14534 FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR
14535 FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR
14536 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
14537 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
14538 WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM*((FL**2+FR**2)*
14539 & (SH+PMNCHI**2-PMSTOP**2)+SMZ(IZ)*4D0*SHR*FL*FR)/SH
14540 IF(KFLR.GT.0) THEN
14541 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
14542 ELSE
14543 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
14544 ENDIF
14545 ENDIF
14546 ELSEIF(I.EQ.14.AND.IMSS(1).NE.0) THEN
14547C...t -> ~g + ~t
14548 KFC1=PYCOMP(KFDP(IDC,1))
14549 KFC2=PYCOMP(KFDP(IDC,2))
14550 PMNCHI=PMAS(KFC1,1)
14551 PMSTOP=PMAS(KFC2,1)
14552 IF(SHR.GT.PMNCHI+PMSTOP) THEN
14553 FL=SFMIX(6,1)
14554 FR=-SFMIX(6,2)
14555 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
14556 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
14557 WDTP(I)=4D0/3D0*0.5D0*PYALPS(SH)*PCM*((FL**2+FR**2)*
14558 & (SH+PMNCHI**2-PMSTOP**2)+PMNCHI*4D0*SHR*FL*FR)/SH
14559 IF(KFLR.GT.0) THEN
14560 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
14561 ELSE
14562 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
14563 ENDIF
14564 ENDIF
14565 ELSEIF(I.EQ.15.AND.IMSS(1).NE.0) THEN
14566C...t -> ~gravitino + ~t
14567 XMP2=RMSS(29)**2
14568 KFC1=PYCOMP(KFDP(IDC,1))
14569 XMGR2=PMAS(KFC1,1)**2
14570 WDTP(I)=SH**2*SHR/(96D0*PARU(1)*XMP2*XMGR2)*(1D0-RM2)**4
14571 KFC2=PYCOMP(KFDP(IDC,2))
14572 WID2=WIDS(KFC2,2)
14573 IF(KFLR.LT.0) WID2=WIDS(KFC2,3)
14574CMRENNA--
14575 ENDIF
14576 WDTP(0)=WDTP(0)+WDTP(I)
14577 IF(MDME(IDC,1).GT.0) THEN
14578 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
14579 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
14580 WDTE(I,0)=WDTE(I,MDME(IDC,1))
14581 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
14582 ENDIF
14583 130 CONTINUE
14584
14585 ELSEIF(KFLA.EQ.7) THEN
14586C...b' quark.
14587 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
14588 DO 140 I=1,MDCY(KC,3)
14589 IDC=I+MDCY(KC,2)-1
14590 IF(MDME(IDC,1).LT.0) GOTO 140
14591 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
14592 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
14593 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
14594 WID2=1D0
14595 IF(I.GE.4.AND.I.LE.7) THEN
14596C...b' -> W + q.
14597 WDTP(I)=FAC*VCKM(I-3,4)*
14598 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
14599 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
14600 IF(KFLR.GT.0) THEN
14601 WID2=WIDS(24,3)
14602 IF(I.EQ.6) WID2=WID2*WIDS(6,2)
14603 IF(I.EQ.7) WID2=WID2*WIDS(8,2)
14604 ELSE
14605 WID2=WIDS(24,2)
14606 IF(I.EQ.6) WID2=WID2*WIDS(6,3)
14607 IF(I.EQ.7) WID2=WID2*WIDS(8,3)
14608 ENDIF
14609 WID2=WIDS(24,3)
14610 IF(KFLR.LT.0) WID2=WIDS(24,2)
14611 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
14612C...b' -> H + q.
14613 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
14614 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
14615 IF(KFLR.GT.0) THEN
14616 WID2=WIDS(37,3)
14617 IF(I.EQ.10) WID2=WID2*WIDS(6,2)
14618 ELSE
14619 WID2=WIDS(37,2)
14620 IF(I.EQ.10) WID2=WID2*WIDS(6,3)
14621 ENDIF
14622 ENDIF
14623 WDTP(0)=WDTP(0)+WDTP(I)
14624 IF(MDME(IDC,1).GT.0) THEN
14625 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
14626 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
14627 WDTE(I,0)=WDTE(I,MDME(IDC,1))
14628 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
14629 ENDIF
14630 140 CONTINUE
14631
14632 ELSEIF(KFLA.EQ.8) THEN
14633C...t' quark.
14634 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
14635 DO 150 I=1,MDCY(KC,3)
14636 IDC=I+MDCY(KC,2)-1
14637 IF(MDME(IDC,1).LT.0) GOTO 150
14638 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
14639 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
14640 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150
14641 WID2=1D0
14642 IF(I.GE.4.AND.I.LE.7) THEN
14643C...t' -> W + q.
14644 WDTP(I)=FAC*VCKM(4,I-3)*
14645 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
14646 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
14647 IF(KFLR.GT.0) THEN
14648 WID2=WIDS(24,2)
14649 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
14650 ELSE
14651 WID2=WIDS(24,3)
14652 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
14653 ENDIF
14654 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
14655C...t' -> H + q.
14656 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
14657 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
14658 IF(KFLR.GT.0) THEN
14659 WID2=WIDS(37,2)
14660 IF(I.EQ.10) WID2=WID2*WIDS(7,2)
14661 ELSE
14662 WID2=WIDS(37,3)
14663 IF(I.EQ.10) WID2=WID2*WIDS(7,3)
14664 ENDIF
14665 ENDIF
14666 WDTP(0)=WDTP(0)+WDTP(I)
14667 IF(MDME(IDC,1).GT.0) THEN
14668 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
14669 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
14670 WDTE(I,0)=WDTE(I,MDME(IDC,1))
14671 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
14672 ENDIF
14673 150 CONTINUE
14674
14675 ELSEIF(KFLA.EQ.17) THEN
14676C...tau' lepton.
14677 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
14678 DO 160 I=1,MDCY(KC,3)
14679 IDC=I+MDCY(KC,2)-1
14680 IF(MDME(IDC,1).LT.0) GOTO 160
14681 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
14682 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
14683 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160
14684 WID2=1D0
14685 IF(I.EQ.3) THEN
14686C...tau' -> W + nu'_tau.
14687 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
14688 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
14689 IF(KFLR.GT.0) THEN
14690 WID2=WIDS(24,3)
14691 WID2=WID2*WIDS(18,2)
14692 ELSE
14693 WID2=WIDS(24,2)
14694 WID2=WID2*WIDS(18,3)
14695 ENDIF
14696 ELSEIF(I.EQ.5) THEN
14697C...tau' -> H + nu'_tau.
14698 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
14699 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
14700 IF(KFLR.GT.0) THEN
14701 WID2=WIDS(37,3)
14702 WID2=WID2*WIDS(18,2)
14703 ELSE
14704 WID2=WIDS(37,2)
14705 WID2=WID2*WIDS(18,3)
14706 ENDIF
14707 ENDIF
14708 WDTP(0)=WDTP(0)+WDTP(I)
14709 IF(MDME(IDC,1).GT.0) THEN
14710 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
14711 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
14712 WDTE(I,0)=WDTE(I,MDME(IDC,1))
14713 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
14714 ENDIF
14715 160 CONTINUE
14716
14717 ELSEIF(KFLA.EQ.18) THEN
14718C...nu'_tau neutrino.
14719 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
14720 DO 170 I=1,MDCY(KC,3)
14721 IDC=I+MDCY(KC,2)-1
14722 IF(MDME(IDC,1).LT.0) GOTO 170
14723 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
14724 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
14725 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170
14726 WID2=1D0
14727 IF(I.EQ.2) THEN
14728C...nu'_tau -> W + tau'.
14729 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
14730 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
14731 IF(KFLR.GT.0) THEN
14732 WID2=WIDS(24,2)
14733 WID2=WID2*WIDS(17,2)
14734 ELSE
14735 WID2=WIDS(24,3)
14736 WID2=WID2*WIDS(17,3)
14737 ENDIF
14738 ELSEIF(I.EQ.3) THEN
14739C...nu'_tau -> H + tau'.
14740 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
14741 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
14742 IF(KFLR.GT.0) THEN
14743 WID2=WIDS(37,2)
14744 WID2=WID2*WIDS(17,2)
14745 ELSE
14746 WID2=WIDS(37,3)
14747 WID2=WID2*WIDS(17,3)
14748 ENDIF
14749 ENDIF
14750 WDTP(0)=WDTP(0)+WDTP(I)
14751 IF(MDME(IDC,1).GT.0) THEN
14752 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
14753 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
14754 WDTE(I,0)=WDTE(I,MDME(IDC,1))
14755 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
14756 ENDIF
14757 170 CONTINUE
14758
14759 ELSEIF(KFLA.EQ.21) THEN
14760C...QCD:
14761C***Note that widths are not given in dimensional quantities here.
14762 DO 180 I=1,MDCY(KC,3)
14763 IDC=I+MDCY(KC,2)-1
14764 IF(MDME(IDC,1).LT.0) GOTO 180
14765 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
14766 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
14767 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180
14768 WID2=1D0
14769 IF(I.LE.8) THEN
14770C...QCD -> q + qbar
14771 WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
14772 IF(I.EQ.6) WID2=WIDS(6,1)
14773 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
14774 ENDIF
14775 WDTP(0)=WDTP(0)+WDTP(I)
14776 IF(MDME(IDC,1).GT.0) THEN
14777 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
14778 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
14779 WDTE(I,0)=WDTE(I,MDME(IDC,1))
14780 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
14781 ENDIF
14782 180 CONTINUE
14783
14784 ELSEIF(KFLA.EQ.22) THEN
14785C...QED photon.
14786C***Note that widths are not given in dimensional quantities here.
14787 DO 190 I=1,MDCY(KC,3)
14788 IDC=I+MDCY(KC,2)-1
14789 IF(MDME(IDC,1).LT.0) GOTO 190
14790 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
14791 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
14792 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190
14793 WID2=1D0
14794 IF(I.LE.8) THEN
14795C...QED -> q + qbar.
14796 EF=KCHG(I,1)/3D0
14797 FCOF=3D0*RADC
14798 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
14799 WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
14800 IF(I.EQ.6) WID2=WIDS(6,1)
14801 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
14802 ELSEIF(I.LE.12) THEN
14803C...QED -> l+ + l-.
14804 EF=KCHG(9+2*(I-8),1)/3D0
14805 WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
14806 IF(I.EQ.12) WID2=WIDS(17,1)
14807 ENDIF
14808 WDTP(0)=WDTP(0)+WDTP(I)
14809 IF(MDME(IDC,1).GT.0) THEN
14810 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
14811 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
14812 WDTE(I,0)=WDTE(I,MDME(IDC,1))
14813 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
14814 ENDIF
14815 190 CONTINUE
14816
14817 ELSEIF(KFLA.EQ.23) THEN
14818C...Z0:
14819 ICASE=1
14820 XWC=1D0/(16D0*XW*XW1)
14821 FAC=(AEM*XWC/3D0)*SHR
14822 200 CONTINUE
14823 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
14824 VINT(111)=0D0
14825 VINT(112)=0D0
14826 VINT(114)=0D0
14827 ENDIF
14828 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
14829 KFI=IABS(MINT(15))
14830 IF(KFI.GT.20) KFI=IABS(MINT(16))
14831 EI=KCHG(KFI,1)/3D0
14832 AI=SIGN(1D0,EI)
14833 VI=AI-4D0*EI*XWV
14834 SQMZ=PMAS(23,1)**2
14835 HZ=SHR*WDTP(0)
14836 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0
14837 IF(MSTP(43).EQ.3) VINT(112)=
14838 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
14839 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
14840 & XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
14841 ENDIF
14842 DO 210 I=1,MDCY(KC,3)
14843 IDC=I+MDCY(KC,2)-1
14844 IF(MDME(IDC,1).LT.0) GOTO 210
14845 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
14846 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
14847 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 210
14848 WID2=1D0
14849 IF(I.LE.8) THEN
14850C...Z0 -> q + qbar
14851 EF=KCHG(I,1)/3D0
14852 AF=SIGN(1D0,EF+0.1D0)
14853 VF=AF-4D0*EF*XWV
14854 FCOF=3D0*RADC
14855 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
14856 IF(I.EQ.6) WID2=WIDS(6,1)
14857 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
14858 ELSEIF(I.LE.16) THEN
14859C...Z0 -> l+ + l-, nu + nubar
14860 EF=KCHG(I+2,1)/3D0
14861 AF=SIGN(1D0,EF+0.1D0)
14862 VF=AF-4D0*EF*XWV
14863 FCOF=1D0
14864 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
14865 ENDIF
14866 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
14867 IF(ICASE.EQ.1) THEN
14868 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
14869 & BE34
14870 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
14871 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
14872 & EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+
14873 & (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34
14874 ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
14875 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
14876 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
14877 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
14878 ENDIF
14879 IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I)
14880 IF(MDME(IDC,1).GT.0) THEN
14881 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
14882 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
14883 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
14884 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
14885 & WDTE(I,MDME(IDC,1))
14886 WDTE(I,0)=WDTE(I,MDME(IDC,1))
14887 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
14888 ENDIF
14889 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
14890 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=
14891 & VINT(111)+FGGF*WID2
14892 IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2
14893 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
14894 & VINT(114)+FZZF*WID2
14895 ENDIF
14896 ENDIF
14897 210 CONTINUE
14898 IF(MINT(61).GE.1) ICASE=3-ICASE
14899 IF(ICASE.EQ.2) GOTO 200
14900
14901 ELSEIF(KFLA.EQ.24) THEN
14902C...W+/-:
14903 FAC=(AEM/(24D0*XW))*SHR
14904 DO 220 I=1,MDCY(KC,3)
14905 IDC=I+MDCY(KC,2)-1
14906 IF(MDME(IDC,1).LT.0) GOTO 220
14907 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
14908 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
14909 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220
14910 WID2=1D0
14911 IF(I.LE.16) THEN
14912C...W+/- -> q + qbar'
14913 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
14914 IF(KFLR.GT.0) THEN
14915 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
14916 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
14917 IF(I.GE.13) WID2=WID2*WIDS(7,3)
14918 ELSE
14919 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
14920 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
14921 IF(I.GE.13) WID2=WID2*WIDS(7,2)
14922 ENDIF
14923 ELSEIF(I.LE.20) THEN
14924C...W+/- -> l+/- + nu
14925 FCOF=1D0
14926 IF(KFLR.GT.0) THEN
14927 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
14928 ELSE
14929 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
14930 ENDIF
14931 ENDIF
14932 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
14933 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
14934 WDTP(0)=WDTP(0)+WDTP(I)
14935 IF(MDME(IDC,1).GT.0) THEN
14936 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
14937 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
14938 WDTE(I,0)=WDTE(I,MDME(IDC,1))
14939 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
14940 ENDIF
14941 220 CONTINUE
14942
14943 ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN
14944C...h0 (or H0, or A0):
14945 IF(MSTP(49).EQ.0) THEN
14946 FAC=(AEM/(8D0*XW))*(SH/PMAS(24,1)**2)*SHR
14947 ELSE
14948 FAC=(AEM/(8D0*XW))*(PMAS(KFHIGG,1)/PMAS(24,1))**2*SHR
14949 ENDIF
14950 DO 260 I=1,MDCY(KFHIGG,3)
14951 IDC=I+MDCY(KFHIGG,2)-1
14952 IF(MDME(IDC,1).LT.0) GOTO 260
14953 KFC1=PYCOMP(KFDP(IDC,1))
14954 KFC2=PYCOMP(KFDP(IDC,2))
14955 RM1=PMAS(KFC1,1)**2/SH
14956 RM2=PMAS(KFC2,1)**2/SH
14957 IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0)
14958 & GOTO 260
14959 WID2=1D0
14960
14961 IF(I.LE.8) THEN
14962C...h0 -> q + qbar
14963 WDTP(I)=FAC*3D0*(PYMRUN(KFDP(IDC,1),SH)**2/SH)*
14964 & SQRT(MAX(0D0,1D0-4D0*RM1))*RADC
14965C...A0 behaves like beta, ho and H0 like beta**3.
14966 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
14967 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
14968 IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2
14969 IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2
14970 ENDIF
14971 IF(I.EQ.6) WID2=WIDS(6,1)
14972 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
14973
14974 ELSEIF(I.LE.12) THEN
14975C...h0 -> l+ + l-
14976 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))
14977C...A0 behaves like beta, ho and H0 like beta**3.
14978 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
14979 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
14980 & PARU(153+10*IHIGG)**2
14981 IF(I.EQ.12) WID2=WIDS(17,1)
14982
14983 ELSEIF(I.EQ.13) THEN
14984C...h0 -> g + g; quark loop contribution only
14985 ETARE=0D0
14986 ETAIM=0D0
14987 DO 230 J=1,2*MSTP(1)
14988 EPS=(2D0*PMAS(J,1))**2/SH
14989C...Loop integral; function of eps=4m^2/shat; different for A0.
14990 IF(EPS.LE.1D0) THEN
14991 IF(EPS.GT.1D-4) THEN
14992 ROOT=SQRT(1D0-EPS)
14993 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
14994 ELSE
14995 RLN=LOG(4D0/EPS-2D0)
14996 ENDIF
14997 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
14998 PHIIM=0.5D0*PARU(1)*RLN
14999 ELSE
15000 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
15001 PHIIM=0D0
15002 ENDIF
15003 IF(IHIGG.LE.2) THEN
15004 ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
15005 ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM
15006 ELSE
15007 ETAREJ=-0.5D0*EPS*PHIRE
15008 ETAIMJ=-0.5D0*EPS*PHIIM
15009 ENDIF
15010C...Couplings (=1 for standard model Higgs).
15011 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
15012 IF(MOD(J,2).EQ.1) THEN
15013 ETAREJ=ETAREJ*PARU(151+10*IHIGG)
15014 ETAIMJ=ETAIMJ*PARU(151+10*IHIGG)
15015 ELSE
15016 ETAREJ=ETAREJ*PARU(152+10*IHIGG)
15017 ETAIMJ=ETAIMJ*PARU(152+10*IHIGG)
15018 ENDIF
15019 ENDIF
15020 ETARE=ETARE+ETAREJ
15021 ETAIM=ETAIM+ETAIMJ
15022 230 CONTINUE
15023 ETA2=ETARE**2+ETAIM**2
15024 WDTP(I)=FAC*(AS/PARU(1))**2*ETA2
15025
15026 ELSEIF(I.EQ.14) THEN
15027C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
15028 ETARE=0D0
15029 ETAIM=0D0
15030 JMAX=3*MSTP(1)+1
15031 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
15032 DO 240 J=1,JMAX
15033 IF(J.LE.2*MSTP(1)) THEN
15034 EJ=KCHG(J,1)/3D0
15035 EPS=(2D0*PMAS(J,1))**2/SH
15036 ELSEIF(J.LE.3*MSTP(1)) THEN
15037 JL=2*(J-2*MSTP(1))-1
15038 EJ=KCHG(10+JL,1)/3D0
15039 EPS=(2D0*PMAS(10+JL,1))**2/SH
15040 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
15041 EPS=(2D0*PMAS(24,1))**2/SH
15042 ELSE
15043 EPS=(2D0*PMAS(37,1))**2/SH
15044 ENDIF
15045C...Loop integral; function of eps=4m^2/shat.
15046 IF(EPS.LE.1D0) THEN
15047 IF(EPS.GT.1D-4) THEN
15048 ROOT=SQRT(1D0-EPS)
15049 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
15050 ELSE
15051 RLN=LOG(4D0/EPS-2D0)
15052 ENDIF
15053 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
15054 PHIIM=0.5D0*PARU(1)*RLN
15055 ELSE
15056 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
15057 PHIIM=0D0
15058 ENDIF
15059 IF(J.LE.3*MSTP(1)) THEN
15060C...Fermion loops: loop integral different for A0; charges.
15061 IF(IHIGG.LE.2) THEN
15062 PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
15063 PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM
15064 ELSE
15065 PHIPRE=-0.5D0*EPS*PHIRE
15066 PHIPIM=-0.5D0*EPS*PHIIM
15067 ENDIF
15068 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
15069 EJC=3D0*EJ**2
15070 EJH=PARU(151+10*IHIGG)
15071 ELSEIF(J.LE.2*MSTP(1)) THEN
15072 EJC=3D0*EJ**2
15073 EJH=PARU(152+10*IHIGG)
15074 ELSE
15075 EJC=EJ**2
15076 EJH=PARU(153+10*IHIGG)
15077 ENDIF
15078 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
15079 ETAREJ=EJC*EJH*PHIPRE
15080 ETAIMJ=EJC*EJH*PHIPIM
15081 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
15082C...W loops: loop integral and charges.
15083 ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE)
15084 ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM
15085 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
15086 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
15087 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
15088 ENDIF
15089 ELSE
15090C...Charged H loops: loop integral and charges.
15091 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*
15092 & PARU(158+10*IHIGG+2*(IHIGG/3))
15093 ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH
15094 ETAIMJ=-EPS**2*PHIIM*FACHHH
15095 ENDIF
15096 ETARE=ETARE+ETAREJ
15097 ETAIM=ETAIM+ETAIMJ
15098 240 CONTINUE
15099 ETA2=ETARE**2+ETAIM**2
15100 WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2
15101
15102 ELSEIF(I.EQ.15) THEN
15103C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
15104 ETARE=0D0
15105 ETAIM=0D0
15106 JMAX=3*MSTP(1)+1
15107 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
15108 DO 250 J=1,JMAX
15109 IF(J.LE.2*MSTP(1)) THEN
15110 EJ=KCHG(J,1)/3D0
15111 AJ=SIGN(1D0,EJ+0.1D0)
15112 VJ=AJ-4D0*EJ*XWV
15113 EPS=(2D0*PMAS(J,1))**2/SH
15114 EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2
15115 ELSEIF(J.LE.3*MSTP(1)) THEN
15116 JL=2*(J-2*MSTP(1))-1
15117 EJ=KCHG(10+JL,1)/3D0
15118 AJ=SIGN(1D0,EJ+0.1D0)
15119 VJ=AJ-4D0*EJ*XWV
15120 EPS=(2D0*PMAS(10+JL,1))**2/SH
15121 EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2
15122 ELSE
15123 EPS=(2D0*PMAS(24,1))**2/SH
15124 EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2
15125 ENDIF
15126C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
15127 IF(EPS.LE.1D0) THEN
15128 ROOT=SQRT(1D0-EPS)
15129 IF(EPS.GT.1D-4) THEN
15130 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
15131 ELSE
15132 RLN=LOG(4D0/EPS-2D0)
15133 ENDIF
15134 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
15135 PHIIM=0.5D0*PARU(1)*RLN
15136 PSIRE=0.5D0*ROOT*RLN
15137 PSIIM=-0.5D0*ROOT*PARU(1)
15138 ELSE
15139 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
15140 PHIIM=0D0
15141 PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS))
15142 PSIIM=0D0
15143 ENDIF
15144 IF(EPSP.LE.1D0) THEN
15145 ROOT=SQRT(1D0-EPSP)
15146 IF(EPSP.GT.1D-4) THEN
15147 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
15148 ELSE
15149 RLN=LOG(4D0/EPSP-2D0)
15150 ENDIF
15151 PHIREP=-0.25D0*(RLN**2-PARU(1)**2)
15152 PHIIMP=0.5D0*PARU(1)*RLN
15153 PSIREP=0.5D0*ROOT*RLN
15154 PSIIMP=-0.5D0*ROOT*PARU(1)
15155 ELSE
15156 PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
15157 PHIIMP=0D0
15158 PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
15159 PSIIMP=0D0
15160 ENDIF
15161 FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)*
15162 & (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
15163 FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)*
15164 & (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP))
15165 F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP)
15166 F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP)
15167 IF(J.LE.3*MSTP(1)) THEN
15168C...Fermion loops: loop integral different for A0; charges.
15169 IF(IHIGG.EQ.3) FXYRE=0D0
15170 IF(IHIGG.EQ.3) FXYIM=0D0
15171 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
15172 EJC=-3D0*EJ*VJ
15173 EJH=PARU(151+10*IHIGG)
15174 ELSEIF(J.LE.2*MSTP(1)) THEN
15175 EJC=-3D0*EJ*VJ
15176 EJH=PARU(152+10*IHIGG)
15177 ELSE
15178 EJC=-EJ*VJ
15179 EJH=PARU(153+10*IHIGG)
15180 ENDIF
15181 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
15182 ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE)
15183 ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM)
15184 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
15185C...W loops: loop integral and charges.
15186 HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS)
15187 ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE)
15188 ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM)
15189 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
15190 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
15191 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
15192 ENDIF
15193 ELSE
15194C...Charged H loops: loop integral and charges.
15195 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)*
15196 & PARU(158+10*IHIGG+2*(IHIGG/3))
15197 ETAREJ=FACHHH*FXYRE
15198 ETAIMJ=FACHHH*FXYIM
15199 ENDIF
15200 ETARE=ETARE+ETAREJ
15201 ETAIM=ETAIM+ETAIMJ
15202 250 CONTINUE
15203 ETA2=(ETARE**2+ETAIM**2)/(XW*XW1)
15204 WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2
15205 WID2=WIDS(23,2)
15206
15207 ELSEIF(I.LE.17) THEN
15208C...h0 -> Z0 + Z0, W+ + W-
15209 PM1=PMAS(IABS(KFDP(IDC,1)),1)
15210 PG1=PMAS(IABS(KFDP(IDC,1)),2)
15211 IF(MINT(62).GE.1) THEN
15212 IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND.
15213 & CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND.
15214 & MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN
15215 MOFSV(IHIGG,I-15)=0
15216 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
15217 & 1D0-4D0*RM1))
15218 WID2=1D0
15219 ELSE
15220 MOFSV(IHIGG,I-15)=1
15221 RMAS=SQRT(MAX(0D0,SH))
15222 CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW,
15223 & WID2)
15224 WIDWSV(IHIGG,I-15)=WIDW
15225 WID2SV(IHIGG,I-15)=WID2
15226 ENDIF
15227 ELSE
15228 IF(MOFSV(IHIGG,I-15).EQ.0) THEN
15229 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
15230 & 1D0-4D0*RM1))
15231 WID2=1D0
15232 ELSE
15233 WIDW=WIDWSV(IHIGG,I-15)
15234 WID2=WID2SV(IHIGG,I-15)
15235 ENDIF
15236 ENDIF
15237 WDTP(I)=FAC*WIDW/(2D0*(18-I))
15238 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
15239 & PARU(138+I+10*IHIGG)**2
15240 WID2=WID2*WIDS(7+I,1)
15241
15242 ELSEIF(I.EQ.18.AND.KFLA.EQ.35) THEN
15243C***H0 -> Z0 + h0 (not yet implemented).
15244
15245 ELSEIF(I.EQ.19.AND.KFLA.EQ.35) THEN
15246C...H0 -> h0 + h0.
15247 WDTP(I)=FAC*PARU(176)**2*0.25D0*PMAS(23,1)**4/SH**2*
15248 & SQRT(MAX(0D0,1D0-4D0*RM1))
15249 WID2=WIDS(25,2)**2
15250
15251 ELSEIF(I.EQ.20.AND.KFLA.EQ.35) THEN
15252C...H0 -> A0 + A0.
15253 WDTP(I)=FAC*PARU(177)**2*0.25D0*PMAS(23,1)**4/SH**2*
15254 & SQRT(MAX(0D0,1D0-4D0*RM1))
15255 WID2=WIDS(36,2)**2
15256
15257 ELSEIF(I.EQ.18.AND.KFLA.EQ.36) THEN
15258C...A0 -> Z0 + h0.
15259 WDTP(I)=FAC*PARU(186)**2*0.5D0*SQRT(MAX(0D0,
15260 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
15261 WID2=WIDS(23,2)*WIDS(25,2)
15262
15263CMRENNA++
15264 ELSE
15265C...Add in SUSY decays (two-body) by rescaling by phase space factor.
15266 RM10=RM1*SH/PMR**2
15267 RM20=RM2*SH/PMR**2
15268 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
15269 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
15270 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
15271 WFAC=0D0
15272 ELSE
15273 WFAC=WFAC/WFAC0
15274 ENDIF
15275 WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
15276CMRENNA--
15277 IF(KFC2.EQ.KFC1) THEN
15278 WID2=WIDS(KFC1,1)
15279 ELSE
15280 KSGN1=2
15281 IF(KFDP(IDC,1).LT.0) KSGN1=3
15282 KSGN2=2
15283 IF(KFDP(IDC,2).LT.0) KSGN2=3
15284 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
15285 ENDIF
15286 ENDIF
15287 WDTP(0)=WDTP(0)+WDTP(I)
15288 IF(MDME(IDC,1).GT.0) THEN
15289 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
15290 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
15291 WDTE(I,0)=WDTE(I,MDME(IDC,1))
15292 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
15293 ENDIF
15294 260 CONTINUE
15295
15296 ELSEIF(KFLA.EQ.32) THEN
15297C...Z'0:
15298 ICASE=1
15299 XWC=1D0/(16D0*XW*XW1)
15300 FAC=(AEM*XWC/3D0)*SHR
15301 VINT(117)=0D0
15302 270 CONTINUE
15303 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
15304 VINT(111)=0D0
15305 VINT(112)=0D0
15306 VINT(113)=0D0
15307 VINT(114)=0D0
15308 VINT(115)=0D0
15309 VINT(116)=0D0
15310 ENDIF
15311 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
15312 KFAI=IABS(MINT(15))
15313 EI=KCHG(KFAI,1)/3D0
15314 AI=SIGN(1D0,EI+0.1D0)
15315 VI=AI-4D0*EI*XWV
15316 KFAIC=1
15317 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
15318 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
15319 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
15320 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
15321 VPI=PARU(119+2*KFAIC)
15322 API=PARU(120+2*KFAIC)
15323 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
15324 VPI=PARJ(178+2*KFAIC)
15325 API=PARJ(179+2*KFAIC)
15326 ELSE
15327 VPI=PARJ(186+2*KFAIC)
15328 API=PARJ(187+2*KFAIC)
15329 ENDIF
15330 SQMZ=PMAS(23,1)**2
15331 HZ=SHR*VINT(117)
15332 SQMZP=PMAS(32,1)**2
15333 HZP=SHR*WDTP(0)
15334 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
15335 & MSTP(44).EQ.7) VINT(111)=1D0
15336 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=
15337 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
15338 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
15339 & 2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2)
15340 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
15341 & MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
15342 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
15343 & 2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/
15344 & (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2))
15345 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
15346 & MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2)
15347 ENDIF
15348 DO 280 I=1,MDCY(KC,3)
15349 IDC=I+MDCY(KC,2)-1
15350 IF(MDME(IDC,1).LT.0) GOTO 280
15351 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
15352 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
15353 IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 280
15354 WID2=1D0
15355 IF(I.LE.16) THEN
15356 IF(I.LE.8) THEN
15357C...Z'0 -> q + qbar
15358 EF=KCHG(I,1)/3D0
15359 AF=SIGN(1D0,EF+0.1D0)
15360 VF=AF-4D0*EF*XWV
15361 IF(I.LE.2) THEN
15362 VPF=PARU(123-2*MOD(I,2))
15363 APF=PARU(124-2*MOD(I,2))
15364 ELSEIF(I.LE.4) THEN
15365 VPF=PARJ(182-2*MOD(I,2))
15366 APF=PARJ(183-2*MOD(I,2))
15367 ELSE
15368 VPF=PARJ(190-2*MOD(I,2))
15369 APF=PARJ(191-2*MOD(I,2))
15370 ENDIF
15371 FCOF=3D0*RADC
15372 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
15373 & PYHFTH(SH,SH*RM1,1D0)
15374 IF(I.EQ.6) WID2=WIDS(6,1)
15375 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
15376 ELSEIF(I.LE.16) THEN
15377C...Z'0 -> l+ + l-, nu + nubar
15378 EF=KCHG(I+2,1)/3D0
15379 AF=SIGN(1D0,EF+0.1D0)
15380 VF=AF-4D0*EF*XWV
15381 IF(I.LE.10) THEN
15382 VPF=PARU(127-2*MOD(I,2))
15383 APF=PARU(128-2*MOD(I,2))
15384 ELSEIF(I.LE.12) THEN
15385 VPF=PARJ(186-2*MOD(I,2))
15386 APF=PARJ(187-2*MOD(I,2))
15387 ELSE
15388 VPF=PARJ(194-2*MOD(I,2))
15389 APF=PARJ(195-2*MOD(I,2))
15390 ENDIF
15391 FCOF=1D0
15392 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
15393 ENDIF
15394 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
15395 IF(ICASE.EQ.1) THEN
15396 WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
15397 WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+
15398 & APF**2*(1D0-4D0*RM1))*BE34
15399 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
15400 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
15401 & EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
15402 & VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)*
15403 & VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)*
15404 & AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)*
15405 & VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34
15406 ELSEIF(MINT(61).EQ.2) THEN
15407 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
15408 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
15409 FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34
15410 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
15411 FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))*
15412 & BE34
15413 FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))*
15414 & BE34
15415 ENDIF
15416 ELSEIF(I.EQ.17) THEN
15417C...Z'0 -> W+ + W-
15418 WDTPZP=PARU(129)**2*XW1**2*
15419 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
15420 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
15421 IF(ICASE.EQ.1) THEN
15422 WDTPZ=0D0
15423 WDTP(I)=FAC*WDTPZP
15424 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
15425 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
15426 ELSEIF(MINT(61).EQ.2) THEN
15427 FGGF=0D0
15428 FGZF=0D0
15429 FGZPF=0D0
15430 FZZF=0D0
15431 FZZPF=0D0
15432 FZPZPF=WDTPZP
15433 ENDIF
15434 WID2=WIDS(24,1)
15435 ELSEIF(I.EQ.18) THEN
15436C...Z'0 -> H+ + H-
15437 CZC=2D0*(1D0-2D0*XW)
15438 BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
15439 IF(ICASE.EQ.1) THEN
15440 WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C
15441 WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C
15442 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
15443 WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI*
15444 & VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2*
15445 & (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)*
15446 & (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2*
15447 & (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C
15448 ELSEIF(MINT(61).EQ.2) THEN
15449 FGGF=0.25D0*BE34C
15450 FGZF=0.25D0*PARU(142)*CZC*BE34C
15451 FGZPF=0.25D0*PARU(143)*CZC*BE34C
15452 FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C
15453 FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C
15454 FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C
15455 ENDIF
15456 WID2=WIDS(37,1)
15457 ELSEIF(I.EQ.19) THEN
15458C...Z'0 -> Z0 + gamma.
15459 ELSEIF(I.EQ.20) THEN
15460C...Z'0 -> Z0 + h0
15461 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
15462 WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)*
15463 & (3D0*RM1+0.25D0*FLAM**2)*FLAM
15464 IF(ICASE.EQ.1) THEN
15465 WDTPZ=0D0
15466 WDTP(I)=FAC*WDTPZP
15467 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
15468 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
15469 ELSEIF(MINT(61).EQ.2) THEN
15470 FGGF=0D0
15471 FGZF=0D0
15472 FGZPF=0D0
15473 FZZF=0D0
15474 FZZPF=0D0
15475 FZPZPF=WDTPZP
15476 ENDIF
15477 WID2=WIDS(23,2)*WIDS(25,2)
15478 ELSEIF(I.EQ.21.OR.I.EQ.22) THEN
15479C...Z' -> h0 + A0 or H0 + A0.
15480 BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
15481 IF(I.EQ.21) THEN
15482 CZAH=PARU(186)
15483 CZPAH=PARU(188)
15484 ELSE
15485 CZAH=PARU(187)
15486 CZPAH=PARU(189)
15487 ENDIF
15488 IF(ICASE.EQ.1) THEN
15489 WDTPZ=CZAH**2*BE34C
15490 WDTP(I)=FAC*CZPAH**2*BE34C
15491 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
15492 WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH*
15493 & (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)*
15494 & VINT(116))*BE34C
15495 ELSEIF(MINT(61).EQ.2) THEN
15496 FGGF=0D0
15497 FGZF=0D0
15498 FGZPF=0D0
15499 FZZF=CZAH**2*BE34C
15500 FZZPF=CZAH*CZPAH*BE34C
15501 FZPZPF=CZPAH**2*BE34C
15502 ENDIF
15503 IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2)
15504 IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2)
15505 ENDIF
15506 IF(ICASE.EQ.1) THEN
15507 VINT(117)=VINT(117)+FAC*WDTPZ
15508 WDTP(0)=WDTP(0)+WDTP(I)
15509 ENDIF
15510 IF(MDME(IDC,1).GT.0) THEN
15511 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
15512 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
15513 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
15514 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
15515 & WDTE(I,MDME(IDC,1))
15516 WDTE(I,0)=WDTE(I,MDME(IDC,1))
15517 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
15518 ENDIF
15519 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
15520 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
15521 & MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2
15522 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+
15523 & FGZF*WID2
15524 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+
15525 & FGZPF*WID2
15526 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
15527 & MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2
15528 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+
15529 & FZZPF*WID2
15530 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
15531 & MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2
15532 ENDIF
15533 ENDIF
15534 280 CONTINUE
15535 IF(MINT(61).GE.1) ICASE=3-ICASE
15536 IF(ICASE.EQ.2) GOTO 270
15537
15538 ELSEIF(KFLA.EQ.34) THEN
15539C...W'+/-:
15540 FAC=(AEM/(24D0*XW))*SHR
15541 DO 290 I=1,MDCY(KC,3)
15542 IDC=I+MDCY(KC,2)-1
15543 IF(MDME(IDC,1).LT.0) GOTO 290
15544 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
15545 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
15546 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 290
15547 WID2=1D0
15548 IF(I.LE.20) THEN
15549 IF(I.LE.16) THEN
15550C...W'+/- -> q + qbar'
15551 FCOF=3D0*RADC*(PARU(131)**2+PARU(132)**2)*
15552 & VCKM((I-1)/4+1,MOD(I-1,4)+1)
15553 IF(KFLR.GT.0) THEN
15554 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
15555 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
15556 IF(I.GE.13) WID2=WID2*WIDS(7,3)
15557 ELSE
15558 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
15559 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
15560 IF(I.GE.13) WID2=WID2*WIDS(7,2)
15561 ENDIF
15562 ELSEIF(I.LE.20) THEN
15563C...W'+/- -> l+/- + nu
15564 FCOF=PARU(133)**2+PARU(134)**2
15565 IF(KFLR.GT.0) THEN
15566 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
15567 ELSE
15568 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
15569 ENDIF
15570 ENDIF
15571 WDTP(I)=FAC*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)*
15572 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
15573 ELSEIF(I.EQ.21) THEN
15574C...W'+/- -> W+/- + Z0
15575 WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)*
15576 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
15577 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
15578 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2)
15579 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2)
15580 ELSEIF(I.EQ.23) THEN
15581C...W'+/- -> W+/- + h0
15582 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
15583 WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM
15584 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
15585 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
15586 ENDIF
15587 WDTP(0)=WDTP(0)+WDTP(I)
15588 IF(MDME(IDC,1).GT.0) THEN
15589 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
15590 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
15591 WDTE(I,0)=WDTE(I,MDME(IDC,1))
15592 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
15593 ENDIF
15594 290 CONTINUE
15595
15596 ELSEIF(KFLA.EQ.37) THEN
15597C...H+/-:
15598 FAC=(AEM/(8D0*XW))*(SH/PMAS(24,1)**2)*SHR
15599 DO 300 I=1,MDCY(KC,3)
15600 IDC=I+MDCY(KC,2)-1
15601 IF(MDME(IDC,1).LT.0) GOTO 300
15602 KFC1=PYCOMP(KFDP(IDC,1))
15603 KFC2=PYCOMP(KFDP(IDC,2))
15604 RM1=PMAS(KFC1,1)**2/SH
15605 RM2=PMAS(KFC2,1)**2/SH
15606 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300
15607 WID2=1D0
15608 IF(I.LE.4) THEN
15609C...H+/- -> q + qbar'
15610 RM1R=PYMRUN(KFDP(IDC,1),SH)**2/SH
15611 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
15612 WDTP(I)=FAC*3D0*RADC*MAX(0D0,(RM1R*PARU(141)**2+
15613 & RM2R/PARU(141)**2)*(1D0-RM1R-RM2R)-4D0*RM1R*RM2R)*
15614 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
15615 IF(KFLR.GT.0) THEN
15616 IF(I.EQ.3) WID2=WIDS(6,2)
15617 IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2)
15618 ELSE
15619 IF(I.EQ.3) WID2=WIDS(6,3)
15620 IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3)
15621 ENDIF
15622 ELSEIF(I.LE.8) THEN
15623C...H+/- -> l+/- + nu
15624 WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)*
15625 & (1D0-RM1-RM2)-4D0*RM1*RM2)*
15626 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
15627 IF(KFLR.GT.0) THEN
15628 IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2)
15629 ELSE
15630 IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3)
15631 ENDIF
15632 ELSEIF(I.EQ.9) THEN
15633C...H+/- -> W+/- + h0.
15634 WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0,
15635 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
15636 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
15637 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
15638
15639CMRENNA++
15640 ELSE
15641C...Add in SUSY decays (two-body) by rescaling by phase space factor.
15642 RM10=RM1*SH/PMR**2
15643 RM20=RM2*SH/PMR**2
15644 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
15645 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
15646 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
15647 WFAC=0D0
15648 ELSE
15649 WFAC=WFAC/WFAC0
15650 ENDIF
15651 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
15652CMRENNA--
15653 KSGN1=2
15654 IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3
15655 KSGN2=2
15656 IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3
15657 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
15658 ENDIF
15659 WDTP(0)=WDTP(0)+WDTP(I)
15660 IF(MDME(IDC,1).GT.0) THEN
15661 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
15662 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
15663 WDTE(I,0)=WDTE(I,MDME(IDC,1))
15664 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
15665 ENDIF
15666 300 CONTINUE
15667
15668 ELSEIF(KFLA.EQ.38) THEN
15669C...Techni-eta.
15670 FAC=(SH/PARP(46)**2)*SHR
15671 DO 310 I=1,MDCY(KC,3)
15672 IDC=I+MDCY(KC,2)-1
15673 IF(MDME(IDC,1).LT.0) GOTO 310
15674 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
15675 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
15676 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310
15677 WID2=1D0
15678 IF(I.LE.2) THEN
15679 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1))
15680 IF(I.EQ.2) WID2=WIDS(6,1)
15681 ELSE
15682 WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3)
15683 ENDIF
15684 WDTP(0)=WDTP(0)+WDTP(I)
15685 IF(MDME(IDC,1).GT.0) THEN
15686 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
15687 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
15688 WDTE(I,0)=WDTE(I,MDME(IDC,1))
15689 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
15690 ENDIF
15691 310 CONTINUE
15692
15693 ELSEIF(KFLA.EQ.39) THEN
15694C...LQ (leptoquark).
15695 FAC=(AEM/4D0)*PARU(151)*SHR
15696 DO 320 I=1,MDCY(KC,3)
15697 IDC=I+MDCY(KC,2)-1
15698 IF(MDME(IDC,1).LT.0) GOTO 320
15699 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
15700 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
15701 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320
15702 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
15703 WID2=1D0
15704 ILQQ=KFDP(IDC,1)*ISIGN(1,KFLR)
15705 IF(ILQQ.GE.6) WID2=WIDS(ILQQ,2)
15706 IF(ILQQ.LE.-6) WID2=WIDS(-ILQQ,3)
15707 ILQL=KFDP(IDC,2)*ISIGN(1,KFLR)
15708 IF(ILQL.GE.17) WID2=WID2*WIDS(ILQL,2)
15709 IF(ILQL.LE.-17) WID2=WID2*WIDS(-ILQL,3)
15710 WDTP(0)=WDTP(0)+WDTP(I)
15711 IF(MDME(IDC,1).GT.0) THEN
15712 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
15713 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
15714 WDTE(I,0)=WDTE(I,MDME(IDC,1))
15715 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
15716 ENDIF
15717 320 CONTINUE
15718
15719 ELSEIF(KFLA.EQ.40) THEN
15720C...R:
15721 FAC=(AEM/(12D0*XW))*SHR
15722 DO 330 I=1,MDCY(KC,3)
15723 IDC=I+MDCY(KC,2)-1
15724 IF(MDME(IDC,1).LT.0) GOTO 330
15725 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
15726 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
15727 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330
15728 WID2=1D0
15729 IF(I.LE.6) THEN
15730C...R -> q + qbar'
15731 FCOF=3D0*RADC
15732 ELSEIF(I.LE.9) THEN
15733C...R -> l+ + l'-
15734 FCOF=1D0
15735 ENDIF
15736 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
15737 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
15738 IF(KFLR.GT.0) THEN
15739 IF(I.EQ.4) WID2=WIDS(6,3)
15740 IF(I.EQ.5) WID2=WIDS(7,3)
15741 IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3)
15742 IF(I.EQ.9) WID2=WIDS(17,3)
15743 ELSE
15744 IF(I.EQ.4) WID2=WIDS(6,2)
15745 IF(I.EQ.5) WID2=WIDS(7,2)
15746 IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2)
15747 IF(I.EQ.9) WID2=WIDS(17,2)
15748 ENDIF
15749 WDTP(0)=WDTP(0)+WDTP(I)
15750 IF(MDME(IDC,1).GT.0) THEN
15751 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
15752 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
15753 WDTE(I,0)=WDTE(I,MDME(IDC,1))
15754 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
15755 ENDIF
15756 330 CONTINUE
15757
15758 ELSEIF(KFLA.EQ.51.OR.KFLA.EQ.53) THEN
15759C...Techni-pi0 and techni-pi0':
15760 FAC=(1D0/(32D0*PARU(1)*PARP(142)**2))*SHR
15761 DO 340 I=1,MDCY(KC,3)
15762 IDC=I+MDCY(KC,2)-1
15763 IF(MDME(IDC,1).LT.0) GOTO 340
15764 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
15765 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
15766 RM1=PM1**2/SH
15767 RM2=PM2**2/SH
15768 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340
15769 WID2=1D0
15770C...pi_tech -> g + g
15771 IF(I.EQ.8) THEN
15772 FACP=(AS/(4D0*PARU(1))*PARP(144)/PARP(142))**2
15773 & /(8D0*PARU(1))*SH*SHR
15774 IF(KFLA.EQ.51) THEN
15775 FACP=FACP*PARP(149)
15776 ELSE
15777 FACP=FACP*PARP(150)
15778 ENDIF
15779 WDTP(I)=FACP
15780 ELSE
15781C...pi_tech -> f + fbar.
15782 FCOF=1D0
15783 IKA=IABS(KFDP(IDC,1))
15784 IF(IKA.LT.10) FCOF=3D0*RADC
15785 HM1=PM1
15786 HM2=PM2
15787 IF(IKA.GE.4.AND.IKA.LE.6) THEN
15788 FCOF=FCOF*PARP(141+IKA)**2
15789 HM1=PYMRUN(KFDP(IDC,1),SH)
15790 HM2=PYMRUN(KFDP(IDC,2),SH)
15791 ELSEIF(IKA.EQ.15) THEN
15792 FCOF=FCOF*PARP(148)**2
15793 ENDIF
15794 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
15795 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
15796 ENDIF
15797 WDTP(0)=WDTP(0)+WDTP(I)
15798 IF(MDME(IDC,1).GT.0) THEN
15799 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
15800 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
15801 WDTE(I,0)=WDTE(I,MDME(IDC,1))
15802 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
15803 ENDIF
15804 340 CONTINUE
15805
15806 ELSEIF(KFLA.EQ.52) THEN
15807C...pi+_tech
15808 FAC=(1D0/(32D0*PARU(1)*PARP(142)**2))*SHR
15809 DO 350 I=1,MDCY(KC,3)
15810 IDC=I+MDCY(KC,2)-1
15811 IF(MDME(IDC,1).LT.0) GOTO 350
15812 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
15813 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
15814 PM3=0D0
15815 IF(I.EQ.3) PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
15816 RM1=PM1**2/SH
15817 RM2=PM2**2/SH
15818 RM3=PM3**2/SH
15819 IF(SQRT(RM1)+SQRT(RM2)+SQRT(RM3).GT.1D0) GOTO 350
15820 WID2=1D0
15821C...pi_tech -> f + f'.
15822 FCOF=1D0
15823 IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
15824C...pi_tech+ -> W b b~
15825 IF(I.EQ.3.AND.SHR.LT.PMAS(6,1)+PMAS(5,1)) THEN
15826 FCOF=3D0*RADC
15827 XMT2=PMAS(6,1)**2/SH
15828 FACP=FAC/(4D0*PARU(1))*FCOF*XMT2*PARP(147)**2
15829 KFC3=PYCOMP(KFDP(IDC,3))
15830 CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3)
15831 CHECK = SQRT(RM1)
15832 T0 = (1D0-CHECK**2)*
15833 & (XMT2*(6.*XMT2**2+3.*XMT2*RM1-4.*RM1**2)-
15834 & (5.*XMT2**2+2.*XMT2*RM1-8.*RM1**2))/(4.*XMT2**2)
15835 T1 = (1D0-XMT2)*(RM1-XMT2)*((XMT2**2+XMT2*RM1+4.*RM1**2)
15836 & -3.*XMT2**2*(XMT2+RM1))/(2.0*XMT2**3)
15837 T3 = RM1**2/XMT2**3*(3.0*XMT2-4.0*RM1+4.0*XMT2*RM1)
15838 WDTP(I)=FACP*(T0 + T1*LOG((XMT2-CHECK**2)/(XMT2-1D0))
15839 & +T3*LOG(CHECK))
15840 IF(KFLR.GT.0) THEN
15841 WID2=WIDS(24,2)
15842 ELSE
15843 WID2=WIDS(24,3)
15844 ENDIF
15845 ELSE
15846 FCOF=1D0
15847 IKA=IABS(KFDP(IDC,1))
15848 IF(IKA.LT.10) FCOF=3D0*RADC
15849 HM1=PM1
15850 HM2=PM2
15851 IF(I.GE.1.AND.I.LE.3) THEN
15852 FCOF=FCOF*PARP(144+I)**2
15853 HM1=PYMRUN(KFDP(IDC,1),SH)
15854 HM2=PYMRUN(KFDP(IDC,2),SH)
15855 ELSEIF(I.EQ.6) THEN
15856 FCOF=FCOF*PARP(148)**2
15857 ENDIF
15858 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
15859 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
15860 ENDIF
15861 WDTP(0)=WDTP(0)+WDTP(I)
15862 IF(MDME(IDC,1).GT.0) THEN
15863 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
15864 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
15865 WDTE(I,0)=WDTE(I,MDME(IDC,1))
15866 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
15867 ENDIF
15868 350 CONTINUE
15869
15870 ELSEIF(KFLA.EQ.54) THEN
15871C...Techni-rho0:
15872 ALPRHT=2.91D0*(3D0/PARP(144))
15873 FAC=(ALPRHT/12D0)*SHR
15874 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
15875 SQMZ=PMAS(23,1)**2
15876 SQMW=PMAS(24,1)**2
15877 SHP=SH
15878 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
15879 GMMZ=SHR*WDTPP(0)
15880 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
15881 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
15882 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
15883 DO 360 I=1,MDCY(KC,3)
15884 IDC=I+MDCY(KC,2)-1
15885 IF(MDME(IDC,1).LT.0) GOTO 360
15886 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
15887 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
15888 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360
15889 WID2=1D0
15890 IF(I.EQ.1) THEN
15891C...rho_tech0 -> W+ + W-.
15892 WDTP(I)=FAC*PARP(141)**4*
15893 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
15894 WID2=WIDS(24,1)
15895 ELSEIF(I.EQ.2) THEN
15896C...rho_tech0 -> W+ + pi_tech-.
15897 WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
15898 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
15899 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
15900 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
15901 & (1D0-PARP(141)**2)/4D0/XW/24D0/PARJ(173)**2*SHR**3
15902 WID2=WIDS(24,2)*WIDS(52,3)
15903 ELSEIF(I.EQ.3) THEN
15904C...rho_tech0 -> pi_tech+ + W-.
15905 WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
15906 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
15907 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
15908 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
15909 & (1D0-PARP(141)**2)/4D0/XW/24D0/PARJ(173)**2*SHR**3
15910 WID2=WIDS(52,2)*WIDS(24,3)
15911 ELSEIF(I.EQ.4) THEN
15912C...rho_tech0 -> pi_tech+ + pi_tech-.
15913 WDTP(I)=FAC*(1D0-PARP(141)**2)**2*
15914 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
15915 WID2=WIDS(52,1)
15916 ELSEIF(I.EQ.5) THEN
15917C...rho_tech0 -> gamma + pi_tech0
15918 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
15919 & (2D0*PARP(143)-1D0)**2*(1D0-PARP(141)**2)/24D0/PARJ(172)**2*
15920 & SHR**3
15921 WID2=WIDS(51,2)
15922 ELSEIF(I.EQ.6) THEN
15923C...rho_tech0 -> gamma + pi_tech0'
15924 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
15925 & (1D0-PARJ(174)**2)/24D0/PARJ(172)**2*SHR**3
15926 WID2=WIDS(53,2)
15927 ELSEIF(I.EQ.7) THEN
15928C...rho_tech0 -> Z0 + pi_tech0
15929 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
15930 & (2D0*PARP(143)-1D0)**2*(1D0-PARP(141)**2)/24D0/PARJ(172)**2*
15931 & XW/XW1*SHR**3
15932 WID2=WIDS(23,2)*WIDS(51,2)
15933 ELSEIF(I.EQ.8) THEN
15934C...rho_tech0 -> Z0 + pi_tech0'
15935 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
15936 & (1D0-PARJ(174)**2)/24D0/PARJ(172)**2*(1D0-2D0*XW)**2/4D0/
15937 & XW/XW1*SHR**3
15938 WID2=WIDS(23,2)*WIDS(53,2)
15939 ELSE
15940C...rho_tech0 -> f + fbar.
15941 WID2=1D0
15942 IF(I.LE.16) THEN
15943 IA=I-8
15944 FCOF=3D0*RADC
15945 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
15946 ELSE
15947 IA=I-6
15948 FCOF=1D0
15949 IF(IA.GE.17) WID2=WIDS(IA,1)
15950 ENDIF
15951 EI=KCHG(IA,1)/3D0
15952 AI=SIGN(1D0,EI+0.1D0)
15953 VI=AI-4D0*EI*XWV
15954 VALI=0.5D0*(VI+AI)
15955 VARI=0.5D0*(VI-AI)
15956 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
15957 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
15958 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
15959 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
15960 ENDIF
15961 WDTP(0)=WDTP(0)+WDTP(I)
15962 IF(MDME(IDC,1).GT.0) THEN
15963 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
15964 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
15965 WDTE(I,0)=WDTE(I,MDME(IDC,1))
15966 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
15967 ENDIF
15968 360 CONTINUE
15969
15970 ELSEIF(KFLA.EQ.55) THEN
15971C...Techni-rho+/-:
15972 ALPRHT=2.91D0*(3D0/PARP(144))
15973 FAC=(ALPRHT/12D0)*SHR
15974 SQMZ=PMAS(23,1)**2
15975 SQMW=PMAS(24,1)**2
15976 SHP=SH
15977 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
15978 GMMW=SHR*WDTPP(0)
15979 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
15980 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
15981 DO 370 I=1,MDCY(KC,3)
15982 IDC=I+MDCY(KC,2)-1
15983 IF(MDME(IDC,1).LT.0) GOTO 370
15984 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
15985 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
15986 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370
15987 WID2=1D0
15988 IF(I.EQ.1) THEN
15989C...rho_tech+ -> W+ + Z0.
15990 WDTP(I)=FAC*PARP(141)**4*
15991 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
15992 IF(KFLR.GT.0) THEN
15993 WID2=WIDS(24,2)*WIDS(23,2)
15994 ELSE
15995 WID2=WIDS(24,3)*WIDS(23,2)
15996 ENDIF
15997 ELSEIF(I.EQ.2) THEN
15998C...rho_tech+ -> W+ + pi_tech0.
15999 WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
16000 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
16001 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16002 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
16003 & (1D0-PARP(141)**2)/4D0/XW/24D0/PARJ(173)**2*SHR**3
16004 IF(KFLR.GT.0) THEN
16005 WID2=WIDS(24,2)*WIDS(51,2)
16006 ELSE
16007 WID2=WIDS(24,3)*WIDS(51,2)
16008 ENDIF
16009 ELSEIF(I.EQ.3) THEN
16010C...rho_tech+ -> pi_tech+ + Z0.
16011 WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
16012 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
16013 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16014 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMZ/SH)*
16015 & (1D0-PARP(141)**2)/4D0/XW/XW1/24D0/PARJ(173)**2*SHR**3+
16016 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
16017 & (2D0*PARP(143)-1D0)**2*(1D0-PARP(141)**2)/24D0/PARJ(172)**2*
16018 & SHR**3*XW/XW1
16019 IF(KFLR.GT.0) THEN
16020 WID2=WIDS(52,2)*WIDS(23,2)
16021 ELSE
16022 WID2=WIDS(52,3)*WIDS(23,2)
16023 ENDIF
16024 ELSEIF(I.EQ.4) THEN
16025C...rho_tech+ -> pi_tech+ + pi_tech0.
16026 WDTP(I)=FAC*(1D0-PARP(141)**2)**2*
16027 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
16028 IF(KFLR.GT.0) THEN
16029 WID2=WIDS(52,2)*WIDS(51,2)
16030 ELSE
16031 WID2=WIDS(52,3)*WIDS(51,2)
16032 ENDIF
16033 ELSEIF(I.EQ.5) THEN
16034C...rho_tech+ -> pi_tech+ + gamma
16035 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
16036 & (2D0*PARP(143)-1D0)**2*(1D0-PARP(141)**2)/24D0/PARJ(172)**2*
16037 & SHR**3
16038 IF(KFLR.GT.0) THEN
16039 WID2=WIDS(52,2)
16040 ELSE
16041 WID2=WIDS(52,3)
16042 ENDIF
16043 ELSEIF(I.EQ.6) THEN
16044C...rho_tech+ -> W+ + pi_tech0'
16045 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
16046 & (1D0-PARJ(174)**2)/4D0/XW/24D0/PARJ(172)**2*SHR**3
16047 IF(KFLR.GT.0) THEN
16048 WID2=WIDS(24,2)*WIDS(53,2)
16049 ELSE
16050 WID2=WIDS(24,3)*WIDS(53,2)
16051 ENDIF
16052 ELSE
16053C...rho_tech+ -> f + fbar'.
16054 IA=I-6
16055 WID2=1D0
16056 IF(IA.LE.16) THEN
16057 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
16058 IF(KFLR.GT.0) THEN
16059 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
16060 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
16061 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
16062 ELSE
16063 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
16064 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
16065 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
16066 ENDIF
16067 ELSE
16068 FCOF=1D0
16069 IF(KFLR.GT.0) THEN
16070 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
16071 ELSE
16072 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
16073 ENDIF
16074 ENDIF
16075 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
16076 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
16077 ENDIF
16078 WDTP(0)=WDTP(0)+WDTP(I)
16079 IF(MDME(IDC,1).GT.0) THEN
16080 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16081 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16082 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16083 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16084 ENDIF
16085 370 CONTINUE
16086
16087 ELSEIF(KFLA.EQ.56) THEN
16088C...Techni-omega:
16089 ALPRHT=2.91D0*(3D0/PARP(144))
16090 FAC=(ALPRHT/12D0)*SHR
16091 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR*(2D0*PARP(143)-1D0)**2
16092 SQMZ=PMAS(23,1)**2
16093 SHP=SH
16094 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
16095 GMMZ=SHR*WDTPP(0)
16096 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
16097 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
16098 DO 380 I=1,MDCY(KC,3)
16099 IDC=I+MDCY(KC,2)-1
16100 IF(MDME(IDC,1).LT.0) GOTO 380
16101 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16102 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16103 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380
16104 WID2=1D0
16105 IF(I.EQ.1) THEN
16106C...omega_tech0 -> gamma + pi_tech0.
16107 WDTP(I)=AEM/24D0/PARJ(172)**2*(1D0-PARP(141)**2)*
16108 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*SHR**3
16109 WID2=WIDS(51,2)
16110 ELSEIF(I.EQ.2) THEN
16111C...omega_tech0 -> Z0 + pi_tech0
16112 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
16113 & (1D0-PARP(141)**2)/24D0/PARJ(172)**2*(1D0-2D0*XW)**2/4D0/
16114 & XW/XW1*SHR**3
16115 WID2=WIDS(23,2)*WIDS(51,2)
16116 ELSEIF(I.EQ.3) THEN
16117C...omega_tech0 -> gamma + pi_tech0'
16118 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
16119 & (2D0*PARP(143)-1D0)**2*(1D0-PARJ(174)**2)/24D0/PARJ(172)**2*
16120 & SHR**3
16121 WID2=WIDS(53,2)
16122 ELSEIF(I.EQ.4) THEN
16123C...omega_tech0 -> Z0 + pi_tech0'
16124 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
16125 & (2D0*PARP(143)-1D0)**2*(1D0-PARJ(174)**2)/24D0/PARJ(172)**2*
16126 & XW/XW1*SHR**3
16127 WID2=WIDS(23,2)*WIDS(51,2)
16128 ELSEIF(I.EQ.5) THEN
16129C...omega_tech0 -> W+ + pi_tech-
16130 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
16131 & (1D0-PARP(141)**2)/4D0/XW/24D0/PARJ(172)**2*SHR**3+
16132 & FAC*PARP(141)**2*(1D0-PARP(141)**2)*PARJ(175)**2*
16133 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
16134 WID2=WIDS(24,2)*WIDS(52,3)
16135 ELSEIF(I.EQ.6) THEN
16136C...omega_tech0 -> pi_tech+ + W-
16137 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
16138 & (1D0-PARP(141)**2)/4D0/XW/24D0/PARJ(172)**2*SHR**3+
16139 & FAC*PARP(141)**2*(1D0-PARP(141)**2)*PARJ(175)**2*
16140 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
16141 WID2=WIDS(24,3)*WIDS(52,2)
16142 ELSEIF(I.EQ.7) THEN
16143C...omega_tech0 -> W+ + W-.
16144 WDTP(I)=FAC*PARP(141)**4*PARJ(175)**2*
16145 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
16146 WID2=WIDS(24,1)
16147 ELSEIF(I.EQ.8) THEN
16148C...omega_tech0 -> pi_tech+ + pi_tech-.
16149 WDTP(I)=FAC*(1D0-PARP(141)**2)**2*PARJ(175)**2*
16150 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
16151 WID2=WIDS(52,1)
16152 ELSE
16153C...omega_tech0 -> f + fbar.
16154 WID2=1D0
16155 IF(I.LE.14) THEN
16156 IA=I-8
16157 FCOF=3D0*RADC
16158 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
16159 ELSE
16160 IA=I-6
16161 FCOF=1D0
16162 IF(IA.GE.17) WID2=WIDS(IA,1)
16163 ENDIF
16164 EI=KCHG(IA,1)/3D0
16165 AI=SIGN(1D0,EI+0.1D0)
16166 VI=AI-4D0*EI*XWV
16167 VALI=0.5D0*(VI+AI)
16168 VARI=0.5D0*(VI-AI)
16169 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
16170 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
16171 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
16172 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
16173 ENDIF
16174 WDTP(0)=WDTP(0)+WDTP(I)
16175 IF(MDME(IDC,1).GT.0) THEN
16176 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16177 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16178 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16179 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16180 ENDIF
16181 380 CONTINUE
16182
16183 ELSEIF(KFLA.EQ.61) THEN
16184C...H_L++/--:
16185 FAC=(1D0/(8D0*PARU(1)))*SHR
16186 DO 372 I=1,MDCY(KC,3)
16187 IDC=I+MDCY(KC,2)-1
16188 IF(MDME(IDC,1).LT.0) GOTO 372
16189 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16190 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16191 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 372
16192 WID2=1D0
16193 IF(I.LE.6) THEN
16194C...H_L++/-- -> l+/- + l'+/-
16195 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
16196 & (IABS(KFDP(IDC,2))-9)/2)**2
16197C***Should be factor 4 below ???
16198 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
16199 ELSEIF(I.EQ.7) THEN
16200C...H_L++/-- -> W_L+/- + W_L+/-
16201 FCOF=0.5D0*PARP(190)**4*PARP(192)**2/PMAS(24,1)**2*
16202 & (3D0*RM1+0.25D0/RM1-1D0)
16203 WID2=WIDS(24,4+(1-KFLS)/2)
16204 ENDIF
16205 WDTP(I)=FAC*FCOF*
16206 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
16207 WDTP(0)=WDTP(0)+WDTP(I)
16208 IF(MDME(IDC,1).GT.0) THEN
16209 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16210 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16211 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16212 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16213 ENDIF
16214 372 CONTINUE
16215
16216 ELSEIF(KFLA.EQ.62) THEN
16217C...H_R++/--:
16218 FAC=(1D0/(8D0*PARU(1)))*SHR
16219 DO 373 I=1,MDCY(KC,3)
16220 IDC=I+MDCY(KC,2)-1
16221 IF(MDME(IDC,1).LT.0) GOTO 373
16222 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16223 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16224 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 373
16225 WID2=1D0
16226 IF(I.LE.6) THEN
16227C...H_R++/-- -> l+/- + l'+/-
16228 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
16229 & (IABS(KFDP(IDC,2))-9)/2)**2
16230 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
16231 ELSEIF(I.EQ.7) THEN
16232C...H_R++/-- -> W_R+/- + W_R+/-
16233 FCOF=PARP(191)**2*(3D0*RM1+0.25D0/RM1-1D0)
16234 WID2=WIDS(63,4+(1-KFLS)/2)
16235 ENDIF
16236 WDTP(I)=FAC*FCOF*
16237 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
16238 WDTP(0)=WDTP(0)+WDTP(I)
16239 IF(MDME(IDC,1).GT.0) THEN
16240 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16241 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16242 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16243 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16244 ENDIF
16245 373 CONTINUE
16246
16247 ELSEIF(KFLA.EQ.63) THEN
16248C...W_R+/-:
16249 FAC=(AEM/(24D0*XW))*SHR
16250 DO 374 I=1,MDCY(KC,3)
16251 IDC=I+MDCY(KC,2)-1
16252 IF(MDME(IDC,1).LT.0) GOTO 374
16253 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16254 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16255 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 374
16256 WID2=1D0
16257 IF(I.LE.9) THEN
16258C...W_R+/- -> q + qbar'
16259 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
16260 IF(KFLR.GT.0) THEN
16261 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
16262 ELSE
16263 IF(MOD(I,3).EQ.0) WID2=WIDS(6,3)
16264 ENDIF
16265 ELSEIF(I.LE.12) THEN
16266C...W_R+/- -> l+/- + nu_R
16267 FCOF=1D0
16268 ENDIF
16269 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
16270 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
16271 WDTP(0)=WDTP(0)+WDTP(I)
16272 IF(MDME(IDC,1).GT.0) THEN
16273 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16274 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16275 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16276 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16277 ENDIF
16278 374 CONTINUE
16279
16280 ELSEIF(KFLA.EQ.KEXCIT+1) THEN
16281C...d* excited quark.
16282 FAC=(SH/PARU(155)**2)*SHR
16283 DO 390 I=1,MDCY(KC,3)
16284 IDC=I+MDCY(KC,2)-1
16285 IF(MDME(IDC,1).LT.0) GOTO 390
16286 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16287 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16288 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390
16289 WID2=1D0
16290 IF(I.EQ.1) THEN
16291C...d* -> g + d.
16292 WDTP(I)=FAC*AS*PARU(159)**2/3D0
16293 WID2=1D0
16294 ELSEIF(I.EQ.2) THEN
16295C...d* -> gamma + d.
16296 QF=-PARU(157)/2D0+PARU(158)/6D0
16297 WDTP(I)=FAC*AEM*QF**2/4D0
16298 WID2=1D0
16299 ELSEIF(I.EQ.3) THEN
16300C...d* -> Z0 + d.
16301 QF=-PARU(157)*XW1/2D0-PARU(158)*XW/6D0
16302 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
16303 & (1D0-RM1)**2*(2D0+RM1)
16304 WID2=WIDS(23,2)
16305 ELSEIF(I.EQ.4) THEN
16306C...d* -> W- + u.
16307 WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
16308 & (1D0-RM1)**2*(2D0+RM1)
16309 IF(KFLR.GT.0) WID2=WIDS(24,3)
16310 IF(KFLR.LT.0) WID2=WIDS(24,2)
16311 ENDIF
16312 WDTP(0)=WDTP(0)+WDTP(I)
16313 IF(MDME(IDC,1).GT.0) THEN
16314 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16315 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16316 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16317 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16318 ENDIF
16319 390 CONTINUE
16320
16321 ELSEIF(KFLA.EQ.KEXCIT+2) THEN
16322C...u* excited quark.
16323 FAC=(SH/PARU(155)**2)*SHR
16324 DO 400 I=1,MDCY(KC,3)
16325 IDC=I+MDCY(KC,2)-1
16326 IF(MDME(IDC,1).LT.0) GOTO 400
16327 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16328 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16329 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 400
16330 WID2=1D0
16331 IF(I.EQ.1) THEN
16332C...u* -> g + u.
16333 WDTP(I)=FAC*AS*PARU(159)**2/3D0
16334 WID2=1D0
16335 ELSEIF(I.EQ.2) THEN
16336C...u* -> gamma + u.
16337 QF=PARU(157)/2D0+PARU(158)/6D0
16338 WDTP(I)=FAC*AEM*QF**2/4D0
16339 WID2=1D0
16340 ELSEIF(I.EQ.3) THEN
16341C...u* -> Z0 + u.
16342 QF=PARU(157)*XW1/2D0-PARU(158)*XW/6D0
16343 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
16344 & (1D0-RM1)**2*(2D0+RM1)
16345 WID2=WIDS(23,2)
16346 ELSEIF(I.EQ.4) THEN
16347C...u* -> W+ + d.
16348 WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
16349 & (1D0-RM1)**2*(2D0+RM1)
16350 IF(KFLR.GT.0) WID2=WIDS(24,2)
16351 IF(KFLR.LT.0) WID2=WIDS(24,3)
16352 ENDIF
16353 WDTP(0)=WDTP(0)+WDTP(I)
16354 IF(MDME(IDC,1).GT.0) THEN
16355 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16356 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16357 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16358 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16359 ENDIF
16360 400 CONTINUE
16361
16362 ELSEIF(KFLA.EQ.KEXCIT+11) THEN
16363C...e* excited lepton.
16364 FAC=(SH/PARU(155)**2)*SHR
16365 DO 410 I=1,MDCY(KC,3)
16366 IDC=I+MDCY(KC,2)-1
16367 IF(MDME(IDC,1).LT.0) GOTO 410
16368 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16369 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16370 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410
16371 WID2=1D0
16372 IF(I.EQ.1) THEN
16373C...e* -> gamma + e.
16374 QF=-PARU(157)/2D0-PARU(158)/2D0
16375 WDTP(I)=FAC*AEM*QF**2/4D0
16376 WID2=1D0
16377 ELSEIF(I.EQ.2) THEN
16378C...e* -> Z0 + e.
16379 QF=-PARU(157)*XW1/2D0+PARU(158)*XW/2D0
16380 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
16381 & (1D0-RM1)**2*(2D0+RM1)
16382 WID2=WIDS(23,2)
16383 ELSEIF(I.EQ.3) THEN
16384C...e* -> W- + nu.
16385 WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
16386 & (1D0-RM1)**2*(2D0+RM1)
16387 IF(KFLR.GT.0) WID2=WIDS(24,3)
16388 IF(KFLR.LT.0) WID2=WIDS(24,2)
16389 ENDIF
16390 WDTP(0)=WDTP(0)+WDTP(I)
16391 IF(MDME(IDC,1).GT.0) THEN
16392 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16393 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16394 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16395 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16396 ENDIF
16397 410 CONTINUE
16398
16399 ELSEIF(KFLA.EQ.KEXCIT+12) THEN
16400C...nu*_e excited neutrino.
16401 FAC=(SH/PARU(155)**2)*SHR
16402 DO 420 I=1,MDCY(KC,3)
16403 IDC=I+MDCY(KC,2)-1
16404 IF(MDME(IDC,1).LT.0) GOTO 420
16405 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16406 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16407 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 420
16408 WID2=1D0
16409 IF(I.EQ.1) THEN
16410C...nu*_e -> Z0 + nu*_e.
16411 QF=PARU(157)*XW1/2D0+PARU(158)*XW/2D0
16412 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
16413 & (1D0-RM1)**2*(2D0+RM1)
16414 WID2=WIDS(23,2)
16415 ELSEIF(I.EQ.2) THEN
16416C...nu*_e -> W+ + e.
16417 WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
16418 & (1D0-RM1)**2*(2D0+RM1)
16419 IF(KFLR.GT.0) WID2=WIDS(24,2)
16420 IF(KFLR.LT.0) WID2=WIDS(24,3)
16421 ENDIF
16422 WDTP(0)=WDTP(0)+WDTP(I)
16423 IF(MDME(IDC,1).GT.0) THEN
16424 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16425 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16426 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16427 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16428 ENDIF
16429 420 CONTINUE
16430
16431 ENDIF
16432 MINT(61)=0
16433 MINT(62)=0
16434 MINT(63)=0
16435
16436 RETURN
16437 END
16438
16439C***********************************************************************
16440
16441C...PYWIDX
16442C...Calculates full and partial widths of resonances.
16443C....copy of PYWIDT, used for techniparticle widths
16444
16445 SUBROUTINE PYWIDX(KFLR,SH,WDTP,WDTE)
16446
16447C...Double precision and integer declarations.
16448 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16449 IMPLICIT INTEGER(I-N)
16450 INTEGER PYK,PYCHGE,PYCOMP
16451C...Parameter statement to help give large particle numbers.
16452 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
16453C...Commonblocks.
16454 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16455 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
16456 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
16457 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
16458 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16459 COMMON/PYINT1/MINT(400),VINT(400)
16460 COMMON/PYINT4/MWID(500),WIDS(500,5)
16461 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
16462 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
16463 &SFMIX(16,4)
16464 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
16465 &/PYINT4/,/PYMSSM/,/PYSSMT/
16466C...Local arrays and saved variables.
16467 DIMENSION WDTP(0:200),WDTE(0:200,0:5),MOFSV(3,2),WIDWSV(3,2),
16468 &WID2SV(3,2)
16469 SAVE MOFSV,WIDWSV,WID2SV
16470 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
16471
16472C...Compressed code and sign; mass.
16473 KFLA=IABS(KFLR)
16474 KFLS=ISIGN(1,KFLR)
16475 KC=PYCOMP(KFLA)
16476 SHR=SQRT(SH)
16477 PMR=PMAS(KC,1)
16478
16479C...Reset width information.
16480 DO 110 I=0,200
16481 WDTP(I)=0D0
16482 DO 100 J=0,5
16483 WDTE(I,J)=0D0
16484 100 CONTINUE
16485 110 CONTINUE
16486
16487C...Common electroweak and strong constants.
16488 XW=PARU(102)
16489 XWV=XW
16490 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
16491 XW1=1D0-XW
16492 AEM=PYALEM(SH)
16493 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
16494 AS=PYALPS(SH)
16495 RADC=1D0+AS/PARU(1)
16496
16497 IF(KFLA.EQ.23) THEN
16498C...Z0:
16499 ICASE=1
16500 XWC=1D0/(16D0*XW*XW1)
16501 FAC=(AEM*XWC/3D0)*SHR
16502 200 CONTINUE
16503 DO 210 I=1,MDCY(KC,3)
16504 IDC=I+MDCY(KC,2)-1
16505 IF(MDME(IDC,1).LT.0) GOTO 210
16506 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16507 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16508 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 210
16509 WID2=1D0
16510 IF(I.LE.8) THEN
16511C...Z0 -> q + qbar
16512 EF=KCHG(I,1)/3D0
16513 AF=SIGN(1D0,EF+0.1D0)
16514 VF=AF-4D0*EF*XWV
16515 FCOF=3D0*RADC
16516 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
16517 IF(I.EQ.6) WID2=WIDS(6,1)
16518 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
16519 ELSEIF(I.LE.16) THEN
16520C...Z0 -> l+ + l-, nu + nubar
16521 EF=KCHG(I+2,1)/3D0
16522 AF=SIGN(1D0,EF+0.1D0)
16523 VF=AF-4D0*EF*XWV
16524 FCOF=1D0
16525 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
16526 ENDIF
16527 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
16528 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
16529 & BE34
16530 WDTP(0)=WDTP(0)+WDTP(I)
16531 IF(MDME(IDC,1).GT.0) THEN
16532 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16533 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
16534 & WDTE(I,MDME(IDC,1))
16535 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16536 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16537 ENDIF
16538 210 CONTINUE
16539
16540
16541 ELSEIF(KFLA.EQ.24) THEN
16542C...W+/-:
16543 FAC=(AEM/(24D0*XW))*SHR
16544 DO 220 I=1,MDCY(KC,3)
16545 IDC=I+MDCY(KC,2)-1
16546 IF(MDME(IDC,1).LT.0) GOTO 220
16547 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16548 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16549 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220
16550 WID2=1D0
16551 IF(I.LE.16) THEN
16552C...W+/- -> q + qbar'
16553 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
16554 IF(KFLR.GT.0) THEN
16555 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
16556 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
16557 IF(I.GE.13) WID2=WID2*WIDS(7,3)
16558 ELSE
16559 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
16560 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
16561 IF(I.GE.13) WID2=WID2*WIDS(7,2)
16562 ENDIF
16563 ELSEIF(I.LE.20) THEN
16564C...W+/- -> l+/- + nu
16565 FCOF=1D0
16566 IF(KFLR.GT.0) THEN
16567 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
16568 ELSE
16569 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
16570 ENDIF
16571 ENDIF
16572 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
16573 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
16574 WDTP(0)=WDTP(0)+WDTP(I)
16575 IF(MDME(IDC,1).GT.0) THEN
16576 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16577 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16578 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16579 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16580 ENDIF
16581 220 CONTINUE
16582 ENDIF
16583
16584 RETURN
16585 END
16586
16587C***********************************************************************
16588
16589C...PYOFSH
16590C...Calculates partial width and differential cross-section maxima
16591C...of channels/processes not allowed on mass-shell, and selects
16592C...masses in such channels/processes.
16593
16594 SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
16595
16596C...Double precision and integer declarations.
16597 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16598 IMPLICIT INTEGER(I-N)
16599 INTEGER PYK,PYCHGE,PYCOMP
16600C...Commonblocks.
16601 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16602 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
16603 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
16604 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
16605 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16606 COMMON/PYINT1/MINT(400),VINT(400)
16607 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
16608 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
16609 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
16610 &/PYINT2/,/PYINT5/
16611C...Local arrays.
16612 DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2),
16613 &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100),
16614 &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:200),
16615 &WDTE(0:200,0:5)
16616
16617C...Find if particles equal, maximum mass, matrix elements, etc.
16618 MINT(51)=0
16619 ISUB=MINT(1)
16620 KFD(1)=IABS(KFD1)
16621 KFD(2)=IABS(KFD2)
16622 MEQL=0
16623 IF(KFD(1).EQ.KFD(2)) MEQL=1
16624 MLM=0
16625 IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0))
16626 IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN
16627 NOFF=44
16628 PMMX=PMMO
16629 ELSE
16630 NOFF=40
16631 PMMX=VINT(1)
16632 IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1))
16633 ENDIF
16634 MMED=0
16635 IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
16636 &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
16637 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR.
16638 &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2
16639 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR.
16640 &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3
16641 LOOP=1
16642
16643C...Find where Breit-Wigners are required, else select discrete masses.
16644 100 DO 110 I=1,2
16645 KFCA=PYCOMP(KFD(I))
16646 IF(KFCA.GT.0) THEN
16647 PMD(I)=PMAS(KFCA,1)
16648 PGD(I)=PMAS(KFCA,2)
16649 ELSE
16650 PMD(I)=0D0
16651 PGD(I)=0D0
16652 ENDIF
16653 IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN
16654 MBW(I)=0
16655 PMG(I)=PMD(I)
16656 RMG(I)=(PMG(I)/PMMX)**2
16657 ELSE
16658 MBW(I)=1
16659 ENDIF
16660 110 CONTINUE
16661
16662C...Find allowed mass range and Breit-Wigner parameters.
16663 DO 120 I=1,2
16664 IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN
16665 PML(I)=PARP(42)
16666 PMU(I)=PMMX-PARP(42)
16667 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
16668 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
16669 ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN
16670 ILM=I
16671 IF(MLM.EQ.2) ILM=3-I
16672 PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42))
16673 IF(MBW(3-I).EQ.0) THEN
16674 PMU(I)=PMMX-PMD(3-I)
16675 ELSE
16676 PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42))
16677 ENDIF
16678 IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=
16679 & MIN(PMU(I),CKIN(NOFF+2*ILM))
16680 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
16681 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
16682 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
16683 IF(MBW(I).EQ.1) THEN
16684 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
16685 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
16686 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
16687 & PGD(I)))
16688 ENDIF
16689 ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN
16690 ILM=I
16691 IF(MLM.EQ.2) ILM=3-I
16692 PML(I)=MAX(CKIN(48+I),PARP(42))
16693 PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42))
16694 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
16695 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
16696 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
16697 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
16698 IF(MBW(I).EQ.1) THEN
16699 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
16700 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
16701 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
16702 & PGD(I)))
16703 ENDIF
16704 ENDIF
16705 120 CONTINUE
16706 IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0))
16707 &THEN
16708 CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses')
16709 MINT(51)=1
16710 RETURN
16711 ENDIF
16712
16713C...Calculation of partial width of resonance.
16714 IF(MOFSH.EQ.1) THEN
16715
16716C..If only one integration, pick that to be the inner.
16717 IF(MBW(1).EQ.0) THEN
16718 PM2=PMD(1)
16719 PMD(1)=PMD(2)
16720 PGD(1)=PGD(2)
16721 PML(1)=PML(2)
16722 PMU(1)=PMU(2)
16723 ELSEIF(MBW(2).EQ.0) THEN
16724 PM2=PMD(2)
16725 ENDIF
16726
16727C...Start outer loop of integration.
16728 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
16729 ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
16730 ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
16731 NPT2=1
16732 XPT2(1)=1D0
16733 INX2(1)=0
16734 FMAX2=0D0
16735 ENDIF
16736 130 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
16737 PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2))
16738 PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S))))
16739 ENDIF
16740 RM2=(PM2/PMMX)**2
16741
16742C...Start inner loop of integration.
16743 PML1=PML(1)
16744 PMU1=MIN(PMU(1),PMMX-PM2)
16745 IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2)
16746 ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
16747 ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
16748 IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN
16749 FUNC2=0D0
16750 GOTO 180
16751 ENDIF
16752 NPT1=1
16753 XPT1(1)=1D0
16754 INX1(1)=0
16755 FMAX1=0D0
16756 140 PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1))
16757 PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S))))
16758 RM1=(PM1/PMMX)**2
16759
16760C...Evaluate function value - inner loop.
16761 FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
16762 IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2)
16763 IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+
16764 & RM2**2+10D0*RM1*RM2)
16765 IF(FUNC1.GT.FMAX1) FMAX1=FUNC1
16766 FPT1(NPT1)=FUNC1
16767
16768C...Go to next position in inner loop.
16769 IF(NPT1.EQ.1) THEN
16770 NPT1=NPT1+1
16771 XPT1(NPT1)=0D0
16772 INX1(NPT1)=1
16773 GOTO 140
16774 ELSEIF(NPT1.LE.8) THEN
16775 NPT1=NPT1+1
16776 IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1
16777 ISH1=ISH1+1
16778 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
16779 INX1(NPT1)=INX1(ISH1)
16780 INX1(ISH1)=NPT1
16781 GOTO 140
16782 ELSEIF(NPT1.LT.100) THEN
16783 ISN1=ISH1
16784 150 ISH1=ISH1+1
16785 IF(ISH1.GT.NPT1) ISH1=2
16786 IF(ISH1.EQ.ISN1) GOTO 160
16787 DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1)))
16788 IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150
16789 NPT1=NPT1+1
16790 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
16791 INX1(NPT1)=INX1(ISH1)
16792 INX1(ISH1)=NPT1
16793 GOTO 140
16794 ENDIF
16795
16796C...Calculate integral over inner loop.
16797 160 FSUM1=0D0
16798 DO 170 IPT1=2,NPT1
16799 FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))*
16800 & (XPT1(INX1(IPT1))-XPT1(IPT1))
16801 170 CONTINUE
16802 FUNC2=FSUM1*(ATU1-ATL1)/PARU(1)
16803 180 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
16804 IF(FUNC2.GT.FMAX2) FMAX2=FUNC2
16805 FPT2(NPT2)=FUNC2
16806
16807C...Go to next position in outer loop.
16808 IF(NPT2.EQ.1) THEN
16809 NPT2=NPT2+1
16810 XPT2(NPT2)=0D0
16811 INX2(NPT2)=1
16812 GOTO 130
16813 ELSEIF(NPT2.LE.8) THEN
16814 NPT2=NPT2+1
16815 IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1
16816 ISH2=ISH2+1
16817 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
16818 INX2(NPT2)=INX2(ISH2)
16819 INX2(ISH2)=NPT2
16820 GOTO 130
16821 ELSEIF(NPT2.LT.100) THEN
16822 ISN2=ISH2
16823 190 ISH2=ISH2+1
16824 IF(ISH2.GT.NPT2) ISH2=2
16825 IF(ISH2.EQ.ISN2) GOTO 200
16826 DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2)))
16827 IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190
16828 NPT2=NPT2+1
16829 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
16830 INX2(NPT2)=INX2(ISH2)
16831 INX2(ISH2)=NPT2
16832 GOTO 130
16833 ENDIF
16834
16835C...Calculate integral over outer loop.
16836 200 FSUM2=0D0
16837 DO 210 IPT2=2,NPT2
16838 FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))*
16839 & (XPT2(INX2(IPT2))-XPT2(IPT2))
16840 210 CONTINUE
16841 FSUM2=FSUM2*(ATU2-ATL2)/PARU(1)
16842 IF(MEQL.EQ.1) FSUM2=2D0*FSUM2
16843 ELSE
16844 FSUM2=FUNC2
16845 ENDIF
16846
16847C...Save result; second integration for user-selected mass range.
16848 IF(LOOP.EQ.1) WIDW=FSUM2
16849 WID2=FSUM2
16850 IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47)
16851 & .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN
16852 LOOP=2
16853 GOTO 100
16854 ENDIF
16855 RET1=WIDW
16856 RET2=WID2/WIDW
16857
16858C...Select two decay product masses of a resonance.
16859 ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN
16860 220 DO 230 I=1,2
16861 IF(MBW(I).EQ.0) GOTO 230
16862 PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*
16863 & (ATU(I)-ATL(I)))
16864 PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW))))
16865 RMG(I)=(PMG(I)/PMMX)**2
16866 230 CONTINUE
16867 IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
16868 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220
16869
16870C...Weight with matrix element (if none known, use beta factor).
16871 FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2)))
16872 IF(MMED.EQ.1) THEN
16873 WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2))
16874 ELSEIF(MMED.EQ.2) THEN
16875 WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+
16876 & RMG(2)**2+10D0*RMG(1)*RMG(2))
16877 ELSEIF(MMED.EQ.3) THEN
16878 WTBE=FLAM*(RMG(1)+FLAM**2/12D0)
16879 ELSE
16880 WTBE=FLAM
16881 ENDIF
16882 IF(WTBE.LT.PYR(0)) GOTO 220
16883 RET1=PMG(1)
16884 RET2=PMG(2)
16885
16886C...Find suitable set of masses for initialization of 2 -> 2 processes.
16887 ELSEIF(MOFSH.EQ.3) THEN
16888 IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN
16889 PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1)))
16890 PMG(2)=PMD(2)
16891 ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN
16892 PMG(1)=PMD(1)
16893 PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2)))
16894 ELSE
16895 IDIV=-1
16896 240 IDIV=IDIV+1
16897 PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1)))
16898 PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2)))
16899 IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240
16900 ENDIF
16901 RET1=PMG(1)
16902 RET2=PMG(2)
16903
16904C...Evaluate importance of excluded tails of Breit-Wigners.
16905 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
16906 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
16907 IF(MEQL.LE.1) THEN
16908 VINT(80)=1D0
16909 DO 250 I=1,2
16910 IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/
16911 & PARU(1)
16912 250 CONTINUE
16913 ELSE
16914 VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))*
16915 & (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2)))
16916 ENDIF
16917 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND.
16918 & MSTP(43).NE.2) VINT(80)=2D0*VINT(80)
16919 IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80)
16920 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
16921
16922C...Pick one particle to be the lighter (if improves efficiency).
16923 ELSEIF(MOFSH.EQ.4) THEN
16924 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
16925 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
16926 260 IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0))
16927
16928C...Select two masses according to Breit-Wigner + flat in s + 1/s.
16929 DO 270 I=1,2
16930 IF(MBW(I).EQ.0) GOTO 270
16931 PMV=PMU(I)
16932 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
16933 ATV=ATU(I)
16934 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
16935 RBR=PYR(0)
16936 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
16937 & ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR
16938 IF(RBR.LT.0.8D0) THEN
16939 PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I)))
16940 PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR))))
16941 ELSEIF(RBR.LT.0.9D0) THEN
16942 PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2)))
16943 ELSEIF(RBR.LT.1.5D0) THEN
16944 PMG(I)=PML(I)*(PMV/PML(I))**PYR(0)
16945 ELSE
16946 PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)*
16947 & (PMV**2-PML(I)**2))))
16948 ENDIF
16949 270 CONTINUE
16950 IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
16951 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN
16952 IF(MINT(48).EQ.1) THEN
16953 NGEN(0,1)=NGEN(0,1)+1
16954 NGEN(MINT(1),1)=NGEN(MINT(1),1)+1
16955 GOTO 260
16956 ELSE
16957 MINT(51)=1
16958 RETURN
16959 ENDIF
16960 ENDIF
16961 RET1=PMG(1)
16962 RET2=PMG(2)
16963
16964C...Give weight for selected mass distribution.
16965 VINT(80)=1D0
16966 DO 280 I=1,2
16967 IF(MBW(I).EQ.0) GOTO 280
16968 PMV=PMU(I)
16969 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
16970 ATV=ATU(I)
16971 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
16972 F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+
16973 & (PMD(I)*PGD(I))**2)/PARU(1)
16974 F1=1D0
16975 F2=1D0/PMG(I)**2
16976 F3=1D0/PMG(I)**4
16977 FI0=(ATV-ATL(I))/PARU(1)
16978 FI1=PMV**2-PML(I)**2
16979 FI2=2D0*LOG(PMV/PML(I))
16980 FI3=1D0/PML(I)**2-1D0/PMV**2
16981 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
16982 & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
16983 VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+
16984 & 5D0*F3/FI3))
16985 ELSE
16986 VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2))
16987 ENDIF
16988 VINT(80)=VINT(80)*FI0
16989 280 CONTINUE
16990 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
16991 ENDIF
16992
16993 RETURN
16994 END
16995
16996C***********************************************************************
16997
16998C...PYRECO
16999C...Handles the possibility of colour reconnection in W+W- events,
17000C...Based on the main scenarios of the Sjostrand and Khoze study:
17001C...I, II, II', intermediate and instantaneous; plus one model
17002C...along the lines of the Gustafson and Hakkinen: GH.
17003C...Note: also handles Z0 Z0 and W-W+ events, but notation below
17004C...is as if first resonance is W+ and second W-.
17005
17006 SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
17007
17008C...Double precision and integer declarations.
17009 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
17010 IMPLICIT INTEGER(I-N)
17011 INTEGER PYK,PYCHGE,PYCOMP
17012C...Parameter value; number of points in MC integration.
17013 PARAMETER (NPT=100)
17014C...Commonblocks.
17015 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
17016 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
17017 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
17018 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
17019 COMMON/PYINT1/MINT(400),VINT(400)
17020 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
17021C...Local arrays.
17022 DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
17023 &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
17024 &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
17025 &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
17026 &TMC(20),IJOIN(100)
17027
17028C...Functions to give four-product and to do determinants.
17029 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)
17030 DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+
17031 &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+
17032 &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3)
17033
17034C...Only allow fraction of recoupling for GH, intermediate and
17035C...instantaneous.
17036 IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
17037 IF(PYR(0).GT.PARP(120)) RETURN
17038 ENDIF
17039 ISUB=MINT(1)
17040
17041C...Common part for scenarios I, II, II', and GH.
17042 IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
17043 &MSTP(115).EQ.5) THEN
17044
17045C...Read out frequently-used parameters.
17046 PI=PARU(1)
17047 HBAR=PARU(3)
17048 PMW=PMAS(24,1)
17049 IF(ISUB.EQ.22) PMW=PMAS(23,1)
17050 PGW=PMAS(24,2)
17051 IF(ISUB.EQ.22) PGW=PMAS(23,2)
17052 TFRAG=PARP(115)
17053 RHAD=PARP(116)
17054 FACT=PARP(117)
17055 BLOWR=PARP(118)
17056 BLOWT=PARP(119)
17057
17058C...Find range of decay products of the W's.
17059C...Background: the W's are stored in IW1 and IW2.
17060C...Their direct decay products in NSD1+1 through NSD1+4.
17061C...Products after shower (if any) in NSD1+5 through NAFT1
17062C...for first W and in NAFT1+1 through N for the second.
17063 IF(NAFT1.GT.NSD1+4) THEN
17064 NBEG(1)=NSD1+5
17065 NEND(1)=NAFT1
17066 ELSE
17067 NBEG(1)=NSD1+1
17068 NEND(1)=NSD1+2
17069 ENDIF
17070 IF(N.GT.NAFT1) THEN
17071 NBEG(2)=NAFT1+1
17072 NEND(2)=N
17073 ELSE
17074 NBEG(2)=NSD1+3
17075 NEND(2)=NSD1+4
17076 ENDIF
17077
17078C...Rearrange parton shower products along strings.
17079 NOLD=N
17080 CALL PYPREP(NSD1+1)
17081
17082C...Find partons pointing back to W+ and W-; store them with quark
17083C...end of string first.
17084 NNP=0
17085 NNM=0
17086 ISGP=0
17087 ISGM=0
17088 DO 120 I=NOLD+1,N
17089 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
17090 IF(IABS(K(I,2)).GE.22) GOTO 120
17091 IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
17092 IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
17093 NNP=NNP+1
17094 IF(ISGP.EQ.1) THEN
17095 INP(NNP)=I
17096 ELSE
17097 DO 100 I1=NNP,2,-1
17098 INP(I1)=INP(I1-1)
17099 100 CONTINUE
17100 INP(1)=I
17101 ENDIF
17102 IF(K(I,1).EQ.1) ISGP=0
17103 ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
17104 IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
17105 NNM=NNM+1
17106 IF(ISGM.EQ.1) THEN
17107 INM(NNM)=I
17108 ELSE
17109 DO 110 I1=NNM,2,-1
17110 INM(I1)=INM(I1-1)
17111 110 CONTINUE
17112 INM(1)=I
17113 ENDIF
17114 IF(K(I,1).EQ.1) ISGM=0
17115 ENDIF
17116 120 CONTINUE
17117
17118C...Boost to W+W- rest frame (not strictly needed).
17119 DO 130 J=1,3
17120 BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
17121 130 CONTINUE
17122 CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
17123 CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
17124 CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
17125
17126C...Select decay vertices of W+ and W-.
17127 TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/
17128 & SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2)
17129 TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/
17130 & SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2)
17131 GTMAX=MAX(TP,TM)
17132 DO 140 J=1,3
17133 XP(J)=TP*P(IW1,J)/P(IW1,4)
17134 XM(J)=TM*P(IW2,J)/P(IW2,4)
17135 140 CONTINUE
17136
17137C...Begin scenario I specifics.
17138 IF(MSTP(115).EQ.1) THEN
17139
17140C...Reconstruct velocity and direction of W+ string pieces.
17141 DO 170 IIP=1,NNP-1
17142 IF(K(INP(IIP),2).LT.0) GOTO 170
17143 I1=INP(IIP)
17144 I2=INP(IIP+1)
17145 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
17146 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
17147 DO 150 J=1,3
17148 V1(J)=P(I1,J)/P1A
17149 V2(J)=P(I2,J)/P2A
17150 BETP(IIP,J)=0.5D0*(V1(J)+V2(J))
17151 DIRP(IIP,J)=V1(J)-V2(J)
17152 150 CONTINUE
17153 BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2-
17154 & BETP(IIP,3)**2)
17155 DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2)
17156 DO 160 J=1,3
17157 DIRP(IIP,J)=DIRP(IIP,J)/DIRL
17158 160 CONTINUE
17159 170 CONTINUE
17160
17161C...Reconstruct velocity and direction of W- string pieces.
17162 DO 200 IIM=1,NNM-1
17163 IF(K(INM(IIM),2).LT.0) GOTO 200
17164 I1=INM(IIM)
17165 I2=INM(IIM+1)
17166 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
17167 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
17168 DO 180 J=1,3
17169 V1(J)=P(I1,J)/P1A
17170 V2(J)=P(I2,J)/P2A
17171 BETM(IIM,J)=0.5D0*(V1(J)+V2(J))
17172 DIRM(IIM,J)=V1(J)-V2(J)
17173 180 CONTINUE
17174 BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2-
17175 & BETM(IIM,3)**2)
17176 DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2)
17177 DO 190 J=1,3
17178 DIRM(IIM,J)=DIRM(IIM,J)/DIRL
17179 190 CONTINUE
17180 200 CONTINUE
17181
17182C...Loop over number of space-time points.
17183 NACC=0
17184 SUM=0D0
17185 DO 250 IPT=1,NPT
17186
17187C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
17188 R=SQRT(-LOG(PYR(0)))
17189 PHI=2D0*PI*PYR(0)
17190 X=BLOWR*RHAD*R*COS(PHI)
17191 Y=BLOWR*RHAD*R*SIN(PHI)
17192 R=SQRT(-LOG(PYR(0)))
17193 PHI=2D0*PI*PYR(0)
17194 Z=BLOWR*RHAD*R*COS(PHI)
17195 T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI))
17196
17197C...Weight for sample distribution.
17198 WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)*
17199 & EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2)
17200
17201C...Loop over W+ string pieces and find one with largest weight.
17202 IMAXP=0
17203 WTMAXP=1D-10
17204 XD(1)=X-XP(1)
17205 XD(2)=Y-XP(2)
17206 XD(3)=Z-XP(3)
17207 XD(4)=T-TP
17208 DO 220 IIP=1,NNP-1
17209 IF(K(INP(IIP),2).LT.0) GOTO 220
17210 BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3)
17211 BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4))
17212 DO 210 J=1,3
17213 XB(J)=XD(J)+BEDG*BETP(IIP,J)
17214 210 CONTINUE
17215 XB(4)=BETP(IIP,4)*(XD(4)-BED)
17216 SR2=XB(1)**2+XB(2)**2+XB(3)**2
17217 SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+
17218 & DIRP(IIP,3)*XB(3))**2
17219 WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
17220 & TFRAG**2)
17221 IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0
17222 IF(WTP.GT.WTMAXP) THEN
17223 IMAXP=IIP
17224 WTMAXP=WTP
17225 ENDIF
17226 220 CONTINUE
17227
17228C...Loop over W- string pieces and find one with largest weight.
17229 IMAXM=0
17230 WTMAXM=1D-10
17231 XD(1)=X-XM(1)
17232 XD(2)=Y-XM(2)
17233 XD(3)=Z-XM(3)
17234 XD(4)=T-TM
17235 DO 240 IIM=1,NNM-1
17236 IF(K(INM(IIM),2).LT.0) GOTO 240
17237 BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3)
17238 BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4))
17239 DO 230 J=1,3
17240 XB(J)=XD(J)+BEDG*BETM(IIM,J)
17241 230 CONTINUE
17242 XB(4)=BETM(IIM,4)*(XD(4)-BED)
17243 SR2=XB(1)**2+XB(2)**2+XB(3)**2
17244 SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+
17245 & DIRM(IIM,3)*XB(3))**2
17246 WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
17247 & TFRAG**2)
17248 IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0
17249 IF(WTM.GT.WTMAXM) THEN
17250 IMAXM=IIM
17251 WTMAXM=WTM
17252 ENDIF
17253 240 CONTINUE
17254
17255C...Result of integration.
17256 WT=0D0
17257 IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN
17258 WT=WTMAXP*WTMAXM/WTSMP
17259 SUM=SUM+WT
17260 NACC=NACC+1
17261 IAP(NACC)=IMAXP
17262 IAM(NACC)=IMAXM
17263 WTA(NACC)=WT
17264 ENDIF
17265 250 CONTINUE
17266 RES=BLOWR**3*BLOWT*SUM/NPT
17267
17268C...Decide whether to reconnect and, if so, where.
17269 IACC=0
17270 PREC=1D0-EXP(-FACT*RES)
17271 IF(PREC.GT.PYR(0)) THEN
17272 RSUM=PYR(0)*SUM
17273 DO 260 IA=1,NACC
17274 IACC=IA
17275 RSUM=RSUM-WTA(IA)
17276 IF(RSUM.LE.0D0) GOTO 270
17277 260 CONTINUE
17278 270 IIP=IAP(IACC)
17279 IIM=IAM(IACC)
17280 ENDIF
17281
17282C...Begin scenario II and II' specifics.
17283 ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN
17284
17285C...Loop through all string pieces, one from W+ and one from W-.
17286 NCROSS=0
17287 TC(0)=0D0
17288 DO 340 IIP=1,NNP-1
17289 IF(K(INP(IIP),2).LT.0) GOTO 340
17290 I1P=INP(IIP)
17291 I2P=INP(IIP+1)
17292 DO 330 IIM=1,NNM-1
17293 IF(K(INM(IIM),2).LT.0) GOTO 330
17294 I1M=INM(IIM)
17295 I2M=INM(IIM+1)
17296
17297C...Find endpoint velocity vectors.
17298 DO 280 J=1,3
17299 V1P(J)=P(I1P,J)/P(I1P,4)
17300 V2P(J)=P(I2P,J)/P(I2P,4)
17301 V1M(J)=P(I1M,J)/P(I1M,4)
17302 V2M(J)=P(I2M,J)/P(I2M,4)
17303 280 CONTINUE
17304
17305C...Define q matrix and find t.
17306 DO 290 J=1,3
17307 Q(1,J)=V2P(J)-V1P(J)
17308 Q(2,J)=-(V2M(J)-V1M(J))
17309 Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J)
17310 Q(4,J)=V1P(J)-V1M(J)
17311 290 CONTINUE
17312 T=-DETER(1,2,3)/DETER(1,2,4)
17313
17314C...Find alpha and beta; i.e. coordinates of crossing point.
17315 S11=Q(1,1)*(T-TP)
17316 S12=Q(2,1)*(T-TM)
17317 S13=Q(3,1)+Q(4,1)*T
17318 S21=Q(1,2)*(T-TP)
17319 S22=Q(2,2)*(T-TM)
17320 S23=Q(3,2)+Q(4,2)*T
17321 DEN=S11*S22-S12*S21
17322 ALP=(S12*S23-S22*S13)/DEN
17323 BET=(S21*S13-S11*S23)/DEN
17324
17325C...Check if solution acceptable.
17326 IANSW=1
17327 IF(T.LT.GTMAX) IANSW=0
17328 IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
17329 IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
17330
17331C...Find point of crossing and check that not inconsistent.
17332 DO 300 J=1,3
17333 XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP)
17334 XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM)
17335 300 CONTINUE
17336 D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+
17337 & (XPP(3)-XMM(3))**2
17338 D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2
17339 D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2
17340 IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
17341
17342C...Find string eigentimes at crossing.
17343 IF(IANSW.EQ.1) THEN
17344 TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2-
17345 & (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2))
17346 TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2-
17347 & (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2))
17348 ELSE
17349 TAUP=0D0
17350 TAUM=0D0
17351 ENDIF
17352
17353C...Order crossings by time. End loop over crossings.
17354 IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
17355 NCROSS=NCROSS+1
17356 DO 310 I1=NCROSS,1,-1
17357 IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
17358 IPC(I1)=IIP
17359 IMC(I1)=IIM
17360 TC(I1)=T
17361 TPC(I1)=TAUP
17362 TMC(I1)=TAUM
17363 GOTO 320
17364 ELSE
17365 IPC(I1)=IPC(I1-1)
17366 IMC(I1)=IMC(I1-1)
17367 TC(I1)=TC(I1-1)
17368 TPC(I1)=TPC(I1-1)
17369 TMC(I1)=TMC(I1-1)
17370 ENDIF
17371 310 CONTINUE
17372 320 CONTINUE
17373 ENDIF
17374 330 CONTINUE
17375 340 CONTINUE
17376
17377C...Loop over crossings; find first (if any) acceptable one.
17378 IACC=0
17379 IF(NCROSS.GE.1) THEN
17380 DO 350 IC=1,NCROSS
17381 PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2)
17382 IF(PNFRAG.GT.PYR(0)) THEN
17383C...Scenario II: only compare with fragmentation time.
17384 IF(MSTP(115).EQ.2) THEN
17385 IACC=IC
17386 IIP=IPC(IACC)
17387 IIM=IMC(IACC)
17388 GOTO 360
17389C...Scenario II': also require that string length decreases.
17390 ELSE
17391 IIP=IPC(IC)
17392 IIM=IMC(IC)
17393 I1P=INP(IIP)
17394 I2P=INP(IIP+1)
17395 I1M=INM(IIM)
17396 I2M=INM(IIM+1)
17397 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
17398 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
17399 IF(ELNEW.LT.ELOLD) THEN
17400 IACC=IC
17401 IIP=IPC(IACC)
17402 IIM=IMC(IACC)
17403 GOTO 360
17404 ENDIF
17405 ENDIF
17406 ENDIF
17407 350 CONTINUE
17408 360 CONTINUE
17409 ENDIF
17410
17411C...Begin scenario GH specifics.
17412 ELSEIF(MSTP(115).EQ.5) THEN
17413
17414C...Loop through all string pieces, one from W+ and one from W-.
17415 IACC=0
17416 ELMIN=1D0
17417 DO 380 IIP=1,NNP-1
17418 IF(K(INP(IIP),2).LT.0) GOTO 380
17419 I1P=INP(IIP)
17420 I2P=INP(IIP+1)
17421 DO 370 IIM=1,NNM-1
17422 IF(K(INM(IIM),2).LT.0) GOTO 370
17423 I1M=INM(IIM)
17424 I2M=INM(IIM+1)
17425
17426C...Look for largest decrease of (exponent of) Lambda measure.
17427 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
17428 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
17429 ELDIF=ELNEW/MAX(1D-10,ELOLD)
17430 IF(ELDIF.LT.ELMIN) THEN
17431 IACC=IIP+IIM
17432 ELMIN=ELDIF
17433 IPC(1)=IIP
17434 IMC(1)=IIM
17435 ENDIF
17436 370 CONTINUE
17437 380 CONTINUE
17438 IIP=IPC(1)
17439 IIM=IMC(1)
17440 ENDIF
17441
17442C...Common for scenarios I, II, II' and GH: reconnect strings.
17443 IF(IACC.NE.0) THEN
17444 MINT(32)=1
17445 NJOIN=0
17446 DO 390 IS=1,NNP+NNM
17447 NJOIN=NJOIN+1
17448 IF(IS.LE.IIP) THEN
17449 I=INP(IS)
17450 ELSEIF(IS.LE.IIP+NNM-IIM) THEN
17451 I=INM(IS-IIP+IIM)
17452 ELSEIF(IS.LE.IIP+NNM) THEN
17453 I=INM(IS-IIP-NNM+IIM)
17454 ELSE
17455 I=INP(IS-NNM)
17456 ENDIF
17457 IJOIN(NJOIN)=I
17458 IF(K(I,2).LT.0) THEN
17459 CALL PYJOIN(NJOIN,IJOIN)
17460 NJOIN=0
17461 ENDIF
17462 390 CONTINUE
17463
17464C...Restore original event record if no reconnection.
17465 ELSE
17466 DO 400 I=NSD1+1,NOLD
17467 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
17468 K(I,4)=MOD(K(I,4),MSTU(5)**2)
17469 K(I,5)=MOD(K(I,5),MSTU(5)**2)
17470 ENDIF
17471 400 CONTINUE
17472 DO 410 I=NOLD+1,N
17473 K(K(I,3),1)=3
17474 410 CONTINUE
17475 N=NOLD
17476 ENDIF
17477
17478C...Boost back system.
17479 CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
17480 CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
17481 IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
17482 & BEWW(1),BEWW(2),BEWW(3))
17483
17484C...Common part for intermediate and instantaneous scenarios.
17485 ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
17486 MINT(32)=1
17487
17488C...Remove old shower products and reset showering ones.
17489 N=NSD1+4
17490 DO 420 I=NSD1+1,NSD1+4
17491 K(I,1)=3
17492 K(I,4)=MOD(K(I,4),MSTU(5)**2)
17493 K(I,5)=MOD(K(I,5),MSTU(5)**2)
17494 420 CONTINUE
17495
17496C...Identify quark-antiquark pairs.
17497 IQ1=NSD1+1
17498 IQ2=NSD1+2
17499 IQ3=NSD1+3
17500 IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
17501 IQ4=2*NSD1+7-IQ3
17502
17503C...Reconnect strings.
17504 IJOIN(1)=IQ1
17505 IJOIN(2)=IQ4
17506 CALL PYJOIN(2,IJOIN)
17507 IJOIN(1)=IQ3
17508 IJOIN(2)=IQ2
17509 CALL PYJOIN(2,IJOIN)
17510
17511C...Do new parton showers in intermediate scenario.
17512 IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
17513 MSTJ50=MSTJ(50)
17514 MSTJ(50)=0
17515 CALL PYSHOW(IQ1,IQ2,P(IW1,5))
17516 CALL PYSHOW(IQ3,IQ4,P(IW2,5))
17517 MSTJ(50)=MSTJ50
17518
17519C...Do new parton showers in instantaneous scenario.
17520 ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
17521 PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2-
17522 & (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2
17523 PPM=SQRT(MAX(0D0,PPM2))
17524 CALL PYSHOW(IQ1,IQ4,PPM)
17525 PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2-
17526 & (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2
17527 PPM=SQRT(MAX(0D0,PPM2))
17528 CALL PYSHOW(IQ3,IQ2,PPM)
17529 ENDIF
17530 ENDIF
17531
17532 RETURN
17533 END
17534
17535C***********************************************************************
17536
17537C...PYKLIM
17538C...Checks generated variables against pre-set kinematical limits;
17539C...also calculates limits on variables used in generation.
17540
17541 SUBROUTINE PYKLIM(ILIM)
17542
17543C...Double precision and integer declarations.
17544 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
17545 IMPLICIT INTEGER(I-N)
17546 INTEGER PYK,PYCHGE,PYCOMP
17547C...Commonblocks.
17548 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
17549 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
17550 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
17551 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
17552 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
17553 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
17554 COMMON/PYINT1/MINT(400),VINT(400)
17555 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
17556 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
17557 &/PYINT1/,/PYINT2/
17558
17559C...Common kinematical expressions.
17560 MINT(51)=0
17561 ISUB=MINT(1)
17562 ISTSB=ISET(ISUB)
17563 IF(ISUB.EQ.96) GOTO 100
17564 SQM3=VINT(63)
17565 SQM4=VINT(64)
17566 IF(ILIM.NE.0) THEN
17567 IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
17568 CKIN09=MAX(CKIN(9),CKIN(13))
17569 CKIN10=MIN(CKIN(10),CKIN(14))
17570 CKIN11=MAX(CKIN(11),CKIN(15))
17571 CKIN12=MIN(CKIN(12),CKIN(16))
17572 ELSE
17573 CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
17574 CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
17575 CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
17576 CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
17577 ENDIF
17578 ENDIF
17579 IF(ILIM.NE.1) THEN
17580 TAU=VINT(21)
17581 RM3=SQM3/(TAU*VINT(2))
17582 RM4=SQM4/(TAU*VINT(2))
17583 BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
17584 ENDIF
17585 PTHMIN=CKIN(3)
17586 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3)
17587 &PTHMIN=MAX(CKIN(3),CKIN(5))
17588
17589 IF(ILIM.EQ.0) THEN
17590C...Check generated values of tau, y*, cos(theta-hat), and tau' against
17591C...pre-set kinematical limits.
17592 YST=VINT(22)
17593 CTH=VINT(23)
17594 TAUP=VINT(26)
17595 TAUE=TAU
17596 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
17597 X1=SQRT(TAUE)*EXP(YST)
17598 X2=SQRT(TAUE)*EXP(-YST)
17599 XF=X1-X2
17600 IF(MINT(47).NE.1) THEN
17601 IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
17602 IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
17603 IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
17604 IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
17605 ENDIF
17606 IF(MINT(45).NE.1) THEN
17607 IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
17608 ENDIF
17609 IF(MINT(46).NE.1) THEN
17610 IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
17611 ENDIF
17612 IF(MINT(45).EQ.2) THEN
17613 IF(X1.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
17614 ENDIF
17615 IF(MINT(46).EQ.2) THEN
17616 IF(X2.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
17617 ENDIF
17618 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
17619 PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2))
17620 EXPY3=MAX(1D-20,(1D0+RM3-RM4+BE34*CTH)/
17621 & MAX(1D-20,(1D0+RM3-RM4-BE34*CTH)))
17622 EXPY4=MAX(1D-20,(1D0-RM3+RM4-BE34*CTH)/
17623 & MAX(1D-20,(1D0-RM3+RM4+BE34*CTH)))
17624 Y3=YST+0.5D0*LOG(EXPY3)
17625 Y4=YST+0.5D0*LOG(EXPY4)
17626 YLARGE=MAX(Y3,Y4)
17627 YSMALL=MIN(Y3,Y4)
17628 ETALAR=20D0
17629 ETASMA=-20D0
17630 STH=SQRT(MAX(0D0,1D0-CTH**2))
17631 EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*
17632 & CTH)**2-4D0*RM3))
17633 EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*
17634 & CTH)**2-4D0*RM4))
17635 IF(STH.GE.1D-10) THEN
17636 EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/
17637 & (BE34*STH)
17638 EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/
17639 & (BE34*STH)
17640 ETA3=LOG(MIN(1D10,MAX(1D-10,EXPET3)))
17641 ETA4=LOG(MIN(1D10,MAX(1D-10,EXPET4)))
17642 ETALAR=MAX(ETA3,ETA4)
17643 ETASMA=MIN(ETA3,ETA4)
17644 ENDIF
17645 CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3
17646 CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4
17647 CTSLAR=MIN(1D0,MAX(-1D0,CTS3,CTS4))
17648 CTSSMA=MAX(-1D0,MIN(1D0,CTS3,CTS4))
17649 SH=TAU*VINT(2)
17650 RPTS=4D0*VINT(71)**2/SH
17651 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
17652 RM34=MAX(1D-20,2D0*RM3*RM4)
17653 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
17654 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
17655 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
17656 THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
17657 UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
17658 IF(PTH.LT.PTHMIN) MINT(51)=1
17659 IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1
17660 IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
17661 IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
17662 IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
17663 IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
17664 IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
17665 IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
17666 IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
17667 IF(THA.LT.CKIN(35)) MINT(51)=1
17668 IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1
17669 IF(UHA.LT.CKIN(37)) MINT(51)=1
17670 IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1
17671 ENDIF
17672 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
17673 IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
17674 IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
17675 ENDIF
17676
17677C...Additional cuts on W2 (approximately) in DIS.
17678 IF(ISUB.EQ.10.AND.MINT(43).GE.2) THEN
17679 XBJ=X2
17680 IF(IABS(MINT(12)).LT.20) XBJ=X1
17681 Q2BJ=THA
17682 W2BJ=Q2BJ*(1D0-XBJ)/XBJ
17683 IF(W2BJ.LT.CKIN(39)) MINT(51)=1
17684 IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1
17685 ENDIF
17686
17687 ELSEIF(ILIM.EQ.1) THEN
17688C...Calculate limits on tau
17689C...0) due to definition
17690 TAUMN0=0D0
17691 TAUMX0=1D0
17692C...1) due to limits on subsystem mass
17693 TAUMN1=CKIN(1)**2/VINT(2)
17694 TAUMX1=1D0
17695 IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2)
17696C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
17697 TM3=SQRT(SQM3+PTHMIN**2)
17698 TM4=SQRT(SQM4+PTHMIN**2)
17699 YDCOSH=1D0
17700 IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12)
17701 TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
17702 TAUMX2=1D0
17703C...3) due to limits on pT-hat and cos(theta-hat)
17704 CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
17705 CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
17706 TAUMN3=0D0
17707 IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3=
17708 & (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+
17709 & SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2)
17710 TAUMX3=1D0
17711 IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3=
17712 & (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+
17713 & SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2)
17714C...4) due to limits on x1 and x2
17715 TAUMN4=CKIN(21)*CKIN(23)
17716 TAUMX4=CKIN(22)*CKIN(24)
17717C...5) due to limits on xF
17718 TAUMN5=0D0
17719 TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26))
17720C...6) due to limits on that and uhat
17721 TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2)
17722 TAUMX6=1D0
17723 IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6=
17724 & (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2)
17725
17726C...Net effect of all separate limits.
17727 VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6)
17728 VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6)
17729 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
17730 VINT(11)=1D0-1D-9
17731 VINT(31)=1D0+1D-9
17732 ELSEIF(MINT(47).EQ.5) THEN
17733 VINT(31)=MIN(VINT(31),1D0-2D-10)
17734 ELSEIF(MINT(47).GE.6) THEN
17735 VINT(31)=MIN(VINT(31),1D0-1D-10)
17736 ENDIF
17737 IF(VINT(31).LE.VINT(11)) MINT(51)=1
17738
17739 ELSEIF(ILIM.EQ.2) THEN
17740C...Calculate limits on y*
17741 TAUE=TAU
17742 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
17743 TAURT=SQRT(TAUE)
17744C...0) due to kinematics
17745 YSTMN0=LOG(TAURT)
17746 YSTMX0=-YSTMN0
17747C...1) due to explicit limits
17748 YSTMN1=CKIN(7)
17749 YSTMX1=CKIN(8)
17750C...2) due to limits on x1
17751 YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT)
17752 YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT)
17753C...3) due to limits on x2
17754 YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT)
17755 YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT)
17756C...4) due to limits on xF
17757 YEPMN4=0.5D0*ABS(CKIN(25))/TAURT
17758 YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25))
17759 YEPMX4=0.5D0*ABS(CKIN(26))/TAURT
17760 YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26))
17761C...5) due to simultaneous limits on y-large and y-small
17762 YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11)
17763 YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12)
17764 YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN)))
17765 YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX)))
17766 YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN)
17767 YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX)
17768C...6) due to simultaneous limits on cos(theta-hat) and y-large or
17769C... y-small
17770 CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2))))
17771 RZMN=BE34*MAX(CKIN(27),-CTHLIM)
17772 RZMX=BE34*MIN(CKIN(28),CTHLIM)
17773 YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX)
17774 YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN)
17775 YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN)
17776 YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX)
17777 YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX))
17778 YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN))
17779
17780C...Net effect of all separate limits.
17781 VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
17782 VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
17783 IF(MINT(47).EQ.1) THEN
17784 VINT(12)=-1D-9
17785 VINT(32)=1D-9
17786 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
17787 VINT(12)=(1D0-1D-9)*YSTMX0
17788 VINT(32)=(1D0+1D-9)*YSTMX0
17789 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
17790 VINT(12)=-(1D0+1D-9)*YSTMX0
17791 VINT(32)=-(1D0-1D-9)*YSTMX0
17792 ELSEIF(MINT(47).EQ.5) THEN
17793 YSTEE=LOG((1D0-1D-10)/TAURT)
17794 VINT(12)=MAX(VINT(12),-YSTEE)
17795 VINT(32)=MIN(VINT(32),YSTEE)
17796 ENDIF
17797 IF(VINT(32).LE.VINT(12)) MINT(51)=1
17798
17799 ELSEIF(ILIM.EQ.3) THEN
17800C...Calculate limits on cos(theta-hat)
17801 YST=VINT(22)
17802C...0) due to definition
17803 CTNMN0=-1D0
17804 CTNMX0=0D0
17805 CTPMN0=0D0
17806 CTPMX0=1D0
17807C...1) due to explicit limits
17808 CTNMN1=MIN(0D0,CKIN(27))
17809 CTNMX1=MIN(0D0,CKIN(28))
17810 CTPMN1=MAX(0D0,CKIN(27))
17811 CTPMX1=MAX(0D0,CKIN(28))
17812C...2) due to limits on pT-hat
17813 CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2))))
17814 CTPMX2=-CTNMN2
17815 CTNMX2=0D0
17816 CTPMN2=0D0
17817 IF(CKIN(4).GE.0D0) THEN
17818 CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/
17819 & (BE34**2*TAU*VINT(2))))
17820 CTPMN2=-CTNMX2
17821 ENDIF
17822C...3) due to limits on y-large and y-small
17823 CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST),
17824 & -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST)))
17825 CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST),
17826 & -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST))
17827 CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST),
17828 & -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST))
17829 CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST),
17830 & -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST)))
17831C...4) due to limits on that
17832 CTNMN4=-1D0
17833 CTNMX4=0D0
17834 CTPMN4=0D0
17835 CTPMX4=1D0
17836 SH=TAU*VINT(2)
17837 IF(CKIN(35).GT.0D0) THEN
17838 CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34
17839 IF(CTLIM.GT.0D0) THEN
17840 CTPMX4=CTLIM
17841 ELSE
17842 CTPMX4=0D0
17843 CTNMX4=CTLIM
17844 ENDIF
17845 ENDIF
17846 IF(CKIN(36).GT.0D0) THEN
17847 CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34
17848 IF(CTLIM.LT.0D0) THEN
17849 CTNMN4=CTLIM
17850 ELSE
17851 CTNMN4=0D0
17852 CTPMN4=CTLIM
17853 ENDIF
17854 ENDIF
17855C...5) due to limits on uhat
17856 CTNMN5=-1D0
17857 CTNMX5=0D0
17858 CTPMN5=0D0
17859 CTPMX5=1D0
17860 IF(CKIN(37).GT.0D0) THEN
17861 CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34
17862 IF(CTLIM.LT.0D0) THEN
17863 CTNMN5=CTLIM
17864 ELSE
17865 CTNMN5=0D0
17866 CTPMN5=CTLIM
17867 ENDIF
17868 ENDIF
17869 IF(CKIN(38).GT.0D0) THEN
17870 CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34
17871 IF(CTLIM.GT.0D0) THEN
17872 CTPMX5=CTLIM
17873 ELSE
17874 CTPMX5=0D0
17875 CTNMX5=CTLIM
17876 ENDIF
17877 ENDIF
17878
17879C...Net effect of all separate limits.
17880 VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5)
17881 VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5)
17882 VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5)
17883 VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5)
17884 IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
17885
17886 ELSEIF(ILIM.EQ.4) THEN
17887C...Calculate limits on tau'
17888C...0) due to kinematics
17889 TAPMN0=TAU
17890 IF(ISTSB.EQ.5.AND.KFPR(ISUB,2).GT.0) THEN
17891 PQRAT=2D0*PMAS(PYCOMP(KFPR(ISUB,2)),1)/VINT(1)
17892 TAPMN0=(SQRT(TAU)+PQRAT)**2
17893 ENDIF
17894 TAPMX0=1D0
17895C...1) due to explicit limits
17896 TAPMN1=CKIN(31)**2/VINT(2)
17897 TAPMX1=1D0
17898 IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2)
17899
17900C...Net effect of all separate limits.
17901 VINT(16)=MAX(TAPMN0,TAPMN1)
17902 VINT(36)=MIN(TAPMX0,TAPMX1)
17903 IF(MINT(47).EQ.1) THEN
17904 VINT(16)=1D0-1D-9
17905 VINT(36)=1D0+1D-9
17906 ELSEIF(MINT(47).EQ.5) THEN
17907 VINT(36)=MIN(VINT(36),1D0-2D-10)
17908 ELSEIF(MINT(47).EQ.6.OR.MINT(47).EQ.7) THEN
17909 VINT(36)=MIN(VINT(36),1D0-1D-10)
17910 ENDIF
17911 IF(VINT(36).LE.VINT(16)) MINT(51)=1
17912
17913 ENDIF
17914 RETURN
17915
17916C...Special case for low-pT and multiple interactions:
17917C...effective kinematical limits for tau, y*, cos(theta-hat).
17918 100 IF(ILIM.EQ.0) THEN
17919 ELSEIF(ILIM.EQ.1) THEN
17920 IF(MSTP(82).LE.1) THEN
17921 VINT(11)=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
17922 & VINT(2)
17923 ELSE
17924 VINT(11)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/VINT(2)
17925 ENDIF
17926 VINT(31)=1D0
17927 ELSEIF(ILIM.EQ.2) THEN
17928 VINT(12)=0.5D0*LOG(VINT(21))
17929 VINT(32)=-VINT(12)
17930 ELSEIF(ILIM.EQ.3) THEN
17931 IF(MSTP(82).LE.1) THEN
17932 ST2EFF=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
17933 & (VINT(21)*VINT(2))
17934 ELSE
17935 ST2EFF=0.01D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
17936 & (VINT(21)*VINT(2))
17937 ENDIF
17938 VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF))
17939 VINT(33)=0D0
17940 VINT(14)=0D0
17941 VINT(34)=-VINT(13)
17942 ENDIF
17943
17944 RETURN
17945 END
17946
17947C*********************************************************************
17948
17949C...PYKMAP
17950C...Maps a uniform distribution into a distribution of a kinematical
17951C...variable according to one of the possibilities allowed. It is
17952C...assumed that kinematical limits have been set by a PYKLIM call.
17953
17954 SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
17955
17956C...Double precision and integer declarations.
17957 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
17958 IMPLICIT INTEGER(I-N)
17959 INTEGER PYK,PYCHGE,PYCOMP
17960C...Commonblocks.
17961 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
17962 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
17963 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
17964 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
17965 COMMON/PYINT1/MINT(400),VINT(400)
17966 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
17967 SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
17968
17969C...Convert VVAR to tau variable.
17970 ISUB=MINT(1)
17971 ISTSB=ISET(ISUB)
17972 IF(IVAR.EQ.1) THEN
17973 TAUMIN=VINT(11)
17974 TAUMAX=VINT(31)
17975 IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
17976 TAURE=VINT(73)
17977 GAMRE=VINT(74)
17978 ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
17979 TAURE=VINT(75)
17980 GAMRE=VINT(76)
17981 ENDIF
17982 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
17983 TAU=1D0
17984 ELSEIF(MVAR.EQ.1) THEN
17985 TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
17986 ELSEIF(MVAR.EQ.2) THEN
17987 TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
17988 ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5) THEN
17989 RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
17990 TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
17991 ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6) THEN
17992 AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
17993 ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
17994 TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
17995 ELSEIF(MINT(47).EQ.5) THEN
17996 AUPP=LOG(MAX(2D-10,1D0-TAUMAX))
17997 ALOW=LOG(MAX(2D-10,1D0-TAUMIN))
17998 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
17999 ELSE
18000 AUPP=LOG(MAX(1D-10,1D0-TAUMAX))
18001 ALOW=LOG(MAX(1D-10,1D0-TAUMIN))
18002 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
18003 ENDIF
18004 VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
18005
18006C...Convert VVAR to y* variable.
18007 ELSEIF(IVAR.EQ.2) THEN
18008 YSTMIN=VINT(12)
18009 YSTMAX=VINT(32)
18010 TAUE=VINT(21)
18011 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
18012 IF(MINT(47).EQ.1) THEN
18013 YST=0D0
18014 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
18015 YST=-0.5D0*LOG(TAUE)
18016 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
18017 YST=0.5D0*LOG(TAUE)
18018 ELSEIF(MVAR.EQ.1) THEN
18019 YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
18020 ELSEIF(MVAR.EQ.2) THEN
18021 YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR)
18022 ELSEIF(MVAR.EQ.3) THEN
18023 AUPP=ATAN(EXP(YSTMAX))
18024 ALOW=ATAN(EXP(YSTMIN))
18025 YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
18026 ELSEIF(MVAR.EQ.4) THEN
18027 YST0=-0.5D0*LOG(TAUE)
18028 AUPP=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0))
18029 ALOW=LOG(MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
18030 YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW)))
18031 ELSE
18032 YST0=-0.5D0*LOG(TAUE)
18033 AUPP=LOG(MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
18034 ALOW=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0))
18035 YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0
18036 ENDIF
18037 VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
18038
18039C...Convert VVAR to cos(theta-hat) variable.
18040 ELSEIF(IVAR.EQ.3) THEN
18041 RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2)
18042 RSQM=1D0+RM34
18043 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
18044 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
18045 CTNMIN=VINT(13)
18046 CTNMAX=VINT(33)
18047 CTPMIN=VINT(14)
18048 CTPMAX=VINT(34)
18049 IF(MVAR.EQ.1) THEN
18050 ANEG=CTNMAX-CTNMIN
18051 APOS=CTPMAX-CTPMIN
18052 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
18053 VCTN=VVAR*(ANEG+APOS)/ANEG
18054 CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
18055 ELSE
18056 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
18057 CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
18058 ENDIF
18059 ELSEIF(MVAR.EQ.2) THEN
18060 RMNMIN=MAX(RM34,RSQM-CTNMIN)
18061 RMNMAX=MAX(RM34,RSQM-CTNMAX)
18062 RMPMIN=MAX(RM34,RSQM-CTPMIN)
18063 RMPMAX=MAX(RM34,RSQM-CTPMAX)
18064 ANEG=LOG(RMNMIN/RMNMAX)
18065 APOS=LOG(RMPMIN/RMPMAX)
18066 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
18067 VCTN=VVAR*(ANEG+APOS)/ANEG
18068 CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
18069 ELSE
18070 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
18071 CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
18072 ENDIF
18073 ELSEIF(MVAR.EQ.3) THEN
18074 RMNMIN=MAX(RM34,RSQM+CTNMIN)
18075 RMNMAX=MAX(RM34,RSQM+CTNMAX)
18076 RMPMIN=MAX(RM34,RSQM+CTPMIN)
18077 RMPMAX=MAX(RM34,RSQM+CTPMAX)
18078 ANEG=LOG(RMNMAX/RMNMIN)
18079 APOS=LOG(RMPMAX/RMPMIN)
18080 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
18081 VCTN=VVAR*(ANEG+APOS)/ANEG
18082 CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
18083 ELSE
18084 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
18085 CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
18086 ENDIF
18087 ELSEIF(MVAR.EQ.4) THEN
18088 RMNMIN=MAX(RM34,RSQM-CTNMIN)
18089 RMNMAX=MAX(RM34,RSQM-CTNMAX)
18090 RMPMIN=MAX(RM34,RSQM-CTPMIN)
18091 RMPMAX=MAX(RM34,RSQM-CTPMAX)
18092 ANEG=1D0/RMNMAX-1D0/RMNMIN
18093 APOS=1D0/RMPMAX-1D0/RMPMIN
18094 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
18095 VCTN=VVAR*(ANEG+APOS)/ANEG
18096 CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN)
18097 ELSE
18098 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
18099 CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP)
18100 ENDIF
18101 ELSEIF(MVAR.EQ.5) THEN
18102 RMNMIN=MAX(RM34,RSQM+CTNMIN)
18103 RMNMAX=MAX(RM34,RSQM+CTNMAX)
18104 RMPMIN=MAX(RM34,RSQM+CTPMIN)
18105 RMPMAX=MAX(RM34,RSQM+CTPMAX)
18106 ANEG=1D0/RMNMIN-1D0/RMNMAX
18107 APOS=1D0/RMPMIN-1D0/RMPMAX
18108 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
18109 VCTN=VVAR*(ANEG+APOS)/ANEG
18110 CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM
18111 ELSE
18112 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
18113 CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM
18114 ENDIF
18115 ENDIF
18116 IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
18117 IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
18118 VINT(23)=CTH
18119
18120C...Convert VVAR to tau' variable.
18121 ELSEIF(IVAR.EQ.4) THEN
18122 TAU=VINT(21)
18123 TAUPMN=VINT(16)
18124 TAUPMX=VINT(36)
18125 IF(MINT(47).EQ.1) THEN
18126 TAUP=1D0
18127 ELSEIF(MVAR.EQ.1) THEN
18128 TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
18129 ELSEIF(MVAR.EQ.2) THEN
18130 AUPP=(1D0-TAU/TAUPMX)**4
18131 ALOW=(1D0-TAU/TAUPMN)**4
18132 TAUP=TAU/MAX(1D-10,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0)
18133 ELSEIF(MINT(47).EQ.5) THEN
18134 AUPP=LOG(MAX(2D-10,1D0-TAUPMX))
18135 ALOW=LOG(MAX(2D-10,1D0-TAUPMN))
18136 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
18137 ELSE
18138 AUPP=LOG(MAX(1D-10,1D0-TAUPMX))
18139 ALOW=LOG(MAX(1D-10,1D0-TAUPMN))
18140 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
18141 ENDIF
18142 VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
18143
18144C...Selection of extra variables needed in 2 -> 3 process:
18145C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
18146C...Since no options are available, the functions of PYKLIM
18147C...and PYKMAP are joint for these choices.
18148 ELSEIF(IVAR.EQ.5) THEN
18149
18150C...Read out total energy and particle masses.
18151 MINT(51)=0
18152 MPTPK=1
18153 IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174
18154 & .OR.ISUB.EQ.178.OR.ISUB.EQ.179.OR.ISUB.EQ.351.OR.ISUB.EQ.352)
18155 & MPTPK=2
18156 SHP=VINT(26)*VINT(2)
18157 SHPR=SQRT(SHP)
18158 PM1=VINT(201)
18159 PM2=VINT(206)
18160 PM3=SQRT(VINT(21))*VINT(1)
18161 IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN
18162 MINT(51)=1
18163 RETURN
18164 ENDIF
18165 PMRS1=VINT(204)**2
18166 PMRS2=VINT(209)**2
18167
18168C...Specify coefficients of pT choice; upper and lower limits.
18169 IF(MPTPK.EQ.1) THEN
18170 HWT1=0.4D0
18171 HWT2=0.4D0
18172 ELSE
18173 HWT1=0.05D0
18174 HWT2=0.05D0
18175 ENDIF
18176 HWT3=1D0-HWT1-HWT2
18177 PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/
18178 & (4D0*SHP)
18179 IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
18180 PTSMN1=CKIN(51)**2
18181 PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/
18182 & (4D0*SHP)
18183 IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2)
18184 PTSMN2=CKIN(53)**2
18185
18186C...Select transverse momenta according to
18187C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
18188 HMX=PMRS1+PTSMX1
18189 HMN=PMRS1+PTSMN1
18190 IF(HMX.LT.1.0001D0*HMN) THEN
18191 MINT(51)=1
18192 RETURN
18193 ENDIF
18194 HDE=PTSMX1-PTSMN1
18195 RPT=PYR(0)
18196 IF(RPT.LT.HWT1) THEN
18197 PTS1=PTSMN1+PYR(0)*HDE
18198 ELSEIF(RPT.LT.HWT1+HWT2) THEN
18199 PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1)
18200 ELSE
18201 PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1)
18202 ENDIF
18203 WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+
18204 & HWT3*HMN*HMX/(PMRS1+PTS1)**2)
18205 HMX=PMRS2+PTSMX2
18206 HMN=PMRS2+PTSMN2
18207 IF(HMX.LT.1.0001D0*HMN) THEN
18208 MINT(51)=1
18209 RETURN
18210 ENDIF
18211 HDE=PTSMX2-PTSMN2
18212 RPT=PYR(0)
18213 IF(RPT.LT.HWT1) THEN
18214 PTS2=PTSMN2+PYR(0)*HDE
18215 ELSEIF(RPT.LT.HWT1+HWT2) THEN
18216 PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2)
18217 ELSE
18218 PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2)
18219 ENDIF
18220 WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+
18221 & HWT3*HMN*HMX/(PMRS2+PTS2)**2)
18222
18223C...Select azimuthal angles and check pT choice.
18224 PHI1=PARU(2)*PYR(0)
18225 PHI2=PARU(2)*PYR(0)
18226 PHIR=PHI2-PHI1
18227 PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR))
18228 IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT.
18229 & CKIN(56)**2)) THEN
18230 MINT(51)=1
18231 RETURN
18232 ENDIF
18233
18234C...Calculate transverse masses and check phase space not closed.
18235 PMS1=PM1**2+PTS1
18236 PMS2=PM2**2+PTS2
18237 PMS3=PM3**2+PTS3
18238 PMT1=SQRT(PMS1)
18239 PMT2=SQRT(PMS2)
18240 PMT3=SQRT(PMS3)
18241 PM12=(PMT1+PMT2)**2
18242 IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN
18243 MINT(51)=1
18244 RETURN
18245 ENDIF
18246
18247C...Select rapidity for particle 3 and check phase space not closed.
18248 Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2-
18249 & 4D0*PMS3*PM12)))/(2D0*SHPR*PMT3))
18250 IF(Y3MAX.LT.1D-6) THEN
18251 MINT(51)=1
18252 RETURN
18253 ENDIF
18254 Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX
18255 PZ3=PMT3*SINH(Y3)
18256 PE3=PMT3*COSH(Y3)
18257
18258C...Find momentum transfers in two mirror solutions (in 1-2 frame).
18259 PZ12=-PZ3
18260 PE12=SHPR-PE3
18261 PMS12=PE12**2-PZ12**2
18262 SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2))
18263 IF(SQL12.LT.1D-6*SHP) THEN
18264 MINT(51)=1
18265 RETURN
18266 ENDIF
18267 PMM1=PMS12+PMS1-PMS2
18268 PMM2=PMS12+PMS2-PMS1
18269 TFAC=-SHPR/(2D0*PMS12)
18270 T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12)
18271 T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12)
18272 T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12)
18273 T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12)
18274
18275C...Construct relative mirror weights and make choice.
18276 IF(MPTPK.EQ.1.OR.ISUB.EQ.351.OR.ISUB.EQ.352) THEN
18277 WTPU=1D0
18278 WTNU=1D0
18279 ELSE
18280 WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2
18281 WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2
18282 ENDIF
18283 WTP=WTPU/(WTPU+WTNU)
18284 WTN=WTNU/(WTPU+WTNU)
18285 EPS=1D0
18286 IF(WTN.GT.PYR(0)) EPS=-1D0
18287
18288C...Store result of variable choice and associated weights.
18289 VINT(202)=PTS1
18290 VINT(207)=PTS2
18291 VINT(203)=PHI1
18292 VINT(208)=PHI2
18293 VINT(205)=WTPTS1
18294 VINT(210)=WTPTS2
18295 VINT(211)=Y3
18296 VINT(212)=Y3MAX
18297 VINT(213)=EPS
18298 IF(EPS.GT.0D0) THEN
18299 VINT(214)=1D0/WTP
18300 VINT(215)=T1P
18301 VINT(216)=T2P
18302 ELSE
18303 VINT(214)=1D0/WTN
18304 VINT(215)=T1N
18305 VINT(216)=T2N
18306 ENDIF
18307 VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12)
18308 VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12)
18309 VINT(219)=0.5D0*(PMS12-PTS3)
18310 VINT(220)=SQL12
18311 ENDIF
18312
18313 RETURN
18314 END
18315
18316C***********************************************************************
18317
18318C...PYSIGH
18319C...Differential matrix elements for all included subprocesses
18320C...Note that what is coded is (disregarding the COMFAC factor)
18321C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
18322C...when d(sigma-hat) is given in the zero-width limit, the delta
18323C...function in tau is replaced by a (modified) Breit-Wigner:
18324C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
18325C...where H_res = s-hat/m_res*Gamma_res(s-hat);
18326C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
18327C...i.e., dimensionless quantities
18328C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
18329C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
18330C...(2pi)^4 delta^4(P - sum p_i)
18331C...COMFAC contains the factor pi/s (or equivalent) and
18332C...the conversion factor from GeV^-2 to mb
18333
18334 SUBROUTINE PYSIGH(NCHN,SIGS)
18335
18336C...Double precision and integer declarations
18337 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
18338 IMPLICIT INTEGER(I-N)
18339 INTEGER PYK,PYCHGE,PYCOMP
18340C...Parameter statement to help give large particle numbers.
18341 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
18342C...Commonblocks
18343 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
18344 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
18345 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
18346 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
18347 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
18348 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
18349 COMMON/PYINT1/MINT(400),VINT(400)
18350 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
18351 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
18352 COMMON/PYINT4/MWID(500),WIDS(500,5)
18353 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
18354 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
18355 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
18356 &SFMIX(16,4)
18357 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
18358 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
18359 &/PYSSMT/
18360C...Local arrays and complex variables
18361 DIMENSION X(2),XPQ(-25:25),KFAC(2,-40:40),WDTP(0:200),
18362 &WDTE(0:200,0:5),HGZ(6,3),HL3(3),HR3(3),HL4(3),HR4(3)
18363 COMPLEX A004,A204,A114,A00U,A20U,A11U
18364 COMPLEX CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF,
18365 &COULCK,COULCP,COULCD,COULCR,COULCS
18366 REAL A00L,A11L,A20L,COULXX
18367 COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME
18368 COMPLEX*16 DAA,DZZ,DAZ
18369
18370C...Reset number of channels and cross-section
18371 NCHN=0
18372 SIGS=0D0
18373
18374C...Convert H or A process into equivalent h one
18375 ISUB=MINT(1)
18376 ISUBSV=ISUB
18377 IHIGG=1
18378 KFHIGG=25
18379 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
18380 &ISUB.LE.190)) THEN
18381 IHIGG=2
18382 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
18383 KFHIGG=33+IHIGG
18384 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
18385 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
18386 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
18387 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
18388 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
18389 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
18390 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
18391 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
18392 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
18393 ENDIF
18394
18395CMRENNA++
18396C...Convert almost equivalent SUSY processes into each other
18397C...Extract differences in flavours and couplings
18398 IF(ISUB.GE.200.AND.ISUB.LE.301) THEN
18399
18400C...Sleptons and sneutrinos
18401 IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN
18402 KFID=MOD(KFPR(ISUB,1),KSUSY1)
18403 ISUB=201
18404 ILR=0
18405 ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN
18406 KFID=MOD(KFPR(ISUB,1),KSUSY1)
18407 ISUB=201
18408 ILR=1
18409 ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN
18410 KFID=MOD(KFPR(ISUB,1),KSUSY1)
18411 ISUB=203
18412 ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN
18413 IF(ISUB.EQ.210) THEN
18414 RKF=2.0D0
18415 ELSEIF(ISUB.EQ.211) THEN
18416 RKF=SFMIX(15,1)**2
18417 ELSEIF(ISUB.EQ.212) THEN
18418 RKF=SFMIX(15,2)**2
18419 ENDIF
18420 ISUB=210
18421 ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN
18422 IF(ISUB.EQ.213) THEN
18423 KFID=MOD(KFPR(ISUB,1),KSUSY1)
18424 RKF=2.0D0
18425 ELSEIF(ISUB.EQ.214) THEN
18426 KFID=16
18427 RKF=1.0D0
18428 ENDIF
18429 ISUB=213
18430
18431C...Neutralinos
18432 ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN
18433 IF(ISUB.EQ.216) THEN
18434 IZID1=1
18435 IZID2=1
18436 ELSEIF(ISUB.EQ.217) THEN
18437 IZID1=2
18438 IZID2=2
18439 ELSEIF(ISUB.EQ.218) THEN
18440 IZID1=3
18441 IZID2=3
18442 ELSEIF(ISUB.EQ.219) THEN
18443 IZID1=4
18444 IZID2=4
18445 ELSEIF(ISUB.EQ.220) THEN
18446 IZID1=1
18447 IZID2=2
18448 ELSEIF(ISUB.EQ.221) THEN
18449 IZID1=1
18450 IZID2=3
18451 ELSEIF(ISUB.EQ.222) THEN
18452 IZID1=1
18453 IZID2=4
18454 ELSEIF(ISUB.EQ.223) THEN
18455 IZID1=2
18456 IZID2=3
18457 ELSEIF(ISUB.EQ.224) THEN
18458 IZID1=2
18459 IZID2=4
18460 ELSEIF(ISUB.EQ.225) THEN
18461 IZID1=3
18462 IZID2=4
18463 ENDIF
18464 ISUB=216
18465
18466C...Charginos
18467 ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN
18468 IF(ISUB.EQ.226) THEN
18469 IZID1=1
18470 IZID2=1
18471 ELSEIF(ISUB.EQ.227) THEN
18472 IZID1=2
18473 IZID2=2
18474 ELSEIF(ISUB.EQ.228) THEN
18475 IZID1=1
18476 IZID2=2
18477 ENDIF
18478 ISUB=226
18479
18480C...Neutralino + chargino
18481 ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN
18482 IF(ISUB.EQ.229) THEN
18483 IZID1=1
18484 IZID2=1
18485 ELSEIF(ISUB.EQ.230) THEN
18486 IZID1=1
18487 IZID2=2
18488 ELSEIF(ISUB.EQ.231) THEN
18489 IZID1=1
18490 IZID2=3
18491 ELSEIF(ISUB.EQ.232) THEN
18492 IZID1=1
18493 IZID2=4
18494 ELSEIF(ISUB.EQ.233) THEN
18495 IZID1=2
18496 IZID2=1
18497 ELSEIF(ISUB.EQ.234) THEN
18498 IZID1=2
18499 IZID2=2
18500 ELSEIF(ISUB.EQ.235) THEN
18501 IZID1=2
18502 IZID2=3
18503 ELSEIF(ISUB.EQ.236) THEN
18504 IZID1=2
18505 IZID2=4
18506 ENDIF
18507 ISUB=229
18508
18509C...Gluino + neutralino
18510 ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN
18511 IF(ISUB.EQ.237) THEN
18512 IZID=1
18513 ELSEIF(ISUB.EQ.238) THEN
18514 IZID=2
18515 ELSEIF(ISUB.EQ.239) THEN
18516 IZID=3
18517 ELSEIF(ISUB.EQ.240) THEN
18518 IZID=4
18519 ENDIF
18520 ISUB=237
18521
18522C...Gluino + chargino
18523 ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN
18524 IF(ISUB.EQ.241) THEN
18525 IZID=1
18526 ELSEIF(ISUB.EQ.242) THEN
18527 IZID=2
18528 ENDIF
18529 ISUB=241
18530
18531C...Squark + neutralino
18532 ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN
18533 ILR=0
18534 IF(MOD(ISUB,2).NE.0) ILR=1
18535 IF(ISUB.LE.247) THEN
18536 IZID=1
18537 ELSEIF(ISUB.LE.249) THEN
18538 IZID=2
18539 ELSEIF(ISUB.LE.251) THEN
18540 IZID=3
18541 ELSEIF(ISUB.LE.253) THEN
18542 IZID=4
18543 ENDIF
18544 ISUB=246
18545 RKF=5D0
18546
18547C...Squark + chargino
18548 ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN
18549 IF(ISUB.LE.255) THEN
18550 IZID=1
18551 ELSEIF(ISUB.LE.257) THEN
18552 IZID=2
18553 ENDIF
18554 IF(MOD(ISUB,2).EQ.0) THEN
18555 ILR=0
18556 ELSE
18557 ILR=1
18558 ENDIF
18559 ISUB=254
18560 RKF=5D0
18561
18562C...Squark + gluino
18563 ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN
18564 ISUB=258
18565 RKF=4D0
18566
18567C...Stops
18568 ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN
18569 ILR=0
18570 IF(ISUB.EQ.262) ILR=1
18571 ISUB=261
18572 ELSEIF(ISUB.EQ.265) THEN
18573 ISUB=264
18574
18575C...Squarks
18576 ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN
18577 ILR=0
18578 IF(ISUB.LE.273) THEN
18579 IF(ISUB.EQ.273) ILR=1
18580 ISUB=271
18581 RKF=16D0
18582 ELSEIF(ISUB.LE.276) THEN
18583 IF(ISUB.EQ.276) ILR=1
18584 ISUB=274
18585 RKF=16D0
18586 ELSEIF(ISUB.LE.278) THEN
18587 IF(ISUB.EQ.278) ILR=1
18588 ISUB=277
18589 RKF=4D0
18590 ELSE
18591 IF(ISUB.EQ.280) ILR=1
18592 ISUB=279
18593 RKF=4D0
18594 ENDIF
18595C...Sbottoms
18596 ELSEIF(ISUB.GE.281.AND.ISUB.LE.296) THEN
18597 ILR=0
18598 IF(ISUB.LE.283) THEN
18599 IF(ISUB.EQ.283) ILR=1
18600 ISUB=271
18601 RKF=4D0
18602 ELSEIF(ISUB.LE.286) THEN
18603 IF(ISUB.EQ.286) ILR=1
18604 ISUB=274
18605 RKF=4D0
18606 ELSEIF(ISUB.LE.288) THEN
18607 IF(ISUB.EQ.288) ILR=1
18608 ISUB=277
18609 RKF=1D0
18610 ELSEIF(ISUB.LE.290) THEN
18611 IF(ISUB.EQ.290) ILR=1
18612 ISUB=279
18613 RKF=1D0
18614 ELSEIF(ISUB.LE.293) THEN
18615 IF(ISUB.EQ.293) ILR=1
18616 ISUB=271
18617 RKF=1D0
18618 ELSEIF(ISUB.EQ.296) THEN
18619 ILR=1
18620 ISUB=274
18621 RKF=1D0
18622C...Squark + gluino
18623 ELSEIF(ISUB.EQ.294.OR.ISUB.EQ.295) THEN
18624 ISUB=258
18625 RKF=1D0
18626 ENDIF
18627C...H+/- + H0
18628 ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
18629 IF(ISUB.EQ.297) THEN
18630 RKF=.5D0*PARU(195)**2
18631 ELSEIF(ISUB.EQ.298) THEN
18632 RKF=.5D0*(1D0-PARU(195)**2)
18633 ENDIF
18634 ISUB=210
18635C...A0 + H0
18636 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
18637 IF(ISUB.EQ.299) THEN
18638 RKF=PARU(186)**2
18639 ELSEIF(ISUB.EQ.300) THEN
18640 RKF=PARU(187)**2
18641 ENDIF
18642 ISUB=213
18643C...H+ + H-
18644 ELSEIF(ISUB.EQ.301) THEN
18645 KFID=37
18646 RKF=1D0
18647 ISUB=201
18648 ENDIF
18649 ELSEIF(ISUB.GE.361.AND.ISUB.LE.379) THEN
18650 SQTV=PARJ(172)**2
18651 SQTA=PARJ(173)**2
18652 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
18653 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
18654 CSXI=COS(ASIN(PARP(141)))
18655 CSXIP=COS(ASIN(PARJ(174)))
18656 QUPD=2D0*PARP(143)-1D0
18657C... rho_tech0 -> W_L W_L
18658 IF(ISUB.EQ.361) THEN
18659 KFA=24
18660 KFB=24
18661 CAB2=PARP(141)**4
18662C... rho_tech0 -> W_L pi_tech-
18663 ELSEIF(ISUB.EQ.362) THEN
18664 KFA=24
18665 KFB=52
18666 ISUB=361
18667 CAB2=PARP(141)**2*(1D0-PARP(141)**2)
18668C... pi_tech pi_tech
18669 ELSEIF(ISUB.EQ.363) THEN
18670 KFA=52
18671 KFB=52
18672 ISUB=361
18673 CAB2=(1D0-PARP(141)**2)**2
18674C... rho_tech0/omega_tech -> gamma pi_tech
18675 ELSEIF(ISUB.EQ.364) THEN
18676 KFA=22
18677 KFB=51
18678 VOGP=CSXI
18679 VRGP=VOGP*QUPD
18680 AOGP=0D0
18681 ARGP=0D0
18682C... gamma pi_tech'
18683 ELSEIF(ISUB.EQ.365) THEN
18684 KFA=22
18685 KFB=53
18686 ISUB=364
18687 VRGP=CSXIP
18688 VOGP=VRGP*QUPD
18689 AOGP=0D0
18690 ARGP=0D0
18691C... Z pi_tech
18692 ELSEIF(ISUB.EQ.366) THEN
18693 KFA=23
18694 KFB=51
18695 ISUB=364
18696 VOGP=CSXI*CT2W
18697 VRGP=-QUPD*CSXI*TANW
18698 AOGP=0D0
18699 ARGP=0D0
18700C... Z pi_tech'
18701 ELSEIF(ISUB.EQ.367) THEN
18702 KFA=23
18703 KFB=53
18704 ISUB=364
18705 VRGP=CSXIP*CT2W
18706 VOGP=-QUPD*CSXIP*TANW
18707 AOGP=0D0
18708 ARGP=0D0
18709C... W_T pi_tech
18710 ELSEIF(ISUB.EQ.368) THEN
18711 KFA=24
18712 KFB=52
18713 ISUB=364
18714 VOGP=CSXI/(2D0*SQRT(PARU(102)))
18715 VRGP=0D0
18716 AOGP=0D0
18717 ARGP=-VOGP
18718C... rho_tech+ -> W_L Z_L
18719 ELSEIF(ISUB.EQ.370) THEN
18720 KFA=24
18721 KFB=23
18722 CAB2=PARP(141)**4
18723C... W_L pi_tech0
18724 ELSEIF(ISUB.EQ.371) THEN
18725 KFA=24
18726 KFB=51
18727 ISUB=370
18728 CAB2=PARP(141)**2*(1D0-PARP(141)**2)
18729C... Z_L pi_tech+
18730 ELSEIF(ISUB.EQ.372) THEN
18731 KFA=52
18732 KFB=23
18733 ISUB=370
18734 CAB2=PARP(141)**2*(1D0-PARP(141)**2)
18735C... pi_tech+ pi_tech0
18736 ELSEIF(ISUB.EQ.373) THEN
18737 KFA=52
18738 KFB=51
18739 ISUB=370
18740 CAB2=(1D0-PARP(141)**2)**2
18741C... gamma pi_tech+
18742 ELSEIF(ISUB.EQ.374) THEN
18743 KFA=52
18744 KFB=22
18745 VRGP=QUPD*CSXI
18746 ARGP=0D0
18747C... Z_T pi_tech+
18748 ELSEIF(ISUB.EQ.375) THEN
18749 KFA=52
18750 KFB=23
18751 ISUB=374
18752 VRGP=-QUPD*CSXI*TANW
18753 ARGP=CSXI/(2D0*SQRT(PARU(102)*(1D0-PARU(102))))
18754C... W_T pi_tech0
18755 ELSEIF(ISUB.EQ.376) THEN
18756 KFA=24
18757 KFB=51
18758 ISUB=374
18759 VRGP=0D0
18760 ARGP=-CSXI/(2D0*SQRT(PARU(102)))
18761C... W_T pi_tech0'
18762 ELSEIF(ISUB.EQ.377) THEN
18763 KFA=24
18764 KFB=53
18765 ISUB=374
18766 ARGP=0D0
18767 VRGP=CSXIP/(2D0*SQRT(PARU(102)))
18768 ENDIF
18769 ENDIF
18770CMRENNA--
18771
18772C...Read kinematical variables and limits
18773 ISTSB=ISET(ISUBSV)
18774 TAUMIN=VINT(11)
18775 YSTMIN=VINT(12)
18776 CTNMIN=VINT(13)
18777 CTPMIN=VINT(14)
18778 TAUPMN=VINT(16)
18779 TAU=VINT(21)
18780 YST=VINT(22)
18781 CTH=VINT(23)
18782 XT2=VINT(25)
18783 TAUP=VINT(26)
18784 TAUMAX=VINT(31)
18785 YSTMAX=VINT(32)
18786 CTNMAX=VINT(33)
18787 CTPMAX=VINT(34)
18788 TAUPMX=VINT(36)
18789
18790C...Derive kinematical quantities
18791 TAUE=TAU
18792 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
18793 X(1)=SQRT(TAUE)*EXP(YST)
18794 X(2)=SQRT(TAUE)*EXP(-YST)
18795 IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN
18796 IF(X(1).GT.1D0-1D-7) RETURN
18797 ELSEIF(MINT(45).EQ.3) THEN
18798 X(1)=MIN(1D0-1.1D-10,X(1))
18799 ENDIF
18800 IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
18801 IF(X(2).GT.1D0-1D-7) RETURN
18802 ELSEIF(MINT(46).EQ.3) THEN
18803 X(2)=MIN(1D0-1.1D-10,X(2))
18804 ENDIF
18805 SH=MAX(1D0,TAU*VINT(2))
18806 SQM3=VINT(63)
18807 SQM4=VINT(64)
18808 RM3=SQM3/SH
18809 RM4=SQM4/SH
18810 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
18811 RPTS=4D0*VINT(71)**2/SH
18812 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
18813 RM34=MAX(1D-20,2D0*RM3*RM4)
18814 RSQM=1D0+RM34
18815 IF(2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)).LT.0.0001D0)
18816 &RM34=MAX(RM34,2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)))
18817 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
18818 IF(ISTSB.EQ.0) THEN
18819 TH=VINT(45)
18820 UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
18821 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
18822 ELSE
18823C...Kinematics with incoming masses tricky: now depends on how
18824C...subprocess has been set up w.r.t. order of incoming partons.
18825 RM1=0D0
18826 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) RM1=-VINT(3)**2/SH
18827 RM2=0D0
18828 IF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) RM2=-VINT(4)**2/SH
18829 IF(ISUB.EQ.35) THEN
18830 RM2=MIN(RM1,RM2)
18831 RM1=0D0
18832 ENDIF
18833 BE12=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18834 TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4)
18835 TH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM4-2D0*RM2*RM3-
18836 & BE12*BE34*CTH)
18837 UH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM3-2D0*RM2*RM4+
18838 & BE12*BE34*CTH)
18839 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
18840 ENDIF
18841 SHR=SQRT(SH)
18842 SH2=SH**2
18843 TH2=TH**2
18844 UH2=UH**2
18845
18846C...Choice of Q2 scale: hard, parton distributions, parton showers
18847 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
18848 Q2=SH
18849 ELSEIF(ISTSB.EQ.8) THEN
18850 IF(MINT(107).EQ.4) Q2=VINT(307)
18851 IF(MINT(108).EQ.4) Q2=VINT(308)
18852 ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
18853 Q2IN1=0D0
18854 IF(MINT(11).EQ.22.AND.VINT(3).LT.0D0) Q2IN1=VINT(3)**2
18855 Q2IN2=0D0
18856 IF(MINT(12).EQ.22.AND.VINT(4).LT.0D0) Q2IN2=VINT(4)**2
18857 IF(MSTP(32).EQ.1) THEN
18858 Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
18859 ELSEIF(MSTP(32).EQ.2) THEN
18860 Q2=SQPTH+0.5D0*(SQM3+SQM4)
18861 ELSEIF(MSTP(32).EQ.3) THEN
18862 Q2=MIN(-TH,-UH)
18863 ELSEIF(MSTP(32).EQ.4) THEN
18864 Q2=SH
18865 ELSEIF(MSTP(32).EQ.5) THEN
18866 Q2=-TH
18867 ELSEIF(MSTP(32).EQ.6) THEN
18868 XSF1=X(1)
18869 IF(ISTSB.EQ.9) XSF1=X(1)/VINT(143)
18870 XSF2=X(2)
18871 IF(ISTSB.EQ.9) XSF2=X(2)/VINT(144)
18872 Q2=(1D0+XSF1*Q2IN1/SH+XSF2*Q2IN2/SH)*
18873 & (SQPTH+0.5D0*(SQM3+SQM4))
18874 ELSEIF(MSTP(32).EQ.7) THEN
18875 Q2=(1D0+Q2IN1/SH+Q2IN2/SH)*(SQPTH+0.5D0*(SQM3+SQM4))
18876 ELSEIF(MSTP(32).EQ.8) THEN
18877 Q2=SQPTH+0.5D0*(Q2IN1+Q2IN2+SQM3+SQM4)
18878 ELSEIF(MSTP(32).EQ.9) THEN
18879 Q2=SQPTH+Q2IN1+Q2IN2+SQM3+SQM4
18880 ELSEIF(MSTP(32).EQ.10) THEN
18881 Q2=VINT(2)
18882 ENDIF
18883 IF(ISTSB.EQ.9) Q2=SQPTH
18884 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2=Q2+
18885 & (PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
18886 ENDIF
18887 Q2SF=Q2
18888 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
18889 Q2SF=PMAS(23,1)**2
18890 IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124.OR.
18891 & ISUB.EQ.351) Q2SF=PMAS(24,1)**2
18892 IF(ISUB.EQ.352) Q2SF=PMAS(63,1)**2
18893 IF(ISUB.EQ.121.OR.ISUB.EQ.122) THEN
18894 Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
18895 IF(MSTP(39).EQ.2) Q2SF=Q2SF+MAX(VINT(202),VINT(207))
18896 IF(MSTP(39).EQ.3) Q2SF=SH
18897 IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2)
18898 IF(MSTP(39).EQ.5) Q2SF=PMAS(KFHIGG,1)**2
18899 ENDIF
18900 ENDIF
18901 Q2PS=Q2SF
18902 Q2SF=Q2SF*PARP(34)
18903 IF(MSTP(69).GE.1.AND.MINT(47).EQ.5) Q2SF=VINT(2)
18904 IF(MSTP(69).GE.2) Q2SF=VINT(2)
18905 IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND.
18906 &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
18907 XBJ=X(2)
18908 IF(MINT(43).EQ.3) XBJ=X(1)
18909 IF(MSTP(22).EQ.1) THEN
18910 Q2PS=-TH
18911 ELSEIF(MSTP(22).EQ.2) THEN
18912 Q2PS=((1D0-XBJ)/XBJ)*(-TH)
18913 ELSEIF(MSTP(22).EQ.3) THEN
18914 Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH)
18915 ELSE
18916 Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH)
18917 ENDIF
18918 ENDIF
18919 IF(MSTP(68).EQ.1.AND.(ISUBSV.EQ.1.OR.ISUBSV.EQ.2.OR.
18920 &ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR.ISUBSV.EQ.144)) THEN
18921 Q2PS=VINT(2)
18922 ELSEIF(MSTP(68).GE.2.AND.(ISUBSV.NE.11.AND.ISUBSV.NE.12.AND.
18923 &ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.ISUBSV.NE.53.AND.
18924 &ISUBSV.NE.68)) THEN
18925 Q2PS=VINT(2)
18926 ENDIF
18927
18928C...Store derived kinematical quantities
18929 VINT(41)=X(1)
18930 VINT(42)=X(2)
18931 VINT(44)=SH
18932 VINT(43)=SQRT(SH)
18933 VINT(45)=TH
18934 VINT(46)=UH
18935 IF(ISTSB.NE.8) VINT(48)=SQPTH
18936 IF(ISTSB.NE.8) VINT(47)=SQRT(SQPTH)
18937 VINT(50)=TAUP*VINT(2)
18938 VINT(49)=SQRT(MAX(0D0,VINT(50)))
18939 VINT(52)=Q2
18940 VINT(51)=SQRT(Q2)
18941 VINT(54)=Q2SF
18942 VINT(53)=SQRT(Q2SF)
18943 VINT(56)=Q2PS
18944 VINT(55)=SQRT(Q2PS)
18945
18946C...Calculate parton distributions
18947 IF(ISTSB.LE.0) GOTO 152
18948 IF(MINT(47).GE.2) THEN
18949 DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
18950 XSF=X(I)
18951 IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
18952 IF(ISUB.EQ.99) THEN
18953 XSF=VINT(309-I)/(VINT(2)+VINT(307)+VINT(308))
18954 Q2SF=VINT(309-I)
18955 ENDIF
18956 MINT(105)=MINT(102+I)
18957 MINT(109)=MINT(106+I)
18958 VINT(120)=VINT(2+I)
fd658fdb 18959C.... ALICE
18960C.... Store side in MINT(124)
18961 MINT(124)=I
18962C....
952cc209 18963 IF(MSTP(57).LE.1) THEN
18964 CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ)
18965 ELSE
18966 CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ)
18967 ENDIF
18968 DO 100 KFL=-25,25
18969 XSFX(I,KFL)=XPQ(KFL)
18970 100 CONTINUE
18971 110 CONTINUE
18972 ENDIF
18973
18974C...Calculate alpha_em, alpha_strong and K-factor
18975 XW=PARU(102)
18976 XWV=XW
18977 IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW=
18978 &1D0-(PMAS(24,1)/PMAS(23,1))**2
18979 XW1=1D0-XW
18980 XWC=1D0/(16D0*XW*XW1)
18981 AEM=PYALEM(Q2)
18982 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
18983 IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2)
18984 FACK=1D0
18985 FACA=1D0
18986 IF(MSTP(33).EQ.1) THEN
18987 FACK=PARP(31)
18988 ELSEIF(MSTP(33).EQ.2) THEN
18989 FACK=PARP(31)
18990 FACA=PARP(32)/PARP(31)
18991 ELSEIF(MSTP(33).EQ.3) THEN
18992 Q2AS=PARP(33)*Q2
18993 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+
18994 & PARU(112)*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
18995 AS=PYALPS(Q2AS)
18996 ENDIF
18997 VINT(138)=1D0
18998 VINT(57)=AEM
18999 VINT(58)=AS
19000
19001C...Set flags for allowed reacting partons/leptons
19002 DO 140 I=1,2
19003 DO 120 J=-25,25
19004 KFAC(I,J)=0
19005 120 CONTINUE
19006 IF(MINT(44+I).EQ.1) THEN
19007 KFAC(I,MINT(10+I))=1
19008 ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN
19009 KFAC(I,MINT(10+I))=1
19010 KFAC(I,22)=1
19011 KFAC(I,24)=1
19012 KFAC(I,-24)=1
19013 ELSE
19014 DO 130 J=-25,25
19015 KFAC(I,J)=KFIN(I,J)
19016 IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0
19017 IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0
19018 130 CONTINUE
19019 ENDIF
19020 140 CONTINUE
19021
19022C...Lower and upper limit for fermion flavour loops
19023 MMIN1=0
19024 MMAX1=0
19025 MMIN2=0
19026 MMAX2=0
19027 DO 150 J=-20,20
19028 IF(KFAC(1,-J).EQ.1) MMIN1=-J
19029 IF(KFAC(1,J).EQ.1) MMAX1=J
19030 IF(KFAC(2,-J).EQ.1) MMIN2=-J
19031 IF(KFAC(2,J).EQ.1) MMAX2=J
19032 150 CONTINUE
19033 MMINA=MIN(MMIN1,MMIN2)
19034 MMAXA=MAX(MMAX1,MMAX2)
19035
19036C...Common resonance mass and width combinations
19037 SQMZ=PMAS(23,1)**2
19038 SQMW=PMAS(24,1)**2
19039 SQMH=PMAS(KFHIGG,1)**2
19040 GMMZ=PMAS(23,1)*PMAS(23,2)
19041 GMMW=PMAS(24,1)*PMAS(24,2)
19042 GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2)
19043C...MRENNA+++
19044 ZWID=PMAS(23,2)
19045 WWID=PMAS(24,2)
19046 TANW=SQRT(XW/XW1)
19047 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
19048C...MRENNA---
19049
19050C...Phase space integral in tau
19051 COMFAC=PARU(1)*PARU(5)/VINT(2)
19052 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK
19053 IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND.
19054 &ISTSB.NE.8.AND.ISTSB.NE.9) THEN
19055 ATAU1=LOG(TAUMAX/TAUMIN)
19056 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
19057 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
19058 IF(MINT(72).GE.1) THEN
19059 TAUR1=VINT(73)
19060 GAMR1=VINT(74)
19061 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
19062 ATAU3=ATAUD/TAUR1
19063 IF(ATAUD.GT.1D-10) H1=H1+
19064 & (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
19065 ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
19066 ATAU4=ATAUD/GAMR1
19067 IF(ATAUD.GT.1D-10) H1=H1+
19068 & (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
19069 ENDIF
19070 IF(MINT(72).EQ.2) THEN
19071 TAUR2=VINT(75)
19072 GAMR2=VINT(76)
19073 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
19074 ATAU5=ATAUD/TAUR2
19075 IF(ATAUD.GT.1D-10) H1=H1+
19076 & (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
19077 ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
19078 ATAU6=ATAUD/GAMR2
19079 IF(ATAUD.GT.1D-10) H1=H1+
19080 & (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
19081 ENDIF
19082 IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
19083 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
19084 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
19085 & MAX(2D-10,1D0-TAU)
19086 ELSEIF(MINT(47).GE.6.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
19087 ATAU7=LOG(MAX(1D-10,1D0-TAUMIN)/MAX(1D-10,1D0-TAUMAX))
19088 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
19089 & MAX(1D-10,1D0-TAU)
19090 ENDIF
19091 COMFAC=COMFAC*ATAU1/(TAU*H1)
19092 ENDIF
19093
19094C...Phase space integral in y*
19095 IF((MINT(47).EQ.4.OR.MINT(47).EQ.5).AND.ISTSB.NE.8.AND.ISTSB.NE.9)
19096 &THEN
19097 AYST0=YSTMAX-YSTMIN
19098 IF(AYST0.LT.1D-10) THEN
19099 COMFAC=0D0
19100 ELSE
19101 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
19102 AYST2=AYST1
19103 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
19104 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
19105 & (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
19106 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
19107 IF(MINT(45).EQ.3) THEN
19108 YST0=-0.5D0*LOG(TAUE)
19109 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
19110 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
19111 IF(AYST4.GT.1D-10) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
19112 & MAX(1D-10,1D0-EXP(YST-YST0))
19113 ENDIF
19114 IF(MINT(46).EQ.3) THEN
19115 YST0=-0.5D0*LOG(TAUE)
19116 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
19117 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
19118 IF(AYST5.GT.1D-10) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
19119 & MAX(1D-10,1D0-EXP(-YST-YST0))
19120 ENDIF
19121 COMFAC=COMFAC*AYST0/H2
19122 ENDIF
19123 ENDIF
19124
19125C...2 -> 1 processes: reduction in angular part of phase space integral
19126C...for case of decaying resonance
19127 ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
19128 IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
19129 IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
19130 IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
19131 & KFPR(ISUB,1).EQ.39) THEN
19132 COMFAC=COMFAC*0.5D0*ACTH0
19133 ELSE
19134 COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
19135 & CTPMAX**3-CTPMIN**3)
19136 ENDIF
19137 ENDIF
19138
19139C...2 -> 2 processes: angular part of phase space integral
19140 ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
19141 ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
19142 & (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
19143 ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
19144 & (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
19145 ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
19146 & 1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
19147 ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
19148 & 1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
19149 H3=COEF(ISUBSV,13)+
19150 & (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
19151 & (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
19152 & (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
19153 & (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
19154 COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3
19155
19156C...2 -> 2 processes: take into account final state Breit-Wigners
19157 COMFAC=COMFAC*VINT(80)
19158 ENDIF
19159
19160C...2 -> 3, 4 processes: phace space integral in tau'
19161 IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
19162 ATAUP1=LOG(TAUPMX/TAUPMN)
19163 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
19164 H4=COEF(ISUBSV,18)+
19165 & (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
19166 IF(MINT(47).EQ.5) THEN
19167 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
19168 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-10,1D0-TAUP)
19169 ELSEIF(MINT(47).GE.6) THEN
19170 ATAUP3=LOG(MAX(1D-10,1D0-TAUPMN)/MAX(1D-10,1D0-TAUPMX))
19171 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(1D-10,1D0-TAUP)
19172 ENDIF
19173 COMFAC=COMFAC*ATAUP1/H4
19174 ENDIF
19175
19176C...2 -> 3, 4 processes: effective W/Z parton distributions
19177 IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
19178 IF(1D0-TAU/TAUP.GT.1D-4) THEN
19179 FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
19180 ELSE
19181 FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
19182 ENDIF
19183 COMFAC=COMFAC*FZW
19184 ENDIF
19185
19186C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
19187 IF(ISTSB.EQ.5) THEN
19188 COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
19189 & (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
19190 ENDIF
19191
19192C...Phase space integral for low-pT and multiple interactions
19193 IF(ISTSB.EQ.9) THEN
19194 COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
19195 ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
19196 ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
19197 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
19198 COMFAC=COMFAC*ATAU1/H1
19199 AYST0=YSTMAX-YSTMIN
19200 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
19201 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
19202 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
19203 & (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
19204 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
19205 COMFAC=COMFAC*AYST0/H2
19206 IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
19207C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
19208C...introduced to make cross-section finite for xT2 -> 0
19209 IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
19210 & (1D0+VINT(149)))
19211 ENDIF
19212
19213C...Real gamma + gamma: include factor 2 when different nature
19214 152 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
19215 &MSTP(14).LE.10) COMFAC=2D0*COMFAC
19216
19217C...Extra factors to include the effects of
19218C...longitudinal resolved photons.
19219 DO 155 ISDE=1,2
19220 IF(MINT(10+ISDE).EQ.22.AND.MINT(106+ISDE).GE.1) THEN
19221 VINT(314+ISDE)=1D0
19222 XY=PARP(166+ISDE)
19223 IF(MSTP(16).EQ.0) THEN
19224 IF(VINT(304+ISDE).GT.0D0.AND.VINT(304+ISDE).LT.1D0)
19225 & XY=VINT(304+ISDE)
19226 ELSE
19227 IF(VINT(308+ISDE).GT.0D0.AND.VINT(308+ISDE).LT.1D0)
19228 & XY=VINT(308+ISDE)
19229 ENDIF
19230 Q2GA=VINT(306+ISDE)
19231 IF(MSTP(17).GT.0.AND.XY.GT.0D0.AND.XY.LT.1D0.AND.
19232 & Q2GA.GT.0D0) THEN
19233 REDUCE=0D0
19234 IF(MSTP(17).EQ.1) THEN
19235 REDUCE=4D0*Q2*Q2GA/(Q2+Q2GA)**2
19236 ELSEIF(MSTP(17).EQ.2) THEN
19237 REDUCE=4D0*Q2GA/(Q2+Q2GA)
19238 ELSEIF(MSTP(17).EQ.3) THEN
19239 PMVIRT=PMAS(PYCOMP(113),1)
19240 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
19241 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.1) THEN
19242 PMVIRT=PMAS(PYCOMP(113),1)
19243 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
19244 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.2) THEN
19245 PMVIRT=PMAS(PYCOMP(113),1)
19246 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
19247 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.3) THEN
19248 PMVSMN=4D0*PARP(15)**2
19249 PMVSMX=4D0*VINT(154)**2
19250 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
19251 REDLON=(3D0*PMVSMN+Q2GA)/(PMVSMN+Q2GA)**3-
19252 & (3D0*PMVSMX+Q2GA)/(PMVSMX+Q2GA)**3
19253 REDUCE=4D0*(Q2GA/6D0)*REDLON/REDTRA
19254 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.1) THEN
19255 PMVIRT=PMAS(PYCOMP(113),1)
19256 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
19257 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.2) THEN
19258 PMVIRT=PMAS(PYCOMP(113),1)
19259 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
19260 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.3) THEN
19261 PMVSMN=4D0*PARP(15)**2
19262 PMVSMX=4D0*VINT(154)**2
19263 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
19264 REDLON=1D0/(PMVSMN+Q2GA)**2-1D0/(PMVSMX+Q2GA)**2
19265 REDUCE=4D0*(Q2GA/2D0)*REDLON/REDTRA
19266 ENDIF
19267 BEAMAS=PYMASS(11)
19268 IF(VINT(302+ISDE).GT.0D0) BEAMAS=VINT(302+ISDE)
19269 FRACLT=1D0/(1D0+XY**2/2D0/(1D0-XY)*
19270 & (1D0-2D0*BEAMAS**2/Q2GA))
19271 VINT(314+ISDE)=1D0+PARP(165)*REDUCE*FRACLT
19272 ENDIF
19273 ELSE
19274 VINT(314+ISDE)=1D0
19275 ENDIF
19276 COMFAC=COMFAC*VINT(314+ISDE)
19277 155 CONTINUE
19278
19279C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
19280 IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ.
19281 &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN
19282C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
19283 IF(MSTP(46).LE.4) THEN
19284 HDTLH=LOG(PMAS(25,1)/PARP(44))
19285 HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0
19286 HDTNR=-1D0/18D0+HDTLH/6D0
19287 ELSE
19288 HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2)
19289 HDTLQ=LOG(PARP(45)/PARP(44))
19290 HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0
19291 HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0
19292 ENDIF
19293
19294C...Calculate lowest and next-to-lowest order partial wave amplitudes
19295 HDTV=1D0/(16D0*PARU(1)*PARP(47)**2)
19296 A00L=SNGL(HDTV*SH)
19297 A20L=-0.5*A00L
19298 A11L=A00L/6.
19299 HDTLS=LOG(SH/PARP(44)**2)
19300 A004=SNGL((HDTV*SH)**2/(4D0*PARU(1)))*
19301 & CMPLX(SNGL((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0-
19302 & (50D0/9D0)*HDTLS),SNGL(4D0*PARU(1)))
19303 A204=SNGL((HDTV*SH)**2/(4D0*PARU(1)))*
19304 & CMPLX(SNGL(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0-
19305 & (20D0/9D0)*HDTLS),SNGL(PARU(1)))
19306 A114=SNGL((HDTV*SH)**2/(6D0*PARU(1)))*
19307 & CMPLX(SNGL(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),SNGL(PARU(1)/6D0))
19308
19309C...Unitarize partial wave amplitudes with Pade or K-matrix method
19310 IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN
19311 A00U=A00L/(1.-A004/A00L)
19312 A20U=A20L/(1.-A204/A20L)
19313 A11U=A11L/(1.-A114/A11L)
19314 ELSE
19315 A00U=(A00L+REAL(A004))/(1.-CMPLX(0.,A00L+REAL(A004)))
19316 A20U=(A20L+REAL(A204))/(1.-CMPLX(0.,A20L+REAL(A204)))
19317 A11U=(A11L+REAL(A114))/(1.-CMPLX(0.,A11L+REAL(A114)))
19318 ENDIF
19319 ENDIF
19320
19321C...Supersymmetric processes - all of type 2 -> 2 :
19322C...correct final-state Breit-Wigners from fixed to running width.
19323 IF(ISUB.GE.200.AND.ISUB.LE.301.AND.MSTP(42).GT.0) THEN
19324 DO 160 I=1,2
19325 KFLW=KFPR(ISUBSV,I)
19326 KCW=PYCOMP(KFLW)
19327 IF(PMAS(KCW,2).LT.PARP(41)) GOTO 160
19328 IF(I.EQ.1) SQMI=SQM3
19329 IF(I.EQ.2) SQMI=SQM4
19330 SQMS=PMAS(KCW,1)**2
19331 GMMS=PMAS(KCW,1)*PMAS(KCW,2)
19332 HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2)
19333 CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
19334 GMMI=SQRT(SQMI)*WDTP(0)
19335 HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2)
19336 COMFAC=COMFAC*(HBWI/HBWS)
19337 160 CONTINUE
19338 ENDIF
19339
19340C...A: 2 -> 1, tree diagrams
19341
19342 IF(ISUB.LE.10) THEN
19343 IF(ISUB.EQ.1) THEN
19344C...f + fbar -> gamma*/Z0
19345 MINT(61)=2
19346 CALL PYWIDT(23,SH,WDTP,WDTE)
19347 HS=SHR*WDTP(0)
19348 FACZ=4D0*COMFAC*3D0
19349 HP0=AEM/3D0*SH
19350 HP1=AEM/3D0*XWC*SH
19351 DO 180 I=MMINA,MMAXA
19352 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180
19353 EI=KCHG(IABS(I),1)/3D0
19354 AI=SIGN(1D0,EI)
19355 VI=AI-4D0*EI*XWV
19356 HI0=HP0
19357 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
19358 HI1=HP1
19359 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
19360 NCHN=NCHN+1
19361 ISIG(NCHN,1)=I
19362 ISIG(NCHN,2)=-I
19363 ISIG(NCHN,3)=1
19364 SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+
19365 & EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*
19366 & (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/
19367 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114))
19368 180 CONTINUE
19369
19370 ELSEIF(ISUB.EQ.2) THEN
19371C...f + fbar' -> W+/-
19372 CALL PYWIDT(24,SH,WDTP,WDTE)
19373 HS=SHR*WDTP(0)
19374 FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0
19375 HP=AEM/(24D0*XW)*SH
19376 DO 200 I=MMIN1,MMAX1
19377 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 200
19378 IA=IABS(I)
19379 DO 190 J=MMIN2,MMAX2
19380 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 190
19381 JA=IABS(J)
19382 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 190
19383 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
19384 & GOTO 190
19385 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
19386 HI=HP*2D0
19387 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
19388 NCHN=NCHN+1
19389 ISIG(NCHN,1)=I
19390 ISIG(NCHN,2)=J
19391 ISIG(NCHN,3)=1
19392 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
19393 SIGH(NCHN)=HI*FACBW*HF
19394 190 CONTINUE
19395 200 CONTINUE
19396
19397 ELSEIF(ISUB.EQ.3) THEN
19398C...f + fbar -> h0 (or H0, or A0)
19399 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
19400 HS=SHR*WDTP(0)
19401 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
19402 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
19403 & FACBW=0D0
19404 HP=AEM/(8D0*XW)*SH/SQMW*SH
19405 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19406 DO 210 I=MMINA,MMAXA
19407 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210
19408 IA=IABS(I)
19409 RMQ=PYMRUN(IA,SH)**2/SH
19410 HI=HP*RMQ
19411 IF(IA.LE.10) HI=HP*RMQ*FACA/3D0
19412 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
19413 IKFI=1
19414 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
19415 IF(IA.GT.10) IKFI=3
19416 HI=HI*PARU(150+10*IHIGG+IKFI)**2
19417 ENDIF
19418 NCHN=NCHN+1
19419 ISIG(NCHN,1)=I
19420 ISIG(NCHN,2)=-I
19421 ISIG(NCHN,3)=1
19422 SIGH(NCHN)=HI*FACBW*HF
19423 210 CONTINUE
19424
19425 ELSEIF(ISUB.EQ.4) THEN
19426C...gamma + W+/- -> W+/-
19427
19428 ELSEIF(ISUB.EQ.5) THEN
19429C...Z0 + Z0 -> h0
19430 CALL PYWIDT(25,SH,WDTP,WDTE)
19431 HS=SHR*WDTP(0)
19432 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
19433 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
19434 HP=AEM/(8D0*XW)*SH/SQMW*SH
19435 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19436 HI=HP/4D0
19437 FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2
19438 DO 230 I=MMIN1,MMAX1
19439 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 230
19440 DO 220 J=MMIN2,MMAX2
19441 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 220
19442 EI=KCHG(IABS(I),1)/3D0
19443 AI=SIGN(1D0,EI)
19444 VI=AI-4D0*EI*XWV
19445 EJ=KCHG(IABS(J),1)/3D0
19446 AJ=SIGN(1D0,EJ)
19447 VJ=AJ-4D0*EJ*XWV
19448 NCHN=NCHN+1
19449 ISIG(NCHN,1)=I
19450 ISIG(NCHN,2)=J
19451 ISIG(NCHN,3)=1
19452 SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF
19453 220 CONTINUE
19454 230 CONTINUE
19455
19456 ELSEIF(ISUB.EQ.6) THEN
19457C...Z0 + W+/- -> W+/-
19458
19459 ELSEIF(ISUB.EQ.7) THEN
19460C...W+ + W- -> Z0
19461
19462 ELSEIF(ISUB.EQ.8) THEN
19463C...W+ + W- -> h0
19464 CALL PYWIDT(25,SH,WDTP,WDTE)
19465 HS=SHR*WDTP(0)
19466 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
19467 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
19468 HP=AEM/(8D0*XW)*SH/SQMW*SH
19469 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19470 HI=HP/2D0
19471 FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2
19472 DO 250 I=MMIN1,MMAX1
19473 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 250
19474 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
19475 DO 240 J=MMIN2,MMAX2
19476 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 240
19477 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
19478 IF(EI*EJ.GT.0D0) GOTO 240
19479 NCHN=NCHN+1
19480 ISIG(NCHN,1)=I
19481 ISIG(NCHN,2)=J
19482 ISIG(NCHN,3)=1
19483 SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF
19484 240 CONTINUE
19485 250 CONTINUE
19486
19487C...B: 2 -> 2, tree diagrams
19488
19489 ELSEIF(ISUB.EQ.10) THEN
19490C...f + f' -> f + f' (gamma/Z/W exchange)
19491 FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2
19492 FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ))
19493 FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2
19494 FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2
19495 DO 270 I=MMIN1,MMAX1
19496 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 270
19497 IA=IABS(I)
19498 DO 260 J=MMIN2,MMAX2
19499 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 260
19500 JA=IABS(J)
19501C...Electroweak couplings
19502 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
19503 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
19504 VI=AI-4D0*EI*XWV
19505 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
19506 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
19507 VJ=AJ-4D0*EJ*XWV
19508 EPSIJ=ISIGN(1,I*J)
19509C...gamma/Z exchange, only gamma exchange, or only Z exchange
19510 IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN
19511 IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN
19512 FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ*
19513 & (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+
19514 & FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+
19515 & 4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
19516 ELSEIF(MSTP(21).EQ.2) THEN
19517 FACNCF=FACGGF*EI**2*EJ**2
19518 ELSE
19519 FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*
19520 & (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
19521 ENDIF
19522 NCHN=NCHN+1
19523 ISIG(NCHN,1)=I
19524 ISIG(NCHN,2)=J
19525 ISIG(NCHN,3)=1
19526 SIGH(NCHN)=FACNCF
19527 ENDIF
19528C...W exchange
19529 IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN
19530 FACCCF=FACWWF*VINT(180+I)*VINT(180+J)
19531 IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2
19532 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF
19533 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF
19534 NCHN=NCHN+1
19535 ISIG(NCHN,1)=I
19536 ISIG(NCHN,2)=J
19537 ISIG(NCHN,3)=2
19538 SIGH(NCHN)=FACCCF
19539 ENDIF
19540 260 CONTINUE
19541 270 CONTINUE
19542 ENDIF
19543
19544 ELSEIF(ISUB.LE.20) THEN
19545 IF(ISUB.EQ.11) THEN
19546C...f + f' -> f + f' (g exchange)
19547 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
19548 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
19549 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
19550 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)/UH2
19551 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
19552 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
19553 IF(MSTP(5).GE.1) THEN
19554C...Modifications from contact interactions (compositeness)
19555 FACCI1=FACQQ1+COMFAC*(SH2/PARU(155)**4)
19556 FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*PARU(156)/PARU(155)**2)*
19557 & (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/PARU(155)**4)
19558 FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*PARU(156)/PARU(155)**2)*
19559 & (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/PARU(155)**4)
19560 FACCI3=FACQQ1+COMFAC*(UH2/PARU(155)**4)
19561 RATCII=(FACCI1*FACCI2+FACQQI)/(FACCI1+FACCI2)
19562 ENDIF
19563 DO 290 I=MMIN1,MMAX1
19564 IA=IABS(I)
19565 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 290
19566 DO 280 J=MMIN2,MMAX2
19567 JA=IABS(J)
19568 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 280
19569 NCHN=NCHN+1
19570 ISIG(NCHN,1)=I
19571 ISIG(NCHN,2)=J
19572 ISIG(NCHN,3)=1
19573 IF(MSTP(5).LE.0.OR.(MSTP(5).EQ.1.AND.(IA.GE.3.OR.
19574 & JA.GE.3))) THEN
19575 SIGH(NCHN)=FACQQ1
19576 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
19577 ELSE
19578 SIGH(NCHN)=FACCI1
19579 IF(I*J.LT.0) SIGH(NCHN)=FACCI3
19580 IF(I.EQ.-J) SIGH(NCHN)=FACCIB
19581 ENDIF
19582 IF(I.EQ.J) THEN
19583 NCHN=NCHN+1
19584 ISIG(NCHN,1)=I
19585 ISIG(NCHN,2)=J
19586 ISIG(NCHN,3)=2
19587 IF(MSTP(5).LE.0.OR.(MSTP(5).EQ.1.AND.IA.GE.3)) THEN
19588 SIGH(NCHN-1)=0.5D0*FACQQ1*RATQQI
19589 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
19590 ELSE
19591 SIGH(NCHN-1)=0.5D0*FACCI1*RATCII
19592 SIGH(NCHN)=0.5D0*FACCI2*RATCII
19593 ENDIF
19594 ENDIF
19595 280 CONTINUE
19596 290 CONTINUE
19597
19598 ELSEIF(ISUB.EQ.12) THEN
19599C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
19600 CALL PYWIDT(21,SH,WDTP,WDTE)
19601 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
19602 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19603 IF(MSTP(5).EQ.1) THEN
19604C...Modifications from contact interactions (compositeness)
19605 FACCIB=FACQQB
19606 DO 300 I=1,2
19607 FACCIB=FACCIB+COMFAC*(UH2/PARU(155)**4)*(WDTE(I,1)+
19608 & WDTE(I,2)+WDTE(I,4))
19609 300 CONTINUE
19610 ELSEIF(MSTP(5).GE.2) THEN
19611 FACCIB=FACQQB+COMFAC*(UH2/PARU(155)**4)*
19612 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19613 ENDIF
19614 DO 310 I=MMINA,MMAXA
19615 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
19616 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
19617 NCHN=NCHN+1
19618 ISIG(NCHN,1)=I
19619 ISIG(NCHN,2)=-I
19620 ISIG(NCHN,3)=1
19621 IF(MSTP(5).LE.0.OR.(MSTP(5).EQ.1.AND.IABS(I).GE.3)) THEN
19622 SIGH(NCHN)=FACQQB
19623 ELSE
19624 SIGH(NCHN)=FACCIB
19625 ENDIF
19626 310 CONTINUE
19627
19628 ELSEIF(ISUB.EQ.13) THEN
19629C...f + fbar -> g + g (q + qbar -> g + g only)
19630 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
19631 & UH2/SH2)
19632 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
19633 & TH2/SH2)
19634 DO 320 I=MMINA,MMAXA
19635 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
19636 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
19637 NCHN=NCHN+1
19638 ISIG(NCHN,1)=I
19639 ISIG(NCHN,2)=-I
19640 ISIG(NCHN,3)=1
19641 SIGH(NCHN)=0.5D0*FACGG1
19642 NCHN=NCHN+1
19643 ISIG(NCHN,1)=I
19644 ISIG(NCHN,2)=-I
19645 ISIG(NCHN,3)=2
19646 SIGH(NCHN)=0.5D0*FACGG2
19647 320 CONTINUE
19648
19649 ELSEIF(ISUB.EQ.14) THEN
19650C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
19651 FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH)
19652 DO 330 I=MMINA,MMAXA
19653 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
19654 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 330
19655 EI=KCHG(IABS(I),1)/3D0
19656 NCHN=NCHN+1
19657 ISIG(NCHN,1)=I
19658 ISIG(NCHN,2)=-I
19659 ISIG(NCHN,3)=1
19660 SIGH(NCHN)=FACGG*EI**2
19661 330 CONTINUE
19662
19663 ELSEIF(ISUB.EQ.15) THEN
19664C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
19665 FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
19666C...gamma, gamma/Z interference and Z couplings to final fermion pairs
19667 HFGG=0D0
19668 HFGZ=0D0
19669 HFZZ=0D0
19670 RADC4=1D0+PYALPS(SQM4)/PARU(1)
19671 DO 340 I=1,MIN(16,MDCY(23,3))
19672 IDC=I+MDCY(23,2)-1
19673 IF(MDME(IDC,1).LT.0) GOTO 340
19674 IMDM=0
19675 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
19676 & IMDM=1
19677 IF(I.LE.8) THEN
19678 EF=KCHG(I,1)/3D0
19679 AF=SIGN(1D0,EF+0.1D0)
19680 VF=AF-4D0*EF*XWV
19681 ELSEIF(I.LE.16) THEN
19682 EF=KCHG(I+2,1)/3D0
19683 AF=SIGN(1D0,EF+0.1D0)
19684 VF=AF-4D0*EF*XWV
19685 ENDIF
19686 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
19687 IF(4D0*RM1.LT.1D0) THEN
19688 FCOF=1D0
19689 IF(I.LE.8) FCOF=3D0*RADC4
19690 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
19691 IF(IMDM.EQ.1) THEN
19692 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
19693 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
19694 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
19695 & AF**2*(1D0-4D0*RM1))*BE34
19696 ENDIF
19697 ENDIF
19698 340 CONTINUE
19699C...Propagators: as simulated in PYOFSH and as desired
19700 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
19701 MINT15=MINT(15)
19702 MINT(15)=1
19703 MINT(61)=1
19704 CALL PYWIDT(23,SQM4,WDTP,WDTE)
19705 MINT(15)=MINT15
19706 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
19707 HFGG=HFGG*HFAEM*VINT(111)/SQM4
19708 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
19709 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
19710C...Loop over flavours; consider full gamma/Z structure
19711 DO 350 I=MMINA,MMAXA
19712 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
19713 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
19714 EI=KCHG(IABS(I),1)/3D0
19715 AI=SIGN(1D0,EI)
19716 VI=AI-4D0*EI*XWV
19717 NCHN=NCHN+1
19718 ISIG(NCHN,1)=I
19719 ISIG(NCHN,2)=-I
19720 ISIG(NCHN,3)=1
19721 SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+
19722 & (VI**2+AI**2)*HFZZ)/HBW4
19723 350 CONTINUE
19724
19725 ELSEIF(ISUB.EQ.16) THEN
19726C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
19727 FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
19728C...Propagators: as simulated in PYOFSH and as desired
19729 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
19730 CALL PYWIDT(24,SQM4,WDTP,WDTE)
19731 GMMWC=SQRT(SQM4)*WDTP(0)
19732 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
19733 FACWG=FACWG*HBW4C/HBW4
19734 DO 370 I=MMIN1,MMAX1
19735 IA=IABS(I)
19736 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 370
19737 DO 360 J=MMIN2,MMAX2
19738 JA=IABS(J)
19739 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 360
19740 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
19741 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
19742 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
19743 FCKM=VCKM((IA+1)/2,(JA+1)/2)
19744 NCHN=NCHN+1
19745 ISIG(NCHN,1)=I
19746 ISIG(NCHN,2)=J
19747 ISIG(NCHN,3)=1
19748 SIGH(NCHN)=FACWG*FCKM*WIDSC
19749 360 CONTINUE
19750 370 CONTINUE
19751
19752 ELSEIF(ISUB.EQ.17) THEN
19753C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
19754
19755 ELSEIF(ISUB.EQ.18) THEN
19756C...f + fbar -> gamma + gamma
19757 FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH)
19758 DO 380 I=MMINA,MMAXA
19759 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
19760 EI=KCHG(IABS(I),1)/3D0
19761 FCOI=1D0
19762 IF(IABS(I).LE.10) FCOI=FACA/3D0
19763 NCHN=NCHN+1
19764 ISIG(NCHN,1)=I
19765 ISIG(NCHN,2)=-I
19766 ISIG(NCHN,3)=1
19767 SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4
19768 380 CONTINUE
19769
19770 ELSEIF(ISUB.EQ.19) THEN
19771C...f + fbar -> gamma + (gamma*/Z0)
19772 FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
19773C...gamma, gamma/Z interference and Z couplings to final fermion pairs
19774 HFGG=0D0
19775 HFGZ=0D0
19776 HFZZ=0D0
19777 RADC4=1D0+PYALPS(SQM4)/PARU(1)
19778 DO 390 I=1,MIN(16,MDCY(23,3))
19779 IDC=I+MDCY(23,2)-1
19780 IF(MDME(IDC,1).LT.0) GOTO 390
19781 IMDM=0
19782 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
19783 & IMDM=1
19784 IF(I.LE.8) THEN
19785 EF=KCHG(I,1)/3D0
19786 AF=SIGN(1D0,EF+0.1D0)
19787 VF=AF-4D0*EF*XWV
19788 ELSEIF(I.LE.16) THEN
19789 EF=KCHG(I+2,1)/3D0
19790 AF=SIGN(1D0,EF+0.1D0)
19791 VF=AF-4D0*EF*XWV
19792 ENDIF
19793 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
19794 IF(4D0*RM1.LT.1D0) THEN
19795 FCOF=1D0
19796 IF(I.LE.8) FCOF=3D0*RADC4
19797 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
19798 IF(IMDM.EQ.1) THEN
19799 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
19800 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
19801 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
19802 & AF**2*(1D0-4D0*RM1))*BE34
19803 ENDIF
19804 ENDIF
19805 390 CONTINUE
19806C...Propagators: as simulated in PYOFSH and as desired
19807 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
19808 MINT15=MINT(15)
19809 MINT(15)=1
19810 MINT(61)=1
19811 CALL PYWIDT(23,SQM4,WDTP,WDTE)
19812 MINT(15)=MINT15
19813 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
19814 HFGG=HFGG*HFAEM*VINT(111)/SQM4
19815 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
19816 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
19817C...Loop over flavours; consider full gamma/Z structure
19818 DO 400 I=MMINA,MMAXA
19819 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
19820 EI=KCHG(IABS(I),1)/3D0
19821 AI=SIGN(1D0,EI)
19822 VI=AI-4D0*EI*XWV
19823 FCOI=1D0
19824 IF(IABS(I).LE.10) FCOI=FACA/3D0
19825 NCHN=NCHN+1
19826 ISIG(NCHN,1)=I
19827 ISIG(NCHN,2)=-I
19828 ISIG(NCHN,3)=1
19829 SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+
19830 & (VI**2+AI**2)*HFZZ)/HBW4
19831 400 CONTINUE
19832
19833 ELSEIF(ISUB.EQ.20) THEN
19834C...f + fbar' -> gamma + W+/-
19835 FACGW=COMFAC*0.5D0*AEM**2/XW
19836C...Propagators: as simulated in PYOFSH and as desired
19837 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
19838 CALL PYWIDT(24,SQM4,WDTP,WDTE)
19839 GMMWC=SQRT(SQM4)*WDTP(0)
19840 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
19841 FACGW=FACGW*HBW4C/HBW4
19842C...Anomalous couplings
19843 TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
19844 TERM2=0D0
19845 TERM3=0D0
19846 IF(MSTP(5).GE.1) THEN
19847 TERM2=PARU(153)*(TH-UH)/(TH+UH)
19848 TERM3=0.5D0*PARU(153)**2*(TH*UH+(TH2+UH2)*SH/
19849 & (4D0*SQMW))/(TH+UH)**2
19850 ENDIF
19851 DO 420 I=MMIN1,MMAX1
19852 IA=IABS(I)
19853 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 420
19854 DO 410 J=MMIN2,MMAX2
19855 JA=IABS(J)
19856 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 410
19857 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 410
19858 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
19859 & GOTO 410
19860 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
19861 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
19862 IF(IA.LE.10) THEN
19863 FACWR=UH/(TH+UH)-1D0/3D0
19864 FCKM=VCKM((IA+1)/2,(JA+1)/2)
19865 FCOI=FACA/3D0
19866 ELSE
19867 FACWR=-TH/(TH+UH)
19868 FCKM=1D0
19869 FCOI=1D0
19870 ENDIF
19871 FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3
19872 NCHN=NCHN+1
19873 ISIG(NCHN,1)=I
19874 ISIG(NCHN,2)=J
19875 ISIG(NCHN,3)=1
19876 SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC
19877 410 CONTINUE
19878 420 CONTINUE
19879 ENDIF
19880
19881 ELSEIF(ISUB.LE.30) THEN
19882 IF(ISUB.EQ.21) THEN
19883C...f + fbar -> gamma + h0
19884
19885 ELSEIF(ISUB.EQ.22) THEN
19886C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
19887C...Kinematics dependence
19888 FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)-
19889 & SQM3*SQM4*(1D0/TH2+1D0/UH2))
19890C...gamma, gamma/Z interference and Z couplings to final fermion pairs
19891 DO 440 I=1,6
19892 DO 430 J=1,3
19893 HGZ(I,J)=0D0
19894 430 CONTINUE
19895 440 CONTINUE
19896 RADC3=1D0+PYALPS(SQM3)/PARU(1)
19897 RADC4=1D0+PYALPS(SQM4)/PARU(1)
19898 DO 450 I=1,MIN(16,MDCY(23,3))
19899 IDC=I+MDCY(23,2)-1
19900 IF(MDME(IDC,1).LT.0) GOTO 450
19901 IMDM=0
19902 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1
19903 IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2
19904 IF(I.LE.8) THEN
19905 EF=KCHG(I,1)/3D0
19906 AF=SIGN(1D0,EF+0.1D0)
19907 VF=AF-4D0*EF*XWV
19908 ELSEIF(I.LE.16) THEN
19909 EF=KCHG(I+2,1)/3D0
19910 AF=SIGN(1D0,EF+0.1D0)
19911 VF=AF-4D0*EF*XWV
19912 ENDIF
19913 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3
19914 IF(4D0*RM1.LT.1D0) THEN
19915 FCOF=1D0
19916 IF(I.LE.8) FCOF=3D0*RADC3
19917 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
19918 IF(IMDM.GE.1) THEN
19919 HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
19920 HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
19921 HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
19922 & AF**2*(1D0-4D0*RM1))*BE34
19923 ENDIF
19924 ENDIF
19925 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
19926 IF(4D0*RM1.LT.1D0) THEN
19927 FCOF=1D0
19928 IF(I.LE.8) FCOF=3D0*RADC4
19929 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
19930 IF(IMDM.GE.1) THEN
19931 HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
19932 HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
19933 HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
19934 & AF**2*(1D0-4D0*RM1))*BE34
19935 ENDIF
19936 ENDIF
19937 450 CONTINUE
19938C...Propagators: as simulated in PYOFSH and as desired
19939 HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
19940 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
19941 MINT15=MINT(15)
19942 MINT(15)=1
19943 MINT(61)=1
19944 CALL PYWIDT(23,SQM3,WDTP,WDTE)
19945 MINT(15)=MINT15
19946 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
19947 DO 460 J=1,3
19948 HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3
19949 HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3
19950 HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3
19951 460 CONTINUE
19952 MINT15=MINT(15)
19953 MINT(15)=1
19954 MINT(61)=1
19955 CALL PYWIDT(23,SQM4,WDTP,WDTE)
19956 MINT(15)=MINT15
19957 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
19958 DO 470 J=1,3
19959 HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4
19960 HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4
19961 HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4
19962 470 CONTINUE
19963C...Loop over flavours; separate left- and right-handed couplings
19964 DO 490 I=MMINA,MMAXA
19965 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 490
19966 EI=KCHG(IABS(I),1)/3D0
19967 AI=SIGN(1D0,EI)
19968 VI=AI-4D0*EI*XWV
19969 VALI=VI-AI
19970 VARI=VI+AI
19971 FCOI=1D0
19972 IF(IABS(I).LE.10) FCOI=FACA/3D0
19973 DO 480 J=1,3
19974 HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J)
19975 HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J)
19976 HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J)
19977 HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J)
19978 480 CONTINUE
19979 FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+
19980 & HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+
19981 & HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+
19982 & HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3)
19983 NCHN=NCHN+1
19984 ISIG(NCHN,1)=I
19985 ISIG(NCHN,2)=-I
19986 ISIG(NCHN,3)=1
19987 SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4)
19988 490 CONTINUE
19989
19990 ELSEIF(ISUB.EQ.23) THEN
19991C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.)
19992 FACZW=COMFAC*0.5D0*(AEM/XW)**2
19993 FACZW=FACZW*WIDS(23,2)
19994 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
19995 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
19996 DO 510 I=MMIN1,MMAX1
19997 IA=IABS(I)
19998 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 510
19999 DO 500 J=MMIN2,MMAX2
20000 JA=IABS(J)
20001 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 500
20002 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 500
20003 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
20004 & GOTO 500
20005 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
20006 EI=KCHG(IA,1)/3D0
20007 AI=SIGN(1D0,EI+0.1D0)
20008 VI=AI-4D0*EI*XWV
20009 EJ=KCHG(JA,1)/3D0
20010 AJ=SIGN(1D0,EJ+0.1D0)
20011 VJ=AJ-4D0*EJ*XWV
20012 IF(VI+AI.GT.0) THEN
20013 VISAV=VI
20014 AISAV=AI
20015 VI=VJ
20016 AI=AJ
20017 VJ=VISAV
20018 AJ=AISAV
20019 ENDIF
20020 FCKM=1D0
20021 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
20022 FCOI=1D0
20023 IF(IA.LE.10) FCOI=FACA/3D0
20024 NCHN=NCHN+1
20025 ISIG(NCHN,1)=I
20026 ISIG(NCHN,2)=J
20027 ISIG(NCHN,3)=1
20028 SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+
20029 & (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))*
20030 & (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
20031 & THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
20032 & SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))*
20033 & WIDS(24,(5-KCHW)/2)
20034C***Protect against slightly negative cross sections. (Reason yet to be
20035C***sorted out. One possibility: addition of width to the W propagator.)
20036 SIGH(NCHN)=MAX(0D0,SIGH(NCHN))
20037 500 CONTINUE
20038 510 CONTINUE
20039
20040 ELSEIF(ISUB.EQ.24) THEN
20041C...f + fbar -> Z0 + h0 (or H0, or A0)
20042 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
20043 FACHZ=COMFAC*8D0*(AEM*XWC)**2*
20044 & (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2)
20045 FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2)
20046 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
20047 & PARU(154+10*IHIGG)**2
20048 DO 520 I=MMINA,MMAXA
20049 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 520
20050 EI=KCHG(IABS(I),1)/3D0
20051 AI=SIGN(1D0,EI)
20052 VI=AI-4D0*EI*XWV
20053 FCOI=1D0
20054 IF(IABS(I).LE.10) FCOI=FACA/3D0
20055 NCHN=NCHN+1
20056 ISIG(NCHN,1)=I
20057 ISIG(NCHN,2)=-I
20058 ISIG(NCHN,3)=1
20059 SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2)
20060 520 CONTINUE
20061
20062 ELSEIF(ISUB.EQ.25) THEN
20063C...f + fbar -> W+ + W-
20064C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
20065 GMMZC=GMMZ
20066 HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2)
20067 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
20068 CALL PYWIDT(24,SQM3,WDTP,WDTE)
20069 GMMW3=SQRT(SQM3)*WDTP(0)
20070 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
20071 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
20072 CALL PYWIDT(24,SQM4,WDTP,WDTE)
20073 GMMW4=SQRT(SQM4)*WDTP(0)
20074 HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2)
20075C...Kinematical functions
20076 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
20077 THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4)
20078 GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2
20079 GT=THUH34+4D0*THUH/TH2
20080 GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH
20081 GU=THUH34+4D0*THUH/UH2
20082 GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH
20083C...Common factors and couplings
20084 FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)
20085 FACWW=FACWW*WIDS(24,1)
20086 CGG=AEM**2/2D0
20087 CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH)
20088 CZZ=AEM**2/(32D0*XW**2)*HBWZC
20089 CNG=AEM**2/(4D0*XW)
20090 CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH)
20091 CNN=AEM**2/(16D0*XW**2)
20092C...Coulomb factor for W+W- pair
20093 IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
20094 COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1))
20095 COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH))
20096 IF(COULE.LT.100D0*PMAS(24,2)) THEN
20097 COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
20098 & PMAS(24,2)**2)-COULE))
20099 ELSE
20100 COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE))
20101 ENDIF
20102 IF(COULE.GT.-100D0*PMAS(24,2)) THEN
20103 COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
20104 & PMAS(24,2)**2)+COULE))
20105 ELSE
20106 COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/
20107 & ABS(COULE)))
20108 ENDIF
20109 IF(MSTP(40).EQ.1) THEN
20110 COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/
20111 & MAX(1D-10,2D0*COULP*COULP1))
20112 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
20113 ELSEIF(MSTP(40).EQ.2) THEN
20114 COULCK=CMPLX(SNGL(COULP1),SNGL(COULP2))
20115 COULCP=CMPLX(0.,SNGL(COULP))
20116 COULCD=(COULCK+COULCP)/(COULCK-COULCP)
20117 COULCR=1.+SNGL(PARU(101)*SQRT(SH))/(4.*COULCP)*LOG(COULCD)
20118 COULCS=CMPLX(0.,0.)
20119 NSTP=100
20120 DO 530 ISTP=1,NSTP
20121 COULXX=(ISTP-0.5)/NSTP
20122 COULCS=COULCS+(1./COULXX)*LOG((1.+COULXX*COULCD)/
20123 & (1.+COULXX/COULCD))
20124 530 CONTINUE
20125 COULCR=COULCR+SNGL(PARU(101)**2*SH)/(16.*COULCP*COULCK)*
20126 & (COULCS/NSTP)
20127 FACCOU=ABS(COULCR)**2
20128 ELSEIF(MSTP(40).EQ.3) THEN
20129 COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+
20130 & COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1))
20131 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
20132 ENDIF
20133 ELSEIF(MSTP(40).EQ.4) THEN
20134 FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34)
20135 ELSE
20136 FACCOU=1D0
20137 ENDIF
20138 VINT(95)=FACCOU
20139 FACWW=FACWW*FACCOU
20140C...Loop over allowed flavours
20141 DO 540 I=MMINA,MMAXA
20142 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 540
20143 EI=KCHG(IABS(I),1)/3D0
20144 AI=SIGN(1D0,EI+0.1D0)
20145 VI=AI-4D0*EI*XWV
20146 FCOI=1D0
20147 IF(IABS(I).LE.10) FCOI=FACA/3D0
20148 IF(AI.LT.0D0) THEN
20149 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+
20150 & (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT
20151 ELSE
20152 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS-
20153 & (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU
20154 ENDIF
20155 NCHN=NCHN+1
20156 ISIG(NCHN,1)=I
20157 ISIG(NCHN,2)=-I
20158 ISIG(NCHN,3)=1
20159 SIGH(NCHN)=FACWW*FCOI*DSIGWW
20160 540 CONTINUE
20161
20162 ELSEIF(ISUB.EQ.26) THEN
20163C...f + fbar' -> W+/- + h0 (or H0, or A0)
20164 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
20165 FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/
20166 & ((SH-SQMW)**2+GMMW**2)
20167 FACHW=FACHW*WIDS(KFHIGG,2)
20168 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
20169 & PARU(155+10*IHIGG)**2
20170 DO 560 I=MMIN1,MMAX1
20171 IA=IABS(I)
20172 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 560
20173 DO 550 J=MMIN2,MMAX2
20174 JA=IABS(J)
20175 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 550
20176 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 550
20177 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
20178 & GOTO 550
20179 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
20180 FCKM=1D0
20181 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
20182 FCOI=1D0
20183 IF(IA.LE.10) FCOI=FACA/3D0
20184 NCHN=NCHN+1
20185 ISIG(NCHN,1)=I
20186 ISIG(NCHN,2)=J
20187 ISIG(NCHN,3)=1
20188 SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2)
20189 550 CONTINUE
20190 560 CONTINUE
20191
20192 ELSEIF(ISUB.EQ.27) THEN
20193C...f + fbar -> h0 + h0
20194
20195 ELSEIF(ISUB.EQ.28) THEN
20196C...f + g -> f + g (q + g -> q + g only)
20197 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
20198 & UH/SH)*FACA
20199 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
20200 & SH/UH)
20201 DO 580 I=MMINA,MMAXA
20202 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 580
20203 DO 570 ISDE=1,2
20204 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 570
20205 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 570
20206 NCHN=NCHN+1
20207 ISIG(NCHN,ISDE)=I
20208 ISIG(NCHN,3-ISDE)=21
20209 ISIG(NCHN,3)=1
20210 SIGH(NCHN)=FACQG1
20211 NCHN=NCHN+1
20212 ISIG(NCHN,ISDE)=I
20213 ISIG(NCHN,3-ISDE)=21
20214 ISIG(NCHN,3)=2
20215 SIGH(NCHN)=FACQG2
20216 570 CONTINUE
20217 580 CONTINUE
20218
20219 ELSEIF(ISUB.EQ.29) THEN
20220C...f + g -> f + gamma (q + g -> q + gamma only)
20221 FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH)
20222 DO 600 I=MMINA,MMAXA
20223 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 600
20224 EI=KCHG(IABS(I),1)/3D0
20225 FACGQ=FGQ*EI**2
20226 DO 590 ISDE=1,2
20227 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 590
20228 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 590
20229 NCHN=NCHN+1
20230 ISIG(NCHN,ISDE)=I
20231 ISIG(NCHN,3-ISDE)=21
20232 ISIG(NCHN,3)=1
20233 SIGH(NCHN)=FACGQ
20234 590 CONTINUE
20235 600 CONTINUE
20236
20237 ELSEIF(ISUB.EQ.30) THEN
20238C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
20239 FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/
20240 & (-SH*UH)
20241C...gamma, gamma/Z interference and Z couplings to final fermion pairs
20242 HFGG=0D0
20243 HFGZ=0D0
20244 HFZZ=0D0
20245 RADC4=1D0+PYALPS(SQM4)/PARU(1)
20246 DO 610 I=1,MIN(16,MDCY(23,3))
20247 IDC=I+MDCY(23,2)-1
20248 IF(MDME(IDC,1).LT.0) GOTO 610
20249 IMDM=0
20250 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
20251 & IMDM=1
20252 IF(I.LE.8) THEN
20253 EF=KCHG(I,1)/3D0
20254 AF=SIGN(1D0,EF+0.1D0)
20255 VF=AF-4D0*EF*XWV
20256 ELSEIF(I.LE.16) THEN
20257 EF=KCHG(I+2,1)/3D0
20258 AF=SIGN(1D0,EF+0.1D0)
20259 VF=AF-4D0*EF*XWV
20260 ENDIF
20261 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
20262 IF(4D0*RM1.LT.1D0) THEN
20263 FCOF=1D0
20264 IF(I.LE.8) FCOF=3D0*RADC4
20265 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
20266 IF(IMDM.EQ.1) THEN
20267 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
20268 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
20269 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
20270 & AF**2*(1D0-4D0*RM1))*BE34
20271 ENDIF
20272 ENDIF
20273 610 CONTINUE
20274C...Propagators: as simulated in PYOFSH and as desired
20275 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
20276 MINT15=MINT(15)
20277 MINT(15)=1
20278 MINT(61)=1
20279 CALL PYWIDT(23,SQM4,WDTP,WDTE)
20280 MINT(15)=MINT15
20281 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
20282 HFGG=HFGG*HFAEM*VINT(111)/SQM4
20283 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
20284 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
20285C...Loop over flavours; consider full gamma/Z structure
20286 DO 630 I=MMINA,MMAXA
20287 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 630
20288 EI=KCHG(IABS(I),1)/3D0
20289 AI=SIGN(1D0,EI)
20290 VI=AI-4D0*EI*XWV
20291 FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+
20292 & (VI**2+AI**2)*HFZZ)/HBW4
20293 DO 620 ISDE=1,2
20294 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 620
20295 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 620
20296 NCHN=NCHN+1
20297 ISIG(NCHN,ISDE)=I
20298 ISIG(NCHN,3-ISDE)=21
20299 ISIG(NCHN,3)=1
20300 SIGH(NCHN)=FACZQ
20301 620 CONTINUE
20302 630 CONTINUE
20303 ENDIF
20304
20305 ELSEIF(ISUB.LE.40) THEN
20306 IF(ISUB.EQ.31) THEN
20307C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
20308 FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0*
20309 & (SH2+UH2+2D0*SQM4*TH)/(-SH*UH)
20310C...Propagators: as simulated in PYOFSH and as desired
20311 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
20312 CALL PYWIDT(24,SQM4,WDTP,WDTE)
20313 GMMWC=SQRT(SQM4)*WDTP(0)
20314 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
20315 FACWQ=FACWQ*HBW4C/HBW4
20316 DO 650 I=MMINA,MMAXA
20317 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 650
20318 IA=IABS(I)
20319 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
20320 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
20321 DO 640 ISDE=1,2
20322 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 640
20323 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 640
20324 NCHN=NCHN+1
20325 ISIG(NCHN,ISDE)=I
20326 ISIG(NCHN,3-ISDE)=21
20327 ISIG(NCHN,3)=1
20328 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
20329 640 CONTINUE
20330 650 CONTINUE
20331
20332 ELSEIF(ISUB.EQ.32) THEN
20333C...f + g -> f + h0 (q + g -> q + h0 only)
20334 SQMHC=PMAS(25,1)**2
20335 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24D0
20336 DO 651 I=MMINA,MMAXA
20337 IA=IABS(I)
20338 IF(IA.NE.5) GOTO 651
20339 SQML=PMAS(IA,1)**2
20340 IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) SQML=SQML*
20341 & (LOG(MAX(4D0,PARP(37)**2*SQML/PARU(117)**2))/
20342 & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
20343 IUA=IA+MOD(IA,2)
20344 SQMQ=SQML
20345 FACHCQ=FHCQ*SQML/SQMW*
20346 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH+
20347 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
20348 & (SQMHC-SQMQ-SH)/SH)
20349 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
20350 DO 641 ISDE=1,2
20351 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 641
20352 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,1).EQ.0) GOTO 641
20353 NCHN=NCHN+1
20354 ISIG(NCHN,ISDE)=I
20355 ISIG(NCHN,3-ISDE)=21
20356 ISIG(NCHN,3)=1
20357 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
20358 641 CONTINUE
20359 651 CONTINUE
20360
20361 ELSEIF(ISUB.EQ.33) THEN
20362C...f + gamma -> f + g (q + gamma -> q + g only)
20363 FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH)
20364 DO 670 I=MMINA,MMAXA
20365 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 670
20366 EI=KCHG(IABS(I),1)/3D0
20367 FACGQ=FGQ*EI**2
20368 DO 660 ISDE=1,2
20369 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 660
20370 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 660
20371 NCHN=NCHN+1
20372 ISIG(NCHN,ISDE)=I
20373 ISIG(NCHN,3-ISDE)=22
20374 ISIG(NCHN,3)=1
20375 SIGH(NCHN)=FACGQ
20376 660 CONTINUE
20377 670 CONTINUE
20378
20379 ELSEIF(ISUB.EQ.34) THEN
20380C...f + gamma -> f + gamma
20381 FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH)
20382 DO 690 I=MMINA,MMAXA
20383 IF(I.EQ.0) GOTO 690
20384 EI=KCHG(IABS(I),1)/3D0
20385 FACGQ=FGQ*EI**4
20386 DO 680 ISDE=1,2
20387 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 680
20388 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 680
20389 NCHN=NCHN+1
20390 ISIG(NCHN,ISDE)=I
20391 ISIG(NCHN,3-ISDE)=22
20392 ISIG(NCHN,3)=1
20393 SIGH(NCHN)=FACGQ
20394 680 CONTINUE
20395 690 CONTINUE
20396
20397 ELSEIF(ISUB.EQ.35) THEN
20398C...f + gamma -> f + (gamma*/Z0)
20399 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) THEN
20400 FZQN=SH2+UH2+2D0*(SQM4-VINT(3)**2)*TH
20401 FZQDTM=VINT(3)**2*SQM4-SH*(UH-VINT(4)**2)
20402 ELSEIF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) THEN
20403 FZQN=SH2+UH2+2D0*(SQM4-VINT(4)**2)*TH
20404 FZQDTM=VINT(4)**2*SQM4-SH*(UH-VINT(3)**2)
20405 ELSE
20406 FZQN=SH2+UH2+2D0*SQM4*TH
20407 FZQDTM=-SH*UH
20408 ENDIF
20409 FZQN=COMFAC*2D0*AEM**2*MAX(0D0,FZQN)
20410C...gamma, gamma/Z interference and Z couplings to final fermion pairs
20411 HFGG=0D0
20412 HFGZ=0D0
20413 HFZZ=0D0
20414 RADC4=1D0+PYALPS(SQM4)/PARU(1)
20415 DO 700 I=1,MIN(16,MDCY(23,3))
20416 IDC=I+MDCY(23,2)-1
20417 IF(MDME(IDC,1).LT.0) GOTO 700
20418 IMDM=0
20419 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
20420 & IMDM=1
20421 IF(I.LE.8) THEN
20422 EF=KCHG(I,1)/3D0
20423 AF=SIGN(1D0,EF+0.1D0)
20424 VF=AF-4D0*EF*XWV
20425 ELSEIF(I.LE.16) THEN
20426 EF=KCHG(I+2,1)/3D0
20427 AF=SIGN(1D0,EF+0.1D0)
20428 VF=AF-4D0*EF*XWV
20429 ENDIF
20430 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
20431 IF(4D0*RM1.LT.1D0) THEN
20432 FCOF=1D0
20433 IF(I.LE.8) FCOF=3D0*RADC4
20434 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
20435 IF(IMDM.EQ.1) THEN
20436 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
20437 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
20438 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
20439 & AF**2*(1D0-4D0*RM1))*BE34
20440 ENDIF
20441 ENDIF
20442 700 CONTINUE
20443C...Propagators: as simulated in PYOFSH and as desired
20444 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
20445 MINT15=MINT(15)
20446 MINT(15)=1
20447 MINT(61)=1
20448 CALL PYWIDT(23,SQM4,WDTP,WDTE)
20449 MINT(15)=MINT15
20450 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
20451 HFGG=HFGG*HFAEM*VINT(111)/SQM4
20452 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
20453 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
20454C...Loop over flavours; consider full gamma/Z structure
20455 DO 720 I=MMINA,MMAXA
20456 IF(I.EQ.0) GOTO 720
20457 EI=KCHG(IABS(I),1)/3D0
20458 AI=SIGN(1D0,EI)
20459 VI=AI-4D0*EI*XWV
20460 FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+
20461 & (VI**2+AI**2)*HFZZ)/HBW4
20462 FZQD=MAX(PMAS(IABS(I),1)**2*SQM4,FZQDTM)
20463 DO 710 ISDE=1,2
20464 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 710
20465 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 710
20466 NCHN=NCHN+1
20467 ISIG(NCHN,ISDE)=I
20468 ISIG(NCHN,3-ISDE)=22
20469 ISIG(NCHN,3)=1
20470 SIGH(NCHN)=FACZQ*FZQN/FZQD
20471 710 CONTINUE
20472 720 CONTINUE
20473
20474 ELSEIF(ISUB.EQ.36) THEN
20475C...f + gamma -> f' + W+/-
20476 FWQ=COMFAC*AEM**2/(2D0*XW)*
20477 & (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH)
20478C...Propagators: as simulated in PYOFSH and as desired
20479 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
20480 CALL PYWIDT(24,SQM4,WDTP,WDTE)
20481 GMMWC=SQRT(SQM4)*WDTP(0)
20482 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
20483 FWQ=FWQ*HBW4C/HBW4
20484 DO 740 I=MMINA,MMAXA
20485 IF(I.EQ.0) GOTO 740
20486 IA=IABS(I)
20487 EIA=ABS(KCHG(IABS(I),1)/3D0)
20488 FACWQ=FWQ*(EIA-SH/(SH+UH))**2
20489 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
20490 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
20491 DO 730 ISDE=1,2
20492 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 730
20493 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 730
20494 NCHN=NCHN+1
20495 ISIG(NCHN,ISDE)=I
20496 ISIG(NCHN,3-ISDE)=22
20497 ISIG(NCHN,3)=1
20498 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
20499 730 CONTINUE
20500 740 CONTINUE
20501
20502 ELSEIF(ISUB.EQ.37) THEN
20503C...f + gamma -> f + h0
20504
20505 ELSEIF(ISUB.EQ.38) THEN
20506C...f + Z0 -> f + g (q + Z0 -> q + g only)
20507
20508 ELSEIF(ISUB.EQ.39) THEN
20509C...f + Z0 -> f + gamma
20510
20511 ELSEIF(ISUB.EQ.40) THEN
20512C...f + Z0 -> f + Z0
20513 ENDIF
20514
20515 ELSEIF(ISUB.LE.50) THEN
20516 IF(ISUB.EQ.41) THEN
20517C...f + Z0 -> f' + W+/-
20518
20519 ELSEIF(ISUB.EQ.42) THEN
20520C...f + Z0 -> f + h0
20521
20522 ELSEIF(ISUB.EQ.43) THEN
20523C...f + W+/- -> f' + g (q + W+/- -> q' + g only)
20524
20525 ELSEIF(ISUB.EQ.44) THEN
20526C...f + W+/- -> f' + gamma
20527
20528 ELSEIF(ISUB.EQ.45) THEN
20529C...f + W+/- -> f' + Z0
20530
20531 ELSEIF(ISUB.EQ.46) THEN
20532C...f + W+/- -> f' + W+/-
20533
20534 ELSEIF(ISUB.EQ.47) THEN
20535C...f + W+/- -> f' + h0
20536
20537 ELSEIF(ISUB.EQ.48) THEN
20538C...f + h0 -> f + g (q + h0 -> q + g only)
20539
20540 ELSEIF(ISUB.EQ.49) THEN
20541C...f + h0 -> f + gamma
20542
20543 ELSEIF(ISUB.EQ.50) THEN
20544C...f + h0 -> f + Z0
20545 ENDIF
20546
20547 ELSEIF(ISUB.LE.60) THEN
20548 IF(ISUB.EQ.51) THEN
20549C...f + h0 -> f' + W+/-
20550
20551 ELSEIF(ISUB.EQ.52) THEN
20552C...f + h0 -> f + h0
20553
20554 ELSEIF(ISUB.EQ.53) THEN
20555C...g + g -> f + fbar (g + g -> q + qbar only)
20556 CALL PYWIDT(21,SH,WDTP,WDTE)
20557 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
20558 & UH2/SH2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
20559 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
20560 & TH2/SH2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
20561 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 750
20562 NCHN=NCHN+1
20563 ISIG(NCHN,1)=21
20564 ISIG(NCHN,2)=21
20565 ISIG(NCHN,3)=1
20566 SIGH(NCHN)=FACQQ1
20567 NCHN=NCHN+1
20568 ISIG(NCHN,1)=21
20569 ISIG(NCHN,2)=21
20570 ISIG(NCHN,3)=2
20571 SIGH(NCHN)=FACQQ2
20572 750 CONTINUE
20573
20574 ELSEIF(ISUB.EQ.54) THEN
20575C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
20576 CALL PYWIDT(21,SH,WDTP,WDTE)
20577 WDTESU=0D0
20578 DO 760 I=1,MIN(8,MDCY(21,3))
20579 EF=KCHG(I,1)/3D0
20580 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
20581 & WDTE(I,4))
20582 760 CONTINUE
20583 FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH)
20584 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
20585 NCHN=NCHN+1
20586 ISIG(NCHN,1)=21
20587 ISIG(NCHN,2)=22
20588 ISIG(NCHN,3)=1
20589 SIGH(NCHN)=FACQQ
20590 ENDIF
20591 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
20592 NCHN=NCHN+1
20593 ISIG(NCHN,1)=22
20594 ISIG(NCHN,2)=21
20595 ISIG(NCHN,3)=1
20596 SIGH(NCHN)=FACQQ
20597 ENDIF
20598
20599 ELSEIF(ISUB.EQ.55) THEN
20600C...g + Z -> f + fbar (g + Z -> q + qbar only)
20601
20602 ELSEIF(ISUB.EQ.56) THEN
20603C...g + W -> f + f'bar (g + W -> q + q'bar only)
20604
20605 ELSEIF(ISUB.EQ.57) THEN
20606C...g + h0 -> f + fbar (g + h0 -> q + qbar only)
20607
20608 ELSEIF(ISUB.EQ.58) THEN
20609C...gamma + gamma -> f + fbar
20610 CALL PYWIDT(22,SH,WDTP,WDTE)
20611 WDTESU=0D0
20612 DO 770 I=1,MIN(12,MDCY(22,3))
20613 IF(I.LE.8) EF= KCHG(I,1)/3D0
20614 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
20615 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
20616 & WDTE(I,4))
20617 770 CONTINUE
20618 FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH)
20619 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
20620 NCHN=NCHN+1
20621 ISIG(NCHN,1)=22
20622 ISIG(NCHN,2)=22
20623 ISIG(NCHN,3)=1
20624 SIGH(NCHN)=FACFF
20625 ENDIF
20626
20627 ELSEIF(ISUB.EQ.59) THEN
20628C...gamma + Z0 -> f + fbar
20629
20630 ELSEIF(ISUB.EQ.60) THEN
20631C...gamma + W+/- -> f + fbar'
20632 ENDIF
20633
20634 ELSEIF(ISUB.LE.70) THEN
20635 IF(ISUB.EQ.61) THEN
20636C...gamma + h0 -> f + fbar
20637
20638 ELSEIF(ISUB.EQ.62) THEN
20639C...Z0 + Z0 -> f + fbar
20640
20641 ELSEIF(ISUB.EQ.63) THEN
20642C...Z0 + W+/- -> f + fbar'
20643
20644 ELSEIF(ISUB.EQ.64) THEN
20645C...Z0 + h0 -> f + fbar
20646
20647 ELSEIF(ISUB.EQ.65) THEN
20648C...W+ + W- -> f + fbar
20649
20650 ELSEIF(ISUB.EQ.66) THEN
20651C...W+/- + h0 -> f + fbar'
20652
20653 ELSEIF(ISUB.EQ.67) THEN
20654C...h0 + h0 -> f + fbar
20655
20656 ELSEIF(ISUB.EQ.68) THEN
20657C...g + g -> g + g
20658 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+2D0*TH/SH+
20659 & TH2/SH2)*FACA
20660 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+2D0*SH/UH+
20661 & SH2/UH2)*FACA
20662 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+2D0*UH/TH+
20663 & UH2/TH2)
20664 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 780
20665 NCHN=NCHN+1
20666 ISIG(NCHN,1)=21
20667 ISIG(NCHN,2)=21
20668 ISIG(NCHN,3)=1
20669 SIGH(NCHN)=0.5D0*FACGG1
20670 NCHN=NCHN+1
20671 ISIG(NCHN,1)=21
20672 ISIG(NCHN,2)=21
20673 ISIG(NCHN,3)=2
20674 SIGH(NCHN)=0.5D0*FACGG2
20675 NCHN=NCHN+1
20676 ISIG(NCHN,1)=21
20677 ISIG(NCHN,2)=21
20678 ISIG(NCHN,3)=3
20679 SIGH(NCHN)=0.5D0*FACGG3
20680 780 CONTINUE
20681
20682 ELSEIF(ISUB.EQ.69) THEN
20683C...gamma + gamma -> W+ + W-
20684 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
20685 FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
20686 FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+
20687 & FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1)
20688 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 790
20689 NCHN=NCHN+1
20690 ISIG(NCHN,1)=22
20691 ISIG(NCHN,2)=22
20692 ISIG(NCHN,3)=1
20693 SIGH(NCHN)=FACWW
20694 790 CONTINUE
20695
20696 ELSEIF(ISUB.EQ.70) THEN
20697C...gamma + W+/- -> Z0 + W+/-
20698 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
20699 FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH))
20700 FACZW=COMFAC*6D0*AEM**2*(XW1/XW)*
20701 & (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+
20702 & FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2)
20703 DO 810 KCHW=1,-1,-2
20704 DO 800 ISDE=1,2
20705 IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 800
20706 NCHN=NCHN+1
20707 ISIG(NCHN,ISDE)=22
20708 ISIG(NCHN,3-ISDE)=24*KCHW
20709 ISIG(NCHN,3)=1
20710 SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2)
20711 800 CONTINUE
20712 810 CONTINUE
20713 ENDIF
20714
20715 ELSEIF(ISUB.LE.80) THEN
20716 IF(ISUB.EQ.71) THEN
20717C...Z0 + Z0 -> Z0 + Z0
20718 IF(SH.LE.4.01D0*SQMZ) GOTO 840
20719
20720 IF(MSTP(46).LE.2) THEN
20721C...Exact scattering ME:s for on-mass-shell gauge bosons
20722 BE2=1D0-4D0*SQMZ/SH
20723 TH=-0.5D0*SH*BE2*(1D0-CTH)
20724 UH=-0.5D0*SH*BE2*(1D0+CTH)
20725 IF(MAX(TH,UH).GT.-1D0) GOTO 840
20726 SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2
20727 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
20728 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
20729 THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2
20730 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
20731 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
20732 UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2
20733 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
20734 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
20735 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
20736 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
20737 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
20738 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+
20739 & (ASHIM+ATHIM+AUHIM)**2)
20740 IF(MSTP(46).EQ.2) FACZZ=0D0
20741
20742 ELSE
20743C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
20744 FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
20745 & ABS(A00U+2.*A20U)**2
20746 ENDIF
20747 FACZZ=FACZZ*WIDS(23,1)
20748
20749 DO 830 I=MMIN1,MMAX1
20750 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 830
20751 EI=KCHG(IABS(I),1)/3D0
20752 AI=SIGN(1D0,EI)
20753 VI=AI-4D0*EI*XWV
20754 AVI=AI**2+VI**2
20755 DO 820 J=MMIN2,MMAX2
20756 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 820
20757 EJ=KCHG(IABS(J),1)/3D0
20758 AJ=SIGN(1D0,EJ)
20759 VJ=AJ-4D0*EJ*XWV
20760 AVJ=AJ**2+VJ**2
20761 NCHN=NCHN+1
20762 ISIG(NCHN,1)=I
20763 ISIG(NCHN,2)=J
20764 ISIG(NCHN,3)=1
20765 SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ
20766 820 CONTINUE
20767 830 CONTINUE
20768 840 CONTINUE
20769
20770 ELSEIF(ISUB.EQ.72) THEN
20771C...Z0 + Z0 -> W+ + W-
20772 IF(SH.LE.4.01D0*SQMZ) GOTO 870
20773
20774 IF(MSTP(46).LE.2) THEN
20775C...Exact scattering ME:s for on-mass-shell gauge bosons
20776 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
20777 CTH2=CTH**2
20778 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
20779 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
20780 IF(MAX(TH,UH).GT.-1D0) GOTO 870
20781 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
20782 & (1D0-2D0*SQMZ/SH)
20783 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
20784 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
20785 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
20786 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
20787 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
20788 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
20789 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
20790 ATWIM=0D0
20791 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
20792 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
20793 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
20794 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
20795 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
20796 AUWIM=0D0
20797 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
20798 A4IM=0D0
20799 FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
20800 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
20801 IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2)
20802 IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+
20803 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
20804 IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+
20805 & (ATWIM+AUWIM+A4IM)**2)
20806
20807 ELSE
20808C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
20809 FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
20810 & ABS(A00U-A20U)**2
20811 ENDIF
20812 FACWW=FACWW*WIDS(24,1)
20813
20814 DO 860 I=MMIN1,MMAX1
20815 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 860
20816 EI=KCHG(IABS(I),1)/3D0
20817 AI=SIGN(1D0,EI)
20818 VI=AI-4D0*EI*XWV
20819 AVI=AI**2+VI**2
20820 DO 850 J=MMIN2,MMAX2
20821 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 850
20822 EJ=KCHG(IABS(J),1)/3D0
20823 AJ=SIGN(1D0,EJ)
20824 VJ=AJ-4D0*EJ*XWV
20825 AVJ=AJ**2+VJ**2
20826 NCHN=NCHN+1
20827 ISIG(NCHN,1)=I
20828 ISIG(NCHN,2)=J
20829 ISIG(NCHN,3)=1
20830 SIGH(NCHN)=FACWW*AVI*AVJ
20831 850 CONTINUE
20832 860 CONTINUE
20833 870 CONTINUE
20834
20835 ELSEIF(ISUB.EQ.73) THEN
20836C...Z0 + W+/- -> Z0 + W+/-
20837 IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 900
20838
20839 IF(MSTP(46).LE.2) THEN
20840C...Exact scattering ME:s for on-mass-shell gauge bosons
20841 BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
20842 EP1=1D0-(SQMZ-SQMW)/SH
20843 EP2=1D0+(SQMZ-SQMW)/SH
20844 TH=-0.5D0*SH*BE2*(1D0-CTH)
20845 UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH)
20846 IF(MAX(TH,UH).GT.-1D0) GOTO 900
20847 THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH)
20848 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
20849 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
20850 ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
20851 & 1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+
20852 & 2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
20853 & 1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
20854 ASWIM=0D0
20855 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
20856 & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
20857 & (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)-
20858 & BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0*
20859 & (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+
20860 & 1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
20861 & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
20862 & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
20863 & (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*
20864 & (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2*
20865 & ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW*
20866 & (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
20867 AUWIM=0D0
20868 A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)-
20869 & 2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2)
20870 A4IM=0D0
20871 FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4*
20872 & (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2
20873 IF(MSTP(46).LE.0) FACZW=0D0
20874 IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+
20875 & (ATHIM+ASWIM+AUWIM+A4IM)**2)
20876 IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+
20877 & (ASWIM+AUWIM+A4IM)**2)
20878
20879 ELSE
20880C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
20881 FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0*
20882 & ABS(A20U+3.*A11U*SNGL(CTH))**2
20883 ENDIF
20884 FACZW=FACZW*WIDS(23,2)
20885
20886 DO 890 I=MMIN1,MMAX1
20887 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 890
20888 EI=KCHG(IABS(I),1)/3D0
20889 AI=SIGN(1D0,EI)
20890 VI=AI-4D0*EI*XWV
20891 AVI=AI**2+VI**2
20892 KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I))
20893 DO 880 J=MMIN2,MMAX2
20894 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 880
20895 EJ=KCHG(IABS(J),1)/3D0
20896 AJ=SIGN(1D0,EJ)
20897 VJ=AI-4D0*EJ*XWV
20898 AVJ=AJ**2+VJ**2
20899 KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J))
20900 NCHN=NCHN+1
20901 ISIG(NCHN,1)=I
20902 ISIG(NCHN,2)=J
20903 ISIG(NCHN,3)=1
20904 SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2)
20905 NCHN=NCHN+1
20906 ISIG(NCHN,1)=I
20907 ISIG(NCHN,2)=J
20908 ISIG(NCHN,3)=2
20909 SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ
20910 880 CONTINUE
20911 890 CONTINUE
20912 900 CONTINUE
20913
20914 ELSEIF(ISUB.EQ.75) THEN
20915C...W+ + W- -> gamma + gamma
20916
20917 ELSEIF(ISUB.EQ.76) THEN
20918C...W+ + W- -> Z0 + Z0
20919 IF(SH.LE.4.01D0*SQMZ) GOTO 930
20920
20921 IF(MSTP(46).LE.2) THEN
20922C...Exact scattering ME:s for on-mass-shell gauge bosons
20923 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
20924 CTH2=CTH**2
20925 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
20926 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
20927 IF(MAX(TH,UH).GT.-1D0) GOTO 930
20928 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
20929 & (1D0-2D0*SQMZ/SH)
20930 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
20931 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
20932 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
20933 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
20934 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
20935 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
20936 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
20937 ATWIM=0D0
20938 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
20939 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
20940 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
20941 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
20942 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
20943 AUWIM=0D0
20944 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
20945 A4IM=0D0
20946 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
20947 & (SH/SQMW)**2*SH2
20948 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
20949 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+
20950 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
20951 IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+
20952 & (ATWIM+AUWIM+A4IM)**2)
20953
20954 ELSE
20955C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
20956 FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
20957 & ABS(A00U-A20U)**2
20958 ENDIF
20959 FACZZ=FACZZ*WIDS(23,1)
20960
20961 DO 920 I=MMIN1,MMAX1
20962 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 920
20963 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
20964 DO 910 J=MMIN2,MMAX2
20965 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 910
20966 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
20967 IF(EI*EJ.GT.0D0) GOTO 910
20968 NCHN=NCHN+1
20969 ISIG(NCHN,1)=I
20970 ISIG(NCHN,2)=J
20971 ISIG(NCHN,3)=1
20972 SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J)
20973 910 CONTINUE
20974 920 CONTINUE
20975 930 CONTINUE
20976
20977 ELSEIF(ISUB.EQ.77) THEN
20978C...W+/- + W+/- -> W+/- + W+/-
20979 IF(SH.LE.4.01D0*SQMW) GOTO 960
20980
20981 IF(MSTP(46).LE.2) THEN
20982C...Exact scattering ME:s for on-mass-shell gauge bosons
20983 BE2=1D0-4D0*SQMW/SH
20984 BE4=BE2**2
20985 CTH2=CTH**2
20986 CTH3=CTH**3
20987 TH=-0.5D0*SH*BE2*(1D0-CTH)
20988 UH=-0.5D0*SH*BE2*(1D0+CTH)
20989 IF(MAX(TH,UH).GT.-1D0) GOTO 960
20990 SHANG=(1D0+BE2)**2
20991 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
20992 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
20993 THANG=(BE2-CTH)**2
20994 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
20995 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
20996 UHANG=(BE2+CTH)**2
20997 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
20998 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
20999 SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH
21000 ASGRE=XW*SGZANG
21001 ASGIM=0D0
21002 ASZRE=XW1*SH/(SH-SQMZ)*SGZANG
21003 ASZIM=0D0
21004 TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+
21005 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3)
21006 ATGRE=0.5D0*XW*SH/TH*TGZANG
21007 ATGIM=0D0
21008 ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG
21009 ATZIM=0D0
21010 UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+
21011 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3)
21012 AUGRE=0.5D0*XW*SH/UH*UGZANG
21013 AUGIM=0D0
21014 AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG
21015 AUZIM=0D0
21016 A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2)
21017 A4AIM=0D0
21018 A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2)
21019 A4SIM=0D0
21020 FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
21021 & (SH/SQMW)**2*SH2
21022 IF(MSTP(46).LE.0) THEN
21023 AWWARE=ASHRE
21024 AWWAIM=ASHIM
21025 AWWSRE=0D0
21026 AWWSIM=0D0
21027 ELSEIF(MSTP(46).EQ.1) THEN
21028 AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
21029 AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
21030 AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
21031 AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
21032 ELSE
21033 AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
21034 AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
21035 AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
21036 AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
21037 ENDIF
21038 AWWA2=AWWARE**2+AWWAIM**2
21039 AWWS2=AWWSRE**2+AWWSIM**2
21040
21041 ELSE
21042C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
21043 FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
21044 & ABS(A00U+0.5*A20U+4.5*A11U*SNGL(CTH))**2
21045 FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2
21046 ENDIF
21047
21048 DO 950 I=MMIN1,MMAX1
21049 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 950
21050 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
21051 DO 940 J=MMIN2,MMAX2
21052 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 940
21053 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
21054 IF(EI*EJ.LT.0D0) THEN
21055C...W+W-
21056 IF(MSTP(45).EQ.1) GOTO 940
21057 IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1)
21058 IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1)
21059 ELSE
21060C...W+W+/W-W-
21061 IF(MSTP(45).EQ.2) GOTO 940
21062 IF(MSTP(46).LE.2) FACWW=FWW*AWWS2
21063 IF(MSTP(46).GE.3) FACWW=FWWS
21064 IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4)
21065 IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5)
21066 ENDIF
21067 NCHN=NCHN+1
21068 ISIG(NCHN,1)=I
21069 ISIG(NCHN,2)=J
21070 ISIG(NCHN,3)=1
21071 SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J)
21072 IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN)
21073 940 CONTINUE
21074 950 CONTINUE
21075 960 CONTINUE
21076
21077 ELSEIF(ISUB.EQ.78) THEN
21078C...W+/- + h0 -> W+/- + h0
21079
21080 ELSEIF(ISUB.EQ.79) THEN
21081C...h0 + h0 -> h0 + h0
21082
21083 ELSEIF(ISUB.EQ.80) THEN
21084C...q + gamma -> q' + pi+/-
21085 FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2)
21086 ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
21087 Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
21088 DELSH=UH*SQRT(ASSH*Q2FPSH)
21089 ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
21090 Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
21091 DELUH=SH*SQRT(ASUH*Q2FPUH)
21092 DO 980 I=MAX(-2,MMINA),MIN(2,MMAXA)
21093 IF(I.EQ.0) GOTO 980
21094 EI=KCHG(IABS(I),1)/3D0
21095 EJ=SIGN(1D0-ABS(EI),EI)
21096 DO 970 ISDE=1,2
21097 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 970
21098 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 970
21099 NCHN=NCHN+1
21100 ISIG(NCHN,ISDE)=I
21101 ISIG(NCHN,3-ISDE)=22
21102 ISIG(NCHN,3)=1
21103 SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2
21104 970 CONTINUE
21105 980 CONTINUE
21106
21107 ENDIF
21108
21109C...C: 2 -> 2, tree diagrams with masses
21110
21111 ELSEIF(ISUB.LE.90) THEN
21112 IF(ISUB.EQ.81) THEN
21113C...q + qbar -> Q + Qbar
21114 SQMA=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
21115 FACQQB=COMFAC*AS**2*4D0/9D0*(((TH-SQMA)**2+
21116 & (UH-SQMA)**2)/SH2+2D0*SQMA/SH)
21117 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMA,0D0)
21118 WID2=1D0
21119 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
21120 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
21121 FACQQB=FACQQB*WID2
21122 DO 990 I=MMINA,MMAXA
21123 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
21124 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 990
21125 NCHN=NCHN+1
21126 ISIG(NCHN,1)=I
21127 ISIG(NCHN,2)=-I
21128 ISIG(NCHN,3)=1
21129 SIGH(NCHN)=FACQQB
21130 990 CONTINUE
21131
21132 ELSEIF(ISUB.EQ.82) THEN
21133C...g + g -> Q + Qbar
21134 SQMA=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
21135 IF(MSTP(34).EQ.0) THEN
21136 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*((UH-SQMA)/(TH-SQMA)-
21137 & 2D0*(UH-SQMA)**2/SH2+4D0*(SQMA/SH)*(TH*UH-SQMA**2)/
21138 & (TH-SQMA)**2)
21139 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*((TH-SQMA)/(UH-SQMA)-
21140 & 2D0*(TH-SQMA)**2/SH2+4D0*(SQMA/SH)*(TH*UH-SQMA**2)/
21141 & (UH-SQMA)**2)
21142 ELSE
21143 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*((UH-SQMA)/(TH-SQMA)-
21144 & 2.25D0*(UH-SQMA)**2/SH2+4.5D0*(SQMA/SH)*(TH*UH-SQMA**2)/
21145 & (TH-SQMA)**2+0.5D0*SQMA*TH/(TH-SQMA)**2-SQMA**2/
21146 & (SH*(TH-SQMA)))
21147 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*((TH-SQMA)/(UH-SQMA)-
21148 & 2.25D0*(TH-SQMA)**2/SH2+4.5D0*(SQMA/SH)*(TH*UH-SQMA**2)/
21149 & (UH-SQMA)**2+0.5D0*SQMA*UH/(UH-SQMA)**2-SQMA**2/
21150 & (SH*(UH-SQMA)))
21151 ENDIF
21152 IF(MSTP(35).GE.1) THEN
21153 FATRE=PYHFTH(SH,SQMA,2D0/7D0)
21154 FACQQ1=FACQQ1*FATRE
21155 FACQQ2=FACQQ2*FATRE
21156 ENDIF
21157 WID2=1D0
21158 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
21159 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
21160 FACQQ1=FACQQ1*WID2
21161 FACQQ2=FACQQ2*WID2
21162 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1000
21163 NCHN=NCHN+1
21164 ISIG(NCHN,1)=21
21165 ISIG(NCHN,2)=21
21166 ISIG(NCHN,3)=1
21167 SIGH(NCHN)=FACQQ1
21168 NCHN=NCHN+1
21169 ISIG(NCHN,1)=21
21170 ISIG(NCHN,2)=21
21171 ISIG(NCHN,3)=2
21172 SIGH(NCHN)=FACQQ2
21173 1000 CONTINUE
21174
21175 ELSEIF(ISUB.EQ.83) THEN
21176C...f + q -> f' + Q
21177 FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2
21178 FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2
21179 DO 1020 I=MMIN1,MMAX1
21180 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1020
21181 DO 1010 J=MMIN2,MMAX2
21182 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1010
21183 IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 1010
21184 IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 1010
21185 IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1)
21186 & THEN
21187 NCHN=NCHN+1
21188 ISIG(NCHN,1)=I
21189 ISIG(NCHN,2)=J
21190 ISIG(NCHN,3)=1
21191 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
21192 & (IABS(I)+1)/2)*VINT(180+J)
21193 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2,
21194 & (MINT(55)+1)/2)*VINT(180+J)
21195 WID2=1D0
21196 IF(I.GT.0) THEN
21197 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
21198 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
21199 & WIDS(MINT(55),2)
21200 ELSE
21201 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
21202 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
21203 & WIDS(MINT(55),3)
21204 ENDIF
21205 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
21206 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
21207 ENDIF
21208 IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1)
21209 & THEN
21210 NCHN=NCHN+1
21211 ISIG(NCHN,1)=I
21212 ISIG(NCHN,2)=J
21213 ISIG(NCHN,3)=2
21214 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
21215 & (IABS(J)+1)/2)*VINT(180+I)
21216 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2,
21217 & (MINT(55)+1)/2)*VINT(180+I)
21218 IF(J.GT.0) THEN
21219 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
21220 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
21221 & WIDS(MINT(55),2)
21222 ELSE
21223 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
21224 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
21225 & WIDS(MINT(55),3)
21226 ENDIF
21227 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
21228 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
21229 ENDIF
21230 1010 CONTINUE
21231 1020 CONTINUE
21232
21233 ELSEIF(ISUB.EQ.84) THEN
21234C...g + gamma -> Q + Qbar
21235 SQMA=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
21236 FMTU=SQMA/(SQMA-TH)+SQMA/(SQMA-UH)
21237 FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
21238 & ((SQMA-TH)/(SQMA-UH)+(SQMA-UH)/(SQMA-TH)+4D0*FMTU*(1D0-FMTU))
21239 IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQMA,0D0)
21240 WID2=1D0
21241 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
21242 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
21243 FACQQ=FACQQ*WID2
21244 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
21245 NCHN=NCHN+1
21246 ISIG(NCHN,1)=21
21247 ISIG(NCHN,2)=22
21248 ISIG(NCHN,3)=1
21249 SIGH(NCHN)=FACQQ
21250 ENDIF
21251 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
21252 NCHN=NCHN+1
21253 ISIG(NCHN,1)=22
21254 ISIG(NCHN,2)=21
21255 ISIG(NCHN,3)=1
21256 SIGH(NCHN)=FACQQ
21257 ENDIF
21258
21259 ELSEIF(ISUB.EQ.85) THEN
21260C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
21261 SQMA=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
21262 FMTU=SQMA/(SQMA-TH)+SQMA/(SQMA-UH)
21263 FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
21264 & ((SQMA-TH)/(SQMA-UH)+(SQMA-UH)/(SQMA-TH)+4D0*FMTU*(1D0-FMTU))
21265 IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF
21266 IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1)
21267 & FACFF=FACFF*PYHFTH(SH,SQMA,1D0)
21268 WID2=1D0
21269 IF(MINT(56).EQ.6) WID2=WIDS(6,1)
21270 IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1)
21271 IF(MINT(56).EQ.17) WID2=WIDS(17,1)
21272 FACFF=FACFF*WID2
21273 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
21274 NCHN=NCHN+1
21275 ISIG(NCHN,1)=22
21276 ISIG(NCHN,2)=22
21277 ISIG(NCHN,3)=1
21278 SIGH(NCHN)=FACFF
21279 ENDIF
21280
21281 ELSEIF(ISUB.EQ.86) THEN
21282C...g + g -> J/Psi + g
21283 FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)*
21284 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
21285 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
21286 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
21287 NCHN=NCHN+1
21288 ISIG(NCHN,1)=21
21289 ISIG(NCHN,2)=21
21290 ISIG(NCHN,3)=1
21291 SIGH(NCHN)=FACQQG
21292 ENDIF
21293
21294 ELSEIF(ISUB.EQ.87) THEN
21295C...g + g -> chi_0c + g
21296 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
21297 QGTW=(SH*TH*UH)/SH**3
21298 RGTW=SQM3/SH
21299 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
21300 & (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
21301 & 6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)-
21302 & PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+
21303 & 2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/
21304 & (QGTW*(QGTW-RGTW*PGTW)**4)
21305 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
21306 NCHN=NCHN+1
21307 ISIG(NCHN,1)=21
21308 ISIG(NCHN,2)=21
21309 ISIG(NCHN,3)=1
21310 SIGH(NCHN)=FACQQG
21311 ENDIF
21312
21313 ELSEIF(ISUB.EQ.88) THEN
21314C...g + g -> chi_1c + g
21315 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
21316 QGTW=(SH*TH*UH)/SH**3
21317 RGTW=SQM3/SH
21318 FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
21319 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+
21320 & 5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/
21321 & (QGTW-RGTW*PGTW)**4
21322 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
21323 NCHN=NCHN+1
21324 ISIG(NCHN,1)=21
21325 ISIG(NCHN,2)=21
21326 ISIG(NCHN,3)=1
21327 SIGH(NCHN)=FACQQG
21328 ENDIF
21329
21330 ELSEIF(ISUB.EQ.89) THEN
21331C...g + g -> chi_2c + g
21332 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
21333 QGTW=(SH*TH*UH)/SH**3
21334 RGTW=SQM3/SH
21335 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
21336 & (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
21337 & 3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+
21338 & 2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+
21339 & RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2*
21340 & QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
21341 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
21342 NCHN=NCHN+1
21343 ISIG(NCHN,1)=21
21344 ISIG(NCHN,2)=21
21345 ISIG(NCHN,3)=1
21346 SIGH(NCHN)=FACQQG
21347 ENDIF
21348 ENDIF
21349
21350C...D: Mimimum bias processes
21351
21352 ELSEIF(ISUB.LE.100) THEN
21353 IF(ISUB.EQ.91) THEN
21354C...Elastic scattering
21355 SIGS=VINT(315)*VINT(316)*SIGT(0,0,1)
21356
21357 ELSEIF(ISUB.EQ.92) THEN
21358C...Single diffractive scattering (first side, i.e. XB)
21359 SIGS=VINT(315)*VINT(316)*SIGT(0,0,2)
21360
21361 ELSEIF(ISUB.EQ.93) THEN
21362C...Single diffractive scattering (second side, i.e. AX)
21363 SIGS=VINT(315)*VINT(316)*SIGT(0,0,3)
21364
21365 ELSEIF(ISUB.EQ.94) THEN
21366C...Double diffractive scattering
21367 SIGS=VINT(315)*VINT(316)*SIGT(0,0,4)
21368
21369 ELSEIF(ISUB.EQ.95) THEN
21370C...Low-pT scattering
21371 SIGS=VINT(315)*VINT(316)*SIGT(0,0,5)
21372
21373 ELSEIF(ISUB.EQ.96) THEN
21374C...Multiple interactions: sum of QCD processes
21375 CALL PYWIDT(21,SH,WDTP,WDTE)
21376
21377C...q + q' -> q + q'
21378 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
21379 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
21380 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
21381 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)/UH2
21382 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
21383 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
21384 DO 1040 I=-5,5
21385 IF(I.EQ.0) GOTO 1040
21386 DO 1030 J=-5,5
21387 IF(J.EQ.0) GOTO 1030
21388 NCHN=NCHN+1
21389 ISIG(NCHN,1)=I
21390 ISIG(NCHN,2)=J
21391 ISIG(NCHN,3)=111
21392 SIGH(NCHN)=FACQQ1
21393 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
21394 IF(I.EQ.J) THEN
21395 SIGH(NCHN)=0.5D0*FACQQ1*RATQQI
21396 NCHN=NCHN+1
21397 ISIG(NCHN,1)=I
21398 ISIG(NCHN,2)=J
21399 ISIG(NCHN,3)=112
21400 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
21401 ENDIF
21402 1030 CONTINUE
21403 1040 CONTINUE
21404
21405C...q + qbar -> q' + qbar' or g + g
21406 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
21407 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
21408 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
21409 & UH2/SH2)
21410 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
21411 & TH2/SH2)
21412 DO 1050 I=-5,5
21413 IF(I.EQ.0) GOTO 1050
21414 NCHN=NCHN+1
21415 ISIG(NCHN,1)=I
21416 ISIG(NCHN,2)=-I
21417 ISIG(NCHN,3)=121
21418 SIGH(NCHN)=FACQQB
21419 NCHN=NCHN+1
21420 ISIG(NCHN,1)=I
21421 ISIG(NCHN,2)=-I
21422 ISIG(NCHN,3)=131
21423 SIGH(NCHN)=0.5D0*FACGG1
21424 NCHN=NCHN+1
21425 ISIG(NCHN,1)=I
21426 ISIG(NCHN,2)=-I
21427 ISIG(NCHN,3)=132
21428 SIGH(NCHN)=0.5D0*FACGG2
21429 1050 CONTINUE
21430
21431C...q + g -> q + g
21432 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
21433 & UH/SH)*FACA
21434 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
21435 & SH/UH)
21436 DO 1070 I=-5,5
21437 IF(I.EQ.0) GOTO 1070
21438 DO 1060 ISDE=1,2
21439 NCHN=NCHN+1
21440 ISIG(NCHN,ISDE)=I
21441 ISIG(NCHN,3-ISDE)=21
21442 ISIG(NCHN,3)=281
21443 SIGH(NCHN)=FACQG1
21444 NCHN=NCHN+1
21445 ISIG(NCHN,ISDE)=I
21446 ISIG(NCHN,3-ISDE)=21
21447 ISIG(NCHN,3)=282
21448 SIGH(NCHN)=FACQG2
21449 1060 CONTINUE
21450 1070 CONTINUE
21451
21452C...g + g -> q + qbar or g + g
21453 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
21454 & UH2/SH2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
21455 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
21456 & TH2/SH2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
21457 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
21458 & 2D0*TH/SH+TH2/SH2)*FACA
21459 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
21460 & 2D0*SH/UH+SH2/UH2)*FACA
21461 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+
21462 & 2D0*UH/TH+UH2/TH2)
21463 NCHN=NCHN+1
21464 ISIG(NCHN,1)=21
21465 ISIG(NCHN,2)=21
21466 ISIG(NCHN,3)=531
21467 SIGH(NCHN)=FACQQ1
21468 NCHN=NCHN+1
21469 ISIG(NCHN,1)=21
21470 ISIG(NCHN,2)=21
21471 ISIG(NCHN,3)=532
21472 SIGH(NCHN)=FACQQ2
21473 NCHN=NCHN+1
21474 ISIG(NCHN,1)=21
21475 ISIG(NCHN,2)=21
21476 ISIG(NCHN,3)=681
21477 SIGH(NCHN)=0.5D0*FACGG1
21478 NCHN=NCHN+1
21479 ISIG(NCHN,1)=21
21480 ISIG(NCHN,2)=21
21481 ISIG(NCHN,3)=682
21482 SIGH(NCHN)=0.5D0*FACGG2
21483 NCHN=NCHN+1
21484 ISIG(NCHN,1)=21
21485 ISIG(NCHN,2)=21
21486 ISIG(NCHN,3)=683
21487 SIGH(NCHN)=0.5D0*FACGG3
21488
21489 ELSEIF(ISUB.EQ.99) THEN
21490C...f + gamma* -> f.
21491 IF(MINT(107).EQ.4) THEN
21492 Q2GA=VINT(307)
21493 P2GA=VINT(308)
21494 ISDE=2
21495 ELSE
21496 Q2GA=VINT(308)
21497 P2GA=VINT(307)
21498 ISDE=1
21499 ENDIF
21500 COMFAC=PARU(5)*4D0*PARU(1)**2*PARU(101)
21501 PM2RHO=PMAS(PYCOMP(113),1)**2
21502 IF(MSTP(19).EQ.0) THEN
21503 COMFAC=COMFAC/Q2GA
21504 ELSEIF(MSTP(19).EQ.1) THEN
21505 COMFAC=COMFAC/(Q2GA+PM2RHO)
21506 ELSEIF(MSTP(19).EQ.2) THEN
21507 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
21508 ELSE
21509 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
21510 W2GA=VINT(2)
21511 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
21512 RDRDS=4.1D-3*W2GA**2.167D0/((Q2GA+0.15D0*W2GA)**2*
21513 & Q2GA**0.75D0)*(1D0+0.11D0*Q2GA*P2GA/(1D0+0.02D0*P2GA**2))
21514 XGA=Q2GA/(W2GA+VINT(307)+VINT(308))
21515 ELSE
21516 RDRDS=1.5D-4*W2GA**2.167D0/((Q2GA+0.041D0*W2GA)**2*
21517 & Q2GA**0.57D0)
21518 XGA=Q2GA/(W2GA+Q2GA-PMAS(PYCOMP(MINT(10+ISDE)),1)**2)
21519 ENDIF
21520 COMFAC=COMFAC*EXP(-MAX(1D-10,RDRDS))
21521 IF(MSTP(19).EQ.4) COMFAC=COMFAC/MAX(1D-2,1D0-XGA)
21522 ENDIF
21523 DO 1075 I=MMINA,MMAXA
21524 IF(I.EQ.0.OR.KFAC(ISDE,I).EQ.0) GOTO 1075
21525 IF(IABS(I).LT.10.AND.IABS(I).GT.MSTP(58)) GOTO 1075
21526 EI=KCHG(IABS(I),1)/3D0
21527 NCHN=NCHN+1
21528 ISIG(NCHN,ISDE)=I
21529 ISIG(NCHN,3-ISDE)=22
21530 ISIG(NCHN,3)=1
21531 SIGH(NCHN)=COMFAC*EI**2
21532 1075 CONTINUE
21533 ENDIF
21534
21535C...E: 2 -> 1, loop diagrams
21536
21537 ELSEIF(ISUB.LE.110) THEN
21538 IF(ISUB.EQ.101) THEN
21539C...g + g -> gamma*/Z0
21540
21541 ELSEIF(ISUB.EQ.102) THEN
21542C...g + g -> h0 (or H0, or A0)
21543 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
21544 HS=SHR*WDTP(0)
21545 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
21546 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
21547 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
21548 & FACBW=0D0
21549 HI=SHR*WDTP(13)/32D0
21550 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1080
21551 NCHN=NCHN+1
21552 ISIG(NCHN,1)=21
21553 ISIG(NCHN,2)=21
21554 ISIG(NCHN,3)=1
21555 SIGH(NCHN)=HI*FACBW*HF
21556 1080 CONTINUE
21557
21558 ELSEIF(ISUB.EQ.103) THEN
21559C...gamma + gamma -> h0 (or H0, or A0)
21560 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
21561 HS=SHR*WDTP(0)
21562 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
21563 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
21564 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
21565 & FACBW=0D0
21566 HI=SHR*WDTP(14)*2D0
21567 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 1090
21568 NCHN=NCHN+1
21569 ISIG(NCHN,1)=22
21570 ISIG(NCHN,2)=22
21571 ISIG(NCHN,3)=1
21572 SIGH(NCHN)=HI*FACBW*HF
21573 1090 CONTINUE
21574
21575 ELSEIF(ISUB.EQ.104) THEN
21576C...g + g -> chi_c0.
21577 KC=PYCOMP(10441)
21578 FACBW=COMFAC*12D0*AS**2*PARP(39)*PMAS(KC,2)/
21579 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
21580 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
21581 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
21582 NCHN=NCHN+1
21583 ISIG(NCHN,1)=21
21584 ISIG(NCHN,2)=21
21585 ISIG(NCHN,3)=1
21586 SIGH(NCHN)=FACBW
21587 ENDIF
21588
21589 ELSEIF(ISUB.EQ.105) THEN
21590C...g + g -> chi_c2.
21591 KC=PYCOMP(445)
21592 FACBW=COMFAC*16D0*AS**2*PARP(39)*PMAS(KC,2)/
21593 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
21594 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
21595 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
21596 NCHN=NCHN+1
21597 ISIG(NCHN,1)=21
21598 ISIG(NCHN,2)=21
21599 ISIG(NCHN,3)=1
21600 SIGH(NCHN)=FACBW
21601 ENDIF
21602
21603C...Continuation C: 2 -> 2, tree diagrams with masses.
21604
21605 ELSEIF(ISUB.EQ.106) THEN
21606C...g + g -> J/Psi + gamma.
21607 EQ=2D0/3D0
21608 FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)*
21609 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
21610 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
21611 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
21612 NCHN=NCHN+1
21613 ISIG(NCHN,1)=21
21614 ISIG(NCHN,2)=21
21615 ISIG(NCHN,3)=1
21616 SIGH(NCHN)=FACQQG
21617 ENDIF
21618
21619 ELSEIF(ISUB.EQ.107) THEN
21620C...g + gamma -> J/Psi + g.
21621 EQ=2D0/3D0
21622 FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)*
21623 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
21624 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
21625 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
21626 NCHN=NCHN+1
21627 ISIG(NCHN,1)=21
21628 ISIG(NCHN,2)=22
21629 ISIG(NCHN,3)=1
21630 SIGH(NCHN)=FACQQG
21631 ENDIF
21632 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
21633 NCHN=NCHN+1
21634 ISIG(NCHN,1)=22
21635 ISIG(NCHN,2)=21
21636 ISIG(NCHN,3)=1
21637 SIGH(NCHN)=FACQQG
21638 ENDIF
21639
21640 ELSEIF(ISUB.EQ.108) THEN
21641C...gamma + gamma -> J/Psi + gamma.
21642 EQ=2D0/3D0
21643 FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)*
21644 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
21645 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
21646 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
21647 NCHN=NCHN+1
21648 ISIG(NCHN,1)=22
21649 ISIG(NCHN,2)=22
21650 ISIG(NCHN,3)=1
21651 SIGH(NCHN)=FACQQG
21652 ENDIF
21653
21654C...F: 2 -> 2, box diagrams
21655
21656 ELSEIF(ISUB.EQ.110) THEN
21657C...f + fbar -> gamma + h0
21658 THUH=MAX(TH*UH,SH*CKIN(3)**2)
21659 FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH
21660 FACHG=FACHG*WIDS(KFHIGG,2)
21661C...Calculate loop contributions for intermediate gamma* and Z0
21662 CIGTOT=CMPLX(0.,0.)
21663 CIZTOT=CMPLX(0.,0.)
21664 JMAX=3*MSTP(1)+1
21665 DO 1100 J=1,JMAX
21666 IF(J.LE.2*MSTP(1)) THEN
21667 FNC=1D0
21668 EJ=KCHG(J,1)/3D0
21669 AJ=SIGN(1D0,EJ+0.1D0)
21670 VJ=AJ-4D0*EJ*XWV
21671 BALP=SQM4/(2D0*PMAS(J,1))**2
21672 BBET=SH/(2D0*PMAS(J,1))**2
21673 ELSEIF(J.LE.3*MSTP(1)) THEN
21674 FNC=3D0
21675 JL=2*(J-2*MSTP(1))-1
21676 EJ=KCHG(10+JL,1)/3D0
21677 AJ=SIGN(1D0,EJ+0.1D0)
21678 VJ=AJ-4D0*EJ*XWV
21679 BALP=SQM4/(2D0*PMAS(10+JL,1))**2
21680 BBET=SH/(2D0*PMAS(10+JL,1))**2
21681 ELSE
21682 BALP=SQM4/(2D0*PMAS(24,1))**2
21683 BBET=SH/(2D0*PMAS(24,1))**2
21684 ENDIF
21685 BABI=1D0/(BALP-BBET)
21686 IF(BALP.LT.1D0) THEN
21687 F0ALP=CMPLX(SNGL(ASIN(SQRT(BALP))),0.)
21688 F1ALP=F0ALP**2
21689 ELSE
21690 F0ALP=CMPLX(SNGL(LOG(SQRT(BALP)+SQRT(BALP-1D0))),
21691 & -SNGL(0.5D0*PARU(1)))
21692 F1ALP=-F0ALP**2
21693 ENDIF
21694 F2ALP=SNGL(SQRT(ABS(BALP-1D0)/BALP))*F0ALP
21695 IF(BBET.LT.1D0) THEN
21696 F0BET=CMPLX(SNGL(ASIN(SQRT(BBET))),0.)
21697 F1BET=F0BET**2
21698 ELSE
21699 F0BET=CMPLX(SNGL(LOG(SQRT(BBET)+SQRT(BBET-1D0))),
21700 & -SNGL(0.5D0*PARU(1)))
21701 F1BET=-F0BET**2
21702 ENDIF
21703 F2BET=SNGL(SQRT(ABS(BBET-1D0)/BBET))*F0BET
21704 IF(J.LE.3*MSTP(1)) THEN
21705 FIF=SNGL(0.5D0*BABI)+SNGL(BABI**2)*(SNGL(0.5D0*(1D0-BALP+
21706 & BBET))*(F1BET-F1ALP)+SNGL(BBET)*(F2BET-F2ALP))
21707 CIGTOT=CIGTOT+SNGL(FNC*EJ**2)*FIF
21708 CIZTOT=CIZTOT+SNGL(FNC*EJ*VJ)*FIF
21709 ELSE
21710 TXW=XW/XW1
21711 CIGTOT=CIGTOT-0.5*(SNGL(BABI*(1.5D0+BALP))+SNGL(BABI**2)*
21712 & (SNGL(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+
21713 & SNGL(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP)))
21714 CIZTOT=CIZTOT-SNGL(0.5D0*BABI*XW1)*(SNGL(5D0-TXW+2D0*BALP*
21715 & (1D0-TXW))*(1.+SNGL(2D0*BABI*BBET)*(F2BET-F2ALP))+
21716 & SNGL(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))*
21717 & (F1BET-F1ALP))
21718 ENDIF
21719 1100 CONTINUE
21720 CIGTOT=CIGTOT/SNGL(SH)
21721 CIZTOT=CIZTOT*SNGL(XWC)/CMPLX(SNGL(SH-SQMZ),SNGL(GMMZ))
21722C...Loop over initial flavours
21723 DO 1110 I=MMINA,MMAXA
21724 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1110
21725 EI=KCHG(IABS(I),1)/3D0
21726 AI=SIGN(1D0,EI)
21727 VI=AI-4D0*EI*XWV
21728 FCOI=1D0
21729 IF(IABS(I).LE.10) FCOI=FACA/3D0
21730 NCHN=NCHN+1
21731 ISIG(NCHN,1)=I
21732 ISIG(NCHN,2)=-I
21733 ISIG(NCHN,3)=1
21734 SIGH(NCHN)=FACHG*FCOI*(ABS(SNGL(EI)*CIGTOT+SNGL(VI)*
21735 & CIZTOT)**2+AI**2*ABS(CIZTOT)**2)
21736 1110 CONTINUE
21737
21738 ENDIF
21739
21740 ELSEIF(ISUB.LE.120) THEN
21741 IF(ISUB.EQ.111) THEN
21742C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
21743 A5STUR=0D0
21744 A5STUI=0D0
21745 DO 1120 I=1,2*MSTP(1)
21746 SQMQ=PMAS(I,1)**2
21747 EPSS=4D0*SQMQ/SH
21748 EPSH=4D0*SQMQ/SQMH
21749 CALL PYWAUX(1,EPSS,W1SR,W1SI)
21750 CALL PYWAUX(1,EPSH,W1HR,W1HI)
21751 CALL PYWAUX(2,EPSS,W2SR,W2SI)
21752 CALL PYWAUX(2,EPSH,W2HR,W2HI)
21753 A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+
21754 & (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR))
21755 A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+
21756 & (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI))
21757 1120 CONTINUE
21758 FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
21759 & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
21760 FACGH=FACGH*WIDS(25,2)
21761 DO 1130 I=MMINA,MMAXA
21762 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
21763 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1130
21764 NCHN=NCHN+1
21765 ISIG(NCHN,1)=I
21766 ISIG(NCHN,2)=-I
21767 ISIG(NCHN,3)=1
21768 SIGH(NCHN)=FACGH
21769 1130 CONTINUE
21770
21771 ELSEIF(ISUB.EQ.112) THEN
21772C...f + g -> f + h0 (q + g -> q + h0 only)
21773 A5TSUR=0D0
21774 A5TSUI=0D0
21775 DO 1140 I=1,2*MSTP(1)
21776 SQMQ=PMAS(I,1)**2
21777 EPST=4D0*SQMQ/TH
21778 EPSH=4D0*SQMQ/SQMH
21779 CALL PYWAUX(1,EPST,W1TR,W1TI)
21780 CALL PYWAUX(1,EPSH,W1HR,W1HI)
21781 CALL PYWAUX(2,EPST,W2TR,W2TI)
21782 CALL PYWAUX(2,EPSH,W2HR,W2HI)
21783 A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+
21784 & (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR))
21785 A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+
21786 & (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI))
21787 1140 CONTINUE
21788 FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
21789 & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
21790 FACQH=FACQH*WIDS(25,2)
21791 DO 1160 I=MMINA,MMAXA
21792 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1160
21793 DO 1150 ISDE=1,2
21794 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1150
21795 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1150
21796 NCHN=NCHN+1
21797 ISIG(NCHN,ISDE)=I
21798 ISIG(NCHN,3-ISDE)=21
21799 ISIG(NCHN,3)=1
21800 SIGH(NCHN)=FACQH
21801 1150 CONTINUE
21802 1160 CONTINUE
21803
21804 ELSEIF(ISUB.EQ.113) THEN
21805C...g + g -> g + h0
21806 A2STUR=0D0
21807 A2STUI=0D0
21808 A2USTR=0D0
21809 A2USTI=0D0
21810 A2TUSR=0D0
21811 A2TUSI=0D0
21812 A4STUR=0D0
21813 A4STUI=0D0
21814 DO 1170 I=1,2*MSTP(1)
21815 SQMQ=PMAS(I,1)**2
21816 EPSS=4D0*SQMQ/SH
21817 EPST=4D0*SQMQ/TH
21818 EPSU=4D0*SQMQ/UH
21819 EPSH=4D0*SQMQ/SQMH
21820 IF(EPSH.LT.1D-6) GOTO 1170
21821 CALL PYWAUX(1,EPSS,W1SR,W1SI)
21822 CALL PYWAUX(1,EPST,W1TR,W1TI)
21823 CALL PYWAUX(1,EPSU,W1UR,W1UI)
21824 CALL PYWAUX(1,EPSH,W1HR,W1HI)
21825 CALL PYWAUX(2,EPSS,W2SR,W2SI)
21826 CALL PYWAUX(2,EPST,W2TR,W2TI)
21827 CALL PYWAUX(2,EPSU,W2UR,W2UI)
21828 CALL PYWAUX(2,EPSH,W2HR,W2HI)
21829 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
21830 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
21831 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
21832 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
21833 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
21834 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
21835 CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI)
21836 CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI)
21837 CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI)
21838 CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI)
21839 CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI)
21840 CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI)
21841 W3STUR=YHSTUR-Y3STUR-Y3UTSR
21842 W3STUI=YHSTUI-Y3STUI-Y3UTSI
21843 W3SUTR=YHSUTR-Y3SUTR-Y3TUSR
21844 W3SUTI=YHSUTI-Y3SUTI-Y3TUSI
21845 W3TSUR=YHTSUR-Y3TSUR-Y3USTR
21846 W3TSUI=YHTSUI-Y3TSUI-Y3USTI
21847 W3TUSR=YHTUSR-Y3TUSR-Y3SUTR
21848 W3TUSI=YHTUSI-Y3TUSI-Y3SUTI
21849 W3USTR=YHUSTR-Y3USTR-Y3TSUR
21850 W3USTI=YHUSTI-Y3USTI-Y3TSUI
21851 W3UTSR=YHUTSR-Y3UTSR-Y3STUR
21852 W3UTSI=YHUTSI-Y3UTSI-Y3STUI
21853 B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH*
21854 & (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)*
21855 & (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/
21856 & (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH*
21857 & (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR)
21858 B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2*
21859 & (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+
21860 & W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))*
21861 & (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0*
21862 & (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI)
21863 B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH*
21864 & (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)*
21865 & (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/
21866 & (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH*
21867 & (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR)
21868 B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2*
21869 & (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+
21870 & W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))*
21871 & (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0*
21872 & (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI)
21873 B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH*
21874 & (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)*
21875 & (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/
21876 & (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH*
21877 & (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR)
21878 B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2*
21879 & (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+
21880 & W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))*
21881 & (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0*
21882 & (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI)
21883 B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH*
21884 & (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)*
21885 & (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/
21886 & (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH*
21887 & (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR)
21888 B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2*
21889 & (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+
21890 & W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))*
21891 & (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0*
21892 & (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI)
21893 B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH*
21894 & (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)*
21895 & (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/
21896 & (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH*
21897 & (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR)
21898 B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2*
21899 & (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+
21900 & W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))*
21901 & (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0*
21902 & (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI)
21903 B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH*
21904 & (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)*
21905 & (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/
21906 & (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH*
21907 & (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR)
21908 B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2*
21909 & (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+
21910 & W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))*
21911 & (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0*
21912 & (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI)
21913 B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
21914 & (W2SR-W2HR+W3STUR))
21915 B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI)
21916 B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
21917 & (W2TR-W2HR+W3TUSR))
21918 B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI)
21919 B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
21920 & (W2UR-W2HR+W3USTR))
21921 B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI)
21922 A2STUR=A2STUR+B2STUR+B2SUTR
21923 A2STUI=A2STUI+B2STUI+B2SUTI
21924 A2USTR=A2USTR+B2USTR+B2UTSR
21925 A2USTI=A2USTI+B2USTI+B2UTSI
21926 A2TUSR=A2TUSR+B2TUSR+B2TSUR
21927 A2TUSI=A2TUSI+B2TUSI+B2TSUI
21928 A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
21929 A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
21930 1170 CONTINUE
21931 FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3*
21932 & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
21933 & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
21934 FACGH=FACGH*WIDS(25,2)
21935 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1180
21936 NCHN=NCHN+1
21937 ISIG(NCHN,1)=21
21938 ISIG(NCHN,2)=21
21939 ISIG(NCHN,3)=1
21940 SIGH(NCHN)=FACGH
21941 1180 CONTINUE
21942
21943 ELSEIF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN
21944C...g + g -> gamma + gamma or g + g -> g + gamma
21945 A0STUR=0D0
21946 A0STUI=0D0
21947 A0TSUR=0D0
21948 A0TSUI=0D0
21949 A0UTSR=0D0
21950 A0UTSI=0D0
21951 A1STUR=0D0
21952 A1STUI=0D0
21953 A2STUR=0D0
21954 A2STUI=0D0
21955 ALST=LOG(-SH/TH)
21956 ALSU=LOG(-SH/UH)
21957 ALTU=LOG(TH/UH)
21958 IMAX=2*MSTP(1)
21959 IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38)
21960 DO 1190 I=1,IMAX
21961 EI=KCHG(IABS(I),1)/3D0
21962 EIWT=EI**2
21963 IF(ISUB.EQ.115) EIWT=EI
21964 SQMQ=PMAS(I,1)**2
21965 EPSS=4D0*SQMQ/SH
21966 EPST=4D0*SQMQ/TH
21967 EPSU=4D0*SQMQ/UH
21968 IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1D-4) THEN
21969 B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+
21970 & PARU(1)**2)
21971 B0STUI=0D0
21972 B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2
21973 B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU)
21974 B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2
21975 B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST)
21976 B1STUR=-1D0
21977 B1STUI=0D0
21978 B2STUR=-1D0
21979 B2STUI=0D0
21980 ELSE
21981 CALL PYWAUX(1,EPSS,W1SR,W1SI)
21982 CALL PYWAUX(1,EPST,W1TR,W1TI)
21983 CALL PYWAUX(1,EPSU,W1UR,W1UI)
21984 CALL PYWAUX(2,EPSS,W2SR,W2SI)
21985 CALL PYWAUX(2,EPST,W2TR,W2TI)
21986 CALL PYWAUX(2,EPSU,W2UR,W2UI)
21987 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
21988 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
21989 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
21990 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
21991 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
21992 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
21993 B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+
21994 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)-
21995 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)-
21996 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+
21997 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
21998 & 0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
21999 B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+
22000 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)-
22001 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)-
22002 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+
22003 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
22004 & 0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
22005 B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+
22006 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)-
22007 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)-
22008 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+
22009 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
22010 & 0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)
22011 B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+
22012 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)-
22013 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)-
22014 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+
22015 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
22016 & 0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)
22017 B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+
22018 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)-
22019 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)-
22020 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+
22021 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
22022 & 0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR)
22023 B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+
22024 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)-
22025 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)-
22026 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+
22027 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
22028 & 0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI)
22029 B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+
22030 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+
22031 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+
22032 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
22033 B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+
22034 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+
22035 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+
22036 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
22037 B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+
22038 & 0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+
22039 & 0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR)
22040 B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+
22041 & 0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+
22042 & 0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI)
22043 ENDIF
22044 A0STUR=A0STUR+EIWT*B0STUR
22045 A0STUI=A0STUI+EIWT*B0STUI
22046 A0TSUR=A0TSUR+EIWT*B0TSUR
22047 A0TSUI=A0TSUI+EIWT*B0TSUI
22048 A0UTSR=A0UTSR+EIWT*B0UTSR
22049 A0UTSI=A0UTSI+EIWT*B0UTSI
22050 A1STUR=A1STUR+EIWT*B1STUR
22051 A1STUI=A1STUI+EIWT*B1STUI
22052 A2STUR=A2STUR+EIWT*B2STUR
22053 A2STUI=A2STUI+EIWT*B2STUI
22054 1190 CONTINUE
22055 ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+
22056 & A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2
22057 FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM
22058 FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM
22059 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1200
22060 NCHN=NCHN+1
22061 ISIG(NCHN,1)=21
22062 ISIG(NCHN,2)=21
22063 ISIG(NCHN,3)=1
22064 IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG
22065 IF(ISUB.EQ.115) SIGH(NCHN)=FACGP
22066 1200 CONTINUE
22067
22068 ELSEIF(ISUB.EQ.116) THEN
22069C...g + g -> gamma + Z0
22070
22071 ELSEIF(ISUB.EQ.117) THEN
22072C...g + g -> Z0 + Z0
22073
22074 ELSEIF(ISUB.EQ.118) THEN
22075C...g + g -> W+ + W-
22076
22077 ENDIF
22078
22079C...G: 2 -> 3, tree diagrams
22080
22081 ELSEIF(ISUB.LE.140) THEN
22082 IF(ISUB.EQ.121) THEN
22083C...g + g -> Q + Qbar + h0
22084 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1210
22085 IA=KFPR(ISUBSV,2)
22086 PMF=PYMRUN(IA,SH)
22087 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
22088 & (0.5D0*PMF/PMAS(24,1))**2
22089 WID2=1D0
22090 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
22091 FACQQH=FACQQH*WID2
22092 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
22093 IKFI=1
22094 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
22095 IF(IA.GT.10) IKFI=3
22096 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
22097 ENDIF
22098 CALL PYQQBH(WTQQBH)
22099 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
22100 HS=SHR*WDTP(0)
22101 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
22102 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
22103 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
22104 & FACBW=0D0
22105 NCHN=NCHN+1
22106 ISIG(NCHN,1)=21
22107 ISIG(NCHN,2)=21
22108 ISIG(NCHN,3)=1
22109 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
22110 1210 CONTINUE
22111
22112 ELSEIF(ISUB.EQ.122) THEN
22113C...q + qbar -> Q + Qbar + h0
22114 IA=KFPR(ISUBSV,2)
22115 PMF=PYMRUN(IA,SH)
22116 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
22117 & (0.5D0*PMF/PMAS(24,1))**2
22118 WID2=1D0
22119 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
22120 FACQQH=FACQQH*WID2
22121 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
22122 IKFI=1
22123 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
22124 IF(IA.GT.10) IKFI=3
22125 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
22126 ENDIF
22127 CALL PYQQBH(WTQQBH)
22128 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
22129 HS=SHR*WDTP(0)
22130 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
22131 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
22132 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
22133 & FACBW=0D0
22134 DO 1220 I=MMINA,MMAXA
22135 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
22136 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1220
22137 NCHN=NCHN+1
22138 ISIG(NCHN,1)=I
22139 ISIG(NCHN,2)=-I
22140 ISIG(NCHN,3)=1
22141 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
22142 1220 CONTINUE
22143
22144 ELSEIF(ISUB.EQ.123) THEN
22145C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
22146C...inner process)
22147 FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0
22148 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
22149 & PARU(154+10*IHIGG)**2
22150 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
22151 & (VINT(216)-VINT(209)**2))**2
22152 FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
22153 FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218)
22154 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
22155 HS=SHR*WDTP(0)
22156 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
22157 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
22158 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
22159 & FACBW=0D0
22160 DO 1240 I=MMIN1,MMAX1
22161 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1240
22162 IA=IABS(I)
22163 DO 1230 J=MMIN2,MMAX2
22164 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1230
22165 JA=IABS(J)
22166 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
22167 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
22168 VI=AI-4D0*EI*XWV
22169 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
22170 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
22171 VJ=AJ-4D0*EJ*XWV
22172 FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ
22173 FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ
22174 NCHN=NCHN+1
22175 ISIG(NCHN,1)=I
22176 ISIG(NCHN,2)=J
22177 ISIG(NCHN,3)=1
22178 SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW
22179 1230 CONTINUE
22180 1240 CONTINUE
22181
22182 ELSEIF(ISUB.EQ.124) THEN
22183C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
22184C...inner process)
22185 FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW
22186 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
22187 & PARU(155+10*IHIGG)**2
22188 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
22189 & (VINT(216)-VINT(209)**2))**2
22190 FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
22191 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
22192 HS=SHR*WDTP(0)
22193 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
22194 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
22195 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
22196 & FACBW=0D0
22197 DO 1260 I=MMIN1,MMAX1
22198 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1260
22199 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
22200 DO 1250 J=MMIN2,MMAX2
22201 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1250
22202 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
22203 IF(EI*EJ.GT.0D0) GOTO 1250
22204 FACLR=VINT(180+I)*VINT(180+J)
22205 NCHN=NCHN+1
22206 ISIG(NCHN,1)=I
22207 ISIG(NCHN,2)=J
22208 ISIG(NCHN,3)=1
22209 SIGH(NCHN)=FACLR*FACWW*FACBW
22210 1250 CONTINUE
22211 1260 CONTINUE
22212
22213 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
22214C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only)
22215 PH=0D0
22216 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
22217 & PH=VINT(3)**2
22218 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
22219 & PH=VINT(4)**2
22220 IF(ISUB.EQ.131) THEN
22221 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**2*
22222 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
22223 ELSE
22224 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
22225 ENDIF
22226 DO 1280 I=MMINA,MMAXA
22227 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1280
22228 EI=KCHG(IABS(I),1)/3D0
22229 FACGQ=FGQ*EI**2
22230 DO 1270 ISDE=1,2
22231 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 1270
22232 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 1270
22233 NCHN=NCHN+1
22234 ISIG(NCHN,ISDE)=I
22235 ISIG(NCHN,3-ISDE)=22
22236 ISIG(NCHN,3)=1
22237 SIGH(NCHN)=FACGQ
22238 1270 CONTINUE
22239 1280 CONTINUE
22240
22241 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
22242C...f + gamma*_(T,L) -> f + gamma
22243 PH=0D0
22244 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
22245 & PH=VINT(3)**2
22246 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
22247 & PH=VINT(4)**2
22248 IF(ISUB.EQ.133) THEN
22249 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**2*
22250 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
22251 ELSE
22252 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
22253 ENDIF
22254 DO 1300 I=MMINA,MMAXA
22255 IF(I.EQ.0) GOTO 1300
22256 EI=KCHG(IABS(I),1)/3D0
22257 FACGQ=FGQ*EI**4
22258 DO 1290 ISDE=1,2
22259 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 1290
22260 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 1290
22261 NCHN=NCHN+1
22262 ISIG(NCHN,ISDE)=I
22263 ISIG(NCHN,3-ISDE)=22
22264 ISIG(NCHN,3)=1
22265 SIGH(NCHN)=FACGQ
22266 1290 CONTINUE
22267 1300 CONTINUE
22268
22269 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
22270C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only)
22271 PH=0D0
22272 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
22273 & PH=VINT(3)**2
22274 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
22275 & PH=VINT(4)**2
22276 CALL PYWIDT(21,SH,WDTP,WDTE)
22277 WDTESU=0D0
22278 DO 1310 I=1,MIN(8,MDCY(21,3))
22279 EF=KCHG(I,1)/3D0
22280 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
22281 & WDTE(I,4))
22282 1310 CONTINUE
22283 IF(ISUB.EQ.135) THEN
22284 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**2*
22285 & ((TH2+UH2-2D0*PH*SH)/(TH*UH)+4D0*PH*SH/(SH+PH)**2)
22286 ELSE
22287 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**4*8D0*PH*SH
22288 ENDIF
22289 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
22290 NCHN=NCHN+1
22291 ISIG(NCHN,1)=21
22292 ISIG(NCHN,2)=22
22293 ISIG(NCHN,3)=1
22294 SIGH(NCHN)=FACQQ
22295 ENDIF
22296 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
22297 NCHN=NCHN+1
22298 ISIG(NCHN,1)=22
22299 ISIG(NCHN,2)=21
22300 ISIG(NCHN,3)=1
22301 SIGH(NCHN)=FACQQ
22302 ENDIF
22303
22304 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
22305C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar
22306 PH1=0D0
22307 IF(VINT(3).LT.0D0) PH1=VINT(3)**2
22308 PH2=0D0
22309 IF(VINT(4).LT.0D0) PH2=VINT(4)**2
22310 CALL PYWIDT(22,SH,WDTP,WDTE)
22311 WDTESU=0D0
22312 DO 1320 I=1,MIN(12,MDCY(22,3))
22313 IF(I.LE.8) EF= KCHG(I,1)/3D0
22314 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
22315 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
22316 & WDTE(I,4))
22317 1320 CONTINUE
22318 DLAMB2=(TH+UH)**2-4D0*PH1*PH2
22319 IF(ISUB.EQ.137) THEN
22320 FPARAM=-SH*(TH+UH)/DLAMB2
22321 FACFF=COMFAC*AEM**2*WDTESU*2D0*SH2/(DLAMB2*TH2*UH2)*
22322 & (TH*UH-PH1*PH2)*((TH2+UH2)*(1D0-2D0*FPARAM*(1D0-FPARAM))-
22323 & 2D0*PH1*PH2*FPARAM**2)
22324 ELSEIF(ISUB.EQ.138) THEN
22325 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
22326 & PH2*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH1*SH*(TH-UH)**2/DLAMB2)+
22327 & 2D0*PH1**2*(TH-UH)**2)
22328 ELSEIF(ISUB.EQ.139) THEN
22329 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
22330 & PH1*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH2*SH*(TH-UH)**2/DLAMB2)+
22331 & 2D0*PH2**2*(TH-UH)**2)
22332 ELSE
22333 FACFF=COMFAC*AEM**2*WDTESU*32D0*SH2**2/(DLAMB2**3*TH2*UH2)*
22334 & PH1*PH2*(TH*UH-PH1*PH2)*(TH-UH)**2
22335 ENDIF
22336 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
22337 NCHN=NCHN+1
22338 ISIG(NCHN,1)=22
22339 ISIG(NCHN,2)=22
22340 ISIG(NCHN,3)=1
22341 SIGH(NCHN)=FACFF
22342 ENDIF
22343
22344 ENDIF
22345
22346C...H: 2 -> 1, tree diagrams, non-standard model processes
22347
22348 ELSEIF(ISUB.LE.160) THEN
22349 IF(ISUB.EQ.141) THEN
22350C...f + fbar -> gamma*/Z0/Z'0
22351 SQMZP=PMAS(32,1)**2
22352 MINT(61)=2
22353 CALL PYWIDT(32,SH,WDTP,WDTE)
22354 HP0=AEM/3D0*SH
22355 HP1=AEM/3D0*XWC*SH
22356 HP2=HP1
22357 HS=SHR*VINT(117)
22358 HSP=SHR*WDTP(0)
22359 FACZP=4D0*COMFAC*3D0
22360 DO 1330 I=MMINA,MMAXA
22361 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1330
22362 EI=KCHG(IABS(I),1)/3D0
22363 AI=SIGN(1D0,EI)
22364 VI=AI-4D0*EI*XWV
22365 IA=IABS(I)
22366 IF(IA.LT.10) THEN
22367 IF(IA.LE.2) THEN
22368 VPI=PARU(123-2*MOD(IABS(I),2))
22369 API=PARU(124-2*MOD(IABS(I),2))
22370 ELSEIF(IA.LE.4) THEN
22371 VPI=PARJ(182-2*MOD(IABS(I),2))
22372 API=PARJ(183-2*MOD(IABS(I),2))
22373 ELSE
22374 VPI=PARJ(190-2*MOD(IABS(I),2))
22375 API=PARJ(191-2*MOD(IABS(I),2))
22376 ENDIF
22377 ELSE
22378 IF(IA.LE.12) THEN
22379 VPI=PARU(127-2*MOD(IABS(I),2))
22380 API=PARU(128-2*MOD(IABS(I),2))
22381 ELSEIF(IA.LE.14) THEN
22382 VPI=PARJ(186-2*MOD(IABS(I),2))
22383 API=PARJ(187-2*MOD(IABS(I),2))
22384 ELSE
22385 VPI=PARJ(194-2*MOD(IABS(I),2))
22386 API=PARJ(195-2*MOD(IABS(I),2))
22387 ENDIF
22388 ENDIF
22389 HI0=HP0
22390 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
22391 HI1=HP1
22392 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
22393 HI2=HP2
22394 IF(IABS(I).LE.10) HI2=HI2*FACA/3D0
22395 NCHN=NCHN+1
22396 ISIG(NCHN,1)=I
22397 ISIG(NCHN,2)=-I
22398 ISIG(NCHN,3)=1
22399 SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI*
22400 & (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)*
22401 & VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)*
22402 & (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/
22403 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)*
22404 & ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)*
22405 & ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+
22406 & (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116))
22407 1330 CONTINUE
22408
22409 ELSEIF(ISUB.EQ.142) THEN
22410C...f + fbar' -> W'+/-
22411 SQMWP=PMAS(34,1)**2
22412 CALL PYWIDT(34,SH,WDTP,WDTE)
22413 HS=SHR*WDTP(0)
22414 FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0
22415 HP=AEM/(24D0*XW)*SH
22416 DO 1350 I=MMIN1,MMAX1
22417 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1350
22418 IA=IABS(I)
22419 DO 1340 J=MMIN2,MMAX2
22420 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1340
22421 JA=IABS(J)
22422 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1340
22423 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
22424 & GOTO 1340
22425 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
22426 HI=HP*(PARU(133)**2+PARU(134)**2)
22427 IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)*
22428 & VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
22429 NCHN=NCHN+1
22430 ISIG(NCHN,1)=I
22431 ISIG(NCHN,2)=J
22432 ISIG(NCHN,3)=1
22433 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
22434 SIGH(NCHN)=HI*FACBW*HF
22435 1340 CONTINUE
22436 1350 CONTINUE
22437
22438 ELSEIF(ISUB.EQ.143) THEN
22439C...f + fbar' -> H+/-
22440 SQMHC=PMAS(37,1)**2
22441 CALL PYWIDT(37,SH,WDTP,WDTE)
22442 HS=SHR*WDTP(0)
22443 FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2)
22444 HP=AEM/(8D0*XW)*SH/SQMW*SH
22445 DO 1370 I=MMIN1,MMAX1
22446 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1370
22447 IA=IABS(I)
22448 IM=(MOD(IA,10)+1)/2
22449 DO 1360 J=MMIN2,MMAX2
22450 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1360
22451 JA=IABS(J)
22452 JM=(MOD(JA,10)+1)/2
22453 IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 1360
22454 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
22455 & GOTO 1360
22456 IF(MOD(IA,2).EQ.0) THEN
22457 IU=IA
22458 IL=JA
22459 ELSE
22460 IU=JA
22461 IL=IA
22462 ENDIF
22463 RML=PYMRUN(IL,SH)**2/SH
22464 RMU=PYMRUN(IU,SH)**2/SH
22465 HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2)
22466 IF(IA.LE.10) HI=HI*FACA/3D0
22467 KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
22468 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
22469 NCHN=NCHN+1
22470 ISIG(NCHN,1)=I
22471 ISIG(NCHN,2)=J
22472 ISIG(NCHN,3)=1
22473 SIGH(NCHN)=HI*FACBW*HF
22474 1360 CONTINUE
22475 1370 CONTINUE
22476
22477 ELSEIF(ISUB.EQ.144) THEN
22478C...f + fbar' -> R
22479 SQMR=PMAS(40,1)**2
22480 CALL PYWIDT(40,SH,WDTP,WDTE)
22481 HS=SHR*WDTP(0)
22482 FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0
22483 HP=AEM/(12D0*XW)*SH
22484 DO 1390 I=MMIN1,MMAX1
22485 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1390
22486 IA=IABS(I)
22487 DO 1380 J=MMIN2,MMAX2
22488 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1380
22489 JA=IABS(J)
22490 IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 1380
22491 HI=HP
22492 IF(IA.LE.10) HI=HI*FACA/3D0
22493 HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
22494 NCHN=NCHN+1
22495 ISIG(NCHN,1)=I
22496 ISIG(NCHN,2)=J
22497 ISIG(NCHN,3)=1
22498 SIGH(NCHN)=HI*FACBW*HF
22499 1380 CONTINUE
22500 1390 CONTINUE
22501
22502 ELSEIF(ISUB.EQ.145) THEN
22503C...q + l -> LQ (leptoquark)
22504 SQMLQ=PMAS(39,1)**2
22505 CALL PYWIDT(39,SH,WDTP,WDTE)
22506 HS=SHR*WDTP(0)
22507 FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2)
22508 IF(ABS(SHR-PMAS(39,1)).GT.PARP(48)*PMAS(39,2)) FACBW=0D0
22509 HP=AEM/4D0*SH
22510 KFLQQ=KFDP(MDCY(39,2),1)
22511 KFLQL=KFDP(MDCY(39,2),2)
22512 DO 1410 I=MMIN1,MMAX1
22513 IF(KFAC(1,I).EQ.0) GOTO 1410
22514 IA=IABS(I)
22515 IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 1410
22516 DO 1400 J=MMIN2,MMAX2
22517 IF(KFAC(2,J).EQ.0) GOTO 1400
22518 JA=IABS(J)
22519 IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 1400
22520 IF(I*J.NE.KFLQQ*KFLQL) GOTO 1400
22521 IF(JA.EQ.IA) GOTO 1400
22522 IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I)
22523 IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J)
22524 HI=HP*PARU(151)
22525 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4))
22526 NCHN=NCHN+1
22527 ISIG(NCHN,1)=I
22528 ISIG(NCHN,2)=J
22529 ISIG(NCHN,3)=1
22530 SIGH(NCHN)=HI*FACBW*HF
22531 1400 CONTINUE
22532 1410 CONTINUE
22533
22534 ELSEIF(ISUB.EQ.146) THEN
22535C...e + gamma* -> e* (excited lepton)
22536 KFQSTR=KFPR(ISUB,1)
22537 KCQSTR=PYCOMP(KFQSTR)
22538 KFQEXC=MOD(KFQSTR,KEXCIT)
22539 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
22540 HS=SHR*WDTP(0)
22541 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
22542 QF=-PARU(157)/2D0-PARU(158)/2D0
22543 FACBW=FACBW*AEM*QF**2*SH/PARU(155)**2
22544 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
22545 & FACBW=0D0
22546 HP=SH
22547 DO 1416 I=-KFQEXC,KFQEXC,2*KFQEXC
22548 DO 1413 ISDE=1,2
22549 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 1413
22550 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 1413
22551 HI=HP
22552 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
22553 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
22554 NCHN=NCHN+1
22555 ISIG(NCHN,ISDE)=I
22556 ISIG(NCHN,3-ISDE)=22
22557 ISIG(NCHN,3)=1
22558 SIGH(NCHN)=HI*FACBW*HF
22559 1413 CONTINUE
22560 1416 CONTINUE
22561
22562 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
22563C...d + g -> d* and u + g -> u* (excited quarks)
22564 KFQSTR=KFPR(ISUB,1)
22565 KCQSTR=PYCOMP(KFQSTR)
22566 KFQEXC=MOD(KFQSTR,KEXCIT)
22567 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
22568 HS=SHR*WDTP(0)
22569 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
22570 FACBW=FACBW*AS*PARU(159)**2*SH/(3D0*PARU(155)**2)
22571 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
22572 & FACBW=0D0
22573 HP=SH
22574 DO 1430 I=-KFQEXC,KFQEXC,2*KFQEXC
22575 DO 1420 ISDE=1,2
22576 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1420
22577 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1420
22578 HI=HP
22579 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
22580 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
22581 NCHN=NCHN+1
22582 ISIG(NCHN,ISDE)=I
22583 ISIG(NCHN,3-ISDE)=21
22584 ISIG(NCHN,3)=1
22585 SIGH(NCHN)=HI*FACBW*HF
22586 1420 CONTINUE
22587 1430 CONTINUE
22588
22589 ELSEIF(ISUB.EQ.149) THEN
22590C...g + g -> eta_techni
22591 CALL PYWIDT(38,SH,WDTP,WDTE)
22592 HS=SHR*WDTP(0)
22593 FACBW=COMFAC*0.5D0/((SH-PMAS(38,1)**2)**2+HS**2)
22594 IF(ABS(SHR-PMAS(38,1)).GT.PARP(48)*PMAS(38,2)) FACBW=0D0
22595 HP=SH
22596 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1440
22597 HI=HP*WDTP(3)
22598 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
22599 NCHN=NCHN+1
22600 ISIG(NCHN,1)=21
22601 ISIG(NCHN,2)=21
22602 ISIG(NCHN,3)=1
22603 SIGH(NCHN)=HI*FACBW*HF
22604 1440 CONTINUE
22605
22606 ENDIF
22607
22608C...I: 2 -> 2, tree diagrams, non-standard model processes
22609
22610 ELSEIF(ISUB.LE.200) THEN
22611 IF(ISUB.EQ.161) THEN
22612C...f + g -> f' + H+/- (b + g -> t + H+/- only)
22613C...(choice of only b and t to avoid kinematics problems)
22614 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24
22615C...H propagator: as simulated in PYOFSH and as desired
22616 SQMHC=PMAS(37,1)**2
22617 GMMHC=PMAS(37,1)*PMAS(37,2)
22618 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
22619 CALL PYWIDT(37,SQM4,WDTP,WDTE)
22620 GMMHCC=SQRT(SQM4)*WDTP(0)
22621 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
22622 FHCQ=FHCQ*HBW4C/HBW4
22623 DO 1460 I=MMINA,MMAXA
22624 IA=IABS(I)
22625 IF(IA.NE.5) GOTO 1460
22626 SQML=PYMRUN(IA,SH)**2
22627 IUA=IA+MOD(IA,2)
22628 SQMQ=PYMRUN(IUA,SH)**2
22629 FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW*
22630 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH+
22631 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
22632 & (SQMHC-SQMQ-SH)/SH)
22633 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
22634 DO 1450 ISDE=1,2
22635 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1450
22636 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,1).EQ.0) GOTO 1450
22637 NCHN=NCHN+1
22638 ISIG(NCHN,ISDE)=I
22639 ISIG(NCHN,3-ISDE)=21
22640 ISIG(NCHN,3)=1
22641 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
22642 1450 CONTINUE
22643 1460 CONTINUE
22644
22645 ELSEIF(ISUB.EQ.162) THEN
22646C...q + g -> LQ + lbar; LQ=leptoquark
22647 SQMLQ=PMAS(39,1)**2
22648 FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)*
22649 & (UH2+SQMLQ**2)/(UH-SQMLQ)**2
22650 KFLQQ=KFDP(MDCY(39,2),1)
22651 DO 1480 I=MMINA,MMAXA
22652 IF(IABS(I).NE.KFLQQ) GOTO 1480
22653 KCHLQ=ISIGN(1,I)
22654 DO 1470 ISDE=1,2
22655 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1470
22656 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1470
22657 NCHN=NCHN+1
22658 ISIG(NCHN,ISDE)=I
22659 ISIG(NCHN,3-ISDE)=21
22660 ISIG(NCHN,3)=1
22661 SIGH(NCHN)=FACLQ*WIDS(39,(5-KCHLQ)/2)
22662 1470 CONTINUE
22663 1480 CONTINUE
22664
22665 ELSEIF(ISUB.EQ.163) THEN
22666C...g + g -> LQ + LQbar; LQ=leptoquark
22667 SQMLQ=PMAS(39,1)**2
22668 FACLQ=COMFAC*FACA*WIDS(39,1)*(AS**2/2D0)*
22669 & (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/
22670 & (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/
22671 & ((TH-SQMLQ)*(UH-SQMLQ)))
22672 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1490
22673 NCHN=NCHN+1
22674 ISIG(NCHN,1)=21
22675 ISIG(NCHN,2)=21
22676C...Since don't know proper colour flow, randomize between alternatives
22677 ISIG(NCHN,3)=INT(1.5D0+PYR(0))
22678 SIGH(NCHN)=FACLQ
22679 1490 CONTINUE
22680
22681 ELSEIF(ISUB.EQ.164) THEN
22682C...q + qbar -> LQ + LQbar; LQ=leptoquark
22683 SQMLQ=PMAS(39,1)**2
22684 FACLQA=COMFAC*WIDS(39,1)*(AS**2/9D0)*
22685 & (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2
22686 FACLQS=COMFAC*WIDS(39,1)*((PARU(151)**2*AEM**2/8D0)*
22687 & (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)*
22688 & ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH))
22689 KFLQQ=KFDP(MDCY(39,2),1)
22690 DO 1500 I=MMINA,MMAXA
22691 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
22692 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1500
22693 NCHN=NCHN+1
22694 ISIG(NCHN,1)=I
22695 ISIG(NCHN,2)=-I
22696 ISIG(NCHN,3)=1
22697 SIGH(NCHN)=FACLQA
22698 IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS
22699 1500 CONTINUE
22700
22701 ELSEIF(ISUB.EQ.165) THEN
22702C...q + qbar -> l+ + l- (including contact term for compositeness)
22703 ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
22704 ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
22705 KFF=IABS(KFPR(ISUB,1))
22706 EF=KCHG(KFF,1)/3D0
22707 AF=SIGN(1D0,EF+0.1D0)
22708 VF=AF-4D0*EF*XWV
22709 VALF=VF+AF
22710 VARF=VF-AF
22711 FCOF=1D0
22712 IF(KFF.LE.10) FCOF=3D0
22713 WID2=1D0
22714 IF(KFF.EQ.6) WID2=WIDS(6,1)
22715 IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1)
22716 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
22717 DO 1510 I=MMINA,MMAXA
22718 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1510
22719 EI=KCHG(IABS(I),1)/3D0
22720 AI=SIGN(1D0,EI+0.1D0)
22721 VI=AI-4D0*EI*XWV
22722 VALI=VI+AI
22723 VARI=VI-AI
22724 FCOI=1D0
22725 IF(IABS(I).LE.10) FCOI=FACA/3D0
22726 IF((MSTP(5).EQ.1.AND.IABS(I).LE.2).OR.MSTP(5).EQ.2) THEN
22727 FGZA=(EI*EF+VALI*VALF*ZRATR+PARU(156)*SH/
22728 & (AEM*PARU(155)**2))**2+(VALI*VALF*ZRATI)**2+
22729 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
22730 ELSE
22731 FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+
22732 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
22733 ENDIF
22734 FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+
22735 & (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2
22736 FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2)
22737 IF((MSTP(5).EQ.3.AND.IABS(I).EQ.2).OR.(MSTP(5).EQ.4.AND.
22738 & MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*PARU(155)**4)
22739 NCHN=NCHN+1
22740 ISIG(NCHN,1)=I
22741 ISIG(NCHN,2)=-I
22742 ISIG(NCHN,3)=1
22743 SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2
22744 1510 CONTINUE
22745
22746 ELSEIF(ISUB.EQ.166) THEN
22747C...q + q'bar -> l + nu_l (including contact term for compositeness)
22748 WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2)
22749 WCIFAC=WFAC+SH2/(4D0*PARU(155)**4)
22750 KFF=IABS(KFPR(ISUB,1))
22751 FCOF=1D0
22752 IF(KFF.LE.10) FCOF=3D0
22753 DO 1530 I=MMIN1,MMAX1
22754 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1530
22755 IA=IABS(I)
22756 DO 1520 J=MMIN2,MMAX2
22757 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1520
22758 JA=IABS(J)
22759 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1520
22760 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
22761 & GOTO 1520
22762 FCOI=1D0
22763 IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
22764 WID2=1D0
22765 IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND.
22766 & MOD(J,2).EQ.0)) THEN
22767 IF(KFF.EQ.5) WID2=WIDS(6,2)
22768 IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3)
22769 IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3)
22770 ELSE
22771 IF(KFF.EQ.5) WID2=WIDS(6,3)
22772 IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2)
22773 IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2)
22774 ENDIF
22775 NCHN=NCHN+1
22776 ISIG(NCHN,1)=I
22777 ISIG(NCHN,2)=J
22778 ISIG(NCHN,3)=1
22779 SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2
22780 IF((MSTP(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.MSTP(5).EQ.4)
22781 & SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2
22782 1520 CONTINUE
22783 1530 CONTINUE
22784
22785 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
22786C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks)
22787 KFQSTR=KFPR(ISUB,2)
22788 KCQSTR=PYCOMP(KFQSTR)
22789 KFQEXC=MOD(KFQSTR,KEXCIT)
22790 FACQSA=COMFAC*(SH/PARU(155)**2)**2*(1D0-SQM4/SH)
22791 FACQSB=COMFAC*0.25D0*(SH/PARU(155)**2)**2*(1D0-SQM4/SH)*
22792 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
22793C...Propagators: as simulated in PYOFSH and as desired
22794 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
22795 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
22796 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
22797 GMMQC=SQRT(SQM4)*WDTP(0)
22798 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
22799 FACQSA=FACQSA*HBW4C/HBW4
22800 FACQSB=FACQSB*HBW4C/HBW4
22801 DO 1550 I=MMIN1,MMAX1
22802 IA=IABS(I)
22803 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 1550
22804 DO 1540 J=MMIN2,MMAX2
22805 JA=IABS(J)
22806 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 1540
22807 IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN
22808 NCHN=NCHN+1
22809 ISIG(NCHN,1)=I
22810 ISIG(NCHN,2)=J
22811 ISIG(NCHN,3)=1
22812 SIGH(NCHN)=(4D0/3D0)*FACQSA
22813 NCHN=NCHN+1
22814 ISIG(NCHN,1)=I
22815 ISIG(NCHN,2)=J
22816 ISIG(NCHN,3)=2
22817 SIGH(NCHN)=(4D0/3D0)*FACQSA
22818 ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN
22819 NCHN=NCHN+1
22820 ISIG(NCHN,1)=I
22821 ISIG(NCHN,2)=J
22822 ISIG(NCHN,3)=1
22823 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
22824 SIGH(NCHN)=FACQSA
22825 ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN
22826 NCHN=NCHN+1
22827 ISIG(NCHN,1)=I
22828 ISIG(NCHN,2)=J
22829 ISIG(NCHN,3)=1
22830 SIGH(NCHN)=(8D0/3D0)*FACQSB
22831 NCHN=NCHN+1
22832 ISIG(NCHN,1)=I
22833 ISIG(NCHN,2)=J
22834 ISIG(NCHN,3)=2
22835 SIGH(NCHN)=(8D0/3D0)*FACQSB
22836 ELSEIF(I.EQ.-J) THEN
22837 NCHN=NCHN+1
22838 ISIG(NCHN,1)=I
22839 ISIG(NCHN,2)=J
22840 ISIG(NCHN,3)=1
22841 SIGH(NCHN)=FACQSB
22842 NCHN=NCHN+1
22843 ISIG(NCHN,1)=I
22844 ISIG(NCHN,2)=J
22845 ISIG(NCHN,3)=2
22846 SIGH(NCHN)=FACQSB
22847 ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN
22848 NCHN=NCHN+1
22849 ISIG(NCHN,1)=I
22850 ISIG(NCHN,2)=J
22851 ISIG(NCHN,3)=1
22852 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
22853 SIGH(NCHN)=FACQSB
22854 ENDIF
22855 1540 CONTINUE
22856 1550 CONTINUE
22857
22858 ELSEIF(ISUB.EQ.169) THEN
22859C...q + qbar -> e + e* (excited lepton)
22860 KFQSTR=KFPR(ISUB,2)
22861 KCQSTR=PYCOMP(KFQSTR)
22862 KFQEXC=MOD(KFQSTR,KEXCIT)
22863 FACQSB=(COMFAC/6D0)*(SH/PARU(155)**2)**2*(1D0-SQM4/SH)*
22864 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
22865C...Propagators: as simulated in PYOFSH and as desired
22866 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
22867 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
22868 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
22869 GMMQC=SQRT(SQM4)*WDTP(0)
22870 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
22871 FACQSB=FACQSB*HBW4C/HBW4
22872 DO 1555 I=MMIN1,MMAX1
22873 IA=IABS(I)
22874 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 1555
22875 J=-I
22876 JA=IABS(J)
22877 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 1555
22878 NCHN=NCHN+1
22879 ISIG(NCHN,1)=I
22880 ISIG(NCHN,2)=J
22881 ISIG(NCHN,3)=1
22882 SIGH(NCHN)=FACQSB
22883 NCHN=NCHN+1
22884 ISIG(NCHN,1)=I
22885 ISIG(NCHN,2)=J
22886 ISIG(NCHN,3)=2
22887 SIGH(NCHN)=FACQSB
22888 1555 CONTINUE
22889
22890 ELSEIF(ISUB.EQ.191) THEN
22891C...q + qbar -> rho_tech0.
22892 SQMRHT=PMAS(54,1)**2
22893 CALL PYWIDT(54,SH,WDTP,WDTE)
22894 HS=SHR*WDTP(0)
22895 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
22896 IF(ABS(SHR-PMAS(54,1)).GT.PARP(48)*PMAS(54,2)) FACBW=0D0
22897 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
22898 ALPRHT=2.91D0*(3D0/PARP(144))
22899 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)
22900 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
22901 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
22902 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
22903 DO 1560 I=MMINA,MMAXA
22904 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1560
22905 IA=IABS(I)
22906 EI=KCHG(IABS(I),1)/3D0
22907 AI=SIGN(1D0,EI+0.1D0)
22908 VI=AI-4D0*EI*XWV
22909 VALI=0.5D0*(VI+AI)
22910 VARI=0.5D0*(VI-AI)
22911 HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
22912 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
22913 IF(IA.LE.10) HI=HI*FACA/3D0
22914 NCHN=NCHN+1
22915 ISIG(NCHN,1)=I
22916 ISIG(NCHN,2)=-I
22917 ISIG(NCHN,3)=1
22918 SIGH(NCHN)=HI*FACBW*HF
22919 1560 CONTINUE
22920
22921 ELSEIF(ISUB.EQ.192) THEN
22922C...q + qbar' -> rho_tech+/-.
22923 SQMRHT=PMAS(55,1)**2
22924 CALL PYWIDT(55,SH,WDTP,WDTE)
22925 HS=SHR*WDTP(0)
22926 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
22927 IF(ABS(SHR-PMAS(55,1)).GT.PARP(48)*PMAS(55,2)) FACBW=0D0
22928 ALPRHT=2.91D0*(3D0/PARP(144))
22929 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)*
22930 & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
22931 DO 1580 I=MMIN1,MMAX1
22932 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1580
22933 IA=IABS(I)
22934 DO 1570 J=MMIN2,MMAX2
22935 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1570
22936 JA=IABS(J)
22937 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1570
22938 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
22939 & GOTO 1570
22940 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
22941 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4))
22942 HI=HP
22943 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
22944 NCHN=NCHN+1
22945 ISIG(NCHN,1)=I
22946 ISIG(NCHN,2)=J
22947 ISIG(NCHN,3)=1
22948 SIGH(NCHN)=HI*FACBW*HF
22949 1570 CONTINUE
22950 1580 CONTINUE
22951
22952 ELSEIF(ISUB.EQ.193) THEN
22953C...q + qbar -> omega_tech0.
22954 SQMOMT=PMAS(56,1)**2
22955 CALL PYWIDT(56,SH,WDTP,WDTE)
22956 HS=SHR*WDTP(0)
22957 FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2)
22958 IF(ABS(SHR-PMAS(56,1)).GT.PARP(48)*PMAS(56,2)) FACBW=0D0
22959 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
22960 ALPRHT=2.91D0*(3D0/PARP(144))
22961 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)*
22962 & (2D0*PARP(143)-1D0)**2
22963 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
22964 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
22965 DO 1590 I=MMINA,MMAXA
22966 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1590
22967 IA=IABS(I)
22968 EI=KCHG(IABS(I),1)/3D0
22969 AI=SIGN(1D0,EI+0.1D0)
22970 VI=AI-4D0*EI*XWV
22971 VALI=0.5D0*(VI+AI)
22972 VARI=0.5D0*(VI-AI)
22973 HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
22974 & (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
22975 IF(IA.LE.10) HI=HI*FACA/3D0
22976 NCHN=NCHN+1
22977 ISIG(NCHN,1)=I
22978 ISIG(NCHN,2)=-I
22979 ISIG(NCHN,3)=1
22980 SIGH(NCHN)=HI*FACBW*HF
22981 1590 CONTINUE
22982
22983 ELSEIF(ISUB.EQ.194) THEN
22984C...f + fbar -> f' + fbar' via s-channel rho_tech and omega_tech.
22985 KFA=KFPR(ISUBSV,1)
22986 ALPRHT=2.91D0*(3D0/PARP(144))
22987 HP=AEM**2*COMFAC
22988 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
22989 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
22990
22991 QUPD=2D0*PARP(143)-1D0
22992 FAR=SQRT(AEM/ALPRHT)
22993 FAO=FAR*QUPD
22994 FZR=FAR*CT2W
22995 FZO=-FAO*TANW
22996 SFAR=FAR**2
22997 SFAO=FAO**2
22998 SFZR=FZR**2
22999 SFZO=FZO**2
23000 CALL PYWIDT(23,SH,WDTP,WDTE)
23001 SSMZ=CMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
23002 CALL PYWIDT(54,SH,WDTP,WDTE)
23003 SSMR=CMPLX(1D0-PMAS(54,1)**2/SH,WDTP(0)/SHR)
23004 CALL PYWIDT(56,SH,WDTP,WDTE)
23005 SSMO=CMPLX(1D0-PMAS(56,1)**2/SH,WDTP(0)/SHR)
23006 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
23007 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
23008 DAA=(-Sfzr*SSMO - Sfzo*SSMR + SSMO*SSMR*SSMZ)/DETD/SH
23009 DZZ=(-Sfar*SSMO - Sfao*SSMR + SSMO*SSMR)/DETD/SH
23010 DAZ=(far*fzr*SSMO + fao*fzo*SSMR)/DETD/SH
23011
23012 XWRHT=1D0/(4D0*XW*(1D0-XW))
23013 KFF=IABS(KFPR(ISUB,1))
23014 EF=KCHG(KFF,1)/3D0
23015 AF=SIGN(1D0,EF+0.1D0)
23016 VF=AF-4D0*EF*XWV
23017 VALF=0.5D0*(VF+AF)
23018 VARF=0.5D0*(VF-AF)
23019 FCOF=1D0
23020 IF(KFF.LE.10) FCOF=3D0
23021
23022 WID2=1D0
23023 IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1)
23024 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
23025 DZZ=DZZ*CMPLX(XWRHT,0D0)
23026 DAZ=DAZ*CMPLX(SQRT(XWRHT),0D0)
23027
23028 DO 1600 I=MMINA,MMAXA
23029 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1600
23030 EI=KCHG(IABS(I),1)/3D0
23031 AI=SIGN(1D0,EI+0.1D0)
23032 VI=AI-4D0*EI*XWV
23033 VALI=0.5D0*(VI+AI)
23034 VARI=0.5D0*(VI-AI)
23035 FCOI=FCOF
23036 IF(IABS(I).LE.10) FCOI=FCOI/3D0
23037 DIFLL=ABS(EI*EF*DAA+VALI*VALF*DZZ+DAZ*(EI*VALF+EF*VALI))**2
23038 DIFRR=ABS(EI*EF*DAA+VARI*VARF*DZZ+DAZ*(EI*VARF+EF*VARI))**2
23039 DIFLR=ABS(EI*EF*DAA+VALI*VARF*DZZ+DAZ*(EI*VARF+EF*VALI))**2
23040 DIFRL=ABS(EI*EF*DAA+VARI*VALF*DZZ+DAZ*(EI*VALF+EF*VARI))**2
23041 FACSIG=(DIFLL+DIFRR)*((UH-SQM4)**2+SH*SQM4)+
23042 & (DIFLR+DIFRL)*((TH-SQM3)**2+SH*SQM3)
23043 NCHN=NCHN+1
23044 ISIG(NCHN,1)=I
23045 ISIG(NCHN,2)=-I
23046 ISIG(NCHN,3)=1
23047 SIGH(NCHN)=HP*FCOI*FACSIG*WID2
23048 1600 CONTINUE
23049
23050 ELSEIF(ISUB.EQ.195) THEN
23051C...f + fbar' -> f'' + fbar''' via s-channel rho_tech+
23052 KFA=KFPR(ISUBSV,1)
23053 KFB=KFA+1
23054 ALPRHT=2.91D0*(3D0/PARP(144))
23055 FACTC=COMFAC*(AEM**2/12D0/XW**2)*(UH-SQM3)*(UH-SQM4)*3D0
23056
23057 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
23058 CALL PYWIDT(24,SH,WDTP,WDTE)
23059 SSMZ=CMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
23060 CALL PYWIDT(55,SH,WDTP,WDTE)
23061 SSMR=CMPLX(1D0-PMAS(54,1)**2/SH,WDTP(0)/SHR)
23062
23063 FCOF=1D0
23064 IF(KFA.LE.8) FCOF=3D0
23065 DETD=SSMZ*SSMR-CMPLX(FWR**2,0D0)
23066 HP=FACTC*ABS(SSMR/DETD)**2/SH**2*FCOF
23067
23068 DO 1605 I=MMIN1,MMAX1
23069 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1605
23070 IA=IABS(I)
23071 DO 1604 J=MMIN2,MMAX2
23072 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1604
23073 JA=IABS(J)
23074 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1604
23075 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
23076 & GOTO 1604
23077 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
23078 HI=HP
23079 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
23080 NCHN=NCHN+1
23081 ISIG(NCHN,1)=I
23082 ISIG(NCHN,2)=J
23083 ISIG(NCHN,3)=1
23084 SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,(5+KCHR)/2)
23085 1604 CONTINUE
23086 1605 CONTINUE
23087
23088 ENDIF
23089
23090CMRENNA++
23091C...J: 2 -> 2, tree diagrams, SUSY processes
23092
23093 ELSEIF(ISUB.LE.210) THEN
23094 IF(ISUB.EQ.201) THEN
23095C...f + fbar -> e_L + e_Lbar
23096 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
23097 DO 1630 I=MMIN1,MMAX1
23098 IA=IABS(I)
23099 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1630
23100 EI=KCHG(IA,1)/3D0
23101 TT3I=SIGN(1D0,EI+1D-6)/2D0
23102 EJ=-1D0
23103 TT3J=-1D0/2D0
23104 FCOL=1D0
23105C...Color factor for e+ e-
23106 IF(IA.GE.11) FCOL=3D0
23107 IF(ISUBSV.EQ.301) THEN
23108 A1=1D0
23109 A2=0D0
23110 ELSEIF(ILR.EQ.1) THEN
23111 A1=SFMIX(KFID,3)**2
23112 A2=SFMIX(KFID,4)**2
23113 ELSEIF(ILR.EQ.0) THEN
23114 A1=SFMIX(KFID,1)**2
23115 A2=SFMIX(KFID,2)**2
23116 ENDIF
23117 XLQ=(TT3J-EJ*XW)*A1
23118 XRQ=(-EJ*XW)*A2
23119 XLF=(TT3I-EI*XW)
23120 XRF=(-EI*XW)
23121 TAA=2D0*(EI*EJ)**2
23122 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/XW**2/XW1**2
23123 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
23124 TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF+XRF)/XW/XW1
23125 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
23126 TNN=0.0D0
23127 TAN=0.0D0
23128 TZN=0.0D0
23129 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
23130 FAC2=SQRT(2D0)
23131 TNN1=0D0
23132 TNN2=0D0
23133 TNN3=0D0
23134 DO 1620 II=1,4
23135 DK=1D0/(TH-SMZ(II)**2)
23136 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
23137 & ZMIX(II,1))
23138 FREK=FAC2*TANW*EI*ZMIX(II,1)
23139 TNN1=TNN1+FLEK**2*DK
23140 TNN2=TNN2+FREK**2*DK
23141 DO 1610 JJ=1,4
23142 DL=1D0/(TH-SMZ(JJ)**2)
23143 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
23144 & ZMIX(JJ,1))
23145 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
23146 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
23147 1610 CONTINUE
23148 1620 CONTINUE
23149 TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2+A2**2*TNN2**2)
23150 TNN=(TNN+2D0*SH*A1*A2*TNN3)/4D0/XW**2
23151 TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
23152 & (TNN1*XLF*A1+TNN2*XRF*A2)
23153 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
23154 & (1D0-SQMZ/SH)/SH
23155 TZN=TZN/XW**2/XW1
23156 TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1+A2*TNN2)/XW
23157 ENDIF
23158 FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0
23159 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2
23160 FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0
23161 NCHN=NCHN+1
23162 ISIG(NCHN,1)=I
23163 ISIG(NCHN,2)=-I
23164 ISIG(NCHN,3)=1
23165 SIGH(NCHN)=FACQQ1+FACQQ2
23166 1630 CONTINUE
23167
23168 ELSEIF(ISUB.EQ.203) THEN
23169C...f + fbar -> e_L + e_Rbar
23170 DO 1660 I=MMIN1,MMAX1
23171 IA=IABS(I)
23172 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1660
23173 EI=KCHG(IABS(I),1)/3D0
23174 TT3I=SIGN(1D0,EI)/2D0
23175 EJ=-1
23176 TT3J=-1D0/2D0
23177 FCOL=1D0
23178C...Color factor for e+ e-
23179 IF(IA.GE.11) FCOL=3D0
23180 A1=SFMIX(KFID,1)**2
23181 A2=SFMIX(KFID,2)**2
23182 XLQ=(TT3J-EJ*XW)
23183 XRQ=(-EJ*XW)
23184 XLF=(TT3I-EI*XW)
23185 XRF=(-EI*XW)
23186 TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/XW**2/XW1**2*A1*A2
23187 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
23188 TNN=0.0D0
23189 TZN=0.0D0
23190 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
23191 FAC2=SQRT(2D0)
23192 TNN1=0D0
23193 TNN2=0D0
23194 TNN3=0D0
23195 DO 1650 II=1,4
23196 DK=1D0/(TH-SMZ(II)**2)
23197 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
23198 & ZMIX(II,1))
23199 FREK=FAC2*TANW*EI*ZMIX(II,1)
23200 TNN1=TNN1+FLEK**2*DK
23201 TNN2=TNN2+FREK**2*DK
23202 DO 1640 JJ=1,4
23203 DL=1D0/(TH-SMZ(JJ)**2)
23204 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
23205 & ZMIX(JJ,1))
23206 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
23207 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
23208 1640 CONTINUE
23209 1650 CONTINUE
23210 TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2+TNN1**2)
23211 TNN=(TNN+SH*(A2**2+A1**2)*TNN3)/4D0
23212 TZN=(UH*TH-SQM3*SQM4)*A1*A2
23213 TZN=TZN*(XLQ-XRQ)*(XLF*TNN1-XRF*TNN2)/XW1
23214 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
23215 & (1D0-SQMZ/SH)/SH
23216 ENDIF
23217 FACQQ1=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
23218 FACQQ2=COMFAC*AEM**2/XW**2*(TNN+TZN)*FCOL/3D0
23219 FACQQ=(FACQQ1+FACQQ2)
23220 NCHN=NCHN+1
23221 ISIG(NCHN,1)=I
23222 ISIG(NCHN,2)=-I
23223 ISIG(NCHN,3)=1
23224 SIGH(NCHN)=FACQQ*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
23225 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
23226 NCHN=NCHN+1
23227 ISIG(NCHN,1)=I
23228 ISIG(NCHN,2)=-I
23229 ISIG(NCHN,3)=2
23230 SIGH(NCHN)=FACQQ*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
23231 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
23232 1660 CONTINUE
23233
23234 ELSEIF(ISUB.EQ.210) THEN
23235C...q + qbar' -> W*- > ~l_L + ~nu_L
23236 FAC0=RKF*COMFAC*AEM**2/XW**2/12D0
23237 FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW)
23238 DO 1680 I=MMIN1,MMAX1
23239 IA=IABS(I)
23240 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 1680
23241 DO 1670 J=MMIN2,MMAX2
23242 JA=IABS(J)
23243 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 1670
23244 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1670
23245 FCKM=3D0
23246 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
23247 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
23248 KCHW=2
23249 IF(KCHSUM.LT.0) KCHW=3
23250 NCHN=NCHN+1
23251 ISIG(NCHN,1)=I
23252 ISIG(NCHN,2)=J
23253 ISIG(NCHN,3)=1
23254 IF(ISUBSV.EQ.297.OR.ISUBSV.EQ.298) THEN
23255 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
23256 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
23257 ELSE
23258 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
23259 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
23260 ENDIF
23261 SIGH(NCHN)=FAC0*FAC1*FCKM*FACR
23262 1670 CONTINUE
23263 1680 CONTINUE
23264 ENDIF
23265
23266 ELSEIF(ISUB.LE.220) THEN
23267 IF(ISUB.EQ.213) THEN
23268C...f + fbar -> ~nu_L + ~nu_Lbar
23269 IF(ISUBSV.EQ.299.OR.ISUBSV.EQ.300) THEN
23270 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
23271 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
23272 ELSE
23273 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
23274 ENDIF
23275 COMFAC=COMFAC*FACR
23276 PROPZ=(SH-SQMZ)**2+ZWID**2*SQMZ
23277 XLL=0.5D0
23278 XLR=0.0D0
23279 DO 1690 I=MMIN1,MMAX1
23280 IA=IABS(I)
23281 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1690
23282 EI=KCHG(IA,1)/3D0
23283 FCOL=1D0
23284C...Color factor for e+ e-
23285 IF(IA.GE.11) FCOL=3D0
23286 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
23287 XRQ=-EI*XW
23288 TZC=0.0D0
23289 TCC=0.0D0
23290 IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN
23291 TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/
23292 & (TH-SMW(2)**2)
23293 TCC=TZC**2
23294 TZC=TZC/XW1*(SH-SQMZ)/PROPZ*XLQ*XLL
23295 ENDIF
23296 FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ
23297 FACQQ2=TZC+TCC/4D0
23298 NCHN=NCHN+1
23299 ISIG(NCHN,1)=I
23300 ISIG(NCHN,2)=-I
23301 ISIG(NCHN,3)=1
23302 SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC
23303 & *AEM**2*FCOL/3D0/XW**2
23304 1690 CONTINUE
23305
23306 ELSEIF(ISUB.EQ.216) THEN
23307C...q + qbar -> ~chi0_1 + ~chi0_1
23308 IF(IZID1.EQ.IZID2) THEN
23309 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
23310 ELSE
23311 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
23312 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
23313 ENDIF
23314 FACGG1=COMFAC*AEM**2/3D0/XW**2
23315 IF(IZID1.EQ.IZID2) FACGG1=FACGG1/2D0
23316 ZM12=SQM3
23317 ZM22=SQM4
23318 WU2 = (UH-ZM12)*(UH-ZM22)/SH2
23319 WT2 = (TH-ZM12)*(TH-ZM22)/SH2
23320 XS2 = SMZ(IZID1)*SMZ(IZID2)/SH
23321 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
23322 REPRPZ = (SH-SQMZ)/PROPZ2
23323 OLPP=(-ZMIX(IZID1,3)*ZMIX(IZID2,3)+
23324 & ZMIX(IZID1,4)*ZMIX(IZID2,4))/2D0
23325 DO 1700 I=MMINA,MMAXA
23326 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1700
23327 EI=KCHG(IABS(I),1)/3D0
23328 FCOL=1D0
23329 IF(ABS(I).GE.11) FCOL=3D0
23330 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
23331 XRQ=-EI*XW
23332 XLQ=XLQ/XW1
23333 XRQ=XRQ/XW1
23334C...Factored out sqrt(2)
23335 FR1=TANW*EI*ZMIX(IZID1,1)
23336 FR2=TANW*EI*ZMIX(IZID2,1)
23337 FL1=-(SIGN(1D0,EI)*ZMIX(IZID1,2)-TANW*
23338 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID1,1))/2D0
23339 FL2=-(SIGN(1D0,EI)*ZMIX(IZID2,2)-TANW*
23340 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID2,1))/2D0
23341 FR12=FR1**2
23342 FR22=FR2**2
23343 FL12=FL1**2
23344 FL22=FL2**2
23345 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2
23346 XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2
23347 FACS=OLPP**2*(XLQ**2+XRQ**2)*(WU2+WT2-2D0*XS2)*(SH2/PROPZ2)
23348 FACT=FL12*FL22*(WT2*SH2/(TH-XML2)**2+WU2*SH2/(UH-XML2)**2-
23349 & 2D0*XS2*SH2/(TH-XML2)/(UH-XML2))
23350 FACU=FR12*FR22*(WT2*SH2/(TH-XMR2)**2+WU2*SH2/(UH-XMR2)**2-
23351 & 2D0*XS2*SH2/(TH-XMR2)/(UH-XMR2))
23352 FACST=2D0*REPRPZ*OLPP*XLQ*FL1*FL2*( (WT2-XS2)*SH2/
23353 & (TH-XML2) + (WU2-XS2)*SH2/(UH-XML2) )
23354 FACSU=-2D0*REPRPZ*OLPP*XRQ*FR1*FR2*( (WT2-XS2)*SH2/
23355 & (TH-XMR2) + (WU2-XS2)*SH2/(UH-XMR2) )
23356 NCHN=NCHN+1
23357 ISIG(NCHN,1)=I
23358 ISIG(NCHN,2)=-I
23359 ISIG(NCHN,3)=1
23360 SIGH(NCHN)=FACGG1*FCOL*(FACS+FACT+FACU+FACST+FACSU)
23361 1700 CONTINUE
23362 ENDIF
23363
23364 ELSEIF(ISUB.LE.230) THEN
23365 IF(ISUB.EQ.226) THEN
23366C...f + fbar -> ~chi+_1 + ~chi-_1
23367 FACGG1=COMFAC*AEM**2/3D0/XW**2
23368 ZM12=SQM3
23369 ZM22=SQM4
23370 WU2 = (UH-ZM12)*(UH-ZM22)/SH2
23371 WT2 = (TH-ZM12)*(TH-ZM22)/SH2
23372 WS2 = SMW(IZID1)*SMW(IZID2)/SH
23373 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
23374 REPRPZ = (SH-SQMZ)/PROPZ2
23375 DIFF=0D0
23376 IF(IZID1.EQ.IZID2) DIFF=1D0
23377 DO 1710 I=MMINA,MMAXA
23378 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1710
23379 EI=KCHG(IABS(I),1)/3D0
23380 FCOL=1D0
23381 IF(IABS(I).GE.11) FCOL=3D0
23382 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
23383 XRQ=-EI*XW
23384 XLQ=XLQ/XW1
23385 XRQ=XRQ/XW1
23386 XLQ2=XLQ**2
23387 XRQ2=XRQ**2
23388 OLP=-VMIX(IZID1,1)*VMIX(IZID2,1)-
23389 & VMIX(IZID1,2)*VMIX(IZID2,2)/2D0+XW*DIFF
23390 ORP=-UMIX(IZID1,1)*UMIX(IZID2,1)-
23391 & UMIX(IZID1,2)*UMIX(IZID2,2)/2D0+XW*DIFF
23392 ORP2=ORP**2
23393 OLP2=OLP**2
23394C...u-type quark - d-type squark
23395 IF(MOD(I,2).EQ.0) THEN
23396 FACT0 = -UMIX(IZID1,1)*UMIX(IZID2,1)
23397 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
23398C...d-type quark - u-type squark
23399 ELSE
23400 FACT0 = VMIX(IZID1,1)*VMIX(IZID2,1)
23401 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2
23402 ENDIF
23403 FACA=2D0*XW**2*DIFF*(WT2+WU2+2D0*ABS(WS2))*EI**2
23404 FACZ=0.5D0*((XLQ2+XRQ2)*(OLP2+ORP2)*(WT2+WU2)+
23405 & 4D0*(XLQ2+XRQ2)*OLP*ORP*WS2-(XLQ2-XRQ2)*(OLP2-ORP2)*
23406 & (WU2-WT2))*SH2/PROPZ2
23407 FACT=FACT0**2/4D0*WT2*SH2/(TH-XML2)**2
23408 FACAZ=XW*REPRPZ*DIFF*( (XLQ+XRQ)*(OLP+ORP)*(WU2+
23409 & WT2+2D0*ABS(WS2))-(XLQ-XRQ)*(OLP-ORP)*(WU2-WT2) )*SH*(-EI)
23410 FACTA=XW*DIFF/(TH-XML2)*(WT2+ABS(WS2))*SH*FACT0*(-EI)
23411 FACTZ=REPRPZ/(TH-XML2)*XLQ*FACT0*(OLP*WT2+ORP*WS2)*SH2
23412 FACSUM=FACGG1*(FACA+FACAZ+FACZ+FACT+FACTA+FACTZ)*FCOL
23413 NCHN=NCHN+1
23414 ISIG(NCHN,1)=I
23415 ISIG(NCHN,2)=-I
23416 ISIG(NCHN,3)=1
23417 IF(IZID1.EQ.IZID2) THEN
23418 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
23419 ELSE
23420 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
23421 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
23422 NCHN=NCHN+1
23423 ISIG(NCHN,1)=I
23424 ISIG(NCHN,2)=-I
23425 ISIG(NCHN,3)=2
23426 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
23427 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
23428 ENDIF
23429 1710 CONTINUE
23430
23431 ELSEIF(ISUB.EQ.229) THEN
23432C...q + qbar' -> ~chi0_1 + ~chi+-_1
23433 FACGG1=COMFAC*AEM**2/6D0/XW**2
23434 ZM12=SQM3
23435 ZM22=SQM4
23436 ZMU2 = PMAS(PYCOMP(KSUSY1+2),1)**2
23437 ZMD2 = PMAS(PYCOMP(KSUSY1+1),1)**2
23438 WU2 = (UH-ZM12)*(UH-ZM22)/SH2
23439 WT2 = (TH-ZM12)*(TH-ZM22)/SH2
23440 WS2 = SMW(IZID1)*SMZ(IZID2)/SH
23441 RT2I = 1D0/SQRT(2D0)
23442 PROPW = ((SH-SQMW)**2+WWID**2*SQMW)
23443 OL=-RT2I*ZMIX(IZID2,4)*VMIX(IZID1,2)+
23444 & ZMIX(IZID2,2)*VMIX(IZID1,1)
23445 OR= RT2I*ZMIX(IZID2,3)*UMIX(IZID1,2)+
23446 & ZMIX(IZID2,2)*UMIX(IZID1,1)
23447 OL2=OL**2
23448 OR2=OR**2
23449 CROSS=2D0*OL*OR
23450 FACST0=UMIX(IZID1,1)
23451 FACSU0=VMIX(IZID1,1)
23452 FACSU0=FACSU0*(0.5D0*ZMIX(IZID2,2)+TANW*ZMIX(IZID2,1)/6D0)
23453 FACST0=FACST0*(-0.5D0*ZMIX(IZID2,2)+TANW*ZMIX(IZID2,1)/6D0)
23454 FACT0=FACST0**2
23455 FACU0=FACSU0**2
23456 FACTU0=FACSU0*FACST0
23457 FACST = -2D0*(SH-SQMW)/PROPW/(TH-ZMD2)*(WT2*SH2*OR
23458 & + SH2*WS2*OL)*FACST0
23459 FACSU = 2D0*(SH-SQMW)/PROPW/(UH-ZMU2)*(WU2*SH2*OL
23460 & + SH2*WS2*OR)*FACSU0
23461 FACT = WT2*SH2/(TH-ZMD2)**2*FACT0
23462 FACU = WU2*SH2/(UH-ZMU2)**2*FACU0
23463 FACTU = -2D0*WS2*SH2/(TH-ZMD2)/(UH-ZMU2)*FACTU0
23464 FACW = (OR2*WT2+OL2*WU2+CROSS*WS2)/PROPW*SH2
23465 FACGG1=FACGG1*(FACW+FACT+FACTU+FACU+FACSU+FACST)
23466 DO 1730 I=MMIN1,MMAX1
23467 IA=IABS(I)
23468 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 1730
23469 DO 1720 J=MMIN2,MMAX2
23470 JA=IABS(J)
23471 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 1720
23472 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1720
23473 FCKM=3D0
23474 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
23475 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
23476 KCHW=2
23477 IF(KCHSUM.LT.0) KCHW=3
23478 NCHN=NCHN+1
23479 ISIG(NCHN,1)=I
23480 ISIG(NCHN,2)=J
23481 ISIG(NCHN,3)=1
23482 SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
23483 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
23484 1720 CONTINUE
23485 1730 CONTINUE
23486 ENDIF
23487
23488 ELSEIF(ISUB.LE.240) THEN
23489 IF(ISUB.EQ.237) THEN
23490C...q + qbar -> gluino + ~chi0_1
23491 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
23492 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
23493 FAC0=COMFAC*AS*AEM*4D0/9D0/XW
23494 GM2=SQM3
23495 ZM2=SQM4
23496 DO 1740 I=MMINA,MMAXA
23497 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1740
23498 EI=KCHG(IABS(I),1)/3D0
23499 IA=IABS(I)
23500 XLQC = -TANW*EI*ZMIX(IZID,1)
23501 XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
23502 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
23503 XLQ2=XLQC**2
23504 XRQ2=XRQC**2
23505 XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2
23506 XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2
23507 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2
23508 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2
23509 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2)
23510 SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN)
23511 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2
23512 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2
23513 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2)
23514 SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN)
23515 NCHN=NCHN+1
23516 ISIG(NCHN,1)=I
23517 ISIG(NCHN,2)=-I
23518 ISIG(NCHN,3)=1
23519 SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR)
23520 1740 CONTINUE
23521 ENDIF
23522
23523 ELSEIF(ISUB.LE.250) THEN
23524 IF(ISUB.EQ.241) THEN
23525C...q + qbar' -> ~chi+-_1 + gluino
23526 FACWG=COMFAC*AS*AEM/XW*2D0/9D0
23527 GM2=SQM3
23528 ZM2=SQM4
23529 FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1)
23530 FAC0=UMIX(IZID,1)**2
23531 FAC1=VMIX(IZID,1)**2
23532 DO 1760 I=MMIN1,MMAX1
23533 IA=IABS(I)
23534 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 1760
23535 DO 1750 J=MMIN2,MMAX2
23536 JA=IABS(J)
23537 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 1750
23538 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1750
23539 FCKM=1D0
23540 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
23541 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
23542 KCHW=2
23543 IF(KCHSUM.LT.0) KCHW=3
23544 XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2
23545 XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2
23546 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2
23547 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2
23548 ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2)
23549 XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2
23550 XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2
23551 ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0
23552 AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0
23553 ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)*
23554 & SH/(TH-XMU2)/(UH-XMD2))/2D0
23555 NCHN=NCHN+1
23556 ISIG(NCHN,1)=I
23557 ISIG(NCHN,2)=J
23558 ISIG(NCHN,3)=1
23559 SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN-
23560 & FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
23561 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
23562 1750 CONTINUE
23563 1760 CONTINUE
23564
23565 ELSEIF(ISUB.EQ.243) THEN
23566C...q + qbar -> gluino + gluino
23567 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
23568 XMT=SQM3-TH
23569 XMU=SQM3-UH
23570 DO 1770 I=MMINA,MMAXA
23571 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
23572 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1770
23573 NCHN=NCHN+1
23574 XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH
23575 XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH
23576 FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
23577 & 2D0*SQM3*SH)/SH2 +4D0/9D0*(XMT**2/XST**2+
23578 & XMU**2/XSU**2) - (XMT**2+SH*SQM3)/SH/XST +
23579 & SQM3*SH/XST/XSU/9D0- (XMU**2+SH*SQM3)/SH/XSU )
23580 XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
23581 XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
23582 FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
23583 & 2D0*SQM3*SH)/SH2 +4D0/9D0*(XMT**2/XST**2+
23584 & XMU**2/XSU**2) - (XMT**2+SH*SQM3)/SH/XST +
23585 & SQM3*SH/XST/XSU/9D0- (XMU**2+SH*SQM3)/SH/XSU )
23586 ISIG(NCHN,1)=I
23587 ISIG(NCHN,2)=-I
23588 ISIG(NCHN,3)=1
23589C...1/2 for identical particles
23590 SIGH(NCHN)=0.25D0*(FACGG1+FACGG2)
23591 1770 CONTINUE
23592
23593 ELSEIF(ISUB.EQ.244) THEN
23594C...g + g -> gluino + gluino
23595 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
23596 XMT=SQM3-TH
23597 XMU=SQM3-UH
23598 FACQQ1=COMFAC*AS**2*9D0/4D0*(
23599 & (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 -
23600 & (XMT*XMU+SQM3*(UH-TH))/SH/XMT )
23601 FACQQ2=COMFAC*AS**2*9D0/4D0*(
23602 & (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 -
23603 & (XMU*XMT+SQM3*(TH-UH))/SH/XMU )
23604 FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 +
23605 & SQM3*(SH-4D0*SQM3)/XMT/XMU)
23606 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1780
23607 NCHN=NCHN+1
23608 ISIG(NCHN,1)=21
23609 ISIG(NCHN,2)=21
23610 ISIG(NCHN,3)=1
23611 SIGH(NCHN)=FACQQ1/2D0
23612 NCHN=NCHN+1
23613 ISIG(NCHN,1)=21
23614 ISIG(NCHN,2)=21
23615 ISIG(NCHN,3)=2
23616 SIGH(NCHN)=FACQQ2/2D0
23617 NCHN=NCHN+1
23618 ISIG(NCHN,1)=21
23619 ISIG(NCHN,2)=21
23620 ISIG(NCHN,3)=3
23621 SIGH(NCHN)=FACQQ3/2D0
23622 1780 CONTINUE
23623
23624 ELSEIF(ISUB.EQ.246) THEN
23625C...g + q_j -> ~chi0_1 + ~q_j
23626 FAC0=COMFAC*AS*AEM/6D0/XW
23627 ZM2=SQM4
23628 QM2=SQM3
23629 FACZQ0=FAC0*( (ZM2-TH)/SH +
23630 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
23631 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
23632 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
23633 DO 1800 I=-KFNSQ,KFNSQ,2*KFNSQ
23634 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 1800
23635 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1800
23636 EI=KCHG(IABS(I),1)/3D0
23637 IA=IABS(I)
23638 XRQZ = -TANW*EI*ZMIX(IZID,1)
23639 XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
23640 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
23641 IF(ILR.EQ.0) THEN
23642 BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2
23643 ELSE
23644 BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2
23645 ENDIF
23646 FACZQ=FACZQ0*BS
23647 KCHQ=2
23648 IF(I.LT.0) KCHQ=3
23649 DO 1790 ISDE=1,2
23650 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1790
23651 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1790
23652 NCHN=NCHN+1
23653 ISIG(NCHN,ISDE)=I
23654 ISIG(NCHN,3-ISDE)=21
23655 ISIG(NCHN,3)=1
23656 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
23657 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
23658 1790 CONTINUE
23659 1800 CONTINUE
23660 ENDIF
23661
23662 ELSEIF(ISUB.LE.260) THEN
23663 IF(ISUB.EQ.254) THEN
23664C...g + q_j -> ~chi1_1 + ~q_i
23665 FAC0=COMFAC*AS*AEM/12D0/XW
23666 ZM2=SQM4
23667 QM2=SQM3
23668 AU=UMIX(IZID,1)**2
23669 AD=VMIX(IZID,1)**2
23670 FACZQ0=FAC0*( (ZM2-TH)/SH +
23671 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
23672 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
23673 KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1)
23674 IF(MOD(KFNSQ1,2).EQ.0) THEN
23675 KFNSQ=KFNSQ1-1
23676 KCHW=2
23677 ELSE
23678 KFNSQ=KFNSQ1+1
23679 KCHW=3
23680 ENDIF
23681 DO 1820 I=-KFNSQ,KFNSQ,2*KFNSQ
23682 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 1820
23683 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1820
23684 IA=IABS(I)
23685 IF(MOD(IA,2).EQ.0) THEN
23686 FACZQ=FACZQ0*AU
23687 ELSE
23688 FACZQ=FACZQ0*AD
23689 ENDIF
23690 FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2
23691 KCHQ=2
23692 IF(I.LT.0) KCHQ=3
23693 KCHWQ=KCHW
23694 IF(I.LT.0) KCHWQ=5-KCHW
23695 DO 1810 ISDE=1,2
23696 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1810
23697 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1810
23698 NCHN=NCHN+1
23699 ISIG(NCHN,ISDE)=I
23700 ISIG(NCHN,3-ISDE)=21
23701 ISIG(NCHN,3)=1
23702 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
23703 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ)
23704 1810 CONTINUE
23705 1820 CONTINUE
23706
23707 ELSEIF(ISUB.EQ.258) THEN
23708C...g + q_j -> gluino + ~q_i
23709 XG2=SQM4
23710 XQ2=SQM3
23711 XMT=XG2-TH
23712 XMU=XG2-UH
23713 XST=XQ2-TH
23714 XSU=XQ2-UH
23715 FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 -
23716 & ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) +
23717 & 0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) +
23718 & (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU
23719 FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0*
23720 & (SH*(UH+XG2)
23721 & +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH +
23722 & 0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+
23723 & (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU
23724 FACQG1=COMFAC*AS**2*FACQG1/2D0
23725 FACQG2=COMFAC*AS**2*FACQG2/2D0
23726 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
23727 DO 1840 I=-KFNSQ,KFNSQ,2*KFNSQ
23728 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 1840
23729 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 1840
23730 KCHQ=2
23731 IF(I.LT.0) KCHQ=3
23732 FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
23733 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
23734 DO 1830 ISDE=1,2
23735 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1830
23736 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1830
23737 NCHN=NCHN+1
23738 ISIG(NCHN,ISDE)=I
23739 ISIG(NCHN,3-ISDE)=21
23740 ISIG(NCHN,3)=1
23741 SIGH(NCHN)=FACQG1*FACSEL
23742 NCHN=NCHN+1
23743 ISIG(NCHN,ISDE)=I
23744 ISIG(NCHN,3-ISDE)=21
23745 ISIG(NCHN,3)=2
23746 SIGH(NCHN)=FACQG2*FACSEL
23747 1830 CONTINUE
23748 1840 CONTINUE
23749 ENDIF
23750
23751 ELSEIF(ISUB.LE.270) THEN
23752 IF(ISUB.EQ.261) THEN
23753C...q_i + q_ibar -> ~t_1 + ~t_1bar
23754 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )*
23755 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
23756 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
23757 FAC0=AS**2*4D0/9D0
23758 DO 1850 I=MMIN1,MMAX1
23759 IA=IABS(I)
23760 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1850
23761 IF(IA.GE.11.AND.IA.LE.18) THEN
23762 EI=KCHG(IA,1)/3D0
23763 EJ=KCHG(KFNSQ,1)/3D0
23764 T3I=SIGN(1D0,EI)/2D0
23765 T3J=SIGN(1D0,EJ)/2D0
23766 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2
23767 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2
23768 XLF=2D0*(T3I-EI*XW)
23769 XRF=2D0*(-EI*XW)
23770 TAA=0.5D0*(EI*EJ)**2
23771 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
23772 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
23773 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
23774 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
23775 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
23776 ENDIF
23777 NCHN=NCHN+1
23778 ISIG(NCHN,1)=I
23779 ISIG(NCHN,2)=-I
23780 ISIG(NCHN,3)=1
23781 SIGH(NCHN)=FACQQ1*FAC0
23782 1850 CONTINUE
23783
23784 ELSEIF(ISUB.EQ.263) THEN
23785C...f + fbar -> ~t1 + ~t2bar
23786 DO 1860 I=MMIN1,MMAX1
23787 IA=IABS(I)
23788 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1860
23789 EI=KCHG(IABS(I),1)/3D0
23790 TT3I=SIGN(1D0,EI)/2D0
23791 EJ=2D0/3D0
23792 TT3J=1D0/2D0
23793 FCOL=1D0
23794C...Color factor for e+ e-
23795 IF(IA.GE.11) FCOL=3D0
23796 XLQ=2D0*(TT3J-EJ*XW)
23797 XRQ=2D0*(-EJ*XW)
23798 XLF=2D0*(TT3I-EI*XW)
23799 XRF=2D0*(-EI*XW)
23800 TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2
23801 TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2
23802 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
23803C...Factor of 2 for t1 t2bar + t2 t1bar
23804 FACQQ1=2D0*COMFAC*AEM**2*TZZ*FCOL*4D0
23805 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2
23806 NCHN=NCHN+1
23807 ISIG(NCHN,1)=I
23808 ISIG(NCHN,2)=-I
23809 ISIG(NCHN,3)=1
23810 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
23811 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
23812 NCHN=NCHN+1
23813 ISIG(NCHN,1)=I
23814 ISIG(NCHN,2)=-I
23815 ISIG(NCHN,3)=2
23816 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
23817 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
23818 1860 CONTINUE
23819
23820 ELSEIF(ISUB.EQ.264) THEN
23821C...g + g -> ~t_1 + ~t_1bar
23822 XSU=SQM3-UH
23823 XST=SQM3-TH
23824 FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0*
23825 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
23826 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
23827 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
23828 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1870
23829 NCHN=NCHN+1
23830 ISIG(NCHN,1)=21
23831 ISIG(NCHN,2)=21
23832 ISIG(NCHN,3)=1
23833 SIGH(NCHN)=FACQQ1
23834 NCHN=NCHN+1
23835 ISIG(NCHN,1)=21
23836 ISIG(NCHN,2)=21
23837 ISIG(NCHN,3)=2
23838 SIGH(NCHN)=FACQQ2
23839 1870 CONTINUE
23840 ENDIF
23841
23842 ELSEIF(ISUB.LE.280) THEN
23843 IF(ISUB.EQ.271) THEN
23844C...q + q' -> ~q + ~q' (~g exchange)
23845 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
23846 XMT=XMG2-TH
23847 XMU=XMG2-UH
23848 XSU1=SQM3-UH
23849 XSU2=SQM4-UH
23850 XST1=SQM3-TH
23851 XST2=SQM4-TH
23852 IF(ILR.EQ.1) THEN
23853 FACQQ1=COMFAC*AS**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 )
23854 FACQQ2=COMFAC*AS**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 )
23855 FACQQB=0.0D0
23856 ELSE
23857 FACQQ1=0.5D0*COMFAC*AS**2*4D0/9D0*( SH*XMG2/XMT**2 )
23858 FACQQ2=0.5D0*COMFAC*AS**2*4D0/9D0*( SH*XMG2/XMU**2 )
23859 FACQQB=0.5D0*COMFAC*AS**2*4D0/9D0*( -2D0*SH*XMG2/3D0/
23860 & XMT/XMU )
23861 ENDIF
23862 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
23863 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
23864 DO 1890 I=-KFNSQI,KFNSQI,2*KFNSQI
23865 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 1890
23866 IA=IABS(I)
23867 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 1890
23868 KCHQ=2
23869 IF(I.LT.0) KCHQ=3
23870 DO 1880 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
23871 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 1880
23872 JA=IABS(J)
23873 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 1880
23874 IF(I*J.LT.0) GOTO 1880
23875 NCHN=NCHN+1
23876 ISIG(NCHN,1)=I
23877 ISIG(NCHN,2)=J
23878 ISIG(NCHN,3)=1
23879 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
23880 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
23881 IF(I.EQ.J) THEN
23882 IF(ILR.EQ.0) THEN
23883 SIGH(NCHN)=0.5D0*(FACQQ1+0.5D0*FACQQB)*RKF*
23884 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
23885 ELSE
23886 SIGH(NCHN)=0.5D0*FACQQ1*RKF*
23887 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
23888 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
23889 ENDIF
23890 NCHN=NCHN+1
23891 ISIG(NCHN,1)=I
23892 ISIG(NCHN,2)=J
23893 ISIG(NCHN,3)=2
23894 IF(ILR.EQ.0) THEN
23895 SIGH(NCHN)=0.5D0*(FACQQ2+0.5D0*FACQQB)*RKF*
23896 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
23897 ELSE
23898 SIGH(NCHN)=0.5D0*FACQQ2*RKF*
23899 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
23900 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
23901 ENDIF
23902 ENDIF
23903 1880 CONTINUE
23904 1890 CONTINUE
23905
23906 ELSEIF(ISUB.EQ.274) THEN
23907C...q + qbar' -> ~q + ~qbar'
23908 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
23909 XMT=XMG2-TH
23910 XMU=XMG2-UH
23911 IF(ILR.EQ.0) THEN
23912C...Mrenna...Normalization.and.1/XMT
23913 FACQQ1=COMFAC*AS**2*2D0/9D0*(
23914 & (UH*TH-SQM3*SQM4)/XMT**2 )
23915 FACQQB=COMFAC*AS**2*2D0/9D0*(
23916 & (UH*TH-SQM3*SQM4)/SH2*(2D0-2D0/3D0*SH/XMT))
23917 FACQQB=FACQQB+FACQQ1
23918 ELSE
23919 FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )
23920 FACQQB=FACQQ1
23921 ENDIF
23922 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
23923 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
23924 DO 1910 I=-KFNSQI,KFNSQI,2*KFNSQI
23925 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 1910
23926 IA=IABS(I)
23927 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 1910
23928 KCHQ=2
23929 IF(I.LT.0) KCHQ=3
23930 DO 1900 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
23931 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 1900
23932 JA=IABS(J)
23933 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 1900
23934 IF(I*J.GT.0) GOTO 1900
23935 NCHN=NCHN+1
23936 ISIG(NCHN,1)=I
23937 ISIG(NCHN,2)=J
23938 ISIG(NCHN,3)=1
23939 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
23940 & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
23941 IF(I.EQ.-J) SIGH(NCHN)=FACQQB*RKF*
23942 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
23943 1900 CONTINUE
23944 1910 CONTINUE
23945
23946 ELSEIF(ISUB.EQ.277) THEN
23947C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
23948C...if i .eq. j covered in 274
23949 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )
23950 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
23951 FAC0=0D0
23952 DO 1920 I=MMIN1,MMAX1
23953 IA=IABS(I)
23954 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.
23955 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1920
23956 IF(IA.EQ.KFNSQ) GOTO 1920
23957 IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN
23958 EI=KCHG(IA,1)/3D0
23959 EJ=KCHG(KFNSQ,1)/3D0
23960 T3J=SIGN(0.5D0,EJ)
23961 T3I=SIGN(1D0,EI)/2D0
23962 IF(ILR.EQ.0) THEN
23963 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1)
23964 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2)
23965 ELSE
23966 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3)
23967 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4)
23968 ENDIF
23969 XLF=2D0*(T3I-EI*XW)
23970 XRF=2D0*(-EI*XW)
23971 IF(ILR.EQ.0) THEN
23972 XRQ=0D0
23973 ELSE
23974 XLQ=0D0
23975 ENDIF
23976 TAA=0.5D0*(EI*EJ)**2
23977 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
23978 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
23979 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
23980 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
23981 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
23982 ELSEIF(IA.LE.6) THEN
23983 FAC0=AS**2*8D0/9D0/2D0
23984 ENDIF
23985 NCHN=NCHN+1
23986 ISIG(NCHN,1)=I
23987 ISIG(NCHN,2)=-I
23988 ISIG(NCHN,3)=1
23989 SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
23990 1920 CONTINUE
23991
23992 ELSEIF(ISUB.EQ.279) THEN
23993C...g + g -> ~q_j + ~q_jbar
23994 XSU=SQM3-UH
23995 XST=SQM3-TH
23996C...5=RKF because ~t ~tbar treated separately
23997 FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )
23998 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
23999 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
24000 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1930
24001 NCHN=NCHN+1
24002 ISIG(NCHN,1)=21
24003 ISIG(NCHN,2)=21
24004 ISIG(NCHN,3)=1
24005 SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
24006 NCHN=NCHN+1
24007 ISIG(NCHN,1)=21
24008 ISIG(NCHN,2)=21
24009 ISIG(NCHN,3)=2
24010 SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
24011 1930 CONTINUE
24012
24013 ENDIF
24014CMRENNA--
24015
24016 ELSEIF(ISUB.LE.340) THEN
24017
24018 ELSEIF(ISUB.LE.360) THEN
24019
24020 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
24021C...l + l -> H_L++/-- or H_R++/--.
24022 KFRES=KFPR(ISUB,1)
24023 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
24024 HS=SHR*WDTP(0)
24025 FACBW=8D0*COMFAC/((SH-PMAS(KFRES,1)**2)**2+HS**2)
24026 DO 1950 I=MMIN1,MMAX1
24027 IA=IABS(I)
24028 IF((IA.NE.11.AND.IA.NE.13.AND.IA.NE.15).OR.KFAC(1,I).EQ.0)
24029 & GOTO 1950
24030 DO 1940 J=MMIN2,MMAX2
24031 JA=IABS(J)
24032 IF((JA.NE.11.AND.JA.NE.13.AND.JA.NE.15).OR.KFAC(2,J).EQ.0)
24033 & GOTO 1940
24034 IF(I*J.LT.0) GOTO 1940
24035 KCHH=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
24036 NCHN=NCHN+1
24037 ISIG(NCHN,1)=I
24038 ISIG(NCHN,2)=J
24039 ISIG(NCHN,3)=1
24040 HI=SH*PARP(181+3*((IA-11)/2)+(JA-11)/2)**2/(8D0*PARU(1))
24041 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
24042 SIGH(NCHN)=HI*FACBW*HF
24043 1940 CONTINUE
24044 1950 CONTINUE
24045
24046 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
24047C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'.
24048 KFRES=KFPR(ISUB,1)
24049C...Propagators: as simulated in PYOFSH and as desired
24050 HBW3=PMAS(KFRES,1)*PMAS(KFRES,2)/((SQM3-PMAS(KFRES,1)**2)**2+
24051 & (PMAS(KFRES,1)*PMAS(KFRES,2))**2)
24052 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
24053 GMMC=SQRT(SQM3)*WDTP(0)
24054 HBW3C=GMMC/((SQM3-PMAS(KFRES,1)**2)**2+GMMC**2)
24055 FHCC=COMFAC*AEM*HBW3C/HBW3
24056 DO 1980 I=MMINA,MMAXA
24057 IA=IABS(I)
24058 IF(IA.NE.11.AND.IA.NE.13.AND.IA.NE.15) GOTO 1980
24059 SQML=PMAS(IA,1)**2
24060 J=ISIGN(KFPR(ISUB,2),-I)
24061 KCHH=ISIGN(2,KCHG(IA,1)*ISIGN(1,I))
24062 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))/WDTP(0)
24063 SMM1=8D0*(SH+TH-SQM3)*(SH+TH-2D0*SQM3-SQML-SQM4)/
24064 & (UH-SQM3)**2
24065 SMM2=2D0*((2D0*SQM3-3D0*SQML)*SQM4+(SQML-2D0*SQM4)*TH-
24066 & (TH-SQM4)*SH)/(TH-SQM4)**2
24067 SMM3=2D0*((2D0*SQM3-3D0*SQM4+TH)*SQML-(2D0*SQML-SQM4+TH)*
24068 & SH)/(SH-SQML)**2
24069 SMM12=4D0*((2D0*SQML-SQM4-2D0*SQM3+TH)*SH+(TH-3D0*SQM3-
24070 & 3D0*SQM4)*TH+(2D0*SQM3-2D0*SQML+3D0*SQM4)*SQM3)/
24071 & ((UH-SQM3)*(TH-SQM4))
24072 SMM13=-4D0*((TH+SQML-2D0*SQM4)*TH-(SQM3+3D0*SQML-2D0*SQM4)*
24073 & SQM3+(SQM3+3D0*SQML+TH)*SH-(TH-SQM3+SH)**2)/
24074 & ((UH-SQM3)*(SH-SQML))
24075 SMM23=-4D0*((SQML-SQM4+SQM3)*TH-SQM3**2+SQM3*(SQML+SQM4)-
24076 & 3D0*SQML*SQM4-(SQML-SQM4-SQM3+TH)*SH)/
24077 & ((SH-SQML)*(TH-SQM4))
24078 SMM=(SH/(SH-SQML))**2*(SMM1+SMM2+SMM3+SMM12+SMM13+SMM23)*
24079 & PARP(181+3*((IA-11)/2)+(IABS(J)-11)/2)**2/(4D0*PARU(1))
24080 DO 1960 ISDE=1,2
24081 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 1960
24082 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 1960
24083 NCHN=NCHN+1
24084 ISIG(NCHN,ISDE)=I
24085 ISIG(NCHN,3-ISDE)=22
24086 ISIG(NCHN,3)=0
24087 SIGH(NCHN)=FHCC*SMM*WIDSC
24088 1960 CONTINUE
24089 1980 CONTINUE
24090
24091 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
24092C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R--
24093 KFRES=KFPR(ISUB,1)
24094 SQMH=PMAS(KFRES,1)**2
24095 GMMH=PMAS(KFRES,1)*PMAS(KFRES,2)
24096C...Propagators: H++/-- as simulated in PYOFSH and as desired
24097 HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2)
24098 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
24099 GMMH3=SQRT(SQM3)*WDTP(0)
24100 HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2)
24101 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
24102 CALL PYWIDT(KFRES,SQM4,WDTP,WDTE)
24103 GMMH4=SQRT(SQM4)*WDTP(0)
24104 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
24105C...Kinematical and coupling functions
24106 FACHH=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*(TH*UH-SQM3*SQM4)
24107 XWHH=(1D0-2D0*XWV)/(8D0*XWV*(1D0-XWV))
24108C...Loop over allowed flavours
24109 DO 2000 I=MMINA,MMAXA
24110 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2000
24111 EI=KCHG(IABS(I),1)/3D0
24112 AI=SIGN(1D0,EI+0.1D0)
24113 VI=AI-4D0*EI*XWV
24114 FCOI=1D0
24115 IF(IABS(I).LE.10) FCOI=FACA/3D0
24116 IF(ISUB.EQ.349) THEN
24117 HBWZ=1D0/((SH-SQMZ)**2+GMMZ**2)
24118 IF(IABS(I).LT.10) THEN
24119 DSIGHH=8D0*AEM**2*(EI**2/SH2+
24120 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
24121 & (VI**2+AI**2)*XWHH**2*HBWZ)
24122 ELSE
24123 IAOFF=181+3*((IABS(I)-11)/2)
24124 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
24125 & (4D0*PARU(1))
24126 DSIGHH=8D0*AEM**2*(EI**2/SH2+
24127 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
24128 & (VI**2+AI**2)*XWHH**2*HBWZ)+
24129 & 8D0*AEM*(EI*HSUM/(SH*TH)+
24130 & (VI+AI)*XWHH*HSUM*(SH-SQMZ)*HBWZ/TH)+
24131 & 4D0*HSUM**2/TH2
24132 ENDIF
24133 ELSE
24134 IF(IABS(I).LT.10) THEN
24135 DSIGHH=8D0*AEM**2*EI**2/SH2
24136 ELSE
24137 IAOFF=181+3*((IABS(I)-11)/2)
24138 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
24139 & (4D0*PARU(1))
24140 DSIGHH=8D0*AEM**2*EI**2/SH2+8D0*AEM*EI*HSUM/(SH*TH)+
24141 & 4D0*HSUM**2/TH2
24142 ENDIF
24143 ENDIF
24144 NCHN=NCHN+1
24145 ISIG(NCHN,1)=I
24146 ISIG(NCHN,2)=-I
24147 ISIG(NCHN,3)=1
24148 SIGH(NCHN)=FACHH*FCOI*DSIGHH
24149 2000 CONTINUE
24150
24151 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
24152C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process)
24153 KFRES=KFPR(ISUB,1)
24154 SQMH=PMAS(KFRES,1)**2
24155 IF(ISUB.EQ.351) FACNOR=PARP(190)**8*PARP(192)**2
24156 IF(ISUB.EQ.352) FACNOR=PARP(191)**6*2D0*PMAS(63,1)**2
24157 FACWW=COMFAC*FACNOR*TAUP*VINT(2)*VINT(219)
24158 FACPRT=1D0/((VINT(204)**2-VINT(215))*
24159 & (VINT(209)**2-VINT(216)))
24160 FACPRU=1D0/((VINT(204)**2+2D0*VINT(217))*
24161 & (VINT(209)**2+2D0*VINT(218)))
24162 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
24163 HS=SHR*WDTP(0)
24164 FACBW=(1D0/PARU(1))*VINT(2)/((SH-SQMH)**2+HS**2)
24165 IF(ABS(SHR-PMAS(KFRES,1)).GT.PARP(48)*PMAS(KFRES,2))
24166 & FACBW=0D0
24167 DO 2020 I=MMIN1,MMAX1
24168 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 2020
24169 IF(ISUB.EQ.352.AND.IABS(I).GT.10) GOTO 2020
24170 KCHWI=(1-2*MOD(IABS(I),2))*ISIGN(1,I)
24171 DO 2010 J=MMIN2,MMAX2
24172 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 2010
24173 IF(ISUB.EQ.352.AND.IABS(J).GT.10) GOTO 2010
24174 KCHWJ=(1-2*MOD(IABS(J),2))*ISIGN(1,J)
24175 KCHH=KCHWI+KCHWJ
24176 IF(IABS(KCHH).NE.2) GOTO 2010
24177 FACLR=VINT(180+I)*VINT(180+J)
24178 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
24179 IF(I.EQ.J.AND.IABS(I).GT.10) THEN
24180 FACPRP=0.5D0*(FACPRT+FACPRU)**2
24181 ELSE
24182 FACPRP=FACPRT**2
24183 ENDIF
24184 NCHN=NCHN+1
24185 ISIG(NCHN,1)=I
24186 ISIG(NCHN,2)=J
24187 ISIG(NCHN,3)=1
24188 SIGH(NCHN)=FACLR*FACWW*FACPRP*FACBW*HF
24189 2010 CONTINUE
24190 2020 CONTINUE
24191 ENDIF
24192
24193 ELSEIF(ISUB.LE.380) THEN
24194
24195 IF(ISUB.EQ.361) THEN
24196C...f + fbar -> W_L W_L, W_L pi_tech, pi_tech pi_tech
24197 FACA=(SH**2*BE34**2-(TH-UH)**2)
24198 ALPRHT=2.91D0*(3D0/PARP(144))
24199 HP=(1D0/12D0)*AEM*ALPRHT*CAB2*COMFAC*FACA*3D0
24200 FAR=SQRT(AEM/ALPRHT)
24201 FAO=FAR*QUPD
24202 FZR=FAR*CT2W
24203 FZO=-FAO*TANW
24204 SFAR=FAR**2
24205 SFAO=FAO**2
24206 SFZR=FZR**2
24207 SFZO=FZO**2
24208 CALL PYWIDT(23,SH,WDTP,WDTE)
24209 SSMZ=CMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
24210 CALL PYWIDT(54,SH,WDTP,WDTE)
24211 SSMR=CMPLX(1D0-PMAS(54,1)**2/SH,WDTP(0)/SHR)
24212 CALL PYWIDT(56,SH,WDTP,WDTE)
24213 SSMO=CMPLX(1D0-PMAS(56,1)**2/SH,WDTP(0)/SHR)
24214 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
24215 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
24216 DARHO=(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)/DETD/SH
24217 DZRHO=(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH
24218
24219 DO 2040 I=MMINA,MMAXA
24220 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2040
24221 IA=IABS(I)
24222 EI=KCHG(IABS(I),1)/3D0
24223 AI=SIGN(1D0,EI+0.1D0)
24224 VI=AI-4D0*EI*XWV
24225 VALI=0.25D0*(VI+AI)
24226 VARI=0.25D0*(VI-AI)
24227 F2L=EI*DARHO+VALI*DZRHO/SQRT(XW*XW1)
24228 F2R=EI*DARHO+VARI*DZRHO/SQRT(XW*XW1)
24229 HI=ABS(F2L)**2+ABS(F2R)**2
24230 IF(IA.LE.10) HI=HI/3D0
24231 NCHN=NCHN+1
24232 ISIG(NCHN,1)=I
24233 ISIG(NCHN,2)=-I
24234 ISIG(NCHN,3)=1
24235 IF(KFA.EQ.KFB) THEN
24236 SIGH(NCHN)=HI*HP*WIDS(KFA,1)
24237 ELSE
24238 SIGH(NCHN)=HI*HP*WIDS(KFA,2)*WIDS(KFB,3)
24239 NCHN=NCHN+1
24240 ISIG(NCHN,1)=I
24241 ISIG(NCHN,2)=-I
24242 ISIG(NCHN,3)=2
24243 SIGH(NCHN)=HI*HP*WIDS(KFA,3)*WIDS(KFB,2)
24244 ENDIF
24245 2040 CONTINUE
24246
24247 ELSEIF(ISUB.EQ.364) THEN
24248C...f + fbar -> gamma pi_tech, gamma pi_tech', Z pi_tech, Z pi_tech',
24249C...W pi_tech
24250 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)/SQTV*SH
24251 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)/SQTA*SH
24252
24253 ALPRHT=2.91D0*(3D0/PARP(144))
24254 HP=(1D0/24D0)*AEM**2*COMFAC*3D0
24255 FAR=SQRT(AEM/ALPRHT)
24256 FAO=FAR*QUPD
24257 FZR=FAR*CT2W
24258 FZO=-FAO*TANW
24259 SFAR=FAR**2
24260 SFAO=FAO**2
24261 SFZR=FZR**2
24262 SFZO=FZO**2
24263 CALL PYWIDT(23,SH,WDTP,WDTE)
24264 SSMZ=CMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
24265 CALL PYWIDT(54,SH,WDTP,WDTE)
24266 SSMR=CMPLX(1D0-PMAS(54,1)**2/SH,WDTP(0)/SHR)
24267 CALL PYWIDT(56,SH,WDTP,WDTE)
24268 SSMO=CMPLX(1D0-PMAS(56,1)**2/SH,WDTP(0)/SHR)
24269 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
24270 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
24271 DARHO=(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)/DETD/SH
24272 DZRHO=(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH
24273 DAOME=(-FAO*SFZR+FAR*FZO*FZR+FAO*SSMR*SSMZ)/DETD/SH
24274 DZOME=(-FZO*SFAR+FAR*FAO*FZR+FZO*SSMR)/DETD/SH
24275
24276 DO 2060 I=MMINA,MMAXA
24277 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2060
24278 IA=IABS(I)
24279 EI=KCHG(IABS(I),1)/3D0
24280 AI=SIGN(1D0,EI+0.1D0)
24281 VI=AI-4D0*EI*XWV
24282 VALI=0.25D0*(VI+AI)
24283 VARI=0.25D0*(VI-AI)
24284 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*VRGP
24285 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*VOGP
24286 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*VRGP
24287 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*VOGP
24288 HI=(ABS(F2L)**2+ABS(F2R)**2)*VFAC
24289 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*ARGP
24290 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*AOGP
24291 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*ARGP
24292 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*AOGP
24293 HJ=(ABS(F2L)**2+ABS(F2R)**2)*AFAC
24294 HI=HI+HJ
24295 IF(IA.LE.10) HI=HI/3D0
24296 NCHN=NCHN+1
24297 ISIG(NCHN,1)=I
24298 ISIG(NCHN,2)=-I
24299 ISIG(NCHN,3)=1
24300 IF(ISUBSV.NE.368) THEN
24301 SIGH(NCHN)=HI*HP*WIDS(KFA,2)*WIDS(KFB,2)
24302 ELSE
24303 SIGH(NCHN)=HI*HP*WIDS(KFA,2)*WIDS(KFB,3)
24304 NCHN=NCHN+1
24305 ISIG(NCHN,1)=I
24306 ISIG(NCHN,2)=-I
24307 ISIG(NCHN,3)=2
24308 SIGH(NCHN)=HI*HP*WIDS(KFA,3)*WIDS(KFB,2)
24309 ENDIF
24310 2060 CONTINUE
24311
24312 ELSEIF(ISUB.EQ.370) THEN
24313C...f + fbar' -> W_L Z_L, W_L pi_tech, Z_L pi_tech, pi_tech pi_tech
24314
24315 FACA=(SH**2*BE34**2-(TH-UH)**2)
24316 ALPRHT=2.91D0*(3D0/PARP(144))
24317 HP=(1D0/24D0)*AEM*ALPRHT*CAB2*COMFAC*FACA*3D0/XW
24318
24319 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
24320 CALL PYWIDT(24,SH,WDTP,WDTE)
24321 SSMZ=CMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
24322 CALL PYWIDT(55,SH,WDTP,WDTE)
24323 SSMR=CMPLX(1D0-PMAS(55,1)**2/SH,WDTP(0)/SHR)
24324
24325 DETD=SSMZ*SSMR-CMPLX(FWR**2,0D0)
24326 HP=HP*FWR**2/ABS(DETD)**2/SH**2
24327
24328 DO 2080 I=MMIN1,MMAX1
24329 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 2080
24330 IA=IABS(I)
24331 DO 2070 J=MMIN2,MMAX2
24332 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 2070
24333 JA=IABS(J)
24334 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 2070
24335 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
24336 & GOTO 2070
24337 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
24338 HI=HP
24339 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
24340 NCHN=NCHN+1
24341 ISIG(NCHN,1)=I
24342 ISIG(NCHN,2)=J
24343 ISIG(NCHN,3)=1
24344 SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,2)
24345 2070 CONTINUE
24346 2080 CONTINUE
24347
24348 ELSEIF(ISUB.EQ.374) THEN
24349C...f + fbar' -> G pi_tech
24350 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)/SQTV*VRGP**2
24351 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)/SQTA*ARGP**2
24352
24353 ALPRHT=2.91D0*(3D0/PARP(144))
24354 HP=(1D0/48D0)*AEM**2/XW*COMFAC*3D0*(VFAC+AFAC)*SH
24355
24356 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
24357 CALL PYWIDT(24,SH,WDTP,WDTE)
24358 SSMZ=CMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
24359 CALL PYWIDT(55,SH,WDTP,WDTE)
24360 SSMR=CMPLX(1D0-PMAS(55,1)**2/SH,WDTP(0)/SHR)
24361
24362 DETD=SSMZ*SSMR-CMPLX(FWR**2,0D0)
24363 HP=HP*FWR**2/ABS(DETD)**2/SH**2
24364
24365 DO 2100 I=MMIN1,MMAX1
24366 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 2100
24367 IA=IABS(I)
24368 DO 2090 J=MMIN2,MMAX2
24369 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 2090
24370 JA=IABS(J)
24371 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 2090
24372 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
24373 & GOTO 2090
24374 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
24375 HI=HP
24376 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
24377 NCHN=NCHN+1
24378 ISIG(NCHN,1)=I
24379 ISIG(NCHN,2)=J
24380 ISIG(NCHN,3)=1
24381 SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,2)
24382 2090 CONTINUE
24383 2100 CONTINUE
24384
24385 ENDIF
24386 ENDIF
24387
24388C...Multiply with parton distributions
24389 IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
24390 DO 2200 ICHN=1,NCHN
24391 IF(MINT(45).GE.2) THEN
24392 KFL1=ISIG(ICHN,1)
24393 SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
24394 ENDIF
24395 IF(MINT(46).GE.2) THEN
24396 KFL2=ISIG(ICHN,2)
24397 SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
24398 ENDIF
24399 SIGS=SIGS+SIGH(ICHN)
24400 2200 CONTINUE
24401 ENDIF
24402
24403 RETURN
24404 END
24405
24406C*********************************************************************
24407
24408C...PYPDFU
24409C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon
24410C...parton distributions according to a few different parametrizations.
24411C...Note that what is coded is x times the probability distribution,
24412C...i.e. xq(x,Q2) etc.
24413
24414 SUBROUTINE PYPDFU(KF,X,Q2,XPQ)
24415
24416C...Double precision and integer declarations.
24417 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24418 IMPLICIT INTEGER(I-N)
24419 INTEGER PYK,PYCHGE,PYCOMP
24420C...Commonblocks.
24421 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24422 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
24423 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24424 COMMON/PYINT1/MINT(400),VINT(400)
24425 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
24426 &XPDIR(-6:6)
24427 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/
24428C...Local arrays.
24429 DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
24430 &XPPI(-6:6),XPPR(-6:6)
24431
24432C...Interface to PDFLIB.
24433 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
24434 SAVE /W50513/
24435 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
24436 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
24437 CHARACTER*20 PARM(20)
24438 DATA VALUE/20*0D0/,PARM/20*' '/
24439
24440C...Data related to Schuler-Sjostrand photon distributions.
24441 DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
24442
24443C...Reset parton distributions.
24444 MINT(92)=0
24445 DO 100 KFL=-25,25
24446 XPQ(KFL)=0D0
24447 100 CONTINUE
24448
24449C...Check x and particle species.
24450 IF(X.LE.0D0.OR.X.GE.1D0) THEN
24451 WRITE(MSTU(11),5000) X
24452 RETURN
24453 ENDIF
24454 KFA=IABS(KF)
24455 IF(KFA.NE.11.AND.KFA.NE.13.AND.KFA.NE.15.AND.KFA.NE.22.AND.
24456 &KFA.NE.211.AND.KFA.NE.2112.AND.KFA.NE.2212.AND.KFA.NE.3122.AND.
24457 &KFA.NE.3112.AND.KFA.NE.3212.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.
24458 &KFA.NE.3322.AND.KFA.NE.3334.AND.KFA.NE.111) THEN
24459 WRITE(MSTU(11),5100) KF
24460 RETURN
24461 ENDIF
24462
24463C...Electron (or muon or tau) parton distribution call.
24464 IF(KFA.EQ.11.OR.KFA.EQ.13.OR.KFA.EQ.15) THEN
24465 CALL PYPDEL(KFA,X,Q2,XPEL)
24466 DO 110 KFL=-25,25
24467 XPQ(KFL)=XPEL(KFL)
24468 110 CONTINUE
24469
24470C...Photon parton distribution call (VDM+anomalous).
24471 ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
24472 IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
24473 CALL PYPDGA(X,Q2,XPGA)
24474 DO 120 KFL=-6,6
24475 XPQ(KFL)=XPGA(KFL)
24476 120 CONTINUE
24477 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
24478 Q2MX=Q2
24479 P2MX=0.36D0
24480 IF(MSTP(55).GE.7) P2MX=4.0D0
24481 IF(MSTP(57).EQ.0) Q2MX=P2MX
24482 P2=0D0
24483 IF(VINT(120).LT.0D0) P2=VINT(120)**2
24484 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
24485 DO 130 KFL=-6,6
24486 XPQ(KFL)=XPGA(KFL)
24487 130 CONTINUE
24488 VINT(231)=P2MX
24489 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
24490 Q2MX=Q2
24491 P2MX=0.36D0
24492 IF(MSTP(55).GE.11) P2MX=4.0D0
24493 IF(MSTP(57).EQ.0) Q2MX=P2MX
24494 P2=0D0
24495 IF(VINT(120).LT.0D0) P2=VINT(120)**2
24496 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
24497 DO 140 KFL=-6,6
24498 XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
24499 140 CONTINUE
24500 VINT(231)=P2MX
24501 ELSEIF(MSTP(56).EQ.2) THEN
24502C...Call PDFLIB parton distributions.
24503 PARM(1)='NPTYPE'
24504 VALUE(1)=3
24505 PARM(2)='NGROUP'
24506 VALUE(2)=MSTP(55)/1000
24507 PARM(3)='NSET'
24508 VALUE(3)=MOD(MSTP(55),1000)
24509 IF(MINT(93).NE.3000000+MSTP(55)) THEN
24510 CALL PDFSET(PARM,VALUE)
24511 MINT(93)=3000000+MSTP(55)
24512 ENDIF
24513 XX=X
24514 QQ2=MAX(0D0,Q2MIN,Q2)
24515 IF(MSTP(57).EQ.0) QQ2=Q2MIN
24516 P2=0D0
24517 IF(VINT(120).LT.0D0) P2=VINT(120)**2
24518 IP2=MSTP(60)
24519 IF(MSTP(55).EQ.5004) THEN
24520 IF(5D0*P2.LT.QQ2.AND.
24521 & QQ2.GT.0.6D0.AND.QQ2.LT.5D4.AND.
24522 & P2.GE.0D0.AND.P2.LT.10D0.AND.
24523 & XX.GT.1D-4.AND.XX.LT.1D0) THEN
24524 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
24525 & BOT,TOP,GLU)
24526 ELSE
24527 UPV=0D0
24528 DNV=0D0
24529 USEA=0D0
24530 DSEA=0D0
24531 STR=0D0
24532 CHM=0D0
24533 BOT=0D0
24534 TOP=0D0
24535 GLU=0D0
24536 ENDIF
24537 ELSE
24538 IF(P2.LT.QQ2) THEN
24539 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
24540 & BOT,TOP,GLU)
24541 ELSE
24542 UPV=0D0
24543 DNV=0D0
24544 USEA=0D0
24545 DSEA=0D0
24546 STR=0D0
24547 CHM=0D0
24548 BOT=0D0
24549 TOP=0D0
24550 GLU=0D0
24551 ENDIF
24552 ENDIF
24553 VINT(231)=Q2MIN
24554 XPQ(0)=GLU
24555 XPQ(1)=DNV
24556 XPQ(-1)=DNV
24557 XPQ(2)=UPV
24558 XPQ(-2)=UPV
24559 XPQ(3)=STR
24560 XPQ(-3)=STR
24561 XPQ(4)=CHM
24562 XPQ(-4)=CHM
24563 XPQ(5)=BOT
24564 XPQ(-5)=BOT
24565 XPQ(6)=TOP
24566 XPQ(-6)=TOP
24567 ELSE
24568 WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
24569 ENDIF
24570
24571C...Pion/gammaVDM parton distribution call.
24572 ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.(KFA.EQ.22.AND.
24573 & MINT(109).EQ.2)) THEN
24574 IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
24575 & MSTP(55).LE.12) THEN
24576 ISET=1+MOD(MSTP(55)-1,4)
24577 Q2MX=Q2
24578 P2MX=0.36D0
24579 IF(ISET.GE.3) P2MX=4.0D0
24580 IF(MSTP(57).EQ.0) Q2MX=P2MX
24581 P2=0D0
24582 IF(VINT(120).LT.0D0) P2=VINT(120)**2
24583 CALL PYGGAM(ISET,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
24584 DO 150 KFL=-6,6
24585 XPQ(KFL)=XPVMD(KFL)
24586 150 CONTINUE
24587 VINT(231)=P2MX
24588 ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
24589 CALL PYPDPI(X,Q2,XPPI)
24590 DO 160 KFL=-6,6
24591 XPQ(KFL)=XPPI(KFL)
24592 160 CONTINUE
24593 ELSEIF(MSTP(54).EQ.2) THEN
24594C...Call PDFLIB parton distributions.
24595 PARM(1)='NPTYPE'
24596 VALUE(1)=2
24597 PARM(2)='NGROUP'
24598 VALUE(2)=MSTP(53)/1000
24599 PARM(3)='NSET'
24600 VALUE(3)=MOD(MSTP(53),1000)
24601 IF(MINT(93).NE.2000000+MSTP(53)) THEN
24602 CALL PDFSET(PARM,VALUE)
24603 MINT(93)=2000000+MSTP(53)
24604 ENDIF
24605 XX=X
24606 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
24607 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
24608 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
24609 VINT(231)=Q2MIN
24610 XPQ(0)=GLU
24611 XPQ(1)=DSEA
24612 XPQ(-1)=UPV+DSEA
24613 XPQ(2)=UPV+USEA
24614 XPQ(-2)=USEA
24615 XPQ(3)=STR
24616 XPQ(-3)=STR
24617 XPQ(4)=CHM
24618 XPQ(-4)=CHM
24619 XPQ(5)=BOT
24620 XPQ(-5)=BOT
24621 XPQ(6)=TOP
24622 XPQ(-6)=TOP
24623 ELSE
24624 WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
24625 ENDIF
24626
24627C...Anomalous photon parton distribution call.
24628 ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
24629 Q2MX=Q2
24630 P2MX=PARP(15)**2
24631 IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
24632 IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
24633 IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
24634 IF(MSTP(57).EQ.0) Q2MX=P2MX
24635 P2=0D0
24636 IF(VINT(120).LT.0D0) P2=VINT(120)**2
24637 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
24638 DO 170 KFL=-6,6
24639 XPQ(KFL)=XPANL(KFL)+XPANH(KFL)
24640 170 CONTINUE
24641 VINT(231)=P2MX
24642 ELSEIF(MSTP(56).EQ.1) THEN
24643 IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
24644 IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
24645 IF(MSTP(57).EQ.0) Q2MX=P2MX
24646 P2=0D0
24647 IF(VINT(120).LT.0D0) P2=VINT(120)**2
24648 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
24649 DO 180 KFL=-6,6
24650 XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
24651 180 CONTINUE
24652 VINT(231)=P2MX
24653 ELSEIF(MSTP(56).EQ.2) THEN
24654 IF(MSTP(57).EQ.0) Q2MX=P2MX
24655 CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
24656 DO 190 KFL=-6,6
24657 XPQ(KFL)=XPGA(KFL)
24658 190 CONTINUE
24659 VINT(231)=P2MX
24660 ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
24661 IF(MSTP(57).EQ.0) Q2MX=P2MX
24662 CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
24663 DO 200 KFL=-6,6
24664 XPQ(KFL)=XPGA(KFL)
24665 200 CONTINUE
24666 VINT(231)=P2MX
24667 ELSE
24668 210 RKF=11D0*PYR(0)
24669 KFR=1
24670 IF(RKF.GT.1D0) KFR=2
24671 IF(RKF.GT.5D0) KFR=3
24672 IF(RKF.GT.6D0) KFR=4
24673 IF(RKF.GT.10D0) KFR=5
24674 IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 210
24675 IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 210
24676 IF(MSTP(57).EQ.0) Q2MX=P2MX
24677 CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
24678 DO 220 KFL=-6,6
24679 XPQ(KFL)=XPGA(KFL)
24680 220 CONTINUE
24681 VINT(231)=P2MX
24682 ENDIF
24683
24684C...Proton parton distribution call.
24685 ELSE
24686 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
24687 CALL PYPDPR(X,Q2,XPPR)
24688 DO 230 KFL=-6,6
24689 XPQ(KFL)=XPPR(KFL)
24690 230 CONTINUE
24691 ELSEIF(MSTP(52).EQ.2) THEN
24692C...Call PDFLIB parton distributions.
24693 PARM(1)='NPTYPE'
24694 VALUE(1)=1
24695 PARM(2)='NGROUP'
24696 VALUE(2)=MSTP(51)/1000
24697 PARM(3)='NSET'
24698 VALUE(3)=MOD(MSTP(51),1000)
24699 IF(MINT(93).NE.1000000+MSTP(51)) THEN
fd658fdb 24700C...ALICE
24701 CALL PDFSET_ALICE(PARM,VALUE)
952cc209 24702 MINT(93)=1000000+MSTP(51)
24703 ENDIF
24704 XX=X
24705 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
24706 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
fd658fdb 24707C...ALICE
24708 CALL STRUCTM_ALICE(
24709 + XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
952cc209 24710 VINT(231)=Q2MIN
24711 XPQ(0)=GLU
24712 XPQ(1)=DNV+DSEA
24713 XPQ(-1)=DSEA
24714 XPQ(2)=UPV+USEA
24715 XPQ(-2)=USEA
24716 XPQ(3)=STR
24717 XPQ(-3)=STR
24718 XPQ(4)=CHM
24719 XPQ(-4)=CHM
24720 XPQ(5)=BOT
24721 XPQ(-5)=BOT
24722 XPQ(6)=TOP
24723 XPQ(-6)=TOP
24724 ELSE
24725 WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
24726 ENDIF
24727 ENDIF
24728
24729C...Isospin average for pi0/gammaVDM.
24730 IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
24731 IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
24732 XPV=XPQ(2)-XPQ(1)
24733 XPQ(2)=XPQ(1)
24734 XPQ(-2)=XPQ(-1)
24735 ELSE
24736 XPS=0.5D0*(XPQ(1)+XPQ(-2))
24737 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
24738 XPQ(2)=XPS
24739 XPQ(-1)=XPS
24740 ENDIF
24741 IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
24742 XPQ(1)=XPQ(1)+0.2D0*XPV
24743 XPQ(-1)=XPQ(-1)+0.2D0*XPV
24744 XPQ(2)=XPQ(2)+0.8D0*XPV
24745 XPQ(-2)=XPQ(-2)+0.8D0*XPV
24746 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
24747 XPQ(3)=XPQ(3)+XPV
24748 XPQ(-3)=XPQ(-3)+XPV
24749 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
24750 XPQ(4)=XPQ(4)+XPV
24751 XPQ(-4)=XPQ(-4)+XPV
24752 IF(MSTP(55).GE.9) THEN
24753 DO 240 KFL=-6,6
24754 XPQ(KFL)=0D0
24755 240 CONTINUE
24756 ENDIF
24757 ELSE
24758 XPQ(1)=XPQ(1)+0.5D0*XPV
24759 XPQ(-1)=XPQ(-1)+0.5D0*XPV
24760 XPQ(2)=XPQ(2)+0.5D0*XPV
24761 XPQ(-2)=XPQ(-2)+0.5D0*XPV
24762 ENDIF
24763
24764C...Rescale for gammaVDM by effective gamma -> rho coupling.
24765C+++Do not rescale?
24766 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND..NOT.(MSTP(56).EQ.1
24767 & .AND.MSTP(55).GE.5.AND.MSTP(55).LE.12)) THEN
24768 DO 250 KFL=-6,6
24769 XPQ(KFL)=VINT(281)*XPQ(KFL)
24770 250 CONTINUE
24771 VINT(232)=VINT(281)*XPV
24772 ENDIF
24773
24774C...Isospin conjugation for neutron.
24775 ELSEIF(KFA.EQ.2112) THEN
24776 XPS=XPQ(1)
24777 XPQ(1)=XPQ(2)
24778 XPQ(2)=XPS
24779 XPS=XPQ(-1)
24780 XPQ(-1)=XPQ(-2)
24781 XPQ(-2)=XPS
24782
24783C...Simple recipes for hyperon (average valence parton distribution).
24784 ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
24785 & .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
24786 XPVAL=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
24787 XPSEA=0.5D0*(XPQ(-1)+XPQ(-2))
24788 XPQ(1)=XPSEA
24789 XPQ(2)=XPSEA
24790 XPQ(-1)=XPSEA
24791 XPQ(-2)=XPSEA
24792 XPQ(KFA/1000)=XPQ(KFA/1000)+XPVAL
24793 XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPVAL
24794 XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPVAL
24795 ENDIF
24796
24797C...Charge conjugation for antiparticle.
24798 IF(KF.LT.0) THEN
24799 DO 260 KFL=1,25
24800 IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 260
24801 XPS=XPQ(KFL)
24802 XPQ(KFL)=XPQ(-KFL)
24803 XPQ(-KFL)=XPS
24804 260 CONTINUE
24805 ENDIF
24806
24807C...Allow gluon also in position 21.
24808 XPQ(21)=XPQ(0)
24809
24810C...Check positivity and reset above maximum allowed flavour.
24811 DO 270 KFL=-25,25
24812 XPQ(KFL)=MAX(0D0,XPQ(KFL))
24813 IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0
24814 270 CONTINUE
24815
24816C...Formats for error printouts.
24817 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
24818 5100 FORMAT(' Error: illegal particle code for parton distribution;',
24819 &' KF =',I5)
24820 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
24821 &3I5)
24822
24823 RETURN
24824 END
24825
24826C*********************************************************************
24827
24828C...PYPDFL
24829C...Gives proton parton distribution at small x and/or Q^2 according to
24830C...correct limiting behaviour.
24831
24832 SUBROUTINE PYPDFL(KF,X,Q2,XPQ)
24833
24834C...Double precision and integer declarations.
24835 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24836 IMPLICIT INTEGER(I-N)
24837 INTEGER PYK,PYCHGE,PYCOMP
24838C...Commonblocks.
24839 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24840 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
24841 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24842 COMMON/PYINT1/MINT(400),VINT(400)
24843 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
24844C...Local arrays.
24845 DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3)
24846 DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/
24847
24848C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
24849 MINT(92)=0
24850 KFA=IABS(KF)
24851 IACC=0
24852 IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1
24853 IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1
24854 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1
24855 IF(IACC.EQ.0) THEN
24856 CALL PYPDFU(KF,X,Q2,XPQ)
24857 RETURN
24858 ENDIF
24859
24860C...Reset. Check x.
24861 DO 100 KFL=-25,25
24862 XPQ(KFL)=0D0
24863 100 CONTINUE
24864 IF(X.LE.0D0.OR.X.GE.1D0) THEN
24865 WRITE(MSTU(11),5000) X
24866 RETURN
24867 ENDIF
24868
24869C...Define valence content.
24870 KFC=KF
24871 NV1=2
24872 NV2=1
24873 IF(KF.EQ.2212) THEN
24874 KFV1=2
24875 KFV2=1
24876 ELSEIF(KF.EQ.-2212) THEN
24877 KFV1=-2
24878 KFV2=-1
24879 ELSEIF(KF.EQ.2112) THEN
24880 KFV1=1
24881 KFV2=2
24882 ELSEIF(KF.EQ.-2112) THEN
24883 KFV1=-1
24884 KFV2=-2
24885 ELSEIF(KF.EQ.211) THEN
24886 NV1=1
24887 KFV1=2
24888 KFV2=-1
24889 ELSEIF(KF.EQ.-211) THEN
24890 NV1=1
24891 KFV1=-2
24892 KFV2=1
24893 ELSEIF(MINT(105).LE.223) THEN
24894 KFV1=1
24895 WTV1=0.2D0
24896 KFV2=2
24897 WTV2=0.8D0
24898 ELSEIF(MINT(105).EQ.333) THEN
24899 KFV1=3
24900 WTV1=1.0D0
24901 KFV2=1
24902 WTV2=0.0D0
24903 ELSEIF(MINT(105).EQ.443) THEN
24904 KFV1=4
24905 WTV1=1.0D0
24906 KFV2=1
24907 WTV2=0.0D0
24908 ENDIF
24909
24910C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
24911 CALL PYPDFU(KFC,X,Q2,XPA)
24912 Q2MN=MAX(3D0,VINT(231))
24913 Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X))))
24914 XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0
24915
24916C...Large Q2 and large x: naive call is enough.
24917 IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN
24918 DO 110 KFL=-25,25
24919 XPQ(KFL)=XPA(KFL)
24920 110 CONTINUE
24921 MINT(92)=1
24922
24923C...Small Q2 and large x: dampen boundary value.
24924 ELSEIF(X.GT.XMN) THEN
24925
24926C...Evaluate at boundary and define dampening factors.
24927 CALL PYPDFU(KFC,X,Q2MN,XPA)
24928 FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN))
24929 FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0
24930
24931C...Separate valence and sea parts of parton distribution.
24932 IF(KFA.NE.22) THEN
24933 XFV1=XPA(KFV1)-XPA(-KFV1)
24934 XPA(KFV1)=XPA(-KFV1)
24935 XFV2=XPA(KFV2)-XPA(-KFV2)
24936 XPA(KFV2)=XPA(-KFV2)
24937 ELSE
24938 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
24939 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
24940 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
24941 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
24942 ENDIF
24943
24944C...Dampen valence and sea separately. Put back together.
24945 DO 120 KFL=-25,25
24946 XPQ(KFL)=FS*XPA(KFL)
24947 120 CONTINUE
24948 IF(KFA.NE.22) THEN
24949 XPQ(KFV1)=XPQ(KFV1)+FV*XFV1
24950 XPQ(KFV2)=XPQ(KFV2)+FV*XFV2
24951 ELSE
24952 XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232)
24953 XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232)
24954 XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232)
24955 XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232)
24956 ENDIF
24957 MINT(92)=2
24958
24959C...Large Q2 and small x: interpolate behaviour.
24960 ELSEIF(Q2.GT.Q2MN) THEN
24961
24962C...Evaluate at extremes and define coefficients for interpolation.
24963 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
24964 VI232A=VINT(232)
24965 CALL PYPDFU(KFC,X,Q2B,XPB)
24966 VI232B=VINT(232)
24967 FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN)
24968 FVA=(X/XMN)**0.45D0*FLA
24969 FSA=(X/XMN)**(-0.08D0)*FLA
24970 FB=1D0-FLA
24971
24972C...Separate valence and sea parts of parton distribution.
24973 IF(KFA.NE.22) THEN
24974 XFVA1=XPA(KFV1)-XPA(-KFV1)
24975 XPA(KFV1)=XPA(-KFV1)
24976 XFVA2=XPA(KFV2)-XPA(-KFV2)
24977 XPA(KFV2)=XPA(-KFV2)
24978 XFVB1=XPB(KFV1)-XPB(-KFV1)
24979 XPB(KFV1)=XPB(-KFV1)
24980 XFVB2=XPB(KFV2)-XPB(-KFV2)
24981 XPB(KFV2)=XPB(-KFV2)
24982 ELSE
24983 XPA(KFV1)=XPA(KFV1)-WTV1*VI232A
24984 XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A
24985 XPA(KFV2)=XPA(KFV2)-WTV2*VI232A
24986 XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A
24987 XPB(KFV1)=XPB(KFV1)-WTV1*VI232B
24988 XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B
24989 XPB(KFV2)=XPB(KFV2)-WTV2*VI232B
24990 XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B
24991 ENDIF
24992
24993C...Interpolate for valence and sea. Put back together.
24994 DO 130 KFL=-25,25
24995 XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL)
24996 130 CONTINUE
24997 IF(KFA.NE.22) THEN
24998 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1)
24999 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2)
25000 ELSE
25001 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
25002 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
25003 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
25004 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
25005 ENDIF
25006 MINT(92)=3
25007
25008C...Small Q2 and small x: dampen boundary value and add term.
25009 ELSE
25010
25011C...Evaluate at boundary and define dampening factors.
25012 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
25013 FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN)
25014 FA=1D0-FB
25015 FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0
25016 FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0
25017 FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0
25018 FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0
25019 FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0
25020 FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0
25021
25022C...Separate valence and sea parts of parton distribution.
25023 IF(KFA.NE.22) THEN
25024 XFV1=XPA(KFV1)-XPA(-KFV1)
25025 XPA(KFV1)=XPA(-KFV1)
25026 XFV2=XPA(KFV2)-XPA(-KFV2)
25027 XPA(KFV2)=XPA(-KFV2)
25028 ELSE
25029 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
25030 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
25031 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
25032 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
25033 ENDIF
25034
25035C...Dampen valence and sea separately. Add constant terms.
25036C...Put back together.
25037 DO 140 KFL=-25,25
25038 XPQ(KFL)=FSA*XPA(KFL)
25039 140 CONTINUE
25040 IF(KFA.NE.22) THEN
25041 DO 150 KFL=-3,3
25042 XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL)
25043 150 CONTINUE
25044 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1)
25045 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2)
25046 ELSE
25047 DO 160 KFL=-3,3
25048 XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL)
25049 160 CONTINUE
25050 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
25051 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
25052 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
25053 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
25054 ENDIF
25055 XPQ(21)=XPQ(0)
25056 MINT(92)=4
25057 ENDIF
25058
25059C...Format for error printout.
25060 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
25061
25062 RETURN
25063 END
25064
25065C*********************************************************************
25066
25067C...PYPDEL
25068C...Gives electron (or muon, or tau) parton distribution.
25069
25070 SUBROUTINE PYPDEL(KFA,X,Q2,XPEL)
25071
25072C...Double precision and integer declarations.
25073 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25074 IMPLICIT INTEGER(I-N)
25075 INTEGER PYK,PYCHGE,PYCOMP
25076C...Commonblocks.
25077 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
25078 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
25079 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
25080 COMMON/PYINT1/MINT(400),VINT(400)
25081 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
25082C...Local arrays.
25083 DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6)
25084
25085C...Interface to PDFLIB.
25086 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
25087 SAVE /W50513/
25088 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
25089 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
25090 CHARACTER*20 PARM(20)
25091 DATA VALUE/20*0D0/,PARM/20*' '/
25092
25093C...Some common constants.
25094 DO 100 KFL=-25,25
25095 XPEL(KFL)=0D0
25096 100 CONTINUE
25097 AEM=PARU(101)
25098 PME=PMAS(11,1)
25099 IF(KFA.EQ.13) PME=PMAS(13,1)
25100 IF(KFA.EQ.15) PME=PMAS(15,1)
25101 XL=LOG(MAX(1D-10,X))
25102 X1L=LOG(MAX(1D-10,1D0-X))
25103 HLE=LOG(MAX(3D0,Q2/PME**2))
25104 HBE2=(AEM/PARU(1))*(HLE-1D0)
25105
25106C...Electron inside electron, see R. Kleiss et al., in Z physics at
25107C...LEP 1, CERN 89-08, p. 34
25108 IF(MSTP(59).LE.1) THEN
25109 HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2*
25110 & (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0)
25111 HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))-
25112 & 0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)-
25113 & 4D0*XL/(1D0-X)-5D0-X)
25114 ELSE
25115 HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/
25116 & PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*
25117 & (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X)
25118 ENDIF
25119C...Zero distribution for very large x and rescale it for intermediate.
25120 IF(X.GT.1D0-1D-10) THEN
25121 HEE=0D0
25122 ELSEIF(X.GT.1D0-1D-7) THEN
25123 HEE=HEE*1000D0**HBE2/(1000D0**HBE2-1D0)
25124 ENDIF
25125 XPEL(KFA)=X*HEE
25126
25127C...Photon and (transverse) W- inside electron.
25128 AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2)
25129 IF(MSTP(13).LE.1) THEN
25130 HLG=HLE
25131 ELSE
25132 HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2))
25133 ENDIF
25134 XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2)
25135 HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102))
25136 XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2)
25137
25138C...Electron or positron inside photon inside electron.
25139 IF(KFA.EQ.11.AND.MSTP(12).EQ.1) THEN
25140 XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+
25141 & 2D0*X*(1D0+X)*XL)
25142 XPEL(11)=XPEL(11)+XFSEA
25143 XPEL(-11)=XFSEA
25144
25145C...Initialize PDFLIB photon parton distributions.
25146 IF(MSTP(56).EQ.2) THEN
25147 PARM(1)='NPTYPE'
25148 VALUE(1)=3
25149 PARM(2)='NGROUP'
25150 VALUE(2)=MSTP(55)/1000
25151 PARM(3)='NSET'
25152 VALUE(3)=MOD(MSTP(55),1000)
25153 IF(MINT(93).NE.3000000+MSTP(55)) THEN
25154 CALL PDFSET(PARM,VALUE)
25155 MINT(93)=3000000+MSTP(55)
25156 ENDIF
25157 ENDIF
25158
25159C...Quarks and gluons inside photon inside electron:
25160C...numerical convolution required.
25161 DO 110 KFL=0,6
25162 SXP(KFL)=0D0
25163 110 CONTINUE
25164 SUMXPP=0D0
25165 ITER=-1
25166 120 ITER=ITER+1
25167 SUMXP=SUMXPP
25168 NSTP=2**(ITER-1)
25169 IF(ITER.EQ.0) NSTP=2
25170 DO 130 KFL=0,6
25171 SXP(KFL)=0.5D0*SXP(KFL)
25172 130 CONTINUE
25173 WTSTP=0.5D0/NSTP
25174 IF(ITER.EQ.0) WTSTP=0.5D0
25175C...Pick grid of x_{gamma} values logarithmically even.
25176 DO 150 ISTP=1,NSTP
25177 IF(ITER.EQ.0) THEN
25178 XLE=XL*(ISTP-1)
25179 ELSE
25180 XLE=XL*(ISTP-0.5D0)/NSTP
25181 ENDIF
25182 XE=MIN(1D0-1D-10,EXP(XLE))
25183 XG=MIN(1D0-1D-10,X/XE)
25184C...Evaluate photon inside electron parton distribution for convolution.
25185 XPGP=1D0+(1D0-XE)**2
25186 IF(MSTP(13).LE.1) THEN
25187 XPGP=XPGP*HLE
25188 ELSE
25189 XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2))
25190 ENDIF
25191C...Evaluate photon parton distributions for convolution.
25192 IF(MSTP(56).EQ.1) THEN
25193 CALL PYPDGA(XG,Q2,XPGA)
25194 DO 140 KFL=0,5
25195 SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL)
25196 140 CONTINUE
25197 ELSEIF(MSTP(56).EQ.2) THEN
25198C...Call PDFLIB parton distributions.
25199 XX=XG
25200 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
25201 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
25202 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
25203 SXP(0)=SXP(0)+WTSTP*XPGP*GLU
25204 SXP(1)=SXP(1)+WTSTP*XPGP*DNV
25205 SXP(2)=SXP(2)+WTSTP*XPGP*UPV
25206 SXP(3)=SXP(3)+WTSTP*XPGP*STR
25207 SXP(4)=SXP(4)+WTSTP*XPGP*CHM
25208 SXP(5)=SXP(5)+WTSTP*XPGP*BOT
25209 SXP(6)=SXP(6)+WTSTP*XPGP*TOP
25210 ENDIF
25211 150 CONTINUE
25212 SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2)
25213 IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT.
25214 & PARP(14)*(SUMXPP+SUMXP))) GOTO 120
25215
25216C...Put convolution into output arrays.
25217 FCONV=AEMP*(-XL)
25218 XPEL(0)=FCONV*SXP(0)
25219 DO 160 KFL=1,6
25220 XPEL(KFL)=FCONV*SXP(KFL)
25221 XPEL(-KFL)=XPEL(KFL)
25222 160 CONTINUE
25223 ENDIF
25224
25225 RETURN
25226 END
25227
25228C*********************************************************************
25229
25230C...PYPDGA
25231C...Gives photon parton distribution.
25232
25233 SUBROUTINE PYPDGA(X,Q2,XPGA)
25234
25235C...Double precision and integer declarations.
25236 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25237 IMPLICIT INTEGER(I-N)
25238 INTEGER PYK,PYCHGE,PYCOMP
25239C...Commonblocks.
25240 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
25241 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
25242 COMMON/PYINT1/MINT(400),VINT(400)
25243 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
25244C...Local arrays.
25245 DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3),
25246 &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3),
25247 &DGCS(4,3),DGDS(4,3),DGES(4,3)
25248
25249C...The following data lines are coefficients needed in the
25250C...Drees and Grassie photon parton distribution parametrization.
25251 DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0,
25252 &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/
25253 DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0,
25254 &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/
25255 DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0,
25256 &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/
25257 DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0,
25258 &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/
25259 DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0,
25260 &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/
25261 DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1,
25262 &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/
25263 DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0,
25264 &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/
25265 DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0,
25266 &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/
25267 DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0,
25268 &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/
25269 DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0,
25270 &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/
25271 DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0,
25272 &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/
25273 DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0,
25274 &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/
25275 DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0,
25276 &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/
25277
25278C...Photon parton distribution from Drees and Grassie.
25279C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
25280 DO 100 KFL=-6,6
25281 XPGA(KFL)=0D0
25282 100 CONTINUE
25283 VINT(231)=1D0
25284 IF(MSTP(57).LE.0) THEN
25285 T=LOG(1D0/0.16D0)
25286 ELSE
25287 T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0)
25288 ENDIF
25289 X1=1D0-X
25290 NF=3
25291 IF(Q2.GT.25D0) NF=4
25292 IF(Q2.GT.300D0) NF=5
25293 NFE=NF-2
25294 AEM=PARU(101)
25295
25296C...Evaluate gluon content.
25297 DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE))
25298 DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE))
25299 DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE))
25300 XPGL=DGA*X**DGB*X1**DGC
25301
25302C...Evaluate up- and down-type quark content.
25303 DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE))
25304 DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE))
25305 DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE))
25306 DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE))
25307 DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE))
25308 XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
25309 DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE))
25310 DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE))
25311 DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE))
25312 DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE))
25313 DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE))
25314 DGF=9D0
25315 IF(NF.EQ.4) DGF=10D0
25316 IF(NF.EQ.5) DGF=55D0/6D0
25317 XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
25318 IF(NF.LE.3) THEN
25319 XPQU=(XPQS+9D0*XPQN)/6D0
25320 XPQD=(XPQS-4.5D0*XPQN)/6D0
25321 ELSEIF(NF.EQ.4) THEN
25322 XPQU=(XPQS+6D0*XPQN)/8D0
25323 XPQD=(XPQS-6D0*XPQN)/8D0
25324 ELSE
25325 XPQU=(XPQS+7.5D0*XPQN)/10D0
25326 XPQD=(XPQS-5D0*XPQN)/10D0
25327 ENDIF
25328
25329C...Put into output arrays.
25330 XPGA(0)=AEM*XPGL
25331 XPGA(1)=AEM*XPQD
25332 XPGA(2)=AEM*XPQU
25333 XPGA(3)=AEM*XPQD
25334 IF(NF.GE.4) XPGA(4)=AEM*XPQU
25335 IF(NF.GE.5) XPGA(5)=AEM*XPQD
25336 DO 110 KFL=1,6
25337 XPGA(-KFL)=XPGA(KFL)
25338 110 CONTINUE
25339
25340 RETURN
25341 END
25342
25343C*********************************************************************
25344
25345C...PYGGAM
25346C...Constructs the F2 and parton distributions of the photon
25347C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
25348C...For F2, c and b are included by the Bethe-Heitler formula;
25349C...in the 'MSbar' scheme additionally a Cgamma term is added.
25350C...Contains the SaS sets 1D, 1M, 2D and 2M.
25351C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
25352
25353 SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
25354
25355C...Double precision and integer declarations.
25356 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25357 IMPLICIT INTEGER(I-N)
25358 INTEGER PYK,PYCHGE,PYCOMP
25359C...Commonblocks.
25360 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
25361 &XPDIR(-6:6)
25362 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
25363 SAVE /PYINT8/,/PYINT9/
25364C...Local arrays.
25365 DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6)
25366C...Charm and bottom masses (low to compensate for J/psi etc.).
25367 DATA PMC/1.3D0/, PMB/4.6D0/
25368C...alpha_em and alpha_em/(2*pi).
25369 DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/
25370C...Lambda value for 4 flavours.
25371 DATA ALAM/0.20D0/
25372C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
25373 DATA FRACU/0.8D0/
25374C...VMD couplings f_V**2/(4*pi).
25375 DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/
25376C...Masses for rho (=omega) and phi.
25377 DATA PMRHO/0.770D0/, PMPHI/1.020D0/
25378C...Number of points in integration for IP2=1.
25379 DATA NSTEP/100/
25380
25381C...Reset output.
25382 F2GM=0D0
25383 DO 100 KFL=-6,6
25384 XPDFGM(KFL)=0D0
25385 XPVMD(KFL)=0D0
25386 XPANL(KFL)=0D0
25387 XPANH(KFL)=0D0
25388 XPBEH(KFL)=0D0
25389 XPDIR(KFL)=0D0
25390 VXPVMD(KFL)=0D0
25391 VXPANL(KFL)=0D0
25392 VXPANH(KFL)=0D0
25393 VXPDGM(KFL)=0D0
25394 100 CONTINUE
25395
25396C...Set Q0 cut-off parameter as function of set used.
25397 IF(ISET.LE.2) THEN
25398 Q0=0.6D0
25399 ELSE
25400 Q0=2D0
25401 ENDIF
25402 Q02=Q0**2
25403
25404C...Scale choice for off-shell photon; common factors.
25405 Q2A=Q2
25406 FACNOR=1D0
25407 IF(IP2.EQ.1) THEN
25408 P2MX=P2+Q02
25409 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
25410 FACNOR=LOG(Q2/Q02)/NSTEP
25411 ELSEIF(IP2.EQ.2) THEN
25412 P2MX=MAX(P2,Q02)
25413 ELSEIF(IP2.EQ.3) THEN
25414 P2MX=P2+Q02
25415 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
25416 ELSEIF(IP2.EQ.4) THEN
25417 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
25418 & ((Q2+P2)*(Q02+P2)))
25419 ELSEIF(IP2.EQ.5) THEN
25420 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
25421 & ((Q2+P2)*(Q02+P2)))
25422 P2MX=Q0*SQRT(P2MXA)
25423 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
25424 ELSEIF(IP2.EQ.6) THEN
25425 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
25426 & ((Q2+P2)*(Q02+P2)))
25427 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
25428 ELSE
25429 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
25430 & ((Q2+P2)*(Q02+P2)))
25431 P2MX=Q0*SQRT(P2MXA)
25432 P2MXB=P2MX
25433 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
25434 P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA
25435 IF(ABS(Q2-Q02).GT.1D-6) THEN
25436 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
25437 ELSEIF(P2.LT.Q02) THEN
25438 FACNOR=Q02**3/(Q02+P2)/(Q02**2-P2**2/2D0)
25439 ELSE
25440 FACNOR=1D0
25441 ENDIF
25442 ENDIF
25443
25444C...Call VMD parametrization for d quark and use to give rho, omega,
25445C...phi. Note dipole dampening for off-shell photon.
25446 CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
25447 XFVAL=VXPGA(1)
25448 XPGA(1)=XPGA(2)
25449 XPGA(-1)=XPGA(-2)
25450 FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
25451 FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
25452 DO 110 KFL=-5,5
25453 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
25454 110 CONTINUE
25455 XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL
25456 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
25457 XPVMD(3)=XPVMD(3)+FACS*XFVAL
25458 XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL
25459 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
25460 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
25461 VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL
25462 VXPVMD(2)=FRACU*FACUD*XFVAL
25463 VXPVMD(3)=FACS*XFVAL
25464 VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL
25465 VXPVMD(-2)=FRACU*FACUD*XFVAL
25466 VXPVMD(-3)=FACS*XFVAL
25467
25468 IF(IP2.NE.1) THEN
25469C...Anomalous parametrizations for different strategies
25470C...for off-shell photons; except full integration.
25471
25472C...Call anomalous parametrization for d + u + s.
25473 CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
25474 DO 120 KFL=-5,5
25475 XPANL(KFL)=FACNOR*XPGA(KFL)
25476 VXPANL(KFL)=FACNOR*VXPGA(KFL)
25477 120 CONTINUE
25478
25479C...Call anomalous parametrization for c and b.
25480 CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
25481 DO 130 KFL=-5,5
25482 XPANH(KFL)=FACNOR*XPGA(KFL)
25483 VXPANH(KFL)=FACNOR*VXPGA(KFL)
25484 130 CONTINUE
25485 CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
25486 DO 140 KFL=-5,5
25487 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
25488 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
25489 140 CONTINUE
25490
25491 ELSE
25492C...Special option: loop over flavours and integrate over k2.
25493 DO 170 KF=1,5
25494 DO 160 ISTEP=1,NSTEP
25495 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP)
25496 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
25497 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
25498 CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
25499 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
25500 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0)
25501 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0)
25502 DO 150 KFL=-5,5
25503 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
25504 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
25505 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
25506 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
25507 150 CONTINUE
25508 160 CONTINUE
25509 170 CONTINUE
25510 ENDIF
25511
25512C...Call Bethe-Heitler term expression for charm and bottom.
25513 CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH)
25514 XPBEH(4)=XPBH
25515 XPBEH(-4)=XPBH
25516 CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH)
25517 XPBEH(5)=XPBH
25518 XPBEH(-5)=XPBH
25519
25520C...For MSbar subtraction call C^gamma term expression for d, u, s.
25521 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
25522 CALL PYGDIR(X,Q2,P2,Q02,XPGA)
25523 DO 180 KFL=-5,5
25524 XPDIR(KFL)=XPGA(KFL)
25525 180 CONTINUE
25526 ENDIF
25527
25528C...Store result in output array.
25529 DO 190 KFL=-5,5
25530 CHSQ=1D0/9D0
25531 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0
25532 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
25533 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
25534 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
25535 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
25536 190 CONTINUE
25537
25538 RETURN
25539 END
25540
25541C*********************************************************************
25542
25543C...PYGVMD
25544C...Evaluates the VMD parton distributions of a photon,
25545C...evolved homogeneously from an initial scale P2 to Q2.
25546C...Does not include dipole suppression factor.
25547C...ISET is parton distribution set, see above;
25548C...additionally ISET=0 is used for the evolution of an anomalous photon
25549C...which branched at a scale P2 and then evolved homogeneously to Q2.
25550C...ALAM is the 4-flavour Lambda, which is automatically converted
25551C...to 3- and 5-flavour equivalents as needed.
25552C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
25553
25554 SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
25555
25556C...Double precision and integer declarations.
25557 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25558 IMPLICIT INTEGER(I-N)
25559 INTEGER PYK,PYCHGE,PYCOMP
25560C...Local arrays and data.
25561 DIMENSION XPGA(-6:6), VXPGA(-6:6)
25562 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
25563
25564C...Reset output.
25565 DO 100 KFL=-6,6
25566 XPGA(KFL)=0D0
25567 VXPGA(KFL)=0D0
25568 100 CONTINUE
25569 KFA=IABS(KF)
25570
25571C...Calculate Lambda; protect against unphysical Q2 and P2 input.
25572 ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
25573 ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
25574 P2EFF=MAX(P2,1.2D0*ALAM3**2)
25575 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
25576 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
25577 Q2EFF=MAX(Q2,P2EFF)
25578
25579C...Find number of flavours at lower and upper scale.
25580 NFP=4
25581 IF(P2EFF.LT.PMC**2) NFP=3
25582 IF(P2EFF.GT.PMB**2) NFP=5
25583 NFQ=4
25584 IF(Q2EFF.LT.PMC**2) NFQ=3
25585 IF(Q2EFF.GT.PMB**2) NFQ=5
25586
25587C...Find s as sum of 3-, 4- and 5-flavour parts.
25588 S=0D0
25589 IF(NFP.EQ.3) THEN
25590 Q2DIV=PMC**2
25591 IF(NFQ.EQ.3) Q2DIV=Q2EFF
25592 S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
25593 ENDIF
25594 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
25595 P2DIV=P2EFF
25596 IF(NFP.EQ.3) P2DIV=PMC**2
25597 Q2DIV=Q2EFF
25598 IF(NFQ.EQ.5) Q2DIV=PMB**2
25599 S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
25600 ENDIF
25601 IF(NFQ.EQ.5) THEN
25602 P2DIV=PMB**2
25603 IF(NFP.EQ.5) P2DIV=P2EFF
25604 S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
25605 ENDIF
25606
25607C...Calculate frequent combinations of x and s.
25608 X1=1D0-X
25609 XL=-LOG(X)
25610 S2=S**2
25611 S3=S**3
25612 S4=S**4
25613
25614C...Evaluate homogeneous anomalous parton distributions below or
25615C...above threshold.
25616 IF(ISET.EQ.0) THEN
25617 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
25618 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
25619 XVAL = X * 1.5D0 * (X**2+X1**2)
25620 XGLU = 0D0
25621 XSEA = 0D0
25622 ELSE
25623 XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
25624 & (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
25625 & 5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
25626 & X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
25627 XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
25628 & X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
25629 & ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
25630 XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
25631 & X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
25632 & ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
25633 & (2D0*X-1D0)*X*XL**2)
25634 ENDIF
25635
25636C...Evaluate set 1D parton distributions below or above threshold.
25637 ELSEIF(ISET.EQ.1) THEN
25638 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
25639 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
25640 XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
25641 XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
25642 XSEA = 0.100D0 * X1**3.76D0
25643 ELSE
25644 XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
25645 & X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
25646 XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
25647 & X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
25648 & XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
25649 & X**0.40D0 * X1**(1.76D0+3D0*S)
25650 XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
25651 & (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
25652 & X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
25653 XSEA0 = 0.100D0 * X1**3.76D0
25654 ENDIF
25655
25656C...Evaluate set 1M parton distributions below or above threshold.
25657 ELSEIF(ISET.EQ.2) THEN
25658 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
25659 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
25660 XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
25661 XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
25662 XSEA = 0D0
25663 ELSE
25664 XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
25665 & X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
25666 XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
25667 & EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
25668 & X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
25669 & EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
25670 XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
25671 & X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
25672 & XL**(2.8D0*S)
25673 XSEA0 = 0D0
25674 ENDIF
25675
25676C...Evaluate set 2D parton distributions below or above threshold.
25677 ELSEIF(ISET.EQ.3) THEN
25678 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
25679 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
25680 XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
25681 XGLU = 1.925D0 * X1**2
25682 XSEA = 0.242D0 * X1**4
25683 ELSE
25684 XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
25685 & X**(0.46D0+0.25D0*S) *
25686 & X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
25687 & (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
25688 XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
25689 & EXP(-18.67D0*S) *
25690 & X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
25691 & * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
25692 & XL**(9.3D0*S/(1D0+1.7D0*S))
25693 XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
25694 & (1D0-0.607D0*S+21.95D0*S2) *
25695 & X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
25696 XSEA0 = 0.242D0 * X1**4
25697 ENDIF
25698
25699C...Evaluate set 2M parton distributions below or above threshold.
25700 ELSEIF(ISET.EQ.4) THEN
25701 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
25702 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
25703 XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
25704 XGLU = 1.808D0 * X1**2
25705 XSEA = 0.209D0 * X1**4
25706 ELSE
25707 XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
25708 & X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
25709 & X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
25710 & XL**(5.15D0*S/(1D0+2D0*S)) +
25711 & (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
25712 XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
25713 & X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
25714 & X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
25715 & XL**(10.9D0*S/(1D0+2.5D0*S))
25716 XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
25717 & X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
25718 & X1**(4D0+S) * XL**(0.45D0*S)
25719 XSEA0 = 0.209D0 * X1**4
25720 ENDIF
25721 ENDIF
25722
25723C...Threshold factors for c and b sea.
25724 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
25725 XCHM=0D0
25726 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
25727 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
25728 IF(ISET.EQ.0) THEN
25729 XCHM=XSEA*(1D0-(SCH/SLL)**2)
25730 ELSE
25731 XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
25732 ENDIF
25733 ENDIF
25734 XBOT=0D0
25735 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
25736 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
25737 IF(ISET.EQ.0) THEN
25738 XBOT=XSEA*(1D0-(SBT/SLL)**2)
25739 ELSE
25740 XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
25741 ENDIF
25742 ENDIF
25743
25744C...Fill parton distributions.
25745 XPGA(0)=XGLU
25746 XPGA(1)=XSEA
25747 XPGA(2)=XSEA
25748 XPGA(3)=XSEA
25749 XPGA(4)=XCHM
25750 XPGA(5)=XBOT
25751 XPGA(KFA)=XPGA(KFA)+XVAL
25752 DO 110 KFL=1,5
25753 XPGA(-KFL)=XPGA(KFL)
25754 110 CONTINUE
25755 VXPGA(KFA)=XVAL
25756 VXPGA(-KFA)=XVAL
25757
25758 RETURN
25759 END
25760
25761C*********************************************************************
25762
25763C...PYGANO
25764C...Evaluates the parton distributions of the anomalous photon,
25765C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
25766C...KF=0 gives the sum over (up to) 5 flavours,
25767C...KF<0 limits to flavours up to abs(KF),
25768C...KF>0 is for flavour KF only.
25769C...ALAM is the 4-flavour Lambda, which is automatically converted
25770C...to 3- and 5-flavour equivalents as needed.
25771C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
25772
25773 SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
25774
25775C...Double precision and integer declarations.
25776 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25777 IMPLICIT INTEGER(I-N)
25778 INTEGER PYK,PYCHGE,PYCOMP
25779C...Local arrays and data.
25780 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
25781 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
25782
25783C...Reset output.
25784 DO 100 KFL=-6,6
25785 XPGA(KFL)=0D0
25786 VXPGA(KFL)=0D0
25787 100 CONTINUE
25788 IF(Q2.LE.P2) RETURN
25789 KFA=IABS(KF)
25790
25791C...Calculate Lambda; protect against unphysical Q2 and P2 input.
25792 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2
25793 ALAMSQ(4)=ALAM**2
25794 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2
25795 P2EFF=MAX(P2,1.2D0*ALAMSQ(3))
25796 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
25797 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
25798 Q2EFF=MAX(Q2,P2EFF)
25799 XL=-LOG(X)
25800
25801C...Find number of flavours at lower and upper scale.
25802 NFP=4
25803 IF(P2EFF.LT.PMC**2) NFP=3
25804 IF(P2EFF.GT.PMB**2) NFP=5
25805 NFQ=4
25806 IF(Q2EFF.LT.PMC**2) NFQ=3
25807 IF(Q2EFF.GT.PMB**2) NFQ=5
25808
25809C...Define range of flavour loop.
25810 IF(KF.EQ.0) THEN
25811 KFLMN=1
25812 KFLMX=5
25813 ELSEIF(KF.LT.0) THEN
25814 KFLMN=1
25815 KFLMX=KFA
25816 ELSE
25817 KFLMN=KFA
25818 KFLMX=KFA
25819 ENDIF
25820
25821C...Loop over flavours the photon can branch into.
25822 DO 110 KFL=KFLMN,KFLMX
25823
25824C...Light flavours: calculate t range and (approximate) s range.
25825 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
25826 TDIFF=LOG(Q2EFF/P2EFF)
25827 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
25828 & LOG(P2EFF/ALAMSQ(NFQ)))
25829 IF(NFQ.GT.NFP) THEN
25830 Q2DIV=PMB**2
25831 IF(NFQ.EQ.4) Q2DIV=PMC**2
25832 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
25833 & LOG(P2EFF/ALAMSQ(NFQ)))
25834 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
25835 & LOG(P2EFF/ALAMSQ(NFQ-1)))
25836 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
25837 ENDIF
25838 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
25839 Q2DIV=PMC**2
25840 SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
25841 & LOG(P2EFF/ALAMSQ(4)))
25842 SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
25843 & LOG(P2EFF/ALAMSQ(3)))
25844 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
25845 ENDIF
25846
25847C...u and s quark do not need a separate treatment when d has been done.
25848 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
25849
25850C...Charm: as above, but only include range above c threshold.
25851 ELSEIF(KFL.EQ.4) THEN
25852 IF(Q2.LE.PMC**2) GOTO 110
25853 P2EFF=MAX(P2EFF,PMC**2)
25854 Q2EFF=MAX(Q2EFF,P2EFF)
25855 TDIFF=LOG(Q2EFF/P2EFF)
25856 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
25857 & LOG(P2EFF/ALAMSQ(NFQ)))
25858 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
25859 Q2DIV=PMB**2
25860 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
25861 & LOG(P2EFF/ALAMSQ(NFQ)))
25862 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
25863 & LOG(P2EFF/ALAMSQ(NFQ-1)))
25864 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
25865 ENDIF
25866
25867C...Bottom: as above, but only include range above b threshold.
25868 ELSEIF(KFL.EQ.5) THEN
25869 IF(Q2.LE.PMB**2) GOTO 110
25870 P2EFF=MAX(P2EFF,PMB**2)
25871 Q2EFF=MAX(Q2,P2EFF)
25872 TDIFF=LOG(Q2EFF/P2EFF)
25873 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
25874 & LOG(P2EFF/ALAMSQ(NFQ)))
25875 ENDIF
25876
25877C...Evaluate flavour-dependent prefactor (charge^2 etc.).
25878 CHSQ=1D0/9D0
25879 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0
25880 FAC=AEM2PI*2D0*CHSQ*TDIFF
25881
25882C...Evaluate parton distributions (normalized to unit momentum sum).
25883 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
25884 XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 +
25885 & (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 +
25886 & 1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) *
25887 & X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S))
25888 XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) *
25889 & X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) *
25890 & ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL)
25891 XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) *
25892 & X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) *
25893 & ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 +
25894 & (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2)
25895
25896C...Threshold factors for c and b sea.
25897 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
25898 XCHM=0D0
25899 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
25900 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
25901 XCHM=XSEA*(1D0-(SCH/SLL)**3)
25902 ENDIF
25903 XBOT=0D0
25904 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
25905 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
25906 XBOT=XSEA*(1D0-(SBT/SLL)**3)
25907 ENDIF
25908 ENDIF
25909
25910C...Add contribution of each valence flavour.
25911 XPGA(0)=XPGA(0)+FAC*XGLU
25912 XPGA(1)=XPGA(1)+FAC*XSEA
25913 XPGA(2)=XPGA(2)+FAC*XSEA
25914 XPGA(3)=XPGA(3)+FAC*XSEA
25915 XPGA(4)=XPGA(4)+FAC*XCHM
25916 XPGA(5)=XPGA(5)+FAC*XBOT
25917 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
25918 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
25919 110 CONTINUE
25920 DO 120 KFL=1,5
25921 XPGA(-KFL)=XPGA(KFL)
25922 VXPGA(-KFL)=VXPGA(KFL)
25923 120 CONTINUE
25924
25925 RETURN
25926 END
25927
25928C*********************************************************************
25929
25930C...PYGBEH
25931C...Evaluates the Bethe-Heitler cross section for heavy flavour
25932C...production.
25933C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
25934
25935 SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)
25936
25937C...Double precision and integer declarations.
25938 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25939 IMPLICIT INTEGER(I-N)
25940 INTEGER PYK,PYCHGE,PYCOMP
25941
25942C...Local data.
25943 DATA AEM2PI/0.0011614D0/
25944
25945C...Reset output.
25946 XPBH=0D0
25947 SIGBH=0D0
25948
25949C...Check kinematics limits.
25950 IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
25951 W2=Q2*(1D0-X)/X-P2
25952 BETA2=1D0-4D0*PM2/W2
25953 IF(BETA2.LT.1D-10) RETURN
25954 BETA=SQRT(BETA2)
25955 RMQ=4D0*PM2/Q2
25956
25957C...Simple case: P2 = 0.
25958 IF(P2.LT.1D-4) THEN
25959 IF(BETA.LT.0.99D0) THEN
25960 XBL=LOG((1D0+BETA)/(1D0-BETA))
25961 ELSE
25962 XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
25963 ENDIF
25964 SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
25965 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)
25966
25967C...Complicated case: P2 > 0, based on approximation of
25968C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
25969 ELSE
25970 RPQ=1D0-4D0*X**2*P2/Q2
25971 IF(RPQ.GT.1D-10) THEN
25972 RPBE=SQRT(RPQ*BETA2)
25973 IF(RPBE.LT.0.99D0) THEN
25974 XBL=LOG((1D0+RPBE)/(1D0-RPBE))
25975 XBI=2D0*RPBE/(1D0-RPBE**2)
25976 ELSE
25977 RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
25978 XBL=LOG((1D0+RPBE)**2/RPBESN)
25979 XBI=2D0*RPBE/RPBESN
25980 ENDIF
25981 SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
25982 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
25983 & XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
25984 ENDIF
25985 ENDIF
25986
25987C...Multiply by charge-squared etc. to get parton distribution.
25988 CHSQ=1D0/9D0
25989 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0
25990 XPBH=3D0*CHSQ*AEM2PI*X*SIGBH
25991
25992 RETURN
25993 END
25994
25995C*********************************************************************
25996
25997C...PYGDIR
25998C...Evaluates the direct contribution, i.e. the C^gamma term,
25999C...as needed in MSbar parametrizations.
26000C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
26001
26002 SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA)
26003
26004C...Double precision and integer declarations.
26005 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26006 IMPLICIT INTEGER(I-N)
26007 INTEGER PYK,PYCHGE,PYCOMP
26008C...Local array and data.
26009 DIMENSION XPGA(-6:6)
26010 DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/
26011
26012C...Reset output.
26013 DO 100 KFL=-6,6
26014 XPGA(KFL)=0D0
26015 100 CONTINUE
26016
26017C...Evaluate common x-dependent expression.
26018 XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0
26019 CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X))
26020
26021C...d, u, s part by simple charge factor.
26022 XPGA(1)=(1D0/9D0)*CGAM
26023 XPGA(2)=(4D0/9D0)*CGAM
26024 XPGA(3)=(1D0/9D0)*CGAM
26025
26026C...Also fill for antiquarks.
26027 DO 110 KF=1,5
26028 XPGA(-KF)=XPGA(KF)
26029 110 CONTINUE
26030
26031 RETURN
26032 END
26033
26034C*********************************************************************
26035
26036C...PYPDPI
26037C...Gives pi+ parton distribution according to two different
26038C...parametrizations.
26039
26040 SUBROUTINE PYPDPI(X,Q2,XPPI)
26041
26042C...Double precision and integer declarations.
26043 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26044 IMPLICIT INTEGER(I-N)
26045 INTEGER PYK,PYCHGE,PYCOMP
26046C...Commonblocks.
26047 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
26048 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
26049 COMMON/PYINT1/MINT(400),VINT(400)
26050 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
26051C...Local arrays.
26052 DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6)
26053
26054C...The following data lines are coefficients needed in the
26055C...Owens pion parton distribution parametrizations, see below.
26056C...Expansion coefficients for up and down valence quark distributions.
26057 DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
26058 &4.0000D-01, 7.0000D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
26059 &-6.2120D-02, 6.4780D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
26060 &-7.1090D-03, 1.3350D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
26061 DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
26062 &4.0000D-01, 6.2800D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
26063 &-5.9090D-02, 6.4360D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
26064 &-6.5240D-03, 1.4510D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
26065C...Expansion coefficients for gluon distribution.
26066 DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
26067 &8.8800D-01, 0.0000D+00, 3.1100D+00, 6.0000D+00, 0.0000D+00,
26068 &-1.8020D+00, -1.5760D+00, -1.3170D-01, 2.8010D+00, -1.7280D+01,
26069 &1.8120D+00, 1.2000D+00, 5.0680D-01, -1.2160D+01, 2.0490D+01/
26070 DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
26071 &7.9400D-01, 0.0000D+00, 2.8900D+00, 6.0000D+00, 0.0000D+00,
26072 &-9.1440D-01, -1.2370D+00, 5.9660D-01, -3.6710D+00, -8.1910D+00,
26073 &5.9660D-01, 6.5820D-01, -2.5500D-01, -2.3040D+00, 7.7580D+00/
26074C...Expansion coefficients for (up+down+strange) quark sea distribution.
26075 DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
26076 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
26077 &-2.4280D-01, -2.1200D-01, 8.6730D-01, 1.2660D+00, 2.3820D+00,
26078 &1.3860D-01, 3.6710D-03, 4.7470D-02, -2.2150D+00, 3.4820D-01/
26079 DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
26080 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
26081 &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00, 5.6210D-01,
26082 &-1.7400D-01, -9.6230D-02, 1.5750D+00, 1.3780D+00, -2.7010D-01/
26083C...Expansion coefficients for charm quark sea distribution.
26084 DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
26085 &0.0000D+00, -2.2120D-02, 2.8940D+00, 0.0000D+00, 0.0000D+00,
26086 &7.9280D-02, -3.7850D-01, 9.4330D+00, 5.2480D+00, 8.3880D+00,
26087 &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/
26088 DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
26089 &0.0000D+00, -8.8200D-02, 1.9240D+00, 0.0000D+00, 0.0000D+00,
26090 &6.2290D-02, -2.8920D-01, 2.4240D-01, -4.4630D+00, -8.3670D-01,
26091 &-4.0990D-02, -1.0820D-01, 2.0360D+00, 5.2090D+00, -4.8400D-02/
26092
26093C...Euler's beta function, requires ordinary Gamma function
26094 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
26095
26096C...Reset output array.
26097 DO 100 KFL=-6,6
26098 XPPI(KFL)=0D0
26099 100 CONTINUE
26100
26101 IF(MSTP(53).LE.2) THEN
26102C...Pion parton distributions from Owens.
26103C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
26104
26105C...Determine set, Lambda and s expansion variable.
26106 NSET=MSTP(53)
26107 IF(NSET.EQ.1) ALAM=0.2D0
26108 IF(NSET.EQ.2) ALAM=0.4D0
26109 VINT(231)=4D0
26110 IF(MSTP(57).LE.0) THEN
26111 SD=0D0
26112 ELSE
26113 Q2IN=MIN(2D3,MAX(4D0,Q2))
26114 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
26115 ENDIF
26116
26117C...Calculate parton distributions.
26118 DO 120 KFL=1,4
26119 DO 110 IS=1,5
26120 TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
26121 & COW(3,IS,KFL,NSET)*SD**2
26122 110 CONTINUE
26123 IF(KFL.EQ.1) THEN
26124 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0)
26125 ELSE
26126 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
26127 & TS(5)*X**2)
26128 ENDIF
26129 120 CONTINUE
26130
26131C...Put into output array.
26132 XPPI(0)=XQ(2)
26133 XPPI(1)=XQ(3)/6D0
26134 XPPI(2)=XQ(1)+XQ(3)/6D0
26135 XPPI(3)=XQ(3)/6D0
26136 XPPI(4)=XQ(4)
26137 XPPI(-1)=XQ(1)+XQ(3)/6D0
26138 XPPI(-2)=XQ(3)/6D0
26139 XPPI(-3)=XQ(3)/6D0
26140 XPPI(-4)=XQ(4)
26141
26142C...Leading order pion parton distributions from Gluck, Reya and Vogt.
26143C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
26144C...10^-5 < x < 1.
26145 ELSE
26146
26147C...Determine s expansion variable and some x expressions.
26148 VINT(231)=0.25D0
26149 IF(MSTP(57).LE.0) THEN
26150 SD=0D0
26151 ELSE
26152 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
26153 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
26154 ENDIF
26155 SD2=SD**2
26156 XL=-LOG(X)
26157 XS=SQRT(X)
26158
26159C...Evaluate valence, gluon and sea distributions.
26160 XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)*
26161 & (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD)
26162 XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0*
26163 & SD-0.175D0*SD2)+
26164 & (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+
26165 & SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0*
26166 & XL)))*
26167 & (1D0-X)**(0.390D0+1.053D0*SD)
26168 XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0-
26169 & X)**3.359D0*
26170 & EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0*
26171 & XL))/
26172 & XL**(2.538D0-0.763D0*SD)
26173 IF(SD.LE.0.888D0) THEN
26174 XFCHM=0D0
26175 ELSE
26176 XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+
26177 & 0.771D0*SD)*
26178 & EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0*
26179 & XL))
26180 ENDIF
26181 IF(SD.LE.1.351D0) THEN
26182 XFBOT=0D0
26183 ELSE
26184 XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)*
26185 & EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0*
26186 & XL))
26187 ENDIF
26188
26189C...Put into output array.
26190 XPPI(0)=XFGLU
26191 XPPI(1)=XFSEA
26192 XPPI(2)=XFSEA
26193 XPPI(3)=XFSEA
26194 XPPI(4)=XFCHM
26195 XPPI(5)=XFBOT
26196 DO 130 KFL=1,5
26197 XPPI(-KFL)=XPPI(KFL)
26198 130 CONTINUE
26199 XPPI(2)=XPPI(2)+XFVAL
26200 XPPI(-1)=XPPI(-1)+XFVAL
26201 ENDIF
26202
26203 RETURN
26204 END
26205
26206C*********************************************************************
26207
26208C...PYPDPR
26209C...Gives proton parton distributions according to a few different
26210C...parametrizations.
26211
26212 SUBROUTINE PYPDPR(X,Q2,XPPR)
26213
26214C...Double precision and integer declarations.
26215 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26216 IMPLICIT INTEGER(I-N)
26217 INTEGER PYK,PYCHGE,PYCOMP
26218C...Commonblocks.
26219 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
26220 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
26221 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
26222 COMMON/PYINT1/MINT(400),VINT(400)
26223 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
26224C...Arrays and data.
26225 DIMENSION XPPR(-6:6),Q2MIN(16)
26226 DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0,
26227 &1.0D0, 1.0D0, 2*0D0, 0.25D0, 5D0, 5D0, 4D0, 4D0, 0D0/
26228
26229C...Reset output array.
26230 DO 100 KFL=-6,6
26231 XPPR(KFL)=0D0
26232 100 CONTINUE
26233
26234C...Common preliminaries.
26235 NSET=MAX(1,MIN(16,MSTP(51)))
26236 IF(NSET.EQ.9.OR.NSET.EQ.10) NSET=6
26237 VINT(231)=Q2MIN(NSET)
26238 IF(MSTP(57).EQ.0) THEN
26239 Q2L=Q2MIN(NSET)
26240 ELSE
26241 Q2L=MAX(Q2MIN(NSET),Q2)
26242 ENDIF
26243
26244 IF(NSET.GE.1.AND.NSET.LE.3) THEN
26245C...Interface to the CTEQ 3 parton distributions.
26246 QRT=SQRT(MAX(1D0,Q2L))
26247
26248C...Loop over flavours.
26249 DO 110 I=-6,6
26250 IF(I.LE.0) THEN
26251 XPPR(I)=PYCTEQ(NSET,I,X,QRT)
26252 ELSEIF(I.LE.2) THEN
26253 XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I)
26254 ELSE
26255 XPPR(I)=XPPR(-I)
26256 ENDIF
26257 110 CONTINUE
26258
26259 ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN
26260C...Interface to the GRV 94 distributions.
26261 IF(NSET.EQ.4) THEN
26262 CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
26263 ELSEIF(NSET.EQ.5) THEN
26264 CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
26265 ELSE
26266 CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
26267 ENDIF
26268
26269C...Put into output array.
26270 XPPR(0)=GL
26271 XPPR(-1)=0.5D0*(UDB+DEL)
26272 XPPR(-2)=0.5D0*(UDB-DEL)
26273 XPPR(-3)=SB
26274 XPPR(-4)=CHM
26275 XPPR(-5)=BOT
26276 XPPR(1)=DV+XPPR(-1)
26277 XPPR(2)=UV+XPPR(-2)
26278 XPPR(3)=SB
26279 XPPR(4)=CHM
26280 XPPR(5)=BOT
26281
26282 ELSEIF(NSET.EQ.7) THEN
26283C...Interface to the CTEQ 5L parton distributions.
26284C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by
26285C...freezing x*f(x,Q2) at borders.
26286 QRT=SQRT(MAX(1D0,MIN(1D4,Q2L)))
26287 XIN=MAX(1D-6,MIN(1D0,X))
26288
26289C...Loop over flavours (with u <-> d notation mismatch).
26290 SUMUDB=PYCT5L(-1,XIN,QRT)
26291 RATUDB=PYCT5L(-2,XIN,QRT)
26292 DO 120 I=-5,2
26293 IF(I.EQ.1) THEN
26294 XPPR(I)=XIN*PYCT5L(2,XIN,QRT)
26295 ELSEIF(I.EQ.2) THEN
26296 XPPR(I)=XIN*PYCT5L(1,XIN,QRT)
26297 ELSEIF(I.EQ.-1) THEN
26298 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
26299 ELSEIF(I.EQ.-2) THEN
26300 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
26301 ELSE
26302 XPPR(I)=XIN*PYCT5L(I,XIN,QRT)
26303 IF(I.LT.0) XPPR(-I)=XPPR(I)
26304 ENDIF
26305 120 CONTINUE
26306
26307 ELSEIF(NSET.EQ.8) THEN
26308C...Interface to the CTEQ 5M1 parton distributions.
26309 QRT=SQRT(MAX(1D0,MIN(1D4,Q2L)))
26310 XIN=MAX(1D-6,MIN(1D0,X))
26311
26312C...Loop over flavours (with u <-> d notation mismatch).
26313 SUMUDB=PYCT5M(-1,XIN,QRT)
26314 RATUDB=PYCT5M(-2,XIN,QRT)
26315 DO 130 I=-5,2
26316 IF(I.EQ.1) THEN
26317 XPPR(I)=XIN*PYCT5M(2,XIN,QRT)
26318 ELSEIF(I.EQ.2) THEN
26319 XPPR(I)=XIN*PYCT5M(1,XIN,QRT)
26320 ELSEIF(I.EQ.-1) THEN
26321 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
26322 ELSEIF(I.EQ.-2) THEN
26323 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
26324 ELSE
26325 XPPR(I)=XIN*PYCT5M(I,XIN,QRT)
26326 IF(I.LT.0) XPPR(-I)=XPPR(I)
26327 ENDIF
26328 130 CONTINUE
26329
26330 ELSEIF(NSET.GE.11.AND.NSET.LE.15) THEN
26331C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions:
26332C...obsolete but offers backwards compatibility.
26333 CALL PYPDPO(X,Q2L,XPPR)
26334
26335C...Symmetric choice for debugging only
26336 ELSEIF(NSET.EQ.16) THEN
26337 XPPR(0)=.5D0/X
26338 XPPR(1)=.05D0/X
26339 XPPR(2)=.05D0/X
26340 XPPR(3)=.05D0/X
26341 XPPR(4)=.05D0/X
26342 XPPR(5)=.05D0/X
26343 XPPR(-1)=.05D0/X
26344 XPPR(-2)=.05D0/X
26345 XPPR(-3)=.05D0/X
26346 XPPR(-4)=.05D0/X
26347 XPPR(-5)=.05D0/X
26348
26349 ENDIF
26350
26351 RETURN
26352 END
26353
26354C*********************************************************************
26355
26356C...PYCTEQ
26357C...Gives the CTEQ 3 parton distribution function sets in
26358C...parametrized form, of October 24, 1994.
26359C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
26360C...J. Qiu, W.K. Tung and H. Weerts.
26361
26362 FUNCTION PYCTEQ (ISET, IPRT, X, Q)
26363
26364C...Double precision declaration.
26365 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26366 IMPLICIT INTEGER(I-N)
26367
26368C...Data on Lambda values of fits, minimum Q and quark masses.
26369 DIMENSION ALM(3), QMS(4:6)
26370 DATA ALM / 0.177D0, 0.239D0, 0.247D0 /
26371 DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 /
26372
26373C....Check flavour thresholds. Set up QI for SB.
26374 IP = IABS(IPRT)
26375 IF(IP .GE. 4) THEN
26376 IF(Q .LE. QMS(IP)) THEN
26377 PYCTEQ = 0D0
26378 RETURN
26379 ENDIF
26380 QI = QMS(IP)
26381 ELSE
26382 QI = QMN
26383 ENDIF
26384
26385C...Use "standard lambda" of parametrization program for expansion.
26386 ALAM = ALM (ISET)
26387 SBL = LOG(Q/ALAM) / LOG(QI/ALAM)
26388 SB = LOG (SBL)
26389 SB2 = SB*SB
26390 SB3 = SB2*SB
26391
26392C...Expansion for CTEQ3L.
26393 IF(ISET .EQ. 1) THEN
26394 IF(IPRT .EQ. 2) THEN
26395 A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2-
26396 & 0.3171D+00*SB3)
26397 A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3
26398 A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3
26399 A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3
26400 A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3
26401 A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3
26402 ELSEIF(IPRT .EQ. 1) THEN
26403 A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+
26404 & 0.7728D+00*SB3)
26405 A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3
26406 A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3
26407 A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3
26408 A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3
26409 A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3
26410 ELSEIF(IPRT .EQ. 0) THEN
26411 A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+
26412 & 0.5343D+00*SB3)
26413 A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3
26414 A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3
26415 A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3
26416 A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3
26417 A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3
26418 ELSEIF(IPRT .EQ. -1) THEN
26419 A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2-
26420 & 0.2031D+01*SB3)
26421 A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3
26422 A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3
26423 A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3
26424 A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3
26425 A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3
26426 ELSEIF(IPRT .EQ. -2) THEN
26427 A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2-
26428 & 0.9872D-01*SB3)
26429 A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3
26430 A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3
26431 A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3
26432 A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3
26433 A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3
26434 ELSEIF(IPRT .EQ. -3) THEN
26435 A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+
26436 & 0.8390D+00*SB3)
26437 A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3
26438 A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3
26439 A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3
26440 A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3
26441 A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3
26442 ELSEIF(IPRT .EQ. -4) THEN
26443 A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB +
26444 & 0.1651D-01*SB2)
26445 A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3
26446 A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3
26447 A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3
26448 A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3
26449 A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3
26450 ELSEIF(IPRT .EQ. -5) THEN
26451 A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB +
26452 & 0.3702D+01*SB2)
26453 A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3
26454 A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3
26455 A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3
26456 A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3
26457 A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3
26458 ELSEIF(IPRT .EQ. -6) THEN
26459 A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB -
26460 & 0.6943D+00*SB2)
26461 A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3
26462 A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3
26463 A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3
26464 A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3
26465 A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3
26466 ENDIF
26467
26468C...Expansion for CTEQ3M.
26469 ELSEIF(ISET .EQ. 2) THEN
26470 IF(IPRT .EQ. 2) THEN
26471 A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2-
26472 & 0.2935D+00*SB3)
26473 A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3
26474 A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3
26475 A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3
26476 A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3
26477 A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3
26478 ELSEIF(IPRT .EQ. 1) THEN
26479 A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2-
26480 & 0.4305D-01*SB3)
26481 A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3
26482 A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3
26483 A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3
26484 A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3
26485 A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3
26486 ELSEIF(IPRT .EQ. 0) THEN
26487 A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+
26488 & 0.1037D-01*SB3)
26489 A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3
26490 A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3
26491 A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3
26492 A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3
26493 A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3
26494 ELSEIF(IPRT .EQ. -1) THEN
26495 A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2-
26496 & 0.1602D+01*SB3)
26497 A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3
26498 A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3
26499 A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3
26500 A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3
26501 A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3
26502 ELSEIF(IPRT .EQ. -2) THEN
26503 A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+
26504 & 0.2496D+00*SB3)
26505 A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3
26506 A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3
26507 A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3
26508 A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3
26509 A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3
26510 ELSEIF(IPRT .EQ. -3) THEN
26511 A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+
26512 & 0.1936D+01*SB3)
26513 A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3
26514 A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3
26515 A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3
26516 A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3
26517 A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3
26518 ELSEIF(IPRT .EQ. -4) THEN
26519 A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB +
26520 & 0.5348D+00*SB2)
26521 A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3
26522 A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3
26523 A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3
26524 A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3
26525 A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3
26526 ELSEIF(IPRT .EQ. -5) THEN
26527 A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB +
26528 & 0.1569D+01*SB2)
26529 A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3
26530 A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3
26531 A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3
26532 A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3
26533 A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3
26534 ELSEIF(IPRT .EQ. -6) THEN
26535 A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB +
26536 & 0.8838D+01*SB2)
26537 A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3
26538 A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3
26539 A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3
26540 A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3
26541 A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3
26542 ENDIF
26543
26544C...Expansion for CTEQ3D.
26545 ELSEIF(ISET .EQ. 3) THEN
26546 IF(IPRT .EQ. 2) THEN
26547 A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2-
26548 & 0.2902D+00*SB3)
26549 A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3
26550 A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3
26551 A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3
26552 A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3
26553 A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3
26554 ELSEIF(IPRT .EQ. 1) THEN
26555 A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+
26556 & 0.7257D+00*SB3)
26557 A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3
26558 A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3
26559 A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3
26560 A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3
26561 A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3
26562 ELSEIF(IPRT .EQ. 0) THEN
26563 A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2-
26564 & 0.2734D-04*SB3)
26565 A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3
26566 A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3
26567 A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3
26568 A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3
26569 A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3
26570 ELSEIF(IPRT .EQ. -1) THEN
26571 A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2-
26572 & 0.1671D+01*SB3)
26573 A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3
26574 A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3
26575 A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3
26576 A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3
26577 A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3
26578 ELSEIF(IPRT .EQ. -2) THEN
26579 A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+
26580 & 0.2223D+00*SB3)
26581 A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3
26582 A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3
26583 A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3
26584 A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3
26585 A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3
26586 ELSEIF(IPRT .EQ. -3) THEN
26587 A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+
26588 & 0.1937D+01*SB3)
26589 A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3
26590 A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3
26591 A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3
26592 A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3
26593 A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3
26594 ELSEIF(IPRT .EQ. -4) THEN
26595 A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB +
26596 & 0.5137D+00*SB2)
26597 A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3
26598 A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3
26599 A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3
26600 A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3
26601 A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3
26602 ELSEIF(IPRT .EQ. -5) THEN
26603 A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB +
26604 & 0.2143D+01*SB2)
26605 A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3
26606 A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3
26607 A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3
26608 A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3
26609 A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3
26610 ELSEIF(IPRT .EQ. -6) THEN
26611 A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB +
26612 & 0.9998D+01*SB2)
26613 A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3
26614 A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3
26615 A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3
26616 A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3
26617 A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3
26618 ENDIF
26619 ENDIF
26620
26621C...Calculation of x * f(x, Q).
26622 PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4))
26623 & *(LOG(1D0+1D0/X))**A5 )
26624
26625 RETURN
26626 END
26627
26628C*********************************************************************
26629
26630C...PYGRVL
26631C...Gives the GRV 94 L (leading order) parton distribution function set
26632C...in parametrized form.
26633C...Authors: M. Glueck, E. Reya and A. Vogt.
26634
26635 SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
26636
26637C...Double precision declaration.
26638 IMPLICIT DOUBLE PRECISION (A - Z)
26639
26640C...Common expressions.
26641 MU2 = 0.23D0
26642 LAM2 = 0.2322D0 * 0.2322D0
26643 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
26644 DS = SQRT (S)
26645 S2 = S * S
26646 S3 = S2 * S
26647
26648C...uv :
26649 NU = 2.284D0 + 0.802D0 * S + 0.055D0 * S2
26650 AKU = 0.590D0 - 0.024D0 * S
26651 BKU = 0.131D0 + 0.063D0 * S
26652 AU = -0.449D0 - 0.138D0 * S - 0.076D0 * S2
26653 BU = 0.213D0 + 2.669D0 * S - 0.728D0 * S2
26654 CU = 8.854D0 - 9.135D0 * S + 1.979D0 * S2
26655 DU = 2.997D0 + 0.753D0 * S - 0.076D0 * S2
26656 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
26657
26658C...dv :
26659 ND = 0.371D0 + 0.083D0 * S + 0.039D0 * S2
26660 AKD = 0.376D0
26661 BKD = 0.486D0 + 0.062D0 * S
26662 AD = -0.509D0 + 3.310D0 * S - 1.248D0 * S2
26663 BD = 12.41D0 - 10.52D0 * S + 2.267D0 * S2
26664 CD = 6.373D0 - 6.208D0 * S + 1.418D0 * S2
26665 DD = 3.691D0 + 0.799D0 * S - 0.071D0 * S2
26666 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
26667
26668C...del :
26669 NE = 0.082D0 + 0.014D0 * S + 0.008D0 * S2
26670 AKE = 0.409D0 - 0.005D0 * S
26671 BKE = 0.799D0 + 0.071D0 * S
26672 AE = -38.07D0 + 36.13D0 * S - 0.656D0 * S2
26673 BE = 90.31D0 - 74.15D0 * S + 7.645D0 * S2
26674 CE = 0.0D0
26675 DE = 7.486D0 + 1.217D0 * S - 0.159D0 * S2
26676 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
26677
26678C...udb :
26679 ALX = 1.451D0
26680 BEX = 0.271D0
26681 AKX = 0.410D0 - 0.232D0 * S
26682 BKX = 0.534D0 - 0.457D0 * S
26683 AGX = 0.890D0 - 0.140D0 * S
26684 BGX = -0.981D0
26685 CX = 0.320D0 + 0.683D0 * S
26686 DX = 4.752D0 + 1.164D0 * S + 0.286D0 * S2
26687 EX = 4.119D0 + 1.713D0 * S
26688 ESX = 0.682D0 + 2.978D0 * S
26689 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
26690 & DX, EX, ESX)
26691
26692C...sb :
26693 STS = 0D0
26694 ALS = 0.914D0
26695 BES = 0.577D0
26696 AKS = 1.798D0 - 0.596D0 * S
26697 AS = -5.548D0 + 3.669D0 * DS - 0.616D0 * S
26698 BS = 18.92D0 - 16.73D0 * DS + 5.168D0 * S
26699 DST = 6.379D0 - 0.350D0 * S + 0.142D0 * S2
26700 EST = 3.981D0 + 1.638D0 * S
26701 ESS = 6.402D0
26702 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
26703
26704C...cb :
26705 STC = 0.888D0
26706 ALC = 1.01D0
26707 BEC = 0.37D0
26708 AKC = 0D0
26709 AC = 0D0
26710 BC = 4.24D0 - 0.804D0 * S
26711 DCT = 3.46D0 - 1.076D0 * S
26712 ECT = 4.61D0 + 1.49D0 * S
26713 ESC = 2.555D0 + 1.961D0 * S
26714 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
26715
26716C...bb :
26717 STB = 1.351D0
26718 ALB = 1.00D0
26719 BEB = 0.51D0
26720 AKB = 0D0
26721 AB = 0D0
26722 BB = 1.848D0
26723 DBT = 2.929D0 + 1.396D0 * S
26724 EBT = 4.71D0 + 1.514D0 * S
26725 ESB = 4.02D0 + 1.239D0 * S
26726 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
26727
26728C...gl :
26729 ALG = 0.524D0
26730 BEG = 1.088D0
26731 AKG = 1.742D0 - 0.930D0 * S
26732 BKG = - 0.399D0 * S2
26733 AG = 7.486D0 - 2.185D0 * S
26734 BG = 16.69D0 - 22.74D0 * S + 5.779D0 * S2
26735 CG = -25.59D0 + 29.71D0 * S - 7.296D0 * S2
26736 DG = 2.792D0 + 2.215D0 * S + 0.422D0 * S2 - 0.104D0 * S3
26737 EG = 0.807D0 + 2.005D0 * S
26738 ESG = 3.841D0 + 0.316D0 * S
26739 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG,
26740 & DG, EG, ESG)
26741
26742 RETURN
26743 END
26744
26745C*********************************************************************
26746
26747C...PYGRVM
26748C...Gives the GRV 94 M (MSbar) parton distribution function set
26749C...in parametrized form.
26750C...Authors: M. Glueck, E. Reya and A. Vogt.
26751
26752 SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
26753
26754C...Double precision declaration.
26755 IMPLICIT DOUBLE PRECISION (A - Z)
26756
26757C...Common expressions.
26758 MU2 = 0.34D0
26759 LAM2 = 0.248D0 * 0.248D0
26760 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
26761 DS = SQRT (S)
26762 S2 = S * S
26763 S3 = S2 * S
26764
26765C...uv :
26766 NU = 1.304D0 + 0.863D0 * S
26767 AKU = 0.558D0 - 0.020D0 * S
26768 BKU = 0.183D0 * S
26769 AU = -0.113D0 + 0.283D0 * S - 0.321D0 * S2
26770 BU = 6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3
26771 CU = 7.771D0 - 10.09D0 * S + 2.630D0 * S2
26772 DU = 3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3
26773 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
26774
26775C...dv :
26776 ND = 0.102D0 - 0.017D0 * S + 0.005D0 * S2
26777 AKD = 0.270D0 - 0.019D0 * S
26778 BKD = 0.260D0
26779 AD = 2.393D0 + 6.228D0 * S - 0.881D0 * S2
26780 BD = 46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3
26781 CD = 17.83D0 - 53.47D0 * S + 21.24D0 * S2
26782 DD = 4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3
26783 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
26784
26785C...del :
26786 NE = 0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3
26787 AKE = 0.409D0 - 0.007D0 * S
26788 BKE = 0.782D0 + 0.082D0 * S
26789 AE = -29.65D0 + 26.49D0 * S + 5.429D0 * S2
26790 BE = 90.20D0 - 74.97D0 * S + 4.526D0 * S2
26791 CE = 0.0D0
26792 DE = 8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3
26793 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
26794
26795C...udb :
26796 ALX = 0.877D0
26797 BEX = 0.561D0
26798 AKX = 0.275D0
26799 BKX = 0.0D0
26800 AGX = 0.997D0
26801 BGX = 3.210D0 - 1.866D0 * S
26802 CX = 7.300D0
26803 DX = 9.010D0 + 0.896D0 * DS + 0.222D0 * S2
26804 EX = 3.077D0 + 1.446D0 * S
26805 ESX = 3.173D0 - 2.445D0 * DS + 2.207D0 * S
26806 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
26807 & DX, EX, ESX)
26808
26809C...sb :
26810 STS = 0D0
26811 ALS = 0.756D0
26812 BES = 0.216D0
26813 AKS = 1.690D0 + 0.650D0 * DS - 0.922D0 * S
26814 AS = -4.329D0 + 1.131D0 * S
26815 BS = 9.568D0 - 1.744D0 * S
26816 DST = 9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2
26817 EST = 3.031D0 + 1.639D0 * S
26818 ESS = 5.837D0 + 0.815D0 * S
26819 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
26820
26821C...cb :
26822 STC = 0.820D0
26823 ALC = 0.98D0
26824 BEC = 0D0
26825 AKC = -0.625D0 - 0.523D0 * S
26826 AC = 0D0
26827 BC = 1.896D0 + 1.616D0 * S
26828 DCT = 4.12D0 + 0.683D0 * S
26829 ECT = 4.36D0 + 1.328D0 * S
26830 ESC = 0.677D0 + 0.679D0 * S
26831 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
26832
26833C...bb :
26834 STB = 1.297D0
26835 ALB = 0.99D0
26836 BEB = 0D0
26837 AKB = - 0.193D0 * S
26838 AB = 0D0
26839 BB = 0D0
26840 DBT = 3.447D0 + 0.927D0 * S
26841 EBT = 4.68D0 + 1.259D0 * S
26842 ESB = 1.892D0 + 2.199D0 * S
26843 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
26844
26845C...gl :
26846 ALG = 1.014D0
26847 BEG = 1.738D0
26848 AKG = 1.724D0 + 0.157D0 * S
26849 BKG = 0.800D0 + 1.016D0 * S
26850 AG = 7.517D0 - 2.547D0 * S
26851 BG = 34.09D0 - 52.21D0 * DS + 17.47D0 * S
26852 CG = 4.039D0 + 1.491D0 * S
26853 DG = 3.404D0 + 0.830D0 * S
26854 EG = -1.112D0 + 3.438D0 * S - 0.302D0 * S2
26855 ESG = 3.256D0 - 0.436D0 * S
26856 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
26857
26858 RETURN
26859 END
26860
26861C*********************************************************************
26862
26863C...PYGRVD
26864C...Gives the GRV 94 D (DIS) parton distribution function set
26865C...in parametrized form.
26866C...Authors: M. Glueck, E. Reya and A. Vogt.
26867
26868 SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
26869
26870C...Double precision declaration.
26871 IMPLICIT DOUBLE PRECISION (A - Z)
26872
26873C...Common expressions.
26874 MU2 = 0.34D0
26875 LAM2 = 0.248D0 * 0.248D0
26876 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
26877 DS = SQRT (S)
26878 S2 = S * S
26879 S3 = S2 * S
26880
26881C...uv :
26882 NU = 2.484D0 + 0.116D0 * S + 0.093D0 * S2
26883 AKU = 0.563D0 - 0.025D0 * S
26884 BKU = 0.054D0 + 0.154D0 * S
26885 AU = -0.326D0 - 0.058D0 * S - 0.135D0 * S2
26886 BU = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3
26887 CU = 11.52D0 - 12.99D0 * S + 3.161D0 * S2
26888 DU = 2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3
26889 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
26890
26891C...dv :
26892 ND = 0.156D0 - 0.017D0 * S
26893 AKD = 0.299D0 - 0.022D0 * S
26894 BKD = 0.259D0 - 0.015D0 * S
26895 AD = 3.445D0 + 1.278D0 * S + 0.326D0 * S2
26896 BD = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3
26897 CD = 55.45D0 - 69.92D0 * S + 20.78D0 * S2
26898 DD = 3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3
26899 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
26900
26901C...del :
26902 NE = 0.099D0 + 0.019D0 * S + 0.002D0 * S2
26903 AKE = 0.419D0 - 0.013D0 * S
26904 BKE = 1.064D0 - 0.038D0 * S
26905 AE = -44.00D0 + 98.70D0 * S - 14.79D0 * S2
26906 BE = 28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3
26907 CE = 84.57D0 - 108.8D0 * S + 31.52D0 * S2
26908 DE = 7.469D0 + 2.480D0 * S - 0.866D0 * S2
26909 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
26910
26911C...udb :
26912 ALX = 1.215D0
26913 BEX = 0.466D0
26914 AKX = 0.326D0 + 0.150D0 * S
26915 BKX = 0.956D0 + 0.405D0 * S
26916 AGX = 0.272D0
26917 BGX = 3.794D0 - 2.359D0 * DS
26918 CX = 2.014D0
26919 DX = 7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2
26920 EX = 3.049D0 + 1.597D0 * S
26921 ESX = 4.396D0 - 4.594D0 * DS + 3.268D0 * S
26922 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
26923 & DX, EX, ESX)
26924
26925C...sb :
26926 STS = 0D0
26927 ALS = 0.175D0
26928 BES = 0.344D0
26929 AKS = 1.415D0 - 0.641D0 * DS
26930 AS = 0.580D0 - 9.763D0 * DS + 6.795D0 * S - 0.558D0 * S2
26931 BS = 5.617D0 + 5.709D0 * DS - 3.972D0 * S
26932 DST = 13.78D0 - 9.581D0 * S + 5.370D0 * S2 - 0.996D0 * S3
26933 EST = 4.546D0 + 0.372D0 * S2
26934 ESS = 5.053D0 - 1.070D0 * S + 0.805D0 * S2
26935 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
26936
26937C...cb :
26938 STC = 0.820D0
26939 ALC = 0.98D0
26940 BEC = 0D0
26941 AKC = -0.625D0 - 0.523D0 * S
26942 AC = 0D0
26943 BC = 1.896D0 + 1.616D0 * S
26944 DCT = 4.12D0 + 0.683D0 * S
26945 ECT = 4.36D0 + 1.328D0 * S
26946 ESC = 0.677D0 + 0.679D0 * S
26947 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
26948
26949C...bb :
26950 STB = 1.297D0
26951 ALB = 0.99D0
26952 BEB = 0D0
26953 AKB = - 0.193D0 * S
26954 AB = 0D0
26955 BB = 0D0
26956 DBT = 3.447D0 + 0.927D0 * S
26957 EBT = 4.68D0 + 1.259D0 * S
26958 ESB = 1.892D0 + 2.199D0 * S
26959 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
26960
26961C...gl :
26962 ALG = 1.258D0
26963 BEG = 1.846D0
26964 AKG = 2.423D0
26965 BKG = 2.427D0 + 1.311D0 * S - 0.153D0 * S2
26966 AG = 25.09D0 - 7.935D0 * S
26967 BG = -14.84D0 - 124.3D0 * DS + 72.18D0 * S
26968 CG = 590.3D0 - 173.8D0 * S
26969 DG = 5.196D0 + 1.857D0 * S
26970 EG = -1.648D0 + 3.988D0 * S - 0.432D0 * S2
26971 ESG = 3.232D0 - 0.542D0 * S
26972 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
26973
26974 RETURN
26975 END
26976
26977C*********************************************************************
26978
26979C...PYGRVV
26980C...Auxiliary for the GRV 94 parton distribution functions
26981C...for u and d valence and d-u sea.
26982C...Authors: M. Glueck, E. Reya and A. Vogt.
26983
26984 FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D)
26985
26986C...Double precision declaration.
26987 IMPLICIT DOUBLE PRECISION (A - Z)
26988
26989C...Evaluation.
26990 DX = SQRT (X)
26991 PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) *
26992 & (1D0- X)**D
26993
26994 RETURN
26995 END
26996
26997C*********************************************************************
26998
26999C...PYGRVW
27000C...Auxiliary for the GRV 94 parton distribution functions
27001C...for d+u sea and gluon.
27002C...Authors: M. Glueck, E. Reya and A. Vogt.
27003
27004 FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
27005
27006C...Double precision declaration.
27007 IMPLICIT DOUBLE PRECISION (A - Z)
27008
27009C...Evaluation.
27010 LX = LOG (1D0/X)
27011 PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
27012 & * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D
27013
27014 RETURN
27015 END
27016
27017C*********************************************************************
27018
27019C...PYGRVS
27020C...Auxiliary for the GRV 94 parton distribution functions
27021C...for s, c and b sea.
27022C...Authors: M. Glueck, E. Reya and A. Vogt.
27023
27024 FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
27025
27026C...Double precision declaration.
27027 IMPLICIT DOUBLE PRECISION (A - Z)
27028
27029C...Evaluation.
27030 IF(S.LE.STH) THEN
27031 PYGRVS = 0D0
27032 ELSE
27033 DX = SQRT (X)
27034 LX = LOG (1D0/X)
27035 PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) *
27036 & (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX))
27037 ENDIF
27038
27039 RETURN
27040 END
27041
27042C*********************************************************************
27043
27044C...CTEQ5M1 and CTEQ5L Parton Distribution Functions
27045C...in Parametrized Form
27046C... September 15, 1999
27047C
27048C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON:
27049C... CTEQ5 PPARTON DISTRIBUTIONS"
27050C...hep-ph/9903282
27051
27052C...The CTEQ5M1 set given here is an updated version of the original
27053C...CTEQ5M set posted, in the table version, on the Web page of CTEQ.
27054C...The differences between CTEQ5M and CTEQ5M1 are insignificant for
27055C...almost all applications.
27056C...The improvement is in the QCD evolution which is now more
27057C...accurate, and which agrees completely with the benchmark work
27058C...of the HERA 96/97 Workshop.
27059C...The differences between the parametrized and the corresponding
27060C...table versions (on which it is based) are of similar order as
27061C...between the two version.
27062
27063C...!! Because accurate parametrizations over a wide range of (x,Q)
27064C...is hard to obtain, only the most widely used sets CTEQ5M and
27065C...CTEQ5L are available in parametrized form for now.
27066
27067C...These parametrizations were obtained by Jon Pumplin.
27068
27069C Iset PDF Description Alpha_s(Mz) Lam4 Lam5
27070C -------------------------------------------------------------------
27071C 1 CTEQ5M1 Standard NLO MSbar scheme 0.118 326 226
27072C 3 CTEQ5L Leading Order 0.127 192 146
27073C -------------------------------------------------------------------
27074C...Note the Qcd-lambda values given for CTEQ5L is for the leading
27075C...order form of Alpha_s!! Alpha_s(Mz) gives the absolute
27076C...calibration.
27077
27078C...The two Iset value are adopted to agree with the standard table
27079C...versions.
27080
27081C...Range of validity:
27082C...The range of (x, Q) covered by this parametrization of the QCD
27083C...evolved parton distributions is 1E-6 < x < 1 ;
27084C...1.1 GeV < Q < 10 TeV. Of course, the PDF's are constrained by
27085C...data only in a subset of that region; and the assumed DGLAP
27086C...evolution is unlikely to be valid for all of it either.
27087
27088C...The range of (x, Q) used in the CTEQ5 round of global analysis is
27089C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for
27090C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and
27091C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data.
27092
27093C* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
27094
27095C...PYCT5L
27096C...Auxiliary function for parametrization of CTEQ5L.
27097C...Author: J. Pumplin 9/99.
27098
27099 FUNCTION PYCT5L(IFL,X,Q)
27100
27101C...Double precision declaration.
27102 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27103 IMPLICIT INTEGER(I-N)
27104
27105 PARAMETER (NEX=8, NLF=2)
27106 DIMENSION AM(0:NEX,0:NLF,-5:2)
27107 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
27108 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
27109 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
27110 DIMENSION AF(0:NEX)
27111
27112 DATA MEXVEC( 2) / 8 /
27113 DATA MLFVEC( 2) / 2 /
27114 DATA UT1VEC( 2) / 0.4971265E+01 /
27115 DATA UT2VEC( 2) / -0.1105128E+01 /
27116 DATA ALFVEC( 2) / 0.2987216E+00 /
27117 DATA QMAVEC( 2) / 0.0000000E+00 /
27118 DATA (AM( 0,K, 2),K=0, 2)
27119 & / 0.5292616E+01, -0.2751910E+01, -0.2488990E+01 /
27120 DATA (AM( 1,K, 2),K=0, 2)
27121 & / 0.9714424E+00, 0.1011827E-01, -0.1023660E-01 /
27122 DATA (AM( 2,K, 2),K=0, 2)
27123 & / -0.1651006E+02, 0.7959721E+01, 0.8810563E+01 /
27124 DATA (AM( 3,K, 2),K=0, 2)
27125 & / -0.1643394E+02, 0.5892854E+01, 0.9348874E+01 /
27126 DATA (AM( 4,K, 2),K=0, 2)
27127 & / 0.3067422E+02, 0.4235796E+01, -0.5112136E+00 /
27128 DATA (AM( 5,K, 2),K=0, 2)
27129 & / 0.2352526E+02, -0.5305168E+01, -0.1169174E+02 /
27130 DATA (AM( 6,K, 2),K=0, 2)
27131 & / -0.1095451E+02, 0.3006577E+01, 0.5638136E+01 /
27132 DATA (AM( 7,K, 2),K=0, 2)
27133 & / -0.1172251E+02, -0.2183624E+01, 0.4955794E+01 /
27134 DATA (AM( 8,K, 2),K=0, 2)
27135 & / 0.1662533E-01, 0.7622870E-02, -0.4895887E-03 /
27136
27137 DATA MEXVEC( 1) / 8 /
27138 DATA MLFVEC( 1) / 2 /
27139 DATA UT1VEC( 1) / 0.2612618E+01 /
27140 DATA UT2VEC( 1) / -0.1258304E+06 /
27141 DATA ALFVEC( 1) / 0.3407552E+00 /
27142 DATA QMAVEC( 1) / 0.0000000E+00 /
27143 DATA (AM( 0,K, 1),K=0, 2)
27144 & / 0.9905300E+00, -0.4502235E+00, 0.1624441E+00 /
27145 DATA (AM( 1,K, 1),K=0, 2)
27146 & / 0.8867534E+00, 0.1630829E-01, -0.4049085E-01 /
27147 DATA (AM( 2,K, 1),K=0, 2)
27148 & / 0.8547974E+00, 0.3336301E+00, 0.1371388E+00 /
27149 DATA (AM( 3,K, 1),K=0, 2)
27150 & / 0.2941113E+00, -0.1527905E+01, 0.2331879E+00 /
27151 DATA (AM( 4,K, 1),K=0, 2)
27152 & / 0.3384235E+02, 0.3715315E+01, 0.8276930E+00 /
27153 DATA (AM( 5,K, 1),K=0, 2)
27154 & / 0.6230115E+01, 0.3134639E+01, -0.1729099E+01 /
27155 DATA (AM( 6,K, 1),K=0, 2)
27156 & / -0.1186928E+01, -0.3282460E+00, 0.1052020E+00 /
27157 DATA (AM( 7,K, 1),K=0, 2)
27158 & / -0.8545702E+01, -0.6247947E+01, 0.3692561E+01 /
27159 DATA (AM( 8,K, 1),K=0, 2)
27160 & / 0.1724598E-01, 0.7120465E-02, 0.4003646E-04 /
27161
27162 DATA MEXVEC( 0) / 8 /
27163 DATA MLFVEC( 0) / 2 /
27164 DATA UT1VEC( 0) / -0.4656819E+00 /
27165 DATA UT2VEC( 0) / -0.2742390E+03 /
27166 DATA ALFVEC( 0) / 0.4491863E+00 /
27167 DATA QMAVEC( 0) / 0.0000000E+00 /
27168 DATA (AM( 0,K, 0),K=0, 2)
27169 & / 0.1193572E+03, -0.3886845E+01, -0.1133965E+01 /
27170 DATA (AM( 1,K, 0),K=0, 2)
27171 & / -0.9421449E+02, 0.3995885E+01, 0.1607363E+01 /
27172 DATA (AM( 2,K, 0),K=0, 2)
27173 & / 0.4206383E+01, 0.2485954E+00, 0.2497468E+00 /
27174 DATA (AM( 3,K, 0),K=0, 2)
27175 & / 0.1210557E+03, -0.3015765E+01, -0.1423651E+01 /
27176 DATA (AM( 4,K, 0),K=0, 2)
27177 & / -0.1013897E+03, -0.7113478E+00, 0.2621865E+00 /
27178 DATA (AM( 5,K, 0),K=0, 2)
27179 & / -0.1312404E+01, -0.9297691E+00, -0.1562531E+00 /
27180 DATA (AM( 6,K, 0),K=0, 2)
27181 & / 0.1627137E+01, 0.4954111E+00, -0.6387009E+00 /
27182 DATA (AM( 7,K, 0),K=0, 2)
27183 & / 0.1537698E+00, -0.2487878E+00, 0.8305947E+00 /
27184 DATA (AM( 8,K, 0),K=0, 2)
27185 & / 0.2496448E-01, 0.2457823E-02, 0.8234276E-03 /
27186
27187 DATA MEXVEC(-1) / 8 /
27188 DATA MLFVEC(-1) / 2 /
27189 DATA UT1VEC(-1) / 0.3862583E+01 /
27190 DATA UT2VEC(-1) / -0.1265969E+01 /
27191 DATA ALFVEC(-1) / 0.2457668E+00 /
27192 DATA QMAVEC(-1) / 0.0000000E+00 /
27193 DATA (AM( 0,K,-1),K=0, 2)
27194 & / 0.2647441E+02, 0.1059277E+02, -0.9176654E+00 /
27195 DATA (AM( 1,K,-1),K=0, 2)
27196 & / 0.1990636E+01, 0.8558918E-01, 0.4248667E-01 /
27197 DATA (AM( 2,K,-1),K=0, 2)
27198 & / -0.1476095E+02, -0.3276255E+02, 0.1558110E+01 /
27199 DATA (AM( 3,K,-1),K=0, 2)
27200 & / -0.2966889E+01, -0.3649037E+02, 0.1195914E+01 /
27201 DATA (AM( 4,K,-1),K=0, 2)
27202 & / -0.1000519E+03, -0.2464635E+01, 0.1964849E+00 /
27203 DATA (AM( 5,K,-1),K=0, 2)
27204 & / 0.3718331E+02, 0.4700389E+02, -0.2772142E+01 /
27205 DATA (AM( 6,K,-1),K=0, 2)
27206 & / -0.1872722E+02, -0.2291189E+02, 0.1089052E+01 /
27207 DATA (AM( 7,K,-1),K=0, 2)
27208 & / -0.1628146E+02, -0.1823993E+02, 0.2537369E+01 /
27209 DATA (AM( 8,K,-1),K=0, 2)
27210 & / -0.1156300E+01, -0.1280495E+00, 0.5153245E-01 /
27211
27212 DATA MEXVEC(-2) / 7 /
27213 DATA MLFVEC(-2) / 2 /
27214 DATA UT1VEC(-2) / 0.1895615E+00 /
27215 DATA UT2VEC(-2) / -0.3069097E+01 /
27216 DATA ALFVEC(-2) / 0.5293999E+00 /
27217 DATA QMAVEC(-2) / 0.0000000E+00 /
27218 DATA (AM( 0,K,-2),K=0, 2)
27219 & / -0.6556775E+00, 0.2490190E+00, 0.3966485E-01 /
27220 DATA (AM( 1,K,-2),K=0, 2)
27221 & / 0.1305102E+01, -0.1188925E+00, -0.4600870E-02 /
27222 DATA (AM( 2,K,-2),K=0, 2)
27223 & / -0.2371436E+01, 0.3566814E+00, -0.2834683E+00 /
27224 DATA (AM( 3,K,-2),K=0, 2)
27225 & / -0.6152826E+01, 0.8339877E+00, -0.7233230E+00 /
27226 DATA (AM( 4,K,-2),K=0, 2)
27227 & / -0.8346558E+01, 0.2892168E+01, 0.2137099E+00 /
27228 DATA (AM( 5,K,-2),K=0, 2)
27229 & / 0.1279530E+02, 0.1021114E+00, 0.5787439E+00 /
27230 DATA (AM( 6,K,-2),K=0, 2)
27231 & / 0.5858816E+00, -0.1940375E+01, -0.4029269E+00 /
27232 DATA (AM( 7,K,-2),K=0, 2)
27233 & / -0.2795725E+02, -0.5263392E+00, 0.1290229E+01 /
27234
27235 DATA MEXVEC(-3) / 7 /
27236 DATA MLFVEC(-3) / 2 /
27237 DATA UT1VEC(-3) / 0.3753257E+01 /
27238 DATA UT2VEC(-3) / -0.1113085E+01 /
27239 DATA ALFVEC(-3) / 0.3713141E+00 /
27240 DATA QMAVEC(-3) / 0.0000000E+00 /
27241 DATA (AM( 0,K,-3),K=0, 2)
27242 & / 0.1580931E+01, -0.2273826E+01, -0.1822245E+01 /
27243 DATA (AM( 1,K,-3),K=0, 2)
27244 & / 0.2702644E+01, 0.6763243E+00, 0.7231586E-02 /
27245 DATA (AM( 2,K,-3),K=0, 2)
27246 & / -0.1857924E+02, 0.3907500E+01, 0.5850109E+01 /
27247 DATA (AM( 3,K,-3),K=0, 2)
27248 & / -0.3044793E+02, 0.2639332E+01, 0.5566644E+01 /
27249 DATA (AM( 4,K,-3),K=0, 2)
27250 & / -0.4258011E+01, -0.5429244E+01, 0.4418946E+00 /
27251 DATA (AM( 5,K,-3),K=0, 2)
27252 & / 0.3465259E+02, -0.5532604E+01, -0.4904153E+01 /
27253 DATA (AM( 6,K,-3),K=0, 2)
27254 & / -0.1658858E+02, 0.2923275E+01, 0.2266286E+01 /
27255 DATA (AM( 7,K,-3),K=0, 2)
27256 & / -0.1149263E+02, 0.2877475E+01, -0.7999105E+00 /
27257
27258 DATA MEXVEC(-4) / 7 /
27259 DATA MLFVEC(-4) / 2 /
27260 DATA UT1VEC(-4) / 0.4400772E+01 /
27261 DATA UT2VEC(-4) / -0.1356116E+01 /
27262 DATA ALFVEC(-4) / 0.3712017E-01 /
27263 DATA QMAVEC(-4) / 0.1300000E+01 /
27264 DATA (AM( 0,K,-4),K=0, 2)
27265 & / -0.8293661E+00, -0.3982375E+01, -0.6494283E-01 /
27266 DATA (AM( 1,K,-4),K=0, 2)
27267 & / 0.2754618E+01, 0.8338636E+00, -0.6885160E-01 /
27268 DATA (AM( 2,K,-4),K=0, 2)
27269 & / -0.1657987E+02, 0.1439143E+02, -0.6887240E+00 /
27270 DATA (AM( 3,K,-4),K=0, 2)
27271 & / -0.2800703E+02, 0.1535966E+02, -0.7377693E+00 /
27272 DATA (AM( 4,K,-4),K=0, 2)
27273 & / -0.6460216E+01, -0.4783019E+01, 0.4913297E+00 /
27274 DATA (AM( 5,K,-4),K=0, 2)
27275 & / 0.3141830E+02, -0.3178031E+02, 0.7136013E+01 /
27276 DATA (AM( 6,K,-4),K=0, 2)
27277 & / -0.1802509E+02, 0.1862163E+02, -0.4632843E+01 /
27278 DATA (AM( 7,K,-4),K=0, 2)
27279 & / -0.1240412E+02, 0.2565386E+02, -0.1066570E+02 /
27280
27281 DATA MEXVEC(-5) / 6 /
27282 DATA MLFVEC(-5) / 2 /
27283 DATA UT1VEC(-5) / 0.5562568E+01 /
27284 DATA UT2VEC(-5) / -0.1801317E+01 /
27285 DATA ALFVEC(-5) / 0.4952010E-02 /
27286 DATA QMAVEC(-5) / 0.4500000E+01 /
27287 DATA (AM( 0,K,-5),K=0, 2)
27288 & / -0.6031237E+01, 0.1992727E+01, -0.1076331E+01 /
27289 DATA (AM( 1,K,-5),K=0, 2)
27290 & / 0.2933912E+01, 0.5839674E+00, 0.7509435E-01 /
27291 DATA (AM( 2,K,-5),K=0, 2)
27292 & / -0.8284919E+01, 0.1488593E+01, -0.8251678E+00 /
27293 DATA (AM( 3,K,-5),K=0, 2)
27294 & / -0.1925986E+02, 0.2805753E+01, -0.3015446E+01 /
27295 DATA (AM( 4,K,-5),K=0, 2)
27296 & / -0.9480483E+01, -0.9767837E+00, -0.1165544E+01 /
27297 DATA (AM( 5,K,-5),K=0, 2)
27298 & / 0.2193195E+02, -0.1788518E+02, 0.9460908E+01 /
27299 DATA (AM( 6,K,-5),K=0, 2)
27300 & / -0.1327377E+02, 0.1201754E+02, -0.6277844E+01 /
27301
27302 IF(Q .LE. QMAVEC(IFL)) THEN
27303 PYCT5L = 0.D0
27304 RETURN
27305 ENDIF
27306
27307 IF(X .GE. 1.D0) THEN
27308 PYCT5L = 0.D0
27309 RETURN
27310 ENDIF
27311
27312 TMP = LOG(Q/ALFVEC(IFL))
27313 IF(TMP .LE. 0.D0) THEN
27314 PYCT5L = 0.D0
27315 RETURN
27316 ENDIF
27317
27318 SB = LOG(TMP)
27319 SB1 = SB - 1.2D0
27320 SB2 = SB1*SB1
27321
27322 DO 110 I = 0, NEX
27323 AF(I) = 0.D0
27324 SBX = 1.D0
27325 DO 100 K = 0, MLFVEC(IFL)
27326 AF(I) = AF(I) + SBX*AM(I,K,IFL)
27327 SBX = SB1*SBX
27328 100 CONTINUE
27329 110 CONTINUE
27330
27331 Y = -LOG(X)
27332 U = LOG(X/0.00001D0)
27333
27334 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
27335 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
27336 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
27337 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
27338 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
27339
27340 PYCT5L = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
27341
27342C...Include threshold factor.
27343 PYCT5L = PYCT5L * (1.D0 - QMAVEC(IFL)/Q)
27344
27345 RETURN
27346 END
27347
27348C*********************************************************************
27349
27350C...PYCT5M
27351C...Auxiliary function for parametrization of CTEQ5M1.
27352C...Author: J. Pumplin 9/99.
27353
27354 FUNCTION PYCT5M(IFL,X,Q)
27355
27356C...Double precision declaration.
27357 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27358 IMPLICIT INTEGER(I-N)
27359
27360 PARAMETER (NEX=8, NLF=2)
27361 DIMENSION AM(0:NEX,0:NLF,-5:2)
27362 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
27363 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
27364 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
27365 DIMENSION AF(0:NEX)
27366
27367 DATA MEXVEC( 2) / 8 /
27368 DATA MLFVEC( 2) / 2 /
27369 DATA UT1VEC( 2) / 0.5141718E+01 /
27370 DATA UT2VEC( 2) / -0.1346944E+01 /
27371 DATA ALFVEC( 2) / 0.5260555E+00 /
27372 DATA QMAVEC( 2) / 0.0000000E+00 /
27373 DATA (AM( 0,K, 2),K=0, 2)
27374 & / 0.4289071E+01, -0.2536870E+01, -0.1259948E+01 /
27375 DATA (AM( 1,K, 2),K=0, 2)
27376 & / 0.9839410E+00, 0.4168426E-01, -0.5018952E-01 /
27377 DATA (AM( 2,K, 2),K=0, 2)
27378 & / -0.1651961E+02, 0.9246261E+01, 0.5996400E+01 /
27379 DATA (AM( 3,K, 2),K=0, 2)
27380 & / -0.2077936E+02, 0.9786469E+01, 0.7656465E+01 /
27381 DATA (AM( 4,K, 2),K=0, 2)
27382 & / 0.3054926E+02, 0.1889536E+01, 0.1380541E+01 /
27383 DATA (AM( 5,K, 2),K=0, 2)
27384 & / 0.3084695E+02, -0.1212303E+02, -0.1053551E+02 /
27385 DATA (AM( 6,K, 2),K=0, 2)
27386 & / -0.1426778E+02, 0.6239537E+01, 0.5254819E+01 /
27387 DATA (AM( 7,K, 2),K=0, 2)
27388 & / -0.1909811E+02, 0.3695678E+01, 0.5495729E+01 /
27389 DATA (AM( 8,K, 2),K=0, 2)
27390 & / 0.1889751E-01, 0.5027193E-02, 0.6624896E-03 /
27391
27392 DATA MEXVEC( 1) / 8 /
27393 DATA MLFVEC( 1) / 2 /
27394 DATA UT1VEC( 1) / 0.4138426E+01 /
27395 DATA UT2VEC( 1) / -0.3221374E+01 /
27396 DATA ALFVEC( 1) / 0.4960962E+00 /
27397 DATA QMAVEC( 1) / 0.0000000E+00 /
27398 DATA (AM( 0,K, 1),K=0, 2)
27399 & / 0.1332497E+01, -0.3703718E+00, 0.1288638E+00 /
27400 DATA (AM( 1,K, 1),K=0, 2)
27401 & / 0.7544687E+00, 0.3255075E-01, -0.4706680E-01 /
27402 DATA (AM( 2,K, 1),K=0, 2)
27403 & / -0.7638814E+00, 0.5008313E+00, -0.9237374E-01 /
27404 DATA (AM( 3,K, 1),K=0, 2)
27405 & / -0.3689889E+00, -0.1055098E+01, -0.4645065E+00 /
27406 DATA (AM( 4,K, 1),K=0, 2)
27407 & / 0.3991610E+02, 0.1979881E+01, 0.1775814E+01 /
27408 DATA (AM( 5,K, 1),K=0, 2)
27409 & / 0.6201080E+01, 0.2046288E+01, 0.3804571E+00 /
27410 DATA (AM( 6,K, 1),K=0, 2)
27411 & / -0.8027900E+00, -0.7011688E+00, -0.8049612E+00 /
27412 DATA (AM( 7,K, 1),K=0, 2)
27413 & / -0.8631305E+01, -0.3981200E+01, 0.6970153E+00 /
27414 DATA (AM( 8,K, 1),K=0, 2)
27415 & / 0.2371230E-01, 0.5372683E-02, 0.1118701E-02 /
27416
27417 DATA MEXVEC( 0) / 8 /
27418 DATA MLFVEC( 0) / 2 /
27419 DATA UT1VEC( 0) / -0.1026789E+01 /
27420 DATA UT2VEC( 0) / -0.9051707E+01 /
27421 DATA ALFVEC( 0) / 0.9462977E+00 /
27422 DATA QMAVEC( 0) / 0.0000000E+00 /
27423 DATA (AM( 0,K, 0),K=0, 2)
27424 & / 0.1191990E+03, -0.8548739E+00, -0.1963040E+01 /
27425 DATA (AM( 1,K, 0),K=0, 2)
27426 & / -0.9449972E+02, 0.1074771E+01, 0.2056055E+01 /
27427 DATA (AM( 2,K, 0),K=0, 2)
27428 & / 0.3701064E+01, -0.1167947E-02, 0.1933573E+00 /
27429 DATA (AM( 3,K, 0),K=0, 2)
27430 & / 0.1171345E+03, -0.1064540E+01, -0.1875312E+01 /
27431 DATA (AM( 4,K, 0),K=0, 2)
27432 & / -0.1014453E+03, -0.5707427E+00, 0.4511242E-01 /
27433 DATA (AM( 5,K, 0),K=0, 2)
27434 & / 0.6365168E+01, 0.1275354E+01, -0.4964081E+00 /
27435 DATA (AM( 6,K, 0),K=0, 2)
27436 & / -0.3370693E+01, -0.1122020E+01, 0.5947751E-01 /
27437 DATA (AM( 7,K, 0),K=0, 2)
27438 & / -0.5327270E+01, -0.9293556E+00, 0.6629940E+00 /
27439 DATA (AM( 8,K, 0),K=0, 2)
27440 & / 0.2437513E-01, 0.1600939E-02, 0.6855336E-03 /
27441
27442 DATA MEXVEC(-1) / 8 /
27443 DATA MLFVEC(-1) / 2 /
27444 DATA UT1VEC(-1) / 0.5243571E+01 /
27445 DATA UT2VEC(-1) / -0.2870513E+01 /
27446 DATA ALFVEC(-1) / 0.6701448E+00 /
27447 DATA QMAVEC(-1) / 0.0000000E+00 /
27448 DATA (AM( 0,K,-1),K=0, 2)
27449 & / 0.2428863E+02, 0.1907035E+01, -0.4606457E+00 /
27450 DATA (AM( 1,K,-1),K=0, 2)
27451 & / 0.2006810E+01, -0.1265915E+00, 0.7153556E-02 /
27452 DATA (AM( 2,K,-1),K=0, 2)
27453 & / -0.1884546E+02, -0.2339471E+01, 0.5740679E+01 /
27454 DATA (AM( 3,K,-1),K=0, 2)
27455 & / -0.2527892E+02, -0.2044124E+01, 0.1280470E+02 /
27456 DATA (AM( 4,K,-1),K=0, 2)
27457 & / -0.1013824E+03, -0.1594199E+01, 0.2216401E+00 /
27458 DATA (AM( 5,K,-1),K=0, 2)
27459 & / 0.8070930E+02, 0.1792072E+01, -0.2164364E+02 /
27460 DATA (AM( 6,K,-1),K=0, 2)
27461 & / -0.4641050E+02, 0.1977338E+00, 0.1273014E+02 /
27462 DATA (AM( 7,K,-1),K=0, 2)
27463 & / -0.3910568E+02, 0.1719632E+01, 0.1086525E+02 /
27464 DATA (AM( 8,K,-1),K=0, 2)
27465 & / -0.1185496E+01, -0.1905847E+00, -0.8744118E-03 /
27466
27467 DATA MEXVEC(-2) / 7 /
27468 DATA MLFVEC(-2) / 2 /
27469 DATA UT1VEC(-2) / 0.4782210E+01 /
27470 DATA UT2VEC(-2) / -0.1976856E+02 /
27471 DATA ALFVEC(-2) / 0.7558374E+00 /
27472 DATA QMAVEC(-2) / 0.0000000E+00 /
27473 DATA (AM( 0,K,-2),K=0, 2)
27474 & / -0.6216935E+00, 0.2369963E+00, -0.7909949E-02 /
27475 DATA (AM( 1,K,-2),K=0, 2)
27476 & / 0.1245440E+01, -0.1031510E+00, 0.4916523E-02 /
27477 DATA (AM( 2,K,-2),K=0, 2)
27478 & / -0.7060824E+01, -0.3875283E-01, 0.1784981E+00 /
27479 DATA (AM( 3,K,-2),K=0, 2)
27480 & / -0.7430595E+01, 0.1964572E+00, -0.1284999E+00 /
27481 DATA (AM( 4,K,-2),K=0, 2)
27482 & / -0.6897810E+01, 0.2620543E+01, 0.8012553E-02 /
27483 DATA (AM( 5,K,-2),K=0, 2)
27484 & / 0.1507713E+02, 0.2340307E-01, 0.2482535E+01 /
27485 DATA (AM( 6,K,-2),K=0, 2)
27486 & / -0.1815341E+01, -0.1538698E+01, -0.2014208E+01 /
27487 DATA (AM( 7,K,-2),K=0, 2)
27488 & / -0.2571932E+02, 0.2903941E+00, -0.2848206E+01 /
27489
27490 DATA MEXVEC(-3) / 7 /
27491 DATA MLFVEC(-3) / 2 /
27492 DATA UT1VEC(-3) / 0.4518239E+01 /
27493 DATA UT2VEC(-3) / -0.2690590E+01 /
27494 DATA ALFVEC(-3) / 0.6124079E+00 /
27495 DATA QMAVEC(-3) / 0.0000000E+00 /
27496 DATA (AM( 0,K,-3),K=0, 2)
27497 & / -0.2734458E+01, -0.7245673E+00, -0.6351374E+00 /
27498 DATA (AM( 1,K,-3),K=0, 2)
27499 & / 0.2927174E+01, 0.4822709E+00, -0.1088787E-01 /
27500 DATA (AM( 2,K,-3),K=0, 2)
27501 & / -0.1771017E+02, -0.1416635E+01, 0.8467622E+01 /
27502 DATA (AM( 3,K,-3),K=0, 2)
27503 & / -0.4972782E+02, -0.3348547E+01, 0.1767061E+02 /
27504 DATA (AM( 4,K,-3),K=0, 2)
27505 & / -0.7102770E+01, -0.3205337E+01, 0.4101704E+00 /
27506 DATA (AM( 5,K,-3),K=0, 2)
27507 & / 0.7169698E+02, -0.2205985E+01, -0.2463931E+02 /
27508 DATA (AM( 6,K,-3),K=0, 2)
27509 & / -0.4090347E+02, 0.2103486E+01, 0.1416507E+02 /
27510 DATA (AM( 7,K,-3),K=0, 2)
27511 & / -0.2952639E+02, 0.5376136E+01, 0.7825585E+01 /
27512
27513 DATA MEXVEC(-4) / 7 /
27514 DATA MLFVEC(-4) / 2 /
27515 DATA UT1VEC(-4) / 0.2783230E+01 /
27516 DATA UT2VEC(-4) / -0.1746328E+01 /
27517 DATA ALFVEC(-4) / 0.1115653E+01 /
27518 DATA QMAVEC(-4) / 0.1300000E+01 /
27519 DATA (AM( 0,K,-4),K=0, 2)
27520 & / -0.1743872E+01, -0.1128921E+01, -0.2841969E+00 /
27521 DATA (AM( 1,K,-4),K=0, 2)
27522 & / 0.3345755E+01, 0.3187765E+00, 0.1378124E+00 /
27523 DATA (AM( 2,K,-4),K=0, 2)
27524 & / -0.2037615E+02, 0.4121687E+01, 0.2236520E+00 /
27525 DATA (AM( 3,K,-4),K=0, 2)
27526 & / -0.4703104E+02, 0.5353087E+01, -0.1455347E+01 /
27527 DATA (AM( 4,K,-4),K=0, 2)
27528 & / -0.1060230E+02, -0.1551122E+01, -0.1078863E+01 /
27529 DATA (AM( 5,K,-4),K=0, 2)
27530 & / 0.5088892E+02, -0.8197304E+01, 0.8083451E+01 /
27531 DATA (AM( 6,K,-4),K=0, 2)
27532 & / -0.2819070E+02, 0.4554086E+01, -0.5890995E+01 /
27533 DATA (AM( 7,K,-4),K=0, 2)
27534 & / -0.1098238E+02, 0.2590096E+01, -0.8062879E+01 /
27535
27536 DATA MEXVEC(-5) / 6 /
27537 DATA MLFVEC(-5) / 2 /
27538 DATA UT1VEC(-5) / 0.1619654E+02 /
27539 DATA UT2VEC(-5) / -0.3367346E+01 /
27540 DATA ALFVEC(-5) / 0.5109891E-02 /
27541 DATA QMAVEC(-5) / 0.4500000E+01 /
27542 DATA (AM( 0,K,-5),K=0, 2)
27543 & / -0.6800138E+01, 0.2493627E+01, -0.1075724E+01 /
27544 DATA (AM( 1,K,-5),K=0, 2)
27545 & / 0.3036555E+01, 0.3324733E+00, 0.2008298E+00 /
27546 DATA (AM( 2,K,-5),K=0, 2)
27547 & / -0.5203879E+01, -0.8493476E+01, -0.4523208E+01 /
27548 DATA (AM( 3,K,-5),K=0, 2)
27549 & / -0.1524239E+01, -0.3411912E+01, -0.1771867E+02 /
27550 DATA (AM( 4,K,-5),K=0, 2)
27551 & / -0.1099444E+02, 0.1320930E+01, -0.2353831E+01 /
27552 DATA (AM( 5,K,-5),K=0, 2)
27553 & / 0.1699299E+02, -0.3565802E+02, 0.3566872E+02 /
27554 DATA (AM( 6,K,-5),K=0, 2)
27555 & / -0.1465793E+02, 0.2703365E+02, -0.2176372E+02 /
27556
27557 IF(Q .LE. QMAVEC(IFL)) THEN
27558 PYCT5M = 0.D0
27559 RETURN
27560 ENDIF
27561
27562 IF(X .GE. 1.D0) THEN
27563 PYCT5M = 0.D0
27564 RETURN
27565 ENDIF
27566
27567 TMP = LOG(Q/ALFVEC(IFL))
27568 IF(TMP .LE. 0.D0) THEN
27569 PYCT5M = 0.D0
27570 RETURN
27571 ENDIF
27572
27573 SB = LOG(TMP)
27574 SB1 = SB - 1.2D0
27575 SB2 = SB1*SB1
27576
27577 DO 110 I = 0, NEX
27578 AF(I) = 0.D0
27579 SBX = 1.D0
27580 DO 100 K = 0, MLFVEC(IFL)
27581 AF(I) = AF(I) + SBX*AM(I,K,IFL)
27582 SBX = SB1*SBX
27583 100 CONTINUE
27584 110 CONTINUE
27585
27586 Y = -LOG(X)
27587 U = LOG(X/0.00001D0)
27588
27589 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
27590 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
27591 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
27592 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
27593 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
27594
27595 PYCT5M = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
27596
27597C...Include threshold factor.
27598 PYCT5M = PYCT5M * (1.D0 - QMAVEC(IFL)/Q)
27599
27600 RETURN
27601 END
27602
27603C*********************************************************************
27604
27605C...PYPDPO
27606C...Auxiliary to PYPDPR. Gives proton parton distributions according to
27607C...a few older parametrizations, now obsolete but convenient for
27608C...backwards checks.
27609
27610 SUBROUTINE PYPDPO(X,Q2,XPPR)
27611
27612C...Double precision and integer declarations.
27613 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27614 IMPLICIT INTEGER(I-N)
27615 INTEGER PYK,PYCHGE,PYCOMP
27616C...Commonblocks.
27617 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27618 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27619 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27620 COMMON/PYINT1/MINT(400),VINT(400)
27621 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
27622 DIMENSION XPPR(-6:6),XQ(9),TX(6),TT(6),TS(6),NEHLQ(8,2),
27623 &CEHLQ(6,6,2,8,2),CDO(3,6,5,2)
27624
27625
27626C...The following data lines are coefficients needed in the
27627C...Eichten, Hinchliffe, Lane, Quigg proton structure function
27628C...parametrizations, see below.
27629C...Powers of 1-x in different cases.
27630 DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
27631C...Expansion coefficients for up valence quark distribution.
27632 DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
27633 1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04,
27634 2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03,
27635 3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03,
27636 4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03,
27637 5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03,
27638 6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04,
27639 1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04,
27640 2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03,
27641 3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04,
27642 4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04,
27643 5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05,
27644 6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/
27645 DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
27646 1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04,
27647 2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03,
27648 3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03,
27649 4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03,
27650 5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03,
27651 6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04,
27652 1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04,
27653 2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03,
27654 3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04,
27655 4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04,
27656 5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05,
27657 6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/
27658C...Expansion coefficients for down valence quark distribution.
27659 DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
27660 1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04,
27661 2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03,
27662 3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03,
27663 4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03,
27664 5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04,
27665 6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04,
27666 1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04,
27667 2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03,
27668 3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04,
27669 4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04,
27670 5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05,
27671 6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/
27672 DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
27673 1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04,
27674 2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03,
27675 3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03,
27676 4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03,
27677 5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04,
27678 6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04,
27679 1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04,
27680 2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03,
27681 3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04,
27682 4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04,
27683 5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05,
27684 6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/
27685C...Expansion coefficients for up and down sea quark distributions.
27686 DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
27687 1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04,
27688 2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03,
27689 3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05,
27690 4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04,
27691 5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04,
27692 6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05,
27693 1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04,
27694 2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03,
27695 3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04,
27696 4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05,
27697 5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00,
27698 6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/
27699 DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
27700 1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04,
27701 2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03,
27702 3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04,
27703 4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04,
27704 5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04,
27705 6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04,
27706 1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03,
27707 2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03,
27708 3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04,
27709 4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05,
27710 5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05,
27711 6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/
27712C...Expansion coefficients for gluon distribution.
27713 DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
27714 1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02,
27715 2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02,
27716 3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02,
27717 4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03,
27718 5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04,
27719 6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03,
27720 1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02,
27721 2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02,
27722 3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02,
27723 4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03,
27724 5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03,
27725 6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/
27726 DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
27727 1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02,
27728 2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02,
27729 3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02,
27730 4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02,
27731 5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02,
27732 6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02,
27733 1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02,
27734 2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01,
27735 3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02,
27736 4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03,
27737 5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03,
27738 6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/
27739C...Expansion coefficients for strange sea quark distribution.
27740 DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
27741 1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04,
27742 2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03,
27743 3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04,
27744 4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04,
27745 5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04,
27746 6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05,
27747 1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04,
27748 2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03,
27749 3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04,
27750 4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05,
27751 5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00,
27752 6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/
27753 DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
27754 1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04,
27755 2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03,
27756 3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04,
27757 4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04,
27758 5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04,
27759 6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04,
27760 1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03,
27761 2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03,
27762 3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04,
27763 4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05,
27764 5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05,
27765 6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/
27766C...Expansion coefficients for charm sea quark distribution.
27767 DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
27768 1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03,
27769 2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03,
27770 3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04,
27771 4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05,
27772 5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05,
27773 6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05,
27774 1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04,
27775 2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03,
27776 3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04,
27777 4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04,
27778 5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05,
27779 6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/
27780 DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
27781 1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03,
27782 2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03,
27783 3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04,
27784 4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05,
27785 5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05,
27786 6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05,
27787 1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03,
27788 2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03,
27789 3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04,
27790 4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04,
27791 5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05,
27792 6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/
27793C...Expansion coefficients for bottom sea quark distribution.
27794 DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
27795 1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03,
27796 2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04,
27797 3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04,
27798 4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05,
27799 5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05,
27800 6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05,
27801 1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03,
27802 2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03,
27803 3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04,
27804 4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05,
27805 5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05,
27806 6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/
27807 DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
27808 1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03,
27809 2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04,
27810 3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04,
27811 4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05,
27812 5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00,
27813 6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05,
27814 1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03,
27815 2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03,
27816 3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04,
27817 4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05,
27818 5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05,
27819 6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/
27820C...Expansion coefficients for top sea quark distribution.
27821 DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
27822 1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04,
27823 2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04,
27824 3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04,
27825 4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00,
27826 5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05,
27827 6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
27828 1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03,
27829 2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03,
27830 3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04,
27831 4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05,
27832 5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00,
27833 6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/
27834 DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
27835 1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04,
27836 2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04,
27837 3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04,
27838 4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00,
27839 5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05,
27840 6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
27841 1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03,
27842 2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03,
27843 3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04,
27844 4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05,
27845 5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00,
27846 6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/
27847
27848C...The following data lines are coefficients needed in the
27849C...Duke, Owens proton structure function parametrizations, see below.
27850C...Expansion coefficients for (up+down) valence quark distribution.
27851 DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/
27852 1 4.190D-01, 3.460D+00, 4.400D+00, 0.000D+00, 0.000D+00, 0.000D+00,
27853 2 4.000D-03, 7.240D-01,-4.860D+00, 0.000D+00, 0.000D+00, 0.000D+00,
27854 3-7.000D-03,-6.600D-02, 1.330D+00, 0.000D+00, 0.000D+00, 0.000D+00/
27855 DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/
27856 1 3.740D-01, 3.330D+00, 6.030D+00, 0.000D+00, 0.000D+00, 0.000D+00,
27857 2 1.400D-02, 7.530D-01,-6.220D+00, 0.000D+00, 0.000D+00, 0.000D+00,
27858 3 0.000D+00,-7.600D-02, 1.560D+00, 0.000D+00, 0.000D+00, 0.000D+00/
27859C...Expansion coefficients for down valence quark distribution.
27860 DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/
27861 1 7.630D-01, 4.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
27862 2-2.370D-01, 6.270D-01,-4.210D-01, 0.000D+00, 0.000D+00, 0.000D+00,
27863 3 2.600D-02,-1.900D-02, 3.300D-02, 0.000D+00, 0.000D+00, 0.000D+00/
27864 DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/
27865 1 7.610D-01, 3.830D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
27866 2-2.320D-01, 6.270D-01,-4.180D-01, 0.000D+00, 0.000D+00, 0.000D+00,
27867 3 2.300D-02,-1.900D-02, 3.600D-02, 0.000D+00, 0.000D+00, 0.000D+00/
27868C...Expansion coefficients for (up+down+strange) sea quark distribution.
27869 DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/
27870 1 1.265D+00, 0.000D+00, 8.050D+00, 0.000D+00, 0.000D+00, 0.000D+00,
27871 2-1.132D+00,-3.720D-01, 1.590D+00, 6.310D+00,-1.050D+01, 1.470D+01,
27872 3 2.930D-01,-2.900D-02,-1.530D-01,-2.730D-01,-3.170D+00, 9.800D+00/
27873 DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/
27874 1 1.670D+00, 0.000D+00, 9.150D+00, 0.000D+00, 0.000D+00, 0.000D+00,
27875 2-1.920D+00,-2.730D-01, 5.300D-01, 1.570D+01,-1.010D+02, 2.230D+02,
27876 3 5.820D-01,-1.640D-01,-7.630D-01,-2.830D+00, 4.470D+01,-1.170D+02/
27877C...Expansion coefficients for charm sea quark distribution.
27878 DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/
27879 1 0.000D+00,-3.600D-02, 6.350D+00, 0.000D+00, 0.000D+00, 0.000D+00,
27880 2 1.350D-01,-2.220D-01, 3.260D+00,-3.030D+00, 1.740D+01,-1.790D+01,
27881 3-7.500D-02,-5.800D-02,-9.090D-01, 1.500D+00,-1.130D+01, 1.560D+01/
27882 DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/
27883 1 0.000D+00,-1.200D-01, 3.510D+00, 0.000D+00, 0.000D+00, 0.000D+00,
27884 2 6.700D-02,-2.330D-01, 3.660D+00,-4.740D-01, 9.500D+00,-1.660D+01,
27885 3-3.100D-02,-2.300D-02,-4.530D-01, 3.580D-01,-5.430D+00, 1.550D+01/
27886C...Expansion coefficients for gluon distribution.
27887 DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/
27888 1 1.560D+00, 0.000D+00, 6.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
27889 2-1.710D+00,-9.490D-01, 1.440D+00,-7.190D+00,-1.650D+01, 1.530D+01,
27890 3 6.380D-01, 3.250D-01,-1.050D+00, 2.550D-01, 1.090D+01,-1.010D+01/
27891 DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/
27892 1 8.790D-01, 0.000D+00, 4.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
27893 2-9.710D-01,-1.160D+00, 1.230D+00,-5.640D+00,-7.540D+00,-5.960D-01,
27894 3 4.340D-01, 4.760D-01,-2.540D-01,-8.170D-01, 5.500D+00, 1.260D-01/
27895
27896C...Euler's beta function, requires ordinary Gamma function
27897 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
27898
27899C...Leading order proton parton distributions from Gluck, Reya and Vogt.
27900C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
27901C...10^-5 < x < 1.
27902 IF(MSTP(51).EQ.11) THEN
27903
27904C...Determine s expansion variable and some x expressions.
27905 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
27906 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
27907 SD2=SD**2
27908 XL=-LOG(X)
27909 XS=SQRT(X)
27910
27911C...Evaluate valence, gluon and sea distributions.
27912 XFVUD=(0.663D0+0.191D0*SD-0.041D0*SD2+0.031D0*SD**3)*
27913 & X**0.326D0*(1D0+(-1.97D0+6.74D0*SD-1.96D0*SD2)*XS+
27914 & (24.4D0-20.7D0*SD+4.08D0*SD2)*X)*
27915 & (1D0-X)**(2.86D0+0.70D0*SD-0.02D0*SD2)
27916 XFVDD=(0.579D0+0.283D0*SD+0.047D0*SD2)*X**(0.523D0-0.015D0*SD)*
27917 & (1D0+(2.22D0-0.59D0*SD-0.27D0*SD2)*XS+(5.95D0-6.19D0*SD+
27918 & 1.55D0*SD2)*X)*(1D0-X)**(3.57D0+0.94D0*SD-0.16D0*SD2)
27919 XFGLU=(X**(1.00D0-0.17D0*SD)*((4.879D0*SD-1.383D0*SD2)+
27920 & (25.92D0-28.97D0*SD+5.596D0*SD2)*X+(-25.69D0+23.68D0*SD-
27921 & 1.975D0*SD2)*X**2)+SD**0.558D0*EXP(-(0.595D0+2.138D0*SD)+
27922 & SQRT(4.066D0*SD**1.218D0*XL)))*
27923 & (1D0-X)**(2.537D0+1.718D0*SD+0.353D0*SD2)
27924 XFSEA=(X**(0.412D0-0.171D0*SD)*(0.363D0-1.196D0*X+(1.029D0+
27925 & 1.785D0*SD-0.459D0*SD2)*X**2)*XL**(0.566D0-0.496D0*SD)+
27926 & SD**1.396D0*EXP(-(3.838D0+1.944D0*SD)+SQRT(2.845D0*SD**1.331D0*
27927 & XL)))*(1D0-X)**(4.696D0+2.109D0*SD)
27928 XFSTR=SD**0.803D0*(1D0+(-3.055D0+1.024D0*SD**0.67D0)*XS+
27929 & (27.4D0-20.0D0*SD**0.154D0)*X)*(1D0-X)**6.22D0*
27930 & EXP(-(4.33D0+1.408D0*SD)+SQRT((8.27D0-0.437D0*SD)*
27931 & SD**0.563D0*XL))/XL**(2.082D0-0.577D0*SD)
27932 IF(SD.LE.0.888D0) THEN
27933 XFCHM=0D0
27934 ELSE
27935 XFCHM=(SD-0.888D0)**1.01D0*(1.+(4.24D0-0.804D0*SD)*X)*
27936 & (1D0-X)**(3.46D0+1.076D0*SD)*EXP(-(4.61D0+1.49D0*SD)+
27937 & SQRT((2.555D0+1.961D0*SD)*SD**0.37D0*XL))
27938 ENDIF
27939 IF(SD.LE.1.351D0) THEN
27940 XFBOT=0D0
27941 ELSE
27942 XFBOT=(SD-1.351D0)*(1D0+1.848D0*X)*(1D0-X)**(2.929D0+
27943 & 1.396D0*SD)*EXP(-(4.71D0+1.514D0*SD)+
27944 & SQRT((4.02D0+1.239D0*SD)*SD**0.51D0*XL))
27945 ENDIF
27946
27947C...Put into output array.
27948 XPPR(0)=XFGLU
27949 XPPR(1)=XFVDD+XFSEA
27950 XPPR(2)=XFVUD-XFVDD+XFSEA
27951 XPPR(3)=XFSTR
27952 XPPR(4)=XFCHM
27953 XPPR(5)=XFBOT
27954 XPPR(-1)=XFSEA
27955 XPPR(-2)=XFSEA
27956 XPPR(-3)=XFSTR
27957 XPPR(-4)=XFCHM
27958 XPPR(-5)=XFBOT
27959
27960C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg.
27961C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1
27962 ELSEIF(MSTP(51).EQ.12.OR.MSTP(51).EQ.13) THEN
27963
27964C...Determine set, Lambda and x and t expansion variables.
27965 NSET=MSTP(51)-11
27966 IF(NSET.EQ.1) ALAM=0.2D0
27967 IF(NSET.EQ.2) ALAM=0.29D0
27968 TMIN=LOG(5D0/ALAM**2)
27969 TMAX=LOG(1D8/ALAM**2)
27970 T=LOG(MAX(1D0,Q2/ALAM**2))
27971 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
27972 NX=1
27973 IF(X.LE.0.1D0) NX=2
27974 IF(NX.EQ.1) VX=(2D0*X-1.1D0)/0.9D0
27975 IF(NX.EQ.2) VX=MAX(-1D0,(2D0*LOG(X)+11.51293D0)/6.90776D0)
27976
27977C...Chebyshev polynomials for x and t expansion.
27978 TX(1)=1D0
27979 TX(2)=VX
27980 TX(3)=2D0*VX**2-1D0
27981 TX(4)=4D0*VX**3-3D0*VX
27982 TX(5)=8D0*VX**4-8D0*VX**2+1D0
27983 TX(6)=16D0*VX**5-20D0*VX**3+5D0*VX
27984 TT(1)=1D0
27985 TT(2)=VT
27986 TT(3)=2D0*VT**2-1D0
27987 TT(4)=4D0*VT**3-3D0*VT
27988 TT(5)=8D0*VT**4-8D0*VT**2+1D0
27989 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
27990
27991C...Calculate structure functions.
27992 DO 130 KFL=1,6
27993 XQSUM=0D0
27994 DO 120 IT=1,6
27995 DO 110 IX=1,6
27996 XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)
27997 110 CONTINUE
27998 120 CONTINUE
27999 XQ(KFL)=XQSUM*(1D0-X)**NEHLQ(KFL,NSET)
28000 130 CONTINUE
28001
28002C...Put into output array.
28003 XPPR(0)=XQ(4)
28004 XPPR(1)=XQ(2)+XQ(3)
28005 XPPR(2)=XQ(1)+XQ(3)
28006 XPPR(3)=XQ(5)
28007 XPPR(4)=XQ(6)
28008 XPPR(-1)=XQ(3)
28009 XPPR(-2)=XQ(3)
28010 XPPR(-3)=XQ(5)
28011 XPPR(-4)=XQ(6)
28012
28013C...Special expansion for bottom (threshold effects).
28014 IF(MSTP(58).GE.5) THEN
28015 IF(NSET.EQ.1) TMIN=8.1905D0
28016 IF(NSET.EQ.2) TMIN=7.4474D0
28017 IF(T.GT.TMIN) THEN
28018 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
28019 TT(1)=1D0
28020 TT(2)=VT
28021 TT(3)=2D0*VT**2-1D0
28022 TT(4)=4D0*VT**3-3D0*VT
28023 TT(5)=8D0*VT**4-8D0*VT**2+1D0
28024 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
28025 XQSUM=0D0
28026 DO 150 IT=1,6
28027 DO 140 IX=1,6
28028 XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)
28029 140 CONTINUE
28030 150 CONTINUE
28031 XPPR(5)=XQSUM*(1D0-X)**NEHLQ(7,NSET)
28032 XPPR(-5)=XPPR(5)
28033 ENDIF
28034 ENDIF
28035
28036C...Special expansion for top (threshold effects).
28037 IF(MSTP(58).GE.6) THEN
28038 IF(NSET.EQ.1) TMIN=11.5528D0
28039 IF(NSET.EQ.2) TMIN=10.8097D0
28040 TMIN=TMIN+2D0*LOG(PMAS(6,1)/30D0)
28041 TMAX=TMAX+2D0*LOG(PMAS(6,1)/30D0)
28042 IF(T.GT.TMIN) THEN
28043 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
28044 TT(1)=1D0
28045 TT(2)=VT
28046 TT(3)=2D0*VT**2-1D0
28047 TT(4)=4D0*VT**3-3D0*VT
28048 TT(5)=8D0*VT**4-8D0*VT**2+1D0
28049 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
28050 XQSUM=0D0
28051 DO 170 IT=1,6
28052 DO 160 IX=1,6
28053 XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)
28054 160 CONTINUE
28055 170 CONTINUE
28056 XPPR(6)=XQSUM*(1D0-X)**NEHLQ(8,NSET)
28057 XPPR(-6)=XPPR(6)
28058 ENDIF
28059 ENDIF
28060
28061C...Proton parton distributions from Duke, Owens.
28062C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2.
28063 ELSEIF(MSTP(51).EQ.14.OR.MSTP(51).EQ.15) THEN
28064
28065C...Determine set, Lambda and s expansion parameter.
28066 NSET=MSTP(51)-13
28067 IF(NSET.EQ.1) ALAM=0.2D0
28068 IF(NSET.EQ.2) ALAM=0.4D0
28069 Q2IN=MIN(1D6,MAX(4D0,Q2))
28070 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
28071
28072C...Calculate structure functions.
28073 DO 190 KFL=1,5
28074 DO 180 IS=1,6
28075 TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+
28076 & CDO(3,IS,KFL,NSET)*SD**2
28077 180 CONTINUE
28078 IF(KFL.LE.2) THEN
28079 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)*(1D0+TS(3)*X)/(EULBET(TS(1),
28080 & TS(2)+1D0)*(1D0+TS(3)*TS(1)/(TS(1)+TS(2)+1D0)))
28081 ELSE
28082 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
28083 & TS(5)*X**2+TS(6)*X**3)
28084 ENDIF
28085 190 CONTINUE
28086
28087C...Put into output arrays.
28088 XPPR(0)=XQ(5)
28089 XPPR(1)=XQ(2)+XQ(3)/6D0
28090 XPPR(2)=3D0*XQ(1)-XQ(2)+XQ(3)/6D0
28091 XPPR(3)=XQ(3)/6D0
28092 XPPR(4)=XQ(4)
28093 XPPR(-1)=XQ(3)/6D0
28094 XPPR(-2)=XQ(3)/6D0
28095 XPPR(-3)=XQ(3)/6D0
28096 XPPR(-4)=XQ(4)
28097
28098 ENDIF
28099
28100 RETURN
28101 END
28102
28103C*********************************************************************
28104
28105C...PYHFTH
28106C...Gives threshold attractive/repulsive factor for heavy flavour
28107C...production.
28108
28109 FUNCTION PYHFTH(SH,SQM,FRATT)
28110
28111C...Double precision and integer declarations.
28112 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28113 IMPLICIT INTEGER(I-N)
28114 INTEGER PYK,PYCHGE,PYCOMP
28115C...Commonblocks.
28116 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28117 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28118 COMMON/PYINT1/MINT(400),VINT(400)
28119 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
28120
28121C...Value for alpha_strong.
28122 IF(MSTP(35).LE.1) THEN
28123 ALSSG=PARP(35)
28124 ELSE
28125 MST115=MSTU(115)
28126 MSTU(115)=MSTP(36)
28127 Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+
28128 & PARP(36)**2)))
28129 ALSSG=PYALPS(Q2BN)
28130 MSTU(115)=MST115
28131 ENDIF
28132
28133C...Evaluate attractive and repulsive factors.
28134 XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
28135 FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
28136 XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
28137 FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
28138 PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU
28139 VINT(138)=PYHFTH
28140
28141 RETURN
28142 END
28143
28144C*********************************************************************
28145
28146C...PYSPLI
28147C...Splits a hadron remnant into two (partons or hadron + parton)
28148C...in case it is more complicated than just a quark or a diquark.
28149
28150 SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
28151
28152C...Double precision and integer declarations.
28153 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28154 IMPLICIT INTEGER(I-N)
28155 INTEGER PYK,PYCHGE,PYCOMP
28156C...Commonblocks. PYDAT1 temporary
28157 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28158 COMMON/PYINT1/MINT(400),VINT(400)
28159 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28160 SAVE /PYPARS/,/PYINT1/,/PYDAT1/
28161C...Local array.
28162 DIMENSION KFL(3)
28163
28164C...Preliminaries. Parton composition.
28165 KFA=IABS(KF)
28166 KFS=ISIGN(1,KF)
28167 KFL(1)=MOD(KFA/1000,10)
28168 KFL(2)=MOD(KFA/100,10)
28169 KFL(3)=MOD(KFA/10,10)
28170 IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
28171 KFL(2)=INT(1.5D0+PYR(0))
28172 IF(MINT(105).EQ.333) KFL(2)=3
28173 IF(MINT(105).EQ.443) KFL(2)=4
28174 KFL(3)=KFL(2)
28175 ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN
28176 KFL(2)=2
28177 KFL(3)=2
28178 ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN
28179 KFL(2)=1
28180 KFL(3)=1
28181 ENDIF
28182 IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN
28183 KFLR=KFLIN*KFS
28184 ELSE
28185 KFLR=KFLIN
28186 ENDIF
28187 KFLCH=0
28188
28189C...Subdivide lepton.
28190 IF(KFA.GE.11.AND.KFA.LE.18) THEN
28191 IF(KFLR.EQ.KFA) THEN
28192 KFLSP=KFS*22
28193 ELSEIF(KFLR.EQ.22) THEN
28194 KFLSP=KFA
28195 ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN
28196 KFLSP=KFA+1
28197 ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN
28198 KFLSP=KFA-1
28199 ELSEIF(KFLR.EQ.21) THEN
28200 KFLSP=KFA
28201 KFLCH=KFS*21
28202 ELSE
28203 KFLSP=KFA
28204 KFLCH=-KFLR
28205 ENDIF
28206
28207C...Subdivide photon.
28208 ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN
28209 IF(KFLR.NE.21) THEN
28210 KFLSP=-KFLR
28211 ELSE
28212 RAGR=0.75D0*PYR(0)
28213 KFLSP=1
28214 IF(RAGR.GT.0.125D0) KFLSP=2
28215 IF(RAGR.GT.0.625D0) KFLSP=3
28216 IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP
28217 KFLCH=-KFLSP
28218 ENDIF
28219
28220C...Subdivide Reggeon or Pomeron.
28221 ELSEIF(KFA.EQ.28.OR.KFA.EQ.29) THEN
28222 IF(KFLIN.EQ.21) THEN
28223 KFLSP=KFS*21
28224 ELSE
28225 KFLSP=-KFLIN
28226 ENDIF
28227
28228C...Subdivide meson.
28229 ELSEIF(KFL(1).EQ.0) THEN
28230 KFL(2)=KFL(2)*(-1)**KFL(2)
28231 KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
28232 IF(KFLR.EQ.KFL(2)) THEN
28233 KFLSP=KFL(3)
28234 ELSEIF(KFLR.EQ.KFL(3)) THEN
28235 KFLSP=KFL(2)
28236 ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN
28237 KFLSP=KFL(2)
28238 KFLCH=KFL(3)
28239 ELSEIF(KFLR.EQ.21) THEN
28240 KFLSP=KFL(3)
28241 KFLCH=KFL(2)
28242 ELSEIF(KFLR*KFL(2).GT.0) THEN
28243 NTRY=0
28244 100 NTRY=NTRY+1
28245 CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
28246 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
28247 GOTO 100
28248 ELSEIF(KFLCH.EQ.0) THEN
28249 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
28250 MINT(51)=1
28251 RETURN
28252 ENDIF
28253 KFLSP=KFL(3)
28254 ELSE
28255 NTRY=0
28256 110 NTRY=NTRY+1
28257 CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
28258 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
28259 GOTO 110
28260 ELSEIF(KFLCH.EQ.0) THEN
28261 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
28262 MINT(51)=1
28263 RETURN
28264 ENDIF
28265 KFLSP=KFL(2)
28266 ENDIF
28267
28268C...Subdivide baryon.
28269 ELSE
28270 NAGR=0
28271 DO 120 J=1,3
28272 IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
28273 120 CONTINUE
28274 IF(NAGR.GE.1) THEN
28275 RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0)
28276 IAGR=0
28277 DO 130 J=1,3
28278 IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0
28279 IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J
28280 130 CONTINUE
28281 ELSE
28282 IAGR=1.00001D0+2.99998D0*PYR(0)
28283 ENDIF
28284 ID1=1
28285 IF(IAGR.EQ.1) ID1=2
28286 IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
28287 ID2=6-IAGR-ID1
28288 KSP=3
28289 IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
28290 IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1
28291 ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
28292 IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1
28293 ELSEIF(MOD(KFA,10).EQ.2) THEN
28294 IF(IAGR.EQ.1) KSP=1
28295 IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1
28296 ENDIF
28297 KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
28298 IF(KFLR.EQ.21) THEN
28299 KFLCH=KFL(IAGR)
28300 ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
28301 NTRY=0
28302 140 NTRY=NTRY+1
28303 CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
28304 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
28305 GOTO 140
28306 ELSEIF(KFLCH.EQ.0) THEN
28307 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
28308 MINT(51)=1
28309 RETURN
28310 ENDIF
28311 ELSEIF(NAGR.EQ.0) THEN
28312 NTRY=0
28313 150 NTRY=NTRY+1
28314 CALL PYKFDI(10000*KFL(ID1)+KFLSP,-KFLR,KFDUMP,KFLCH)
28315 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
28316 GOTO 150
28317 ELSEIF(KFLCH.EQ.0) THEN
28318 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
28319 MINT(51)=1
28320 RETURN
28321 ENDIF
28322 KFLSP=KFL(IAGR)
28323 ENDIF
28324 ENDIF
28325
28326C...Add on correct sign for result.
28327 KFLCH=KFLCH*KFS
28328 KFLSP=KFLSP*KFS
28329
28330 RETURN
28331 END
28332
28333C*********************************************************************
28334
28335C...PYGAMM
28336C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
28337C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
28338C...(Dover, 1965) 6.1.36.
28339
28340 FUNCTION PYGAMM(X)
28341
28342C...Double precision and integer declarations.
28343 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28344 IMPLICIT INTEGER(I-N)
28345 INTEGER PYK,PYCHGE,PYCOMP
28346C...Local array and data.
28347 DIMENSION B(8)
28348 DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
28349 &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/
28350
28351 NX=INT(X)
28352 DX=X-NX
28353
28354 PYGAMM=1D0
28355 DXP=1D0
28356 DO 100 I=1,8
28357 DXP=DXP*DX
28358 PYGAMM=PYGAMM+B(I)*DXP
28359 100 CONTINUE
28360 IF(X.LT.1D0) THEN
28361 PYGAMM=PYGAMM/X
28362 ELSE
28363 DO 110 IX=1,NX-1
28364 PYGAMM=(X-IX)*PYGAMM
28365 110 CONTINUE
28366 ENDIF
28367
28368 RETURN
28369 END
28370
28371C***********************************************************************
28372
28373C...PYWAUX
28374C...Calculates real and imaginary parts of the auxiliary functions W1
28375C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
28376C...der Bij, Nucl. Phys. B297 (1988) 221.
28377
28378 SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)
28379
28380C...Double precision and integer declarations.
28381 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28382 IMPLICIT INTEGER(I-N)
28383 INTEGER PYK,PYCHGE,PYCOMP
28384C...Commonblocks.
28385 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28386 SAVE /PYDAT1/
28387
28388 ASINH(X)=LOG(X+SQRT(X**2+1D0))
28389 ACOSH(X)=LOG(X+SQRT(X**2-1D0))
28390
28391 IF(EPS.LT.0D0) THEN
28392 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
28393 IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
28394 WIM=0D0
28395 ELSEIF(EPS.LT.1D0) THEN
28396 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
28397 IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
28398 IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
28399 IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
28400 ELSE
28401 IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
28402 IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
28403 WIM=0D0
28404 ENDIF
28405
28406 RETURN
28407 END
28408
28409C***********************************************************************
28410
28411C...PYI3AU
28412C...Calculates real and imaginary parts of the auxiliary function I3;
28413C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
28414C...Nucl. Phys. B297 (1988) 221.
28415
28416 SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM)
28417
28418C...Double precision and integer declarations.
28419 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28420 IMPLICIT INTEGER(I-N)
28421 INTEGER PYK,PYCHGE,PYCOMP
28422C...Commonblocks.
28423 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28424 SAVE /PYDAT1/
28425
28426 BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS))
28427 IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS))
28428
28429 IF(EPS.LT.0D0) THEN
28430 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
28431 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
28432 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
28433 & PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)-
28434 & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-
28435 & LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)*
28436 & LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+
28437 & LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)*
28438 & EPS))
28439 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
28440 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
28441 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
28442 & PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)-
28443 & PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+
28444 & 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+
28445 & LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+
28446 & LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS))
28447 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
28448 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
28449 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
28450 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)-
28451 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+
28452 & 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+
28453 & LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+
28454 & LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS))
28455 ELSE
28456 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
28457 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)-
28458 & PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2-
28459 & LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+
28460 & LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0))
28461 ENDIF
28462 F3IM=0D0
28463 ELSEIF(EPS.LT.1D0) THEN
28464 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
28465 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
28466 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
28467 & PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)-
28468 & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
28469 & (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
28470 & (0.25D0*(RAT+1D0)*EPS))
28471 F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
28472 & (0.25D0*(RAT+1D0)*EPS))
28473 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
28474 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
28475 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
28476 & PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)-
28477 & PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+
28478 & LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))*
28479 & LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
28480 F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
28481 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
28482 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
28483 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
28484 & PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)-
28485 & PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+
28486 & LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/
28487 & (1D0+0.25D0*RAT*EPS-GA))
28488 F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/
28489 & (1D0+0.25D0*RAT*EPS-GA))
28490 ELSE
28491 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
28492 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)-
28493 & PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))*
28494 & LOG((GA+BE-1D0)/(BE-GA))
28495 F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA))
28496 ENDIF
28497 ELSE
28498 RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2)
28499 RCTHE=RSQ*(1D0-2D0*BE/EPS)
28500 RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2))
28501 RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS)
28502 RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2))
28503 R=SQRT(RSQ)
28504 THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R)))
28505 PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R)))
28506 F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
28507 & PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
28508 & (PHI-THE)*(PHI+THE-PARU(1))
28509 F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
28510 & PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
28511 ENDIF
28512
28513 Y3RE=2D0/(2D0*BE-1D0)*F3RE
28514 Y3IM=2D0/(2D0*BE-1D0)*F3IM
28515
28516 RETURN
28517 END
28518
28519C***********************************************************************
28520
28521C...PYSPEN
28522C...Calculates real and imaginary part of Spence function; see
28523C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
28524
28525 FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
28526
28527C...Double precision and integer declarations.
28528 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28529 IMPLICIT INTEGER(I-N)
28530 INTEGER PYK,PYCHGE,PYCOMP
28531C...Commonblocks.
28532 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28533 SAVE /PYDAT1/
28534C...Local array and data.
28535 DIMENSION B(0:14)
28536 DATA B/
28537 &1.000000D+00, -5.000000D-01, 1.666667D-01,
28538 &0.000000D+00, -3.333333D-02, 0.000000D+00,
28539 &2.380952D-02, 0.000000D+00, -3.333333D-02,
28540 &0.000000D+00, 7.575757D-02, 0.000000D+00,
28541 &-2.531135D-01, 0.000000D+00, 1.166667D+00/
28542
28543 XRE=XREIN
28544 XIM=XIMIN
28545 IF(ABS(1D0-XRE).LT.1D-6.AND.ABS(XIM).LT.1D-6) THEN
28546 IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
28547 IF(IREIM.EQ.2) PYSPEN=0D0
28548 RETURN
28549 ENDIF
28550
28551 XMOD=SQRT(XRE**2+XIM**2)
28552 IF(XMOD.LT.1D-6) THEN
28553 IF(IREIM.EQ.1) PYSPEN=0D0
28554 IF(IREIM.EQ.2) PYSPEN=0D0
28555 RETURN
28556 ENDIF
28557
28558 XARG=SIGN(ACOS(XRE/XMOD),XIM)
28559 SP0RE=0D0
28560 SP0IM=0D0
28561 SGN=1D0
28562 IF(XMOD.GT.1D0) THEN
28563 ALGXRE=LOG(XMOD)
28564 ALGXIM=XARG-SIGN(PARU(1),XARG)
28565 SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
28566 SP0IM=-ALGXRE*ALGXIM
28567 SGN=-1D0
28568 XMOD=1D0/XMOD
28569 XARG=-XARG
28570 XRE=XMOD*COS(XARG)
28571 XIM=XMOD*SIN(XARG)
28572 ENDIF
28573 IF(XRE.GT.0.5D0) THEN
28574 ALGXRE=LOG(XMOD)
28575 ALGXIM=XARG
28576 XRE=1D0-XRE
28577 XIM=-XIM
28578 XMOD=SQRT(XRE**2+XIM**2)
28579 XARG=SIGN(ACOS(XRE/XMOD),XIM)
28580 ALGYRE=LOG(XMOD)
28581 ALGYIM=XARG
28582 SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
28583 SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
28584 SGN=-SGN
28585 ENDIF
28586
28587 XRE=1D0-XRE
28588 XIM=-XIM
28589 XMOD=SQRT(XRE**2+XIM**2)
28590 XARG=SIGN(ACOS(XRE/XMOD),XIM)
28591 ZRE=-LOG(XMOD)
28592 ZIM=-XARG
28593
28594 SPRE=0D0
28595 SPIM=0D0
28596 SAVERE=1D0
28597 SAVEIM=0D0
28598 DO 100 I=0,14
28599 IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
28600 TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
28601 TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
28602 SAVERE=TERMRE
28603 SAVEIM=TERMIM
28604 SPRE=SPRE+B(I)*TERMRE
28605 SPIM=SPIM+B(I)*TERMIM
28606 100 CONTINUE
28607
28608 110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
28609 IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
28610
28611 RETURN
28612 END
28613
28614C***********************************************************************
28615
28616C...PYQQBH
28617C...Calculates the matrix element for the processes
28618C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
28619C...REDUCE output and part of the rest courtesy Z. Kunszt, see
28620C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
28621
28622 SUBROUTINE PYQQBH(WTQQBH)
28623
28624C...Double precision and integer declarations.
28625 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28626 IMPLICIT INTEGER(I-N)
28627 INTEGER PYK,PYCHGE,PYCOMP
28628C...Commonblocks.
28629 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28630 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28631 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28632 COMMON/PYINT1/MINT(400),VINT(400)
28633 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
28634 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/
28635C...Local arrays and function.
28636 DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8)
28637 DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)-
28638 &PP(I,3)*PP(J,3)
28639
28640C...Mass parameters.
28641 WTQQBH=0D0
28642 ISUB=MINT(1)
28643 SHPR=SQRT(VINT(26))*VINT(1)
28644 PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1)
28645 PH=SQRT(VINT(21))*VINT(1)
28646 SPQ=PQ**2
28647 SPH=PH**2
28648
28649C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
28650 DO 100 I=1,2
28651 PT=SQRT(MAX(0D0,VINT(197+5*I)))
28652 PP(I,1)=PT*COS(VINT(198+5*I))
28653 PP(I,2)=PT*SIN(VINT(198+5*I))
28654 100 CONTINUE
28655 PP(3,1)=-PP(1,1)-PP(2,1)
28656 PP(3,2)=-PP(1,2)-PP(2,2)
28657 PMS1=SPQ+PP(1,1)**2+PP(1,2)**2
28658 PMS2=SPQ+PP(2,1)**2+PP(2,2)**2
28659 PMS3=SPH+PP(3,1)**2+PP(3,2)**2
28660 PMT3=SQRT(PMS3)
28661 PP(3,3)=PMT3*SINH(VINT(211))
28662 PP(3,4)=PMT3*COSH(VINT(211))
28663 PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2
28664 PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
28665 &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12)
28666 PP(2,3)=-PP(1,3)-PP(3,3)
28667 PP(1,4)=SQRT(PMS1+PP(1,3)**2)
28668 PP(2,4)=SQRT(PMS2+PP(2,3)**2)
28669
28670C...Set up incoming kinematics and derived momentum combinations.
28671 DO 110 I=4,5
28672 PP(I,1)=0D0
28673 PP(I,2)=0D0
28674 PP(I,3)=-0.5D0*SHPR*(-1)**I
28675 PP(I,4)=-0.5D0*SHPR
28676 110 CONTINUE
28677 DO 120 J=1,4
28678 PP(6,J)=PP(1,J)+PP(2,J)
28679 PP(7,J)=PP(1,J)+PP(3,J)
28680 PP(8,J)=PP(1,J)+PP(4,J)
28681 PP(9,J)=PP(1,J)+PP(5,J)
28682 PP(10,J)=-PP(2,J)-PP(3,J)
28683 PP(11,J)=-PP(2,J)-PP(4,J)
28684 PP(12,J)=-PP(2,J)-PP(5,J)
28685 PP(13,J)=-PP(4,J)-PP(5,J)
28686 120 CONTINUE
28687
28688C...Derived kinematics invariants.
28689 X1=DOT(1,2)
28690 X2=DOT(1,3)
28691 X3=DOT(1,4)
28692 X4=DOT(1,5)
28693 X5=DOT(2,3)
28694 X6=DOT(2,4)
28695 X7=DOT(2,5)
28696 X8=DOT(3,4)
28697 X9=DOT(3,5)
28698 X10=DOT(4,5)
28699
28700C...Propagators.
28701 SS1=DOT(7,7)-SPQ
28702 SS2=DOT(8,8)-SPQ
28703 SS3=DOT(9,9)-SPQ
28704 SS4=DOT(10,10)-SPQ
28705 SS5=DOT(11,11)-SPQ
28706 SS6=DOT(12,12)-SPQ
28707 SS7=DOT(13,13)
28708 DX(1)=SS1*SS6
28709 DX(2)=SS2*SS6
28710 DX(3)=SS2*SS4
28711 DX(4)=SS1*SS5
28712 DX(5)=SS3*SS5
28713 DX(6)=SS3*SS4
28714 DX(7)=SS7*SS1
28715 DX(8)=SS7*SS4
28716
28717C...Define colour coefficients for g + g -> Q + Qbar + H.
28718 IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN
28719 DO 140 I=1,3
28720 DO 130 J=1,3
28721 CLR(I,J)=16D0/3D0
28722 CLR(I+3,J+3)=16D0/3D0
28723 CLR(I,J+3)=-2D0/3D0
28724 CLR(I+3,J)=-2D0/3D0
28725 130 CONTINUE
28726 140 CONTINUE
28727 DO 160 L=1,2
28728 DO 150 I=1,3
28729 CLR(I,6+L)=-6D0
28730 CLR(I+3,6+L)=6D0
28731 CLR(6+L,I)=-6D0
28732 CLR(6+L,I+3)=6D0
28733 150 CONTINUE
28734 160 CONTINUE
28735 DO 180 K1=1,2
28736 DO 170 K2=1,2
28737 CLR(6+K1,6+K2)=12D0
28738 170 CONTINUE
28739 180 CONTINUE
28740
28741C...Evaluate matrix elements for g + g -> Q + Qbar + H.
28742 FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2*
28743 & X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2*
28744 & X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7
28745 FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2
28746 & *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2*
28747 & X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+
28748 & X10)
28749 FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4*
28750 & X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10
28751 & +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
28752 & -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7
28753 & -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+
28754 & X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6)
28755 FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10-
28756 & X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6
28757 & )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+
28758 & 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2*
28759 & X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6)
28760 FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1*
28761 & X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1*
28762 & X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4
28763 & *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1**
28764 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4*
28765 & X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7
28766 & +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5-
28767 & X4*X6*X5)
28768 FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4-
28769 & X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3*
28770 & X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2
28771 & *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5
28772 & +X4*X9*X5+X4*X5**2)
28773 FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2*
28774 & PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1*
28775 & X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3*
28776 & X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7*
28777 & X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7-
28778 & X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5)
28779 FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2*
28780 & PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+
28781 & 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8*
28782 & X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6
28783 & +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8*
28784 & X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4*
28785 & X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2*
28786 & X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+
28787 & X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2)
28788 FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*(
28789 & X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7
28790 FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2
28791 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3*
28792 & X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+
28793 & X6)
28794 FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1*
28795 & X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1*
28796 & X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4
28797 & *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1
28798 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4
28799 & *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3*
28800 & X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6*
28801 & X5+X4*X6*X5)
28802 FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1
28803 & *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3-
28804 & 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4-
28805 & X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1*
28806 & X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3
28807 & *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4*
28808 & X6**2)
28809 FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1*
28810 & X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1*
28811 & X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4*
28812 & X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1**
28813 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4*
28814 & X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7
28815 & -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5-
28816 & X4*X6*X5)
28817 FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
28818 & 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
28819 & X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3*
28820 & X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2
28821 & *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5
28822 & +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
28823 & -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1*
28824 & X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1*
28825 & X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3*
28826 & X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3
28827 & *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5)
28828 FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
28829 & 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
28830 & X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2*
28831 & X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4
28832 & *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5-
28833 & X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
28834 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9-
28835 & X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9
28836 & *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10*
28837 & X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3*
28838 & X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5)
28839 FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6
28840 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3*
28841 & X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5
28842 FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3-
28843 & X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3*
28844 & X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2
28845 & *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5
28846 & +X3*X8*X5+X3*X5**2)
28847 FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1*
28848 & X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1*
28849 & X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3
28850 & *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1
28851 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3
28852 & *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3*
28853 & X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7*
28854 & X5+X4*X6*X5)
28855 FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+
28856 & X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6
28857 & )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2*
28858 & X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2*
28859 & X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10)
28860 FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2*
28861 & PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4*
28862 & X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+
28863 & X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4*
28864 & X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+
28865 & X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3*
28866 & X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2
28867 & *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7
28868 & +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5)
28869 FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2*
28870 & PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+
28871 & 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7
28872 & +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9*
28873 & X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4
28874 & *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8)
28875 FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2*
28876 & X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2*
28877 & X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6
28878 FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4
28879 & *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+
28880 & X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+
28881 & X10)
28882 FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2*
28883 & X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10
28884 & +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
28885 & -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7
28886 & -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+
28887 & X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7)
28888 FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2
28889 & *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1*
28890 & X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3*
28891 & X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7*
28892 & X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2*
28893 & X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5)
28894 FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2
28895 & *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9
28896 & +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4
28897 & *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4*
28898 & X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2
28899 & *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3
28900 & *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2
28901 & *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9*
28902 & X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2)
28903 FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*(
28904 & X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6
28905 FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2
28906 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4*
28907 & X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+
28908 & X7)
28909 FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
28910 & 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
28911 & X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+
28912 & 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+
28913 & 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+
28914 & 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(-
28915 & X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3
28916 & *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10*
28917 & X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2*
28918 & X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4
28919 & *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5)
28920 FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
28921 & 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
28922 & X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+
28923 & 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2*
28924 & X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+
28925 & 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(
28926 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3*
28927 & X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9
28928 & *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10*
28929 & X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+
28930 & X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5)
28931 FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7
28932 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4*
28933 & X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5
28934 FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2
28935 & *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4
28936 & -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9
28937 & -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+
28938 & 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9
28939 & *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4
28940 & *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2
28941 & **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+
28942 & 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5)
28943 FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2
28944 & *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*
28945 & X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12*
28946 & X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9
28947 & *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2*
28948 & X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8)
28949 FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9*
28950 & X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7*
28951 & X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2
28952 & *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8
28953 & *X6)
28954 FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+
28955 & 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4*
28956 & X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9*
28957 & X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3*
28958 & X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2
28959 & +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+
28960 & 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5)
28961 FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2
28962 & *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4
28963 & *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2*
28964 & X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4*
28965 & X8)
28966 FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
28967 & X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6
28968 & )+2*X2*(-X10*X5+X9*X6+X8*X7)
28969 FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
28970 & X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2
28971 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3*
28972 & X9*X5)
28973 FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
28974 & X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2
28975 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4*
28976 & X8*X5)
28977 FM(9,10)=0.5D0*(FMXX+FM(9,10))
28978 FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
28979 & X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6
28980 & )+2*X5*(-X10*X2+X9*X3+X8*X4)
28981
28982C...Repackage matrix elements.
28983 DO 200 I=1,8
28984 DO 190 J=1,8
28985 RM(I,J)=FM(I,J)
28986 190 CONTINUE
28987 200 CONTINUE
28988 RM(7,7)=FM(7,7)-2D0*FM(9,9)
28989 RM(7,8)=FM(7,8)-2D0*FM(9,10)
28990 RM(8,8)=FM(8,8)-2D0*FM(10,10)
28991
28992C...Produce final result: matrix elements * colours * propagators.
28993 DO 220 I=1,8
28994 DO 210 J=I,8
28995 FAC=8D0
28996 IF(I.EQ.J)FAC=4D0
28997 WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J))
28998 210 CONTINUE
28999 220 CONTINUE
29000 WTQQBH=-WTQQBH/256D0
29001
29002 ELSE
29003C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
29004 A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3
29005 & *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9
29006 & *X6+X8*X7)
29007 A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8-
29008 & 2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7
29009 & +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8*
29010 & X5)
29011 A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3*
29012 & X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3
29013 & *X9+X4*X8)
29014
29015C...Produce final result: matrix elements * propagators.
29016 A11=A11/DX(7)**2
29017 A12=A12/(DX(7)*DX(8))
29018 A22=A22/DX(8)**2
29019 WTQQBH=-(A11+A22+2D0*A12)/8D0
29020 ENDIF
29021
29022 RETURN
29023 END
29024
29025C*********************************************************************
29026
29027C...PYMSIN
29028C...Initializes supersymmetry: finds sparticle masses and
29029C...branching ratios and stores this information.
29030C...AUTHOR: STEPHEN MRENNA
29031
29032 SUBROUTINE PYMSIN
29033
29034C...Double precision and integer declarations.
29035 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29036 IMPLICIT INTEGER(I-N)
29037 INTEGER PYK,PYCHGE,PYCOMP
29038C...Parameter statement to help give large particle numbers.
29039 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
29040C...Commonblocks.
29041 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29042 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29043 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
29044 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29045 COMMON/PYINT4/MWID(500),WIDS(500,5)
29046 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
29047 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
29048 &SFMIX(16,4)
29049 COMMON/PYHTRI/HHH(7)
29050 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT4/,/PYMSSM/,
29051 &/PYSSMT/
29052
29053C...Local variables.
29054 INTEGER NSTR
29055 DOUBLE PRECISION ALFA,BETA
29056 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW,AEM,FACT
29057 DOUBLE PRECISION PYALEM
29058 INTEGER I,J,J1,J2,I1,I2,I3,IKNT,K1
29059 INTEGER KC,LKNT,IDLAM(200,3),IDLAM0(100,3),LKNT0
29060 DOUBLE PRECISION XLAM(0:200),XLAM0(0:200),XALL
29061 DOUBLE PRECISION WDTP(0:200),WDTE(0:200,0:5)
29062 1 DOUBLE PRECISION ATERM,TAN2T,THETA,DENOM
29063 DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
29064 DOUBLE PRECISION COSW,SINW,WDMIN,WDMAX
29065 DOUBLE PRECISION DELM,XMDIF,BRLIM
29066 DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
29067 DOUBLE PRECISION ARG,SGNMU,R,GAM
29068 INTEGER IS1,IS2,IS3,IS4,JS1,JS2,JS3,JS4,KS1,KS2,KS3,KS4
29069 INTEGER IMSSM,KFHIGG
29070 INTEGER IRPRTY
29071 INTEGER KFSUSY(36),MWIDSU(36),MDCYSU(36)
29072 SAVE INIT,MWIDSU,MDCYSU
29073 DATA KFSUSY/
29074 &1000001,2000001,1000002,2000002,1000003,2000003,
29075 &1000004,2000004,1000005,2000005,1000006,2000006,
29076 &1000011,2000011,1000012,2000012,1000013,2000013,
29077 &1000014,2000014,1000015,2000015,1000016,2000016,
29078 &1000021,1000022,1000023,1000025,1000035,1000024,
29079 &1000037,1000039, 25, 35, 36, 37/
29080 DATA INIT/0/
29081
29082C...Do nothing if SUSY not requested.
29083 IMSSM=IMSS(1)
29084 IF(IMSSM.EQ.0) RETURN
29085
29086C...Save copy of MWID(KC) and MDCY(KC,1) values before
29087C...they are set to zero for the LSP.
29088 IF(INIT.EQ.0) THEN
29089 INIT=1
29090 DO 105 I=1,36
29091 KF=KFSUSY(I)
29092 KC=PYCOMP(KF)
29093 MWIDSU(I)=MWID(KC)
29094 MDCYSU(I)=MDCY(KC,1)
29095 105 CONTINUE
29096 ENDIF
29097
29098C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP.
29099 DO 107 I=1,36
29100 KF=KFSUSY(I)
29101 KC=PYCOMP(KF)
29102 IF(MDCY(KC,1).EQ.0.AND.MDCYSU(I).NE.0) THEN
29103 MWID(KC)=MWIDSU(I)
29104 MDCY(KC,1)=MDCYSU(I)
29105 ENDIF
29106 107 CONTINUE
29107
29108C...First part of routine: set masses and couplings.
29109
29110C...Reset mixing values in sfermion sector to pure left/right.
29111 DO 100 I=1,16
29112 SFMIX(I,1)=1D0
29113 SFMIX(I,4)=1D0
29114 SFMIX(I,2)=0D0
29115 SFMIX(I,3)=0D0
29116 100 CONTINUE
29117
29118C...Common couplings.
29119 TANB=RMSS(5)
29120 BETA=ATAN(TANB)
29121 COSB=COS(BETA)
29122 SINB=TANB*COSB
29123 COS2B=COS(2D0*BETA)
29124 ALFA=RMSS(18)
29125 XMW2=PMAS(24,1)**2
29126 XMZ2=PMAS(23,1)**2
29127 XW=PARU(102)
29128
29129C...Define sparticle masses for a general MSSM simulation.
29130 IF(IMSSM.EQ.1) THEN
29131 IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9)
29132 DO 110 I=1,5,2
29133 KC=PYCOMP(KSUSY1+I)
29134 PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0)
29135 KC=PYCOMP(KSUSY2+I)
29136 PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0)
29137 KC=PYCOMP(KSUSY1+I+1)
29138 PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0)
29139 KC=PYCOMP(KSUSY2+I+1)
29140 PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0)
29141 110 CONTINUE
29142 XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA))
29143 IF(XARG.LT.0D0) THEN
29144 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
29145 & ' FROM THE SUM RULE. '
29146 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
29147 RETURN
29148 ELSE
29149 XARG=SQRT(XARG)
29150 ENDIF
29151 DO 120 I=11,15,2
29152 PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6)
29153 PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7)
29154 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
29155 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
29156 120 CONTINUE
29157 IF(IMSS(8).EQ.1) THEN
29158 RMSS(13)=RMSS(6)
29159 RMSS(14)=RMSS(7)
29160 ENDIF
29161
29162C...Alternatively derive masses from SUGRA relations.
29163 ELSEIF(IMSSM.EQ.2) THEN
29164 CALL PYAPPS
29165 ENDIF
29166
29167C...Add in extra D-term contributions.
29168 IF(IMSS(7).EQ.1) THEN
29169 R=0.43D0
29170 DX=RMSS(23)
29171 DY=RMSS(24)
29172 DS=RMSS(25)
29173 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
29174 WRITE(MSTU(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
29175 WRITE(MSTU(11),*) 'C IN A U(B-L) THEORY '
29176 WRITE(MSTU(11),*) 'C DX = ',DX
29177 WRITE(MSTU(11),*) 'C DY = ',DY
29178 WRITE(MSTU(11),*) 'C DS = ',DS
29179 WRITE(MSTU(11),*) 'C '
29180 DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS
29181 WRITE(MSTU(11),*) 'C DY AT THE WEAK SCALE = ',DY
29182 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
29183 DQ2=DY/6D0-DX/3D0-DS/3D0
29184 DU2=-2D0*DY/3D0-DX/3D0-DS/3D0
29185 DD2=DY/3D0+DX-2D0*DS/3D0
29186 DL2=-DY/2D0+DX-2D0*DS/3D0
29187 DE2=DY-DX/3D0-DS/3D0
29188 DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0
29189 DHD2=-DY/2D0-2D0*DX/3D0+DS
29190 DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS)
29191 & /ABS(COS2B)
29192 DMA2 = 2D0*DMU2+DHU2+DHD2
29193 DO 130 I=1,5,2
29194 KC=PYCOMP(KSUSY1+I)
29195 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
29196 KC=PYCOMP(KSUSY2+I)
29197 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2)
29198 KC=PYCOMP(KSUSY1+I+1)
29199 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
29200 KC=PYCOMP(KSUSY2+I+1)
29201 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2)
29202 130 CONTINUE
29203 DO 140 I=11,15,2
29204 KC=PYCOMP(KSUSY1+I)
29205 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
29206 KC=PYCOMP(KSUSY2+I)
29207 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2)
29208 KC=PYCOMP(KSUSY1+I+1)
29209 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
29210 140 CONTINUE
29211 IF(RMSS(4)**2+DMU2.LT.0D0) THEN
29212 WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE '
29213 STOP
29214 ENDIF
29215 SGNMU=SIGN(1D0,RMSS(4))
29216 RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2)
29217 ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2
29218 RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
29219 ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2
29220 RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
29221 ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2
29222 RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
29223 ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2
29224 RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
29225 ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2
29226 RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG)
29227 IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN
29228 WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW '
29229 STOP
29230 ENDIF
29231 RMSS(19)=SQRT(RMSS(19)**2+DMA2)
29232 RMSS(6)=SQRT(RMSS(6)**2+DL2)
29233 RMSS(7)=SQRT(RMSS(7)**2+DE2)
29234 WRITE(MSTU(11),*) ' MTL = ',RMSS(10)
29235 WRITE(MSTU(11),*) ' MBR = ',RMSS(11)
29236 WRITE(MSTU(11),*) ' MTR = ',RMSS(12)
29237 WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13)
29238 WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14)
29239 ENDIF
29240
29241C...Fix the third generation sfermions.
29242 CALL PYTHRG
29243 XARG=RMSS(13)**2-PMAS(24,1)**2*ABS(COS2B)
29244 IF(XARG.LT.0D0) THEN
29245 WRITE(MSTU(11),*) ' TAU SNEUTRINO MASS IS NEGATIVE FROM'//
29246 & ' THE SUM RULE. '
29247 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
29248 RETURN
29249 ELSE
29250 PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG)
29251 ENDIF
29252
29253C...Fix the neutralino--chargino--gluino sector.
29254 CALL PYINOM
29255
29256C...Fix the Higgs sector.
29257 CALL PYHGGM(ALFA)
29258
29259C...Choose the Gunion-Haber convention.
29260 ALFA=-ALFA
29261 RMSS(18)=ALFA
29262
29263C...Print information on mass parameters.
29264 IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN
29265 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
29266 WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
29267 WRITE(MSTU(11),*) ' M0 = ',RMSS(8)
29268 WRITE(MSTU(11),*) ' M1/2=',RMSS(1)
29269 WRITE(MSTU(11),*) ' TANB=',RMSS(5)
29270 WRITE(MSTU(11),*) ' MU = ',RMSS(4)
29271 WRITE(MSTU(11),*) ' AT = ',RMSS(16)
29272 WRITE(MSTU(11),*) ' MA = ',RMSS(19)
29273 WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1)
29274 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
29275 ENDIF
29276 IF(IMSS(20).EQ.1) THEN
29277 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
29278 WRITE(MSTU(11),*) ' DEBUG MODE '
29279 WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2),
29280 & UMIX(2,1),UMIX(2,2)
29281 WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2),
29282 & VMIX(2,1),VMIX(2,2)
29283 WRITE(MSTU(11),*) ' ZMIX = ',ZMIX
29284 WRITE(MSTU(11),*) ' ALFA = ',ALFA
29285 WRITE(MSTU(11),*) ' BETA = ',BETA
29286 WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4)
29287 WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4)
29288 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
29289 ENDIF
29290
29291C...Set up the Higgs couplings - needed here since initialization
29292C...in PYINRE did not yet occur when PYWIDT is called below.
29293 AL=ALFA
29294 BE=BETA
29295 SINA=SIN(AL)
29296 COSA=COS(AL)
29297 COSB=COS(BE)
29298 SINB=TANB*COSB
29299 SBMA=SIN(BE-AL)
29300 SAPB=SIN(AL+BE)
29301 CAPB=COS(AL+BE)
29302 CBMA=COS(BE-AL)
29303 S2A=SIN(2D0*AL)
29304 C2A=COS(2D0*AL)
29305 C2B=COSB**2-SINB**2
29306C...tanb (used for H+)
29307 PARU(141)=TANB
29308
29309C...Firstly: h
29310C...Coupling to d-type quarks
29311 PARU(161)=SINA/COSB
29312C...Coupling to u-type quarks
29313 PARU(162)=-COSA/SINB
29314C...Coupling to leptons
29315 PARU(163)=PARU(161)
29316C...Coupling to Z
29317 PARU(164)=SBMA
29318C...Coupling to W
29319 PARU(165)=PARU(164)
29320
29321C...Secondly: H
29322C...Coupling to d-type quarks
29323 PARU(171)=-COSA/COSB
29324C...Coupling to u-type quarks
29325 PARU(172)=-SINA/SINB
29326C...Coupling to leptons
29327 PARU(173)=PARU(171)
29328C...Coupling to Z
29329 PARU(174)=CBMA
29330C...Coupling to W
29331 PARU(175)=PARU(174)
29332C...Coupling to h
29333C PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
29334 HHH(3)=HHH(3)+HHH(4)+HHH(5)
29335 PARU(176)=-3D0/HHH(1)*(HHH(1)*SINA**2*COSB*COSA+
29336 1 HHH(2)*COSA**2*SINB*SINA+HHH(3)*(SINA**3*SINB+COSA**3*COSB-
29337 2 2D0/3D0*CBMA)-HHH(6)*SINA*(COSB*C2A+COSA*CAPB)+
29338 3 HHH(7)*COSA*(SINB*C2A+SINA*CAPB))
29339C...Coupling to H+
29340C...Define later
29341C PARU(168)=-SBMA-COS(2D0*BE)*SAPB/2D0/(1D0-XW)
29342 PARU(168)=1D0/HHH(1)*(HHH(1)*SINB**2*COSB*SINA-
29343 1 HHH(2)*COSB**2*SINB*COSA-HHH(3)*(SINB**3*COSA-COSB**3*SINA)+
29344 2 2D0*HHH(5)*SBMA-HHH(6)*SINB*(COSB*SAPB+SINA*C2B)-
29345 3 HHH(7)*COSB*(COSA*C2B-SINB*SAPB)-(HHH(5)-HHH(4))*SBMA)
29346C...Coupling to A
29347C PARU(177)=COS(2D0*BE)*COS(BE+AL)
29348 PARU(177)=-1D0/HHH(1)*(HHH(1)*SINB**2*COSB*COSA+
29349 1 HHH(2)*COSB**2*SINB*SINA+HHH(3)*(SINB**3*SINA+COSB**3*COSA)-
29350 2 2D0*HHH(5)*CBMA-HHH(6)*SINB*(COSB*CAPB+COSA*C2B)+
29351 3 HHH(7)*COSB*(SINB*CAPB+SINA*C2B))
29352C...Coupling to H+
29353 PARU(178)=PARU(177)-(HHH(5)-HHH(4))/HHH(1)*CBMA
29354C...Thirdly, A
29355C...Coupling to d-type quarks
29356 PARU(181)=TANB
29357C...Coupling to u-type quarks
29358 PARU(182)=1D0/PARU(181)
29359C...Coupling to leptons
29360 PARU(183)=PARU(181)
29361 PARU(184)=0D0
29362 PARU(185)=0D0
29363C...Coupling to Z h
29364 PARU(186)=COS(BE-AL)
29365C...Coupling to Z H
29366 PARU(187)=SIN(BE-AL)
29367 PARU(188)=0D0
29368 PARU(189)=0D0
29369 PARU(190)=0D0
29370
29371C...Finally: H+
29372C...Coupling to W h
29373 PARU(195)=COS(BE-AL)
29374
29375C...Tell that all Higgs couplings have been set.
29376 MSTP(4)=1
29377
29378C...Second part of routine: set decay modes and branching ratios.
29379
29380C...Allow chi10 -> gravitino + gamma or not.
29381 KC=PYCOMP(KSUSY1+39)
29382 IF( IMSS(11) .NE. 0 ) THEN
29383 PMAS(KC,1)=RMSS(21)/1000000000D0
29384 PMAS(KC,2)=0.0001D0
29385 IRPRTY=0
29386 WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
29387 ELSE
29388 PMAS(KC,1)=9999D0
29389 IRPRTY=1
29390 ENDIF
29391
29392C...Loop over sparticle and Higgs species.
29393 PMCHI1=PMAS(PYCOMP(KSUSY1+22),1)
29394C...Find the LSP or NLSP for a gravitino LSP
29395 ILSP=0
29396 PMLSP=1D20
29397 DO 150 I=1,36
29398 KF=KFSUSY(I)
29399 IF(KF.EQ.1000039) GOTO 150
29400 KC=PYCOMP(KF)
29401 IF(PMAS(KC,1).LT.PMLSP) THEN
29402 ILSP=I
29403 PMLSP=PMAS(KC,1)
29404 ENDIF
29405 150 CONTINUE
29406 DO 210 I=1,36
29407 KF=KFSUSY(I)
29408 KC=PYCOMP(KF)
29409 LKNT=0
29410
29411C...Sfermion decays.
29412 IF(I.LE.24) THEN
29413C...First check to see if sneutrino is lighter than chi10.
29414 IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND.
29415 & PMAS(KC,1).LT.PMCHI1) THEN
29416 ELSE
29417 CALL PYSFDC(KF,XLAM,IDLAM,LKNT)
29418 ENDIF
29419
29420C...Gluino decays.
29421 ELSEIF(I.EQ.25) THEN
29422 CALL PYGLUI(KF,XLAM,IDLAM,LKNT)
29423 IF(I.EQ.ILSP) LKNT=0
29424
29425C...Neutralino decays.
29426 ELSEIF(I.GE.26.AND.I.LE.29) THEN
29427 CALL PYNJDC(KF,XLAM,IDLAM,LKNT)
29428C...chi10 stable or chi10 -> gravitino + gamma.
29429 IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN
29430 PMAS(KC,2)=1D-6
29431 MDCY(KC,1)=0
29432 MWID(KC)=0
29433 ENDIF
29434
29435C...Chargino decays.
29436 ELSEIF(I.GE.30.AND.I.LE.31) THEN
29437 CALL PYCJDC(KF,XLAM,IDLAM,LKNT)
29438
29439C...Gravitino is stable.
29440 ELSEIF(I.EQ.32) THEN
29441 MDCY(KC,1)=0
29442 MWID(KC)=0
29443
29444C...Higgs decays.
29445 ELSEIF(I.GE.33.AND.I.LE.36) THEN
29446C...Calculate decays to non-SUSY particles.
29447 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
29448 LKNT=0
29449 DO 160 I1=0,100
29450 XLAM(I1)=0D0
29451 160 CONTINUE
29452 DO 180 I1=1,MDCY(KC,3)
29453 K1=MDCY(KC,2)+I1-1
29454 IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR.
29455 & IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 180
29456 XLAM(I1)=WDTP(I1)
29457 XLAM(0)=XLAM(0)+XLAM(I1)
29458 DO 170 J1=1,3
29459 IDLAM(I1,J1)=KFDP(K1,J1)
29460 170 CONTINUE
29461 LKNT=LKNT+1
29462 180 CONTINUE
29463C...Add the decays to SUSY particles.
29464 CALL PYHEXT(KF,XLAM,IDLAM,LKNT)
29465 ENDIF
29466C...Zero the branching ratios for use in loop mode
29467C...thanks to K. Matchev (FNAL)
29468 DO 185 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
29469 BRAT(IDC)=0D0
29470 185 CONTINUE
29471
29472C...Set stable particles.
29473 IF(LKNT.EQ.0) THEN
29474 MDCY(KC,1)=0
29475 MWID(KC)=0
29476 PMAS(KC,2)=1D-6
29477 PMAS(KC,3)=1D-5
29478 PMAS(KC,4)=0D0
29479
29480C...Store branching ratios in the standard tables.
29481 ELSE
29482 IDC=MDCY(KC,2)+MDCY(KC,3)-1
29483 DELM=1D6
29484 DO 200 IL=1,LKNT
29485 IDCSV=IDC
29486 190 IDC=IDC+1
29487 BRAT(IDC)=0D0
29488 IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2)
29489 IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ.
29490 & KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN
29491 BRAT(IDC)=XLAM(IL)/XLAM(0)
29492 XMDIF=PMAS(KC,1)
29493 IF(MDME(IDC,1).GE.1) THEN
29494 XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)-
29495 & PMAS(PYCOMP(KFDP(IDC,2)),1)
29496 IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF-
29497 & PMAS(PYCOMP(KFDP(IDC,3)),1)
29498 ENDIF
29499 IF(I.LE.32) THEN
29500 IF(XMDIF.GE.0D0) THEN
29501 DELM=MIN(DELM,XMDIF)
29502 ELSE
29503 WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF
29504 WRITE(MSTU(11),*) ' KF = ',KF
29505 WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3)
29506 ENDIF
29507 ENDIF
29508 GOTO 200
29509 ELSEIF(IDC.EQ.IDCSV) THEN
29510 WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ',
29511 & 'channel not recognized:'
29512 WRITE(MSTU(11),*) KF,' -> ',(IDLAM(I,J),J=1,3)
29513 GOTO 200
29514 ELSE
29515 GOTO 190
29516 ENDIF
29517 200 CONTINUE
29518
29519C...Store width, cutoff and lifetime.
29520 PMAS(KC,2)=XLAM(0)
29521 IF(PMAS(KC,2).LT.0.1D0*DELM) THEN
29522 PMAS(KC,3)=PMAS(KC,2)*10D0
29523 ELSE
29524 PMAS(KC,3)=0.95D0*DELM
29525 ENDIF
29526 IF(PMAS(KC,2).NE.0D0) THEN
29527 PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12
29528 ENDIF
29529 ENDIF
29530 210 CONTINUE
29531
29532 RETURN
29533 END
29534
29535C*********************************************************************
29536
29537C...PYAPPS
29538C...Uses approximate analytical formulae to determine the full set of
29539C...MSSM parameters from SUGRA input.
29540C...See M. Drees and S.P. Martin, hep-ph/9504124
29541
29542 SUBROUTINE PYAPPS
29543
29544C...Double precision and integer declarations.
29545 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29546 IMPLICIT INTEGER(I-N)
29547 INTEGER PYK,PYCHGE,PYCOMP
29548C...Parameter statement to help give large particle numbers.
29549 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
29550C...Commonblocks.
29551 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29552 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29553 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
29554 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/
29555
29556 IMSS(5)=0
29557 XMT=PMAS(6,1)
29558 XMZ2=PMAS(23,1)**2
29559 XMW2=PMAS(24,1)**2
29560 TANB=RMSS(5)
29561 BETA=ATAN(TANB)
29562 XW=PARU(102)
29563 XMG=RMSS(1)
29564 XMG2=XMG*XMG
29565 XM0=RMSS(8)
29566 XM02=XM0*XM0
29567 AT=-RMSS(16)
29568 RMSS(15)=AT
29569 RMSS(17)=AT
29570 COSB=COS(BETA)
29571 SINB=TANB/SQRT(TANB**2+1D0)
29572 COSB=SINB/TANB
29573
29574 DTERM=XMZ2*COS(2D0*BETA)
29575 XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM)
29576 XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM)
29577 RMSS(6)=XMEL
29578 RMSS(7)=XMER
29579 XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM))
29580 XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM))
29581 XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM))
29582 XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM))
29583 DO 100 I=1,5,2
29584 PMAS(PYCOMP(KSUSY1+I),1)=XMDL
29585 PMAS(PYCOMP(KSUSY2+I),1)=XMDR
29586 PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL
29587 PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR
29588 100 CONTINUE
29589 XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA))
29590 IF(XARG.LT.0D0) THEN
29591 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
29592 & ' FROM THE SUM RULE. '
29593 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
29594 RETURN
29595 ELSE
29596 XARG=SQRT(XARG)
29597 ENDIF
29598 DO 110 I=11,15,2
29599 PMAS(PYCOMP(KSUSY1+I),1)=XMEL
29600 PMAS(PYCOMP(KSUSY2+I),1)=XMER
29601 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
29602 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
29603 110 CONTINUE
29604 XMNU=XARG
29605
29606 RMT=PYRNMT(XMT)
29607 XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+
29608 &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG))
29609 RMB=3D0
29610 XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+
29611 &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG))
29612 XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0)
29613 ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/
29614 &SINB)**2)
29615 RMSS(16)=-ATP
29616C XMU2=-XM02-0.52D0*XMG2-0.5D0*XMZ2+XTOP/(1D0-1D0/TANB**2)
29617C.....
29618 XMU2=-.5D0*XMZ2+(SINB**2*(XM02+.52D0*XMG2-XTOP)-
29619 &COSB**2*(XM02+.52D0*XMG2-XBOT-XTAU/3D0))/(COSB**2-SINB**2)
29620C XMA2=(XMNU**2+XMU2-XBOT-XTAU/3D0)/SINB**2
29621C.....
29622 XMA2=2D0*(XM02+.52D0*XMG2)-XTOP-XBOT-XTAU/3D0+2D0*XMU2
29623 XMU=SIGN(SQRT(XMU2),RMSS(4))
29624 RMSS(4)=XMU
29625 RMSS(19)=SQRT(XMA2)
29626 ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM
29627 IF(ARG.GT.0D0) THEN
29628 RMSS(14)=SQRT(ARG)
29629 ELSE
29630 WRITE(MSTU(11),*) ' RIGHT STAU MASS < 0 '
29631 STOP
29632 ENDIF
29633 ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM
29634 IF(ARG.GT.0D0) THEN
29635 RMSS(13)=SQRT(ARG)
29636 ELSE
29637 WRITE(MSTU(11),*) ' LEFT STAU MASS < 0 '
29638 STOP
29639 ENDIF
29640 ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0)
29641 IF(ARG.GT.0D0) THEN
29642 RMSS(10)=SQRT(ARG)
29643 ELSE
29644 RMSS(10)=-SQRT(-ARG)
29645 ENDIF
29646 ARG=PYRNMQ(2,-2D0*XTOP/3D0)
29647 IF(ARG.GT.0D0) THEN
29648 RMSS(12)=SQRT(ARG)
29649 ELSE
29650 RMSS(12)=-SQRT(-ARG)
29651 ENDIF
29652 ARG=PYRNMQ(3,-2D0*XBOT/3D0)
29653 IF(ARG.GT.0D0) THEN
29654 RMSS(11)=SQRT(ARG)
29655 ELSE
29656 RMSS(11)=-SQRT(-ARG)
29657 ENDIF
29658
29659 RETURN
29660 END
29661
29662C*********************************************************************
29663
29664C...PYRNMQ
29665C...Determines the running mass of quarks.
29666
29667 FUNCTION PYRNMQ(ID,DTERM)
29668
29669C...Double precision and integer declarations.
29670 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29671 IMPLICIT INTEGER(I-N)
29672 INTEGER PYK,PYCHGE,PYCOMP
29673C...Commonblock.
29674 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
29675 SAVE /PYMSSM/
29676
29677C...Local variables.
29678 DOUBLE PRECISION PI,R
29679 DOUBLE PRECISION TOL
29680 DOUBLE PRECISION CI(3)
29681 EXTERNAL PYALPS
29682 DOUBLE PRECISION PYALPS
29683 DATA TOL/0.001D0/
29684 DATA PI,R/3.141592654D0,.61803399D0/
29685 DATA CI/0.47D0,0.07D0,0.02D0/
29686
29687 C=1D0-R
29688 CA=CI(ID)
29689 AG=(0.71D0)**2/4D0/PI
29690 AG=RMSS(20)
29691 XM0=RMSS(8)
29692 XMG=RMSS(1)
29693 XM02=XM0*XM0
29694 XMG2=XMG*XMG
29695
29696 AS=PYALPS(XM02+6D0*XMG2)
29697 CG=8D0/9D0*((AS/AG)**2-1D0)
29698 BX=XM02+(CA+CG)*XMG2+DTERM
29699 AX=MIN(50D0**2,0.5D0*BX)
29700 CX=MAX(2000D0**2,2D0*BX)
29701
29702 X0=AX
29703 X3=CX
29704 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
29705 X1=BX
29706 X2=BX+C*(CX-BX)
29707 ELSE
29708 X2=BX
29709 X1=BX-C*(BX-AX)
29710 ENDIF
29711 AS1=PYALPS(X1)
29712 CG=8D0/9D0*((AS1/AG)**2-1D0)
29713 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
29714 AS2=PYALPS(X2)
29715 CG=8D0/9D0*((AS2/AG)**2-1D0)
29716 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
29717 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
29718 IF(F2.LT.F1) THEN
29719 X0=X1
29720 X1=X2
29721 X2=R*X1+C*X3
29722 F1=F2
29723 AS2=PYALPS(X2)
29724 CG=8D0/9D0*((AS2/AG)**2-1D0)
29725 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
29726 ELSE
29727 X3=X2
29728 X2=X1
29729 X1=R*X2+C*X0
29730 F2=F1
29731 AS1=PYALPS(X1)
29732 CG=8D0/9D0*((AS1/AG)**2-1D0)
29733 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
29734 ENDIF
29735 GOTO 100
29736 ENDIF
29737 IF(F1.LT.F2) THEN
29738 PYRNMQ=X1
29739 XMIN=X1
29740 ELSE
29741 PYRNMQ=X2
29742 XMIN=X2
29743 ENDIF
29744
29745 RETURN
29746 END
29747
29748C*********************************************************************
29749
29750C...PYRNMT
29751C...Determines the running mass of the top quark.
29752
29753 FUNCTION PYRNMT(XMT)
29754
29755C...Double precision and integer declarations.
29756 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29757 IMPLICIT INTEGER(I-N)
29758 INTEGER PYK,PYCHGE,PYCOMP
29759C...Commonblock.
29760 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
29761 SAVE /PYMSSM/
29762
29763C...Local variables.
29764 DOUBLE PRECISION XMT
29765 DOUBLE PRECISION PI,R
29766 DOUBLE PRECISION TOL
29767 EXTERNAL PYALPS
29768 DOUBLE PRECISION PYALPS
29769 DATA TOL/0.001D0/
29770 DATA PI,R/3.141592654D0,0.61803399D0/
29771
29772 C=1D0-R
29773
29774 BX=XMT
29775 AX=MIN(50D0,BX*0.5D0)
29776 CX=MAX(300D0,2D0*BX)
29777
29778 X0=AX
29779 X3=CX
29780 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
29781 X1=BX
29782 X2=BX+C*(CX-BX)
29783 ELSE
29784 X2=BX
29785 X1=BX-C*(BX-AX)
29786 ENDIF
29787 AS1=PYALPS(X1**2)/PI
29788 F1=ABS(XMT/(1D0+4D0/3D0*AS1+11D0*AS1**2)-X1)
29789 AS2=PYALPS(X2**2)/PI
29790 F2=ABS(XMT/(1D0+4D0/3D0*AS2+11D0*AS2**2)-X2)
29791 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
29792 IF(F2.LT.F1) THEN
29793 X0=X1
29794 X1=X2
29795 X2=R*X1+C*X3
29796 F1=F2
29797 AS2=PYALPS(X2**2)/PI
29798 F2=ABS(XMT/(1D0+4D0/3D0*AS2+11D0*AS2**2)-X2)
29799 ELSE
29800 X3=X2
29801 X2=X1
29802 X1=R*X2+C*X0
29803 F2=F1
29804 AS1=PYALPS(X1**2)/PI
29805 F1=ABS(XMT/(1D0+4D0/3D0*AS1+11D0*AS1**2)-X1)
29806 ENDIF
29807 GOTO 100
29808 ENDIF
29809 IF(F1.LT.F2) THEN
29810 PYRNMT=X1
29811 XMIN=X1
29812 ELSE
29813 PYRNMT=X2
29814 XMIN=X2
29815 ENDIF
29816
29817 RETURN
29818 END
29819
29820C*********************************************************************
29821
29822C...PYTHRG
29823C...Calculates the mass eigenstates of the third generation sfermions.
29824C...Created: 5-31-96
29825
29826 SUBROUTINE PYTHRG
29827
29828C...Double precision and integer declarations.
29829 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29830 IMPLICIT INTEGER(I-N)
29831 INTEGER PYK,PYCHGE,PYCOMP
29832C...Parameter statement to help give large particle numbers.
29833 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
29834C...Commonblocks.
29835 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29836 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29837 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
29838 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
29839 &SFMIX(16,4)
29840 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
29841
29842C...Local variables.
29843 DOUBLE PRECISION BETA
29844 DOUBLE PRECISION PYRNMT
29845 DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
29846 DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
29847 DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
29848 DOUBLE PRECISION SIN2T,COS2T,TWOT,ATR,AMQR,XXX,YYY,AMQL
29849 INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
29850 INTEGER IF,I,J,II,JJ,IT,L
29851 LOGICAL DTERM
29852 DATA SMALL/1D-3/
29853 DATA ID1/10,10,13/
29854 DATA ID2/5,6,15/
29855 DATA ID3/15,16,17/
29856 DATA ID4/11,12,14/
29857 DATA DTERM/.TRUE./
29858
29859 XMZ2=PMAS(23,1)**2
29860 XMW2=PMAS(24,1)**2
29861 TANB=RMSS(5)
29862 XMU=-RMSS(4)
29863 BETA=ATAN(TANB)
29864 COS2B=COS(2D0*BETA)
29865
29866C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
29867
29868 IOPT=IMSS(5)
29869 IF(IOPT.EQ.1) THEN
29870 CTT=RMSS(27)
29871 CTT2=CTT**2
29872 STT2=1D0-CTT2
29873 STT=SQRT(STT2)
29874 XM12=RMSS(12)**2
29875 XM22=RMSS(10)**2
29876 XMQL2=CTT2*XM12+STT2*XM22
29877 XMQR2=STT2*XM12+CTT2*XM22
29878 XMFR=PMAS(6,1)
29879 XMF2=PYRNMT(XMFR)**2
29880 ATOP=-XMU/TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
29881 ATMT=SQRT(XMF2)*(ATOP+XMU/TANB)
29882 XTEST=(XMQL2-XMQR2)*(CTT2-STT2)
29883 IF(XTEST.GT.4D0*STT*CTT*ATMT) THEN
29884 STT=-STT
29885 ATOP=-XMU/TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
29886 ENDIF
29887 RMSS(16)=ATOP
29888C......SUBTRACT OUT D-TERM AND FERMION MASS
29889 XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0
29890 XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0
29891 IF(XMQL2.GE.0D0) THEN
29892 RMSS(10)=SQRT(XMQL2)
29893 ELSE
29894 RMSS(10)=-SQRT(-XMQL2)
29895 ENDIF
29896 IF(XMQR2.GE.0D0) THEN
29897 RMSS(12)=SQRT(XMQR2)
29898 ELSE
29899 RMSS(12)=-SQRT(-XMQR2)
29900 ENDIF
29901C SAME FOR BOTTOM SQUARK
29902 CTT=RMSS(26)
29903 CTT2=CTT**2
29904 STT2=1D0-CTT2
29905 STT=MAX(SQRT(STT2),1D-6)
29906 XMF=3D00
29907 XMF2=XMF**2
29908 XM12=RMSS(11)**2
29909 XMQL2=RMSS(10)**2-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2
29910 IF(ABS(CTT).EQ.1D0) THEN
29911 XM22=XM12
29912 XM12=XMQL2
29913 XMQR2=XM22
29914 ELSEIF(CTT.EQ.0D0) THEN
29915 XM22=XMQL2
29916 XMQR2=XM12
29917 ELSE
29918 XM22=(XMQL2-CTT2*XM12)/STT2
29919 XMQR2=STT2*XM12+CTT2*XM22
29920 ENDIF
29921 ABOT=-XMU*TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
29922 ATMT=SQRT(XMF2)*(ABOT+XMU*TANB)
29923 XTEST=(XMQL2-XMQR2)*(CTT2-STT2)
29924 IF(XTEST.GT.4D0*STT*CTT*ATMT) THEN
29925 STT=-STT
29926 ABOT=-XMU*TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
29927 ENDIF
29928 RMSS(15)=ABOT
29929C......SUBTRACT OUT D-TERM AND FERMION MASS
29930 XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2
29931 IF(XMQR2.GE.0D0) THEN
29932 RMSS(11)=SQRT(XMQR2)
29933 ELSE
29934 RMSS(11)=-SQRT(-XMQR2)
29935 ENDIF
29936C SAME FOR TAU SLEPTON
29937 CTT=RMSS(28)
29938 CTT2=CTT**2
29939 STT2=1D0-CTT2
29940 STT=SQRT(STT2)
29941 XM12=RMSS(14)**2
29942 XM22=RMSS(13)**2
29943 XMQL2=CTT2*XM12+STT2*XM22
29944 XMQR2=STT2*XM12+CTT2*XM22
29945 XMFR=PMAS(15,1)
29946 XMF2=XMFR**2
29947 ATAU=-XMU*TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
29948 ATMT=SQRT(XMF2)*(ATAU+XMU*TANB)
29949 XTEST=(XMQL2-XMQR2)*(CTT2-STT2)
29950 IF(XTEST.GT.4D0*STT*CTT*ATMT) THEN
29951 STT=-STT
29952 ATAU=-XMU*TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
29953 ENDIF
29954 RMSS(17)=ATAU
29955C......SUBTRACT OUT D-TERM AND FERMION MASS
29956 XMQL2=XMQL2-XMF2+(-.5D0*XMZ2+XMW2)*COS2B
29957 XMQR2=XMQR2-XMF2+(XMZ2-XMW2)*COS2B
29958 IF(XMQL2.GE.0D0) THEN
29959 RMSS(13)=SQRT(XMQL2)
29960 ELSE
29961 RMSS(13)=-SQRT(-XMQL2)
29962 ENDIF
29963 IF(XMQR2.GE.0D0) THEN
29964 RMSS(14)=SQRT(XMQR2)
29965 ELSE
29966 RMSS(14)=-SQRT(-XMQR2)
29967 ENDIF
29968 ENDIF
29969 DO 170 L=1,3
29970 AMQL=RMSS(ID1(L))
29971 IF(AMQL.LT.0D0) THEN
29972 XMQL2=-AMQL**2
29973 ELSE
29974 XMQL2=AMQL**2
29975 ENDIF
29976 IF=ID2(L)
29977 XMF=PMAS(IF,1)
29978 IF(L.EQ.1) XMF=3D0
29979 IF(L.EQ.2) XMF=PYRNMT(XMF)
29980 XMF2=XMF**2
29981 ATR=RMSS(ID3(L))
29982 AMQR=RMSS(ID4(L))
29983 IF(AMQR.LT.0D0) THEN
29984 XMQR2=-AMQR**2
29985 ELSE
29986 XMQR2=AMQR**2
29987 ENDIF
29988 AM2(1,1)=XMQL2+XMF2
29989 AM2(2,2)=XMQR2+XMF2
29990 IF(DTERM) THEN
29991 IF(L.EQ.1) THEN
29992 AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0
29993 AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
29994 AM2(1,2)=XMF*(ATR+XMU*TANB)
29995 ELSEIF(L.EQ.2) THEN
29996 AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0
29997 AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0
29998 AM2(1,2)=XMF*(ATR+XMU/TANB)
29999 ELSEIF(L.EQ.3) THEN
30000 IF(IMSS(8).EQ.1) THEN
30001 AM2(1,1)=RMSS(6)**2
30002 AM2(2,2)=RMSS(7)**2
30003 AM2(1,2)=0D0
30004 RMSS(13)=RMSS(6)
30005 RMSS(14)=RMSS(7)
30006 ELSE
30007 AM2(1,2)=XMF*(ATR+XMU*TANB)
30008 ENDIF
30009 ENDIF
30010 ENDIF
30011 AM2(2,1)=AM2(1,2)
30012 DETM=AM2(1,1)*AM2(2,2)-AM2(2,1)**2
30013 IF(DETM.LT.0D0) THEN
30014 WRITE(MSTU(11),*) ID1(L),DETM
30015 CALL PYERRM(30,' NEGATIVE**2 MASS FOR SFERMION ')
30016 ENDIF
30017 SAME=0.5D0*(AM2(1,1)+AM2(2,2))
30018 DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1))
30019 XMF12=SAME-DIFF
30020 XMF22=SAME+DIFF
30021 IT=0
30022 IF(XMF22-XMF12.GT.0D0) THEN
30023 RT(1,1) = SQRT(MAX(0D0,(XMF22-AM2(1,1))/(XMF22-XMF12)))
30024 RT(2,2) = RT(1,1)
30025 RT(1,2) = -SIGN(SQRT(MAX(0D0,1D0-RT(1,1)**2)),
30026 & AM2(1,2)/(XMF22-XMF12))
30027 RT(2,1) = -RT(1,2)
30028 ELSE
30029 RT(1,1) = 1D0
30030 RT(2,2) = RT(1,1)
30031 RT(1,2) = 0D0
30032 RT(2,1) = -RT(1,2)
30033 ENDIF
30034 100 CONTINUE
30035 IT=IT+1
30036
30037 DO 140 I=1,2
30038 DO 130 JJ=1,2
30039 DI(I,JJ)=0D0
30040 DO 120 II=1,2
30041 DO 110 J=1,2
30042 DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II)
30043 110 CONTINUE
30044 120 CONTINUE
30045 130 CONTINUE
30046 140 CONTINUE
30047
30048 IF(DI(1,1).GT.DI(2,2)) THEN
30049 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION '
30050 WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22)
30051 WRITE(MSTU(11),*) AM2
30052 WRITE(MSTU(11),*) DI
30053 WRITE(MSTU(11),*) RT
30054 DI(1,1)=-RT(2,1)
30055 DI(2,2)=RT(1,2)
30056 DI(1,2)=-RT(2,2)
30057 DI(2,1)=RT(1,1)
30058 DO 160 I=1,2
30059 DO 150 J=1,2
30060 RT(I,J)=DI(I,J)
30061 150 CONTINUE
30062 160 CONTINUE
30063 GOTO 100
30064 ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN
30065 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
30066 & ' OFF DIAGONAL ELEMENTS '
30067 WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22)
30068 WRITE(MSTU(11),*) DI
30069 WRITE(MSTU(11),*) ' ROTATION = ',RT
30070C...STOP
30071 ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN
30072 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
30073 & ' NEGATIVE MASSES '
30074 STOP
30075 ENDIF
30076 PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12)
30077 PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22)
30078 SFMIX(IF,1)=RT(1,1)
30079 SFMIX(IF,2)=RT(1,2)
30080 SFMIX(IF,3)=RT(2,1)
30081 SFMIX(IF,4)=RT(2,2)
30082 170 CONTINUE
30083
30084 RETURN
30085 END
30086
30087C*********************************************************************
30088
30089C...PYINOM
30090C...Finds the mass eigenstates and mixing matrices for neutralinos
30091C...and charginos.
30092
30093 SUBROUTINE PYINOM
30094
30095C...Double precision and integer declarations.
30096 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30097 IMPLICIT INTEGER(I-N)
30098 INTEGER PYK,PYCHGE,PYCOMP
30099C...Parameter statement to help give large particle numbers.
30100 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
30101C...Commonblocks.
30102 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30103 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30104 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
30105 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
30106 &SFMIX(16,4)
30107 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
30108
30109C...Local variables.
30110 DOUBLE PRECISION XMW,XMZ
30111 DOUBLE PRECISION AR(4,4),WR(4),ZR(4,4)
30112 DOUBLE PRECISION ZP(4,4)
30113 DOUBLE PRECISION DETX,XI(2,2)
30114 DOUBLE PRECISION XXX,YYY,XMH,XML
30115 DOUBLE PRECISION COSW,SINW
30116 DOUBLE PRECISION XMU
30117 DOUBLE PRECISION TERMB,TERMC,DISCR,XMH2,XML2
30118 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
30119 DOUBLE PRECISION XM1,XM2,XM3,BETA
30120 DOUBLE PRECISION Q2,AEM,A1,A2,A3,AQ,RM1,RM2
30121 DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
30122 DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
30123 DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
30124 DOUBLE PRECISION PYALPS,PYALEM
30125 DOUBLE PRECISION PYRNM3
30126 INTEGER IERR,INDEX(4),I,J,K,L,IOPT,ILR,KFNCHI(4)
30127 DATA KFNCHI/1000022,1000023,1000025,1000035/
30128
30129 IOPT=IMSS(2)
30130 IF(IMSS(1).EQ.2) THEN
30131 IOPT=1
30132 ENDIF
30133C...M1, M2, AND M3 ARE INDEPENDENT
30134 IF(IOPT.EQ.0) THEN
30135 XM1=RMSS(1)
30136 XM2=RMSS(2)
30137 XM3=RMSS(3)
30138 ELSEIF(IOPT.GE.1) THEN
30139 Q2=PMAS(23,1)**2
30140 AEM=PYALEM(Q2)
30141 A2=AEM/PARU(102)
30142 A1=AEM/(1D0-PARU(102))
30143 XM1=RMSS(1)
30144 XM2=RMSS(2)
30145 IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0
30146 IF(IOPT.EQ.1) THEN
30147 XM2=XM1*A2/A1*3D0/5D0
30148 RMSS(2)=XM2
30149 ELSEIF(IOPT.EQ.3) THEN
30150 XM1=XM2*5D0/3D0*A1/A2
30151 RMSS(1)=XM1
30152 ENDIF
30153 XM3=PYRNM3(XM2/A2)
30154 RMSS(3)=XM3
30155 IF(XM3.LE.0D0) THEN
30156 WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3
30157 STOP
30158 ENDIF
30159 ENDIF
30160
30161C...GLUINO MASS
30162 IF(IMSS(3).EQ.1) THEN
30163 PMAS(PYCOMP(KSUSY1+21),1)=XM3
30164 ELSE
30165 AQ=0D0
30166 DO 110 I=1,4
30167 DO 100 ILR=1,2
30168 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
30169 AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0)
30170 & +(1D0-RM1)**2*LOG(ABS(1D0-RM1)))
30171 100 CONTINUE
30172 110 CONTINUE
30173
30174 DO 130 I=5,6
30175 DO 120 ILR=1,2
30176 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
30177 RM2=PMAS(I,1)**2/XM3**2
30178 ARG=(RM1-RM2-1D0)**2-4D0*RM2**2
30179 IF(ARG.GE.0D0) THEN
30180 X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG))
30181 AX0=ABS(X0)
30182 X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG))
30183 AX1=ABS(X1)
30184 IF(X0.EQ.1D0) THEN
30185 AT=-1D0
30186 BT=0.25D0
30187 ELSEIF(X0.EQ.0D0) THEN
30188 AT=0D0
30189 BT=-0.25D0
30190 ELSE
30191 AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+
30192 & 0.5D0*X0**2*LOG(AX0)
30193 BT=(-1D0-2D0*X0)/4D0
30194 ENDIF
30195 IF(X1.EQ.1D0) THEN
30196 AT=-1D0+AT
30197 BT=0.25D0+BT
30198 ELSEIF(X1.EQ.0D0) THEN
30199 AT=0D0+AT
30200 BT=-0.25D0+BT
30201 ELSE
30202 AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0*
30203 & X1**2*LOG(AX1)+AT
30204 BT=(-1D0-2D0*X1)/4D0+BT
30205 ENDIF
30206 AQ=AQ+AT+BT
30207 ELSE
30208 X0=0.5D0*(1D0+RM2-RM1)
30209 Y0=-0.5D0*SQRT(-ARG)
30210 AMGX0=SQRT(X0**2+Y0**2)
30211 AM1X0=SQRT((1D0-X0)**2+Y0**2)
30212 ARGX0=ATAN2(-X0,-Y0)
30213 AR1X0=ATAN2(1D0-X0,Y0)
30214 X1=X0
30215 Y1=-Y0
30216 AMGX1=AMGX0
30217 AM1X1=AM1X0
30218 ARGX1=ATAN2(-X1,-Y1)
30219 AR1X1=ATAN2(1D0-X1,Y1)
30220 AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2)
30221 & +0.5D0*(X0**2-Y0**2)*LOG(AMGX0)
30222 BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 )
30223 AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2)
30224 & +0.5D0*(X1**2-Y1**2)*LOG(AMGX1)
30225 BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 )
30226 AQ=AQ+AT+BT
30227 ENDIF
30228 120 CONTINUE
30229 130 CONTINUE
30230 PMAS(PYCOMP(KSUSY1+21),1)=XM3*(1D0+PYALPS(XM3**2)/(2D0*PARU(2))*
30231 & (15D0+AQ))
30232 ENDIF
30233
30234C...NEUTRALINO MASSES
30235 XMZ=PMAS(23,1)
30236 XMW=PMAS(24,1)
30237 XMU=RMSS(4)
30238 SINW=SQRT(PARU(102))
30239 COSW=SQRT(1D0-PARU(102))
30240 TANB=RMSS(5)
30241 BETA=ATAN(TANB)
30242 COSB=COS(BETA)
30243 SINB=TANB*COSB
30244 AR(1,1) = XM1
30245 AR(2,2) = XM2
30246 AR(3,3) = 0D0
30247 AR(4,4) = 0D0
30248 AR(1,2) = 0D0
30249 AR(2,1) = 0D0
30250 AR(1,3) = -XMZ*SINW*COSB
30251 AR(3,1) = AR(1,3)
30252 AR(1,4) = XMZ*SINW*SINB
30253 AR(4,1) = AR(1,4)
30254 AR(2,3) = XMZ*COSW*COSB
30255 AR(3,2) = AR(2,3)
30256 AR(2,4) = -XMZ*COSW*SINB
30257 AR(4,2) = AR(2,4)
30258 AR(3,4) = -XMU
30259 AR(4,3) = -XMU
30260 CALL PYEIG4(AR,WR,ZR)
30261 DO 150 I=1,4
30262 SMZ(I)=WR(I)
30263 PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I))
30264 DO 140 J=1,4
30265 ZMIX(I,J)=ZR(I,J)
30266 IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0
30267 140 CONTINUE
30268 150 CONTINUE
30269
30270C...CHARGINO MASSES
30271 AR(1,1) = XM2
30272 AR(2,2) = XMU
30273 AR(1,2) = SQRT(2D0)*XMW*SINB
30274 AR(2,1) = SQRT(2D0)*XMW*COSB
30275 TERMB=AR(1,1)**2+AR(2,2)**2+AR(1,2)**2+AR(2,1)**2
30276 TERMC=(AR(1,1)**2-AR(2,2)**2)**2+(AR(1,2)**2-AR(2,1)**2)**2
30277 TERMC=TERMC+2D0*(AR(1,1)**2+AR(2,2)**2)*
30278 &(AR(1,2)**2+AR(2,1)**2)+
30279 &8D0*AR(1,1)*AR(2,2)*AR(1,2)*AR(2,1)
30280 DISCR=TERMC
30281 IF(DISCR.LT.0D0) THEN
30282 WRITE(MSTU(11),*) ' PROBLEM WITH DISCR '
30283 ELSE
30284 DISCR=SQRT(DISCR)
30285 ENDIF
30286 XML2=0.5D0*(TERMB-DISCR)
30287 XMH2=0.5D0*(TERMB+DISCR)
30288 XML=SQRT(XML2)
30289 XMH=SQRT(XMH2)
30290 PMAS(PYCOMP(KSUSY1+24),1)=XML
30291 PMAS(PYCOMP(KSUSY1+37),1)=XMH
30292 SMW(1)=XML
30293 SMW(2)=XMH
30294 XXX=AR(1,1)**2+AR(2,1)**2
30295 YYY=AR(1,1)*AR(1,2)+AR(2,2)*AR(2,1)
30296 VMIX(2,2) = YYY/SQRT(YYY**2+(XML2-XXX)**2)
30297 VMIX(1,1) = SIGN(VMIX(2,2),AR(1,1)*AR(2,2)-0.5D0*AR(1,2)**2)
30298 VMIX(2,1) = -(XML2-XXX)/SQRT(YYY**2+(XML2-XXX)**2)
30299 VMIX(1,2) = -SIGN(VMIX(2,1),AR(1,1)*AR(2,2)-0.5D0*AR(1,2)**2)
30300 ZR(1,1) = XML
30301 ZR(1,2) = 0D0
30302 ZR(2,1) = 0D0
30303 ZR(2,2) = XMH
30304 DETX = AR(1,1)*AR(2,2)-AR(1,2)*AR(2,1)
30305 XI(1,1) = AR(2,2)/DETX
30306 XI(2,2) = AR(1,1)/DETX
30307 XI(1,2) = -AR(1,2)/DETX
30308 XI(2,1) = -AR(2,1)/DETX
30309 DO 190 I=1,2
30310 DO 180 J=1,2
30311 UMIX(I,J)=0D0
30312 DO 170 K=1,2
30313 DO 160 L=1,2
30314 UMIX(I,J)=UMIX(I,J)+ZR(I,K)*VMIX(K,L)*XI(L,J)
30315 160 CONTINUE
30316 170 CONTINUE
30317 180 CONTINUE
30318 190 CONTINUE
30319
30320 RETURN
30321 END
30322
30323
30324
30325C*********************************************************************
30326
30327C...PYRNM3
30328C...Calculates the running of M3, the SU(3) gluino mass parameter.
30329
30330 FUNCTION PYRNM3(RGUT)
30331
30332C...Double precision and integer declarations.
30333 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30334 IMPLICIT INTEGER(I-N)
30335 INTEGER PYK,PYCHGE,PYCOMP
30336
30337C...Local variables.
30338 DOUBLE PRECISION PI,R
30339 DOUBLE PRECISION TOL
30340 EXTERNAL PYALPS
30341 DOUBLE PRECISION PYALPS
30342 DATA TOL/0.001D0/
30343 DATA PI,R/3.141592654D0,0.61803399D0/
30344
30345 C=1D0-R
30346
30347 BX=RGUT*PYALPS(RGUT**2)
30348 AX=MIN(50D0,BX*0.5D0)
30349 CX=MAX(2000D0,2D0*BX)
30350
30351 X0=AX
30352 X3=CX
30353 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
30354 X1=BX
30355 X2=BX+C*(CX-BX)
30356 ELSE
30357 X2=BX
30358 X1=BX-C*(BX-AX)
30359 ENDIF
30360 AS1=PYALPS(X1**2)
30361 F1=ABS(X1-RGUT*AS1)
30362 AS2=PYALPS(X2**2)
30363 F2=ABS(X2-RGUT*AS2)
30364 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
30365 IF(F2.LT.F1) THEN
30366 X0=X1
30367 X1=X2
30368 X2=R*X1+C*X3
30369 F1=F2
30370 AS2=PYALPS(X2**2)
30371 F2=ABS(X2-RGUT*AS2)
30372 ELSE
30373 X3=X2
30374 X2=X1
30375 X1=R*X2+C*X0
30376 F2=F1
30377 AS1=PYALPS(X1**2)
30378 F1=ABS(X1-RGUT*AS1)
30379 ENDIF
30380 GOTO 100
30381 ENDIF
30382 IF(F1.LT.F2) THEN
30383 PYRNM3=X1
30384 XMIN=X1
30385 ELSE
30386 PYRNM3=X2
30387 XMIN=X2
30388 ENDIF
30389
30390 RETURN
30391 END
30392
30393C*********************************************************************
30394
30395C...PYEIG4
30396C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
30397C...Specific application: mixing in neutralino sector.
30398
30399 SUBROUTINE PYEIG4(A,W,Z)
30400
30401C...Double precision and integer declarations.
30402 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30403 IMPLICIT INTEGER(I-N)
30404 INTEGER PYK,PYCHGE,PYCOMP
30405
30406C...Arrays: in call and local.
30407 DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)
30408
30409C...Coefficients of fourth-degree equation from matrix.
30410C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
30411 B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
30412 B2=0D0
30413 DO 110 I=1,3
30414 DO 100 J=I+1,4
30415 B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
30416 100 CONTINUE
30417 110 CONTINUE
30418 B1=0D0
30419 B0=0D0
30420 DO 120 I=1,4
30421 I1=MOD(I,4)+1
30422 I2=MOD(I+1,4)+1
30423 I3=MOD(I+2,4)+1
30424 B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
30425 & A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
30426 & A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
30427 B0=B0+(-1D0)**(I+1)*A(1,I)*(
30428 & A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
30429 & A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
30430 & A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
30431 120 CONTINUE
30432
30433C...Coefficients of third-degree equation needed for
30434C...separation into two second-degree equations.
30435C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
30436 C2=-B2
30437 C1=B1*B3-4D0*B0
30438 C0=-B1**2-B0*B3**2+4D0*B0*B2
30439 CQ=C1/3D0-C2**2/9D0
30440 CR=C1*C2/6D0-C0/2D0-C2**3/27D0
30441 CQR=CQ**3+CR**2
30442
30443C...Cases with one or three real roots.
30444 IF(CQR.GE.0D0) THEN
30445 S1=(CR+SQRT(CQR))**(1D0/3D0)
30446 S2=(CR-SQRT(CQR))**(1D0/3D0)
30447 U=S1+S2-C2/3D0
30448 ELSE
30449 SABS=SQRT(-CQ)
30450 THE=ACOS(CR/SABS**3)/3D0
30451 SRE=SABS*COS(THE)
30452 U=2D0*SRE-C2/3D0
30453 ENDIF
30454
30455C...Find and solve two second-degree equations.
30456 P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
30457 P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
30458 Q1=U/2D0+SQRT(U**2/4D0-B0)
30459 Q2=U/2D0-SQRT(U**2/4D0-B0)
30460 IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
30461 QSAV=Q1
30462 Q1=Q2
30463 Q2=QSAV
30464 ENDIF
30465 X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
30466 X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
30467 X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
30468 X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)
30469
30470C...Order eigenvalues in asceding mass.
30471 W(1)=X(1)
30472 DO 150 I1=2,4
30473 DO 130 I2=I1-1,1,-1
30474 IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
30475 W(I2+1)=W(I2)
30476 130 CONTINUE
30477 140 W(I2+1)=X(I1)
30478 150 CONTINUE
30479
30480C...Find equation system for eigenvectors.
30481 DO 250 I=1,4
30482 DO 170 J1=1,4
30483 D(J1,J1)=A(J1,J1)-W(I)
30484 DO 160 J2=J1+1,4
30485 D(J1,J2)=A(J1,J2)
30486 D(J2,J1)=A(J2,J1)
30487 160 CONTINUE
30488 170 CONTINUE
30489
30490C...Find largest element in matrix.
30491 DAMAX=0D0
30492 DO 190 J1=1,4
30493 DO 180 J2=1,4
30494 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
30495 JA=J1
30496 JB=J2
30497 DAMAX=ABS(D(J1,J2))
30498 180 CONTINUE
30499 190 CONTINUE
30500
30501C...Subtract others by multiple of row selected above.
30502 DAMAX=0D0
30503 DO 210 J3=JA+1,JA+3
30504 J1=J3-4*((J3-1)/4)
30505 RL=D(J1,JB)/D(JA,JB)
30506 DO 200 J2=1,4
30507 D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
30508 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
30509 JC=J1
30510 JD=J2
30511 DAMAX=ABS(D(J1,J2))
30512 200 CONTINUE
30513 210 CONTINUE
30514
30515C...Do one more subtraction of a row.
30516 DAMAX=0D0
30517 DO 230 J3=JC+1,JC+3
30518 J1=J3-4*((J3-1)/4)
30519 IF(J1.EQ.JA) GOTO 230
30520 RL=D(J1,JD)/D(JC,JD)
30521 DO 220 J2=1,4
30522 IF(J2.EQ.JB) GOTO 220
30523 D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
30524 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
30525 JE=J1
30526 DAMAX=ABS(D(J1,J2))
30527 220 CONTINUE
30528 230 CONTINUE
30529
30530C...Construct unnormalized eigenvector.
30531 JF1=JD+1-4*(JD/4)
30532 JF2=JD+2-4*((JD+1)/4)
30533 IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
30534 IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
30535 E(JF1)=-D(JE,JF2)
30536 E(JF2)=D(JE,JF1)
30537 E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
30538 E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
30539 & D(JA,JB)
30540
30541C...Normalize and fill in final array.
30542 EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
30543 SGN=(-1D0)**INT(PYR(0)+0.5D0)
30544 DO 240 J=1,4
30545 Z(I,J)=SGN*E(J)/EA
30546 240 CONTINUE
30547 250 CONTINUE
30548
30549 RETURN
30550 END
30551
30552C*********************************************************************
30553
30554C...PYHGGM
30555C...Determines the Higgs boson mass spectrum using several inputs.
30556
30557 SUBROUTINE PYHGGM(ALPHA)
30558
30559C...Double precision and integer declarations.
30560 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30561 IMPLICIT INTEGER(I-N)
30562 INTEGER PYK,PYCHGE,PYCOMP
30563C...Parameter statement to help give large particle numbers.
30564 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
30565C...Commonblocks.
30566 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30567 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30568 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30569 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
30570 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/
30571
30572C...Local variables.
30573 DOUBLE PRECISION AT,AB,XMU,TANB,XM32,XMT2
30574 DOUBLE PRECISION ALPHA
30575 INTEGER I,J,IHOPT,II,JJ,IT
30576 DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
30577 DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
30578 DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
30579 DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
30580
30581 IHOPT=IMSS(4)
30582 IF(IHOPT.EQ.2) THEN
30583 ALPHA=RMSS(18)
30584 RETURN
30585 ENDIF
30586 AT=RMSS(16)
30587 AB=RMSS(15)
30588 XMU=RMSS(4)
30589 TANB=RMSS(5)
30590
30591 DMA=RMSS(19)
30592 DTANB=TANB
30593 DMQ=RMSS(10)
30594 DMUR=RMSS(12)
30595 DMDR=RMSS(11)
30596 DMTOP=PMAS(6,1)
30597 DMC=PMAS(PYCOMP(KSUSY1+37),1)
30598 DAU=AT
30599 DAD=AB
30600 DMU=XMU
30601
30602 IF(IHOPT.EQ.0) THEN
30603 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
30604 & DMHCH,DSA,DCA,DTANBA)
30605 ELSEIF(IHOPT.EQ.1) THEN
30606 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
30607 & DMHCH,DSA,DCA,DTANBA)
30608 CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU,
30609 & DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA,
30610 & DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA)
30611 DMH=DMHP
30612 DHM=DHMP
30613 DMA=DAMP
30614 IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.5D-1) THEN
30615 WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
30616 WRITE(MSTU(11),*) ' STOP1 MASSES = ',
30617 & PMAS(PYCOMP(1000006),1),DSTOP2
30618 ENDIF
30619 IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.5D-1) THEN
30620 WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
30621 WRITE(MSTU(11),*) ' STOP2 MASSES = ',
30622 & PMAS(PYCOMP(2000006),1),DSTOP1
30623 ENDIF
30624 IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.5D-1) THEN
30625 WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
30626 WRITE(MSTU(11),*) ' SBOT1 MASSES = ',
30627 & PMAS(PYCOMP(1000005),1),DSBOT2
30628 ENDIF
30629 IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.5D-1) THEN
30630 WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
30631 WRITE(MSTU(11),*) ' SBOT2 MASSES = ',
30632 & PMAS(PYCOMP(2000005),1),DSBOT1
30633 ENDIF
30634
30635 ENDIF
30636
30637 ALPHA=ACOS(DCA)
30638
30639 PMAS(25,1)=DMH
30640 PMAS(35,1)=DHM
30641 PMAS(36,1)=DMA
30642 PMAS(37,1)=DMHCH
30643
30644 RETURN
30645 END
30646
30647C*********************************************************************
30648
30649C...PYSUBH
30650C...This routine computes the renormalization group improved
30651C...values of Higgs masses and couplings in the MSSM.
30652
30653C...Program based on the work by M. Carena, J.R. Espinosa,
30654c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
30655
30656C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
30657C...All masses in GeV units. MA is the CP-odd Higgs mass,
30658C...MTOP is the physical top mass, MQ and MUR are the soft
30659C...supersymmetry breaking mass parameters of left handed
30660C...and right handed stops respectively, AU and AD are the
30661C...stop and sbottom trilinear soft breaking terms,
30662C...respectively, and MU is the supersymmetric
30663C...Higgs mass parameter. We use the conventions from
30664C...the physics report of Haber and Kane: left right
30665C...stop mixing term proportional to (AU - MU/TANB)
30666C...We use as input TANB defined at the scale MTOP
30667
30668C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
30669C...where MH and HM are the lightest and heaviest CP-even
30670C...Higgs masses, MHCH is the charged Higgs mass and
30671C...ALPHA is the Higgs mixing angle
30672C...TANBA is the angle TANB at the CP-odd Higgs mass scale
30673
30674C...Range of validity:
30675C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
30676C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
30677C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
30678C...are the sbottom mass eigenvalues, respectively. This
30679C...range automatically excludes the existence of tachyons.
30680C...For the charged Higgs mass computation, the method is
30681C...valid if
30682C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
30683C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
30684C...where M_SUSY**2 is the average of the squared stop mass
30685C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
30686C...masses have been assumed to be of order of the stop ones
30687C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
30688
30689 SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
30690 &XMHCH,SA,CA,TANBA)
30691
30692C...Double precision and integer declarations.
30693 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30694 IMPLICIT INTEGER(I-N)
30695 INTEGER PYK,PYCHGE,PYCOMP
30696C...Parameter statement to help give large particle numbers.
30697 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
30698C...Commonblocks.
30699 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30700 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30701 COMMON/PYHTRI/HHH(7)
30702 SAVE /PYDAT1/,/PYDAT2/
30703
30704C...Local variables.
30705 DOUBLE PRECISION PYALEM,PYALPS
30706 DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
30707 DOUBLE PRECISION XMHCH,SA,CA
30708 DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
30709 DOUBLE PRECISION Q02
30710 DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
30711 DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
30712 DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
30713 DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
30714 DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
30715 DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
30716 DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
30717 DOUBLE PRECISION COS2BT,AU2,XMU2,XMZ,XMS3
30718
30719 XMZ = PMAS(23,1)
30720 Q02=XMZ**2
30721 AEM=PYALEM(Q02)
30722 ALP1=AEM/(1D0-PARU(102))
30723 ALP2=AEM/PARU(102)
30724 ALPH3Z=PYALPS(Q02)
30725
30726 ALP1 = 0.0101D0
30727 ALP2 = 0.0337D0
30728 ALPH3Z = 0.12D0
30729
30730 V = 174.1D0
30731 PI = PARU(1)
30732 TANBA = TANB
30733 TANBT = TANB
30734
30735C...MBOTTOM(MTOP) = 3. GEV
30736 XMB = 3D0
30737 ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z*
30738 &LOG(XMTOP**2/XMZ**2))
30739
30740C...RMTOP= RUNNING TOP QUARK MASS
30741 RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
30742 XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0
30743 T = LOG(XMS**2/XMTOP**2)
30744 SINB = TANB/((1D0 + TANB**2)**0.5D0)
30745 COSB = SINB/TANB
30746C...IF(MA.LE.XMTOP) TANBA = TANBT
30747 IF(XMA.GT.XMTOP)
30748 &TANBA = TANBT*(1D0-3D0/32D0/PI**2*
30749 &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
30750 &LOG(XMA**2/XMTOP**2))
30751
30752 SINBT = TANBT/SQRT(1D0 + TANBT**2)
30753 COSBT = 1D0/SQRT(1D0 + TANBT**2)
30754 COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
30755 G1 = SQRT(ALP1*4D0*PI)
30756 G2 = SQRT(ALP2*4D0*PI)
30757 G3 = SQRT(ALP3*4D0*PI)
30758 HU = RMTOP/V/SINBT
30759 HD = XMB/V/COSBT
30760 HU2=HU*HU
30761 HD2=HD*HD
30762 HU4=HU2*HU2
30763 HD4=HD2*HD2
30764 AU2=AU**2
30765 AD2=AD**2
30766 XMS2=XMS**2
30767 XMS3=XMS**3
30768 XMS4=XMS2*XMS2
30769 XMU2=XMU*XMU
30770 PI2=PI*PI
30771
30772 XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2)
30773 XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2)
30774 AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4
30775 &+ 3D0*(AU + AD)**2/XMS2)/6D0
30776 XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2)
30777 &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
30778 &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2)
30779 &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2
30780 &- 16D0*G3**2) *T/16D0/PI2)
30781 XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2)
30782 &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
30783 &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2)
30784 &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2
30785 &- 16D0*G3**2) *T/16D0/PI2)
30786 XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
30787 &(HU2 + HD2)*T/16D0/PI2)
30788 &+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
30789 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
30790 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
30791 &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0
30792 &- 16D0*G3**2) *T/16D0/PI2)
30793 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
30794 &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2
30795 &- 16D0*G3**2) *T/16D0/PI2)
30796 XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2)
30797 &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
30798 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
30799 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
30800 &XMS4)*
30801 &(1+ (6D0*HU2 -2D0* HD2
30802 &- 16D0*G3**2) *T/16D0/PI2)
30803 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
30804 &XMS4)*
30805 &(1+ (6D0*HD2 -2D0* HU2/2D0
30806 &- 16D0*G3**2) *T/16D0/PI2)
30807 XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) *
30808 &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2)
30809 &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) *
30810 &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2)
30811 XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) *
30812 &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
30813 &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) *
30814 &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
30815 XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) *
30816 &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
30817 &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) *
30818 &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
30819 HHH(1)=XLAM1
30820 HHH(2)=XLAM2
30821 HHH(3)=XLAM3
30822 HHH(4)=XLAM4
30823 HHH(5)=XLAM5
30824 HHH(6)=XLAM6
30825 HHH(7)=XLAM7
30826 TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 +
30827 &2D0* XLAM6*SINBT*COSBT
30828 &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT
30829 &+ XLAM5*COSBT**2)
30830 DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) +
30831 &XLAM6*COSBT**2
30832 &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 +
30833 &2D0* XLAM6* COSBT*SINBT
30834 &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
30835 &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 *
30836 &((XLAM1* COSBT**2 +2D0*
30837 &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 +
30838 &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2)
30839 &*SINBT**2
30840 &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3
30841 &+ XLAM4) + XLAM6*COSBT**2
30842 &+ XLAM7* SINBT**2))
30843
30844 XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0
30845 XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0
30846 XHM = SQRT(XHM2)
30847 XMH = SQRT(XMH2)
30848 XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2
30849 XMHCH = SQRT(XMHCH2)
30850
30851 SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) -
30852 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
30853 &XLAM6* COSBT*SINBT
30854 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
30855 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
30856 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/
30857 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0
30858
30859 COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) +
30860 &XLAM6*COSBT**2 + XLAM7* SINBT**2) -
30861 &XMA**2*SINBT*COSBT))/2D0**0.5D0/
30862 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)*
30863 &(((TRM2**2 - 4D0* DETM2)**0.5D0) -
30864 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
30865 &XLAM6* COSBT*SINBT
30866 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
30867 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
30868 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2))))
30869
30870 SA = -SINALP
30871 CA = -COSALP
30872
30873 100 CONTINUE
30874
30875 RETURN
30876 END
30877
30878C*********************************************************************
30879
30880C...PYPOLE
30881C...This subroutine computes the CP-even higgs and CP-odd pole
30882c...Higgs masses and mixing angles.
30883
30884C...Program based on the work by M. Carena, M. Quiros
30885C...and C.E.M. Wagner, "Effective potential methods and
30886C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
30887
30888C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
30889C...AT,AB,MU
30890C...where MCHI is the largest chargino mass, MA is the running
30891C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
30892C...expectaion values at the scale MTOP, MQ is the third generation
30893C...left handed squark mass parameter, MUR is the third generation
30894C...right handed stop mass parameter, MDR is the third generation
30895C...right handed sbottom mass parameter, MTOP is the pole top quark
30896C...mass; AT,AB are the soft supersymmetry breaking trilinear
30897C...couplings of the stop and sbottoms, respectively, and MU is the
30898C...supersymmetric mass parameter
30899
30900C...The parameter IHIGGS=0,1,2,3 corresponds to the
30901c...number of Higgses whose pole mass is computed
30902c...by the subroutine PYVACU(...). If IHIGGS=0 only running
30903c...masses are given, what makes the running of the program
30904c...much faster and it is quite generally a good approximation
30905c...(for a theoretical discussion see ref. below).
30906c...If IHIGGS=1, only the pole
30907c...mass for H is computed. If IHIGGS=2, then h and H, and
30908c...if IHIGGS=3, then h,H,A polarizations are computed
30909
30910C...Output: MH and MHP which are the lightest CP-even Higgs running
30911C...and pole masses, respectively; HM and HMP are the heaviest CP-even
30912C...Higgs running and pole masses, repectively; SA and CA are the
30913C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
30914C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
30915C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
30916C...the value of TANB at the CP-odd Higgs mass scale
30917
30918C...This subroutine makes use of CERN library subroutine
30919C...integration package, which makes the computation of the
30920C...pole Higgs masses somewhat faster. We thank P. Janot for this
30921C...improvement. Those who are not able to call the CERN
30922C...libraries, please use the subroutine SUBHPOLE2.F, which
30923C...although somewhat slower, gives identical results
30924
30925 SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
30926 &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA)
30927
30928C...Double precision and integer declarations.
30929 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30930 IMPLICIT INTEGER(I-N)
30931
30932C...Parameters.
30933 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30934 INTEGER PYK,PYCHGE,PYCOMP
30935
30936C...Local variables.
30937 DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
30938 &SSBOT2(2),B(2,2),COUPB(2,2),
30939 &HCOUPT(2,2),HCOUPB(2,2),
30940 &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
30941
30942 DELTA(1,1) = 1D0
30943 DELTA(2,2) = 1D0
30944 DELTA(1,2) = 0D0
30945 DELTA(2,1) = 0D0
30946 V = 174.1D0
30947 XMZ=91.18D0
30948 PI=3.14159D0
30949 ALP3Z=0.12D0
30950 ALP3=1D0/(1D0/ALP3Z+23D0/6D0/PI*LOG(XMT/XMZ))
30951
30952C RXMT = XMT/(1D0+4*ALP3/3D0/PI)
30953 RXMT = PYRNMT(XMT)
30954
30955 HT = RXMT /V
30956 CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
30957 &XMU,XMH,HM,SA,CA,TANBA)
30958 SINB = TANB/(TANB**2+1D0)**0.5D0
30959 COSB = 1D0/(TANB**2+1D0)**0.5D0
30960 COS2B = SINB**2 - COSB**2
30961 SINBPA = SINB*CA + COSB*SA
30962 COSBPA = COSB*CA - SINB*SA
30963 RMBOT = 3D0
30964 XMQ2 = XMQ**2
30965 XMUR2 = XMUR**2
30966 IF(XMUR.LT.0D0) XMUR2=-XMUR2
30967 XMDR2 = XMDR**2
30968 XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B
30969 XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
30970 IF(XMST11.LT.0D0) GOTO 500
30971 IF(XMST22.LT.0D0) GOTO 500
30972 XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B
30973 XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
30974 IF(XMSB11.LT.0D0) GOTO 500
30975 IF(XMSB22.LT.0D0) GOTO 500
30976 WMST11 = RXMT**2 + XMQ2
30977 WMST22 = RXMT**2 + XMUR2
30978 XMST12 = RXMT*(AT - XMU/TANB)
30979 XMSB12 = RMBOT*(AB - XMU*TANB)
30980
30981CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
30982C...STOP EIGENVALUES CALCULATION
30983CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
30984
30985 STOP12 = 0.5D0*(XMST11+XMST22) +
30986 &0.5D0*((XMST11+XMST22)**2 -
30987 &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
30988 STOP22 = 0.5D0*(XMST11+XMST22) -
30989 &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
30990 &XMST12**2))**0.5D0
30991
30992 IF(STOP22.LT.0D0) GOTO 500
30993 SSTOP2(1) = STOP12
30994 SSTOP2(2) = STOP22
30995 STOP1 = STOP12**0.5D0
30996 STOP2 = STOP22**0.5D0
30997 STOP1W = STOP1
30998 STOP2W = STOP2
30999
31000 IF(XMST12.EQ.0D0) XST11 = 1D0
31001 IF(XMST12.EQ.0D0) XST12 = 0D0
31002 IF(XMST12.EQ.0D0) XST21 = 0D0
31003 IF(XMST12.EQ.0D0) XST22 = 1D0
31004
31005 IF(XMST12.EQ.0D0) GOTO 110
31006
31007 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
31008 XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
31009 XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
31010 XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
31011
31012 110 T(1,1) = XST11
31013 T(2,2) = XST22
31014 T(1,2) = XST12
31015 T(2,1) = XST21
31016
31017 SBOT12 = 0.5D0*(XMSB11+XMSB22) +
31018 &0.5D0*((XMSB11+XMSB22)**2 -
31019 &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
31020 SBOT22 = 0.5D0*(XMSB11+XMSB22) -
31021 &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
31022 &XMSB12**2))**0.5D0
31023 IF(SBOT22.LT.0D0) GOTO 500
31024 SBOT1 = SBOT12**0.5D0
31025 SBOT2 = SBOT22**0.5D0
31026
31027 SSBOT2(1) = SBOT12
31028 SSBOT2(2) = SBOT22
31029
31030 IF(XMSB12.EQ.0D0) XSB11 = 1D0
31031 IF(XMSB12.EQ.0D0) XSB12 = 0D0
31032 IF(XMSB12.EQ.0D0) XSB21 = 0D0
31033 IF(XMSB12.EQ.0D0) XSB22 = 1D0
31034
31035 IF(XMSB12.EQ.0D0) GOTO 130
31036
31037 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
31038 XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
31039 XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
31040 XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
31041
31042 130 B(1,1) = XSB11
31043 B(2,2) = XSB22
31044 B(1,2) = XSB12
31045 B(2,1) = XSB21
31046
31047
31048 SINT = 0.2320D0
31049 SQR = 2D0**0.5D0
31050 VP = 174.1D0*SQR
31051
31052CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31053C...STARTING OF LIGHT HIGGS
31054CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31055
31056 IF(IHIGGS.EQ.0) GOTO 490
31057
31058 DO 150 I = 1,2
31059 DO 140 J = 1,2
31060 COUPT(I,J) =
31061 & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
31062 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
31063 & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
31064 & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
31065 & T(1,J)*T(2,I))
31066 140 CONTINUE
31067 150 CONTINUE
31068
31069
31070 DO 170 I = 1,2
31071 DO 160 J = 1,2
31072 COUPB(I,J) =
31073 & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
31074 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
31075 & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
31076 & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
31077 & B(1,J)*B(2,I))
31078 160 CONTINUE
31079 170 CONTINUE
31080
31081 PRUN = XMH
31082 EPS = 1D-4*PRUN
31083 ITER = 0
31084 180 ITER = ITER + 1
31085 DO 230 I3 = 1,3
31086
31087 PR(I3)=PRUN+(I3-2)*EPS/2
31088 P2=PR(I3)**2
31089 POLT = 0D0
31090 DO 200 I = 1,2
31091 DO 190 J = 1,2
31092 POLT = POLT + COUPT(I,J)**2*3D0*
31093 & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
31094 190 CONTINUE
31095 200 CONTINUE
31096 POLB = 0D0
31097 DO 220 I = 1,2
31098 DO 210 J = 1,2
31099 POLB = POLB + COUPB(I,J)**2*3D0*
31100 & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
31101 210 CONTINUE
31102 220 CONTINUE
31103 RXMT2 = RXMT**2
31104 XMT2=XMT**2
31105
31106 POLTT =
31107 & 3D0*RXMT**2/8D0/PI**2/ V **2*
31108 & CA**2/SINB**2 *
31109 & (-2D0*XMT**2+0.5D0*P2)*
31110 & PYFINT(P2,XMT2,XMT2)
31111
31112 POL = POLT + POLB + POLTT
31113 POLAR(I3) = P2 - XMH**2 - POL
31114 230 CONTINUE
31115 DERIV = (POLAR(3)-POLAR(1))/EPS
31116 DRUN = - POLAR(2)/DERIV
31117 PRUN = PRUN + DRUN
31118 P2 = PRUN**2
31119 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.100 ) GOTO 240
31120 GOTO 180
31121 240 CONTINUE
31122
31123 XMHP = P2**0.5D0
31124
31125CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31126C...END OF LIGHT HIGGS
31127CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31128
31129 250 IF(IHIGGS.EQ.1) GOTO 490
31130
31131CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31132C... STARTING OF HEAVY HIGGS
31133CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31134
31135 DO 270 I = 1,2
31136 DO 260 J = 1,2
31137 HCOUPT(I,J) =
31138 & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
31139 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
31140 & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
31141 & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
31142 & T(1,J)*T(2,I))
31143 260 CONTINUE
31144 270 CONTINUE
31145
31146 DO 290 I = 1,2
31147 DO 280 J = 1,2
31148 HCOUPB(I,J) =
31149 & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
31150 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
31151 & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
31152 & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
31153 & B(1,J)*B(2,I))
31154 HCOUPB(I,J)=0D0
31155 280 CONTINUE
31156 290 CONTINUE
31157
31158 PRUN = HM
31159 EPS = 1D-4*PRUN
31160 ITER = 0
31161 300 ITER = ITER + 1
31162 DO 350 I3 = 1,3
31163 PR(I3)=PRUN+(I3-2)*EPS/2
31164 HP2=PR(I3)**2
31165
31166 HPOLT = 0D0
31167 DO 320 I = 1,2
31168 DO 310 J = 1,2
31169 HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
31170 & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
31171 310 CONTINUE
31172 320 CONTINUE
31173
31174 HPOLB = 0D0
31175 DO 340 I = 1,2
31176 DO 330 J = 1,2
31177 HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
31178 & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
31179 330 CONTINUE
31180 340 CONTINUE
31181
31182 RXMT2 = RXMT**2
31183 XMT2 = XMT**2
31184
31185 HPOLTT =
31186 & 3D0*RXMT**2/8D0/PI**2/ V **2*
31187 & SA**2/SINB**2 *
31188 & (-2D0*XMT**2+0.5D0*HP2)*
31189 & PYFINT(HP2,XMT2,XMT2)
31190
31191 HPOL = HPOLT + HPOLB + HPOLTT
31192 POLAR(I3) =HP2-HM**2-HPOL
31193 350 CONTINUE
31194 DERIV = (POLAR(3)-POLAR(1))/EPS
31195 DRUN = - POLAR(2)/DERIV
31196 PRUN = PRUN + DRUN
31197 HP2 = PRUN**2
31198 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.100 ) GOTO 360
31199 GOTO 300
31200 360 CONTINUE
31201
31202
31203 370 CONTINUE
31204 HMP = HP2**0.5D0
31205
31206CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31207C... END OF HEAVY HIGGS
31208CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31209
31210 IF(IHIGGS.EQ.2) GOTO 490
31211
31212CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31213C...BEGINNING OF PSEUDOSCALAR HIGGS
31214CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31215
31216 DO 390 I = 1,2
31217 DO 380 J = 1,2
31218 ACOUPT(I,J) =
31219 & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
31220 & (T(1,I)*T(2,J) -T(1,J)*T(2,I))
31221 380 CONTINUE
31222 390 CONTINUE
31223 DO 410 I = 1,2
31224 DO 400 J = 1,2
31225 ACOUPB(I,J) =
31226 & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
31227 & (B(1,I)*B(2,J) -B(1,J)*B(2,I))
31228 400 CONTINUE
31229 410 CONTINUE
31230
31231 PRUN = XMA
31232 EPS = 1D-4*PRUN
31233 ITER = 0
31234 420 ITER = ITER + 1
31235 DO 470 I3 = 1,3
31236 PR(I3)=PRUN+(I3-2)*EPS/2
31237 AP2=PR(I3)**2
31238 APOLT = 0D0
31239 DO 440 I = 1,2
31240 DO 430 J = 1,2
31241 APOLT = APOLT + ACOUPT(I,J)**2*3D0*
31242 & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
31243 430 CONTINUE
31244 440 CONTINUE
31245 APOLB = 0D0
31246 DO 460 I = 1,2
31247 DO 450 J = 1,2
31248 APOLB = APOLB + ACOUPB(I,J)**2*3D0*
31249 & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
31250 450 CONTINUE
31251 460 CONTINUE
31252 RXMT2 = RXMT**2
31253 XMT2=XMT**2
31254 APOLTT =
31255 & 3D0*RXMT**2/8D0/PI**2/ V **2*
31256 & COSB**2/SINB**2 *
31257 & (-0.5D0*AP2)*
31258 & PYFINT(AP2,XMT2,XMT2)
31259 APOL = APOLT + APOLB + APOLTT
31260 POLAR(I3) = AP2 - XMA**2 -APOL
31261 470 CONTINUE
31262 DERIV = (POLAR(3)-POLAR(1))/EPS
31263 DRUN = - POLAR(2)/DERIV
31264 PRUN = PRUN + DRUN
31265 AP2 = PRUN**2
31266 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.100 ) GOTO 480
31267 GOTO 420
31268 480 CONTINUE
31269
31270 AMP = AP2**0.5D0
31271
31272CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31273C...END OF PSEUDOSCALAR HIGGS
31274CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31275
31276 IF(IHIGGS.EQ.3) GOTO 490
31277
31278 490 CONTINUE
31279 RETURN
31280 500 CONTINUE
31281 WRITE(MSTU(11),*) ' EXITING IN PYVACU '
31282 WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
31283 WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
31284 WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
31285 STOP
31286 END
31287
31288C*********************************************************************
31289
31290C...PYVACU
31291C...Computes Higgs masses and mixing angles, see PYPOLE above.
31292
31293 SUBROUTINE PYVACU(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,
31294 &XMT,AT,AB,XMU,XMH,XMHP,HM,HMP,AMP,STOP1,STOP2,
31295 &SBOT1,SBOT2,SA,CA,STOP1W,STOP2W,TANBA)
31296
31297C...Double precision and integer declarations.
31298 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31299 IMPLICIT INTEGER(I-N)
31300C...Parameters.
31301 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31302 INTEGER PYK,PYCHGE,PYCOMP
31303
31304C...Local variables.
31305 DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
31306 &SSBOT2(2),B(2,2),COUPB(2,2),
31307 &HCOUPT(2,2),HCOUPB(2,2),
31308 &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
31309
31310 DELTA(1,1) = 1D0
31311 DELTA(2,2) = 1D0
31312 DELTA(1,2) = 0D0
31313 DELTA(2,1) = 0D0
31314 V = 174.1D0
31315 XMZ=91.18D0
31316 PI=3.14159D0
31317 ALP3Z=0.12D0
31318 ALP3=1D0/(1D0/ALP3Z+23D0/6D0/PI*LOG(XMT/XMZ))
31319
31320C RXMT = XMT/(1D0+4*ALP3/3D0/PI)
31321 RXMT = PYRNMT(XMT)
31322
31323 HT = RXMT /V
31324 CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
31325 &XMU,XMH,HM,SA,CA,TANBA)
31326 SINB = TANB/(TANB**2+1D0)**0.5D0
31327 COSB = 1D0/(TANB**2+1D0)**0.5D0
31328 COS2B = SINB**2 - COSB**2
31329 SINBPA = SINB*CA + COSB*SA
31330 COSBPA = COSB*CA - SINB*SA
31331 RMBOT = 3D0
31332 XMQ2 = XMQ**2
31333 XMUR2 = XMUR**2
31334 IF(XMUR.LT.0D0) XMUR2=-XMUR2
31335 XMDR2 = XMDR**2
31336 XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B
31337 XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
31338 IF(XMST11.LT.0D0) GOTO 500
31339 IF(XMST22.LT.0D0) GOTO 500
31340 XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B
31341 XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
31342 IF(XMSB11.LT.0D0) GOTO 500
31343 IF(XMSB22.LT.0D0) GOTO 500
31344 WMST11 = RXMT**2 + XMQ2
31345 WMST22 = RXMT**2 + XMUR2
31346 XMST12 = RXMT*(AT - XMU/TANB)
31347 XMSB12 = RMBOT*(AB - XMU*TANB)
31348
31349CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31350C...STOP EIGENVALUES CALCULATION
31351CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31352
31353 STOP12 = 0.5D0*(XMST11+XMST22) +
31354 &0.5D0*((XMST11+XMST22)**2 -
31355 &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
31356 STOP22 = 0.5D0*(XMST11+XMST22) -
31357 &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
31358 &XMST12**2))**0.5D0
31359
31360 IF(STOP22.LT.0D0) GOTO 500
31361 SSTOP2(1) = STOP12
31362 SSTOP2(2) = STOP22
31363 STOP1 = STOP12**0.5D0
31364 STOP2 = STOP22**0.5D0
31365 STOP1W = STOP1
31366 STOP2W = STOP2
31367
31368 IF(XMST12.EQ.0D0) XST11 = 1D0
31369 IF(XMST12.EQ.0D0) XST12 = 0D0
31370 IF(XMST12.EQ.0D0) XST21 = 0D0
31371 IF(XMST12.EQ.0D0) XST22 = 1D0
31372
31373 IF(XMST12.EQ.0D0) GOTO 110
31374
31375 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
31376 XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
31377 XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
31378 XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
31379
31380 110 T(1,1) = XST11
31381 T(2,2) = XST22
31382 T(1,2) = XST12
31383 T(2,1) = XST21
31384
31385 SBOT12 = 0.5D0*(XMSB11+XMSB22) +
31386 &0.5D0*((XMSB11+XMSB22)**2 -
31387 &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
31388 SBOT22 = 0.5D0*(XMSB11+XMSB22) -
31389 &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
31390 &XMSB12**2))**0.5D0
31391 IF(SBOT22.LT.0D0) GOTO 500
31392 SBOT1 = SBOT12**0.5D0
31393 SBOT2 = SBOT22**0.5D0
31394
31395 SSBOT2(1) = SBOT12
31396 SSBOT2(2) = SBOT22
31397
31398 IF(XMSB12.EQ.0D0) XSB11 = 1D0
31399 IF(XMSB12.EQ.0D0) XSB12 = 0D0
31400 IF(XMSB12.EQ.0D0) XSB21 = 0D0
31401 IF(XMSB12.EQ.0D0) XSB22 = 1D0
31402
31403 IF(XMSB12.EQ.0D0) GOTO 130
31404
31405 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
31406 XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
31407 XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
31408 XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
31409
31410 130 B(1,1) = XSB11
31411 B(2,2) = XSB22
31412 B(1,2) = XSB12
31413 B(2,1) = XSB21
31414
31415
31416 SINT = 0.2320D0
31417 SQR = 2D0**0.5D0
31418 VP = 174.1D0*SQR
31419
31420CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31421C...STARTING OF LIGHT HIGGS
31422CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31423
31424 IF(IHIGGS.EQ.0) GOTO 490
31425
31426 DO 150 I = 1,2
31427 DO 140 J = 1,2
31428 COUPT(I,J) =
31429 & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
31430 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
31431 & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
31432 & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
31433 & T(1,J)*T(2,I))
31434 140 CONTINUE
31435 150 CONTINUE
31436
31437
31438 DO 170 I = 1,2
31439 DO 160 J = 1,2
31440 COUPB(I,J) =
31441 & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
31442 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
31443 & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
31444 & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
31445 & B(1,J)*B(2,I))
31446 160 CONTINUE
31447 170 CONTINUE
31448
31449 PRUN = XMH
31450 EPS = 1D-4*PRUN
31451 ITER = 0
31452 180 ITER = ITER + 1
31453 DO 230 I3 = 1,3
31454
31455 PR(I3)=PRUN+(I3-2)*EPS/2
31456 P2=PR(I3)**2
31457 POLT = 0D0
31458 DO 200 I = 1,2
31459 DO 190 J = 1,2
31460 POLT = POLT + COUPT(I,J)**2*3D0*
31461 & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
31462 190 CONTINUE
31463 200 CONTINUE
31464 POLB = 0D0
31465 DO 220 I = 1,2
31466 DO 210 J = 1,2
31467 POLB = POLB + COUPB(I,J)**2*3D0*
31468 & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
31469 210 CONTINUE
31470 220 CONTINUE
31471 RXMT2 = RXMT**2
31472 XMT2=XMT**2
31473
31474 POLTT =
31475 & 3D0*RXMT**2/8D0/PI**2/ V **2*
31476 & CA**2/SINB**2 *
31477 & (-2D0*XMT**2+0.5D0*P2)*
31478 & PYFINT(P2,XMT2,XMT2)
31479
31480 POL = POLT + POLB + POLTT
31481 POLAR(I3) = P2 - XMH**2 - POL
31482 230 CONTINUE
31483 DERIV = (POLAR(3)-POLAR(1))/EPS
31484 DRUN = - POLAR(2)/DERIV
31485 PRUN = PRUN + DRUN
31486 P2 = PRUN**2
31487 IF( ABS(DRUN) .LT. 1D-4 ) GOTO 240
31488 GOTO 180
31489 240 CONTINUE
31490
31491 XMHP = P2**0.5D0
31492
31493CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31494C...END OF LIGHT HIGGS
31495CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31496
31497 250 IF(IHIGGS.EQ.1) GOTO 490
31498
31499CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31500C... STARTING OF HEAVY HIGGS
31501CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31502
31503 DO 270 I = 1,2
31504 DO 260 J = 1,2
31505 HCOUPT(I,J) =
31506 & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
31507 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
31508 & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
31509 & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
31510 & T(1,J)*T(2,I))
31511 260 CONTINUE
31512 270 CONTINUE
31513
31514 DO 290 I = 1,2
31515 DO 280 J = 1,2
31516 HCOUPB(I,J) =
31517 & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
31518 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
31519 & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
31520 & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
31521 & B(1,J)*B(2,I))
31522 HCOUPB(I,J)=0D0
31523 280 CONTINUE
31524 290 CONTINUE
31525
31526 PRUN = HM
31527 EPS = 1D-4*PRUN
31528 ITER = 0
31529 300 ITER = ITER + 1
31530 DO 350 I3 = 1,3
31531 PR(I3)=PRUN+(I3-2)*EPS/2
31532 HP2=PR(I3)**2
31533
31534 HPOLT = 0D0
31535 DO 320 I = 1,2
31536 DO 310 J = 1,2
31537 HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
31538 & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
31539 310 CONTINUE
31540 320 CONTINUE
31541
31542 HPOLB = 0D0
31543 DO 340 I = 1,2
31544 DO 330 J = 1,2
31545 HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
31546 & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
31547 330 CONTINUE
31548 340 CONTINUE
31549
31550 RXMT2 = RXMT**2
31551 XMT2 = XMT**2
31552
31553 HPOLTT =
31554 & 3D0*RXMT**2/8D0/PI**2/ V **2*
31555 & SA**2/SINB**2 *
31556 & (-2D0*XMT**2+0.5D0*HP2)*
31557 & PYFINT(HP2,XMT2,XMT2)
31558
31559 HPOL = HPOLT + HPOLB + HPOLTT
31560 POLAR(I3) =HP2-HM**2-HPOL
31561 350 CONTINUE
31562 DERIV = (POLAR(3)-POLAR(1))/EPS
31563 DRUN = - POLAR(2)/DERIV
31564 PRUN = PRUN + DRUN
31565 HP2 = PRUN**2
31566 IF( ABS(DRUN) .LT. 1D-4 ) GOTO 360
31567 GOTO 300
31568 360 CONTINUE
31569
31570
31571 370 CONTINUE
31572 HMP = HP2**0.5D0
31573
31574CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31575C... END OF HEAVY HIGGS
31576CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31577
31578 IF(IHIGGS.EQ.2) GOTO 490
31579
31580CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31581C...BEGINNING OF PSEUDOSCALAR HIGGS
31582CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31583
31584 DO 390 I = 1,2
31585 DO 380 J = 1,2
31586 ACOUPT(I,J) =
31587 & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
31588 & (T(1,I)*T(2,J) -T(1,J)*T(2,I))
31589 380 CONTINUE
31590 390 CONTINUE
31591 DO 410 I = 1,2
31592 DO 400 J = 1,2
31593 ACOUPB(I,J) =
31594 & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
31595 & (B(1,I)*B(2,J) -B(1,J)*B(2,I))
31596 400 CONTINUE
31597 410 CONTINUE
31598
31599 PRUN = XMA
31600 EPS = 1D-4*PRUN
31601 ITER = 0
31602 420 ITER = ITER + 1
31603 DO 470 I3 = 1,3
31604 PR(I3)=PRUN+(I3-2)*EPS/2
31605 AP2=PR(I3)**2
31606 APOLT = 0D0
31607 DO 440 I = 1,2
31608 DO 430 J = 1,2
31609 APOLT = APOLT + ACOUPT(I,J)**2*3D0*
31610 & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
31611 430 CONTINUE
31612 440 CONTINUE
31613 APOLB = 0D0
31614 DO 460 I = 1,2
31615 DO 450 J = 1,2
31616 APOLB = APOLB + ACOUPB(I,J)**2*3D0*
31617 & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
31618 450 CONTINUE
31619 460 CONTINUE
31620 RXMT2 = RXMT**2
31621 XMT2=XMT**2
31622 APOLTT =
31623 & 3D0*RXMT**2/8D0/PI**2/ V **2*
31624 & COSB**2/SINB**2 *
31625 & (-0.5D0*AP2)*
31626 & PYFINT(AP2,XMT2,XMT2)
31627 APOL = APOLT + APOLB + APOLTT
31628 POLAR(I3) = AP2 - XMA**2 -APOL
31629 470 CONTINUE
31630 DERIV = (POLAR(3)-POLAR(1))/EPS
31631 DRUN = - POLAR(2)/DERIV
31632 PRUN = PRUN + DRUN
31633 AP2 = PRUN**2
31634 IF( ABS(DRUN) .LT. 1D-4 ) GOTO 480
31635 GOTO 420
31636 480 CONTINUE
31637
31638 AMP = AP2**0.5D0
31639
31640CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31641C...END OF PSEUDOSCALAR HIGGS
31642CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31643
31644 IF(IHIGGS.EQ.3) GOTO 490
31645
31646 490 CONTINUE
31647 RETURN
31648 500 CONTINUE
31649 WRITE(MSTU(11),*) ' EXITING IN PYVACU '
31650 WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
31651 WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
31652 WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
31653 STOP
31654 END
31655
31656C*********************************************************************
31657
31658C...PYRGHM
31659C...Auxiliary routine to PYVACU for SUSY Higgs calculations.
31660
31661 SUBROUTINE PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDL,XMT,AU,AD,XMU,
31662 &XMHP,HMP,SA,CA,TANBA)
31663
31664C...Double precision and integer declarations.
31665 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31666 IMPLICIT INTEGER(I-N)
31667 INTEGER PYK,PYCHGE,PYCOMP
31668 COMMON/PYHTRI/HHH(7)
31669
31670C...Local variables.
31671 DIMENSION VH(2,2),XM2(2,2),XM2P(2,2)
31672
31673 XMZ = 91.18D0
31674 ALP1 = 0.0101D0
31675 ALP2 = 0.0337D0
31676 ALP3Z = 0.12D0
31677 V = 174.1D0
31678 PI = 3.14159D0
31679 TANBA = TANB
31680 TANBT = TANB
31681
31682C...MBOTTOM(XMT) = 3. GEV
31683 XMB = 3D0
31684 ALP3 = ALP3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALP3Z*
31685 &LOG(XMT**2/XMZ**2))
31686
31687C...RXMT= RUNNING TOP QUARK MASS
31688 RXMT = XMT/(1D0+4D0*ALP3/3D0/PI)
31689 TQ = LOG((XMQ**2+XMT**2)/XMT**2)
31690 TU = LOG((XMUR**2 + XMT**2)/XMT**2)
31691 TD = LOG((XMDL**2 + XMT**2)/XMT**2)
31692 SINB = TANB/((1D0 + TANB**2)**0.5D0)
31693 COSB = SINB/TANB
31694 IF(XMA.GT.XMT)
31695 &TANBA = TANB*(1D0-3D0/32D0/PI**2*
31696 &(RXMT**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
31697 &LOG(XMA**2/XMT**2))
31698 IF(XMA.LT.XMT.OR.XMA.EQ.XMT) TANBT = TANBA
31699 SINB = TANBT/((1D0 + TANBT**2)**0.5D0)
31700 COSB = 1D0/((1D0 + TANBT**2)**0.5D0)
31701 COS2B = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
31702 G1 = (ALP1*4D0*PI)**0.5D0
31703 G2 = (ALP2*4D0*PI)**0.5D0
31704 G3 = (ALP3*4D0*PI)**0.5D0
31705 HU = RXMT/V/SINB
31706 HD = XMB/V/COSB
31707
31708 CALL PYGFXX(XMA,TANBA,XMQ,XMUR,XMDL,XMT,AU,AD,
31709 &XMU,VH,STOP1,STOP2)
31710
31711 IF(XMQ.GT.XMUR) TP = TQ - TU
31712 IF(XMQ.LT.XMUR.OR.XMQ.EQ.XMUR) TP = TU - TQ
31713 IF(XMQ.GT.XMUR) TDP = TU
31714 IF(XMQ.LT.XMUR.OR.XMQ.EQ.XMUR) TDP = TQ
31715 IF(XMQ.GT.XMDL) TPD = TQ - TD
31716 IF(XMQ.LT.XMDL.OR.XMQ.EQ.XMDL) TPD = TD - TQ
31717 IF(XMQ.GT.XMDL) TDPD = TD
31718 IF(XMQ.LT.XMDL.OR.XMQ.EQ.XMDL) TDPD = TQ
31719
31720 IF(XMQ.GT.XMDL) DLAM1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD
31721 IF(XMQ.LT.XMDL.OR.XMQ.EQ.XMDL) DLAM1 = 3D0/32D0/PI**2*
31722 &HD**2*(G1**2/3D0+G2**2)*TPD
31723
31724 IF(XMQ.GT.XMUR) DLAM2 =12D0/96D0/PI**2*G1**2*HU**2*TP
31725 IF(XMQ.LT.XMUR.OR.XMQ.EQ.XMUR) DLAM2 = 3D0/32D0/PI**2*
31726 &HU**2*(-G1**2/3D0+G2**2)*TP
31727
31728 DLAM3 = 0D0
31729 DLAM4 = 0D0
31730
31731 IF(XMQ.GT.XMDL) DLAM3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD
31732 IF(XMQ.LT.XMDL.OR.XMQ.EQ.XMDL) DLAM3 = 3D0/64D0/PI**2*HD**2*
31733 &(G2**2-G1**2/3D0)*TPD
31734
31735 IF(XMQ.GT.XMUR) DLAM3 = DLAM3 -
31736 &1D0/16D0/PI**2*G1**2*HU**2*TP
31737 IF(XMQ.LT.XMUR.OR.XMQ.EQ.XMUR) DLAM3 = DLAM3 +
31738 &3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP
31739
31740 IF(XMQ.LT.XMUR) DLAM4 = -3D0/32D0/PI**2*G2**2*HU**2*TP
31741 IF(XMQ.LT.XMDL) DLAM4 = DLAM4 - 3D0/32D0/PI**2*G2**2*
31742 &HD**2*TPD
31743
31744 XLAM1 = ((G1**2 + G2**2)/4D0)*
31745 &(1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2)
31746 &+(3D0*HD**4/16D0/PI**2) *TPD*(1D0
31747 &+ (3D0*HD**2/2D0 + HU**2/2D0
31748 &- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2)
31749 &+(3D0*HD**4/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0
31750 &- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAM1
31751 XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2*
31752 &(TP + TDP)/8D0/PI**2)
31753 &+(3D0*HU**4/16D0/PI**2) *TP*(1D0
31754 &+ (3D0*HU**2/2D0 + HD**2/2D0
31755 &- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2)
31756 &+(3D0*HU**4/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0
31757 &- 8D0*G3**2) * TDP/16D0/PI**2) + DLAM2
31758 XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
31759 &(HU**2)*(TP + TDP)/16D0/PI**2 -3D0*
31760 &(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAM3
31761 XLAM4 = (- G2**2/2D0)*(1D0
31762 &-3D0*(HU**2)*(TP + TDP)/16D0/PI**2
31763 &-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAM4
31764
31765 XLAM5 = 0D0
31766 XLAM6 = 0D0
31767 XLAM7 = 0D0
31768
31769C...Defined now in PYSUBH
31770C HHH(1)=XLAM1
31771C HHH(2)=XLAM2
31772C HHH(3)=XLAM3
31773C HHH(4)=XLAM4
31774C HHH(5)=XLAM5
31775C HHH(6)=XLAM6
31776C HHH(7)=XLAM7
31777
31778 XM2(1,1) = 2D0*V**2*(XLAM1*COSB**2+2D0*XLAM6*
31779 &COSB*SINB + XLAM5*SINB**2) + XMA**2*SINB**2
31780
31781 XM2(2,2) = 2D0*V**2*(XLAM5*COSB**2+2D0*XLAM7*
31782 &COSB*SINB + XLAM2*SINB**2) + XMA**2*COSB**2
31783 XM2(1,2) = 2D0*V**2*(XLAM6*COSB**2+(XLAM3+XLAM4)*
31784 &COSB*SINB + XLAM7*SINB**2) - XMA**2*SINB*COSB
31785
31786 XM2(2,1) = XM2(1,2)
31787
31788CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31789C...THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
31790CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31791
31792 XMSSU=(0.5D0*(XMQ**2+XMUR**2)+XMT**2)**0.5D0
31793
31794 IF(XMC.GT.XMSSU) GOTO 100
31795 IF(XMC.LT.XMT) XMC=XMT
31796
31797 TCHAR=LOG(XMSSU**2/XMC**2)
31798
31799 DEL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR
31800 DEL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4
31801 &+4D0/32/PI**2*G1**2*G2**2)*TCHAR
31802
31803 DEM112=2D0*DEL12*V**2*COSB**2
31804 DEM222=2D0*DEL12*V**2*SINB**2
31805 DEM122=2D0*DEL3P4*V**2*SINB*COSB
31806
31807 XM2(1,1)=XM2(1,1)+DEM112
31808 XM2(2,2)=XM2(2,2)+DEM222
31809 XM2(1,2)=XM2(1,2)+DEM122
31810 XM2(2,1)=XM2(2,1)+DEM122
31811
31812 100 CONTINUE
31813
31814CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31815C...END OF CHARGINOS/NEUTRALINOS
31816CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31817
31818 DO 120 I = 1,2
31819 DO 110 J = 1,2
31820 XM2P(I,J) = XM2(I,J) + VH(I,J)
31821 110 CONTINUE
31822 120 CONTINUE
31823
31824 TRM2P = XM2P(1,1) + XM2P(2,2)
31825 DETM2P = XM2P(1,1)*XM2P(2,2) - XM2P(1,2)*XM2P(2,1)
31826
31827 XMH2P = (TRM2P - (TRM2P**2 - 4D0* DETM2P)**0.5D0)/2D0
31828 HM2P = (TRM2P + (TRM2P**2 - 4D0* DETM2P)**0.5D0)/2D0
31829 HMP = HM2P**0.5D0
31830 IF(XMH2P.LT.0D0) GOTO 130
31831 XMHP = XMH2P**0.5D0
31832 S2ALP = 2D0*XM2P(1,2)/(TRM2P**2-4D0*DETM2P)**0.5D0
31833 C2ALP = (XM2P(1,1)-XM2P(2,2))/(TRM2P**2-4D0*DETM2P)**0.5D0
31834 IF(C2ALP.GT.0D0) ALP = ASIN(S2ALP)/2D0
31835 IF(C2ALP.LT.0D0) ALP = -PI/2D0-ASIN(S2ALP)/2D0
31836 SA = SIN(ALP)
31837 CA = COS(ALP)
31838 SQBMA = (SINB*CA - COSB*SA)**2
31839 130 XIN = 1D0
31840 140 CONTINUE
31841
31842 RETURN
31843 END
31844
31845C*********************************************************************
31846
31847C...PYGFXX
31848C...Auxiliary routine to PYRGHM for SUSY Higgs calculations.
31849
31850 SUBROUTINE PYGFXX(XMA,TANB,XMQ,XMUR,XMDL,XMT,AT,AB,XMU,VH,
31851 &STOP1,STOP2)
31852
31853C...Double precision and integer declarations.
31854 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31855 IMPLICIT INTEGER(I-N)
31856 INTEGER PYK,PYCHGE,PYCOMP
31857
31858C...Local variables.
31859 DIMENSION DIAH(2),VH(2,2),VH1(2,2),VH2(2,2),
31860 &VH3T(2,2),VH3B(2,2),
31861 &HMIX(2,2),AL(2,2),XM2(2,2)
31862
31863C...Statement function.
31864 G(X,Y) = 2D0 - (X+Y)/(X-Y)*LOG(X/Y)
31865
31866 IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0
31867 XMQ2 = XMQ**2
31868 XMUR2 = XMUR**2
31869 XMDL2 = XMDL**2
31870 TANBA = TANB
31871 SINBA = TANBA/(TANBA**2+1D0)**0.5D0
31872 COSBA = SINBA/TANBA
31873
31874 SINB = TANB/(TANB**2+1D0)**0.5D0
31875 COSB = SINB/TANB
31876 PI = 3.14159D0
31877 G2 = (0.0336D0*4D0*PI)**0.5D0
31878 G12 = (0.0101D0*4D0*PI)
31879 G1 = G12**0.5D0
31880 XMZ = 91.18D0
31881 V = 174.1D0
31882 MW = (G2**2*V**2/2D0)**0.5D0
31883 ALP3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(XMT**2/XMZ**2))
31884
31885 XMB = 3D0
31886 IF(XMQ.GT.XMUR) XMST = XMQ
31887 IF(XMUR.GT.XMQ.OR.XMUR.EQ.XMQ) XMST = XMUR
31888
31889 XMSUT = (XMST**2 + XMT**2)**0.5D0
31890
31891 IF(XMQ.GT.XMDL) XMSB = XMQ
31892 IF(XMDL.GT.XMQ.OR.XMDL.EQ.XMQ) XMSB = XMDL
31893
31894 XMSUB = (XMSB**2 + XMB**2)**0.5D0
31895
31896 TT = LOG(XMSUT**2/XMT**2)
31897 TB = LOG(XMSUB**2/XMT**2)
31898
31899 RXMT = XMT/(1D0+4D0*ALP3/3D0/PI)
31900 HT = RXMT/(174.1D0*SINB)
31901 HTST = RXMT/174.1D0
31902 HB = XMB/174.1D0/COSB
31903 G32 = ALP3*4D0*PI
31904 BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2
31905 BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2
31906 AL2 = 3D0/8D0/PI**2*HT**2
31907 BT2ST = -(8D0*G32 - 9D0*HTST**2/2D0)/(4D0*PI)**2
31908 ALST = 3D0/8D0/PI**2*HTST**2
31909 AL1 = 3D0/8D0/PI**2*HB**2
31910
31911 AL(1,1) = AL1
31912 AL(1,2) = (AL2+AL1)/2D0
31913 AL(2,1) = (AL2+AL1)/2D0
31914 AL(2,2) = AL2
31915
31916 XMT4 = RXMT**4*(1D0+2D0*BT2*TT- AL2*TT)
31917 XMT2 = SQRT(XMT4)
31918 XMBOT4 = XMB**4*(1D0+2D0*BB2*TB - AL1*TB)
31919 XMBOT2 = SQRT(XMBOT4)
31920
31921 IF(XMA.GT.XMT) THEN
31922 VI = 174.1D0*(1D0 + 3D0/32D0/PI**2*HTST**2*
31923 & LOG(XMT**2/XMA**2))
31924 H1I = VI* COSBA
31925 H2I = VI*SINBA
31926 H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(XMA**2/XMSUT**2))**0.25D0
31927 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(XMA**2/XMSUT**2))**0.25D0
31928 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(XMA**2/XMSUB**2))**0.25D0
31929 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(XMA**2/XMSUB**2))**0.25D0
31930 ELSE
31931 VI = 174.1D0
31932 H1I = VI*COSB
31933 H2I = VI*SINB
31934 H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(XMT**2/XMSUT**2))**0.25D0
31935 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(XMT**2/XMSUT**2))**0.25D0
31936 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(XMT**2/XMSUB**2))**0.25D0
31937 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(XMT**2/XMSUB**2))**0.25D0
31938 ENDIF
31939
31940 TANBST = H2T/H1T
31941 SINBT = TANBST/(1D0+TANBST**2)**0.5D0
31942 COSBT = SINBT/TANBST
31943
31944 TANBSB = H2B/H1B
31945 SINBB = TANBSB/(1D0+TANBSB**2)**0.5D0
31946 COSBB = SINBB/TANBSB
31947
31948 STOP12 = (XMQ2 + XMUR2)*0.5D0 + XMT2
31949 &+1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
31950 &+(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
31951 &XMQ2 - XMUR2)**2*0.25D0 + XMT2*(AT-XMU/TANBST)**2)**0.5D0
31952 STOP22 = (XMQ2 + XMUR2)*0.5D0 + XMT2
31953 &+1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
31954 &- (((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
31955 &XMQ2 - XMUR2)**2*0.25D0
31956 &+ XMT2*(AT-XMU/TANBST)**2)**0.5D0
31957 IF(STOP22.LT.0D0) GOTO 120
31958 SBOT12 = (XMQ2 + XMDL2)*0.5D0
31959 &- 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
31960 &+ (((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
31961 &XMQ2 - XMDL2)**2*0.25D0 + XMBOT2*(AB-XMU*TANBSB)**2)**0.5D0
31962 SBOT22 = (XMQ2 + XMDL2)*0.5D0
31963 &- 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
31964 &- (((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
31965 &XMQ2 - XMDL2)**2*0.25D0 + XMBOT2*(AB-XMU*TANBSB)**2)**0.5D0
31966 IF(SBOT22.LT.0D0) GOTO 120
31967
31968 STOP1 = STOP12**0.5D0
31969 STOP2 = STOP22**0.5D0
31970 SBOT1 = SBOT12**0.5D0
31971 SBOT2 = SBOT22**0.5D0
31972
31973 VH1(1,1) = 1D0/TANBST
31974 VH1(2,1) = -1D0
31975 VH1(1,2) = -1D0
31976 VH1(2,2) = TANBST
31977 VH2(1,1) = TANBST
31978 VH2(1,2) = -1D0
31979 VH2(2,1) = -1D0
31980 VH2(2,2) = 1D0/TANBST
31981
31982CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31983C...D-TERMS
31984CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31985 STW=0.2320D0
31986
31987 F1T=(XMQ2-XMUR2)/(STOP12-STOP22)*(0.5D0-4D0/3D0*STW)*
31988 &LOG(STOP1/STOP2)
31989 &+(0.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(XMQ2+XMT2))
31990 &+ 2D0/3D0*STW*LOG(STOP1*STOP2/(XMUR2+XMT2))
31991
31992 F1B=(XMQ2-XMDL2)/(SBOT12-SBOT22)*(-0.5D0+2D0/3D0*STW)*
31993 &LOG(SBOT1/SBOT2)
31994 &+(-0.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(XMQ2+XMBOT2))
31995 &- 1D0/3D0*STW*LOG(SBOT1*SBOT2/(XMDL2+XMBOT2))
31996
31997 F2T=XMT2**0.5D0*(AT-XMU/TANBST)/(STOP12-STOP22)*
31998 &(-0.5D0*LOG(STOP12/STOP22)
31999 &+(4D0/3D0*STW-0.5D0)*(XMQ2-XMUR2)/(STOP12-STOP22)*
32000 &G(STOP12,STOP22))
32001
32002 F2B=XMBOT2**0.5D0*(AB-XMU*TANBSB)/(SBOT12-SBOT22)*
32003 &(0.5D0*LOG(SBOT12/SBOT22)
32004 &+(-2D0/3D0*STW+0.5D0)*(XMQ2-XMDL2)/(SBOT12-SBOT22)*
32005 &G(SBOT12,SBOT22))
32006
32007 VH3B(1,1) = XMBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/
32008 &(XMQ2+XMBOT2)/(XMDL2+XMBOT2))
32009 &+ 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))*
32010 &LOG(SBOT1**2/SBOT2**2)) +
32011 &XMBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/
32012 &(SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22)
32013
32014 VH3T(1,1) =
32015 &XMT4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2
32016 &-STOP2**2))**2*G(STOP12,STOP22)
32017
32018 VH3B(1,1)=VH3B(1,1)+
32019 &XMZ**2*(2*XMBOT2*F1B-XMBOT2**0.5D0*AB*F2B)
32020
32021 VH3T(1,1) = VH3T(1,1) +
32022 &XMZ**2*(XMT2**0.5D0*XMU/TANBST*F2T)
32023
32024 VH3T(2,2) = XMT4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/
32025 &(XMQ2+XMT2)/(XMUR2+XMT2))
32026 &+ 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))*
32027 &LOG(STOP1**2/STOP2**2)) +
32028 &XMT4/(SINBT**2)*(AT*(AT-XMU/TANBST)/
32029 &(STOP1**2-STOP2**2))**2*G(STOP12,STOP22)
32030
32031 VH3B(2,2) =
32032 &XMBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2
32033 &-SBOT2**2))**2*G(SBOT12,SBOT22)
32034
32035 VH3T(2,2)=VH3T(2,2)+
32036 &XMZ**2*(-2*XMT2*F1T+XMT2**0.5D0*AT*F2T)
32037
32038 VH3B(2,2) = VH3B(2,2) -XMZ**2*XMBOT2**0.5D0*XMU*TANBSB*F2B
32039
32040 VH3T(1,2) = -
32041 &XMT4/(SINBT**2)*XMU*(AT-XMU/TANBST)/
32042 &(STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT*
32043 &(AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22))
32044
32045 VH3B(1,2) =
32046 &- XMBOT4/(COSBB**2)*XMU*(AT-XMU*TANBSB)/
32047 &(SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB*
32048 &(AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22))
32049
32050 VH3T(1,2)=VH3T(1,2) +
32051 &XMZ**2*(XMT2/TANBST*F1T-XMT2**0.5D0*(AT/TANBST+XMU)/2D0*F2T)
32052
32053 VH3B(1,2)=VH3B(1,2)
32054 &+XMZ**2*(-XMBOT2*TANBSB*F1B+XMBOT2**0.5D0*(AB*TANBSB+XMU)/2D0*F2B)
32055
32056 VH3T(2,1) = VH3T(1,2)
32057 VH3B(2,1) = VH3B(1,2)
32058
32059 TQ = LOG((XMQ2 + XMT2)/XMT2)
32060 TU = LOG((XMUR2+XMT2)/XMT2)
32061 TQD = LOG((XMQ2 + XMB**2)/XMB**2)
32062 TD = LOG((XMDL2+XMB**2)/XMB**2)
32063
32064 DO 110 I = 1,2
32065 DO 100 J = 1,2
32066
32067 VH(I,J) =
32068 & 6D0/(8D0*PI**2*(H1T**2+H2T**2))
32069 & *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) +
32070 & 6D0/(8D0*PI**2*(H1B**2+H2B**2))
32071 & *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0)
32072
32073 100 CONTINUE
32074 110 CONTINUE
32075
32076 GOTO 150
32077 120 DO 140 I =1,2
32078 DO 130 J = 1,2
32079 VH(I,J) = -1D+15
32080 130 CONTINUE
32081 140 CONTINUE
32082
32083 150 CONTINUE
32084
32085 RETURN
32086 END
32087
32088C*********************************************************************
32089
32090C...PYFINT
32091C...Auxiliary routine to PYVACU for SUSY Higgs calculations.
32092
32093 FUNCTION PYFINT(A,B,C)
32094
32095C...Double precision and integer declarations.
32096 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32097 IMPLICIT INTEGER(I-N)
32098 INTEGER PYK,PYCHGE,PYCOMP
32099C...Commonblock.
32100 COMMON/PYINTS/XXM(20)
32101 SAVE/PYINTS/
32102
32103C...Local variables.
32104 EXTERNAL PYFISB
32105 DOUBLE PRECISION PYFISB
32106
32107 XXM(1)=A
32108 XXM(2)=B
32109 XXM(3)=C
32110 XLO=0D0
32111 XHI=1D0
32112 PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3)
32113
32114 RETURN
32115 END
32116
32117C*********************************************************************
32118
32119C...PYFISB
32120C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
32121
32122 FUNCTION PYFISB(X)
32123
32124C...Double precision and integer declarations.
32125 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32126 IMPLICIT INTEGER(I-N)
32127 INTEGER PYK,PYCHGE,PYCOMP
32128C...Commonblock.
32129 COMMON/PYINTS/XXM(20)
32130 SAVE/PYINTS/
32131
32132 PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/
32133 &(X*(XXM(2)-XXM(3))+XXM(3)))
32134
32135 RETURN
32136 END
32137
32138C*********************************************************************
32139
32140C...PYSFDC
32141C...Calculates decays of sfermions.
32142
32143 SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT)
32144
32145C...Double precision and integer declarations.
32146 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32147 IMPLICIT INTEGER(I-N)
32148 INTEGER PYK,PYCHGE,PYCOMP
32149C...Parameter statement to help give large particle numbers.
32150 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
32151C...Commonblocks.
32152 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32153 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32154 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
32155 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
32156 &SFMIX(16,4)
32157 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
32158
32159C...Local variables.
32160 INTEGER KFIN,KCIN
32161 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,
32162 &XMZ2,AXMJ,AXMI
32163 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMA2,XMB2,XMFP
32164 DOUBLE PRECISION PYLAMF,XL
32165 DOUBLE PRECISION TANW,XW,AEM,C1,AS
32166 DOUBLE PRECISION CA,CB,AL,AR,BL,BR,ALP,ARP,BLP,BRP
32167 DOUBLE PRECISION CH1,CH2,CH3,CH4
32168 DOUBLE PRECISION XMBOT,XMTOP
32169 DOUBLE PRECISION XLAM(0:200)
32170 INTEGER IDLAM(200,3)
32171 INTEGER LKNT,IX,IC,ILR,IDU,J,IJ,I,IKNT,IFL,IFP,II
32172 DOUBLE PRECISION SR2
32173 DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K
32174 DOUBLE PRECISION CW
32175 DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
32176 DOUBLE PRECISION COSA,SINA,TANB
32177 DOUBLE PRECISION PYALEM,PI,PYALPS,EI,PYRNMT
32178 DOUBLE PRECISION GHRR,GHLL,GHLR,CF,XMB,BLR
32179 INTEGER IG,KF1,KF2,ILR2,IDP
32180 INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
32181 DATA IGG/23,25,35,36/
32182 DATA PI/3.141592654D0/
32183 DATA SR2/1.4142136D0/
32184 DATA KFNCHI/1000022,1000023,1000025,1000035/
32185 DATA KFCCHI/1000024,1000037/
32186
32187C...COUNT THE NUMBER OF DECAY MODES
32188 LKNT=0
32189
32190C...NO NU_R DECAYS
32191 IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR.
32192 &KFIN.EQ.KSUSY2+16) RETURN
32193
32194 XMW=PMAS(24,1)
32195 XMW2=XMW**2
32196 XMZ=PMAS(23,1)
32197 XMZ2=XMZ**2
32198 XW=PARU(102)
32199 TANW = SQRT(XW/(1D0-XW))
32200 CW=SQRT(1D0-XW)
32201
32202C...KCIN
32203 KCIN=PYCOMP(KFIN)
32204C...ILR is 1 for left and 2 for right.
32205 ILR=KFIN/KSUSY1
32206C...IFL is matching non-SUSY flavour.
32207 IFL=MOD(KFIN,KSUSY1)
32208C...IDU is weak isospin, 1 for down and 2 for up.
32209 IDU=2-MOD(IFL,2)
32210
32211 XMI=PMAS(KCIN,1)
32212 XMI2=XMI**2
32213 AEM=PYALEM(XMI2)
32214 AS =PYALPS(XMI2)
32215 C1=AEM/XW
32216 XMI3=XMI**3
32217 EI=KCHG(IFL,1)/3D0
32218
32219 XMBOT=3D0
32220 XMTOP=PYRNMT(PMAS(6,1))
32221 XMBOT=0D0
32222
32223 TANB=RMSS(5)
32224 BETA=ATAN(TANB)
32225 ALFA=RMSS(18)
32226 CBETA=COS(BETA)
32227 SBETA=TANB*CBETA
32228 SINA=SIN(ALFA)
32229 COSA=COS(ALFA)
32230 XMU=-RMSS(4)
32231 ATRIT=RMSS(16)
32232 ATRIB=RMSS(15)
32233 ATRIL=RMSS(17)
32234
32235C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
32236
32237 IF(IMSS(11).EQ.1) THEN
32238 XMP=RMSS(29)
32239 IDG=39+KSUSY1
32240 XMGR=PMAS(PYCOMP(IDG),1)
32241 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
32242 IF(IFL.EQ.5) THEN
32243 XMF=XMBOT
32244 ELSEIF(IFL.EQ.6) THEN
32245 XMF=XMTOP
32246 ELSE
32247 XMF=PMAS(IFL,1)
32248 ENDIF
32249 IF(XMI.GT.XMGR+XMF) THEN
32250 LKNT=LKNT+1
32251 IDLAM(LKNT,1)=IDG
32252 IDLAM(LKNT,2)=IFL
32253 IDLAM(LKNT,3)=0
32254 XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4
32255 ENDIF
32256 ENDIF
32257
32258C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
32259
32260C...CHARGED DECAYS:
32261 DO 100 IX=1,2
32262C...DI -> U CHI1-,CHI2-
32263 IF(IDU.EQ.1) THEN
32264 XMFP=PMAS(IFL+1,1)
32265 XMF =PMAS(IFL,1)
32266C...UI -> D CHI1+,CHI2+
32267 ELSE
32268 XMFP=PMAS(IFL-1,1)
32269 XMF =PMAS(IFL,1)
32270 ENDIF
32271 XMJ=SMW(IX)
32272 AXMJ=ABS(XMJ)
32273 IF(XMI.GE.AXMJ+XMFP) THEN
32274 XMA2=XMJ**2
32275 XMB2=XMFP**2
32276 IF(IDU.EQ.2) THEN
32277 IF(IFL.EQ.6) THEN
32278 XMFP=XMBOT
32279 XMF =XMTOP
32280 ELSEIF(IFL.LT.6) THEN
32281 XMF=0D0
32282 XMFP=0D0
32283 ENDIF
32284 BL=VMIX(IX,1)
32285 AL=-XMFP*UMIX(IX,2)/SR2/XMW/CBETA
32286 BR=-XMF*VMIX(IX,2)/SR2/XMW/SBETA
32287 AR=0D0
32288 ELSE
32289 IF(IFL.EQ.5) THEN
32290 XMF =XMBOT
32291 XMFP=XMTOP
32292 ELSEIF(IFL.LT.5) THEN
32293 XMF=0D0
32294 XMFP=0D0
32295 ENDIF
32296 BL=UMIX(IX,1)
32297 AL=-XMFP*VMIX(IX,2)/SR2/XMW/SBETA
32298 BR=-XMF*UMIX(IX,2)/SR2/XMW/CBETA
32299 AR=0D0
32300 ENDIF
32301
32302 ALP=SFMIX(IFL,1)*AL + SFMIX(IFL,2)*AR
32303 BLP=SFMIX(IFL,1)*BL + SFMIX(IFL,2)*BR
32304 ARP=SFMIX(IFL,4)*AR + SFMIX(IFL,3)*AL
32305 BRP=SFMIX(IFL,4)*BR + SFMIX(IFL,3)*BL
32306 AL=ALP
32307 BL=BLP
32308 AR=ARP
32309 BR=BRP
32310
32311C...F1 -> F` CHI
32312 IF(ILR.EQ.1) THEN
32313 CA=AL
32314 CB=BL
32315C...F2 -> F` CHI
32316 ELSE
32317 CA=AR
32318 CB=BR
32319 ENDIF
32320 LKNT=LKNT+1
32321 XL=PYLAMF(XMI2,XMA2,XMB2)
32322C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
32323 XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
32324 & (CA**2+CB**2)-4D0*CA*CB*XMJ*XMFP)
32325 IDLAM(LKNT,3)=0
32326 IF(IDU.EQ.1) THEN
32327 IDLAM(LKNT,1)=-KFCCHI(IX)
32328 IDLAM(LKNT,2)=IFL+1
32329 ELSE
32330 IDLAM(LKNT,1)=KFCCHI(IX)
32331 IDLAM(LKNT,2)=IFL-1
32332 ENDIF
32333 ENDIF
32334 100 CONTINUE
32335
32336C...NEUTRAL DECAYS
32337 DO 110 IX=1,4
32338C...DI -> D CHI10
32339 XMF=PMAS(IFL,1)
32340 XMJ=SMZ(IX)
32341 AXMJ=ABS(XMJ)
32342 IF(XMI.GE.AXMJ+XMF) THEN
32343 XMA2=XMJ**2
32344 XMB2=XMF**2
32345 IF(IDU.EQ.1) THEN
32346 IF(IFL.EQ.5) THEN
32347 XMF=XMBOT
32348 ELSEIF(IFL.LT.5) THEN
32349 XMF=0D0
32350 ENDIF
32351 BL=-ZMIX(IX,2)+TANW*ZMIX(IX,1)*(2D0*EI+1)
32352 AL=XMF*ZMIX(IX,3)/XMW/CBETA
32353 AR=-2D0*EI*TANW*ZMIX(IX,1)
32354 BR=AL
32355 ELSE
32356 IF(IFL.EQ.6) THEN
32357 XMF=XMTOP
32358 ELSEIF(IFL.LT.5) THEN
32359 XMF=0D0
32360 ENDIF
32361 BL=ZMIX(IX,2)+TANW*ZMIX(IX,1)*(2D0*EI-1)
32362 AL=XMF*ZMIX(IX,4)/XMW/SBETA
32363 AR=-2D0*EI*TANW*ZMIX(IX,1)
32364 BR=AL
32365 ENDIF
32366
32367 ALP=SFMIX(IFL,1)*AL + SFMIX(IFL,2)*AR
32368 BLP=SFMIX(IFL,1)*BL + SFMIX(IFL,2)*BR
32369 ARP=SFMIX(IFL,4)*AR + SFMIX(IFL,3)*AL
32370 BRP=SFMIX(IFL,4)*BR + SFMIX(IFL,3)*BL
32371 AL=ALP
32372 BL=BLP
32373 AR=ARP
32374 BR=BRP
32375
32376C...F1 -> F CHI
32377 IF(ILR.EQ.1) THEN
32378 CA=AL
32379 CB=BL
32380C...F2 -> F CHI
32381 ELSE
32382 CA=AR
32383 CB=BR
32384 ENDIF
32385 LKNT=LKNT+1
32386 XL=PYLAMF(XMI2,XMA2,XMB2)
32387C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
32388 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
32389 & (CA**2+CB**2)-4D0*CA*CB*XMJ*XMF)
32390 IDLAM(LKNT,1)=KFNCHI(IX)
32391 IDLAM(LKNT,2)=IFL
32392 IDLAM(LKNT,3)=0
32393 ENDIF
32394 110 CONTINUE
32395
32396C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
32397C...IG=23,25,35,36
32398 DO 120 II=1,4
32399 IG=IGG(II)
32400 IF(ILR.EQ.1) GOTO 120
32401 XMB=PMAS(IG,1)
32402 XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1)
32403 IF(XMI.LT.XMSF1+XMB) GOTO 120
32404 IF(IG.EQ.23) THEN
32405 BL=-SIGN(.5D0,EI)/CW+EI*XW/CW
32406 BR=EI*XW/CW
32407 BLR=0D0
32408 ELSEIF(IG.EQ.25) THEN
32409 IF(IFL.EQ.5) THEN
32410 XMF=XMBOT
32411 ELSEIF(IFL.EQ.6) THEN
32412 XMF=XMTOP
32413 ELSEIF(IFL.LT.5) THEN
32414 XMF=0D0
32415 ELSE
32416 XMF=PMAS(IFL,1)
32417 ENDIF
32418 IF(IDU.EQ.2) THEN
32419 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
32420 & XMF**2/XMW*COSA/SBETA
32421 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
32422 & XMF**2/XMW*COSA/SBETA
32423 ELSE
32424 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
32425 & XMF**2/XMW*(-SINA)/CBETA
32426 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
32427 & XMF**2/XMW*(-SINA)/CBETA
32428 ENDIF
32429 IF(IFL.EQ.5) THEN
32430 AT=ATRIB
32431 ELSEIF(IFL.EQ.6) THEN
32432 AT=ATRIT
32433 ELSEIF(IFL.EQ.15) THEN
32434 AT=ATRIL
32435 ELSE
32436 AT=0D0
32437 ENDIF
32438 IF(IDU.EQ.2) THEN
32439 GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+
32440 & AT*COSA)
32441 ELSE
32442 GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA-
32443 & AT*SINA)
32444 ENDIF
32445 BL=GHLL
32446 BR=GHRR
32447 BLR=-GHLR
32448 ELSEIF(IG.EQ.35) THEN
32449 IF(IFL.EQ.5) THEN
32450 XMF=XMBOT
32451 ELSEIF(IFL.EQ.6) THEN
32452 XMF=XMTOP
32453 ELSEIF(IFL.LT.5) THEN
32454 XMF=0D0
32455 ELSE
32456 XMF=PMAS(IFL,1)
32457 ENDIF
32458 IF(IDU.EQ.2) THEN
32459 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
32460 & XMF**2/XMW*SINA/SBETA
32461 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
32462 & XMF**2/XMW*SINA/SBETA
32463 ELSE
32464 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
32465 & XMF**2/XMW*COSA/CBETA
32466 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
32467 & XMF**2/XMW*COSA/CBETA
32468 ENDIF
32469 IF(IFL.EQ.5) THEN
32470 AT=ATRIB
32471 ELSEIF(IFL.EQ.6) THEN
32472 AT=ATRIT
32473 ELSEIF(IFL.EQ.15) THEN
32474 AT=ATRIL
32475 ELSE
32476 AT=0D0
32477 ENDIF
32478 IF(IDU.EQ.2) THEN
32479 GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+
32480 & AT*SINA)
32481 ELSE
32482 GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+
32483 & AT*COSA)
32484 ENDIF
32485 BL=GHLL
32486 BR=GHRR
32487 BLR=GHLR
32488 ELSEIF(IG.EQ.36) THEN
32489 GHLL=0D0
32490 GHRR=0D0
32491 IF(IFL.EQ.5) THEN
32492 XMF=XMBOT
32493 ELSEIF(IFL.EQ.6) THEN
32494 XMF=XMTOP
32495 ELSEIF(IFL.LT.5) THEN
32496 XMF=0D0
32497 ELSE
32498 XMF=PMAS(IFL,1)
32499 ENDIF
32500 IF(IFL.EQ.5) THEN
32501 AT=ATRIB
32502 ELSEIF(IFL.EQ.6) THEN
32503 AT=ATRIT
32504 ELSEIF(IFL.EQ.15) THEN
32505 AT=ATRIL
32506 ELSE
32507 AT=0D0
32508 ENDIF
32509 IF(IDU.EQ.2) THEN
32510 GHLR=XMF/2D0/XMW*(-XMU+AT/TANB)
32511 ELSE
32512 GHLR=XMF/2D0/XMW/(-XMU+AT*TANB)
32513 ENDIF
32514 BL=GHLL
32515 BR=GHRR
32516 BLR=GHLR
32517 ENDIF
32518 AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+
32519 & SFMIX(IFL,2)*SFMIX(IFL,4)*BR+
32520 & (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR
32521 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
32522 LKNT=LKNT+1
32523 IF(IG.EQ.23) THEN
32524 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
32525 ELSE
32526 XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2
32527 ENDIF
32528 IDLAM(LKNT,3)=0
32529 IDLAM(LKNT,1)=KFIN-KSUSY1
32530 IDLAM(LKNT,2)=IG
32531 120 CONTINUE
32532
32533C...SF -> SF' + W
32534 XMB=PMAS(24,1)
32535 IF(MOD(IFL,2).EQ.0) THEN
32536 KF1=KSUSY1+IFL-1
32537 ELSE
32538 KF1=KSUSY1+IFL+1
32539 ENDIF
32540 KF2=KF1+KSUSY1
32541 XMSF1=PMAS(PYCOMP(KF1),1)
32542 XMSF2=PMAS(PYCOMP(KF2),1)
32543 IF(XMI.GT.XMB+XMSF1) THEN
32544 IF(MOD(IFL,2).EQ.0) THEN
32545 IF(ILR.EQ.1) THEN
32546 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1)
32547 ELSE
32548 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1)
32549 ENDIF
32550 ELSE
32551 IF(ILR.EQ.1) THEN
32552 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1)
32553 ELSE
32554 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1)
32555 ENDIF
32556 ENDIF
32557 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
32558 LKNT=LKNT+1
32559 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
32560 IDLAM(LKNT,3)=0
32561 IDLAM(LKNT,1)=KF1
32562 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
32563 ENDIF
32564 IF(XMI.GT.XMB+XMSF2) THEN
32565 IF(MOD(IFL,2).EQ.0) THEN
32566 IF(ILR.EQ.1) THEN
32567 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3)
32568 ELSE
32569 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3)
32570 ENDIF
32571 ELSE
32572 IF(ILR.EQ.1) THEN
32573 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3)
32574 ELSE
32575 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3)
32576 ENDIF
32577 ENDIF
32578 XL=PYLAMF(XMI2,XMSF2**2,XMB**2)
32579 LKNT=LKNT+1
32580 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
32581 IDLAM(LKNT,3)=0
32582 IDLAM(LKNT,1)=KF2
32583 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
32584 ENDIF
32585
32586C...SF -> SF' + HC
32587 XMB=PMAS(37,1)
32588 IF(MOD(IFL,2).EQ.0) THEN
32589 KF1=KSUSY1+IFL-1
32590 ELSE
32591 KF1=KSUSY1+IFL+1
32592 ENDIF
32593 KF2=KF1+KSUSY1
32594 XMSF1=PMAS(PYCOMP(KF1),1)
32595 XMSF2=PMAS(PYCOMP(KF2),1)
32596 IF(XMI.GT.XMB+XMSF1) THEN
32597 XMF=0D0
32598 XMFP=0D0
32599 AT=0D0
32600 AB=0D0
32601 IF(MOD(IFL,2).EQ.0) THEN
32602C...T1-> B1 HC
32603 IF(ILR.EQ.1) THEN
32604 CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1)
32605 CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2)
32606 CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2)
32607 CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1)
32608C...T2-> B1 HC
32609 ELSE
32610 CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1)
32611 CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2)
32612 CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2)
32613 CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1)
32614 ENDIF
32615 IF(IFL.EQ.6) THEN
32616 XMF=XMTOP
32617 XMFP=XMBOT
32618 AT=ATRIT
32619 AB=ATRIB
32620 ENDIF
32621 ELSE
32622C...B1 -> T1 HC
32623 IF(ILR.EQ.1) THEN
32624 CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1)
32625 CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2)
32626 CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2)
32627 CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1)
32628C...B2-> T1 HC
32629 ELSE
32630 CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1)
32631 CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2)
32632 CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1)
32633 CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2)
32634 ENDIF
32635 IF(IFL.EQ.5) THEN
32636 XMF=XMTOP
32637 XMFP=XMBOT
32638 AT=ATRIT
32639 AB=ATRIB
32640 ENDIF
32641 ENDIF
32642 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
32643 LKNT=LKNT+1
32644 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
32645 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
32646 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
32647 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
32648 IDLAM(LKNT,3)=0
32649 IDLAM(LKNT,1)=KF1
32650 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
32651 ENDIF
32652 IF(XMI.GT.XMB+XMSF2) THEN
32653 XMF=0D0
32654 XMFP=0D0
32655 AT=0D0
32656 AB=0D0
32657 IF(MOD(IFL,2).EQ.0) THEN
32658C...T1-> B2 HC
32659 IF(ILR.EQ.1) THEN
32660 CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1)
32661 CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2)
32662 CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1)
32663 CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2)
32664C...T2-> B2 HC
32665 ELSE
32666 CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3)
32667 CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4)
32668 CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4)
32669 CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3)
32670 ENDIF
32671 IF(IFL.EQ.6) THEN
32672 XMF=XMTOP
32673 XMFP=XMBOT
32674 AT=ATRIT
32675 AB=ATRIB
32676 ENDIF
32677 ELSE
32678C...B1 -> T2 HC
32679 IF(ILR.EQ.1) THEN
32680 CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1)
32681 CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2)
32682 CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2)
32683 CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1)
32684C...B2-> T2 HC
32685 ELSE
32686 CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3)
32687 CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4)
32688 CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4)
32689 CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3)
32690 ENDIF
32691 IF(IFL.EQ.5) THEN
32692 XMF=XMTOP
32693 XMFP=XMBOT
32694 AT=ATRIT
32695 AB=ATRIB
32696 ENDIF
32697 ENDIF
32698 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
32699 LKNT=LKNT+1
32700 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
32701 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
32702 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
32703 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
32704 IDLAM(LKNT,3)=0
32705 IDLAM(LKNT,1)=KF2
32706 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
32707 ENDIF
32708
32709C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
32710
32711 IF(IFL.LE.6) THEN
32712 XMFP=0D0
32713 XMF=0D0
32714 IF(IFL.EQ.6) XMF=PMAS(6,1)
32715 IF(IFL.EQ.5) XMF=PMAS(5,1)
32716 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
32717 AXMJ=ABS(XMJ)
32718 IF(XMI.GE.AXMJ+XMF) THEN
32719 AL=-SFMIX(IFL,3)
32720 BL=SFMIX(IFL,1)
32721 AR=-SFMIX(IFL,4)
32722 BR=SFMIX(IFL,2)
32723C...F1 -> F CHI
32724 IF(ILR.EQ.1) THEN
32725 CA=AL
32726 CB=BL
32727C...F2 -> F CHI
32728 ELSE
32729 CA=AR
32730 CB=BR
32731 ENDIF
32732 LKNT=LKNT+1
32733 XMA2=XMJ**2
32734 XMB2=XMF**2
32735 XL=PYLAMF(XMI2,XMA2,XMB2)
32736 XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
32737 & (CA**2+CB**2)+4D0*CA*CB*XMJ*XMF)
32738 IDLAM(LKNT,1)=KSUSY1+21
32739 IDLAM(LKNT,2)=IFL
32740 IDLAM(LKNT,3)=0
32741 ENDIF
32742 ENDIF
32743
32744C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
32745 IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT.
32746 &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN
32747C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
32748C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
32749C...M*M = C1**2 * G**2/(16PI**2)
32750C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
32751 LKNT=LKNT+1
32752 XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
32753 XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL)
32754 IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3
32755 IDLAM(LKNT,1)=KSUSY1+22
32756 IDLAM(LKNT,2)=4
32757 IDLAM(LKNT,3)=0
32758 ENDIF
32759
32760 IKNT=LKNT
32761 XLAM(0)=0D0
32762 DO 130 I=1,IKNT
32763 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
32764 XLAM(0)=XLAM(0)+XLAM(I)
32765 130 CONTINUE
32766 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3
32767
32768 RETURN
32769 END
32770
32771C*********************************************************************
32772
32773C...PYGLUI
32774C...Calculates gluino decay modes.
32775
32776 SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT)
32777
32778C...Double precision and integer declarations.
32779 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32780 IMPLICIT INTEGER(I-N)
32781 INTEGER PYK,PYCHGE,PYCOMP
32782C...Parameter statement to help give large particle numbers.
32783 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
32784C...Commonblocks.
32785 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32786 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32787 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
32788 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
32789 &SFMIX(16,4)
32790 COMMON/PYINTS/XXM(20)
32791 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTS/
32792
32793C...Local variables.
32794 INTEGER KFIN,KCIN,KF
32795 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
32796 &XMZ,XMZ2,AXMJ,AXMI
32797 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMA2,XMB2,XMFP
32798 DOUBLE PRECISION C1L,C1R,D1L,D1R
32799 DOUBLE PRECISION C2L,C2R,D2L,D2R
32800 DOUBLE PRECISION PYLAMF,XL
32801 DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
32802 DOUBLE PRECISION CA,CB,AL,AR,BL,BR
32803 DOUBLE PRECISION ALFA,BETA
32804 DOUBLE PRECISION SW,CW,SINB,COSB,QT,T3
32805 DOUBLE PRECISION XLAM(0:200)
32806 INTEGER IDLAM(200,3)
32807 INTEGER LKNT,IX,IC,ILR,IDU,J,IJ,I,IKNT,IFL
32808 DOUBLE PRECISION SR2
32809 DOUBLE PRECISION GAM
32810 DOUBLE PRECISION PYALEM,PI,PYALPS,EI
32811 EXTERNAL PYGAUS,PYXXZ5,PYXXW5,PYXXZ2
32812 DOUBLE PRECISION PYGAUS,PYXXZ5,PYXXW5,PYXXZ2
32813 DOUBLE PRECISION PREC
32814 INTEGER KFNCHI(4),KFCCHI(2)
32815 DATA PI/3.141592654D0/
32816 DATA SR2/1.4142136D0/
32817 DATA PREC/1D-2/
32818 DATA KFNCHI/1000022,1000023,1000025,1000035/
32819 DATA KFCCHI/1000024,1000037/
32820
32821C...COUNT THE NUMBER OF DECAY MODES
32822 LKNT=0
32823 IF(KFIN.NE.KSUSY1+21) RETURN
32824 KCIN=PYCOMP(KFIN)
32825
32826 XMW=PMAS(24,1)
32827 XMW2=XMW**2
32828 XMZ=PMAS(23,1)
32829 XMZ2=XMZ**2
32830 XW=PARU(102)
32831 TANW = SQRT(XW/(1D0-XW))
32832
32833 XMI=PMAS(KCIN,1)
32834 AXMI=ABS(XMI)
32835 XMI2=XMI**2
32836 AEM=PYALEM(XMI2)
32837 AS =PYALPS(XMI2)
32838 C1=AEM/XW
32839 XMI3=XMI**3
32840 BETA=ATAN(RMSS(5))
32841
32842C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
32843
32844 IF(IMSS(11).EQ.1) THEN
32845 XMP=RMSS(29)
32846 IDG=39+KSUSY1
32847 XMGR=PMAS(PYCOMP(IDG),1)
32848 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
32849 IF(AXMI.GT.XMGR) THEN
32850 LKNT=LKNT+1
32851 IDLAM(LKNT,1)=IDG
32852 IDLAM(LKNT,2)=21
32853 IDLAM(LKNT,3)=0
32854 XLAM(LKNT)=XFAC
32855 ENDIF
32856 ENDIF
32857
32858C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
32859
32860 DO 110 IFL=1,6
32861 DO 100 ILR=1,2
32862 XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1)
32863 AXMJ=ABS(XMJ)
32864 XMF=PMAS(IFL,1)
32865 IDU=3-(1+MOD(IFL,2))
32866 IF(XMI.GE.AXMJ+XMF) THEN
32867C...Minus sign difference from gluino-quark-squark feynman rules
32868 AL=SFMIX(IFL,1)
32869 BL=-SFMIX(IFL,3)
32870 AR=SFMIX(IFL,2)
32871 BR=-SFMIX(IFL,4)
32872C...F1 -> F CHI
32873 IF(ILR.EQ.1) THEN
32874 CA=AL
32875 CB=BL
32876C...F2 -> F CHI
32877 ELSE
32878 CA=AR
32879 CB=BR
32880 ENDIF
32881 LKNT=LKNT+1
32882 XMA2=XMJ**2
32883 XMB2=XMF**2
32884 XL=PYLAMF(XMI2,XMA2,XMB2)
32885 XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)*
32886 & (CA**2+CB**2)-4D0*CA*CB*XMI*XMF)
32887 IDLAM(LKNT,1)=ILR*KSUSY1+IFL
32888 IDLAM(LKNT,2)=-IFL
32889 IDLAM(LKNT,3)=0
32890 LKNT=LKNT+1
32891 XLAM(LKNT)=XLAM(LKNT-1)
32892 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
32893 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
32894 IDLAM(LKNT,3)=0
32895 ENDIF
32896 100 CONTINUE
32897 110 CONTINUE
32898
32899C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
32900C...GLUINO -> NI Q QBAR
32901 DO 160 IX=1,4
32902 XMJ=SMZ(IX)
32903 AXMJ=ABS(XMJ)
32904 IF(XMI.GE.AXMJ) THEN
32905 XXM(1)=0D0
32906 XXM(2)=XMJ
32907 XXM(3)=0D0
32908 XXM(4)=XMI
32909 XXM(5)=PMAS(PYCOMP(KSUSY1+1),1)
32910 XXM(6)=PMAS(PYCOMP(KSUSY2+1),1)
32911 XXM(7)=1D6
32912 XXM(8)=0D0
32913 XXM(9)=0D0
32914 XXM(10)=0D0
32915 S12MIN=0D0
32916 S12MAX=(XMI-AXMJ)**2
32917C...D-TYPE QUARKS
32918 XXM(11)=0D0
32919 XXM(12)=0D0
32920 XXM(13)=1D0
32921 XXM(14)=-SR2*(-0.5D0*ZMIX(IX,2)+TANW*ZMIX(IX,1)/6D0)
32922 XXM(15)=1D0
32923 XXM(16)=SR2*(-TANW*ZMIX(IX,1)/3D0)
32924 IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 120
32925 IF(XMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
32926 LKNT=LKNT+1
32927 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
32928 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-2)
32929 IDLAM(LKNT,1)=KFNCHI(IX)
32930 IDLAM(LKNT,2)=1
32931 IDLAM(LKNT,3)=-1
32932 ENDIF
32933 IF(XMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
32934 LKNT=LKNT+1
32935 XLAM(LKNT)=XLAM(LKNT-1)
32936 IDLAM(LKNT,1)=KFNCHI(IX)
32937 IDLAM(LKNT,2)=3
32938 IDLAM(LKNT,3)=-3
32939 ENDIF
32940 120 CONTINUE
32941 IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 130
32942 IF(XMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
32943 CALL PYTBBN(IX,80,-1D0/3D0,AXMI,GAM)
32944 LKNT=LKNT+1
32945 XLAM(LKNT)=GAM
32946 IDLAM(LKNT,1)=KFNCHI(IX)
32947 IDLAM(LKNT,2)=5
32948 IDLAM(LKNT,3)=-5
32949 ENDIF
32950C...U-TYPE QUARKS
32951 130 CONTINUE
32952 XXM(5)=PMAS(PYCOMP(KSUSY1+2),1)
32953 XXM(6)=PMAS(PYCOMP(KSUSY2+2),1)
32954 XXM(13)=1D0
32955 XXM(14)=-SR2*(0.5D0*ZMIX(IX,2)+TANW*ZMIX(IX,1)/6D0)
32956 XXM(15)=1D0
32957 XXM(16)=SR2*(2D0*TANW*ZMIX(IX,1)/3D0)
32958 IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 140
32959 IF(XMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
32960 LKNT=LKNT+1
32961 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
32962 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-2)
32963 IDLAM(LKNT,1)=KFNCHI(IX)
32964 IDLAM(LKNT,2)=2
32965 IDLAM(LKNT,3)=-2
32966 ENDIF
32967 IF(XMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
32968 LKNT=LKNT+1
32969 XLAM(LKNT)=XLAM(LKNT-1)
32970 IDLAM(LKNT,1)=KFNCHI(IX)
32971 IDLAM(LKNT,2)=4
32972 IDLAM(LKNT,3)=-4
32973 ENDIF
32974 140 CONTINUE
32975C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
32976C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
32977 IF(XMI.GE.PMAS(PYCOMP(KSUSY1+6),1)+PMAS(6,1)) GOTO 150
32978 XMF=PMAS(6,1)
32979 IF(XMI.GE.AXMJ+2D0*XMF) THEN
32980 CALL PYTBBN(IX,80,2D0/3D0,AXMI,GAM)
32981 LKNT=LKNT+1
32982 XLAM(LKNT)=GAM
32983 IDLAM(LKNT,1)=KFNCHI(IX)
32984 IDLAM(LKNT,2)=6
32985 IDLAM(LKNT,3)=-6
32986 ENDIF
32987 150 CONTINUE
32988 ENDIF
32989 160 CONTINUE
32990
32991C...GLUINO -> CI Q QBAR'
32992 DO 190 IX=1,2
32993 XMJ=SMW(IX)
32994 AXMJ=ABS(XMJ)
32995 IF(XMI.GE.AXMJ) THEN
32996 S12MIN=0D0
32997 S12MAX=(AXMI-AXMJ)**2
32998 XXM(1)=0D0
32999 XXM(2)=XMJ
33000 XXM(3)=0D0
33001 XXM(4)=XMI
33002 XXM(5)=0D0
33003 XXM(6)=0D0
33004 XXM(9)=1D6
33005 XXM(10)=0D0
33006 XXM(7)=UMIX(IX,1)*SR2
33007 XXM(8)=VMIX(IX,1)*SR2
33008 XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
33009 XXM(12)=PMAS(PYCOMP(KSUSY1+2),1)
33010 IF( XXM(11).LT.AXMI .OR. XXM(12).LT.AXMI ) GOTO 170
33011 IF(XMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
33012 LKNT=LKNT+1
33013 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
33014 & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
33015 IDLAM(LKNT,1)=KFCCHI(IX)
33016 IDLAM(LKNT,2)=1
33017 IDLAM(LKNT,3)=-2
33018 LKNT=LKNT+1
33019 XLAM(LKNT)=XLAM(LKNT-1)
33020 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
33021 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
33022 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
33023 ENDIF
33024 IF(XMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
33025 LKNT=LKNT+1
33026 XLAM(LKNT)=XLAM(LKNT-1)
33027 IDLAM(LKNT,1)=KFCCHI(IX)
33028 IDLAM(LKNT,2)=3
33029 IDLAM(LKNT,3)=-4
33030 LKNT=LKNT+1
33031 XLAM(LKNT)=XLAM(LKNT-1)
33032 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
33033 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
33034 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
33035 ENDIF
33036 170 CONTINUE
33037
33038 IF(XMI.GE.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) GOTO 180
33039 IF(XMI.GE.PMAS(PYCOMP(KSUSY1+6),1)+PMAS(6,1)) GOTO 180
33040 XMF=PMAS(6,1)
33041 XMFP=PMAS(5,1)
33042 IF(XMI.GE.AXMJ+XMF+XMFP) THEN
33043 CALL PYTBBC(IX,80,AXMI,GAM)
33044 LKNT=LKNT+1
33045 XLAM(LKNT)=GAM
33046 IDLAM(LKNT,1)=KFCCHI(IX)
33047 IDLAM(LKNT,2)=5
33048 IDLAM(LKNT,3)=-6
33049 LKNT=LKNT+1
33050 XLAM(LKNT)=XLAM(LKNT-1)
33051 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
33052 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
33053 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
33054 ENDIF
33055 180 CONTINUE
33056 ENDIF
33057 190 CONTINUE
33058
33059 IKNT=LKNT
33060 XLAM(0)=0D0
33061 DO 200 I=1,IKNT
33062 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
33063 XLAM(0)=XLAM(0)+XLAM(I)
33064 200 CONTINUE
33065 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
33066
33067 RETURN
33068 END
33069
33070C*********************************************************************
33071
33072C...PYTECM
33073C...Finds the s-hat dependent eigenvalues of the inverse propagator
33074C...matrix for gamma, Z, technirho, and techniomega to optimize the
33075C...phase space generation.
33076
33077 SUBROUTINE PYTECM(S1,S2)
33078
33079C...Double precision and integer declarations.
33080 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33081 IMPLICIT INTEGER(I-N)
33082 INTEGER PYK,PYCHGE,PYCOMP
33083C...Parameter statement to help give large particle numbers.
33084 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
33085C...Commonblocks.
33086 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33087 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33088 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
33089 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/
33090
33091C...Local variables.
33092 DOUBLE PRECISION AR(4,4),WR(4),ZR(4,4),ZI(4,4),WORK(12,12),
33093 &AT(4,4),WI(4),FV1(4),FV2(4),FV3(4),sh,aem,tanw,ct2w,qupd,alprht,
33094 &far,fao,fzr,fzo,shr,R1,R2,S1,S2,WDTP(0:200),WDTE(0:200,0:5)
33095 INTEGER i,j,ierr
33096
33097 SH=PMAS(54,1)**2
33098 AEM=PYALEM(SH)
33099
33100 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
33101 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
33102 QUPD=2D0*PARP(143)-1D0
33103
33104 ALPRHT=2.91D0*(3D0/PARP(144))
33105 FAR=SQRT(AEM/ALPRHT)
33106 FAO=FAR*QUPD
33107 FZR=FAR*CT2W
33108 FZO=-FAO*TANW
33109
33110 AR(1,1) = SH
33111 AR(2,2) = SH-PMAS(23,1)**2
33112 AR(3,3) = SH-PMAS(54,1)**2
33113 AR(4,4) = SH-PMAS(56,1)**2
33114 AR(1,2) = 0D0
33115 AR(2,1) = 0D0
33116 AR(1,3) = -SH*FAR
33117 AR(3,1) = AR(1,3)
33118 AR(1,4) = -SH*FAO
33119 AR(4,1) = AR(1,4)
33120 AR(2,3) = -SH*FZR
33121 AR(3,2) = AR(2,3)
33122 AR(2,4) = -SH*FZO
33123 AR(4,2) = AR(2,4)
33124 AR(3,4) = 0D0
33125 AR(4,3) = 0D0
33126CCCCCCCC
33127 DO 110 I=1,4
33128 DO 100 J=1,4
33129 AT(I,J)=0D0
33130 100 CONTINUE
33131 110 CONTINUE
33132 SHR=SQRT(SH)
33133 CALL PYWIDT(23,SH,WDTP,WDTE)
33134 AT(2,2) = WDTP(0)*SHR
33135 CALL PYWIDT(54,SH,WDTP,WDTE)
33136 AT(3,3) = WDTP(0)*SHR
33137 CALL PYWIDT(56,SH,WDTP,WDTE)
33138 AT(4,4) = WDTP(0)*SHR
33139CCCC
33140 CALL PYEICG(4,4,AR,AT,WR,WI,0,ZR,ZI,FV1,FV2,FV3,IERR)
33141 DO 120 I=1,4
33142 WI(I)=SQRT(ABS(SH-WR(I)))
33143 WR(I)=ABS(WR(I))
33144 120 CONTINUE
33145 R1=MIN(WR(1),WR(2),WR(3),WR(4))
33146 R2=1D20
33147 S1=0D0
33148 S2=0D0
33149 DO 130 I=1,4
33150 IF(ABS(WR(I)-R1).LT.1D-6) THEN
33151 S1=WI(I)
33152 GOTO 130
33153 ENDIF
33154 IF(WR(I).LE.R2) THEN
33155 R2=WR(I)
33156 S2=WI(I)
33157 ENDIF
33158 130 CONTINUE
33159 S1=S1**2
33160 S2=S2**2
33161 RETURN
33162 END
33163
33164
33165
33166C*********************************************************************
33167
33168C...PYEIGC
33169C...Finds eigenvalues of a general complex matrix
33170
33171 SUBROUTINE PYEICG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
33172C
33173 INTEGER N,NM,IS1,IS2,IERR,MATZ
33174 DOUBLE PRECISION AR(NM,N),AI(NM,N),WR(N),WI(N),ZR(NM,N),ZI(NM,N),
33175 X FV1(N),FV2(N),FV3(N)
33176C
33177C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
33178C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
33179C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
33180C OF A COMPLEX GENERAL MATRIX.
33181C
33182C ON INPUT
33183C
33184C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
33185C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
33186C DIMENSION STATEMENT.
33187C
33188C N IS THE ORDER OF THE MATRIX A=(AR,AI).
33189C
33190C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
33191C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
33192C
33193C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
33194C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
33195C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
33196C
33197C ON OUTPUT
33198C
33199C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
33200C RESPECTIVELY, OF THE EIGENVALUES.
33201C
33202C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
33203C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
33204C
33205C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
33206C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
33207C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO.
33208C
33209C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS.
33210C
33211C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
33212C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
33213C
33214C THIS VERSION DATED AUGUST 1983.
33215C
33216C ------------------------------------------------------------------
33217C
33218 IF (N .LE. NM) GO TO 10
33219 IERR = 10 * N
33220 GO TO 50
33221C
33222 10 CALL CBAL(NM,N,AR,AI,IS1,IS2,FV1)
33223 CALL CORTH(NM,N,IS1,IS2,AR,AI,FV2,FV3)
33224 IF (MATZ .NE. 0) GO TO 20
33225C .......... FIND EIGENVALUES ONLY ..........
33226 CALL COMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR)
33227 GO TO 50
33228C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
33229 20 CALL COMQR2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR)
33230 IF (IERR .NE. 0) GO TO 50
33231 CALL CBABK2(NM,N,IS1,IS2,FV1,N,ZR,ZI)
33232 50 RETURN
33233 END
33234 SUBROUTINE CBABK2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
33235C
33236 INTEGER I,J,K,M,N,II,NM,IGH,LOW
33237 DOUBLE PRECISION SCALE(N),ZR(NM,M),ZI(NM,M)
33238 DOUBLE PRECISION S
33239C
33240C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
33241C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
33242C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
33243C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
33244C
33245C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
33246C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
33247C BALANCED MATRIX DETERMINED BY CBAL.
33248C
33249C ON INPUT
33250C
33251C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
33252C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
33253C DIMENSION STATEMENT.
33254C
33255C N IS THE ORDER OF THE MATRIX.
33256C
33257C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL.
33258C
33259C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
33260C AND SCALING FACTORS USED BY CBAL.
33261C
33262C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
33263C
33264C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
33265C RESPECTIVELY, OF THE EIGENVECTORS TO BE
33266C BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
33267C
33268C ON OUTPUT
33269C
33270C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
33271C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
33272C IN THEIR FIRST M COLUMNS.
33273C
33274C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
33275C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
33276C
33277C THIS VERSION DATED AUGUST 1983.
33278C
33279C ------------------------------------------------------------------
33280C
33281 IF (M .EQ. 0) GO TO 200
33282 IF (IGH .EQ. LOW) GO TO 120
33283C
33284 DO 110 I = LOW, IGH
33285 S = SCALE(I)
33286C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
33287C IF THE FOREGOING STATEMENT IS REPLACED BY
33288C S=1.0D0/SCALE(I). ..........
33289 DO 100 J = 1, M
33290 ZR(I,J) = ZR(I,J) * S
33291 ZI(I,J) = ZI(I,J) * S
33292 100 CONTINUE
33293C
33294 110 CONTINUE
33295C .......... FOR I=LOW-1 STEP -1 UNTIL 1,
33296C IGH+1 STEP 1 UNTIL N DO -- ..........
33297 120 DO 140 II = 1, N
33298 I = II
33299 IF (I .GE. LOW .AND. I .LE. IGH) GO TO 140
33300 IF (I .LT. LOW) I = LOW - II
33301 K = SCALE(I)
33302 IF (K .EQ. I) GO TO 140
33303C
33304 DO 130 J = 1, M
33305 S = ZR(I,J)
33306 ZR(I,J) = ZR(K,J)
33307 ZR(K,J) = S
33308 S = ZI(I,J)
33309 ZI(I,J) = ZI(K,J)
33310 ZI(K,J) = S
33311 130 CONTINUE
33312C
33313 140 CONTINUE
33314C
33315 200 RETURN
33316 END
33317 SUBROUTINE CBAL(NM,N,AR,AI,LOW,IGH,SCALE)
33318C
33319 INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
33320 DOUBLE PRECISION AR(NM,N),AI(NM,N),SCALE(N)
33321 DOUBLE PRECISION C,F,G,R,S,B2,RADIX
33322 LOGICAL NOCONV
33323C
33324C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
33325C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
33326C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
33327C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
33328C
33329C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
33330C EIGENVALUES WHENEVER POSSIBLE.
33331C
33332C ON INPUT
33333C
33334C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
33335C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
33336C DIMENSION STATEMENT.
33337C
33338C N IS THE ORDER OF THE MATRIX.
33339C
33340C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
33341C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
33342C
33343C ON OUTPUT
33344C
33345C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
33346C RESPECTIVELY, OF THE BALANCED MATRIX.
33347C
33348C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
33349C ARE EQUAL TO ZERO IF
33350C (1) I IS GREATER THAN J AND
33351C (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
33352C
33353C SCALE CONTAINS INFORMATION DETERMINING THE
33354C PERMUTATIONS AND SCALING FACTORS USED.
33355C
33356C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
33357C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
33358C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
33359C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN
33360C SCALE(J) = P(J), FOR J = 1,...,LOW-1
33361C = D(J,J) J = LOW,...,IGH
33362C = P(J) J = IGH+1,...,N.
33363C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
33364C THEN 1 TO LOW-1.
33365C
33366C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
33367C
33368C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
33369C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
33370C K,L HAVE BEEN REVERSED.)
33371C
33372C ARITHMETIC IS REAL THROUGHOUT.
33373C
33374C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
33375C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
33376C
33377C THIS VERSION DATED AUGUST 1983.
33378C
33379C ------------------------------------------------------------------
33380C
33381 RADIX = 16.0D0
33382C
33383 B2 = RADIX * RADIX
33384 K = 1
33385 L = N
33386 GO TO 100
33387C .......... IN-LINE PROCEDURE FOR ROW AND
33388C COLUMN EXCHANGE ..........
33389 20 SCALE(M) = J
33390 IF (J .EQ. M) GO TO 50
33391C
33392 DO 30 I = 1, L
33393 F = AR(I,J)
33394 AR(I,J) = AR(I,M)
33395 AR(I,M) = F
33396 F = AI(I,J)
33397 AI(I,J) = AI(I,M)
33398 AI(I,M) = F
33399 30 CONTINUE
33400C
33401 DO 40 I = K, N
33402 F = AR(J,I)
33403 AR(J,I) = AR(M,I)
33404 AR(M,I) = F
33405 F = AI(J,I)
33406 AI(J,I) = AI(M,I)
33407 AI(M,I) = F
33408 40 CONTINUE
33409C
33410 50 GO TO (80,130), IEXC
33411C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
33412C AND PUSH THEM DOWN ..........
33413 80 IF (L .EQ. 1) GO TO 280
33414 L = L - 1
33415C .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
33416 100 DO 120 JJ = 1, L
33417 J = L + 1 - JJ
33418C
33419 DO 110 I = 1, L
33420 IF (I .EQ. J) GO TO 110
33421 IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GO TO 120
33422 110 CONTINUE
33423C
33424 M = L
33425 IEXC = 1
33426 GO TO 20
33427 120 CONTINUE
33428C
33429 GO TO 140
33430C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
33431C AND PUSH THEM LEFT ..........
33432 130 K = K + 1
33433C
33434 140 DO 170 J = K, L
33435C
33436 DO 150 I = K, L
33437 IF (I .EQ. J) GO TO 150
33438 IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GO TO 170
33439 150 CONTINUE
33440C
33441 M = K
33442 IEXC = 2
33443 GO TO 20
33444 170 CONTINUE
33445C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
33446 DO 180 I = K, L
33447 180 SCALE(I) = 1.0D0
33448C .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
33449 190 NOCONV = .FALSE.
33450C
33451 DO 270 I = K, L
33452 C = 0.0D0
33453 R = 0.0D0
33454C
33455 DO 200 J = K, L
33456 IF (J .EQ. I) GO TO 200
33457 C = C + DABS(AR(J,I)) + DABS(AI(J,I))
33458 R = R + DABS(AR(I,J)) + DABS(AI(I,J))
33459 200 CONTINUE
33460C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
33461 IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GO TO 270
33462 G = R / RADIX
33463 F = 1.0D0
33464 S = C + R
33465 210 IF (C .GE. G) GO TO 220
33466 F = F * RADIX
33467 C = C * B2
33468 GO TO 210
33469 220 G = R * RADIX
33470 230 IF (C .LT. G) GO TO 240
33471 F = F / RADIX
33472 C = C / B2
33473 GO TO 230
33474C .......... NOW BALANCE ..........
33475 240 IF ((C + R) / F .GE. 0.95D0 * S) GO TO 270
33476 G = 1.0D0 / F
33477 SCALE(I) = SCALE(I) * F
33478 NOCONV = .TRUE.
33479C
33480 DO 250 J = K, N
33481 AR(I,J) = AR(I,J) * G
33482 AI(I,J) = AI(I,J) * G
33483 250 CONTINUE
33484C
33485 DO 260 J = 1, L
33486 AR(J,I) = AR(J,I) * F
33487 AI(J,I) = AI(J,I) * F
33488 260 CONTINUE
33489C
33490 270 CONTINUE
33491C
33492 IF (NOCONV) GO TO 190
33493C
33494 280 LOW = K
33495 IGH = L
33496 RETURN
33497 END
33498 SUBROUTINE CDIV(AR,AI,BR,BI,CR,CI)
33499 DOUBLE PRECISION AR,AI,BR,BI,CR,CI
33500C
33501C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
33502C
33503 DOUBLE PRECISION S,ARS,AIS,BRS,BIS
33504 S = DABS(BR) + DABS(BI)
33505 ARS = AR/S
33506 AIS = AI/S
33507 BRS = BR/S
33508 BIS = BI/S
33509 S = BRS**2 + BIS**2
33510 CR = (ARS*BRS + AIS*BIS)/S
33511 CI = (AIS*BRS - ARS*BIS)/S
33512 RETURN
33513 END
33514 SUBROUTINE COMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
33515C
33516 INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
33517 DOUBLE PRECISION HR(NM,N),HI(NM,N),WR(N),WI(N)
33518 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
33519 X PYTHAG
33520C
33521C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
33522C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
33523C AND WILKINSON.
33524C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
33525C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
33526C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
33527C
33528C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
33529C UPPER HESSENBERG MATRIX BY THE QR METHOD.
33530C
33531C ON INPUT
33532C
33533C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
33534C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
33535C DIMENSION STATEMENT.
33536C
33537C N IS THE ORDER OF THE MATRIX.
33538C
33539C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
33540C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
33541C SET LOW=1, IGH=N.
33542C
33543C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
33544C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
33545C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
33546C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
33547C THE REDUCTION BY CORTH, IF PERFORMED.
33548C
33549C ON OUTPUT
33550C
33551C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
33552C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE
33553C CALLING COMQR IF SUBSEQUENT CALCULATION OF
33554C EIGENVECTORS IS TO BE PERFORMED.
33555C
33556C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
33557C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
33558C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
33559C FOR INDICES IERR+1,...,N.
33560C
33561C IERR IS SET TO
33562C ZERO FOR NORMAL RETURN,
33563C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
33564C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
33565C
33566C CALLS CDIV FOR COMPLEX DIVISION.
33567C CALLS CSROOT FOR COMPLEX SQUARE ROOT.
33568C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
33569C
33570C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
33571C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
33572C
33573C THIS VERSION DATED AUGUST 1983.
33574C
33575C ------------------------------------------------------------------
33576C
33577 IERR = 0
33578 IF (LOW .EQ. IGH) GO TO 180
33579C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
33580 L = LOW + 1
33581C
33582 DO 170 I = L, IGH
33583 LL = MIN0(I+1,IGH)
33584 IF (HI(I,I-1) .EQ. 0.0D0) GO TO 170
33585 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
33586 YR = HR(I,I-1) / NORM
33587 YI = HI(I,I-1) / NORM
33588 HR(I,I-1) = NORM
33589 HI(I,I-1) = 0.0D0
33590C
33591 DO 155 J = I, IGH
33592 SI = YR * HI(I,J) - YI * HR(I,J)
33593 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
33594 HI(I,J) = SI
33595 155 CONTINUE
33596C
33597 DO 160 J = LOW, LL
33598 SI = YR * HI(J,I) + YI * HR(J,I)
33599 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
33600 HI(J,I) = SI
33601 160 CONTINUE
33602C
33603 170 CONTINUE
33604C .......... STORE ROOTS ISOLATED BY CBAL ..........
33605 180 DO 200 I = 1, N
33606 IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200
33607 WR(I) = HR(I,I)
33608 WI(I) = HI(I,I)
33609 200 CONTINUE
33610C
33611 EN = IGH
33612 TR = 0.0D0
33613 TI = 0.0D0
33614 ITN = 30*N
33615C .......... SEARCH FOR NEXT EIGENVALUE ..........
33616 220 IF (EN .LT. LOW) GO TO 1001
33617 ITS = 0
33618 ENM1 = EN - 1
33619C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
33620C FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
33621 240 DO 260 LL = LOW, EN
33622 L = EN + LOW - LL
33623 IF (L .EQ. LOW) GO TO 300
33624 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
33625 X + DABS(HR(L,L)) + DABS(HI(L,L))
33626 TST2 = TST1 + DABS(HR(L,L-1))
33627 IF (TST2 .EQ. TST1) GO TO 300
33628 260 CONTINUE
33629C .......... FORM SHIFT ..........
33630 300 IF (L .EQ. EN) GO TO 660
33631 IF (ITN .EQ. 0) GO TO 1000
33632 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320
33633 SR = HR(EN,EN)
33634 SI = HI(EN,EN)
33635 XR = HR(ENM1,EN) * HR(EN,ENM1)
33636 XI = HI(ENM1,EN) * HR(EN,ENM1)
33637 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GO TO 340
33638 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
33639 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
33640 CALL CSROOT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
33641 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GO TO 310
33642 ZZR = -ZZR
33643 ZZI = -ZZI
33644 310 CALL CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
33645 SR = SR - XR
33646 SI = SI - XI
33647 GO TO 340
33648C .......... FORM EXCEPTIONAL SHIFT ..........
33649 320 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
33650 SI = 0.0D0
33651C
33652 340 DO 360 I = LOW, EN
33653 HR(I,I) = HR(I,I) - SR
33654 HI(I,I) = HI(I,I) - SI
33655 360 CONTINUE
33656C
33657 TR = TR + SR
33658 TI = TI + SI
33659 ITS = ITS + 1
33660 ITN = ITN - 1
33661C .......... REDUCE TO TRIANGLE (ROWS) ..........
33662 LP1 = L + 1
33663C
33664 DO 500 I = LP1, EN
33665 SR = HR(I,I-1)
33666 HR(I,I-1) = 0.0D0
33667 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
33668 XR = HR(I-1,I-1) / NORM
33669 WR(I-1) = XR
33670 XI = HI(I-1,I-1) / NORM
33671 WI(I-1) = XI
33672 HR(I-1,I-1) = NORM
33673 HI(I-1,I-1) = 0.0D0
33674 HI(I,I-1) = SR / NORM
33675C
33676 DO 490 J = I, EN
33677 YR = HR(I-1,J)
33678 YI = HI(I-1,J)
33679 ZZR = HR(I,J)
33680 ZZI = HI(I,J)
33681 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
33682 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
33683 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
33684 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
33685 490 CONTINUE
33686C
33687 500 CONTINUE
33688C
33689 SI = HI(EN,EN)
33690 IF (SI .EQ. 0.0D0) GO TO 540
33691 NORM = PYTHAG(HR(EN,EN),SI)
33692 SR = HR(EN,EN) / NORM
33693 SI = SI / NORM
33694 HR(EN,EN) = NORM
33695 HI(EN,EN) = 0.0D0
33696C .......... INVERSE OPERATION (COLUMNS) ..........
33697 540 DO 600 J = LP1, EN
33698 XR = WR(J-1)
33699 XI = WI(J-1)
33700C
33701 DO 580 I = L, J
33702 YR = HR(I,J-1)
33703 YI = 0.0D0
33704 ZZR = HR(I,J)
33705 ZZI = HI(I,J)
33706 IF (I .EQ. J) GO TO 560
33707 YI = HI(I,J-1)
33708 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
33709 560 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
33710 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
33711 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
33712 580 CONTINUE
33713C
33714 600 CONTINUE
33715C
33716 IF (SI .EQ. 0.0D0) GO TO 240
33717C
33718 DO 630 I = L, EN
33719 YR = HR(I,EN)
33720 YI = HI(I,EN)
33721 HR(I,EN) = SR * YR - SI * YI
33722 HI(I,EN) = SR * YI + SI * YR
33723 630 CONTINUE
33724C
33725 GO TO 240
33726C .......... A ROOT FOUND ..........
33727 660 WR(EN) = HR(EN,EN) + TR
33728 WI(EN) = HI(EN,EN) + TI
33729 EN = ENM1
33730 GO TO 220
33731C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
33732C CONVERGED AFTER 30*N ITERATIONS ..........
33733 1000 IERR = EN
33734 1001 RETURN
33735 END
33736 SUBROUTINE COMQR2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
33737C MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG)
33738C MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG)
33739C
33740 INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
33741 X ITN,ITS,LOW,LP1,ENM1,IEND,IERR
33742 DOUBLE PRECISION HR(NM,N),HI(NM,N),WR(N),WI(N),ZR(NM,N),ZI(NM,N),
33743 X ORTR(IGH),ORTI(IGH)
33744 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
33745 X PYTHAG
33746C
33747C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
33748C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
33749C AND WILKINSON.
33750C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
33751C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
33752C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
33753C
33754C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
33755C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
33756C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
33757C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE
33758C THIS GENERAL MATRIX TO HESSENBERG FORM.
33759C
33760C ON INPUT
33761C
33762C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
33763C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
33764C DIMENSION STATEMENT.
33765C
33766C N IS THE ORDER OF THE MATRIX.
33767C
33768C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
33769C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
33770C SET LOW=1, IGH=N.
33771C
33772C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
33773C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED.
33774C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS
33775C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
33776C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
33777C
33778C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
33779C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
33780C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
33781C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
33782C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF
33783C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
33784C ARBITRARY.
33785C
33786C ON OUTPUT
33787C
33788C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
33789C HAVE BEEN DESTROYED.
33790C
33791C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
33792C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
33793C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
33794C FOR INDICES IERR+1,...,N.
33795C
33796C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
33797C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS
33798C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF
33799C THE EIGENVECTORS HAS BEEN FOUND.
33800C
33801C IERR IS SET TO
33802C ZERO FOR NORMAL RETURN,
33803C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
33804C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
33805C
33806C CALLS CDIV FOR COMPLEX DIVISION.
33807C CALLS CSROOT FOR COMPLEX SQUARE ROOT.
33808C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
33809C
33810C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
33811C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
33812C
33813C THIS VERSION DATED OCTOBER 1989.
33814C
33815C ------------------------------------------------------------------
33816C
33817 IERR = 0
33818C .......... INITIALIZE EIGENVECTOR MATRIX ..........
33819 DO 101 J = 1, N
33820C
33821 DO 100 I = 1, N
33822 ZR(I,J) = 0.0D0
33823 ZI(I,J) = 0.0D0
33824 100 CONTINUE
33825 ZR(J,J) = 1.0D0
33826 101 CONTINUE
33827C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
33828C FROM THE INFORMATION LEFT BY CORTH ..........
33829 IEND = IGH - LOW - 1
33830 IF (IEND) 180, 150, 105
33831C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
33832 105 DO 140 II = 1, IEND
33833 I = IGH - II
33834 IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GO TO 140
33835 IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GO TO 140
33836C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
33837 NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I)
33838 IP1 = I + 1
33839C
33840 DO 110 K = IP1, IGH
33841 ORTR(K) = HR(K,I-1)
33842 ORTI(K) = HI(K,I-1)
33843 110 CONTINUE
33844C
33845 DO 130 J = I, IGH
33846 SR = 0.0D0
33847 SI = 0.0D0
33848C
33849 DO 115 K = I, IGH
33850 SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J)
33851 SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J)
33852 115 CONTINUE
33853C
33854 SR = SR / NORM
33855 SI = SI / NORM
33856C
33857 DO 120 K = I, IGH
33858 ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K)
33859 ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K)
33860 120 CONTINUE
33861C
33862 130 CONTINUE
33863C
33864 140 CONTINUE
33865C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
33866 150 L = LOW + 1
33867C
33868 DO 170 I = L, IGH
33869 LL = MIN0(I+1,IGH)
33870 IF (HI(I,I-1) .EQ. 0.0D0) GO TO 170
33871 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
33872 YR = HR(I,I-1) / NORM
33873 YI = HI(I,I-1) / NORM
33874 HR(I,I-1) = NORM
33875 HI(I,I-1) = 0.0D0
33876C
33877 DO 155 J = I, N
33878 SI = YR * HI(I,J) - YI * HR(I,J)
33879 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
33880 HI(I,J) = SI
33881 155 CONTINUE
33882C
33883 DO 160 J = 1, LL
33884 SI = YR * HI(J,I) + YI * HR(J,I)
33885 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
33886 HI(J,I) = SI
33887 160 CONTINUE
33888C
33889 DO 165 J = LOW, IGH
33890 SI = YR * ZI(J,I) + YI * ZR(J,I)
33891 ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I)
33892 ZI(J,I) = SI
33893 165 CONTINUE
33894C
33895 170 CONTINUE
33896C .......... STORE ROOTS ISOLATED BY CBAL ..........
33897 180 DO 200 I = 1, N
33898 IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200
33899 WR(I) = HR(I,I)
33900 WI(I) = HI(I,I)
33901 200 CONTINUE
33902C
33903 EN = IGH
33904 TR = 0.0D0
33905 TI = 0.0D0
33906 ITN = 30*N
33907C .......... SEARCH FOR NEXT EIGENVALUE ..........
33908 220 IF (EN .LT. LOW) GO TO 680
33909 ITS = 0
33910 ENM1 = EN - 1
33911C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
33912C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
33913 240 DO 260 LL = LOW, EN
33914 L = EN + LOW - LL
33915 IF (L .EQ. LOW) GO TO 300
33916 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
33917 X + DABS(HR(L,L)) + DABS(HI(L,L))
33918 TST2 = TST1 + DABS(HR(L,L-1))
33919 IF (TST2 .EQ. TST1) GO TO 300
33920 260 CONTINUE
33921C .......... FORM SHIFT ..........
33922 300 IF (L .EQ. EN) GO TO 660
33923 IF (ITN .EQ. 0) GO TO 1000
33924 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320
33925 SR = HR(EN,EN)
33926 SI = HI(EN,EN)
33927 XR = HR(ENM1,EN) * HR(EN,ENM1)
33928 XI = HI(ENM1,EN) * HR(EN,ENM1)
33929 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GO TO 340
33930 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
33931 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
33932 CALL CSROOT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
33933 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GO TO 310
33934 ZZR = -ZZR
33935 ZZI = -ZZI
33936 310 CALL CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
33937 SR = SR - XR
33938 SI = SI - XI
33939 GO TO 340
33940C .......... FORM EXCEPTIONAL SHIFT ..........
33941 320 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
33942 SI = 0.0D0
33943C
33944 340 DO 360 I = LOW, EN
33945 HR(I,I) = HR(I,I) - SR
33946 HI(I,I) = HI(I,I) - SI
33947 360 CONTINUE
33948C
33949 TR = TR + SR
33950 TI = TI + SI
33951 ITS = ITS + 1
33952 ITN = ITN - 1
33953C .......... REDUCE TO TRIANGLE (ROWS) ..........
33954 LP1 = L + 1
33955C
33956 DO 500 I = LP1, EN
33957 SR = HR(I,I-1)
33958 HR(I,I-1) = 0.0D0
33959 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
33960 XR = HR(I-1,I-1) / NORM
33961 WR(I-1) = XR
33962 XI = HI(I-1,I-1) / NORM
33963 WI(I-1) = XI
33964 HR(I-1,I-1) = NORM
33965 HI(I-1,I-1) = 0.0D0
33966 HI(I,I-1) = SR / NORM
33967C
33968 DO 490 J = I, N
33969 YR = HR(I-1,J)
33970 YI = HI(I-1,J)
33971 ZZR = HR(I,J)
33972 ZZI = HI(I,J)
33973 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
33974 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
33975 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
33976 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
33977 490 CONTINUE
33978C
33979 500 CONTINUE
33980C
33981 SI = HI(EN,EN)
33982 IF (SI .EQ. 0.0D0) GO TO 540
33983 NORM = PYTHAG(HR(EN,EN),SI)
33984 SR = HR(EN,EN) / NORM
33985 SI = SI / NORM
33986 HR(EN,EN) = NORM
33987 HI(EN,EN) = 0.0D0
33988 IF (EN .EQ. N) GO TO 540
33989 IP1 = EN + 1
33990C
33991 DO 520 J = IP1, N
33992 YR = HR(EN,J)
33993 YI = HI(EN,J)
33994 HR(EN,J) = SR * YR + SI * YI
33995 HI(EN,J) = SR * YI - SI * YR
33996 520 CONTINUE
33997C .......... INVERSE OPERATION (COLUMNS) ..........
33998 540 DO 600 J = LP1, EN
33999 XR = WR(J-1)
34000 XI = WI(J-1)
34001C
34002 DO 580 I = 1, J
34003 YR = HR(I,J-1)
34004 YI = 0.0D0
34005 ZZR = HR(I,J)
34006 ZZI = HI(I,J)
34007 IF (I .EQ. J) GO TO 560
34008 YI = HI(I,J-1)
34009 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
34010 560 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
34011 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
34012 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
34013 580 CONTINUE
34014C
34015 DO 590 I = LOW, IGH
34016 YR = ZR(I,J-1)
34017 YI = ZI(I,J-1)
34018 ZZR = ZR(I,J)
34019 ZZI = ZI(I,J)
34020 ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
34021 ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
34022 ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
34023 ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
34024 590 CONTINUE
34025C
34026 600 CONTINUE
34027C
34028 IF (SI .EQ. 0.0D0) GO TO 240
34029C
34030 DO 630 I = 1, EN
34031 YR = HR(I,EN)
34032 YI = HI(I,EN)
34033 HR(I,EN) = SR * YR - SI * YI
34034 HI(I,EN) = SR * YI + SI * YR
34035 630 CONTINUE
34036C
34037 DO 640 I = LOW, IGH
34038 YR = ZR(I,EN)
34039 YI = ZI(I,EN)
34040 ZR(I,EN) = SR * YR - SI * YI
34041 ZI(I,EN) = SR * YI + SI * YR
34042 640 CONTINUE
34043C
34044 GO TO 240
34045C .......... A ROOT FOUND ..........
34046 660 HR(EN,EN) = HR(EN,EN) + TR
34047 WR(EN) = HR(EN,EN)
34048 HI(EN,EN) = HI(EN,EN) + TI
34049 WI(EN) = HI(EN,EN)
34050 EN = ENM1
34051 GO TO 220
34052C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
34053C VECTORS OF UPPER TRIANGULAR FORM ..........
34054 680 NORM = 0.0D0
34055C
34056 DO 720 I = 1, N
34057C
34058 DO 720 J = I, N
34059 TR = DABS(HR(I,J)) + DABS(HI(I,J))
34060 IF (TR .GT. NORM) NORM = TR
34061 720 CONTINUE
34062C
34063 IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GO TO 1001
34064C .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
34065 DO 800 NN = 2, N
34066 EN = N + 2 - NN
34067 XR = WR(EN)
34068 XI = WI(EN)
34069 HR(EN,EN) = 1.0D0
34070 HI(EN,EN) = 0.0D0
34071 ENM1 = EN - 1
34072C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
34073 DO 780 II = 1, ENM1
34074 I = EN - II
34075 ZZR = 0.0D0
34076 ZZI = 0.0D0
34077 IP1 = I + 1
34078C
34079 DO 740 J = IP1, EN
34080 ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
34081 ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
34082 740 CONTINUE
34083C
34084 YR = XR - WR(I)
34085 YI = XI - WI(I)
34086 IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GO TO 765
34087 TST1 = NORM
34088 YR = TST1
34089 760 YR = 0.01D0 * YR
34090 TST2 = NORM + YR
34091 IF (TST2 .GT. TST1) GO TO 760
34092 765 CONTINUE
34093 CALL CDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
34094C .......... OVERFLOW CONTROL ..........
34095 TR = DABS(HR(I,EN)) + DABS(HI(I,EN))
34096 IF (TR .EQ. 0.0D0) GO TO 780
34097 TST1 = TR
34098 TST2 = TST1 + 1.0D0/TST1
34099 IF (TST2 .GT. TST1) GO TO 780
34100 DO 770 J = I, EN
34101 HR(J,EN) = HR(J,EN)/TR
34102 HI(J,EN) = HI(J,EN)/TR
34103 770 CONTINUE
34104C
34105 780 CONTINUE
34106C
34107 800 CONTINUE
34108C .......... END BACKSUBSTITUTION ..........
34109C .......... VECTORS OF ISOLATED ROOTS ..........
34110 DO 840 I = 1, N
34111 IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840
34112C
34113 DO 820 J = I, N
34114 ZR(I,J) = HR(I,J)
34115 ZI(I,J) = HI(I,J)
34116 820 CONTINUE
34117C
34118 840 CONTINUE
34119C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
34120C VECTORS OF ORIGINAL FULL MATRIX.
34121C FOR J=N STEP -1 UNTIL LOW DO -- ..........
34122 DO 880 JJ = LOW, N
34123 J = N + LOW - JJ
34124 M = MIN0(J,IGH)
34125C
34126 DO 880 I = LOW, IGH
34127 ZZR = 0.0D0
34128 ZZI = 0.0D0
34129C
34130 DO 860 K = LOW, M
34131 ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
34132 ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
34133 860 CONTINUE
34134C
34135 ZR(I,J) = ZZR
34136 ZI(I,J) = ZZI
34137 880 CONTINUE
34138C
34139 GO TO 1001
34140C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
34141C CONVERGED AFTER 30*N ITERATIONS ..........
34142 1000 IERR = EN
34143 1001 RETURN
34144 END
34145 SUBROUTINE CORTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
34146C
34147 INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
34148 DOUBLE PRECISION AR(NM,N),AI(NM,N),ORTR(IGH),ORTI(IGH)
34149 DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG
34150C
34151C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
34152C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
34153C BY MARTIN AND WILKINSON.
34154C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
34155C
34156C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
34157C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
34158C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
34159C UNITARY SIMILARITY TRANSFORMATIONS.
34160C
34161C ON INPUT
34162C
34163C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
34164C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
34165C DIMENSION STATEMENT.
34166C
34167C N IS THE ORDER OF THE MATRIX.
34168C
34169C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
34170C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
34171C SET LOW=1, IGH=N.
34172C
34173C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
34174C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
34175C
34176C ON OUTPUT
34177C
34178C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
34179C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION
34180C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
34181C IS STORED IN THE REMAINING TRIANGLES UNDER THE
34182C HESSENBERG MATRIX.
34183C
34184C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
34185C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED.
34186C
34187C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
34188C
34189C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
34190C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
34191C
34192C THIS VERSION DATED AUGUST 1983.
34193C
34194C ------------------------------------------------------------------
34195C
34196 LA = IGH - 1
34197 KP1 = LOW + 1
34198 IF (LA .LT. KP1) GO TO 200
34199C
34200 DO 180 M = KP1, LA
34201 H = 0.0D0
34202 ORTR(M) = 0.0D0
34203 ORTI(M) = 0.0D0
34204 SCALE = 0.0D0
34205C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
34206 DO 90 I = M, IGH
34207 90 SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1))
34208C
34209 IF (SCALE .EQ. 0.0D0) GO TO 180
34210 MP = M + IGH
34211C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
34212 DO 100 II = M, IGH
34213 I = MP - II
34214 ORTR(I) = AR(I,M-1) / SCALE
34215 ORTI(I) = AI(I,M-1) / SCALE
34216 H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I)
34217 100 CONTINUE
34218C
34219 G = DSQRT(H)
34220 F = PYTHAG(ORTR(M),ORTI(M))
34221 IF (F .EQ. 0.0D0) GO TO 103
34222 H = H + F * G
34223 G = G / F
34224 ORTR(M) = (1.0D0 + G) * ORTR(M)
34225 ORTI(M) = (1.0D0 + G) * ORTI(M)
34226 GO TO 105
34227C
34228 103 ORTR(M) = G
34229 AR(M,M-1) = SCALE
34230C .......... FORM (I-(U*UT)/H) * A ..........
34231 105 DO 130 J = M, N
34232 FR = 0.0D0
34233 FI = 0.0D0
34234C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
34235 DO 110 II = M, IGH
34236 I = MP - II
34237 FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J)
34238 FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J)
34239 110 CONTINUE
34240C
34241 FR = FR / H
34242 FI = FI / H
34243C
34244 DO 120 I = M, IGH
34245 AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I)
34246 AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I)
34247 120 CONTINUE
34248C
34249 130 CONTINUE
34250C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
34251 DO 160 I = 1, IGH
34252 FR = 0.0D0
34253 FI = 0.0D0
34254C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
34255 DO 140 JJ = M, IGH
34256 J = MP - JJ
34257 FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J)
34258 FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J)
34259 140 CONTINUE
34260C
34261 FR = FR / H
34262 FI = FI / H
34263C
34264 DO 150 J = M, IGH
34265 AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J)
34266 AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J)
34267 150 CONTINUE
34268C
34269 160 CONTINUE
34270C
34271 ORTR(M) = SCALE * ORTR(M)
34272 ORTI(M) = SCALE * ORTI(M)
34273 AR(M,M-1) = -G * AR(M,M-1)
34274 AI(M,M-1) = -G * AI(M,M-1)
34275 180 CONTINUE
34276C
34277 200 RETURN
34278 END
34279 SUBROUTINE CSROOT(XR,XI,YR,YI)
34280 DOUBLE PRECISION XR,XI,YR,YI
34281C
34282C (YR,YI) = COMPLEX DSQRT(XR,XI)
34283C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
34284C
34285 DOUBLE PRECISION S,TR,TI,PYTHAG
34286 TR = XR
34287 TI = XI
34288 S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR)))
34289 IF (TR .GE. 0.0D0) YR = S
34290 IF (TI .LT. 0.0D0) S = -S
34291 IF (TR .LE. 0.0D0) YI = S
34292 IF (TR .LT. 0.0D0) YR = 0.5D0*(TI/YI)
34293 IF (TR .GT. 0.0D0) YI = 0.5D0*(TI/YR)
34294 RETURN
34295 END
34296 DOUBLE PRECISION FUNCTION PYTHAG(A,B)
34297 DOUBLE PRECISION A,B
34298C
34299C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
34300C
34301 DOUBLE PRECISION P,R,S,T,U
34302 P = DMAX1(DABS(A),DABS(B))
34303 IF (P .EQ. 0.0D0) GO TO 20
34304 R = (DMIN1(DABS(A),DABS(B))/P)**2
34305 10 CONTINUE
34306 T = 4.0D0 + R
34307 IF (T .EQ. 4.0D0) GO TO 20
34308 S = R/T
34309 U = 1.0D0 + 2.0D0*S
34310 P = U*P
34311 R = (S/U)**2 * R
34312 GO TO 10
34313 20 PYTHAG = P
34314 RETURN
34315 END
34316
34317C*********************************************************************
34318
34319C...PYTBBN
34320C...Calculates the three-body decay of gluinos into
34321C...neutralinos and third generation fermions.
34322
34323 SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
34324
34325C...Double precision and integer declarations.
34326 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34327 IMPLICIT INTEGER(I-N)
34328 INTEGER PYK,PYCHGE,PYCOMP
34329C...Parameter statement to help give large particle numbers.
34330 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
34331C...Commonblocks.
34332 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34333 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34334 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
34335 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
34336 &SFMIX(16,4)
34337 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
34338
34339C...Local variables.
34340 EXTERNAL PYSIMP,PYLAMF
34341 DOUBLE PRECISION PYSIMP,PYLAMF
34342 INTEGER LIN,NN
34343 DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
34344 DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
34345 DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
34346 DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
34347 DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
34348 DOUBLE PRECISION XLN1,XLN2,B1,B2
34349 DOUBLE PRECISION E,XMGLU,GAM
34350 DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
34351 SAVE HRB,HLB,FLB,FRB
34352 DOUBLE PRECISION ALPHAW,ALPHAS,GSU2
34353 DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
34354 SAVE HLT,HRT,FLT,FRT
34355 DOUBLE PRECISION AMC(2),AMN(4),AN(4,4),ZN(3),FLU(4),FRU(4),
34356 &FLD(4),FRD(4)
34357 SAVE AMC,AMN,AN,ZN,FLU,FRU,FLD,FRD
34358 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
34359 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
34360 SAVE AMSB,AMST
34361 DOUBLE PRECISION SINW,COSW,TANW,COSW2,SINW2
34362 DOUBLE PRECISION ROT1(4,4)
34363 LOGICAL IFIRST
34364 SAVE IFIRST
34365 DATA IFIRST/.TRUE./
34366
34367 TANB=RMSS(5)
34368 SINB=TANB/SQRT(1D0+TANB**2)
34369 COSB=SINB/TANB
34370 XW=PARU(102)
34371 SINW=SQRT(XW)
34372 COSW=SQRT(1D0-XW)
34373 TANW=SINW/COSW
34374 AMW=PMAS(24,1)
34375 COSC=SFMIX(5,1)
34376 SINC=SFMIX(5,3)
34377 COSA=SFMIX(6,1)
34378 SINA=SFMIX(6,3)
34379 AMBOT=0D0
34380 AMTOP=PYRNMT(PMAS(6,1))
34381 W2=SQRT(2D0)
34382 FAKT1=AMBOT/W2/AMW/COSB
34383 FAKT2=AMTOP/W2/AMW/SINB
34384 IF(IFIRST) THEN
34385 DO 110 II=1,4
34386 AMN(II)=SMZ(II)
34387 DO 100 J=1,4
34388 ROT1(II,J)=0D0
34389 AN(II,J)=0D0
34390 100 CONTINUE
34391 110 CONTINUE
34392 ROT1(1,1)=COSW
34393 ROT1(1,2)=-SINW
34394 ROT1(2,1)=-ROT1(1,2)
34395 ROT1(2,2)=ROT1(1,1)
34396 ROT1(3,3)=COSB
34397 ROT1(3,4)=SINB
34398 ROT1(4,3)=-ROT1(3,4)
34399 ROT1(4,4)=ROT1(3,3)
34400 DO 140 II=1,4
34401 DO 130 J=1,4
34402 DO 120 JJ=1,4
34403 AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J)
34404 120 CONTINUE
34405 130 CONTINUE
34406 140 CONTINUE
34407 DO 150 J=1,4
34408 ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4))
34409 ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
34410 ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0*
34411 & XW)*AN(J,2)/COSW
34412 HRT(J)=ZN(1)*COSA-ZN(3)*SINA
34413 HLT(J)=ZN(1)*COSA+ZN(2)*SINA
34414 FLT(J)=ZN(3)*COSA+ZN(1)*SINA
34415 FRT(J)=ZN(2)*COSA-ZN(1)*SINA
34416 FLU(J)=ZN(3)
34417 FRU(J)=ZN(2)
34418 ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4))
34419 ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
34420 ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW
34421 HRB(J)=ZN(1)*COSC-ZN(3)*SINC
34422 HLB(J)=ZN(1)*COSC+ZN(2)*SINC
34423 FLB(J)=ZN(3)*COSC+ZN(1)*SINC
34424 FRB(J)=ZN(2)*COSC-ZN(1)*SINC
34425 FLD(J)=ZN(3)
34426 FRD(J)=ZN(2)
34427 150 CONTINUE
34428 AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
34429 AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
34430 AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
34431 AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
34432 IFIRST=.FALSE.
34433 ENDIF
34434
34435 IF(NINT(3D0*E).EQ.2) THEN
34436 HL=HLT(I)
34437 HR=HRT(I)
34438 FL=FLT(I)
34439 FR=FRT(I)
34440 COSD=SFMIX(6,1)
34441 SIND=SFMIX(6,3)
34442 XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2
34443 XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2
34444 XM=PMAS(6,1)
34445 ELSE
34446 HL=HLB(I)
34447 HR=HRB(I)
34448 FL=FLB(I)
34449 FR=FRB(I)
34450 COSD=SFMIX(5,1)
34451 SIND=SFMIX(5,3)
34452 XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2
34453 XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2
34454 XM=PMAS(5,1)
34455 ENDIF
34456 COSD2=COSD*COSD
34457 SIND2=SIND*SIND
34458 COS2D=COSD2-SIND2
34459 SIN2D=SIND*COSD*2D0
34460 HL2=HL*HL
34461 HR2=HR*HR
34462 FL2=FL*FL
34463 FR2=FR*FR
34464 FF=FL*FR
34465 HH=HL*HR
34466 HFL=HL*FL
34467 HFR=HR*FR
34468 HRFL=HR*FL
34469 HLFR=HL*FR
34470 XM2=XM*XM
34471 XMG=XMGLU
34472 XMG2=XMG*XMG
34473 ALPHAW=PYALEM(XMG2)
34474 ALPHAS=PYALPS(XMG2)
34475 XMR=AMN(I)
34476 XMR2=XMR*XMR
34477 XMQ4=XMG*XM2*XMR
34478 XM24=(XMG2+XM2)*(XM2+XMR2)
34479 SMIN=4D0*XM2
34480 SMAX=(XMG-ABS(XMR))**2
34481 XMQA=XMG2+2D0*XM2+XMR2
34482 DO 170 LIN=1,NN-1
34483 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
34484 GRS=SBAR-XMQA
34485 W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR)
34486 W=DSQRT(W)
34487 XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W)))
34488 XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W)))
34489 B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W)
34490 B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W)
34491 G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D
34492 & +2D0*(FF*SIND2-HH*COSD2))*W
34493 G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D)
34494 & +4D0*HFL*XM*XMR)*XLN1
34495 & +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24
34496 & +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D)
34497 & -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1))
34498 & +8D0*HFL*XMQ4*SIN2D)*B1
34499 G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D)
34500 & +4D0*HFR*XMR*XM)*XLN2
34501 & +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24
34502 & +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2))
34503 & +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2)
34504 & -8D0*HFR*XMQ4*SIN2D)*B2
34505 G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
34506 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR
34507 & -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2)
34508 & +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2)
34509 & -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1
34510 G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))*
34511 & (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2)
34512 & +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1))
34513 G(5)=(2D0*(HH*COSD2-FF*SIND2)
34514 & *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2
34515 & +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1)
34516 & +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR)
34517 & *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2)
34518 & +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2)
34519 & +COS2D*XM*(SBAR+XMG2-XMR2))
34520 & +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2))
34521 & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
34522 G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
34523 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR
34524 & -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2)
34525 & -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2)
34526 & -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2
34527 SUMME(LIN)=0D0
34528 DO 160 J=0,6
34529 SUMME(LIN)=SUMME(LIN)+G(J)
34530 160 CONTINUE
34531 170 CONTINUE
34532 SUMME(0)=0D0
34533 SUMME(NN)=0D0
34534 GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
34535 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
34536
34537 RETURN
34538 END
34539
34540C*********************************************************************
34541
34542C...PYTBBC
34543C...Calculates the three-body decay of gluinos into
34544C...charginos and third generation fermions.
34545
34546 SUBROUTINE PYTBBC(I,NN,XMGLU,GAM)
34547
34548C...Double precision and integer declarations.
34549 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34550 IMPLICIT INTEGER(I-N)
34551 INTEGER PYK,PYCHGE,PYCOMP
34552C...Parameter statement to help give large particle numbers.
34553 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
34554C...Commonblocks.
34555 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34556 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34557 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
34558 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
34559 &SFMIX(16,4)
34560 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
34561
34562C...Local variables.
34563 EXTERNAL PYSIMP,PYLAMF
34564 DOUBLE PRECISION PYSIMP,PYLAMF
34565 INTEGER I,NN,LIN
34566 DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
34567 DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
34568 DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
34569 DOUBLE PRECISION SUMME(0:100),A(4,8)
34570 DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
34571 DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
34572 DOUBLE PRECISION XMGLU,GAM
34573 DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
34574 &DDD(2),EEE(2),FFF(2)
34575 SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF
34576 DOUBLE PRECISION ALPHAW,ALPHAS,GSU2
34577 DOUBLE PRECISION AMC(2),AMN(4)
34578 SAVE AMC,AMN
34579 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
34580 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
34581 SAVE AMSB,AMST
34582 DOUBLE PRECISION SINW,COSW,TANW,COSW2,SINW2
34583 LOGICAL IFIRST
34584 SAVE IFIRST
34585 DATA IFIRST/.TRUE./
34586
34587 TANB=RMSS(5)
34588 SINB=TANB/SQRT(1D0+TANB**2)
34589 COSB=SINB/TANB
34590 XW=PARU(102)
34591 SINW=SQRT(XW)
34592 COSW=SQRT(1D0-XW)
34593 AMW=PMAS(24,1)
34594 COSC=SFMIX(5,1)
34595 SINC=SFMIX(5,3)
34596 COSA=SFMIX(6,1)
34597 SINA=SFMIX(6,3)
34598 AMBOT=0D0
34599 AMTOP=PYRNMT(PMAS(6,1))
34600 W2=SQRT(2D0)
34601 AMW=PMAS(24,1)
34602 FAKT1=AMBOT/W2/AMW/COSB
34603 FAKT2=AMTOP/W2/AMW/SINB
34604 IF(IFIRST) THEN
34605 AMC(1)=SMW(1)
34606 AMC(2)=SMW(2)
34607 DO 100 JJ=1,2
34608 CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC
34609 EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC
34610 DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC
34611 FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC
34612 XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA
34613 AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA
34614 XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA
34615 BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA
34616 100 CONTINUE
34617 AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
34618 AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
34619 AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
34620 AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
34621 IFIRST=.FALSE.
34622 ENDIF
34623 AMTOP=PMAS(6,1)
34624
34625 ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I)
34626 ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I)
34627 VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I)
34628 VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I)
34629
34630 COS2A=COSA**2-SINA**2
34631 SIN2A=SINA*COSA*2D0
34632 COS2C=COSC**2-SINC**2
34633 SIN2C=SINC*COSC*2D0
34634
34635 XMG=XMGLU
34636 XMT=AMTOP
34637 XMB=0D0
34638 XMR=AMC(I)
34639 XMG2=XMG*XMG
34640 ALPHAW=PYALEM(XMG2)
34641 ALPHAS=PYALPS(XMG2)
34642 XMT2=XMT*XMT
34643 XMB2=XMB*XMB
34644 XMR2=XMR*XMR
34645 XMQ2=XMG2+XMT2+XMB2+XMR2
34646 XMQ4=XMG*XMT*XMB*XMR
34647 XMQ3=XMG2*XMR2+XMT2*XMB2
34648 XMGBTR=(XMG2+XMB2)*(XMT2+XMR2)
34649 XMGTBR=(XMG2+XMT2)*(XMB2+XMR2)
34650
34651 XMST(1)=AMST(1)*AMST(1)
34652 XMST(2)=AMST(1)*AMST(1)
34653 XMST(3)=AMST(2)*AMST(2)
34654 XMST(4)=AMST(2)*AMST(2)
34655 XMSB(1)=AMSB(1)*AMSB(1)
34656 XMSB(2)=AMSB(2)*AMSB(2)
34657 XMSB(3)=AMSB(1)*AMSB(1)
34658 XMSB(4)=AMSB(2)*AMSB(2)
34659
34660 A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I)
34661 A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I))
34662 A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I))
34663 A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I))
34664 A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I))
34665 A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I))
34666 A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I))
34667 A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I))
34668
34669 A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I)
34670 A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I))
34671 A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I))
34672 A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I))
34673 A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I))
34674 A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I))
34675 A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I))
34676 A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I))
34677
34678 A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I)
34679 A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I))
34680 A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I))
34681 A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I))
34682 A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I))
34683 A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I))
34684 A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I))
34685 A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I))
34686
34687 A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I)
34688 A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I))
34689 A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I))
34690 A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I))
34691 A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I))
34692 A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I))
34693 A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I))
34694 A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I))
34695
34696 SMAX=(XMG-ABS(XMR))**2
34697 SMIN=(XMB+XMT)**2+0.1D0
34698
34699 DO 120 LIN=0,NN-1
34700 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
34701 AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR
34702 GRS=SBAR-XMQ2
34703 W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2)
34704 W=DSQRT(W)/2D0/SBAR
34705 ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W)))
34706 ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W)))
34707 ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W)))
34708 ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W)))
34709 SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A)
34710 & +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1
34711 & +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR
34712 & -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2))
34713 & +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2)
34714 & +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4)
34715 & *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W))
34716 SUMME(LIN)=SUMME(LIN)-ULR(2)*W
34717 & +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A)
34718 & -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2
34719 & +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR
34720 & +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2))
34721 & -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2)
34722 & +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4)
34723 & *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W))
34724 SUMME(LIN)=SUMME(LIN)-VLR(1)*W
34725 & +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C)
34726 & +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1
34727 & +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR
34728 & -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2))
34729 & +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2)
34730 & +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4)
34731 & *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W))
34732 SUMME(LIN)=SUMME(LIN)-VLR(2)*W
34733 & +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C)
34734 & -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2
34735 & +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR
34736 & +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2))
34737 & -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2)
34738 & +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4)
34739 & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
34740 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1))
34741 & *((AAA(I)*BBB(I)-XX1(I)*XX2(I))
34742 & *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1)
34743 & +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1))
34744 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1))
34745 & *((EEE(I)*FFF(I)-CCC(I)*DDD(I))
34746 & *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1)
34747 & +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1))
34748 DO 110 J=1,4
34749 SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W
34750 & +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3)
34751 & +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2)
34752 & +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2)
34753 & -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR)
34754 & -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8))
34755 & *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W)))
34756 & -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3)
34757 & +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2)
34758 & +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2)
34759 & -A(J,6)*(XMG2+XMR2-SBAR)
34760 & -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8))
34761 & *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W))))
34762 & /(GRS+XMSB(J)+XMST(J))
34763 110 CONTINUE
34764 120 CONTINUE
34765 SUMME(NN)=0D0
34766 GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
34767 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
34768
34769 RETURN
34770 END
34771
34772C*********************************************************************
34773
34774C...PYNJDC
34775C...Calculates decay widths for the neutralinos (admixtures of
34776C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
34777
34778C...Input: KCIN = KF code for particle
34779C...Output: XLAM = widths
34780C... IDLAM = KF codes for decay particles
34781C... IKNT = number of decay channels defined
34782C...AUTHOR: STEPHEN MRENNA
34783C...Last change:
34784C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
34785C...when CHIGAMMA .NE. 0
34786C...10 FEB 96: Calculate this decay for small tan(beta)
34787
34788 SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT)
34789
34790C...Double precision and integer declarations.
34791 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34792 IMPLICIT INTEGER(I-N)
34793 INTEGER PYK,PYCHGE,PYCOMP
34794C...Parameter statement to help give large particle numbers.
34795 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
34796C...Commonblocks.
34797 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34798 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34799 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
34800 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
34801 &SFMIX(16,4)
34802 COMMON/PYINTS/XXM(20)
34803 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTS/
34804
34805C...Local variables.
34806 INTEGER KFIN,KCIN
34807 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
34808 &XMZ,XMZ2,AXMJ,AXMI
34809 DOUBLE PRECISION XMFP,XMF1,XMF2,XMSL,XMG,XMK
34810 DOUBLE PRECISION S12MIN,S12MAX
34811 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMHP2,XMA2,XMB2
34812 DOUBLE PRECISION PYLAMF,XL,QIJ,RIJ
34813 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3
34814 DOUBLE PRECISION PYX2XH,PYX2XG
34815 DOUBLE PRECISION XLAM(0:200)
34816 INTEGER IDLAM(200,3)
34817 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
34818 INTEGER ITH(3),KF1,KF2
34819 INTEGER ITHC
34820 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
34821 DOUBLE PRECISION SR2
34822 DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K
34823 DOUBLE PRECISION GAMCON,XMT1,XMT2
34824 DOUBLE PRECISION PYALEM,PI,PYALPS
34825 DOUBLE PRECISION AL,BL,AR,BR,ALP,ARP,BLP,BRP
34826 DOUBLE PRECISION RAT1,RAT2
34827 DOUBLE PRECISION T3T,CA,CB,FCOL
34828 DOUBLE PRECISION ALFA,BETA,TANB
34829 DOUBLE PRECISION PYXXGA
34830 EXTERNAL PYXXW5,PYGAUS,PYXXZ5
34831 DOUBLE PRECISION PYXXW5,PYGAUS,PYXXZ5
34832 DOUBLE PRECISION PREC
34833 INTEGER KFNCHI(4),KFCCHI(2)
34834 DATA ETAH/1D0,1D0,-1D0/
34835 DATA ITH/25,35,36/
34836 DATA ITHC/37/
34837 DATA PREC/1D-2/
34838 DATA PI/3.141592654D0/
34839 DATA SR2/1.4142136D0/
34840 DATA KFNCHI/1000022,1000023,1000025,1000035/
34841 DATA KFCCHI/1000024,1000037/
34842
34843C...COUNT THE NUMBER OF DECAY MODES
34844 LKNT=0
34845
34846 XMW=PMAS(24,1)
34847 XMW2=XMW**2
34848 XMZ=PMAS(23,1)
34849 XMZ2=XMZ**2
34850 XW=1D0-XMW2/XMZ2
34851 TANW = SQRT(XW/(1D0-XW))
34852
34853C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
34854 KCIN=PYCOMP(KFIN)
34855 IX=1
34856 IF(KFIN.EQ.KFNCHI(2)) IX=2
34857 IF(KFIN.EQ.KFNCHI(3)) IX=3
34858 IF(KFIN.EQ.KFNCHI(4)) IX=4
34859
34860 XMI=SMZ(IX)
34861 XMI2=XMI**2
34862 AXMI=ABS(XMI)
34863 AEM=PYALEM(XMI2)
34864 AS =PYALPS(XMI2)
34865 C1=AEM/XW
34866 XMI3=ABS(XMI**3)
34867
34868 TANB=RMSS(5)
34869 BETA=ATAN(TANB)
34870 ALFA=RMSS(18)
34871 CBETA=COS(BETA)
34872 SBETA=TANB*CBETA
34873 CALFA=COS(ALFA)
34874 SALFA=SIN(ALFA)
34875
34876C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
34877 IF(IX.EQ.1.AND.IMSS(11).EQ.0) GOTO 260
34878
34879C...FORCE CHI0_2 -> CHI0_1 + GAMMA
34880 IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN
34881 XMJ=SMZ(1)
34882 AXMJ=ABS(XMJ)
34883 LKNT=LKNT+1
34884 GAMCON=AEM**3/8D0/PI/XMW2/XW
34885 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
34886 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
34887 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
34888 IDLAM(LKNT,1)=KSUSY1+22
34889 IDLAM(LKNT,2)=22
34890 IDLAM(LKNT,3)=0
34891 WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT)
34892 GOTO 300
34893 ENDIF
34894
34895C...GRAVITINO DECAY MODES
34896
34897 IF(IMSS(11).EQ.1) THEN
34898 XMP=RMSS(29)
34899 IDG=39+KSUSY1
34900 XMGR=PMAS(PYCOMP(IDG),1)
34901 SINW=SQRT(XW)
34902 COSW=SQRT(1D0-XW)
34903 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
34904 IF(AXMI.GT.XMGR+PMAS(22,1)) THEN
34905 LKNT=LKNT+1
34906 IDLAM(LKNT,1)=IDG
34907 IDLAM(LKNT,2)=22
34908 IDLAM(LKNT,3)=0
34909 XLAM(LKNT)=XFAC*(ZMIX(IX,1)*COSW+ZMIX(IX,2)*SINW)**2
34910 ENDIF
34911 IF(AXMI.GT.XMGR+XMZ) THEN
34912 LKNT=LKNT+1
34913 IDLAM(LKNT,1)=IDG
34914 IDLAM(LKNT,2)=23
34915 IDLAM(LKNT,3)=0
34916 XLAM(LKNT)=XFAC*((ZMIX(IX,1)*SINW-ZMIX(IX,2)*COSW)**2 +
34917 $ .5D0*(ZMIX(IX,3)*CBETA-ZMIX(IX,4)*SBETA)**2)*(1D0-XMZ2/XMI2)**4
34918 ENDIF
34919 IF(AXMI.GT.XMGR+PMAS(25,1)) THEN
34920 LKNT=LKNT+1
34921 IDLAM(LKNT,1)=IDG
34922 IDLAM(LKNT,2)=25
34923 IDLAM(LKNT,3)=0
34924 XLAM(LKNT)=XFAC*((ZMIX(IX,3)*SALFA-ZMIX(IX,4)*CALFA)**2)*
34925 $ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4
34926 ENDIF
34927 IF(AXMI.GT.XMGR+PMAS(35,1)) THEN
34928 LKNT=LKNT+1
34929 IDLAM(LKNT,1)=IDG
34930 IDLAM(LKNT,2)=35
34931 IDLAM(LKNT,3)=0
34932 XLAM(LKNT)=XFAC*((ZMIX(IX,3)*CALFA+ZMIX(IX,4)*SALFA)**2)*
34933 $ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4
34934 ENDIF
34935 IF(AXMI.GT.XMGR+PMAS(36,1)) THEN
34936 LKNT=LKNT+1
34937 IDLAM(LKNT,1)=IDG
34938 IDLAM(LKNT,2)=36
34939 IDLAM(LKNT,3)=0
34940 XLAM(LKNT)=XFAC*((ZMIX(IX,3)*SBETA+ZMIX(IX,4)*CBETA)**2)*
34941 $ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4
34942 ENDIF
34943 IF(IX.EQ.1) GOTO 260
34944 ENDIF
34945
34946 DO 180 IJ=1,IX-1
34947 XMJ=SMZ(IJ)
34948 AXMJ=ABS(XMJ)
34949 XMJ2=XMJ**2
34950
34951C...CHI0_I -> CHI0_J + GAMMA
34952 IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN
34953 RAT1=ZMIX(IJ,1)**2+ZMIX(IJ,2)**2
34954 RAT1=RAT1/( 1D-6+ZMIX(IX,3)**2+ZMIX(IX,4)**2 )
34955 RAT2=ZMIX(IX,1)**2+ZMIX(IX,2)**2
34956 RAT2=RAT2/( 1D-6+ZMIX(IJ,3)**2+ZMIX(IJ,4)**2 )
34957 IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR.
34958 & (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN
34959 LKNT=LKNT+1
34960 IDLAM(LKNT,1)=KFNCHI(IJ)
34961 IDLAM(LKNT,2)=22
34962 IDLAM(LKNT,3)=0
34963 GAMCON=AEM**3/8D0/PI/XMW2/XW
34964 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
34965 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
34966 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
34967 ENDIF
34968 ENDIF
34969
34970C...CHI0_I -> CHI0_J + Z0
34971 IF(AXMI.GE.AXMJ+XMZ) THEN
34972 LKNT=LKNT+1
34973 GL=-0.5D0*(ZMIX(IX,3)*ZMIX(IJ,3)-ZMIX(IX,4)*ZMIX(IJ,4))
34974 GR=-GL
34975 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GL,GR)
34976 IDLAM(LKNT,1)=KFNCHI(IJ)
34977 IDLAM(LKNT,2)=23
34978 IDLAM(LKNT,3)=0
34979 ELSEIF(AXMI.GE.AXMJ) THEN
34980 FID=11
34981 EI=KCHG(FID,1)/3D0
34982 T3=-0.5D0
34983 XXM(1)=0D0
34984 XXM(2)=XMJ
34985 XXM(3)=0D0
34986 XXM(4)=XMI
34987 XXM(5)=PMAS(PYCOMP(KSUSY1+11),1)
34988 XXM(6)=PMAS(PYCOMP(KSUSY2+11),1)
34989 XXM(7)=XMZ
34990 XXM(8)=PMAS(23,2)
34991 XXM(9)=-0.5D0*(ZMIX(IX,3)*ZMIX(IJ,3)-ZMIX(IX,4)*ZMIX(IJ,4))
34992 XXM(10)=-XXM(9)
34993 XXM(11)=(T3-EI*XW)/(1D0-XW)
34994 XXM(12)=-EI*XW/(1D0-XW)
34995 XXM(13)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))
34996 XXM(14)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))
34997 XXM(15)=SR2*TANW*(EI*ZMIX(IX,1))
34998 XXM(16)=SR2*TANW*(EI*ZMIX(IJ,1))
34999 S12MIN=0D0
35000 S12MAX=(AXMI-AXMJ)**2
35001
35002C...CHARGED LEPTONS
35003 IF( XXM(5).LT.AXMI ) THEN
35004 XXM(5)=1D6
35005 ENDIF
35006 IF(XXM(6).LT.AXMI ) THEN
35007 XXM(6)=1D6
35008 ENDIF
35009 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
35010 LKNT=LKNT+1
35011 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
35012 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
35013 IDLAM(LKNT,1)=KFNCHI(IJ)
35014 IDLAM(LKNT,2)=11
35015 IDLAM(LKNT,3)=-11
35016 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
35017 LKNT=LKNT+1
35018 XLAM(LKNT)=XLAM(LKNT-1)
35019 IDLAM(LKNT,1)=KFNCHI(IJ)
35020 IDLAM(LKNT,2)=13
35021 IDLAM(LKNT,3)=-13
35022 ENDIF
35023 ENDIF
35024 100 CONTINUE
35025 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
35026 XXM(5)=PMAS(PYCOMP(KSUSY1+15),1)
35027 XXM(6)=PMAS(PYCOMP(KSUSY2+15),1)
35028 ELSE
35029 XXM(6)=PMAS(PYCOMP(KSUSY1+15),1)
35030 XXM(5)=PMAS(PYCOMP(KSUSY2+15),1)
35031 ENDIF
35032 IF( XXM(5).LT.AXMI ) THEN
35033 XXM(5)=1D6
35034 ENDIF
35035 IF(XXM(6).LT.AXMI ) THEN
35036 XXM(6)=1D6
35037 ENDIF
35038
35039 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
35040 LKNT=LKNT+1
35041 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
35042 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
35043 IDLAM(LKNT,1)=KFNCHI(IJ)
35044 IDLAM(LKNT,2)=15
35045 IDLAM(LKNT,3)=-15
35046 ENDIF
35047
35048C...NEUTRINOS
35049 110 CONTINUE
35050 FID=12
35051 EI=KCHG(FID,1)/3D0
35052 T3=0.5D0
35053 XXM(5)=PMAS(PYCOMP(KSUSY1+12),1)
35054 XXM(6)=1D6
35055 XXM(11)=(T3-EI*XW)/(1D0-XW)
35056 XXM(12)=-EI*XW/(1D0-XW)
35057 XXM(13)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))
35058 XXM(14)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))
35059 XXM(15)=SR2*TANW*(EI*ZMIX(IX,1))
35060 XXM(16)=SR2*TANW*(EI*ZMIX(IJ,1))
35061
35062 IF( XXM(5).LT.AXMI ) THEN
35063 XXM(5)=1D6
35064 ENDIF
35065
35066 LKNT=LKNT+1
35067 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
35068 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
35069 IDLAM(LKNT,1)=KFNCHI(IJ)
35070 IDLAM(LKNT,2)=12
35071 IDLAM(LKNT,3)=-12
35072 LKNT=LKNT+1
35073 XLAM(LKNT)=XLAM(LKNT-1)
35074 IDLAM(LKNT,1)=KFNCHI(IJ)
35075 IDLAM(LKNT,2)=14
35076 IDLAM(LKNT,3)=-14
35077 120 CONTINUE
35078 XXM(5)=PMAS(PYCOMP(KSUSY1+16),1)
35079 IF( XXM(5).LT.AXMI ) THEN
35080 XXM(5)=1D6
35081 ENDIF
35082 LKNT=LKNT+1
35083 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
35084 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
35085 IDLAM(LKNT,1)=KFNCHI(IJ)
35086 IDLAM(LKNT,2)=16
35087 IDLAM(LKNT,3)=-16
35088
35089C...D-TYPE QUARKS
35090 130 CONTINUE
35091 XXM(5)=PMAS(PYCOMP(KSUSY1+1),1)
35092 XXM(6)=PMAS(PYCOMP(KSUSY2+1),1)
35093 FID=1
35094 EI=KCHG(FID,1)/3D0
35095 T3=-0.5D0
35096
35097 XXM(11)=(T3-EI*XW)/(1D0-XW)
35098 XXM(12)=-EI*XW/(1D0-XW)
35099 XXM(13)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))
35100 XXM(14)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))
35101 XXM(15)=SR2*TANW*(EI*ZMIX(IX,1))
35102 XXM(16)=SR2*TANW*(EI*ZMIX(IJ,1))
35103
35104 IF( XXM(5).LT.AXMI .AND. XXM(6).LT.AXMI ) GOTO 140
35105 IF( XXM(5).LT.AXMI ) THEN
35106 XXM(5)=1D6
35107 ELSEIF( XXM(6).LT.AXMI ) THEN
35108 XXM(6)=1D6
35109 ENDIF
35110 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
35111 LKNT=LKNT+1
35112 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
35113 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)*3D0
35114 IDLAM(LKNT,1)=KFNCHI(IJ)
35115 IDLAM(LKNT,2)=1
35116 IDLAM(LKNT,3)=-1
35117 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
35118 LKNT=LKNT+1
35119 XLAM(LKNT)=XLAM(LKNT-1)
35120 IDLAM(LKNT,1)=KFNCHI(IJ)
35121 IDLAM(LKNT,2)=3
35122 IDLAM(LKNT,3)=-3
35123 ENDIF
35124 ENDIF
35125 140 CONTINUE
35126 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
35127 XXM(5)=PMAS(PYCOMP(KSUSY1+5),1)
35128 XXM(6)=PMAS(PYCOMP(KSUSY2+5),1)
35129 ELSE
35130 XXM(6)=PMAS(PYCOMP(KSUSY1+5),1)
35131 XXM(5)=PMAS(PYCOMP(KSUSY2+5),1)
35132 ENDIF
35133 IF( XXM(5).LT.AXMI .AND. XXM(6).LT.AXMI ) GOTO 150
35134 IF(XXM(5).LT.AXMI) THEN
35135 XXM(5)=1D6
35136 ELSEIF(XXM(6).LT.AXMI) THEN
35137 XXM(6)=1D6
35138 ENDIF
35139 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
35140 LKNT=LKNT+1
35141 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
35142 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)*3D0
35143 IDLAM(LKNT,1)=KFNCHI(IJ)
35144 IDLAM(LKNT,2)=5
35145 IDLAM(LKNT,3)=-5
35146 ENDIF
35147
35148C...U-TYPE QUARKS
35149 150 CONTINUE
35150 XXM(5)=PMAS(PYCOMP(KSUSY1+2),1)
35151 XXM(6)=PMAS(PYCOMP(KSUSY2+2),1)
35152 FID=2
35153 EI=KCHG(FID,1)/3D0
35154 T3=0.5D0
35155
35156 XXM(11)=(T3-EI*XW)/(1D0-XW)
35157 XXM(12)=-EI*XW/(1D0-XW)
35158 XXM(13)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))
35159 XXM(14)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))
35160 XXM(15)=SR2*TANW*(EI*ZMIX(IX,1))
35161 XXM(16)=SR2*TANW*(EI*ZMIX(IJ,1))
35162
35163 IF( XXM(5).LT.AXMI .AND. XXM(6).LT.AXMI ) GOTO 160
35164 IF(XXM(5).LT.AXMI) THEN
35165 XXM(5)=1D6
35166 ELSEIF(XXM(6).LT.AXMI) THEN
35167 XXM(6)=1D6
35168 ENDIF
35169 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
35170 LKNT=LKNT+1
35171 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
35172 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)*3D0
35173 IDLAM(LKNT,1)=KFNCHI(IJ)
35174 IDLAM(LKNT,2)=2
35175 IDLAM(LKNT,3)=-2
35176 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
35177 LKNT=LKNT+1
35178 XLAM(LKNT)=XLAM(LKNT-1)
35179 IDLAM(LKNT,1)=KFNCHI(IJ)
35180 IDLAM(LKNT,2)=4
35181 IDLAM(LKNT,3)=-4
35182 ENDIF
35183 ENDIF
35184 160 CONTINUE
35185 ENDIF
35186
35187C...CHI0_I -> CHI0_J + H0_K
35188 EH(1)=SIN(ALFA)
35189 EH(2)=COS(ALFA)
35190 EH(3)=-SIN(BETA)
35191 DH(1)=COS(ALFA)
35192 DH(2)=-SIN(ALFA)
35193 DH(3)=COS(BETA)
35194
35195 QIJ=ZMIX(IX,3)*ZMIX(IJ,2)+ZMIX(IJ,3)*ZMIX(IX,2)-
35196 & TANW*(ZMIX(IX,3)*ZMIX(IJ,1)+ZMIX(IJ,3)*ZMIX(IX,1))
35197 RIJ=ZMIX(IX,4)*ZMIX(IJ,2)+ZMIX(IJ,4)*ZMIX(IX,2)-
35198 & TANW*(ZMIX(IX,4)*ZMIX(IJ,1)+ZMIX(IJ,4)*ZMIX(IX,1))
35199
35200 DO 170 IH=1,3
35201 XMH=PMAS(ITH(IH),1)
35202 XMH2=XMH**2
35203 IF(AXMI.GE.AXMJ+XMH) THEN
35204 LKNT=LKNT+1
35205 XL=PYLAMF(XMI2,XMJ2,XMH2)
35206 F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH))
35207 F12K=F21K
35208C...SIGN OF MASSES I,J
35209 XMK=XMJ
35210 IF(IH.EQ.3) XMK=-XMK
35211 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,F12K,F21K)
35212 IDLAM(LKNT,1)=KFNCHI(IJ)
35213 IDLAM(LKNT,2)=ITH(IH)
35214 IDLAM(LKNT,3)=0
35215 ENDIF
35216 170 CONTINUE
35217 180 CONTINUE
35218
35219C...CHI0_I -> CHI+_J + W-
35220 DO 220 IJ=1,2
35221 XMJ=SMW(IJ)
35222 AXMJ=ABS(XMJ)
35223 XMJ2=XMJ**2
35224 IF(AXMI.GE.AXMJ+XMW) THEN
35225 LKNT=LKNT+1
35226 GL=ZMIX(IX,2)*VMIX(IJ,1)-ZMIX(IX,4)*VMIX(IJ,2)/SR2
35227 GR=ZMIX(IX,2)*UMIX(IJ,1)+ZMIX(IX,3)*UMIX(IJ,2)/SR2
35228 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GL,GR)
35229 IDLAM(LKNT,1)=KFCCHI(IJ)
35230 IDLAM(LKNT,2)=-24
35231 IDLAM(LKNT,3)=0
35232 LKNT=LKNT+1
35233 XLAM(LKNT)=XLAM(LKNT-1)
35234 IDLAM(LKNT,1)=-KFCCHI(IJ)
35235 IDLAM(LKNT,2)=24
35236 IDLAM(LKNT,3)=0
35237 ELSEIF(AXMI.GE.AXMJ) THEN
35238 S12MIN=0D0
35239 S12MAX=(AXMI-AXMJ)**2
35240 XXM(5)=ZMIX(IX,2)*VMIX(IJ,1)-ZMIX(IX,4)*VMIX(IJ,2)/SR2
35241 XXM(6)=ZMIX(IX,2)*UMIX(IJ,1)+ZMIX(IX,3)*UMIX(IJ,2)/SR2
35242
35243C...LEPTONS
35244 FID=11
35245 EI=KCHG(FID,1)/3D0
35246 T3=-0.5D0
35247 XXM(7)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))*UMIX(IJ,1)
35248 FID=12
35249 EI=KCHG(FID,1)/3D0
35250 T3=0.5D0
35251 XXM(8)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))*VMIX(IJ,1)
35252
35253 XXM(1)=0D0
35254 XXM(2)=XMJ
35255 XXM(3)=0D0
35256 XXM(4)=XMI
35257 XXM(9)=PMAS(24,1)
35258 XXM(10)=PMAS(24,2)
35259 XXM(11)=PMAS(PYCOMP(KSUSY1+11),1)
35260 XXM(12)=PMAS(PYCOMP(KSUSY1+12),1)
35261 IF( XXM(11).LT.AXMI .AND. XXM(12).LT.AXMI ) GOTO 190
35262 IF(XXM(11).LT.AXMI) THEN
35263 XXM(11)=1D6
35264 ELSEIF(XXM(12).LT.AXMI) THEN
35265 XXM(12)=1D6
35266 ENDIF
35267 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
35268 LKNT=LKNT+1
35269 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
35270 & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
35271 IDLAM(LKNT,1)=KFCCHI(IJ)
35272 IDLAM(LKNT,2)=11
35273 IDLAM(LKNT,3)=-12
35274 LKNT=LKNT+1
35275 XLAM(LKNT)=XLAM(LKNT-1)
35276 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
35277 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
35278 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
35279 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
35280 LKNT=LKNT+1
35281 XLAM(LKNT)=XLAM(LKNT-1)
35282 IDLAM(LKNT,1)=KFCCHI(IJ)
35283 IDLAM(LKNT,2)=13
35284 IDLAM(LKNT,3)=-14
35285 LKNT=LKNT+1
35286 XLAM(LKNT)=XLAM(LKNT-1)
35287 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
35288 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
35289 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
35290 ENDIF
35291 ENDIF
35292 190 CONTINUE
35293 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
35294 XXM(11)=PMAS(PYCOMP(KSUSY1+15),1)
35295 XXM(12)=PMAS(PYCOMP(KSUSY1+16),1)
35296 ELSE
35297 XXM(11)=PMAS(PYCOMP(KSUSY2+15),1)
35298 XXM(12)=PMAS(PYCOMP(KSUSY1+16),1)
35299 ENDIF
35300
35301 IF(XXM(11).LT.AXMI) THEN
35302 XXM(11)=1D6
35303 ENDIF
35304 IF(XXM(12).LT.AXMI) THEN
35305 XXM(12)=1D6
35306 ENDIF
35307 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
35308 LKNT=LKNT+1
35309 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
35310 & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
35311 XLAM(LKNT)=XLAM(LKNT-1)
35312 IDLAM(LKNT,1)=KFCCHI(IJ)
35313 IDLAM(LKNT,2)=15
35314 IDLAM(LKNT,3)=-16
35315 LKNT=LKNT+1
35316 XLAM(LKNT)=XLAM(LKNT-1)
35317 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
35318 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
35319 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
35320 ENDIF
35321
35322C...NOW, DO THE QUARKS
35323 200 CONTINUE
35324 FID=1
35325 EI=KCHG(FID,1)/3D0
35326 T3=-0.5D0
35327 XXM(7)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))*UMIX(IJ,1)
35328 FID=2
35329 EI=KCHG(FID,1)/3D0
35330 T3=0.5D0
35331 XXM(8)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))*VMIX(IJ,1)
35332
35333 XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
35334 XXM(12)=PMAS(PYCOMP(KSUSY1+2),1)
35335 IF( XXM(11).LT.AXMI .AND. XXM(12).LT.AXMI ) GOTO 210
35336 IF(XXM(11).LT.AXMI) THEN
35337 XXM(11)=1D6
35338 ELSEIF(XXM(12).LT.AXMI) THEN
35339 XXM(12)=1D6
35340 ENDIF
35341 IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN
35342 LKNT=LKNT+1
35343 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
35344 & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
35345 IDLAM(LKNT,1)=KFCCHI(IJ)
35346 IDLAM(LKNT,2)=1
35347 IDLAM(LKNT,3)=-2
35348 LKNT=LKNT+1
35349 XLAM(LKNT)=XLAM(LKNT-1)
35350 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
35351 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
35352 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
35353 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
35354 LKNT=LKNT+1
35355 XLAM(LKNT)=XLAM(LKNT-1)
35356 IDLAM(LKNT,1)=KFCCHI(IJ)
35357 IDLAM(LKNT,2)=3
35358 IDLAM(LKNT,3)=-4
35359 LKNT=LKNT+1
35360 XLAM(LKNT)=XLAM(LKNT-1)
35361 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
35362 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
35363 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
35364 ENDIF
35365 ENDIF
35366 210 CONTINUE
35367 ENDIF
35368 220 CONTINUE
35369 230 CONTINUE
35370
35371C...CHI0_I -> CHI+_I + H-
35372 DO 240 IJ=1,2
35373 XMJ=SMW(IJ)
35374 AXMJ=ABS(XMJ)
35375 XMJ2=XMJ**2
35376 XMHP=PMAS(ITHC,1)
35377 XMHP2=XMHP**2
35378 IF(AXMI.GE.AXMJ+XMHP) THEN
35379 LKNT=LKNT+1
35380 GL=CBETA*(ZMIX(IX,4)*VMIX(IJ,1)+(ZMIX(IX,2)+
35381 & ZMIX(IX,1)*TANW)*VMIX(IJ,2)/SR2)
35382 GR=SBETA*(ZMIX(IX,3)*UMIX(IJ,1)-(ZMIX(IX,2)+
35383 & ZMIX(IX,1)*TANW)*UMIX(IJ,2)/SR2)
35384 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GL,GR)
35385 IDLAM(LKNT,1)=KFCCHI(IJ)
35386 IDLAM(LKNT,2)=-ITHC
35387 IDLAM(LKNT,3)=0
35388 LKNT=LKNT+1
35389 XLAM(LKNT)=XLAM(LKNT-1)
35390 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
35391 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
35392 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
35393 ELSE
35394
35395 ENDIF
35396 240 CONTINUE
35397
35398C...2-BODY DECAYS TO FERMION SFERMION
35399 DO 250 J=1,16
35400 IF(J.GE.7.AND.J.LE.10) GOTO 250
35401 KF1=KSUSY1+J
35402 KF2=KSUSY2+J
35403 XMSF1=PMAS(PYCOMP(KF1),1)
35404 XMSF2=PMAS(PYCOMP(KF2),1)
35405 XMF=PMAS(J,1)
35406 IF(J.LE.6) THEN
35407 FCOL=3D0
35408 ELSE
35409 FCOL=1D0
35410 ENDIF
35411
35412 EI=KCHG(J,1)/3D0
35413 T3T=SIGN(1D0,EI)
35414 IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0
35415 IF(MOD(J,2).EQ.0) THEN
35416 BL=T3T*ZMIX(IX,2)+TANW*ZMIX(IX,1)*(2D0*EI-T3T)
35417 AL=XMF*ZMIX(IX,4)/XMW/SBETA
35418 AR=-2D0*EI*TANW*ZMIX(IX,1)
35419 BR=AL
35420 ELSE
35421 BL=T3T*ZMIX(IX,2)+TANW*ZMIX(IX,1)*(2D0*EI-T3T)
35422 AL=XMF*ZMIX(IX,3)/XMW/CBETA
35423 AR=-2D0*EI*TANW*ZMIX(IX,1)
35424 BR=AL
35425 ENDIF
35426
35427C...D~ D_L
35428 IF(AXMI.GE.XMF+XMSF1) THEN
35429 LKNT=LKNT+1
35430 XMA2=XMSF1**2
35431 XMB2=XMF**2
35432 XL=PYLAMF(XMI2,XMA2,XMB2)
35433 CA=AL*SFMIX(J,1)+AR*SFMIX(J,2)
35434 CB=BL*SFMIX(J,1)+BR*SFMIX(J,2)
35435 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
35436 & (CA**2+CB**2)+4D0*CA*CB*XMF*XMI)
35437 IDLAM(LKNT,1)=KF1
35438 IDLAM(LKNT,2)=-J
35439 IDLAM(LKNT,3)=0
35440 LKNT=LKNT+1
35441 XLAM(LKNT)=XLAM(LKNT-1)
35442 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
35443 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
35444 IDLAM(LKNT,3)=0
35445 ENDIF
35446
35447C...D~ D_R
35448 IF(AXMI.GE.XMF+XMSF2) THEN
35449 LKNT=LKNT+1
35450 XMA2=XMSF2**2
35451 XMB2=XMF**2
35452 CA=AL*SFMIX(J,3)+AR*SFMIX(J,4)
35453 CB=BL*SFMIX(J,3)+BR*SFMIX(J,4)
35454 XL=PYLAMF(XMI2,XMA2,XMB2)
35455 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
35456 & (CA**2+CB**2)+4D0*CA*CB*XMF*XMI)
35457 IDLAM(LKNT,1)=KF2
35458 IDLAM(LKNT,2)=-J
35459 IDLAM(LKNT,3)=0
35460 LKNT=LKNT+1
35461 XLAM(LKNT)=XLAM(LKNT-1)
35462 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
35463 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
35464 IDLAM(LKNT,3)=0
35465 ENDIF
35466 250 CONTINUE
35467 260 CONTINUE
35468C...3-BODY DECAY TO Q Q~ GLUINO
35469 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
35470 IF(AXMI.GE.XMJ) THEN
35471 AXMJ=ABS(XMJ)
35472 XXM(1)=0D0
35473 XXM(2)=XMJ
35474 XXM(3)=0D0
35475 XXM(4)=XMI
35476 XXM(5)=PMAS(PYCOMP(KSUSY1+1),1)
35477 XXM(6)=PMAS(PYCOMP(KSUSY2+1),1)
35478 XXM(7)=1D6
35479 XXM(8)=0D0
35480 XXM(9)=0D0
35481 XXM(10)=0D0
35482 S12MIN=0D0
35483 S12MAX=(AXMI-AXMJ)**2
35484C...ALL QUARKS BUT T
35485 XXM(11)=0D0
35486 XXM(12)=0D0
35487 XXM(13)=1D0
35488 XXM(14)=-SR2*(-0.5D0*ZMIX(IX,2)+TANW*ZMIX(IX,1)/6D0)
35489 XXM(15)=1D0
35490 XXM(16)=SR2*(-TANW*ZMIX(IX,1)/3D0)
35491 IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 270
35492 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
35493 LKNT=LKNT+1
35494 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
35495 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
35496 IDLAM(LKNT,1)=KSUSY1+21
35497 IDLAM(LKNT,2)=1
35498 IDLAM(LKNT,3)=-1
35499 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
35500 LKNT=LKNT+1
35501 XLAM(LKNT)=XLAM(LKNT-1)
35502 IDLAM(LKNT,1)=KSUSY1+21
35503 IDLAM(LKNT,2)=3
35504 IDLAM(LKNT,3)=-3
35505 ENDIF
35506 ENDIF
35507 270 CONTINUE
35508 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
35509 XXM(5)=PMAS(PYCOMP(KSUSY1+5),1)
35510 XXM(6)=PMAS(PYCOMP(KSUSY2+5),1)
35511 ELSE
35512 XXM(6)=PMAS(PYCOMP(KSUSY1+5),1)
35513 XXM(5)=PMAS(PYCOMP(KSUSY2+5),1)
35514 ENDIF
35515 IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 280
35516 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
35517 LKNT=LKNT+1
35518 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
35519 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
35520 IDLAM(LKNT,1)=KSUSY1+21
35521 IDLAM(LKNT,2)=5
35522 IDLAM(LKNT,3)=-5
35523 ENDIF
35524C...U-TYPE QUARKS
35525 280 CONTINUE
35526 XXM(5)=PMAS(PYCOMP(KSUSY1+2),1)
35527 XXM(6)=PMAS(PYCOMP(KSUSY2+2),1)
35528 XXM(13)=1D0
35529 XXM(14)=-SR2*(0.5D0*ZMIX(IX,2)+TANW*ZMIX(IX,1)/6D0)
35530 XXM(15)=1D0
35531 XXM(16)=SR2*(2D0*TANW*ZMIX(IX,1)/3D0)
35532 IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 290
35533 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
35534 LKNT=LKNT+1
35535 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
35536 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
35537 IDLAM(LKNT,1)=KSUSY1+21
35538 IDLAM(LKNT,2)=2
35539 IDLAM(LKNT,3)=-2
35540 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
35541 LKNT=LKNT+1
35542 XLAM(LKNT)=XLAM(LKNT-1)
35543 IDLAM(LKNT,1)=KSUSY1+21
35544 IDLAM(LKNT,2)=4
35545 IDLAM(LKNT,3)=-4
35546 ENDIF
35547 ENDIF
35548 290 CONTINUE
35549 ENDIF
35550
35551 300 IKNT=LKNT
35552 XLAM(0)=0D0
35553 DO 310 I=1,IKNT
35554 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
35555 XLAM(0)=XLAM(0)+XLAM(I)
35556 310 CONTINUE
35557 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
35558
35559 RETURN
35560 END
35561
35562C*********************************************************************
35563
35564C...PYCJDC
35565C...Calculate decay widths for the charginos (admixtures of
35566C...charged Wino and charged Higgsino.
35567
35568C...Input: KCIN = KF code for particle
35569C...Output: XLAM = widths
35570C... IDLAM = KF codes for decay particles
35571C... IKNT = number of decay channels defined
35572C...AUTHOR: STEPHEN MRENNA
35573C...Last change:
35574C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
35575C...when CHIENU .NE. 0
35576
35577 SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT)
35578
35579C...Double precision and integer declarations.
35580 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35581 IMPLICIT INTEGER(I-N)
35582 INTEGER PYK,PYCHGE,PYCOMP
35583C...Parameter statement to help give large particle numbers.
35584 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
35585C...Commonblocks.
35586 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35587 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35588 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
35589 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
35590 &SFMIX(16,4)
35591 COMMON/PYINTS/XXM(20)
35592 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTS/
35593
35594C...Local variables.
35595 INTEGER KFIN,KCIN
35596 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
35597 &XMZ,XMZ2,AXMJ,AXMI
35598 DOUBLE PRECISION XMFP,XMF1,XMF2,XMSL,XMG
35599 DOUBLE PRECISION S12MIN,S12MAX
35600 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMHP2,XMA2,XMB2,XMK
35601 DOUBLE PRECISION PYLAMF,XL
35602 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3,BETA,ALFA
35603 DOUBLE PRECISION PYX2XH,PYX2XG
35604 DOUBLE PRECISION XLAM(0:200)
35605 INTEGER IDLAM(200,3)
35606 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
35607 INTEGER ITH(3)
35608 INTEGER ITHC
35609 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
35610 DOUBLE PRECISION SR2
35611 DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K,TANB
35612
35613 DOUBLE PRECISION PYALEM,PI,PYALPS
35614 DOUBLE PRECISION AL,BL,AR,BR,ALP,BLP,ARP,BRP
35615 DOUBLE PRECISION CA,CB,FCOL
35616 INTEGER KF1,KF2,ISF
35617 INTEGER KFNCHI(4),KFCCHI(2)
35618
35619 DOUBLE PRECISION TEMP
35620 EXTERNAL PYGAUS,PYXXZ5,PYXXW5,PYXXZ2
35621 DOUBLE PRECISION PYGAUS,PYXXZ5,PYXXW5,PYXXZ2
35622 DOUBLE PRECISION PREC
35623 DATA ITH/25,35,36/
35624 DATA ITHC/37/
35625 DATA ETAH/1D0,1D0,-1D0/
35626 DATA SR2/1.4142136D0/
35627 DATA PI/3.141592654D0/
35628 DATA PREC/1D-2/
35629 DATA KFNCHI/1000022,1000023,1000025,1000035/
35630 DATA KFCCHI/1000024,1000037/
35631
35632C...COUNT THE NUMBER OF DECAY MODES
35633 LKNT=0
35634 XMW=PMAS(24,1)
35635 XMW2=XMW**2
35636 XMZ=PMAS(23,1)
35637 XMZ2=XMZ**2
35638 XW=1D0-XMW2/XMZ2
35639 TANW = SQRT(XW/(1D0-XW))
35640
35641C...1 OR 2 DEPENDING ON CHARGINO TYPE
35642 IX=1
35643 IF(KFIN.EQ.KFCCHI(2)) IX=2
35644 KCIN=PYCOMP(KFIN)
35645
35646 XMI=SMW(IX)
35647 XMI2=XMI**2
35648 AXMI=ABS(XMI)
35649 AEM=PYALEM(XMI2)
35650 AS =PYALPS(XMI2)
35651 C1=AEM/XW
35652 XMI3=ABS(XMI**3)
35653 TANB=RMSS(5)
35654 BETA=ATAN(TANB)
35655 CBETA=COS(BETA)
35656 SBETA=TANB*CBETA
35657 ALFA=RMSS(18)
35658
35659C...GRAVITINO DECAY MODES
35660
35661 IF(IMSS(11).EQ.1) THEN
35662 XMP=RMSS(29)
35663 IDG=39+KSUSY1
35664 XMGR=PMAS(PYCOMP(IDG),1)
35665 SINW=SQRT(XW)
35666 COSW=SQRT(1D0-XW)
35667 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
35668 IF(AXMI.GT.XMGR+XMW) THEN
35669 LKNT=LKNT+1
35670 IDLAM(LKNT,1)=IDG
35671 IDLAM(LKNT,2)=24
35672 IDLAM(LKNT,3)=0
35673 XLAM(LKNT)=XFAC*(.5D0*(VMIX(IX,1)**2+UMIX(IX,1)**2)+
35674 & .5D0*((VMIX(IX,2)*SBETA)**2+(UMIX(IX,2)*CBETA)**2))*
35675 & (1D0-XMW2/XMI2)**4
35676 ENDIF
35677 IF(AXMI.GT.XMGR+PMAS(37,1)) THEN
35678 LKNT=LKNT+1
35679 IDLAM(LKNT,1)=IDG
35680 IDLAM(LKNT,2)=37
35681 IDLAM(LKNT,3)=0
35682 XLAM(LKNT)=XFAC*(.5D0*((VMIX(IX,2)*CBETA)**2+
35683 & (UMIX(IX,2)*SBETA)**2))
35684 & *(1D0-PMAS(37,1)**2/XMI2)**4
35685 ENDIF
35686 ENDIF
35687
35688C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
35689 IF(IX.EQ.1) GOTO 150
35690 XMJ=SMW(1)
35691 AXMJ=ABS(XMJ)
35692 XMJ2=XMJ**2
35693
35694C...CHI_2+ -> CHI_1+ + Z0
35695 IF(AXMI.GE.AXMJ+XMZ) THEN
35696 LKNT=LKNT+1
35697 GL=VMIX(2,1)*VMIX(1,1)+0.5D0*VMIX(2,2)*VMIX(1,2)
35698 GR=UMIX(2,1)*UMIX(1,1)+0.5D0*UMIX(2,2)*UMIX(1,2)
35699 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GL,GR)
35700 IDLAM(LKNT,1)=KFCCHI(1)
35701 IDLAM(LKNT,2)=23
35702 IDLAM(LKNT,3)=0
35703
35704C...CHARGED LEPTONS
35705 ELSEIF(AXMI.GE.AXMJ) THEN
35706 XXM(5)=-(VMIX(2,1)*VMIX(1,1)+0.5D0*VMIX(2,2)*VMIX(1,2))
35707 XXM(6)=-(UMIX(2,1)*UMIX(1,1)+0.5D0*UMIX(2,2)*UMIX(1,2))
35708 XXM(9)=XMZ
35709 XXM(10)=PMAS(23,2)
35710 XXM(1)=0D0
35711 XXM(2)=XMJ
35712 XXM(3)=0D0
35713 XXM(4)=XMI
35714 S12MIN=0D0
35715 S12MAX=(AXMJ-AXMI)**2
35716 XXM(7)= (-0.5D0+XW)/(1D0-XW)
35717 XXM(8)= XW/(1D0-XW)
35718 XXM(11)=PMAS(PYCOMP(KSUSY1+12),1)
35719 XXM(12)=VMIX(2,1)*VMIX(1,1)
35720 IF( XXM(11).LT.AXMI ) THEN
35721 XXM(11)=1D6
35722 ENDIF
35723 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
35724 LKNT=LKNT+1
35725 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
35726 & PYGAUS(PYXXZ2,S12MIN,S12MAX,PREC)
35727 IDLAM(LKNT,1)=KFCCHI(1)
35728 IDLAM(LKNT,2)=11
35729 IDLAM(LKNT,3)=-11
35730 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
35731 LKNT=LKNT+1
35732 XLAM(LKNT)=XLAM(LKNT-1)
35733 IDLAM(LKNT,1)=KFCCHI(1)
35734 IDLAM(LKNT,2)=13
35735 IDLAM(LKNT,3)=-13
35736 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
35737 LKNT=LKNT+1
35738 XLAM(LKNT)=XLAM(LKNT-1)
35739 IDLAM(LKNT,1)=KFCCHI(1)
35740 IDLAM(LKNT,2)=15
35741 IDLAM(LKNT,3)=-15
35742 ENDIF
35743 ENDIF
35744 ENDIF
35745
35746C...NEUTRINOS
35747 100 CONTINUE
35748 XXM(7)= (0.5D0)/(1D0-XW)
35749 XXM(8)= 0D0
35750 XXM(11)=PMAS(PYCOMP(KSUSY1+11),1)
35751 XXM(12)=UMIX(2,1)*UMIX(1,1)
35752 IF( XXM(11).LT.AXMI ) THEN
35753 XXM(11)=1D6
35754 ENDIF
35755 IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN
35756 LKNT=LKNT+1
35757 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
35758 & PYGAUS(PYXXZ2,S12MIN,S12MAX,PREC)
35759 IDLAM(LKNT,1)=KFCCHI(1)
35760 IDLAM(LKNT,2)=12
35761 IDLAM(LKNT,3)=-12
35762 LKNT=LKNT+1
35763 XLAM(LKNT)=XLAM(LKNT-1)
35764 IDLAM(LKNT,1)=KFCCHI(1)
35765 IDLAM(LKNT,2)=14
35766 IDLAM(LKNT,3)=-14
35767 LKNT=LKNT+1
35768 XLAM(LKNT)=XLAM(LKNT-1)
35769 IDLAM(LKNT,1)=KFCCHI(1)
35770 IDLAM(LKNT,2)=16
35771 IDLAM(LKNT,3)=-16
35772 ENDIF
35773
35774C...D-TYPE QUARKS
35775 110 CONTINUE
35776 XXM(7)= (-0.5D0+XW/3D0)/(1D0-XW)
35777 XXM(8)= XW/3D0/(1D0-XW)
35778 XXM(11)=PMAS(PYCOMP(KSUSY1+2),1)
35779 XXM(12)=VMIX(2,1)*VMIX(1,1)
35780 IF( XXM(11).LT.AXMI ) GOTO 120
35781 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
35782 LKNT=LKNT+1
35783 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
35784 & PYGAUS(PYXXZ2,S12MIN,S12MAX,PREC)
35785 IDLAM(LKNT,1)=KFCCHI(1)
35786 IDLAM(LKNT,2)=1
35787 IDLAM(LKNT,3)=-1
35788 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
35789 LKNT=LKNT+1
35790 XLAM(LKNT)=XLAM(LKNT-1)
35791 IDLAM(LKNT,1)=KFCCHI(1)
35792 IDLAM(LKNT,2)=3
35793 IDLAM(LKNT,3)=-3
35794 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
35795 LKNT=LKNT+1
35796 XLAM(LKNT)=XLAM(LKNT-1)
35797 IDLAM(LKNT,1)=KFCCHI(1)
35798 IDLAM(LKNT,2)=5
35799 IDLAM(LKNT,3)=-5
35800 ENDIF
35801 ENDIF
35802 ENDIF
35803
35804C...U-TYPE QUARKS
35805 120 CONTINUE
35806 XXM(7)= (0.5D0-2D0*XW/3D0)/(1D0-XW)
35807 XXM(8)= -2D0*XW/3D0/(1D0-XW)
35808 XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
35809 XXM(12)=UMIX(2,1)*UMIX(1,1)
35810 IF( XXM(11).LT.AXMI ) GOTO 130
35811 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
35812 LKNT=LKNT+1
35813 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
35814 & PYGAUS(PYXXZ2,S12MIN,S12MAX,PREC)
35815 IDLAM(LKNT,1)=KFCCHI(1)
35816 IDLAM(LKNT,2)=2
35817 IDLAM(LKNT,3)=-2
35818 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
35819 LKNT=LKNT+1
35820 XLAM(LKNT)=XLAM(LKNT-1)
35821 IDLAM(LKNT,1)=KFCCHI(1)
35822 IDLAM(LKNT,2)=4
35823 IDLAM(LKNT,3)=-4
35824 ENDIF
35825 ENDIF
35826 130 CONTINUE
35827 ENDIF
35828
35829C...CHI_2+ -> CHI_1+ + H0_K
35830 EH(2)=COS(ALFA)
35831 EH(1)=SIN(ALFA)
35832 EH(3)=-SBETA
35833 DH(2)=-SIN(ALFA)
35834 DH(1)=COS(ALFA)
35835 DH(3)=COS(BETA)
35836 DO 140 IH=1,3
35837 XMH=PMAS(ITH(IH),1)
35838 XMH2=XMH**2
35839C...NO 3-BODY OPTION
35840 IF(AXMI.GE.AXMJ+XMH) THEN
35841 LKNT=LKNT+1
35842 XL=PYLAMF(XMI2,XMJ2,XMH2)
35843 F21K=(VMIX(2,1)*UMIX(1,2)*EH(IH) -
35844 & VMIX(2,2)*UMIX(1,1)*DH(IH))/SR2
35845 F12K=(VMIX(1,1)*UMIX(2,2)*EH(IH) -
35846 & VMIX(1,2)*UMIX(2,1)*DH(IH))/SR2
35847 XMK=XMJ*ETAH(IH)
35848 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,F12K,F21K)
35849 IDLAM(LKNT,1)=KFCCHI(1)
35850 IDLAM(LKNT,2)=ITH(IH)
35851 IDLAM(LKNT,3)=0
35852 ENDIF
35853 140 CONTINUE
35854
35855C...CHI1 JUMPS TO HERE
35856 150 CONTINUE
35857
35858C...CHI+_I -> CHI0_J + W+
35859 DO 180 IJ=1,4
35860 XMJ=SMZ(IJ)
35861 AXMJ=ABS(XMJ)
35862 XMJ2=XMJ**2
35863 IF(AXMI.GE.AXMJ+XMW) THEN
35864 LKNT=LKNT+1
35865 GL=ZMIX(IJ,2)*VMIX(IX,1)-ZMIX(IJ,4)*VMIX(IX,2)/SR2
35866 GR=ZMIX(IJ,2)*UMIX(IX,1)+ZMIX(IJ,3)*UMIX(IX,2)/SR2
35867 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GL,GR)
35868 IDLAM(LKNT,1)=KFNCHI(IJ)
35869 IDLAM(LKNT,2)=24
35870 IDLAM(LKNT,3)=0
35871
35872C...LEPTONS
35873 ELSEIF(AXMI.GE.AXMJ) THEN
35874 XMF1=0D0
35875 XMF2=0D0
35876 S12MIN=(XMF1+XMF2)**2
35877 S12MAX=(AXMJ-AXMI)**2
35878 XXM(5)=-1D0/SR2*ZMIX(IJ,4)*VMIX(IX,2)+ZMIX(IJ,2)*VMIX(IX,1)
35879 XXM(6)= 1D0/SR2*ZMIX(IJ,3)*UMIX(IX,2)+ZMIX(IJ,2)*UMIX(IX,1)
35880 FID=11
35881 EI=KCHG(FID,1)/3D0
35882 T3=-0.5D0
35883 XXM(7)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))*UMIX(IX,1)
35884 FID=12
35885 EI=KCHG(FID,1)/3D0
35886 T3=0.5D0
35887 XXM(8)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))*VMIX(IX,1)
35888
35889 XXM(4)=XMI
35890 XXM(1)=XMF1
35891 XXM(2)=XMJ
35892 XXM(3)=XMF2
35893 XXM(9)=PMAS(24,1)
35894 XXM(10)=PMAS(24,2)
35895 XXM(11)=PMAS(PYCOMP(KSUSY1+11),1)
35896 XXM(12)=PMAS(PYCOMP(KSUSY1+12),1)
35897
35898C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
35899C...--> 1/(16PI)/M**3*(AEM/XW)**2
35900
35901 IF(XXM(11).LT.AXMI) THEN
35902 XXM(11)=1D6
35903 ENDIF
35904 IF(XXM(12).LT.AXMI) THEN
35905 XXM(12)=1D6
35906 ENDIF
35907 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
35908 LKNT=LKNT+1
35909 TEMP=PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
35910 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
35911 IDLAM(LKNT,1)=KFNCHI(IJ)
35912 IDLAM(LKNT,2)=-11
35913 IDLAM(LKNT,3)=12
35914
35915C...ONLY DECAY CHI+1 -> E+ NU_E
35916 IF( IMSS(12).NE. 0 ) GOTO 220
35917 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
35918 LKNT=LKNT+1
35919 XXM(11)=PMAS(PYCOMP(KSUSY1+13),1)
35920 XXM(12)=PMAS(PYCOMP(KSUSY1+14),1)
35921 IF(XXM(11).LT.AXMI) THEN
35922 XXM(11)=1D6
35923 ELSEIF(XXM(12).LT.AXMI) THEN
35924 XXM(12)=1D6
35925 ENDIF
35926 TEMP=PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
35927 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
35928 IDLAM(LKNT,1)=KFNCHI(IJ)
35929 IDLAM(LKNT,2)=-13
35930 IDLAM(LKNT,3)=14
35931 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
35932 LKNT=LKNT+1
35933 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
35934 XXM(11)=PMAS(PYCOMP(KSUSY1+15),1)
35935 ELSE
35936 XXM(11)=PMAS(PYCOMP(KSUSY2+15),1)
35937 ENDIF
35938 XXM(12)=PMAS(PYCOMP(KSUSY1+16),1)
35939 IF(XXM(11).LT.AXMI) THEN
35940 XXM(11)=1D6
35941 ENDIF
35942 IF(XXM(12).LT.AXMI) THEN
35943 XXM(12)=1D6
35944 ENDIF
35945 TEMP=PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
35946 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
35947 IDLAM(LKNT,1)=KFNCHI(IJ)
35948 IDLAM(LKNT,2)=-15
35949 IDLAM(LKNT,3)=16
35950 ENDIF
35951 ENDIF
35952 ENDIF
35953
35954C...NOW, DO THE QUARKS
35955 160 CONTINUE
35956 FID=1
35957 EI=KCHG(FID,1)/3D0
35958 T3=-0.5D0
35959 XXM(7)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))*UMIX(IX,1)
35960 FID=1
35961 EI=KCHG(FID,1)/3D0
35962 T3=0.5D0
35963 XXM(8)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))*VMIX(IX,1)
35964
35965 XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
35966 XXM(12)=PMAS(PYCOMP(KSUSY1+2),1)
35967 IF( XXM(11).LT.AXMI .AND. XXM(12).LT.AXMI ) GOTO 170
35968 IF(XXM(11).LT.AXMI) THEN
35969 XXM(11)=1D6
35970 ELSEIF(XXM(12).LT.AXMI) THEN
35971 XXM(12)=1D6
35972 ENDIF
35973 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
35974 LKNT=LKNT+1
35975 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
35976 & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
35977 IDLAM(LKNT,1)=KFNCHI(IJ)
35978 IDLAM(LKNT,2)=-1
35979 IDLAM(LKNT,3)=2
35980 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
35981 LKNT=LKNT+1
35982 XLAM(LKNT)=XLAM(LKNT-1)
35983 IDLAM(LKNT,1)=KFNCHI(IJ)
35984 IDLAM(LKNT,2)=-3
35985 IDLAM(LKNT,3)=4
35986 ENDIF
35987 ENDIF
35988 170 CONTINUE
35989 ENDIF
35990 180 CONTINUE
35991
35992C...CHI+_I -> CHI0_J + H+
35993 DO 190 IJ=1,4
35994 XMJ=SMZ(IJ)
35995 AXMJ=ABS(XMJ)
35996 XMJ2=XMJ**2
35997 XMHP=PMAS(ITHC,1)
35998 XMHP2=XMHP**2
35999 IF(AXMI.GE.AXMJ+XMHP) THEN
36000 LKNT=LKNT+1
36001 GL=CBETA*(ZMIX(IJ,4)*VMIX(IX,1)+(ZMIX(IJ,2)+
36002 & ZMIX(IJ,1)*TANW)*VMIX(IX,2)/SR2)
36003 GR=SBETA*(ZMIX(IJ,3)*UMIX(IX,1)-(ZMIX(IJ,2)+
36004 & ZMIX(IJ,1)*TANW)*UMIX(IX,2)/SR2)
36005 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GL,GR)
36006 IDLAM(LKNT,1)=KFNCHI(IJ)
36007 IDLAM(LKNT,2)=ITHC
36008 IDLAM(LKNT,3)=0
36009 ELSE
36010
36011 ENDIF
36012 190 CONTINUE
36013
36014C...2-BODY DECAYS TO FERMION SFERMION
36015 DO 200 J=1,16
36016 IF(J.GE.7.AND.J.LE.10) GOTO 200
36017 IF(MOD(J,2).EQ.0) THEN
36018 KF1=KSUSY1+J-1
36019 ELSE
36020 KF1=KSUSY1+J+1
36021 ENDIF
36022 KF2=KF1+KSUSY1
36023 XMSF1=PMAS(PYCOMP(KF1),1)
36024 XMSF2=PMAS(PYCOMP(KF2),1)
36025 XMF=PMAS(J,1)
36026 IF(J.LE.6) THEN
36027 FCOL=3D0
36028 ELSE
36029 FCOL=1D0
36030 ENDIF
36031
36032C...U~ D_L
36033 IF(MOD(J,2).EQ.0) THEN
36034 XMFP=PMAS(J-1,1)
36035 AL=UMIX(IX,1)
36036 BL=-XMF*VMIX(IX,2)/XMW/SBETA/SR2
36037 AR=-XMFP*UMIX(IX,2)/XMW/CBETA/SR2
36038 BR=0D0
36039 ISF=J-1
36040 ELSE
36041 XMFP=PMAS(J+1,1)
36042 AL=VMIX(IX,1)
36043 BL=-XMF*UMIX(IX,2)/XMW/CBETA/SR2
36044 BR=0D0
36045 AR=-XMFP*VMIX(IX,2)/XMW/SBETA/SR2
36046 ISF=J+1
36047 ENDIF
36048
36049C...~U_L D
36050 IF(AXMI.GE.XMF+XMSF1) THEN
36051 LKNT=LKNT+1
36052 XMA2=XMSF1**2
36053 XMB2=XMF**2
36054 XL=PYLAMF(XMI2,XMA2,XMB2)
36055 CA=AL*SFMIX(ISF,1)+AR*SFMIX(ISF,2)
36056 CB=BL*SFMIX(ISF,1)+BR*SFMIX(ISF,2)
36057 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
36058 & (CA**2+CB**2)+4D0*CA*CB*XMF*XMI)
36059 IDLAM(LKNT,3)=0
36060 IF(MOD(J,2).EQ.0) THEN
36061 IDLAM(LKNT,1)=-KF1
36062 IDLAM(LKNT,2)=J
36063 ELSE
36064 IDLAM(LKNT,1)=KF1
36065 IDLAM(LKNT,2)=-J
36066 ENDIF
36067 ENDIF
36068
36069C...U~ D_R
36070 IF(AXMI.GE.XMF+XMSF2) THEN
36071 LKNT=LKNT+1
36072 XMA2=XMSF2**2
36073 XMB2=XMF**2
36074 CA=AL*SFMIX(ISF,3)+AR*SFMIX(ISF,4)
36075 CB=BL*SFMIX(ISF,3)+BR*SFMIX(ISF,4)
36076 XL=PYLAMF(XMI2,XMA2,XMB2)
36077 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
36078 & (CA**2+CB**2)+4D0*CA*CB*XMF*XMI)
36079 IDLAM(LKNT,3)=0
36080 IF(MOD(J,2).EQ.0) THEN
36081 IDLAM(LKNT,1)=-KF2
36082 IDLAM(LKNT,2)=J
36083 ELSE
36084 IDLAM(LKNT,1)=KF2
36085 IDLAM(LKNT,2)=-J
36086 ENDIF
36087 ENDIF
36088 200 CONTINUE
36089
36090C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
36091C...A 2-BODY -- 2-BODY CHAIN
36092 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
36093 IF(AXMI.GE.XMJ) THEN
36094 AXMJ=ABS(XMJ)
36095 S12MIN=0D0
36096 S12MAX=(AXMI-AXMJ)**2
36097 XXM(1)=0D0
36098 XXM(2)=XMJ
36099 XXM(3)=0D0
36100 XXM(4)=XMI
36101 XXM(5)=0D0
36102 XXM(6)=0D0
36103 XXM(9)=1D6
36104 XXM(10)=0D0
36105 XXM(7)=UMIX(IX,1)*SR2
36106 XXM(8)=VMIX(IX,1)*SR2
36107 XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
36108 XXM(12)=PMAS(PYCOMP(KSUSY1+2),1)
36109 IF( XXM(11).LT.AXMI .OR. XXM(12).LT.AXMI ) GOTO 210
36110 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
36111 LKNT=LKNT+1
36112 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
36113 & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
36114 IDLAM(LKNT,1)=KSUSY1+21
36115 IDLAM(LKNT,2)=-1
36116 IDLAM(LKNT,3)=2
36117 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
36118 LKNT=LKNT+1
36119 XLAM(LKNT)=XLAM(LKNT-1)
36120 IDLAM(LKNT,1)=KSUSY1+21
36121 IDLAM(LKNT,2)=-3
36122 IDLAM(LKNT,3)=4
36123 ENDIF
36124 ENDIF
36125 210 CONTINUE
36126 ENDIF
36127
36128 220 IKNT=LKNT
36129 XLAM(0)=0D0
36130 DO 230 I=1,IKNT
36131 XLAM(0)=XLAM(0)+XLAM(I)
36132 IF(XLAM(I).LT.0D0) THEN
36133 WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN,
36134 & (IDLAM(I,J),J=1,3)
36135 XLAM(I)=0D0
36136 ENDIF
36137 230 CONTINUE
36138 IF(XLAM(0).EQ.0D0) THEN
36139 XLAM(0)=1D-6
36140 WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0)
36141 WRITE(MSTU(11),*) LKNT
36142 WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT)
36143 ENDIF
36144
36145 RETURN
36146 END
36147
36148C*********************************************************************
36149
36150C...PYXXZ5
36151C...Calculates chi0 -> chi0 + f + ~f.
36152
36153 FUNCTION PYXXZ5(X)
36154
36155C...Double precision and integer declarations.
36156 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36157 IMPLICIT INTEGER(I-N)
36158 INTEGER PYK,PYCHGE,PYCOMP
36159C...Parameter statement to help give large particle numbers.
36160 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
36161C...Commonblocks.
36162 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36163 COMMON/PYINTS/XXM(20)
36164 SAVE /PYDAT1/,/PYINTS/
36165
36166C...Local variables.
36167 DOUBLE PRECISION PYXXZ5,X
36168 DOUBLE PRECISION XM12,XM22,XM32,S,S23,S13,WPROP2
36169 DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
36170 DOUBLE PRECISION SIJ
36171 DOUBLE PRECISION SR2,OL,OR,FLD,FLU,XMV,XMG,XMSU,XMSD
36172 DOUBLE PRECISION LE,RE,LE2,RE2,OL2,OR2,FLI,FLJ,FRI,FRJ
36173 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
36174 INTEGER I
36175 DATA SR2/1.4142136D0/
36176
36177C...Statement functions.
36178C...Integral from x to y of (t-a)(b-t) dt.
36179 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
36180C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
36181 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
36182 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
36183C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
36184 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
36185 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
36186C...Integral from x to y of (t-a)/(b-t) dt.
36187 UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
36188C...Integral from x to y of 1/(t-a) dt.
36189 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
36190
36191 XM12=XXM(1)**2
36192 XM22=XXM(2)**2
36193 XM32=XXM(3)**2
36194 S=XXM(4)**2
36195 S13=X
36196
36197 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
36198 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
36199 &( (X-XM22-S)**2 -4D0*XM22*S ) )
36200
36201 S23MIN=(S23AVE-S23DEL)
36202 S23MAX=(S23AVE+S23DEL)
36203
36204 XMV=XXM(7)
36205 XMG=XXM(8)
36206 XMSD=XXM(5)**2
36207 XMSU=XXM(6)**2
36208 OL=XXM(9)
36209 OR=XXM(10)
36210 OL2=OL**2
36211 OR2=OR**2
36212 LE=XXM(11)
36213 RE=XXM(12)
36214 LE2=LE**2
36215 RE2=RE**2
36216 FLI=XXM(13)
36217 FLJ=XXM(14)
36218 FRI=XXM(15)
36219 FRJ=XXM(16)
36220
36221 WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
36222 SIJ=2D0*XXM(2)*XXM(4)*S13
36223
36224 IF(XMV.LE.1000D0) THEN
36225 WW=2D0*(LE2+RE2)*(OL2)*( 2D0*TINT(S23MAX,S23MIN,XM22,S)
36226 & +SIJ*(S23MAX-S23MIN) )/WPROP2
36227 IF(XXM(5).LE.10000D0) THEN
36228 WFL1=2D0*FLI*FLJ*OL*LE*( 2D0*TINT2(S23MAX,S23MIN,XM22,S,XMSD)
36229 & + SIJ*TPROP(S23MAX,S23MIN,XMSD) )
36230 WFL1=WFL1*(S13-XMV**2)/WPROP2
36231 ELSE
36232 WFL1=0D0
36233 ENDIF
36234 IF(XXM(6).LE.10000D0) THEN
36235 WFL2=2D0*FRI*FRJ*OR*RE*( 2D0*TINT2(S23MAX,S23MIN,XM22,S,XMSU)
36236 & + SIJ*TPROP(S23MAX,S23MIN,XMSU) )
36237 WFL2=WFL2*(S13-XMV**2)/WPROP2
36238 ELSE
36239 WFL2=0D0
36240 ENDIF
36241 ELSE
36242 WW=0D0
36243 WFL1=0D0
36244 WFL2=0D0
36245 ENDIF
36246 IF(XXM(5).LE.10000D0) THEN
36247 WF1=0.5D0*(FLI*FLJ)**2*( 2D0*TINT3(S23MAX,S23MIN,XM22,S,XMSD)
36248 & + SIJ*UTINT(S23MAX,S23MIN,XMSD,XM22+S-S13-XMSD) )
36249 ELSE
36250 WF1=0D0
36251 ENDIF
36252 IF(XXM(6).LE.10000D0) THEN
36253 WF2=0.5D0*(FRI*FRJ)**2*( 2D0*TINT3(S23MAX,S23MIN,XM22,S,XMSU)
36254 & + SIJ*UTINT(S23MAX,S23MIN,XMSU,XM22+S-S13-XMSU) )
36255 ELSE
36256 WF2=0D0
36257 ENDIF
36258
36259C...WFL1=0.0
36260C...WFL2=0.0
36261 PYXXZ5=(WW+WF1+WF2+WFL1+WFL2)
36262 IF(PYXXZ5.LT.0D0) THEN
36263 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ5 '
36264 WRITE(MSTU(11),*) XXM(1),XXM(2),XXM(3),XXM(4)
36265 WRITE(MSTU(11),*) (XXM(I),I=5,8)
36266 WRITE(MSTU(11),*) (XXM(I),I=9,12)
36267 WRITE(MSTU(11),*) (XXM(I),I=13,16)
36268 WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2
36269 WRITE(MSTU(11),*) S23MIN,S23MAX
36270 PYXXZ5=0D0
36271 ENDIF
36272
36273 RETURN
36274 END
36275
36276C*********************************************************************
36277
36278C...PYXXW5
36279C...Calculates chi0(+) -> chi+(0) + f + ~f'.
36280
36281 FUNCTION PYXXW5(X)
36282
36283C...Double precision and integer declarations.
36284 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36285 IMPLICIT INTEGER(I-N)
36286 INTEGER PYK,PYCHGE,PYCOMP
36287C...Parameter statement to help give large particle numbers.
36288 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
36289C...Commonblocks.
36290 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36291 COMMON/PYINTS/XXM(20)
36292 SAVE /PYDAT1/,/PYINTS/
36293
36294C...Local variables.
36295 DOUBLE PRECISION PYXXW5,X
36296 DOUBLE PRECISION XM12,XM22,XM32,S,S23,S13,S12,WPROP2
36297 DOUBLE PRECISION WW,WU,WD,WWU,WWD,WUD
36298 DOUBLE PRECISION SR2,OL,OR,FLD,FLU,XMV,XMG,XMSD,XMSU
36299 DOUBLE PRECISION SIJ
36300 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
36301 INTEGER IK
36302 SAVE IK
36303 DATA IK/0/
36304 DATA SR2/1.4142136D0/
36305
36306C...Statement functions.
36307C...Integral from x to y of (t-a)(b-t) dt.
36308 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
36309C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
36310 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
36311 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
36312C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
36313 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
36314 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
36315C...Integral from x to y of (t-a)/(b-t) dt.
36316 UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
36317C...Integral from x to y of 1/(t-a) dt.
36318 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
36319
36320 XM12=XXM(1)**2
36321 XM22=XXM(2)**2
36322 XM32=XXM(3)**2
36323 S=XXM(4)**2
36324 S13=X
36325 IF(XXM(1).EQ.0.AND.XXM(3).EQ.0D0) THEN
36326 S23AVE=0.5D0*(XM22+S-S13)
36327 S23DEL=0.5D0*SQRT( (X-XM22-S)**2-4D0*XM22*S )
36328 ELSE
36329 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
36330 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
36331 & ( (X-XM22-S)**2 -4D0*XM22*S ) )
36332 ENDIF
36333 S23MIN=(S23AVE-S23DEL)
36334 S23MAX=(S23AVE+S23DEL)
36335 IF(S23DEL.LT.1D-3) THEN
36336 PYXXW5=0D0
36337 RETURN
36338 ENDIF
36339 XMV=XXM(9)
36340 XMG=XXM(10)
36341 XMSD=XXM(11)**2
36342 XMSU=XXM(12)**2
36343 OL=XXM(5)
36344 OR=XXM(6)
36345 FLD=XXM(7)
36346 FLU=XXM(8)
36347
36348 WPROP2=((S13-XMV**2)**2+(XMV*XMG)**2)
36349 SIJ=S13*XXM(2)*XXM(4)
36350 IF(XMV.LE.1000D0) THEN
36351 WW=(OR**2+OL**2)*TINT(S23MAX,S23MIN,XM22,S)
36352 & -2D0*OL*OR*SIJ*(S23MAX-S23MIN)
36353 WW=WW/WPROP2
36354 IF(XXM(11).LE.10000D0) THEN
36355 WWD=OL*SIJ*TPROP(S23MAX,S23MIN,XMSD)
36356 & -OR*TINT2(S23MAX,S23MIN,XM22,S,XMSD)
36357 WWD=-WWD*SR2*FLD
36358 WWD=WWD*(S13-XMV**2)/WPROP2
36359 ELSE
36360 WWD=0D0
36361 ENDIF
36362 IF(XXM(12).LE.10000D0) THEN
36363 WWU=OR*SIJ*TPROP(S23MAX,S23MIN,XMSU)
36364 & -OL*TINT2(S23MAX,S23MIN,XM22,S,XMSU)
36365 WWU=WWU*SR2*FLU
36366 WWU=WWU*(S13-XMV**2)/WPROP2
36367 ELSE
36368 WWU=0D0
36369 ENDIF
36370 ELSE
36371 WW=0D0
36372 WWD=0D0
36373 WWU=0D0
36374 ENDIF
36375 IF(XXM(12).LE.10000D0) THEN
36376 WU=0.5D0*FLU**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU)
36377 ELSE
36378 WU=0D0
36379 ENDIF
36380 IF(XXM(11).LE.10000D0) THEN
36381 WD=0.5D0*FLD**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD)
36382 ELSE
36383 WD=0D0
36384 ENDIF
36385 IF(XXM(11).LE.10000D0.AND.XXM(12).LE.10000D0) THEN
36386 WUD=FLU*FLD*SIJ*UTINT(S23MAX,S23MIN,XMSD,XM22+S-S13-XMSU)
36387 ELSE
36388 WUD=0D0
36389 ENDIF
36390
36391 PYXXW5=WW+WU+WD+WWU+WWD+WUD
36392
36393 IF(PYXXW5.LT.0D0) THEN
36394 IF(IK.EQ.0) THEN
36395 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXW5 '
36396 WRITE(MSTU(11),*) WW,WU,WD
36397 WRITE(MSTU(11),*) WWD,WWU,WUD
36398 WRITE(MSTU(11),*) SQRT(S13)
36399 WRITE(MSTU(11),*) TINT(S23MAX,S23MIN,XM22,S)
36400 IK=1
36401 ENDIF
36402 PYXXW5=0D0
36403 ENDIF
36404
36405 RETURN
36406 END
36407
36408C*********************************************************************
36409
36410C...PYXXGA
36411C...Calculates chi0_i -> chi0_j + gamma.
36412
36413 FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL)
36414
36415C...Double precision and integer declarations.
36416 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36417 IMPLICIT INTEGER(I-N)
36418 INTEGER PYK,PYCHGE,PYCOMP
36419
36420C...Local variables.
36421 DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
36422 DOUBLE PRECISION F1,F2
36423
36424 F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR)
36425 F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL)
36426 PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3
36427 PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2
36428
36429 RETURN
36430 END
36431
36432C*********************************************************************
36433
36434C...PYX2XG
36435C...Calculates the decay rate for ino -> ino + gauge boson.
36436
36437 FUNCTION PYX2XG(C1,XM1,XM2,XM3,GL,GR)
36438
36439C...Double precision and integer declarations.
36440 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36441 IMPLICIT INTEGER(I-N)
36442 INTEGER PYK,PYCHGE,PYCOMP
36443
36444C...Local variables.
36445 DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GL,GR
36446 DOUBLE PRECISION XL,PYLAMF,C1
36447 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
36448
36449 XMI2=XM1**2
36450 XMI3=ABS(XM1**3)
36451 XMJ2=XM2**2
36452 XMV2=XM3**2
36453 XL=PYLAMF(XMI2,XMJ2,XMV2)
36454 PYX2XG=C1/8D0/XMI3*SQRT(XL)
36455 &*((GL**2+GR**2)*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))-
36456 &12D0*GL*GR*XM1*XM2*XMV2)
36457
36458 RETURN
36459 END
36460
36461C*********************************************************************
36462
36463C...PYX2XH
36464C...Calculates the decay rate for ino -> ino + H.
36465
36466 FUNCTION PYX2XH(C1,XM1,XM2,XM3,GL,GR)
36467
36468C...Double precision and integer declarations.
36469 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36470 IMPLICIT INTEGER(I-N)
36471 INTEGER PYK,PYCHGE,PYCOMP
36472
36473C...Local variables.
36474 DOUBLE PRECISION PYX2XH,XM1,XM2,XM3,GL,GR
36475 DOUBLE PRECISION XL,PYLAMF,C1
36476 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
36477
36478 XMI2=XM1**2
36479 XMI3=ABS(XM1**3)
36480 XMJ2=XM2**2
36481 XMV2=XM3**2
36482 XL=PYLAMF(XMI2,XMJ2,XMV2)
36483 PYX2XH=C1/8D0/XMI3*SQRT(XL)
36484 &*((GL**2+GR**2)*(XMI2+XMJ2-XMV2)+
36485 &4D0*GL*GR*XM1*XM2)
36486
36487 RETURN
36488 END
36489
36490C*********************************************************************
36491
36492C...PYXXZ2
36493C...Calculates chi+ -> chi+ + f + ~f.
36494
36495 FUNCTION PYXXZ2(X)
36496
36497C...Double precision and integer declarations.
36498 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36499 IMPLICIT INTEGER(I-N)
36500 INTEGER PYK,PYCHGE,PYCOMP
36501C...Parameter statement to help give large particle numbers.
36502 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
36503C...Commonblocks.
36504 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36505 COMMON/PYINTS/XXM(20)
36506 SAVE /PYDAT1/,/PYINTS/
36507
36508C...Local variables.
36509 DOUBLE PRECISION PYXXZ2,X
36510 DOUBLE PRECISION XM12,XM22,XM32,S,S23,S13,S12,WPROP2
36511 DOUBLE PRECISION WW,WU,WD,WWU,WWD,WUD
36512 DOUBLE PRECISION SR2,OL,OR,FLD,FLU,XMV,XMG,XMSL
36513 DOUBLE PRECISION SIJ
36514 DOUBLE PRECISION LE,RE,LE2,RE2,OL2,OR2,CT
36515 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
36516 INTEGER I
36517 DATA SR2/1.4142136D0/
36518
36519C...Statement functions.
36520C...Integral from x to y of (t-a)(b-t) dt.
36521 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
36522C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
36523 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
36524 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
36525C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
36526 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
36527 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
36528C...Integral from x to y of 1/(t-a) dt.
36529 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
36530
36531 XM12=XXM(1)**2
36532 XM22=XXM(2)**2
36533 XM32=XXM(3)**2
36534 S=XXM(4)**2
36535 S13=X
36536 IF(XXM(1).EQ.0.AND.XXM(3).EQ.0D0) THEN
36537 S23AVE=0.5D0*(XM22+S-S13)
36538 S23DEL=0.5D0*SQRT( (X-XM22-S)**2-4D0*XM22*S )
36539 ELSE
36540 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
36541 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
36542 & ( (X-XM22-S)**2 -4D0*XM22*S ) )
36543 ENDIF
36544 S23MIN=(S23AVE-S23DEL)
36545 S23MAX=(S23AVE+S23DEL)
36546 IF(S23DEL.LT.1D-3) THEN
36547 PYXXZ2=0D0
36548 RETURN
36549 ENDIF
36550
36551 XMV=XXM(9)
36552 XMG=XXM(10)
36553 XMSL=XXM(11)**2
36554 OL=XXM(5)
36555 OR=XXM(6)
36556 OL2=OL**2
36557 OR2=OR**2
36558 LE=XXM(7)
36559 RE=XXM(8)
36560 LE2=LE**2
36561 RE2=RE**2
36562 CT=XXM(12)
36563
36564 WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
36565 SIJ=XXM(2)*XXM(4)*S13
36566 WW=(LE2+RE2)*(OR2+OL2)*2D0*TINT(S23MAX,S23MIN,XM22,S)
36567 &- 4D0*(LE2+RE2)*OL*OR*SIJ*(S23MAX-S23MIN)
36568 WW=WW/WPROP2
36569 IF(XMSL.GT.1D4*S) THEN
36570 WD=0D0
36571 WWD=0D0
36572 ELSE
36573 WD=0.5D0*CT**2*TINT3(S23MAX,S23MIN,XM22,S,XMSL)
36574 WWD=OL*TINT2(S23MAX,S23MIN,XM22,S,XMSL)-
36575 & OR*SIJ*TPROP(S23MAX,S23MIN,XMSL)
36576 WWD=2D0*WWD*LE*CT*(S13-XMV**2)/WPROP2
36577 ENDIF
36578
36579 PYXXZ2=(WW+WD+WWD)
36580 IF(PYXXZ2.LT.0D0) THEN
36581 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ2 '
36582 WRITE(MSTU(11),*) WW,WD,WWD
36583 WRITE(MSTU(11),*) S23MIN,S23MAX
36584 WRITE(MSTU(11),*) (XXM(I),I=1,4)
36585 WRITE(MSTU(11),*) (XXM(I),I=5,8)
36586 WRITE(MSTU(11),*) (XXM(I),I=9,12)
36587 PYXXZ2=0D0
36588 ENDIF
36589
36590 RETURN
36591 END
36592
36593C*********************************************************************
36594
36595C...PYHEXT
36596C...Calculates the non-standard decay modes of the Higgs boson.
36597
36598 SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT)
36599
36600C...Double precision and integer declarations.
36601 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36602 IMPLICIT INTEGER(I-N)
36603 INTEGER PYK,PYCHGE,PYCOMP
36604C...Parameter statement to help give large particle numbers.
36605 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
36606C...Commonblocks.
36607 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36608 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36609 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
36610 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
36611 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
36612 &SFMIX(16,4)
36613 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/
36614
36615C...Local variables.
36616 INTEGER KFIN
36617 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
36618 &XMZ,XMZ2,AXMJ,AXMI
36619 DOUBLE PRECISION XMFP,XMF1,XMF2,XMSL,XMG
36620 DOUBLE PRECISION S12MIN,S12MAX
36621 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMHP2,XMA2,XMB2
36622 DOUBLE PRECISION PYLAMF,XL,CF,EI
36623 INTEGER IDU,IC,ILR,IFL
36624 DOUBLE PRECISION TANW,XW,AEM,C1,AS
36625 DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
36626 DOUBLE PRECISION XLAM(0:200)
36627 INTEGER IDLAM(200,3)
36628 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,IK
36629 INTEGER ITH(4)
36630 INTEGER KFNCHI(4),KFCCHI(2)
36631 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
36632 DOUBLE PRECISION SR2
36633 DOUBLE PRECISION BETA,ALFA
36634 DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K,TANB
36635 DOUBLE PRECISION PYALEM,PI,PYALPS
36636 DOUBLE PRECISION AL,BL,AR,BR,ALP,ARP,BLP,BRP,ALR
36637 DOUBLE PRECISION XMK,AXMK,XMK2,COSA,SINA,CW,XML
36638 DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
36639 DOUBLE PRECISION XMJL,XMJR,XM1,XM2
36640 DATA ITH/25,35,36,37/
36641 DATA ETAH/1D0,1D0,-1D0/
36642 DATA SR2/1.4142136D0/
36643 DATA PI/3.141592654D0/
36644 DATA KFNCHI/1000022,1000023,1000025,1000035/
36645 DATA KFCCHI/1000024,1000037/
36646
36647C...COUNT THE NUMBER OF DECAY MODES
36648 LKNT=IKNT
36649
36650 XMW=PMAS(24,1)
36651 XMW2=XMW**2
36652 XMZ=PMAS(23,1)
36653 XMZ2=XMZ**2
36654 XW=PARU(102)
36655 TANW = SQRT(XW/(1D0-XW))
36656 CW=SQRT(1D0-XW)
36657
36658C...1 - 4 DEPENDING ON Higgs species.
36659 IH=1
36660 IF(KFIN.EQ.ITH(2)) IH=2
36661 IF(KFIN.EQ.ITH(3)) IH=3
36662 IF(KFIN.EQ.ITH(4)) IH=4
36663
36664 XMI=PMAS(KFIN,1)
36665 XMI2=XMI**2
36666 AXMI=ABS(XMI)
36667 AEM=PYALEM(XMI2)
36668 AS =PYALPS(XMI2)
36669 C1=AEM/XW
36670 XMI3=ABS(XMI**3)
36671
36672 TANB=RMSS(5)
36673 BETA=ATAN(TANB)
36674 CBETA=COS(BETA)
36675 SBETA=TANB*CBETA
36676 ALFA=RMSS(18)
36677 COSA=COS(ALFA)
36678 SINA=SIN(ALFA)
36679 ATRIT=RMSS(16)
36680 ATRIB=RMSS(15)
36681 ATRIL=RMSS(17)
36682 XMUZ=-RMSS(4)
36683
36684 IF(IH.EQ.4) GOTO 180
36685
36686C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
36687C...H0_K -> CHI0_I + CHI0_J
36688 EH(1)=SINA
36689 EH(2)=COSA
36690 EH(3)=-SBETA
36691 DH(1)=COSA
36692 DH(2)=-SINA
36693 DH(3)=CBETA
36694 DO 110 IJ=1,4
36695 XMJ=SMZ(IJ)
36696 AXMJ=ABS(XMJ)
36697 DO 100 IK=1,IJ
36698 XMK=SMZ(IK)
36699 AXMK=ABS(XMK)
36700 IF(AXMI.GE.AXMJ+AXMK) THEN
36701 LKNT=LKNT+1
36702 F21K=0.5D0*
36703 & EH(IH)*( ZMIX(IK,3)*ZMIX(IJ,2)+ZMIX(IJ,3)*ZMIX(IK,2)
36704 & -TANW*(ZMIX(IK,3)*ZMIX(IJ,1)+ZMIX(IJ,3)*ZMIX(IK,1)) )+
36705 & 0.5D0*DH(IH)*( ZMIX(IK,4)*ZMIX(IJ,2)+ZMIX(IJ,4)*ZMIX(IK,2)
36706 & -TANW*(ZMIX(IK,4)*ZMIX(IJ,1)+ZMIX(IJ,4)*ZMIX(IK,1)) )
36707 F12K=0.5D0*
36708 & EH(IH)*(ZMIX(IJ,3)*ZMIX(IK,2)+ZMIX(IK,3)*ZMIX(IJ,2)
36709 & -TANW*(ZMIX(IJ,3)*ZMIX(IK,1)+ZMIX(IK,3)*ZMIX(IJ,1)))+
36710 & 0.5D0*DH(IH)*( ZMIX(IJ,4)*ZMIX(IK,2)+ZMIX(IK,4)*ZMIX(IJ,2)
36711 & -TANW*(ZMIX(IJ,4)*ZMIX(IK,1)+ZMIX(IK,4)*ZMIX(IJ,1)) )
36712C...SIGN OF MASSES I,J
36713 XML=XMK*ETAH(IH)
36714 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,F12K,F21K)
36715 IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0
36716 IDLAM(LKNT,1)=KFNCHI(IJ)
36717 IDLAM(LKNT,2)=KFNCHI(IK)
36718 IDLAM(LKNT,3)=0
36719 ENDIF
36720 100 CONTINUE
36721 110 CONTINUE
36722
36723C...H0_K -> CHI+_I CHI-_J
36724 DO 130 IJ=1,2
36725 XMJ=SMW(IJ)
36726 AXMJ=ABS(XMJ)
36727 DO 120 IK=1,2
36728 XMK=SMW(IK)
36729 AXMK=ABS(XMK)
36730 IF(AXMI.GE.AXMJ+AXMK) THEN
36731 LKNT=LKNT+1
36732 F21K=(VMIX(IJ,1)*UMIX(IK,2)*EH(IH) -
36733 & VMIX(IJ,2)*UMIX(IK,1)*DH(IH))/SR2
36734 F12K=(VMIX(IK,1)*UMIX(IJ,2)*EH(IH) -
36735 & VMIX(IK,2)*UMIX(IJ,1)*DH(IH))/SR2
36736 XML=-XMK*ETAH(IH)
36737 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,F12K,F21K)
36738 IDLAM(LKNT,1)=KFCCHI(IJ)
36739 IDLAM(LKNT,2)=-KFCCHI(IK)
36740 IDLAM(LKNT,3)=0
36741 ENDIF
36742 120 CONTINUE
36743 130 CONTINUE
36744
36745C...HIGGS TO SFERMION SFERMION
36746 DO 160 IFL=1,16
36747 IF(IFL.GE.7.AND.IFL.LE.10) GOTO 160
36748 IJ=KSUSY1+IFL
36749 XMJL=PMAS(PYCOMP(IJ),1)
36750 XMJR=PMAS(PYCOMP(IJ+KSUSY1),1)
36751 IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN
36752 XMJ=XMJL
36753 XMJ2=XMJ**2
36754 XL=PYLAMF(XMI2,XMJ2,XMJ2)
36755 XMF=PMAS(IFL,1)
36756 EI=KCHG(IFL,1)/3D0
36757 IDU=2-MOD(IFL,2)
36758
36759 IF(IH.EQ.1) THEN
36760 IF(IDU.EQ.1) THEN
36761 GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+
36762 & XMF**2/XMW*SINA/CBETA
36763 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+
36764 & XMF**2/XMW*SINA/CBETA
36765 IF(IFL.EQ.5) THEN
36766 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
36767 & ATRIB*SINA)
36768 ELSEIF(IFL.EQ.15) THEN
36769 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
36770 & ATRIL*SINA)
36771 ELSE
36772 GHLR=0D0
36773 ENDIF
36774 ELSE
36775 GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)-
36776 & XMF**2/XMW*COSA/SBETA
36777 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)-
36778 & XMF**2/XMW*COSA/SBETA
36779 IF(IFL.EQ.6) THEN
36780 GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA-
36781 & ATRIT*COSA)
36782 ELSE
36783 GHLR=0D0
36784 ENDIF
36785 ENDIF
36786
36787 ELSEIF(IH.EQ.2) THEN
36788 IF(IDU.EQ.1) THEN
36789 GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)-
36790 & XMF**2/XMW*COSA/CBETA
36791 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
36792 & XMF**2/XMW*COSA/CBETA
36793 IF(IFL.EQ.5) THEN
36794 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
36795 & ATRIB*COSA)
36796 ELSEIF(IFL.EQ.15) THEN
36797 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
36798 & ATRIL*COSA)
36799 ELSE
36800 GHLR=0D0
36801 ENDIF
36802 ELSE
36803 GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)-
36804 & XMF**2/XMW*SINA/SBETA
36805 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
36806 & XMF**2/XMW*SINA/SBETA
36807 IF(IFL.EQ.6) THEN
36808 GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+
36809 & ATRIT*SINA)
36810 ELSE
36811 GHLR=0D0
36812 ENDIF
36813 ENDIF
36814
36815 ELSEIF(IH.EQ.3) THEN
36816 GHLL=0D0
36817 GHRR=0D0
36818 GHLR=0D0
36819 IF(IDU.EQ.1) THEN
36820 IF(IFL.EQ.5) THEN
36821 GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ)
36822 ELSEIF(IFL.EQ.15) THEN
36823 GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ)
36824 ENDIF
36825 ELSE
36826 IF(IFL.EQ.6) THEN
36827 GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ)
36828 ENDIF
36829 ENDIF
36830 ENDIF
36831 IF(IH.EQ.3) GOTO 140
36832
36833 AL=SFMIX(IFL,1)**2
36834 AR=SFMIX(IFL,2)**2
36835 ALR=SFMIX(IFL,1)*SFMIX(IFL,2)
36836 IF(IFL.LE.6) THEN
36837 CF=3D0
36838 ELSE
36839 CF=1D0
36840 ENDIF
36841
36842 IF(AXMI.GE.2D0*XMJ) THEN
36843 LKNT=LKNT+1
36844 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
36845 & (GHLL*AL+GHRR*AR
36846 & +2D0*GHLR*ALR)**2
36847 IDLAM(LKNT,1)=IJ
36848 IDLAM(LKNT,2)=-IJ
36849 IDLAM(LKNT,3)=0
36850 ENDIF
36851
36852 IF(AXMI.GE.2D0*XMJR) THEN
36853 LKNT=LKNT+1
36854 AL=SFMIX(IFL,3)**2
36855 AR=SFMIX(IFL,4)**2
36856 ALR=SFMIX(IFL,3)*SFMIX(IFL,4)
36857 XMJ=XMJR
36858 XMJ2=XMJ**2
36859 XL=PYLAMF(XMI2,XMJ2,XMJ2)
36860 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
36861 & (GHLL*AL+GHRR*AR
36862 & +2D0*GHLR*ALR)**2
36863 IDLAM(LKNT,1)=IJ+KSUSY1
36864 IDLAM(LKNT,2)=-(IJ+KSUSY1)
36865 IDLAM(LKNT,3)=0
36866 ENDIF
36867 140 CONTINUE
36868
36869 IF(AXMI.GE.XMJL+XMJR) THEN
36870 LKNT=LKNT+1
36871 AL=SFMIX(IFL,1)*SFMIX(IFL,3)
36872 AR=SFMIX(IFL,2)*SFMIX(IFL,4)
36873 ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3)
36874 XMJ=XMJR
36875 XMJ2=XMJ**2
36876 XL=PYLAMF(XMI2,XMJ2,XMJL**2)
36877 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
36878 & (GHLL*AL+GHRR*AR)**2
36879 IDLAM(LKNT,1)=IJ
36880 IDLAM(LKNT,2)=-(IJ+KSUSY1)
36881 IDLAM(LKNT,3)=0
36882 LKNT=LKNT+1
36883 IDLAM(LKNT,1)=-IJ
36884 IDLAM(LKNT,2)=IJ+KSUSY1
36885 IDLAM(LKNT,3)=0
36886 XLAM(LKNT)=XLAM(LKNT-1)
36887 ENDIF
36888 ENDIF
36889 150 CONTINUE
36890 160 CONTINUE
36891 170 CONTINUE
36892
36893 GOTO 230
36894 180 CONTINUE
36895
36896C...H+ -> CHI+_I + CHI0_J
36897 DO 200 IJ=1,4
36898 XMJ=SMZ(IJ)
36899 AXMJ=ABS(XMJ)
36900 XMJ2=XMJ**2
36901 DO 190 IK=1,2
36902 XMK=SMW(IK)
36903 AXMK=ABS(XMK)
36904 XMK2=XMK**2
36905 IF(AXMI.GE.AXMJ+AXMK) THEN
36906 LKNT=LKNT+1
36907 GL=CBETA*(ZMIX(IJ,4)*VMIX(IK,1)+(ZMIX(IJ,2)+ZMIX(IJ,1)*
36908 & TANW)*VMIX(IK,2)/SR2)
36909 GR=SBETA*(ZMIX(IJ,3)*UMIX(IK,1)-(ZMIX(IJ,2)+ZMIX(IJ,1)*
36910 & TANW)*UMIX(IK,2)/SR2)
36911 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GL,GR)
36912 IDLAM(LKNT,1)=KFNCHI(IJ)
36913 IDLAM(LKNT,2)=KFCCHI(IK)
36914 IDLAM(LKNT,3)=0
36915 ENDIF
36916 190 CONTINUE
36917 200 CONTINUE
36918
36919 GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2)
36920 GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB)
36921 AL=0D0
36922 AR=0D0
36923 CF=3D0
36924
36925C...H+ -> T_1 B_1~
36926 XM1=PMAS(PYCOMP(KSUSY1+6),1)
36927 XM2=PMAS(PYCOMP(KSUSY1+5),1)
36928 IF(XMI.GE.XM1+XM2) THEN
36929 XL=PYLAMF(XMI2,XM1**2,XM2**2)
36930 LKNT=LKNT+1
36931 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
36932 & (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2
36933 IDLAM(LKNT,1)=KSUSY1+6
36934 IDLAM(LKNT,2)=-(KSUSY1+5)
36935 IDLAM(LKNT,3)=0
36936 ENDIF
36937
36938C...H+ -> T_2 B_1~
36939 XM1=PMAS(PYCOMP(KSUSY2+6),1)
36940 XM2=PMAS(PYCOMP(KSUSY1+5),1)
36941 IF(XMI.GE.XM1+XM2) THEN
36942 XL=PYLAMF(XMI2,XM1**2,XM2**2)
36943 LKNT=LKNT+1
36944 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
36945 & (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2
36946 IDLAM(LKNT,1)=KSUSY2+6
36947 IDLAM(LKNT,2)=-(KSUSY1+5)
36948 IDLAM(LKNT,3)=0
36949 ENDIF
36950
36951C...H+ -> T_1 B_2~
36952 XM1=PMAS(PYCOMP(KSUSY1+6),1)
36953 XM2=PMAS(PYCOMP(KSUSY2+5),1)
36954 IF(XMI.GE.XM1+XM2) THEN
36955 XL=PYLAMF(XMI2,XM1**2,XM2**2)
36956 LKNT=LKNT+1
36957 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
36958 & (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2
36959 IDLAM(LKNT,1)=KSUSY1+6
36960 IDLAM(LKNT,2)=-(KSUSY2+5)
36961 IDLAM(LKNT,3)=0
36962 ENDIF
36963
36964C...H+ -> T_2 B_2~
36965 XM1=PMAS(PYCOMP(KSUSY2+6),1)
36966 XM2=PMAS(PYCOMP(KSUSY2+5),1)
36967 IF(XMI.GE.XM1+XM2) THEN
36968 XL=PYLAMF(XMI2,XM1**2,XM2**2)
36969 LKNT=LKNT+1
36970 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
36971 & (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2
36972 IDLAM(LKNT,1)=KSUSY2+6
36973 IDLAM(LKNT,2)=-(KSUSY2+5)
36974 IDLAM(LKNT,3)=0
36975 ENDIF
36976
36977C...H+ -> UL DL~
36978 GL=-XMW/SR2*SIN(2D0*BETA)
36979 DO 210 IJ=1,3,2
36980 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
36981 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
36982 IF(XMI.GE.XM1+XM2) THEN
36983 XL=PYLAMF(XMI2,XM1**2,XM2**2)
36984 LKNT=LKNT+1
36985 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*(GL)**2
36986 IDLAM(LKNT,1)=-(KSUSY1+IJ)
36987 IDLAM(LKNT,2)=KSUSY1+IJ+1
36988 IDLAM(LKNT,3)=0
36989 ENDIF
36990 210 CONTINUE
36991
36992C...H+ -> EL~ NUL
36993 CF=1D0
36994 DO 220 IJ=11,13,2
36995 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
36996 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
36997 IF(XMI.GE.XM1+XM2) THEN
36998 XL=PYLAMF(XMI2,XM1**2,XM2**2)
36999 LKNT=LKNT+1
37000 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*(GL)**2
37001 IDLAM(LKNT,1)=-(KSUSY1+IJ)
37002 IDLAM(LKNT,2)=KSUSY1+IJ+1
37003 IDLAM(LKNT,3)=0
37004 ENDIF
37005 220 CONTINUE
37006
37007C...H+ -> TAU1 NUTAUL
37008 XM1=PMAS(PYCOMP(KSUSY1+15),1)
37009 XM2=PMAS(PYCOMP(KSUSY1+16),1)
37010 IF(XMI.GE.XM1+XM2) THEN
37011 XL=PYLAMF(XMI2,XM1**2,XM2**2)
37012 LKNT=LKNT+1
37013 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*(GL)**2*SFMIX(15,1)**2
37014 IDLAM(LKNT,1)=-(KSUSY1+15)
37015 IDLAM(LKNT,2)= KSUSY1+16
37016 IDLAM(LKNT,3)=0
37017 ENDIF
37018
37019C...H+ -> TAU2 NUTAUL
37020 XM1=PMAS(PYCOMP(KSUSY2+15),1)
37021 XM2=PMAS(PYCOMP(KSUSY1+16),1)
37022 IF(XMI.GE.XM1+XM2) THEN
37023 XL=PYLAMF(XMI2,XM1**2,XM2**2)
37024 LKNT=LKNT+1
37025 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*(GL)**2*SFMIX(15,3)**2
37026 IDLAM(LKNT,1)=-(KSUSY2+15)
37027 IDLAM(LKNT,2)= KSUSY1+16
37028 IDLAM(LKNT,3)=0
37029 ENDIF
37030
37031 230 CONTINUE
37032 IKNT=LKNT
37033 XLAM(0)=0D0
37034 DO 240 I=1,IKNT
37035 IF(XLAM(I).LE.0D0) XLAM(I)=0D0
37036 XLAM(0)=XLAM(0)+XLAM(I)
37037 240 CONTINUE
37038 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
37039
37040 RETURN
37041 END
37042
37043C*********************************************************************
37044
37045C...PYH2XX
37046C...Calculates the decay rate for a Higgs to an ino pair.
37047
37048 FUNCTION PYH2XX(C1,XM1,XM2,XM3,GL,GR)
37049
37050C...Double precision and integer declarations.
37051 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37052 IMPLICIT INTEGER(I-N)
37053 INTEGER PYK,PYCHGE,PYCOMP
37054C...Commonblocks.
37055 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37056 SAVE /PYDAT1/
37057
37058C...Local variables.
37059 DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
37060 DOUBLE PRECISION XL,PYLAMF,C1
37061 DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
37062
37063 XMI2=XM1**2
37064 XMI3=ABS(XM1**3)
37065 XMJ2=XM2**2
37066 XMK2=XM3**2
37067 XL=PYLAMF(XMI2,XMJ2,XMK2)
37068 PYH2XX=C1/4D0/XMI3*SQRT(XL)
37069 &*((GL**2+GR**2)*(XMI2-XMJ2-XMK2)-
37070 &4D0*GL*GR*XM3*XM2)
37071 IF(PYH2XX.LT.0D0) THEN
37072 WRITE(MSTU(11),*) ' NEGATIVE WIDTH IN PYH2XX '
37073 WRITE(MSTU(11),*) XMI2,XMJ2,XMK2,GL,GR,XM1,XM2,XM3
37074 STOP
37075 ENDIF
37076
37077 RETURN
37078 END
37079
37080C*********************************************************************
37081
37082C...PYGAUS
37083C...Integration by adaptive Gaussian quadrature.
37084C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
37085
37086 FUNCTION PYGAUS(F, A, B, EPS)
37087
37088C...Double precision and integer declarations.
37089 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37090 IMPLICIT INTEGER(I-N)
37091 INTEGER PYK,PYCHGE,PYCOMP
37092
37093C...Local declarations.
37094 EXTERNAL F
37095 DOUBLE PRECISION F,W(12), X(12)
37096 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
37097 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
37098 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
37099 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
37100 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
37101 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
37102 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
37103 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
37104 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
37105 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
37106 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
37107 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
37108
37109C...The Gaussian quadrature algorithm.
37110 H = 0D0
37111 IF(B .EQ. A) GO TO 140
37112 CONST = 5D-3 / ABS(B-A)
37113 BB = A
37114 100 CONTINUE
37115 AA = BB
37116 BB = B
37117 110 CONTINUE
37118 C1 = 0.5D0*(BB+AA)
37119 C2 = 0.5D0*(BB-AA)
37120 S8 = 0D0
37121 DO 120 I = 1, 4
37122 U = C2*X(I)
37123 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
37124 120 CONTINUE
37125 S16 = 0D0
37126 DO 130 I = 5, 12
37127 U = C2*X(I)
37128 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
37129 130 CONTINUE
37130 S16 = C2*S16
37131 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
37132 H = H + S16
37133 IF(BB .NE. B) GO TO 100
37134 ELSE
37135 BB = C1
37136 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GO TO 110
37137 H = 0D0
37138 CALL PYERRM(18,'(PYGAUS:) too high accuracy required')
37139 GO TO 140
37140 ENDIF
37141 140 CONTINUE
37142 PYGAUS = H
37143
37144 RETURN
37145 END
37146
37147C*********************************************************************
37148
37149C...PYSIMP
37150C...Simpson formula for an integral.
37151
37152 FUNCTION PYSIMP(Y,X0,X1,N)
37153
37154C...Double precision and integer declarations.
37155 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37156 IMPLICIT INTEGER(I-N)
37157 INTEGER PYK,PYCHGE,PYCOMP
37158
37159C...Local variables.
37160 DOUBLE PRECISION Y,X0,X1,H,S
37161 DIMENSION Y(0:N)
37162
37163 S=0D0
37164 H=(X1-X0)/N
37165 DO 100 I=0,N-2,2
37166 S=S+Y(I)+4D0*Y(I+1)+Y(I+2)
37167 100 CONTINUE
37168 PYSIMP=S*H/3D0
37169
37170 RETURN
37171 END
37172
37173C*********************************************************************
37174
37175C...PYLAMF
37176C...The standard lambda function.
37177
37178 FUNCTION PYLAMF(X,Y,Z)
37179
37180C...Double precision and integer declarations.
37181 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37182 IMPLICIT INTEGER(I-N)
37183 INTEGER PYK,PYCHGE,PYCOMP
37184
37185C...Local variables.
37186 DOUBLE PRECISION PYLAMF,X,Y,Z
37187
37188 PYLAMF=(X-(Y+Z))**2-4D0*Y*Z
37189 IF(PYLAMF.LT.0D0) PYLAMF=0D0
37190
37191 RETURN
37192 END
37193
37194C*********************************************************************
37195
37196C...PYTBDY
37197C...Generates 3-body decays of gauginos.
37198
37199 SUBROUTINE PYTBDY(XM)
37200
37201C...Double precision and integer declarations.
37202 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37203 IMPLICIT INTEGER(I-N)
37204 INTEGER PYK,PYCHGE,PYCOMP
37205C...Parameter statement to help give large particle numbers.
37206 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
37207C...Commonblocks.
37208 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37209 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37210 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37211 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
37212 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
37213 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/
37214
37215C...Local variables.
37216 DOUBLE PRECISION XM(5)
37217 DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
37218 DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
37219 DOUBLE PRECISION CPHI1,SPHI1
37220 DOUBLE PRECISION S23DEL,EPS
37221 DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
37222 PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3)
37223 DOUBLE PRECISION F1,F2,X0,X1,X2,X3
37224 DATA EPS/1D-6/
37225
37226C...GENERATE S12
37227 S12MIN=(XM(1)+XM(2))**2
37228 S12MAX=(XM(5)-XM(3))**2
37229 YJACO1=S12MAX-S12MIN
37230
37231C...FIND S12*
37232 AX=S12MIN
37233 CX=S12MAX
37234 BX=S12MIN+0.5D0*YJACO1
37235 X0=AX
37236 X3=CX
37237 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
37238 X1=BX
37239 X2=BX+C*(CX-BX)
37240 ELSE
37241 X2=BX
37242 X1=BX-C*(BX-AX)
37243 ENDIF
37244
37245C...SOLVE FOR F1 AND F2
37246 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
37247 &-(2D0*XM(1)*XM(2))**2
37248 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
37249 &-(2D0*XM(3)*XM(5))**2
37250 S23DF1=S23DF1*EPS
37251 S23DF2=S23DF2*EPS
37252 S23DEL=SQRT(S23DF1*S23DF2)/(2D0*X1)
37253 F1=-2D0*S23DEL/EPS
37254 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
37255 &-(2D0*XM(1)*XM(2))**2
37256 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
37257 &-(2D0*XM(3)*XM(5))**2
37258 S23DF1=S23DF1*EPS
37259 S23DF2=S23DF2*EPS
37260 S23DEL=SQRT(S23DF1*S23DF2)/(2D0*X2)
37261 F2=-2D0*S23DEL/EPS
37262
37263 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
37264 IF(F2.LT.F1)THEN
37265 X0=X1
37266 X1=X2
37267 X2=R*X1+C*X3
37268 F1=F2
37269 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
37270 & -(2D0*XM(1)*XM(2))**2
37271 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
37272 & -(2D0*XM(3)*XM(5))**2
37273 S23DF1=S23DF1*EPS
37274 S23DF2=S23DF2*EPS
37275 S23DEL=SQRT(S23DF1*S23DF2)/(2D0*X2)
37276 F2=-2D0*S23DEL/EPS
37277 ELSE
37278 X3=X2
37279 X2=X1
37280 X1=R*X2+C*X0
37281 F2=F1
37282 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
37283 & -(2D0*XM(1)*XM(2))**2
37284 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
37285 & -(2D0*XM(3)*XM(5))**2
37286 S23DF1=S23DF1*EPS
37287 S23DF2=S23DF2*EPS
37288 S23DEL=SQRT(S23DF1*S23DF2)/(2D0*X1)
37289 F1=-2D0*S23DEL/EPS
37290 ENDIF
37291 GOTO 100
37292 ENDIF
37293C...WE WANT THE MAXIMUM, NOT THE MINIMUM
37294 IF(F1.LT.F2)THEN
37295 GOLDEN=-F1
37296 XMIN=X1
37297 ELSE
37298 GOLDEN=-F2
37299 XMIN=X2
37300 ENDIF
37301
37302 IKNT=0
37303 110 S12=S12MIN+PYR(0)*YJACO1
37304 IKNT=IKNT+1
37305C...GENERATE S23
37306 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
37307 &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
37308 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
37309 &-(2D0*XM(1)*XM(2))**2
37310 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
37311 &-(2D0*XM(3)*XM(5))**2
37312 S23DF1=S23DF1*EPS
37313 S23DF2=S23DF2*EPS
37314 S23DEL=SQRT(S23DF1*S23DF2)/(2D0*S12)
37315 S23DEL=S23DEL/EPS
37316 S23MIN=S23AVE-S23DEL
37317 S23MAX=S23AVE+S23DEL
37318 YJACO2=S23MAX-S23MIN
37319 S23=S23MIN+PYR(0)*YJACO2
37320
37321C...CHECK THE SAMPLING
37322 IF(IKNT.GT.100) THEN
37323 WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY '
37324 GOTO 120
37325 ENDIF
37326 IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 110
37327 120 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5))
37328 D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5))
37329 D2=XM(5)-D1-D3
37330 P1=SQRT(D1*D1-XM(1)**2)
37331 P2=SQRT(D2*D2-XM(2)**2)
37332 P3=SQRT(D3*D3-XM(3)**2)
37333 CTHE1=2D0*PYR(0)-1D0
37334 ANG1=2D0*PYR(0)*PARU(1)
37335 CPHI1=COS(ANG1)
37336 SPHI1=SIN(ANG1)
37337 ARG=1D0-CTHE1**2
37338 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
37339 STHE1=SQRT(ARG)
37340 P(N+1,1)=P1*STHE1*CPHI1
37341 P(N+1,2)=P1*STHE1*SPHI1
37342 P(N+1,3)=P1*CTHE1
37343 P(N+1,4)=D1
37344
37345C...GET CPHI3
37346 ANG3=2D0*PYR(0)*PARU(1)
37347 CPHI3=COS(ANG3)
37348 SPHI3=SIN(ANG3)
37349 CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3
37350 ARG=1D0-CTHE3**2
37351 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
37352 STHE3=SQRT(ARG)
37353 P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1
37354 &+P3*STHE3*SPHI3*SPHI1
37355 &+P3*CTHE3*STHE1*CPHI1
37356 P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1
37357 &-P3*STHE3*SPHI3*CPHI1
37358 &+P3*CTHE3*STHE1*SPHI1
37359 P(N+3,3)=P3*STHE3*CPHI3*STHE1
37360 &+P3*CTHE3*CTHE1
37361 P(N+3,4)=D3
37362
37363 DO 130 I=1,3
37364 P(N+2,I)=-P(N+1,I)-P(N+3,I)
37365 130 CONTINUE
37366 P(N+2,4)=D2
37367
37368 RETURN
37369 END
37370
37371C*********************************************************************
37372
37373C...PY1ENT
37374C...Stores one parton/particle in commonblock PYJETS.
37375
37376 SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
37377
37378C...Double precision and integer declarations.
37379 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37380 IMPLICIT INTEGER(I-N)
37381 INTEGER PYK,PYCHGE,PYCOMP
37382C...Commonblocks.
37383 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37384 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37385 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37386 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
37387
37388C...Standard checks.
37389 MSTU(28)=0
37390 IF(MSTU(12).GE.1) CALL PYLIST(0)
37391 IPA=MAX(1,IABS(IP))
37392 IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
37393 &'(PY1ENT:) writing outside PYJETS memory')
37394 KC=PYCOMP(KF)
37395 IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
37396
37397C...Find mass. Reset K, P and V vectors.
37398 PM=0D0
37399 IF(MSTU(10).EQ.1) PM=P(IPA,5)
37400 IF(MSTU(10).GE.2) PM=PYMASS(KF)
37401 DO 100 J=1,5
37402 K(IPA,J)=0
37403 P(IPA,J)=0D0
37404 V(IPA,J)=0D0
37405 100 CONTINUE
37406
37407C...Store parton/particle in K and P vectors.
37408 K(IPA,1)=1
37409 IF(IP.LT.0) K(IPA,1)=2
37410 K(IPA,2)=KF
37411 P(IPA,5)=PM
37412 P(IPA,4)=MAX(PE,PM)
37413 PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
37414 P(IPA,1)=PA*SIN(THE)*COS(PHI)
37415 P(IPA,2)=PA*SIN(THE)*SIN(PHI)
37416 P(IPA,3)=PA*COS(THE)
37417
37418C...Set N. Optionally fragment/decay.
37419 N=IPA
37420 IF(IP.EQ.0) CALL PYEXEC
37421
37422 RETURN
37423 END
37424
37425C*********************************************************************
37426
37427C...PY2ENT
37428C...Stores two partons/particles in their CM frame,
37429C...with the first along the +z axis.
37430
37431 SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
37432
37433C...Double precision and integer declarations.
37434 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37435 IMPLICIT INTEGER(I-N)
37436 INTEGER PYK,PYCHGE,PYCOMP
37437C...Commonblocks.
37438 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37439 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37440 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37441 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
37442
37443C...Standard checks.
37444 MSTU(28)=0
37445 IF(MSTU(12).GE.1) CALL PYLIST(0)
37446 IPA=MAX(1,IABS(IP))
37447 IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
37448 &'(PY2ENT:) writing outside PYJETS memory')
37449 KC1=PYCOMP(KF1)
37450 KC2=PYCOMP(KF2)
37451 IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
37452 &'(PY2ENT:) unknown flavour code')
37453
37454C...Find masses. Reset K, P and V vectors.
37455 PM1=0D0
37456 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
37457 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
37458 PM2=0D0
37459 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
37460 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
37461 DO 110 I=IPA,IPA+1
37462 DO 100 J=1,5
37463 K(I,J)=0
37464 P(I,J)=0D0
37465 V(I,J)=0D0
37466 100 CONTINUE
37467 110 CONTINUE
37468
37469C...Check flavours.
37470 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
37471 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
37472 IF(MSTU(19).EQ.1) THEN
37473 MSTU(19)=0
37474 ELSE
37475 IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
37476 & '(PY2ENT:) unphysical flavour combination')
37477 ENDIF
37478 K(IPA,2)=KF1
37479 K(IPA+1,2)=KF2
37480
37481C...Store partons/particles in K vectors for normal case.
37482 IF(IP.GE.0) THEN
37483 K(IPA,1)=1
37484 IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
37485 K(IPA+1,1)=1
37486
37487C...Store partons in K vectors for parton shower evolution.
37488 ELSE
37489 K(IPA,1)=3
37490 K(IPA+1,1)=3
37491 K(IPA,4)=MSTU(5)*(IPA+1)
37492 K(IPA,5)=K(IPA,4)
37493 K(IPA+1,4)=MSTU(5)*IPA
37494 K(IPA+1,5)=K(IPA+1,4)
37495 ENDIF
37496
37497C...Check kinematics and store partons/particles in P vectors.
37498 IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
37499 &'(PY2ENT:) energy smaller than sum of masses')
37500 PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/
37501 &(2D0*PECM)
37502 P(IPA,3)=PA
37503 P(IPA,4)=SQRT(PM1**2+PA**2)
37504 P(IPA,5)=PM1
37505 P(IPA+1,3)=-PA
37506 P(IPA+1,4)=SQRT(PM2**2+PA**2)
37507 P(IPA+1,5)=PM2
37508
37509C...Set N. Optionally fragment/decay.
37510 N=IPA+1
37511 IF(IP.EQ.0) CALL PYEXEC
37512
37513 RETURN
37514 END
37515
37516C*********************************************************************
37517
37518C...PY3ENT
37519C...Stores three partons or particles in their CM frame,
37520C...with the first along the +z axis and the third in the (x,z)
37521C...plane with x > 0.
37522
37523 SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
37524
37525C...Double precision and integer declarations.
37526 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37527 IMPLICIT INTEGER(I-N)
37528 INTEGER PYK,PYCHGE,PYCOMP
37529C...Commonblocks.
37530 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37531 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37532 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37533 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
37534
37535C...Standard checks.
37536 MSTU(28)=0
37537 IF(MSTU(12).GE.1) CALL PYLIST(0)
37538 IPA=MAX(1,IABS(IP))
37539 IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
37540 &'(PY3ENT:) writing outside PYJETS memory')
37541 KC1=PYCOMP(KF1)
37542 KC2=PYCOMP(KF2)
37543 KC3=PYCOMP(KF3)
37544 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
37545 &'(PY3ENT:) unknown flavour code')
37546
37547C...Find masses. Reset K, P and V vectors.
37548 PM1=0D0
37549 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
37550 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
37551 PM2=0D0
37552 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
37553 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
37554 PM3=0D0
37555 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
37556 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
37557 DO 110 I=IPA,IPA+2
37558 DO 100 J=1,5
37559 K(I,J)=0
37560 P(I,J)=0D0
37561 V(I,J)=0D0
37562 100 CONTINUE
37563 110 CONTINUE
37564
37565C...Check flavours.
37566 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
37567 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
37568 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
37569 IF(MSTU(19).EQ.1) THEN
37570 MSTU(19)=0
37571 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
37572 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
37573 & KQ1+KQ3.EQ.4)) THEN
37574 ELSE
37575 CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
37576 ENDIF
37577 K(IPA,2)=KF1
37578 K(IPA+1,2)=KF2
37579 K(IPA+2,2)=KF3
37580
37581C...Store partons/particles in K vectors for normal case.
37582 IF(IP.GE.0) THEN
37583 K(IPA,1)=1
37584 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
37585 K(IPA+1,1)=1
37586 IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
37587 K(IPA+2,1)=1
37588
37589C...Store partons in K vectors for parton shower evolution.
37590 ELSE
37591 K(IPA,1)=3
37592 K(IPA+1,1)=3
37593 K(IPA+2,1)=3
37594 KCS=4
37595 IF(KQ1.EQ.-1) KCS=5
37596 K(IPA,KCS)=MSTU(5)*(IPA+1)
37597 K(IPA,9-KCS)=MSTU(5)*(IPA+2)
37598 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
37599 K(IPA+1,9-KCS)=MSTU(5)*IPA
37600 K(IPA+2,KCS)=MSTU(5)*IPA
37601 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
37602 ENDIF
37603
37604C...Check kinematics.
37605 MKERR=0
37606 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR.
37607 &0.5D0*X3*PECM.LE.PM3) MKERR=1
37608 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
37609 PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2))
37610 PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2))
37611 CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2)
37612 CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3)
37613 IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1
37614 CTHE3=MAX(-1D0,MIN(1D0,CTHE3))
37615 IF(MKERR.NE.0) CALL PYERRM(13,
37616 &'(PY3ENT:) unphysical kinematical variable setup')
37617
37618C...Store partons/particles in P vectors.
37619 P(IPA,3)=PA1
37620 P(IPA,4)=SQRT(PA1**2+PM1**2)
37621 P(IPA,5)=PM1
37622 P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2)
37623 P(IPA+2,3)=PA3*CTHE3
37624 P(IPA+2,4)=SQRT(PA3**2+PM3**2)
37625 P(IPA+2,5)=PM3
37626 P(IPA+1,1)=-P(IPA+2,1)
37627 P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
37628 P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
37629 P(IPA+1,5)=PM2
37630
37631C...Set N. Optionally fragment/decay.
37632 N=IPA+2
37633 IF(IP.EQ.0) CALL PYEXEC
37634
37635 RETURN
37636 END
37637
37638C*********************************************************************
37639
37640C...PY4ENT
37641C...Stores four partons or particles in their CM frame, with
37642C...the first along the +z axis, the last in the xz plane with x > 0
37643C...and the second having y < 0 and y > 0 with equal probability.
37644
37645 SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
37646
37647C...Double precision and integer declarations.
37648 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37649 IMPLICIT INTEGER(I-N)
37650 INTEGER PYK,PYCHGE,PYCOMP
37651C...Commonblocks.
37652 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37653 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37654 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37655 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
37656
37657C...Standard checks.
37658 MSTU(28)=0
37659 IF(MSTU(12).GE.1) CALL PYLIST(0)
37660 IPA=MAX(1,IABS(IP))
37661 IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
37662 &'(PY4ENT:) writing outside PYJETS momory')
37663 KC1=PYCOMP(KF1)
37664 KC2=PYCOMP(KF2)
37665 KC3=PYCOMP(KF3)
37666 KC4=PYCOMP(KF4)
37667 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
37668 &'(PY4ENT:) unknown flavour code')
37669
37670C...Find masses. Reset K, P and V vectors.
37671 PM1=0D0
37672 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
37673 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
37674 PM2=0D0
37675 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
37676 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
37677 PM3=0D0
37678 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
37679 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
37680 PM4=0D0
37681 IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
37682 IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
37683 DO 110 I=IPA,IPA+3
37684 DO 100 J=1,5
37685 K(I,J)=0
37686 P(I,J)=0D0
37687 V(I,J)=0D0
37688 100 CONTINUE
37689 110 CONTINUE
37690
37691C...Check flavours.
37692 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
37693 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
37694 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
37695 KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
37696 IF(MSTU(19).EQ.1) THEN
37697 MSTU(19)=0
37698 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
37699 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
37700 & KQ1+KQ4.EQ.4)) THEN
37701 ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
37702 & THEN
37703 ELSE
37704 CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
37705 ENDIF
37706 K(IPA,2)=KF1
37707 K(IPA+1,2)=KF2
37708 K(IPA+2,2)=KF3
37709 K(IPA+3,2)=KF4
37710
37711C...Store partons/particles in K vectors for normal case.
37712 IF(IP.GE.0) THEN
37713 K(IPA,1)=1
37714 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
37715 K(IPA+1,1)=1
37716 IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
37717 & K(IPA+1,1)=2
37718 K(IPA+2,1)=1
37719 IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
37720 K(IPA+3,1)=1
37721
37722C...Store partons for parton shower evolution from q-g-g-qbar or
37723C...g-g-g-g event.
37724 ELSEIF(KQ1+KQ2.NE.0) THEN
37725 K(IPA,1)=3
37726 K(IPA+1,1)=3
37727 K(IPA+2,1)=3
37728 K(IPA+3,1)=3
37729 KCS=4
37730 IF(KQ1.EQ.-1) KCS=5
37731 K(IPA,KCS)=MSTU(5)*(IPA+1)
37732 K(IPA,9-KCS)=MSTU(5)*(IPA+3)
37733 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
37734 K(IPA+1,9-KCS)=MSTU(5)*IPA
37735 K(IPA+2,KCS)=MSTU(5)*(IPA+3)
37736 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
37737 K(IPA+3,KCS)=MSTU(5)*IPA
37738 K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
37739
37740C...Store partons for parton shower evolution from q-qbar-q-qbar event.
37741 ELSE
37742 K(IPA,1)=3
37743 K(IPA+1,1)=3
37744 K(IPA+2,1)=3
37745 K(IPA+3,1)=3
37746 K(IPA,4)=MSTU(5)*(IPA+1)
37747 K(IPA,5)=K(IPA,4)
37748 K(IPA+1,4)=MSTU(5)*IPA
37749 K(IPA+1,5)=K(IPA+1,4)
37750 K(IPA+2,4)=MSTU(5)*(IPA+3)
37751 K(IPA+2,5)=K(IPA+2,4)
37752 K(IPA+3,4)=MSTU(5)*(IPA+2)
37753 K(IPA+3,5)=K(IPA+3,4)
37754 ENDIF
37755
37756C...Check kinematics.
37757 MKERR=0
37758 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR.
37759 &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4)
37760 &MKERR=1
37761 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
37762 PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2))
37763 PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2))
37764 X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
37765 CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4)
37766 IF(ABS(CTHE4).GE.1.002D0) MKERR=1
37767 CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
37768 STHE4=SQRT(1D0-CTHE4**2)
37769 CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2)
37770 IF(ABS(CTHE2).GE.1.002D0) MKERR=1
37771 CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
37772 STHE2=SQRT(1D0-CTHE2**2)
37773 CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/
37774 &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4)
37775 IF(ABS(CPHI2).GE.1.05D0) MKERR=1
37776 CPHI2=MAX(-1D0,MIN(1D0,CPHI2))
37777 IF(MKERR.EQ.1) CALL PYERRM(13,
37778 &'(PY4ENT:) unphysical kinematical variable setup')
37779
37780C...Store partons/particles in P vectors.
37781 P(IPA,3)=PA1
37782 P(IPA,4)=SQRT(PA1**2+PM1**2)
37783 P(IPA,5)=PM1
37784 P(IPA+3,1)=PA4*STHE4
37785 P(IPA+3,3)=PA4*CTHE4
37786 P(IPA+3,4)=SQRT(PA4**2+PM4**2)
37787 P(IPA+3,5)=PM4
37788 P(IPA+1,1)=PA2*STHE2*CPHI2
37789 P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0)
37790 P(IPA+1,3)=PA2*CTHE2
37791 P(IPA+1,4)=SQRT(PA2**2+PM2**2)
37792 P(IPA+1,5)=PM2
37793 P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
37794 P(IPA+2,2)=-P(IPA+1,2)
37795 P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
37796 P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
37797 P(IPA+2,5)=PM3
37798
37799C...Set N. Optionally fragment/decay.
37800 N=IPA+3
37801 IF(IP.EQ.0) CALL PYEXEC
37802
37803 RETURN
37804 END
37805
37806C*********************************************************************
37807
37808C...PY2FRM
37809C...An interface from a two-fermion generator to include
37810C...parton showers and hadronization.
37811
37812 SUBROUTINE PY2FRM(IRAD,ITAU,ICOM)
37813
37814C...Double precision and integer declarations.
37815 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37816 IMPLICIT INTEGER(I-N)
37817 INTEGER PYK,PYCHGE,PYCOMP
37818C...Commonblocks.
37819 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37820 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37821 SAVE /PYJETS/,/PYDAT1/
37822C...Local arrays.
37823 DIMENSION IJOIN(2),INTAU(2)
37824
37825C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
37826 IF(ICOM.EQ.0) THEN
37827 MSTU(28)=0
37828 CALL PYHEPC(2)
37829 ENDIF
37830
37831C...Loop through entries and pick up all final fermions/antifermions.
37832 I1=0
37833 I2=0
37834 DO 100 I=1,N
37835 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
37836 KFA=IABS(K(I,2))
37837 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
37838 IF(K(I,2).GT.0) THEN
37839 IF(I1.EQ.0) THEN
37840 I1=I
37841 ELSE
37842 CALL PYERRM(16,'(PY2FRM:) more than one fermion')
37843 ENDIF
37844 ELSE
37845 IF(I2.EQ.0) THEN
37846 I2=I
37847 ELSE
37848 CALL PYERRM(16,'(PY2FRM:) more than one antifermion')
37849 ENDIF
37850 ENDIF
37851 ENDIF
37852 100 CONTINUE
37853
37854C...Check that event is arranged according to conventions.
37855 IF(I1.EQ.0.OR.I2.EQ.0) THEN
37856 CALL PYERRM(16,'(PY2FRM:) event contains too few fermions')
37857 ENDIF
37858 IF(I2.LT.I1) THEN
37859 CALL PYERRM(6,'(PY2FRM:) fermions arranged in wrong order')
37860 ENDIF
37861
37862C...Check whether fermion pair is quarks or leptons.
37863 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
37864 IQL12=1
37865 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
37866 IQL12=2
37867 ELSE
37868 CALL PYERRM(16,'(PY2FRM:) fermion pair inconsistent')
37869 ENDIF
37870
37871C...Decide whether to allow or not photon radiation in showers.
37872 MSTJ(41)=2
37873 IF(IRAD.EQ.0) MSTJ(41)=1
37874
37875C...Do colour joining and parton showers.
37876 IP1=I1
37877 IP2=I2
37878 IF(IQL12.EQ.1) THEN
37879 IJOIN(1)=IP1
37880 IJOIN(2)=IP2
37881 CALL PYJOIN(2,IJOIN)
37882 ENDIF
37883 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
37884 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
37885 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
37886 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
37887 ENDIF
37888
37889C...Do fragmentation and decays. Possibly except tau decay.
37890 IF(ITAU.EQ.0) THEN
37891 NTAU=0
37892 DO 110 I=1,N
37893 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
37894 NTAU=NTAU+1
37895 INTAU(NTAU)=I
37896 K(I,1)=11
37897 ENDIF
37898 110 CONTINUE
37899 ENDIF
37900 CALL PYEXEC
37901 IF(ITAU.EQ.0) THEN
37902 DO 120 I=1,NTAU
37903 K(INTAU(I),1)=1
37904 120 CONTINUE
37905 ENDIF
37906
37907C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
37908 IF(ICOM.EQ.0) THEN
37909 MSTU(28)=0
37910 CALL PYHEPC(1)
37911 ENDIF
37912
37913 END
37914
37915C*********************************************************************
37916
37917C...PY4FRM
37918C...An interface from a four-fermion generator to include
37919C...parton showers and hadronization.
37920
37921 SUBROUTINE PY4FRM(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)
37922
37923C...Double precision and integer declarations.
37924 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37925 IMPLICIT INTEGER(I-N)
37926 INTEGER PYK,PYCHGE,PYCOMP
37927C...Commonblocks.
37928 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37929 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37930 SAVE /PYJETS/,/PYDAT1/
37931C...Local arrays.
37932 DIMENSION IJOIN(2),INTAU(4)
37933
37934C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
37935 IF(ICOM.EQ.0) THEN
37936 MSTU(28)=0
37937 CALL PYHEPC(2)
37938 ENDIF
37939
37940C...Loop through entries and pick up all final fermions/antifermions.
37941 I1=0
37942 I2=0
37943 I3=0
37944 I4=0
37945 DO 100 I=1,N
37946 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
37947 KFA=IABS(K(I,2))
37948 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
37949 IF(K(I,2).GT.0) THEN
37950 IF(I1.EQ.0) THEN
37951 I1=I
37952 ELSEIF(I3.EQ.0) THEN
37953 I3=I
37954 ELSE
37955 CALL PYERRM(16,'(PY4FRM:) more than two fermions')
37956 ENDIF
37957 ELSE
37958 IF(I2.EQ.0) THEN
37959 I2=I
37960 ELSEIF(I4.EQ.0) THEN
37961 I4=I
37962 ELSE
37963 CALL PYERRM(16,'(PY4FRM:) more than two antifermions')
37964 ENDIF
37965 ENDIF
37966 ENDIF
37967 100 CONTINUE
37968
37969C...Check that event is arranged according to conventions.
37970 IF(I3.EQ.0.OR.I4.EQ.0) THEN
37971 CALL PYERRM(16,'(PY4FRM:) event contains too few fermions')
37972 ENDIF
37973 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
37974 CALL PYERRM(6,'(PY4FRM:) fermions arranged in wrong order')
37975 ENDIF
37976
37977C...Check which fermion pairs are quarks and which leptons.
37978 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
37979 IQL12=1
37980 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
37981 IQL12=2
37982 ELSE
37983 CALL PYERRM(16,'(PY4FRM:) first fermion pair inconsistent')
37984 ENDIF
37985 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
37986 IQL34=1
37987 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
37988 IQL34=2
37989 ELSE
37990 CALL PYERRM(16,'(PY4FRM:) second fermion pair inconsistent')
37991 ENDIF
37992
37993C...Decide whether to allow or not photon radiation in showers.
37994 MSTJ(41)=2
37995 IF(IRAD.EQ.0) MSTJ(41)=1
37996
37997C...Decide on dipole pairing.
37998 IP1=I1
37999 IP2=I2
38000 IP3=I3
38001 IP4=I4
38002 IF(IQL12.EQ.IQL34) THEN
38003 R1SQ=A1SQ
38004 R2SQ=A2SQ
38005 DELTA=ATOTSQ-A1SQ-A2SQ
38006 IF(ISTRAT.EQ.1) THEN
38007 IF(DELTA.GT.0D0) R1SQ=R1SQ+DELTA
38008 IF(DELTA.LT.0D0) R2SQ=MAX(0D0,R2SQ+DELTA)
38009 ELSEIF(ISTRAT.EQ.2) THEN
38010 IF(DELTA.GT.0D0) R2SQ=R2SQ+DELTA
38011 IF(DELTA.LT.0D0) R1SQ=MAX(0D0,R1SQ+DELTA)
38012 ENDIF
38013 IF(R2SQ.GT.PYR(0)*(R1SQ+R2SQ)) THEN
38014 IP2=I4
38015 IP4=I2
38016 ENDIF
38017 ENDIF
38018
38019C...Do colour joinings and parton showers.
38020 IF(IQL12.EQ.1) THEN
38021 IJOIN(1)=IP1
38022 IJOIN(2)=IP2
38023 CALL PYJOIN(2,IJOIN)
38024 ENDIF
38025 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
38026 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
38027 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
38028 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
38029 ENDIF
38030 IF(IQL34.EQ.1) THEN
38031 IJOIN(1)=IP3
38032 IJOIN(2)=IP4
38033 CALL PYJOIN(2,IJOIN)
38034 ENDIF
38035 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
38036 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
38037 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
38038 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
38039 ENDIF
38040
38041C...Do fragmentation and decays. Possibly except tau decay.
38042 IF(ITAU.EQ.0) THEN
38043 NTAU=0
38044 DO 110 I=1,N
38045 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
38046 NTAU=NTAU+1
38047 INTAU(NTAU)=I
38048 K(I,1)=11
38049 ENDIF
38050 110 CONTINUE
38051 ENDIF
38052 CALL PYEXEC
38053 IF(ITAU.EQ.0) THEN
38054 DO 120 I=1,NTAU
38055 K(INTAU(I),1)=1
38056 120 CONTINUE
38057 ENDIF
38058
38059C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
38060 IF(ICOM.EQ.0) THEN
38061 MSTU(28)=0
38062 CALL PYHEPC(1)
38063 ENDIF
38064
38065 END
38066
38067C*********************************************************************
38068
38069C...PY6FRM
38070C...An interface from a six-fermion generator to include
38071C...parton showers and hadronization.
38072
38073 SUBROUTINE PY6FRM(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)
38074
38075C...Double precision and integer declarations.
38076 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38077 IMPLICIT INTEGER(I-N)
38078 INTEGER PYK,PYCHGE,PYCOMP
38079C...Commonblocks.
38080 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
38081 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38082 SAVE /PYJETS/,/PYDAT1/
38083C...Local arrays.
38084 DIMENSION IJOIN(2),INTAU(6),BETA(3),BETAO(3),BETAN(3)
38085
38086C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
38087 IF(ICOM.EQ.0) THEN
38088 MSTU(28)=0
38089 CALL PYHEPC(2)
38090 ENDIF
38091
38092C...Loop through entries and pick up all final fermions/antifermions.
38093 I1=0
38094 I2=0
38095 I3=0
38096 I4=0
38097 I5=0
38098 I6=0
38099 DO 100 I=1,N
38100 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
38101 KFA=IABS(K(I,2))
38102 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
38103 IF(K(I,2).GT.0) THEN
38104 IF(I1.EQ.0) THEN
38105 I1=I
38106 ELSEIF(I3.EQ.0) THEN
38107 I3=I
38108 ELSEIF(I5.EQ.0) THEN
38109 I5=I
38110 ELSE
38111 CALL PYERRM(16,'(PY6FRM:) more than three fermions')
38112 ENDIF
38113 ELSE
38114 IF(I2.EQ.0) THEN
38115 I2=I
38116 ELSEIF(I4.EQ.0) THEN
38117 I4=I
38118 ELSEIF(I6.EQ.0) THEN
38119 I6=I
38120 ELSE
38121 CALL PYERRM(16,'(PY6FRM:) more than three antifermions')
38122 ENDIF
38123 ENDIF
38124 ENDIF
38125 100 CONTINUE
38126
38127C...Check that event is arranged according to conventions.
38128 IF(I5.EQ.0.OR.I6.EQ.0) THEN
38129 CALL PYERRM(16,'(PY6FRM:) event contains too few fermions')
38130 ENDIF
38131 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3.OR.I5.LT.I4.OR.I6.LT.I5) THEN
38132 CALL PYERRM(6,'(PY6FRM:) fermions arranged in wrong order')
38133 ENDIF
38134
38135C...Check which fermion pairs are quarks and which leptons.
38136 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
38137 IQL12=1
38138 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
38139 IQL12=2
38140 ELSE
38141 CALL PYERRM(16,'(PY6FRM:) first fermion pair inconsistent')
38142 ENDIF
38143 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
38144 IQL34=1
38145 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
38146 IQL34=2
38147 ELSE
38148 CALL PYERRM(16,'(PY6FRM:) second fermion pair inconsistent')
38149 ENDIF
38150 IF(IABS(K(I5,2)).LT.10.AND.IABS(K(I6,2)).LT.10) THEN
38151 IQL56=1
38152 ELSEIF(IABS(K(I5,2)).GT.10.AND.IABS(K(I6,2)).GT.10) THEN
38153 IQL56=2
38154 ELSE
38155 CALL PYERRM(16,'(PY6FRM:) third fermion pair inconsistent')
38156 ENDIF
38157
38158C...Decide whether to allow or not photon radiation in showers.
38159 MSTJ(41)=2
38160 IF(IRAD.EQ.0) MSTJ(41)=1
38161
38162C...Allow dipole pairings only among leptons and quarks separately.
38163 P12D=P12
38164 P13D=0D0
38165 IF(IQL34.EQ.IQL56) P13D=P13
38166 P21D=0D0
38167 IF(IQL12.EQ.IQL34) P21D=P21
38168 P23D=0D0
38169 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P23D=P23
38170 P31D=0D0
38171 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P31D=P31
38172 P32D=0D0
38173 IF(IQL12.EQ.IQL56) P32D=P32
38174
38175C...Decide whether t+tbar.
38176 ITOP=0
38177 IF(PYR(0).LT.PTOP) THEN
38178 ITOP=1
38179
38180C...If t+tbar: reconstruct t's.
38181 IT=N+1
38182 ITB=N+2
38183 DO 110 J=1,5
38184 K(IT,J)=0
38185 K(ITB,J)=0
38186 P(IT,J)=P(I1,J)+P(I3,J)+P(I4,J)
38187 P(ITB,J)=P(I2,J)+P(I5,J)+P(I6,J)
38188 V(IT,J)=0D0
38189 V(ITB,J)=0D0
38190 110 CONTINUE
38191 K(IT,1)=1
38192 K(ITB,1)=1
38193 K(IT,2)=6
38194 K(ITB,2)=-6
38195 P(IT,5)=SQRT(MAX(0D0,P(IT,4)**2-P(IT,1)**2-P(IT,2)**2-
38196 & P(IT,3)**2))
38197 P(ITB,5)=SQRT(MAX(0D0,P(ITB,4)**2-P(ITB,1)**2-P(ITB,2)**2-
38198 & P(ITB,3)**2))
38199 N=N+2
38200
38201C...If t+tbar: colour join t's and let them shower.
38202 IJOIN(1)=IT
38203 IJOIN(2)=ITB
38204 CALL PYJOIN(2,IJOIN)
38205 PMTTS=(P(IT,4)+P(ITB,4))**2-(P(IT,1)+P(ITB,1))**2-
38206 & (P(IT,2)+P(ITB,2))**2-(P(IT,3)+P(ITB,3))**2
38207 CALL PYSHOW(IT,ITB,SQRT(MAX(0D0,PMTTS)))
38208
38209C...If t+tbar: pick up the t's after shower.
38210 ITNEW=IT
38211 ITBNEW=ITB
38212 DO 120 I=ITB+1,N
38213 IF(K(I,2).EQ.6) ITNEW=I
38214 IF(K(I,2).EQ.-6) ITBNEW=I
38215 120 CONTINUE
38216
38217C...If t+tbar: loop over two top systems.
38218 DO 200 IT1=1,2
38219 IF(IT1.EQ.1) THEN
38220 ITO=IT
38221 ITN=ITNEW
38222 IBO=I1
38223 IW1=I3
38224 IW2=I4
38225 ELSE
38226 ITO=ITB
38227 ITN=ITBNEW
38228 IBO=I2
38229 IW1=I5
38230 IW2=I6
38231 ENDIF
38232 IF(IABS(K(IBO,2)).NE.5) CALL PYERRM(6,
38233 & '(PY6FRM:) not b in t decay')
38234
38235C...If t+tbar: find boost from original to new top frame.
38236 DO 130 J=1,3
38237 BETAO(J)=P(ITO,J)/P(ITO,4)
38238 BETAN(J)=P(ITN,J)/P(ITN,4)
38239 130 CONTINUE
38240
38241C...If t+tbar: boost copy of b by t shower and connect it in colour.
38242 N=N+1
38243 IB=N
38244 K(IB,1)=3
38245 K(IB,2)=K(IBO,2)
38246 K(IB,3)=ITN
38247 DO 140 J=1,5
38248 P(IB,J)=P(IBO,J)
38249 V(IB,J)=0D0
38250 140 CONTINUE
38251 CALL PYROBO(IB,IB,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
38252 CALL PYROBO(IB,IB,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
38253 K(IB,4)=MSTU(5)*ITN
38254 K(IB,5)=MSTU(5)*ITN
38255 K(ITN,4)=K(ITN,4)+IB
38256 K(ITN,5)=K(ITN,5)+IB
38257 K(ITN,1)=K(ITN,1)+10
38258 K(IBO,1)=K(IBO,1)+10
38259
38260C...If t+tbar: construct W recoiling against b.
38261 N=N+1
38262 IW=N
38263 DO 150 J=1,5
38264 K(IW,J)=0
38265 V(IW,J)=0D0
38266 150 CONTINUE
38267 K(IW,1)=1
38268 KCHW=PYCHGE(K(IW1,2))+PYCHGE(K(IW2,2))
38269 IF(IABS(KCHW).EQ.3) THEN
38270 K(IW,2)=ISIGN(24,KCHW)
38271 ELSE
38272 CALL PYERRM(16,'(PY6FRM:) fermion pair inconsistent with W')
38273 ENDIF
38274 K(IW,3)=IW1
38275
38276C...If t+tbar: construct W momentum, including boost by t shower.
38277 DO 160 J=1,4
38278 P(IW,J)=P(IW1,J)+P(IW2,J)
38279 160 CONTINUE
38280 P(IW,5)=SQRT(MAX(0D0,P(IW,4)**2-P(IW,1)**2-P(IW,2)**2-
38281 & P(IW,3)**2))
38282 CALL PYROBO(IW,IW,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
38283 CALL PYROBO(IW,IW,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
38284
38285C...If t+tbar: boost b and W to top rest frame.
38286 DO 170 J=1,3
38287 BETA(J)=(P(IB,J)+P(IW,J))/(P(IB,4)+P(IW,4))
38288 170 CONTINUE
38289 CALL PYROBO(IB,IB,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
38290 CALL PYROBO(IW,IW,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
38291
38292C...If t+tbar: let b shower and pick up modified W.
38293 PMTS=(P(IB,4)+P(IW,4))**2-(P(IB,1)+P(IW,1))**2-
38294 & (P(IB,2)+P(IW,2))**2-(P(IB,3)+P(IW,3))**2
38295 CALL PYSHOW(IB,IW,SQRT(MAX(0D0,PMTS)))
38296 DO 180 I=IW,N
38297 IF(IABS(K(I,2)).EQ.24) IWM=I
38298 180 CONTINUE
38299
38300C...If t+tbar: take copy of W decay products.
38301 DO 190 J=1,5
38302 K(N+1,J)=K(IW1,J)
38303 P(N+1,J)=P(IW1,J)
38304 V(N+1,J)=V(IW1,J)
38305 K(N+2,J)=K(IW2,J)
38306 P(N+2,J)=P(IW2,J)
38307 V(N+2,J)=V(IW2,J)
38308 190 CONTINUE
38309 K(IW1,1)=K(IW1,1)+10
38310 K(IW2,1)=K(IW2,1)+10
38311 K(IWM,1)=K(IWM,1)+10
38312 K(IWM,4)=N+1
38313 K(IWM,5)=N+2
38314 K(N+1,3)=IWM
38315 K(N+2,3)=IWM
38316 IF(IT1.EQ.1) THEN
38317 I3=N+1
38318 I4=N+2
38319 ELSE
38320 I5=N+1
38321 I6=N+2
38322 ENDIF
38323 N=N+2
38324
38325C...If t+tbar: boost W decay products, first by effects of t shower,
38326C...then by those of b shower. b and its shower simple boost back.
38327 CALL PYROBO(N-1,N,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
38328 CALL PYROBO(N-1,N,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
38329 CALL PYROBO(N-1,N,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
38330 CALL PYROBO(N-1,N,0D0,0D0,-P(IW,1)/P(IW,4),
38331 & -P(IW,2)/P(IW,4),-P(IW,3)/P(IW,4))
38332 CALL PYROBO(N-1,N,0D0,0D0,P(IWM,1)/P(IWM,4),
38333 & P(IWM,2)/P(IWM,4),P(IWM,3)/P(IWM,4))
38334 CALL PYROBO(IB,IB,0D0,0D0,BETA(1),BETA(2),BETA(3))
38335 CALL PYROBO(IW,N,0D0,0D0,BETA(1),BETA(2),BETA(3))
38336 200 CONTINUE
38337 ENDIF
38338
38339C...Decide on dipole pairing.
38340 IP1=I1
38341 IP3=I3
38342 IP5=I5
38343 PRN=PYR(0)*(P12D+P13D+P21D+P23D+P31D+P32D)
38344 IF(ITOP.EQ.1.OR.PRN.LT.P12D) THEN
38345 IP2=I2
38346 IP4=I4
38347 IP6=I6
38348 ELSEIF(PRN.LT.P12D+P13D) THEN
38349 IP2=I2
38350 IP4=I6
38351 IP6=I4
38352 ELSEIF(PRN.LT.P12D+P13D+P21D) THEN
38353 IP2=I4
38354 IP4=I2
38355 IP6=I6
38356 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D) THEN
38357 IP2=I4
38358 IP4=I6
38359 IP6=I2
38360 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D+P31D) THEN
38361 IP2=I6
38362 IP4=I2
38363 IP6=I4
38364 ELSE
38365 IP2=I6
38366 IP4=I4
38367 IP6=I2
38368 ENDIF
38369
38370C...Do colour joinings and parton showers
38371C...(except ones already made for t+tbar).
38372 IF(ITOP.EQ.0) THEN
38373 IF(IQL12.EQ.1) THEN
38374 IJOIN(1)=IP1
38375 IJOIN(2)=IP2
38376 CALL PYJOIN(2,IJOIN)
38377 ENDIF
38378 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
38379 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
38380 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
38381 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
38382 ENDIF
38383 ENDIF
38384 IF(IQL34.EQ.1) THEN
38385 IJOIN(1)=IP3
38386 IJOIN(2)=IP4
38387 CALL PYJOIN(2,IJOIN)
38388 ENDIF
38389 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
38390 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
38391 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
38392 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
38393 ENDIF
38394 IF(IQL56.EQ.1) THEN
38395 IJOIN(1)=IP5
38396 IJOIN(2)=IP6
38397 CALL PYJOIN(2,IJOIN)
38398 ENDIF
38399 IF(IQL56.EQ.1.OR.IRAD.EQ.1) THEN
38400 PM56S=(P(IP5,4)+P(IP6,4))**2-(P(IP5,1)+P(IP6,1))**2-
38401 & (P(IP5,2)+P(IP6,2))**2-(P(IP5,3)+P(IP6,3))**2
38402 CALL PYSHOW(IP5,IP6,SQRT(MAX(0D0,PM56S)))
38403 ENDIF
38404
38405C...Do fragmentation and decays. Possibly except tau decay.
38406 IF(ITAU.EQ.0) THEN
38407 NTAU=0
38408 DO 210 I=1,N
38409 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
38410 NTAU=NTAU+1
38411 INTAU(NTAU)=I
38412 K(I,1)=11
38413 ENDIF
38414 210 CONTINUE
38415 ENDIF
38416 CALL PYEXEC
38417 IF(ITAU.EQ.0) THEN
38418 DO 220 I=1,NTAU
38419 K(INTAU(I),1)=1
38420 220 CONTINUE
38421 ENDIF
38422
38423C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
38424 IF(ICOM.EQ.0) THEN
38425 MSTU(28)=0
38426 CALL PYHEPC(1)
38427 ENDIF
38428
38429 END
38430
38431C*********************************************************************
38432
38433C...PY4JET
38434C...An interface from a four-parton generator to include
38435C...parton showers and hadronization.
38436
38437 SUBROUTINE PY4JET(PMAX,IRAD,ICOM)
38438
38439C...Double precision and integer declarations.
38440 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38441 IMPLICIT INTEGER(I-N)
38442 INTEGER PYK,PYCHGE,PYCOMP
38443C...Commonblocks.
38444 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
38445 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38446 SAVE /PYJETS/,/PYDAT1/
38447C...Local arrays.
38448 DIMENSION IJOIN(2),PTOT(4),BETA(3)
38449
38450C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
38451 IF(ICOM.EQ.0) THEN
38452 MSTU(28)=0
38453 CALL PYHEPC(2)
38454 ENDIF
38455
38456C...Loop through entries and pick up all final partons.
38457 I1=0
38458 I2=0
38459 I3=0
38460 I4=0
38461 DO 100 I=1,N
38462 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
38463 KFA=IABS(K(I,2))
38464 IF((KFA.GE.1.AND.KFA.LE.6).OR.KFA.EQ.21) THEN
38465 IF(K(I,2).GT.0.AND.K(I,2).LE.6) THEN
38466 IF(I1.EQ.0) THEN
38467 I1=I
38468 ELSEIF(I3.EQ.0) THEN
38469 I3=I
38470 ELSE
38471 CALL PYERRM(16,'(PY4JET:) more than two quarks')
38472 ENDIF
38473 ELSEIF(K(I,2).LT.0) THEN
38474 IF(I2.EQ.0) THEN
38475 I2=I
38476 ELSEIF(I4.EQ.0) THEN
38477 I4=I
38478 ELSE
38479 CALL PYERRM(16,'(PY4JET:) more than two antiquarks')
38480 ENDIF
38481 ELSE
38482 IF(I3.EQ.0) THEN
38483 I3=I
38484 ELSEIF(I4.EQ.0) THEN
38485 I4=I
38486 ELSE
38487 CALL PYERRM(16,'(PY4JET:) more than two gluons')
38488 ENDIF
38489 ENDIF
38490 ENDIF
38491 100 CONTINUE
38492
38493C...Check that event is arranged according to conventions.
38494 IF(I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0.OR.I4.EQ.0) THEN
38495 CALL PYERRM(16,'(PY4JET:) event contains too few partons')
38496 ENDIF
38497 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
38498 CALL PYERRM(6,'(PY4JET:) partons arranged in wrong order')
38499 ENDIF
38500
38501C...Check whether second pair are quarks or gluons.
38502 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
38503 IQG34=1
38504 ELSEIF(K(I3,2).EQ.21.AND.K(I4,2).EQ.21) THEN
38505 IQG34=2
38506 ELSE
38507 CALL PYERRM(16,'(PY4JET:) second parton pair inconsistent')
38508 ENDIF
38509
38510C...Boost partons to their cm frame.
38511 DO 110 J=1,4
38512 PTOT(J)=P(I1,J)+P(I2,J)+P(I3,J)+P(I4,J)
38513 110 CONTINUE
38514 ECM=SQRT(MAX(0D0,PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2))
38515 DO 120 J=1,3
38516 BETA(J)=PTOT(J)/PTOT(4)
38517 120 CONTINUE
38518 CALL PYROBO(I1,I1,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
38519 CALL PYROBO(I2,I2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
38520 CALL PYROBO(I3,I3,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
38521 CALL PYROBO(I4,I4,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
38522 NSAV=N
38523
38524C...Decide and set up shower history for q qbar q' qbar' events.
38525 IF(IQG34.EQ.1) THEN
38526 W1=PY4JTW(0,I1,I3,I4)
38527 W2=PY4JTW(0,I2,I3,I4)
38528 IF(W1.GT.PYR(0)*(W1+W2)) THEN
38529 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
38530 ELSE
38531 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
38532 ENDIF
38533
38534C...Decide and set up shower history for q qbar g g events.
38535 ELSE
38536 W1=PY4JTW(I1,I3,I2,I4)
38537 W2=PY4JTW(I1,I4,I2,I3)
38538 W3=PY4JTW(0,I3,I1,I4)
38539 W4=PY4JTW(0,I4,I1,I3)
38540 W5=PY4JTW(0,I3,I2,I4)
38541 W6=PY4JTW(0,I4,I2,I3)
38542 W7=PY4JTW(0,I1,I3,I4)
38543 W8=PY4JTW(0,I2,I3,I4)
38544 WR=(W1+W2+W3+W4+W5+W6+W7+W8)*PYR(0)
38545 IF(W1.GT.WR) THEN
38546 CALL PY4JTS(I1,I3,I2,I4,0,QMAX)
38547 ELSEIF(W1+W2.GT.WR) THEN
38548 CALL PY4JTS(I1,I4,I2,I3,0,QMAX)
38549 ELSEIF(W1+W2+W3.GT.WR) THEN
38550 CALL PY4JTS(0,I3,I1,I4,I2,QMAX)
38551 ELSEIF(W1+W2+W3+W4.GT.WR) THEN
38552 CALL PY4JTS(0,I4,I1,I3,I2,QMAX)
38553 ELSEIF(W1+W2+W3+W4+W5.GT.WR) THEN
38554 CALL PY4JTS(0,I3,I2,I4,I1,QMAX)
38555 ELSEIF(W1+W2+W3+W4+W5+W6.GT.WR) THEN
38556 CALL PY4JTS(0,I4,I2,I3,I1,QMAX)
38557 ELSEIF(W1+W2+W3+W4+W5+W6+W7.GT.WR) THEN
38558 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
38559 ELSE
38560 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
38561 ENDIF
38562 ENDIF
38563
38564C...Boost back original partons and mark them as deleted.
38565 CALL PYROBO(I1,I1,0D0,0D0,BETA(1),BETA(2),BETA(3))
38566 CALL PYROBO(I2,I2,0D0,0D0,BETA(1),BETA(2),BETA(3))
38567 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
38568 CALL PYROBO(I4,I4,0D0,0D0,BETA(1),BETA(2),BETA(3))
38569 K(I1,1)=K(I1,1)+10
38570 K(I2,1)=K(I2,1)+10
38571 K(I3,1)=K(I3,1)+10
38572 K(I4,1)=K(I4,1)+10
38573
38574C...Rotate shower initiating partons to be along z axis.
38575 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
38576 CALL PYROBO(NSAV+1,NSAV+6,0D0,-PHI,0D0,0D0,0D0)
38577 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
38578 CALL PYROBO(NSAV+1,NSAV+6,-THE,0D0,0D0,0D0,0D0)
38579
38580C...Set up copy of shower initiating partons as on mass shell.
38581 DO 140 I=N+1,N+2
38582 DO 130 J=1,5
38583 K(I,J)=0
38584 P(I,J)=0D0
38585 V(I,J)=V(I1,J)
38586 130 CONTINUE
38587 K(I,1)=1
38588 K(I,2)=K(I-6,2)
38589 140 CONTINUE
38590 IF(K(NSAV+1,2).EQ.K(I1,2)) THEN
38591 K(N+1,3)=I1
38592 P(N+1,5)=P(I1,5)
38593 K(N+2,3)=I2
38594 P(N+2,5)=P(I2,5)
38595 ELSE
38596 K(N+1,3)=I2
38597 P(N+1,5)=P(I2,5)
38598 K(N+2,3)=I1
38599 P(N+2,5)=P(I1,5)
38600 ENDIF
38601 PABS=SQRT(MAX(0D0,(ECM**2-P(N+1,5)**2-P(N+2,5)**2)**2-
38602 &(2D0*P(N+1,5)*P(N+2,5))**2))/(2D0*ECM)
38603 P(N+1,3)=PABS
38604 P(N+1,4)=SQRT(PABS**2+P(N+1,5)**2)
38605 P(N+2,3)=-PABS
38606 P(N+2,4)=SQRT(PABS**2+P(N+2,5)**2)
38607 N=N+2
38608
38609C...Decide whether to allow or not photon radiation in showers.
38610C...Connect up colours.
38611 MSTJ(41)=2
38612 IF(IRAD.EQ.0) MSTJ(41)=1
38613 IJOIN(1)=N-1
38614 IJOIN(2)=N
38615 CALL PYJOIN(2,IJOIN)
38616
38617C...Decide on maximum virtuality and do parton shower.
38618 IF(PMAX.LT.PARJ(82)) THEN
38619 PQMAX=QMAX
38620 ELSE
38621 PQMAX=PMAX
38622 ENDIF
38623 CALL PYSHOW(NSAV+1,-8,PQMAX)
38624
38625C...Rotate and boost back system.
38626 CALL PYROBO(NSAV+1,N,THE,PHI,BETA(1),BETA(2),BETA(3))
38627
38628C...Do fragmentation and decays.
38629 CALL PYEXEC
38630
38631C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
38632 IF(ICOM.EQ.0) THEN
38633 MSTU(28)=0
38634 CALL PYHEPC(1)
38635 ENDIF
38636
38637 RETURN
38638 END
38639
38640C*********************************************************************
38641
38642C...PY4JTW
38643C...Auxiliary to PY4JET, to evaluate weight of configuration.
38644
38645 FUNCTION PY4JTW(IA1,IA2,IA3,IA4)
38646
38647C...Double precision and integer declarations.
38648 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38649 IMPLICIT INTEGER(I-N)
38650 INTEGER PYK,PYCHGE,PYCOMP
38651C...Commonblocks.
38652 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
38653 SAVE /PYJETS/
38654
38655C...First case: when both original partons radiate.
38656C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4.
38657 IF(IA1.NE.0) THEN
38658 DO 100 J=1,4
38659 P(N+1,J)=P(IA1,J)+P(IA2,J)
38660 P(N+2,J)=P(IA3,J)+P(IA4,J)
38661 100 CONTINUE
38662 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
38663 & P(N+1,3)**2))
38664 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
38665 & P(N+2,3)**2))
38666 Z1=P(IA1,4)/P(N+1,4)
38667 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-P(IA1,5)**2)
38668 Z2=P(IA3,4)/P(N+2,4)
38669 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-P(IA3,5)**2)
38670
38671C...Second case: when one original parton radiates to three.
38672C...IA1 = 0: N+1 -> IA2 + N+2, N+2 -> IA3 + IA4.
38673 ELSE
38674 DO 110 J=1,4
38675 P(N+2,J)=P(IA3,J)+P(IA4,J)
38676 P(N+1,J)=P(N+2,J)+P(IA2,J)
38677 110 CONTINUE
38678 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
38679 & P(N+1,3)**2))
38680 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
38681 & P(N+2,3)**2))
38682 IF(K(IA2,2).EQ.21) THEN
38683 Z1=P(N+2,4)/P(N+1,4)
38684 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
38685 & P(IA3,5)**2)
38686 ELSE
38687 Z1=P(IA2,4)/P(N+1,4)
38688 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
38689 & P(IA2,5)**2)
38690 ENDIF
38691 Z2=P(IA3,4)/P(N+2,4)
38692 IF(K(IA2,2).EQ.21) THEN
38693 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-
38694 & P(IA3,5)**2)
38695 ELSEIF(K(IA3,2).EQ.21) THEN
38696 WT2=3D0*((1D0-Z2*(1D0-Z2))**2/(Z2*(1D0-Z2)))/P(N+2,5)**2
38697 ELSE
38698 WT2=0.5D0*(Z2**2+(1D0-Z2)**2)
38699 ENDIF
38700 ENDIF
38701
38702C...Total weight.
38703 PY4JTW=WT1*WT2
38704
38705 RETURN
38706 END
38707
38708C*********************************************************************
38709
38710C...PY4JTS
38711C...Auxiliary to PY4JET, to set up chosen configuration.
38712
38713 SUBROUTINE PY4JTS(IA1,IA2,IA3,IA4,IA5,QMAX)
38714
38715C...Double precision and integer declarations.
38716 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38717 IMPLICIT INTEGER(I-N)
38718 INTEGER PYK,PYCHGE,PYCOMP
38719C...Commonblocks.
38720 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
38721 SAVE /PYJETS/
38722
38723C...Reset info.
38724 DO 110 I=N+1,N+6
38725 DO 100 J=1,5
38726 K(I,J)=0
38727 V(I,J)=V(IA2,J)
38728 100 CONTINUE
38729 K(I,1)=16
38730 110 CONTINUE
38731
38732C...First case: when both original partons radiate.
38733C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
38734 IF(IA1.NE.0) THEN
38735
38736C...Set up flavour and history pointers for new partons.
38737 K(N+1,2)=K(IA1,2)
38738 K(N+2,2)=K(IA3,2)
38739 K(N+3,2)=K(IA1,2)
38740 K(N+4,2)=K(IA2,2)
38741 K(N+5,2)=K(IA3,2)
38742 K(N+6,2)=K(IA4,2)
38743 K(N+1,3)=IA1
38744 K(N+1,4)=N+3
38745 K(N+1,5)=N+4
38746 K(N+2,3)=IA3
38747 K(N+2,4)=N+5
38748 K(N+2,5)=N+6
38749 K(N+3,3)=N+1
38750 K(N+4,3)=N+1
38751 K(N+5,3)=N+2
38752 K(N+6,3)=N+2
38753
38754C...Set up momenta for new partons.
38755 DO 120 J=1,5
38756 P(N+1,J)=P(IA1,J)+P(IA2,J)
38757 P(N+2,J)=P(IA3,J)+P(IA4,J)
38758 P(N+3,J)=P(IA1,J)
38759 P(N+4,J)=P(IA2,J)
38760 P(N+5,J)=P(IA3,J)
38761 P(N+6,J)=P(IA4,J)
38762 120 CONTINUE
38763 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
38764 & P(N+1,3)**2))
38765 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
38766 & P(N+2,3)**2))
38767 QMAX=MIN(P(N+1,5),P(N+2,5))
38768
38769C...Second case: q radiates twice.
38770C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
38771C...IA5=N+2 does not radiate.
38772 ELSEIF(K(IA2,2).EQ.21) THEN
38773
38774C...Set up flavour and history pointers for new partons.
38775 K(N+1,2)=K(IA3,2)
38776 K(N+2,2)=K(IA5,2)
38777 K(N+3,2)=K(IA3,2)
38778 K(N+4,2)=K(IA2,2)
38779 K(N+5,2)=K(IA3,2)
38780 K(N+6,2)=K(IA4,2)
38781 K(N+1,3)=IA3
38782 K(N+1,4)=N+3
38783 K(N+1,5)=N+4
38784 K(N+2,3)=IA5
38785 K(N+3,3)=N+1
38786 K(N+3,4)=N+5
38787 K(N+3,5)=N+6
38788 K(N+4,3)=N+1
38789 K(N+5,3)=N+3
38790 K(N+6,3)=N+3
38791
38792C...Set up momenta for new partons.
38793 DO 130 J=1,5
38794 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
38795 P(N+2,J)=P(IA5,J)
38796 P(N+3,J)=P(IA3,J)+P(IA4,J)
38797 P(N+4,J)=P(IA2,J)
38798 P(N+5,J)=P(IA3,J)
38799 P(N+6,J)=P(IA4,J)
38800 130 CONTINUE
38801 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
38802 & P(N+1,3)**2))
38803 P(N+3,5)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,1)**2-P(N+3,2)**2-
38804 & P(N+3,3)**2))
38805 QMAX=P(N+3,5)
38806
38807C...Third case: q radiates g, g branches.
38808C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
38809C...IA5=N+2 does not radiate.
38810 ELSE
38811
38812C...Set up flavour and history pointers for new partons.
38813 K(N+1,2)=K(IA2,2)
38814 K(N+2,2)=K(IA5,2)
38815 K(N+3,2)=K(IA2,2)
38816 K(N+4,2)=21
38817 K(N+5,2)=K(IA3,2)
38818 K(N+6,2)=K(IA4,2)
38819 K(N+1,3)=IA2
38820 K(N+1,4)=N+3
38821 K(N+1,5)=N+4
38822 K(N+2,3)=IA5
38823 K(N+3,3)=N+1
38824 K(N+4,3)=N+1
38825 K(N+4,4)=N+5
38826 K(N+4,5)=N+6
38827 K(N+5,3)=N+4
38828 K(N+6,3)=N+4
38829
38830C...Set up momenta for new partons.
38831 DO 140 J=1,5
38832 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
38833 P(N+2,J)=P(IA5,J)
38834 P(N+3,J)=P(IA2,J)
38835 P(N+4,J)=P(IA3,J)+P(IA4,J)
38836 P(N+5,J)=P(IA3,J)
38837 P(N+6,J)=P(IA4,J)
38838 140 CONTINUE
38839 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
38840 & P(N+1,3)**2))
38841 P(N+4,5)=SQRT(MAX(0D0,P(N+4,4)**2-P(N+4,1)**2-P(N+4,2)**2-
38842 & P(N+4,3)**2))
38843 QMAX=P(N+4,5)
38844
38845 ENDIF
38846 N=N+6
38847
38848 RETURN
38849 END
38850
38851C*********************************************************************
38852
38853C...PYJOIN
38854C...Connects a sequence of partons with colour flow indices,
38855C...as required for subsequent shower evolution (or other operations).
38856
38857 SUBROUTINE PYJOIN(NJOIN,IJOIN)
38858
38859C...Double precision and integer declarations.
38860 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38861 IMPLICIT INTEGER(I-N)
38862 INTEGER PYK,PYCHGE,PYCOMP
38863C...Commonblocks.
38864 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
38865 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38866 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38867 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
38868C...Local array.
38869 DIMENSION IJOIN(*)
38870
38871C...Check that partons are of right types to be connected.
38872 IF(NJOIN.LT.2) GOTO 120
38873 KQSUM=0
38874 DO 100 IJN=1,NJOIN
38875 I=IJOIN(IJN)
38876 IF(I.LE.0.OR.I.GT.N) GOTO 120
38877 IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
38878 KC=PYCOMP(K(I,2))
38879 IF(KC.EQ.0) GOTO 120
38880 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
38881 IF(KQ.EQ.0) GOTO 120
38882 IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
38883 IF(KQ.NE.2) KQSUM=KQSUM+KQ
38884 IF(IJN.EQ.1) KQS=KQ
38885 100 CONTINUE
38886 IF(KQSUM.NE.0) GOTO 120
38887
38888C...Connect the partons sequentially (closing for gluon loop).
38889 KCS=(9-KQS)/2
38890 IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
38891 DO 110 IJN=1,NJOIN
38892 I=IJOIN(IJN)
38893 K(I,1)=3
38894 IF(IJN.NE.1) IP=IJOIN(IJN-1)
38895 IF(IJN.EQ.1) IP=IJOIN(NJOIN)
38896 IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
38897 IF(IJN.EQ.NJOIN) IN=IJOIN(1)
38898 K(I,KCS)=MSTU(5)*IN
38899 K(I,9-KCS)=MSTU(5)*IP
38900 IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
38901 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
38902 110 CONTINUE
38903
38904C...Error exit: no action taken.
38905 RETURN
38906 120 CALL PYERRM(12,
38907 &'(PYJOIN:) given entries can not be joined by one string')
38908
38909 RETURN
38910 END
38911
38912C*********************************************************************
38913
38914C...PYGIVE
38915C...Sets values of commonblock variables.
38916
38917 SUBROUTINE PYGIVE(CHIN)
38918
38919C...Double precision and integer declarations.
38920 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38921 IMPLICIT INTEGER(I-N)
38922 INTEGER PYK,PYCHGE,PYCOMP
38923C...Commonblocks.
38924 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
38925 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38926 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38927 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
38928 COMMON/PYDAT4/CHAF(500,2)
38929 CHARACTER CHAF*16
38930 COMMON/PYDATR/MRPY(6),RRPY(100)
38931 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
38932 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38933 COMMON/PYINT1/MINT(400),VINT(400)
38934 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
38935 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
38936 COMMON/PYINT4/MWID(500),WIDS(500,5)
38937 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
38938 COMMON/PYINT6/PROC(0:500)
38939 CHARACTER PROC*28
38940 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
38941 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
38942 &XPDIR(-6:6)
38943 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
38944 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
38945 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,
38946 &/PYINT5/,/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/
38947C...Local arrays and character variables.
38948 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
38949 &CHNEW2*28,CHNAM*6,CHVAR(49)*6,CHALP(2)*26,CHIND*8,CHINI*10,
38950 &CHINR*16
38951 DIMENSION MSVAR(49,8)
38952
38953C...For each variable to be translated give: name,
38954C...integer/real/character, no. of indices, lower&upper index bounds.
38955 DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
38956 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
38957 &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
38958 &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
38959 &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
38960 &'XPANH','XPBEH','XPDIR','IMSS','RMSS'/
38961 DATA ((MSVAR(I,J),J=1,8),I=1,49)/ 1,7*0, 1,2,1,4000,1,5,2*0,
38962 &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
38963 &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
38964 &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
38965 &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,4000,1,2,2*0,
38966 &2,1,1,4000,4*0, 1,2,1,4000,1,5,2*0, 3,2,1,500,1,2,2*0,
38967 &1,1,1,6,4*0, 2,1,1,100,4*0,
38968 &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
38969 &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
38970 &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
38971 &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
38972 &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
38973 &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
38974 &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
38975 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
38976 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0/
38977 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
38978 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
38979
38980C...Length of character variable. Subdivide it into instructions.
38981 IF(MSTU(12).GE.1) CALL PYLIST(0)
38982 CHBIT=CHIN//' '
38983 LBIT=101
38984 100 LBIT=LBIT-1
38985 IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
38986 LTOT=0
38987 DO 110 LCOM=1,LBIT
38988 IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
38989 LTOT=LTOT+1
38990 CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
38991 110 CONTINUE
38992 LLOW=0
38993 120 LHIG=LLOW+1
38994 130 LHIG=LHIG+1
38995 IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
38996 LBIT=LHIG-LLOW-1
38997 CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
38998
38999C...Identify commonblock variable.
39000 LNAM=1
39001 140 LNAM=LNAM+1
39002 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
39003 &LNAM.LE.6) GOTO 140
39004 CHNAM=CHBIT(1:LNAM-1)//' '
39005 DO 160 LCOM=1,LNAM-1
39006 DO 150 LALP=1,26
39007 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
39008 & CHALP(2)(LALP:LALP)
39009 150 CONTINUE
39010 160 CONTINUE
39011 IVAR=0
39012 DO 170 IV=1,49
39013 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
39014 170 CONTINUE
39015 IF(IVAR.EQ.0) THEN
39016 CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM)
39017 LLOW=LHIG
39018 IF(LLOW.LT.LTOT) GOTO 120
39019 RETURN
39020 ENDIF
39021
39022C...Identify any indices.
39023 I1=0
39024 I2=0
39025 I3=0
39026 NINDX=0
39027 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
39028 LIND=LNAM
39029 180 LIND=LIND+1
39030 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 180
39031 CHIND=' '
39032 IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c')
39033 & .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17))
39034 & THEN
39035 CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
39036 READ(CHIND,'(I8)') KF
39037 I1=PYCOMP(KF)
39038 ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
39039 & 'c') THEN
39040 CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '//
39041 & CHNAM)
39042 LLOW=LHIG
39043 IF(LLOW.LT.LTOT) GOTO 120
39044 RETURN
39045 ELSE
39046 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
39047 READ(CHIND,'(I8)') I1
39048 ENDIF
39049 LNAM=LIND
39050 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
39051 NINDX=1
39052 ENDIF
39053 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
39054 LIND=LNAM
39055 190 LIND=LIND+1
39056 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
39057 CHIND=' '
39058 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
39059 READ(CHIND,'(I8)') I2
39060 LNAM=LIND
39061 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
39062 NINDX=2
39063 ENDIF
39064 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
39065 LIND=LNAM
39066 200 LIND=LIND+1
39067 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
39068 CHIND=' '
39069 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
39070 READ(CHIND,'(I8)') I3
39071 LNAM=LIND+1
39072 NINDX=3
39073 ENDIF
39074
39075C...Check that indices allowed.
39076 IERR=0
39077 IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
39078 IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
39079 &IERR=2
39080 IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
39081 &IERR=3
39082 IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
39083 &IERR=4
39084 IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
39085 IF(IERR.GE.1) THEN
39086 CALL PYERRM(18,'(PYGIVE:) unallowed indices for '//
39087 & CHBIT(1:LNAM-1))
39088 LLOW=LHIG
39089 IF(LLOW.LT.LTOT) GOTO 120
39090 RETURN
39091 ENDIF
39092
39093C...Save old value of variable.
39094 IF(IVAR.EQ.1) THEN
39095 IOLD=N
39096 ELSEIF(IVAR.EQ.2) THEN
39097 IOLD=K(I1,I2)
39098 ELSEIF(IVAR.EQ.3) THEN
39099 ROLD=P(I1,I2)
39100 ELSEIF(IVAR.EQ.4) THEN
39101 ROLD=V(I1,I2)
39102 ELSEIF(IVAR.EQ.5) THEN
39103 IOLD=MSTU(I1)
39104 ELSEIF(IVAR.EQ.6) THEN
39105 ROLD=PARU(I1)
39106 ELSEIF(IVAR.EQ.7) THEN
39107 IOLD=MSTJ(I1)
39108 ELSEIF(IVAR.EQ.8) THEN
39109 ROLD=PARJ(I1)
39110 ELSEIF(IVAR.EQ.9) THEN
39111 IOLD=KCHG(I1,I2)
39112 ELSEIF(IVAR.EQ.10) THEN
39113 ROLD=PMAS(I1,I2)
39114 ELSEIF(IVAR.EQ.11) THEN
39115 ROLD=PARF(I1)
39116 ELSEIF(IVAR.EQ.12) THEN
39117 ROLD=VCKM(I1,I2)
39118 ELSEIF(IVAR.EQ.13) THEN
39119 IOLD=MDCY(I1,I2)
39120 ELSEIF(IVAR.EQ.14) THEN
39121 IOLD=MDME(I1,I2)
39122 ELSEIF(IVAR.EQ.15) THEN
39123 ROLD=BRAT(I1)
39124 ELSEIF(IVAR.EQ.16) THEN
39125 IOLD=KFDP(I1,I2)
39126 ELSEIF(IVAR.EQ.17) THEN
39127 CHOLD=CHAF(I1,I2)
39128 ELSEIF(IVAR.EQ.18) THEN
39129 IOLD=MRPY(I1)
39130 ELSEIF(IVAR.EQ.19) THEN
39131 ROLD=RRPY(I1)
39132 ELSEIF(IVAR.EQ.20) THEN
39133 IOLD=MSEL
39134 ELSEIF(IVAR.EQ.21) THEN
39135 IOLD=MSUB(I1)
39136 ELSEIF(IVAR.EQ.22) THEN
39137 IOLD=KFIN(I1,I2)
39138 ELSEIF(IVAR.EQ.23) THEN
39139 ROLD=CKIN(I1)
39140 ELSEIF(IVAR.EQ.24) THEN
39141 IOLD=MSTP(I1)
39142 ELSEIF(IVAR.EQ.25) THEN
39143 ROLD=PARP(I1)
39144 ELSEIF(IVAR.EQ.26) THEN
39145 IOLD=MSTI(I1)
39146 ELSEIF(IVAR.EQ.27) THEN
39147 ROLD=PARI(I1)
39148 ELSEIF(IVAR.EQ.28) THEN
39149 IOLD=MINT(I1)
39150 ELSEIF(IVAR.EQ.29) THEN
39151 ROLD=VINT(I1)
39152 ELSEIF(IVAR.EQ.30) THEN
39153 IOLD=ISET(I1)
39154 ELSEIF(IVAR.EQ.31) THEN
39155 IOLD=KFPR(I1,I2)
39156 ELSEIF(IVAR.EQ.32) THEN
39157 ROLD=COEF(I1,I2)
39158 ELSEIF(IVAR.EQ.33) THEN
39159 IOLD=ICOL(I1,I2,I3)
39160 ELSEIF(IVAR.EQ.34) THEN
39161 ROLD=XSFX(I1,I2)
39162 ELSEIF(IVAR.EQ.35) THEN
39163 IOLD=ISIG(I1,I2)
39164 ELSEIF(IVAR.EQ.36) THEN
39165 ROLD=SIGH(I1)
39166 ELSEIF(IVAR.EQ.37) THEN
39167 IOLD=MWID(I1)
39168 ELSEIF(IVAR.EQ.38) THEN
39169 ROLD=WIDS(I1,I2)
39170 ELSEIF(IVAR.EQ.39) THEN
39171 IOLD=NGEN(I1,I2)
39172 ELSEIF(IVAR.EQ.40) THEN
39173 ROLD=XSEC(I1,I2)
39174 ELSEIF(IVAR.EQ.41) THEN
39175 CHOLD2=PROC(I1)
39176 ELSEIF(IVAR.EQ.42) THEN
39177 ROLD=SIGT(I1,I2,I3)
39178 ELSEIF(IVAR.EQ.43) THEN
39179 ROLD=XPVMD(I1)
39180 ELSEIF(IVAR.EQ.44) THEN
39181 ROLD=XPANL(I1)
39182 ELSEIF(IVAR.EQ.45) THEN
39183 ROLD=XPANH(I1)
39184 ELSEIF(IVAR.EQ.46) THEN
39185 ROLD=XPBEH(I1)
39186 ELSEIF(IVAR.EQ.47) THEN
39187 ROLD=XPDIR(I1)
39188 ELSEIF(IVAR.EQ.48) THEN
39189 IOLD=IMSS(I1)
39190 ELSEIF(IVAR.EQ.49) THEN
39191 ROLD=RMSS(I1)
39192 ENDIF
39193
39194C...Print current value of variable. Loop back.
39195 IF(LNAM.GE.LBIT) THEN
39196 CHBIT(LNAM:14)=' '
39197 CHBIT(15:60)=' has the value '
39198 IF(MSVAR(IVAR,1).EQ.1) THEN
39199 WRITE(CHBIT(51:60),'(I10)') IOLD
39200 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
39201 WRITE(CHBIT(47:60),'(F14.5)') ROLD
39202 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
39203 CHBIT(53:60)=CHOLD
39204 ELSE
39205 CHBIT(33:60)=CHOLD
39206 ENDIF
39207 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
39208 LLOW=LHIG
39209 IF(LLOW.LT.LTOT) GOTO 120
39210 RETURN
39211 ENDIF
39212
39213C...Read in new variable value.
39214 IF(MSVAR(IVAR,1).EQ.1) THEN
39215 CHINI=' '
39216 CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
39217 READ(CHINI,'(I10)') INEW
39218 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
39219 CHINR=' '
39220 CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
39221 READ(CHINR,*) RNEW
39222 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
39223 CHNEW=CHBIT(LNAM+1:LBIT)//' '
39224 ELSE
39225 CHNEW2=CHBIT(LNAM+1:LBIT)//' '
39226 ENDIF
39227
39228C...Store new variable value.
39229 IF(IVAR.EQ.1) THEN
39230 N=INEW
39231 ELSEIF(IVAR.EQ.2) THEN
39232 K(I1,I2)=INEW
39233 ELSEIF(IVAR.EQ.3) THEN
39234 P(I1,I2)=RNEW
39235 ELSEIF(IVAR.EQ.4) THEN
39236 V(I1,I2)=RNEW
39237 ELSEIF(IVAR.EQ.5) THEN
39238 MSTU(I1)=INEW
39239 ELSEIF(IVAR.EQ.6) THEN
39240 PARU(I1)=RNEW
39241 ELSEIF(IVAR.EQ.7) THEN
39242 MSTJ(I1)=INEW
39243 ELSEIF(IVAR.EQ.8) THEN
39244 PARJ(I1)=RNEW
39245 ELSEIF(IVAR.EQ.9) THEN
39246 KCHG(I1,I2)=INEW
39247 ELSEIF(IVAR.EQ.10) THEN
39248 PMAS(I1,I2)=RNEW
39249 ELSEIF(IVAR.EQ.11) THEN
39250 PARF(I1)=RNEW
39251 ELSEIF(IVAR.EQ.12) THEN
39252 VCKM(I1,I2)=RNEW
39253 ELSEIF(IVAR.EQ.13) THEN
39254 MDCY(I1,I2)=INEW
39255 ELSEIF(IVAR.EQ.14) THEN
39256 MDME(I1,I2)=INEW
39257 ELSEIF(IVAR.EQ.15) THEN
39258 BRAT(I1)=RNEW
39259 ELSEIF(IVAR.EQ.16) THEN
39260 KFDP(I1,I2)=INEW
39261 ELSEIF(IVAR.EQ.17) THEN
39262 CHAF(I1,I2)=CHNEW
39263 ELSEIF(IVAR.EQ.18) THEN
39264 MRPY(I1)=INEW
39265 ELSEIF(IVAR.EQ.19) THEN
39266 RRPY(I1)=RNEW
39267 ELSEIF(IVAR.EQ.20) THEN
39268 MSEL=INEW
39269 ELSEIF(IVAR.EQ.21) THEN
39270 MSUB(I1)=INEW
39271 ELSEIF(IVAR.EQ.22) THEN
39272 KFIN(I1,I2)=INEW
39273 ELSEIF(IVAR.EQ.23) THEN
39274 CKIN(I1)=RNEW
39275 ELSEIF(IVAR.EQ.24) THEN
39276 MSTP(I1)=INEW
39277 ELSEIF(IVAR.EQ.25) THEN
39278 PARP(I1)=RNEW
39279 ELSEIF(IVAR.EQ.26) THEN
39280 MSTI(I1)=INEW
39281 ELSEIF(IVAR.EQ.27) THEN
39282 PARI(I1)=RNEW
39283 ELSEIF(IVAR.EQ.28) THEN
39284 MINT(I1)=INEW
39285 ELSEIF(IVAR.EQ.29) THEN
39286 VINT(I1)=RNEW
39287 ELSEIF(IVAR.EQ.30) THEN
39288 ISET(I1)=INEW
39289 ELSEIF(IVAR.EQ.31) THEN
39290 KFPR(I1,I2)=INEW
39291 ELSEIF(IVAR.EQ.32) THEN
39292 COEF(I1,I2)=RNEW
39293 ELSEIF(IVAR.EQ.33) THEN
39294 ICOL(I1,I2,I3)=INEW
39295 ELSEIF(IVAR.EQ.34) THEN
39296 XSFX(I1,I2)=RNEW
39297 ELSEIF(IVAR.EQ.35) THEN
39298 ISIG(I1,I2)=INEW
39299 ELSEIF(IVAR.EQ.36) THEN
39300 SIGH(I1)=RNEW
39301 ELSEIF(IVAR.EQ.37) THEN
39302 MWID(I1)=INEW
39303 ELSEIF(IVAR.EQ.38) THEN
39304 WIDS(I1,I2)=RNEW
39305 ELSEIF(IVAR.EQ.39) THEN
39306 NGEN(I1,I2)=INEW
39307 ELSEIF(IVAR.EQ.40) THEN
39308 XSEC(I1,I2)=RNEW
39309 ELSEIF(IVAR.EQ.41) THEN
39310 PROC(I1)=CHNEW2
39311 ELSEIF(IVAR.EQ.42) THEN
39312 SIGT(I1,I2,I3)=RNEW
39313 ELSEIF(IVAR.EQ.43) THEN
39314 XPVMD(I1)=RNEW
39315 ELSEIF(IVAR.EQ.44) THEN
39316 XPANL(I1)=RNEW
39317 ELSEIF(IVAR.EQ.45) THEN
39318 XPANH(I1)=RNEW
39319 ELSEIF(IVAR.EQ.46) THEN
39320 XPBEH(I1)=RNEW
39321 ELSEIF(IVAR.EQ.47) THEN
39322 XPDIR(I1)=RNEW
39323 ELSEIF(IVAR.EQ.48) THEN
39324 IMSS(I1)=INEW
39325 ELSEIF(IVAR.EQ.49) THEN
39326 RMSS(I1)=RNEW
39327 ENDIF
39328
39329C...Write old and new value. Loop back.
39330 CHBIT(LNAM:14)=' '
39331 CHBIT(15:60)=' changed from to '
39332 IF(MSVAR(IVAR,1).EQ.1) THEN
39333 WRITE(CHBIT(33:42),'(I10)') IOLD
39334 WRITE(CHBIT(51:60),'(I10)') INEW
39335 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
39336 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
39337 WRITE(CHBIT(29:42),'(F14.5)') ROLD
39338 WRITE(CHBIT(47:60),'(F14.5)') RNEW
39339 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
39340 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
39341 CHBIT(35:42)=CHOLD
39342 CHBIT(53:60)=CHNEW
39343 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
39344 ELSE
39345 CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
39346 IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
39347 ENDIF
39348 LLOW=LHIG
39349 IF(LLOW.LT.LTOT) GOTO 120
39350
39351C...Format statement for output on unit MSTU(11) (by default 6).
39352 5000 FORMAT(5X,A60)
39353 5100 FORMAT(5X,A88)
39354
39355 RETURN
39356 END
39357
39358C*********************************************************************
39359
39360C...PYEXEC
39361C...Administrates the fragmentation and decay chain.
39362
39363 SUBROUTINE PYEXEC
39364
39365C...Double precision and integer declarations.
39366 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39367 IMPLICIT INTEGER(I-N)
39368 INTEGER PYK,PYCHGE,PYCOMP
39369C...Commonblocks.
39370 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
39371 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39372 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39373 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
39374 COMMON/PYINT4/MWID(500),WIDS(500,5)
39375 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT4/
39376C...Local array.
39377 DIMENSION PS(2,6),IJOIN(100)
39378
39379C...Initialize and reset.
39380 MSTU(24)=0
39381 IF(MSTU(12).GE.1) CALL PYLIST(0)
39382 MSTU(31)=MSTU(31)+1
39383 MSTU(1)=0
39384 MSTU(2)=0
39385 MSTU(3)=0
39386 IF(MSTU(17).LE.0) MSTU(90)=0
39387 MCONS=1
39388
39389C...Sum up momentum, energy and charge for starting entries.
39390 NSAV=N
39391 DO 110 I=1,2
39392 DO 100 J=1,6
39393 PS(I,J)=0D0
39394 100 CONTINUE
39395 110 CONTINUE
39396 DO 130 I=1,N
39397 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
39398 DO 120 J=1,4
39399 PS(1,J)=PS(1,J)+P(I,J)
39400 120 CONTINUE
39401 PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
39402 130 CONTINUE
39403 PARU(21)=PS(1,4)
39404
39405C...Prepare system for subsequent fragmentation/decay.
39406 CALL PYPREP(0)
39407
39408C...Loop through jet fragmentation and particle decays.
39409 MBE=0
39410 140 MBE=MBE+1
39411 IP=0
39412 150 IP=IP+1
39413 KC=0
39414 IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
39415 IF(KC.EQ.0) THEN
39416
39417C...Deal with any remaining undecayed resonance
39418C...(normally the task of PYEVNT, so seldom used).
39419 ELSEIF(MWID(KC).NE.0) THEN
39420 IBEG=IP
39421 IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
39422 IBEG=IP+1
39423 160 IBEG=IBEG-1
39424 IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 160
39425 IF(K(IBEG,1).NE.2) IBEG=IBEG+1
39426 IEND=IP-1
39427 170 IEND=IEND+1
39428 IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 170
39429 IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 170
39430 NJOIN=0
39431 DO 180 I=IBEG,IEND
39432 IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
39433 NJOIN=NJOIN+1
39434 IJOIN(NJOIN)=I
39435 ENDIF
39436 180 CONTINUE
39437 ENDIF
39438 CALL PYRESD(IP)
39439 CALL PYPREP(IBEG)
39440
39441C...Particle decay if unstable and allowed. Save long-lived particle
39442C...decays until second pass after Bose-Einstein effects.
39443 ELSEIF(KCHG(KC,2).EQ.0) THEN
39444 IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
39445 & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
39446 & CALL PYDECY(IP)
39447
39448C...Decay products may develop a shower.
39449 IF(MSTJ(92).GT.0) THEN
39450 IP1=MSTJ(92)
39451 QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
39452 & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
39453 CALL PYSHOW(IP1,IP1+1,QMAX)
39454 CALL PYPREP(IP1)
39455 MSTJ(92)=0
39456 ELSEIF(MSTJ(92).LT.0) THEN
39457 IP1=-MSTJ(92)
39458 CALL PYSHOW(IP1,-3,P(IP,5))
39459 CALL PYPREP(IP1)
39460 MSTJ(92)=0
39461 ENDIF
39462
39463C...Jet fragmentation: string or independent fragmentation.
39464 ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
39465 MFRAG=MSTJ(1)
39466 IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
39467 IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
39468 IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
39469 & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
39470 IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
39471 ENDIF
39472 ENDIF
39473 IF(MFRAG.EQ.1) CALL PYSTRF(IP)
39474 IF(MFRAG.EQ.2) CALL PYINDF(IP)
39475 IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
39476 IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
39477 ENDIF
39478
39479C...Loop back if enough space left in PYJETS and no error abort.
39480 IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
39481 ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
39482 GOTO 150
39483 ELSEIF(IP.LT.N) THEN
39484 CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
39485 ENDIF
39486
39487C...Include simple Bose-Einstein effect parametrization if desired.
39488 IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
39489 CALL PYBOEI(NSAV)
39490 GOTO 140
39491 ENDIF
39492
39493C...Check that momentum, energy and charge were conserved.
39494 DO 200 I=1,N
39495 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 200
39496 DO 190 J=1,4
39497 PS(2,J)=PS(2,J)+P(I,J)
39498 190 CONTINUE
39499 PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
39500 200 CONTINUE
39501 PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
39502 &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
39503 IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
39504 &'(PYEXEC:) four-momentum was not conserved')
39505 IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
39506 &'(PYEXEC:) charge was not conserved')
39507
39508 RETURN
39509 END
39510
39511C*********************************************************************
39512
39513C...PYPREP
39514C...Rearranges partons along strings.
39515C...Allows small systems to collapse into one or two particles.
39516C...Checks flavours and colour singlet invarient masses.
39517
39518 SUBROUTINE PYPREP(IP)
39519
39520C...Double precision and integer declarations.
39521 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39522 INTEGER PYK,PYCHGE,PYCOMP
39523C...Commonblocks.
39524 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
39525 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39526 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39527 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
39528 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
39529C...Local arrays.
39530 DIMENSION DPS(5),DPC(5),UE(3),PG(5),
39531 &E1(3),E2(3),E3(3),E4(3),ECL(3)
39532
39533C...Function to give four-product.
39534 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)
39535
39536C...Rearrange parton shower product listing along strings: begin loop.
39537 I1=N
39538 DO 130 MQGST=1,2
39539 DO 120 I=MAX(1,IP),N
39540 IF(K(I,1).NE.3) GOTO 120
39541 KC=PYCOMP(K(I,2))
39542 IF(KC.EQ.0) GOTO 120
39543 KQ=KCHG(KC,2)
39544 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 120
39545
39546C...Pick up loose string end.
39547 KCS=4
39548 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
39549 IA=I
39550 NSTP=0
39551 100 NSTP=NSTP+1
39552 IF(NSTP.GT.4*N) THEN
39553 CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
39554 RETURN
39555 ENDIF
39556
39557C...Copy undecayed parton.
39558 IF(K(IA,1).EQ.3) THEN
39559 IF(I1.GE.MSTU(4)-MSTU(32)-5) THEN
39560 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
39561 RETURN
39562 ENDIF
39563 I1=I1+1
39564 K(I1,1)=2
39565 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1
39566 K(I1,2)=K(IA,2)
39567 K(I1,3)=IA
39568 K(I1,4)=0
39569 K(I1,5)=0
39570 DO 110 J=1,5
39571 P(I1,J)=P(IA,J)
39572 V(I1,J)=V(IA,J)
39573 110 CONTINUE
39574 K(IA,1)=K(IA,1)+10
39575 IF(K(I1,1).EQ.1) GOTO 120
39576 ENDIF
39577
39578C...Go to next parton in colour space.
39579 IB=IA
39580 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
39581 & .NE.0) THEN
39582 IA=MOD(K(IB,KCS),MSTU(5))
39583 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
39584 MREV=0
39585 ELSE
39586 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
39587 & MSTU(5)).EQ.0) KCS=9-KCS
39588 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
39589 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
39590 MREV=1
39591 ENDIF
39592 IF(IA.LE.0.OR.IA.GT.N) THEN
39593 CALL PYERRM(12,'(PYPREP:) colour rearrangement failed')
39594 RETURN
39595 ENDIF
39596 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
39597 & MSTU(5)).EQ.IB) THEN
39598 IF(MREV.EQ.1) KCS=9-KCS
39599 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
39600 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
39601 ELSE
39602 IF(MREV.EQ.0) KCS=9-KCS
39603 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
39604 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
39605 ENDIF
39606 IF(IA.NE.I) GOTO 100
39607 K(I1,1)=1
39608 120 CONTINUE
39609 130 CONTINUE
39610 N=I1
39611
39612C...Done if no checks on small-mass systems.
39613 IF(MSTJ(14).LT.0) RETURN
39614 IF(MSTJ(14).EQ.0) GOTO 540
39615
39616C...Find lowest-mass colour singlet jet system.
39617 NS=N
39618 140 NSIN=N-NS
39619 PDMIN=1D0+PARJ(32)
39620 IC=0
39621 DO 190 I=MAX(1,IP),N
39622 IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
39623 ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
39624 NSIN=NSIN+1
39625 IC=I
39626 DO 150 J=1,4
39627 DPS(J)=P(I,J)
39628 150 CONTINUE
39629 MSTJ(93)=1
39630 DPS(5)=PYMASS(K(I,2))
39631 ELSEIF(K(I,1).EQ.2) THEN
39632 DO 160 J=1,4
39633 DPS(J)=DPS(J)+P(I,J)
39634 160 CONTINUE
39635 ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
39636 DO 170 J=1,4
39637 DPS(J)=DPS(J)+P(I,J)
39638 170 CONTINUE
39639 MSTJ(93)=1
39640 DPS(5)=DPS(5)+PYMASS(K(I,2))
39641 PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-
39642 & DPS(5)
39643 IF(PD.LT.PDMIN) THEN
39644 PDMIN=PD
39645 DO 180 J=1,5
39646 DPC(J)=DPS(J)
39647 180 CONTINUE
39648 IC1=IC
39649 IC2=I
39650 ENDIF
39651 IC=0
39652 ELSE
39653 NSIN=NSIN+1
39654 ENDIF
39655 190 CONTINUE
39656
39657C...Done if lowest-mass system above threshold for string frag.
39658 IF(PDMIN.GE.PARJ(32)) GOTO 540
39659
39660C...Fill small-mass system as cluster.
39661 NSAV=N
39662 PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
39663 K(N+1,1)=11
39664 K(N+1,2)=91
39665 K(N+1,3)=IC1
39666 P(N+1,1)=DPC(1)
39667 P(N+1,2)=DPC(2)
39668 P(N+1,3)=DPC(3)
39669 P(N+1,4)=DPC(4)
39670 P(N+1,5)=PECM
39671
39672C...Set up history, assuming cluster -> 2 hadrons.
39673 NBODY=2
39674 K(N+1,4)=N+2
39675 K(N+1,5)=N+3
39676 K(N+2,1)=1
39677 K(N+3,1)=1
39678 IF(MSTU(16).NE.2) THEN
39679 K(N+2,3)=N+1
39680 K(N+3,3)=N+1
39681 ELSE
39682 K(N+2,3)=IC1
39683 K(N+3,3)=IC2
39684 ENDIF
39685 K(N+2,4)=0
39686 K(N+3,4)=0
39687 K(N+2,5)=0
39688 K(N+3,5)=0
39689 V(N+1,5)=0D0
39690 V(N+2,5)=0D0
39691 V(N+3,5)=0D0
39692
39693C...Form two particles from flavours of lowest-mass system, if feasible.
39694 NTRY = 0
39695 200 NTRY = NTRY + 1
39696C...Open string.
39697 IF(IABS(K(IC1,2)).NE.21) THEN
39698 KC1=PYCOMP(K(IC1,2))
39699 KC2=PYCOMP(K(IC2,2))
39700 IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 540
39701 KQ1=KCHG(KC1,2)*ISIGN(1,K(IC1,2))
39702 KQ2=KCHG(KC2,2)*ISIGN(1,K(IC2,2))
39703 IF(KQ1+KQ2.NE.0) GOTO 540
39704C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
39705 210 K1=K(IC1,2)
39706 IF(IABS(K(IC2,2)).GT.10) K1=K(IC2,2)
39707 MSTU(125)=0
39708 CALL PYDCYK(K1,0,KFLN,K(N+2,2))
39709 CALL PYDCYK(K(IC1,2)+K(IC2,2)-K1,-KFLN,KFLDMP,K(N+3,2))
39710 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 210
39711C...Closed string.
39712 ELSE
39713 IF(IABS(K(IC2,2)).NE.21) GOTO 540
39714C...No room for popcorn mesons in closed string -> 2 hadrons.
39715 MSTU(125)=0
39716 220 CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
39717 CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
39718 CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
39719 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 220
39720 ENDIF
39721 P(N+2,5)=PYMASS(K(N+2,2))
39722 P(N+3,5)=PYMASS(K(N+3,2))
39723
39724C...If it does not work: try again (a number of times), give up
39725C...(if no place to shuffle momentum), or form one hadron.
39726 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) THEN
39727 IF(NTRY.LT.MSTJ(17)) THEN
39728 GOTO 200
39729 ELSEIF(NSIN.EQ.1) THEN
39730 GOTO 540
39731 ELSE
39732 GOTO 290
39733 END IF
39734 END IF
39735
39736C...Perform two-particle decay of jet system.
39737C...First step: find reference axis in decaying system rest frame.
39738C...(Borrow slot N+2 for temporary direction.)
39739 DO 230 J=1,4
39740 P(N+2,J)=P(IC1,J)
39741 230 CONTINUE
39742 DO 250 I=IC1+1,IC2-1
39743 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
39744 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
39745 FRAC1=FOUR(IC2,I)/(FOUR(IC1,I)+FOUR(IC2,I))
39746 DO 240 J=1,4
39747 P(N+2,J)=P(N+2,J)+FRAC1*P(I,J)
39748 240 CONTINUE
39749 ENDIF
39750 250 CONTINUE
39751 CALL PYROBO(N+2,N+2,0D0,0D0,-DPC(1)/DPC(4),-DPC(2)/DPC(4),
39752 &-DPC(3)/DPC(4))
39753 THE1=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
39754 PHI1=PYANGL(P(N+2,1),P(N+2,2))
39755
39756C...Second step: generate isotropic/anisotropic decay.
39757 PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
39758 &(P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
39759 260 UE(3)=PYR(0)
39760 PT2=(1D0-UE(3)**2)*PA**2
39761 IF(MSTJ(16).LE.0) THEN
39762 PREV=0.5D0
39763 ELSE
39764 IF(EXP(-PT2/(2D0*PARJ(21)**2)).LT.PYR(0)) GOTO 260
39765 PR1=P(N+2,5)**2+PT2
39766 PR2=P(N+3,5)**2+PT2
39767 ALAMBD=SQRT(MAX(0D0,(PECM**2-PR1-PR2)**2-4D0*PR1*PR2))
39768 PREVCF=PARJ(42)
39769 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
39770 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*ALAMBD)))
39771 ENDIF
39772 IF(PYR(0).LT.PREV) UE(3)=-UE(3)
39773 PHI=PARU(2)*PYR(0)
39774 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
39775 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
39776 DO 270 J=1,3
39777 P(N+2,J)=PA*UE(J)
39778 P(N+3,J)=-PA*UE(J)
39779 270 CONTINUE
39780 P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
39781 P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
39782
39783C...Third step: move back to event frame and set production vertex.
39784 CALL PYROBO(N+2,N+3,THE1,PHI1,DPC(1)/DPC(4),DPC(2)/DPC(4),
39785 &DPC(3)/DPC(4))
39786 DO 280 J=1,4
39787 V(N+1,J)=V(IC1,J)
39788 V(N+2,J)=V(IC1,J)
39789 V(N+3,J)=V(IC2,J)
39790 280 CONTINUE
39791 N=N+3
39792 GOTO 520
39793
39794C...Else form one particle, if possible.
39795 290 NBODY=1
39796 K(N+1,5)=N+2
39797 DO 300 J=1,4
39798 V(N+1,J)=V(IC1,J)
39799 V(N+2,J)=V(IC1,J)
39800 300 CONTINUE
39801
39802C...Select hadron flavour from available quark flavours.
39803 310 IF(IABS(K(IC1,2)).GT.100.AND.IABS(K(IC2,2)).GT.100) THEN
39804 GOTO 540
39805 ELSEIF(IABS(K(IC1,2)).NE.21) THEN
39806 CALL PYKFDI(K(IC1,2),K(IC2,2),KFLDMP,K(N+2,2))
39807 ELSE
39808 KFLN=1+INT((2D0+PARJ(2))*PYR(0))
39809 CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
39810 ENDIF
39811 IF(K(N+2,2).EQ.0) GOTO 310
39812 P(N+2,5)=PYMASS(K(N+2,2))
39813
39814C...Use old algorithm for E/p conservation? (EN)
39815 IF (MSTJ(16).LE.0) GOTO 480
39816
39817C...Find the string piece closest to the cluster by a loop
39818C...over the undecayed partons not in present cluster. (EN)
39819 DGLOMI=1D30
39820 IBEG=0
39821 I0=0
39822 DO 340 I1=MAX(1,IP),N-1
39823 IF(I1.GE.IC1-1.AND.I1.LE.IC2) THEN
39824 I0=0
39825 ELSEIF(K(I1,1).EQ.2) THEN
39826 IF(I0.EQ.0) I0=I1
39827 I2=I1
39828 320 I2=I2+1
39829 IF(KCHG(PYCOMP(K(I2,2)),2).EQ.0) GOTO 320
39830
39831C...Define velocity vectors e1, e2, ecl and differences e3, e4.
39832 DO 330 J=1,3
39833 E1(J)=P(I1,J)/P(I1,4)
39834 E2(J)=P(I2,J)/P(I2,4)
39835 ECL(J)=P(N+1,J)/P(N+1,4)
39836 E3(J)=E2(J)-E1(J)
39837 E4(J)=ECL(J)-E1(J)
39838 330 CONTINUE
39839
39840C...Calculate minimal D=(e4-alpha*e3)**2 for 0<alpha<1.
39841 E3S=E3(1)**2+E3(2)**2+E3(3)**2
39842 E4S=E4(1)**2+E4(2)**2+E4(3)**2
39843 E34=E3(1)*E4(1)+E3(2)*E4(2)+E3(3)*E4(3)
39844 IF(E34.LE.0D0) THEN
39845 DDMIN=E4S
39846 ELSEIF(E34.LT.E3S) THEN
39847 DDMIN=E4S-E34**2/E3S
39848 ELSE
39849 DDMIN=E4S-2D0*E34+E3S
39850 ENDIF
39851
39852C...Is this the smallest so far?
39853 IF(DDMIN.LT.DGLOMI) THEN
39854 DGLOMI=DDMIN
39855 IBEG=I0
39856 IPCS=I1
39857 ENDIF
39858 ELSEIF(K(I1,1).EQ.1.AND.KCHG(PYCOMP(K(I1,2)),2).NE.0) THEN
39859 I0=0
39860 ENDIF
39861 340 CONTINUE
39862
39863C... Check if there are any strings to connect to the new gluon. (EN)
39864 IF (IBEG.EQ.0) GOTO 480
39865
39866C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
39867 IF (P(N+1,5).GE.P(N+2,5)) THEN
39868
39869C...Construct 'gluon' that is needed to put hadron on the mass shell.
39870 FRAC=P(N+2,5)/P(N+1,5)
39871 DO 350 J=1,5
39872 P(N+2,J)=FRAC*P(N+1,J)
39873 PG(J)=(1D0-FRAC)*P(N+1,J)
39874 350 CONTINUE
39875
39876C... Copy string with new gluon put in.
39877 N=N+2
39878 I=IBEG-1
39879 360 I=I+1
39880 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 360
39881 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0) GOTO 360
39882 N=N+1
39883 DO 370 J=1,5
39884 K(N,J)=K(I,J)
39885 P(N,J)=P(I,J)
39886 V(N,J)=V(I,J)
39887 370 CONTINUE
39888 K(I,1)=K(I,1)+10
39889 K(I,4)=N
39890 K(I,5)=N
39891 K(N,3)=I
39892 IF(I.EQ.IPCS) THEN
39893 N=N+1
39894 DO 380 J=1,5
39895 K(N,J)=K(N-1,J)
39896 P(N,J)=PG(J)
39897 V(N,J)=V(N-1,J)
39898 380 CONTINUE
39899 K(N,2)=21
39900 K(N,3)=NSAV+1
39901 ENDIF
39902 IF(K(I,1).EQ.12) GOTO 360
39903 GOTO 520
39904
39905C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
39906C...from string piece endpoints.
39907 ELSE
39908
39909C...Begin by copying string that should give energy to cluster.
39910 N=N+2
39911 I=IBEG-1
39912 390 I=I+1
39913 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 390
39914 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0) GOTO 390
39915 N=N+1
39916 DO 400 J=1,5
39917 K(N,J)=K(I,J)
39918 P(N,J)=P(I,J)
39919 V(N,J)=V(I,J)
39920 400 CONTINUE
39921 K(I,1)=K(I,1)+10
39922 K(I,4)=N
39923 K(I,5)=N
39924 K(N,3)=I
39925 IF(I.EQ.IPCS) I1=N
39926 IF(K(I,1).EQ.12) GOTO 390
39927 I2=I1+1
39928
39929C...Set initial Phad.
39930 DO 410 J=1,4
39931 P(NSAV+2,J)=P(NSAV+1,J)
39932 410 CONTINUE
39933
39934C...Calculate Pg, a part of which will be added to Phad later. (EN)
39935 420 IF(MSTJ(16).EQ.1) THEN
39936 ALPHA=1D0
39937 BETA=1D0
39938 ELSE
39939 ALPHA=FOUR(NSAV+1,I2)/FOUR(I1,I2)
39940 BETA=FOUR(NSAV+1,I1)/FOUR(I1,I2)
39941 ENDIF
39942 DO 430 J=1,4
39943 PG(J)=ALPHA*P(I1,J)+BETA*P(I2,J)
39944 430 CONTINUE
39945 PG(5)=SQRT(MAX(1D-20,PG(4)**2-PG(1)**2-PG(2)**2-PG(3)**2))
39946
39947C..Solve 2nd order equation, use the best (smallest) solution. (EN)
39948 PMSCOL=P(NSAV+2,4)**2-P(NSAV+2,1)**2-P(NSAV+2,2)**2-
39949 & P(NSAV+2,3)**2
39950 PCLPG=(P(NSAV+2,4)*PG(4)-P(NSAV+2,1)*PG(1)-
39951 & P(NSAV+2,2)*PG(2)-P(NSAV+2,3)*PG(3))/PG(5)**2
39952 DELTA=SQRT(PCLPG**2+(P(NSAV+2,5)**2-PMSCOL)/PG(5)**2)-PCLPG
39953
39954C...If all gluon energy eaten, zero it and take a step back.
39955 ITER=0
39956 IF(DELTA*ALPHA.GT.1D0.AND.I1.GT.NSAV+3) THEN
39957 ITER=1
39958 DO 440 J=1,4
39959 P(NSAV+2,J)=P(NSAV+2,J)+P(I1,J)
39960 P(I1,J)=0D0
39961 440 CONTINUE
39962 P(I1,5)=0D0
39963 I1=I1-1
39964 ENDIF
39965 IF(DELTA*BETA.GT.1D0.AND.I2.LT.N) THEN
39966 ITER=1
39967 DO 450 J=1,4
39968 P(NSAV+2,J)=P(NSAV+2,J)+P(I2,J)
39969 P(I2,J)=0D0
39970 450 CONTINUE
39971 P(I2,5)=0D0
39972 I2=I2+1
39973 ENDIF
39974 IF(ITER.EQ.1) GOTO 420
39975
39976C...If also all endpoint energy eaten, revert to old procedure.
39977 IF((1D0-DELTA*ALPHA)*P(I1,4).LT.P(I1,5).OR.
39978 & (1D0-DELTA*BETA)*P(I2,4).LT.P(I2,5)) THEN
39979 DO 460 I=NSAV+3,N
39980 IM=K(I,3)
39981 K(IM,1)=K(IM,1)-10
39982 K(IM,4)=0
39983 K(IM,5)=0
39984 460 CONTINUE
39985 N=NSAV
39986 GOTO 480
39987 ENDIF
39988
39989C... Construct the collapsed hadron and modified string partons.
39990 DO 470 J=1,4
39991 P(NSAV+2,J)=P(NSAV+2,J)+DELTA*PG(J)
39992 P(I1,J)=(1D0-DELTA*ALPHA)*P(I1,J)
39993 P(I2,J)=(1D0-DELTA*BETA)*P(I2,J)
39994 470 CONTINUE
39995 P(I1,5)=(1D0-DELTA*ALPHA)*P(I1,5)
39996 P(I2,5)=(1D0-DELTA*BETA)*P(I2,5)
39997
39998C...Finished with string collapse in new scheme.
39999 GOTO 520
40000 ENDIF
40001
40002C... Use old algorithm; by choice or when in trouble.
40003 480 CONTINUE
40004C...Find parton/particle which combines to largest extra mass.
40005 IR=0
40006 HA=0D0
40007 HSM=0D0
40008 DO 500 MCOMB=1,3
40009 IF(IR.NE.0) GOTO 500
40010 DO 490 I=MAX(1,IP),N
40011 IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
40012 & .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 490
40013 IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
40014 IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 490
40015 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 490
40016 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
40017 & GOTO 490
40018 HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
40019 HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5)
40020 IF(HSR.GT.HSM) THEN
40021 IR=I
40022 HA=HCR
40023 HSM=HSR
40024 ENDIF
40025 490 CONTINUE
40026 500 CONTINUE
40027
40028C...Shuffle energy and momentum to put new particle on mass shell.
40029 IF(IR.NE.0) THEN
40030 HB=PECM**2+HA
40031 HC=P(N+2,5)**2+HA
40032 HD=P(IR,5)**2+HA
40033 HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/
40034 & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
40035 HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
40036 DO 510 J=1,4
40037 P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J)
40038 P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J)
40039 510 CONTINUE
40040 N=N+2
40041 ELSE
40042 CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
40043 RETURN
40044 ENDIF
40045
40046C...Mark collapsed system and store daughter pointers. Iterate.
40047 520 DO 530 I=IC1,IC2
40048 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
40049 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
40050 K(I,1)=K(I,1)+10
40051 IF(MSTU(16).NE.2) THEN
40052 K(I,4)=NSAV+1
40053 K(I,5)=NSAV+1
40054 ELSE
40055 K(I,4)=NSAV+2
40056 K(I,5)=NSAV+1+NBODY
40057 ENDIF
40058 ENDIF
40059 530 CONTINUE
40060 IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 140
40061
40062C...Check flavours and invariant masses in parton systems.
40063 540 NP=0
40064 KFN=0
40065 KQS=0
40066 DO 550 J=1,5
40067 DPS(J)=0D0
40068 550 CONTINUE
40069 DO 580 I=MAX(1,IP),N
40070 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 580
40071 KC=PYCOMP(K(I,2))
40072 IF(KC.EQ.0) GOTO 580
40073 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
40074 IF(KQ.EQ.0) GOTO 580
40075 NP=NP+1
40076 IF(KQ.NE.2) THEN
40077 KFN=KFN+1
40078 KQS=KQS+KQ
40079 MSTJ(93)=1
40080 DPS(5)=DPS(5)+PYMASS(K(I,2))
40081 ENDIF
40082 DO 560 J=1,4
40083 DPS(J)=DPS(J)+P(I,J)
40084 560 CONTINUE
40085 IF(K(I,1).EQ.1) THEN
40086 IF(NP.NE.1.AND.(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0)) CALL
40087 & PYERRM(2,'(PYPREP:) unphysical flavour combination')
40088 IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
40089 & (0.9D0*PARJ(32)+DPS(5))**2) THEN
40090 CALL PYERRM(3,'(PYPREP:) too small mass in jet system')
40091 END IF
40092 NP=0
40093 KFN=0
40094 KQS=0
40095 DO 570 J=1,5
40096 DPS(J)=0D0
40097 570 CONTINUE
40098 ENDIF
40099 580 CONTINUE
40100
40101 RETURN
40102 END
40103
40104C*********************************************************************
40105
40106C...PYSTRF
40107C...Handles the fragmentation of an arbitrary colour singlet
40108C...jet system according to the Lund string fragmentation model.
40109
40110 SUBROUTINE PYSTRF(IP)
40111
40112C...Double precision and integer declarations.
40113 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40114 IMPLICIT INTEGER(I-N)
40115 INTEGER PYK,PYCHGE,PYCOMP
40116C...Commonblocks.
40117 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
40118 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40119 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40120 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
40121C...Local arrays. All MOPS variables ends with MO
40122 DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
40123 &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(3),PJU(5,5),
40124 &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
40125 &INMO(9),PM2QMO(2),XTMO(2)
40126
40127C...Function: four-product of two vectors.
40128 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)
40129 DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
40130 &DP(I,3)*DP(J,3)
40131
40132C...Reset counters. Identify parton system.
40133 MSTJ(91)=0
40134 NSAV=N
40135 MSTU90=MSTU(90)
40136 NP=0
40137 KQSUM=0
40138 DO 100 J=1,5
40139 DPS(J)=0D0
40140 100 CONTINUE
40141 MJU(1)=0
40142 MJU(2)=0
40143 I=IP-1
40144 110 I=I+1
40145 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
40146 CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
40147 IF(MSTU(21).GE.1) RETURN
40148 ENDIF
40149 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
40150 KC=PYCOMP(K(I,2))
40151 IF(KC.EQ.0) GOTO 110
40152 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
40153 IF(KQ.EQ.0) GOTO 110
40154 IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
40155 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
40156 IF(MSTU(21).GE.1) RETURN
40157 ENDIF
40158
40159C...Take copy of partons to be considered. Check flavour sum.
40160 NP=NP+1
40161 DO 120 J=1,5
40162 K(N+NP,J)=K(I,J)
40163 P(N+NP,J)=P(I,J)
40164 IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
40165 120 CONTINUE
40166 DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
40167 K(N+NP,3)=I
40168 IF(KQ.NE.2) KQSUM=KQSUM+KQ
40169 IF(K(I,1).EQ.41) THEN
40170 KQSUM=KQSUM+2*KQ
40171 IF(KQSUM.EQ.KQ) MJU(1)=N+NP
40172 IF(KQSUM.NE.KQ) MJU(2)=N+NP
40173 ENDIF
40174 IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
40175 IF(KQSUM.NE.0) THEN
40176 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
40177 IF(MSTU(21).GE.1) RETURN
40178 ENDIF
40179
40180C...Boost copied system to CM frame (for better numerical precision).
40181 IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
40182 MBST=0
40183 MSTU(33)=1
40184 CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
40185 & -DPS(3)/DPS(4))
40186 ELSE
40187 MBST=1
40188 HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
40189 DO 130 I=N+1,N+NP
40190 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
40191 IF(P(I,3).GT.0D0) THEN
40192 HHPEZ=MAX(1D-10,(P(I,4)+P(I,3))/HHBZ)
40193 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
40194 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
40195 ELSE
40196 HHPEZ=MAX(1D-10,(P(I,4)-P(I,3))*HHBZ)
40197 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
40198 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
40199 ENDIF
40200 130 CONTINUE
40201 ENDIF
40202
40203C...Search for very nearby partons that may be recombined.
40204 NTRYR=0
40205 PARU12=PARU(12)
40206 PARU13=PARU(13)
40207 MJU(3)=MJU(1)
40208 MJU(4)=MJU(2)
40209 NR=NP
40210 140 IF(NR.GE.3) THEN
40211 PDRMIN=2D0*PARU12
40212 DO 150 I=N+1,N+NR
40213 IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
40214 I1=I+1
40215 IF(I.EQ.N+NR) I1=N+1
40216 IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
40217 IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
40218 & GOTO 150
40219 IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
40220 & GOTO 150
40221 PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
40222 & P(I1,2)**2+P(I1,3)**2))
40223 PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
40224 PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP))
40225 IF(PDR.LT.PDRMIN) THEN
40226 IR=I
40227 PDRMIN=PDR
40228 ENDIF
40229 150 CONTINUE
40230
40231C...Recombine very nearby partons to avoid machine precision problems.
40232 IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
40233 DO 160 J=1,4
40234 P(N+1,J)=P(N+1,J)+P(N+NR,J)
40235 160 CONTINUE
40236 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
40237 & P(N+1,3)**2))
40238 NR=NR-1
40239 GOTO 140
40240 ELSEIF(PDRMIN.LT.PARU12) THEN
40241 DO 170 J=1,4
40242 P(IR,J)=P(IR,J)+P(IR+1,J)
40243 170 CONTINUE
40244 P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
40245 & P(IR,3)**2))
40246 DO 190 I=IR+1,N+NR-1
40247 K(I,2)=K(I+1,2)
40248 DO 180 J=1,5
40249 P(I,J)=P(I+1,J)
40250 180 CONTINUE
40251 190 CONTINUE
40252 IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
40253 NR=NR-1
40254 IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
40255 IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
40256 GOTO 140
40257 ENDIF
40258 ENDIF
40259 NTRYR=NTRYR+1
40260
40261C...Reset particle counter. Skip ahead if no junctions are present;
40262C...this is usually the case!
40263 NRS=MAX(5*NR+11,NP)
40264 NTRY=0
40265 200 NTRY=NTRY+1
40266 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
40267 PARU12=4D0*PARU12
40268 PARU13=2D0*PARU13
40269 GOTO 140
40270 ELSEIF(NTRY.GT.100) THEN
40271 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
40272 IF(MSTU(21).GE.1) RETURN
40273 ENDIF
40274 I=N+NRS
40275 MSTU(90)=MSTU90
40276 IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 580
40277 IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
40278 & ' junction strings not handled by MSTJ(12)>3 options')
40279 DO 570 JT=1,2
40280 NJS(JT)=0
40281 IF(MJU(JT).EQ.0) GOTO 570
40282 JS=3-2*JT
40283
40284C...Find and sum up momentum on three sides of junction. Check flavours.
40285 DO 220 IU=1,3
40286 IJU(IU)=0
40287 DO 210 J=1,5
40288 PJU(IU,J)=0D0
40289 210 CONTINUE
40290 220 CONTINUE
40291 IU=0
40292 DO 240 I1=N+1+(JT-1)*(NR-1),N+NR+(JT-1)*(1-NR),JS
40293 IF(K(I1,2).NE.21.AND.IU.LE.2) THEN
40294 IU=IU+1
40295 IJU(IU)=I1
40296 ENDIF
40297 DO 230 J=1,4
40298 PJU(IU,J)=PJU(IU,J)+P(I1,J)
40299 230 CONTINUE
40300 240 CONTINUE
40301 DO 250 IU=1,3
40302 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
40303 250 CONTINUE
40304 IF(K(IJU(3),2)/100.NE.10*K(IJU(1),2)+K(IJU(2),2).AND.
40305 & K(IJU(3),2)/100.NE.10*K(IJU(2),2)+K(IJU(1),2)) THEN
40306 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
40307 IF(MSTU(21).GE.1) RETURN
40308 ENDIF
40309
40310C...Calculate (approximate) boost to rest frame of junction.
40311 T12=(PJU(1,1)*PJU(2,1)+PJU(1,2)*PJU(2,2)+PJU(1,3)*PJU(2,3))/
40312 & (PJU(1,5)*PJU(2,5))
40313 T13=(PJU(1,1)*PJU(3,1)+PJU(1,2)*PJU(3,2)+PJU(1,3)*PJU(3,3))/
40314 & (PJU(1,5)*PJU(3,5))
40315 T23=(PJU(2,1)*PJU(3,1)+PJU(2,2)*PJU(3,2)+PJU(2,3)*PJU(3,3))/
40316 & (PJU(2,5)*PJU(3,5))
40317 T11=SQRT((2D0/3D0)*(1D0-T12)*(1D0-T13)/(1D0-T23))
40318 T22=SQRT((2D0/3D0)*(1D0-T12)*(1D0-T23)/(1D0-T13))
40319 TSQ=SQRT((2D0*T11*T22+T12-1D0)*(1D0+T12))
40320 T1F=(TSQ-T22*(1D0+T12))/(1D0-T12**2)
40321 T2F=(TSQ-T11*(1D0+T12))/(1D0-T12**2)
40322 DO 260 J=1,3
40323 TJU(J)=-(T1F*PJU(1,J)/PJU(1,5)+T2F*PJU(2,J)/PJU(2,5))
40324 260 CONTINUE
40325 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
40326 DO 270 IU=1,3
40327 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
40328 & TJU(3)*PJU(IU,3)
40329 270 CONTINUE
40330
40331C...Put junction at rest if motion could give inconsistencies.
40332 IF(PJU(1,5)+PJU(2,5).GT.PJU(1,4)+PJU(2,4)) THEN
40333 DO 280 J=1,3
40334 TJU(J)=0D0
40335 280 CONTINUE
40336 TJU(4)=1D0
40337 PJU(1,5)=PJU(1,4)
40338 PJU(2,5)=PJU(2,4)
40339 PJU(3,5)=PJU(3,4)
40340 ENDIF
40341
40342C...Start preparing for fragmentation of two strings from junction.
40343 ISTA=I
40344 DO 550 IU=1,2
40345 NS=IJU(IU+1)-IJU(IU)
40346
40347C...Junction strings: find longitudinal string directions.
40348 DO 310 IS=1,NS
40349 IS1=IJU(IU)+IS-1
40350 IS2=IJU(IU)+IS
40351 DO 290 J=1,5
40352 DP(1,J)=0.5D0*P(IS1,J)
40353 IF(IS.EQ.1) DP(1,J)=P(IS1,J)
40354 DP(2,J)=0.5D0*P(IS2,J)
40355 IF(IS.EQ.NS) DP(2,J)=-PJU(IU,J)
40356 290 CONTINUE
40357 IF(IS.EQ.NS) DP(2,4)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+
40358 & PJU(IU,3)**2)
40359 IF(IS.EQ.NS) DP(2,5)=0D0
40360 DP(3,5)=DFOUR(1,1)
40361 DP(4,5)=DFOUR(2,2)
40362 DHKC=DFOUR(1,2)
40363 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
40364 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
40365 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
40366 DP(3,5)=0D0
40367 DP(4,5)=0D0
40368 DHKC=DFOUR(1,2)
40369 ENDIF
40370 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
40371 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
40372 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
40373 IN1=N+NR+4*IS-3
40374 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
40375 DO 300 J=1,4
40376 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
40377 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
40378 300 CONTINUE
40379 310 CONTINUE
40380
40381C...Junction strings: initialize flavour, momentum and starting pos.
40382 ISAV=I
40383 MSTU91=MSTU(90)
40384 320 NTRY=NTRY+1
40385 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
40386 PARU12=4D0*PARU12
40387 PARU13=2D0*PARU13
40388 GOTO 140
40389 ELSEIF(NTRY.GT.100) THEN
40390 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
40391 IF(MSTU(21).GE.1) RETURN
40392 ENDIF
40393 I=ISAV
40394 MSTU(90)=MSTU91
40395 IRANKJ=0
40396 IE(1)=K(N+1+(JT/2)*(NP-1),3)
40397 IN(4)=N+NR+1
40398 IN(5)=IN(4)+1
40399 IN(6)=N+NR+4*NS+1
40400 DO 340 JQ=1,2
40401 DO 330 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
40402 P(IN1,1)=2-JQ
40403 P(IN1,2)=JQ-1
40404 P(IN1,3)=1D0
40405 330 CONTINUE
40406 340 CONTINUE
40407 KFL(1)=K(IJU(IU),2)
40408 PX(1)=0D0
40409 PY(1)=0D0
40410 GAM(1)=0D0
40411 DO 350 J=1,5
40412 PJU(IU+3,J)=0D0
40413 350 CONTINUE
40414
40415C...Junction strings: find initial transverse directions.
40416 DO 360 J=1,4
40417 DP(1,J)=P(IN(4),J)
40418 DP(2,J)=P(IN(4)+1,J)
40419 DP(3,J)=0D0
40420 DP(4,J)=0D0
40421 360 CONTINUE
40422 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
40423 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
40424 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
40425 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
40426 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
40427 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
40428 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
40429 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
40430 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
40431 DHC12=DFOUR(1,2)
40432 DHCX1=DFOUR(3,1)/DHC12
40433 DHCX2=DFOUR(3,2)/DHC12
40434 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
40435 DHCY1=DFOUR(4,1)/DHC12
40436 DHCY2=DFOUR(4,2)/DHC12
40437 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
40438 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
40439 DO 370 J=1,4
40440 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
40441 P(IN(6),J)=DP(3,J)
40442 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
40443 & DHCYX*DP(3,J))
40444 370 CONTINUE
40445
40446C...Junction strings: produce new particle, origin.
40447 380 I=I+1
40448 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
40449 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
40450 IF(MSTU(21).GE.1) RETURN
40451 ENDIF
40452 IRANKJ=IRANKJ+1
40453 K(I,1)=1
40454 K(I,3)=IE(1)
40455 K(I,4)=0
40456 K(I,5)=0
40457
40458C...Junction strings: generate flavour, hadron, pT, z and Gamma.
40459 390 CALL PYKFDI(KFL(1),0,KFL(3),K(I,2))
40460 IF(K(I,2).EQ.0) GOTO 320
40461 IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
40462 & IABS(KFL(3)).GT.10) THEN
40463 IF(PYR(0).GT.PARJ(19)) GOTO 390
40464 ENDIF
40465 P(I,5)=PYMASS(K(I,2))
40466 CALL PYPTDI(KFL(1),PX(3),PY(3))
40467 PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
40468 CALL PYZDIS(KFL(1),KFL(3),PR(1),Z)
40469 IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
40470 & MSTU(90).LT.8) THEN
40471 MSTU(90)=MSTU(90)+1
40472 MSTU(90+MSTU(90))=I
40473 PARU(90+MSTU(90))=Z
40474 ENDIF
40475 GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z)
40476 DO 400 J=1,3
40477 IN(J)=IN(3+J)
40478 400 CONTINUE
40479
40480C...Junction strings: stepping within or from 'low' string region easy.
40481 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
40482 & P(IN(1),5)**2.GE.PR(1)) THEN
40483 P(IN(1)+2,4)=Z*P(IN(1)+2,3)
40484 P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
40485 DO 410 J=1,4
40486 P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
40487 410 CONTINUE
40488 GOTO 500
40489 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
40490 P(IN(2)+2,4)=P(IN(2)+2,3)
40491 P(IN(2)+2,1)=1D0
40492 IN(2)=IN(2)+4
40493 IF(IN(2).GT.N+NR+4*NS) GOTO 320
40494 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
40495 P(IN(1)+2,4)=P(IN(1)+2,3)
40496 P(IN(1)+2,1)=0D0
40497 IN(1)=IN(1)+4
40498 ENDIF
40499 ENDIF
40500
40501C...Junction strings: find new transverse directions.
40502 420 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
40503 & IN(1).GT.IN(2)) GOTO 320
40504 IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
40505 DO 430 J=1,4
40506 DP(1,J)=P(IN(1),J)
40507 DP(2,J)=P(IN(2),J)
40508 DP(3,J)=0D0
40509 DP(4,J)=0D0
40510 430 CONTINUE
40511 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
40512 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
40513 DHC12=DFOUR(1,2)
40514 IF(DHC12.LE.1D-2) THEN
40515 P(IN(1)+2,4)=P(IN(1)+2,3)
40516 P(IN(1)+2,1)=0D0
40517 IN(1)=IN(1)+4
40518 GOTO 420
40519 ENDIF
40520 IN(3)=N+NR+4*NS+5
40521 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
40522 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
40523 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
40524 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
40525 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
40526 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
40527 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
40528 DHCX1=DFOUR(3,1)/DHC12
40529 DHCX2=DFOUR(3,2)/DHC12
40530 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
40531 DHCY1=DFOUR(4,1)/DHC12
40532 DHCY2=DFOUR(4,2)/DHC12
40533 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
40534 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
40535 DO 440 J=1,4
40536 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
40537 P(IN(3),J)=DP(3,J)
40538 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
40539 & DHCYX*DP(3,J))
40540 440 CONTINUE
40541C...Express pT with respect to new axes, if sensible.
40542 PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
40543 PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
40544 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
40545 PX(3)=PXP
40546 PY(3)=PYP
40547 ENDIF
40548 ENDIF
40549
40550C...Junction strings: sum up known four-momentum, coefficients for m2.
40551 DO 470 J=1,4
40552 DHG(J)=0D0
40553 P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
40554 & PY(3)*P(IN(3)+1,J)
40555 DO 450 IN1=IN(4),IN(1)-4,4
40556 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
40557 450 CONTINUE
40558 DO 460 IN2=IN(5),IN(2)-4,4
40559 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
40560 460 CONTINUE
40561 470 CONTINUE
40562 DHM(1)=FOUR(I,I)
40563 DHM(2)=2D0*FOUR(I,IN(1))
40564 DHM(3)=2D0*FOUR(I,IN(2))
40565 DHM(4)=2D0*FOUR(IN(1),IN(2))
40566
40567C...Junction strings: find coefficients for Gamma expression.
40568 DO 490 IN2=IN(1)+1,IN(2),4
40569 DO 480 IN1=IN(1),IN2-1,4
40570 DHC=2D0*FOUR(IN1,IN2)
40571 DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
40572 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
40573 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
40574 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
40575 480 CONTINUE
40576 490 CONTINUE
40577
40578C...Junction strings: solve (m2, Gamma) equation system for energies.
40579 DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
40580 IF(ABS(DHS1).LT.1D-4) GOTO 320
40581 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
40582 & (P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
40583 DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
40584 P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
40585 & ABS(DHS1)-DHS2/DHS1)
40586 IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 320
40587 P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
40588 & (DHM(2)+DHM(4)*P(IN(2)+2,4))
40589
40590C...Junction strings: step to new region if necessary.
40591 IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
40592 P(IN(2)+2,4)=P(IN(2)+2,3)
40593 P(IN(2)+2,1)=1D0
40594 IN(2)=IN(2)+4
40595 IF(IN(2).GT.N+NR+4*NS) GOTO 320
40596 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
40597 P(IN(1)+2,4)=P(IN(1)+2,3)
40598 P(IN(1)+2,1)=0D0
40599 IN(1)=IN(1)+4
40600 ENDIF
40601 GOTO 420
40602 ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
40603 P(IN(1)+2,4)=P(IN(1)+2,3)
40604 P(IN(1)+2,1)=0D0
40605 IN(1)=IN(1)+JS
40606 GOTO 890
40607 ENDIF
40608
40609C...Junction strings: particle four-momentum, remainder, loop back.
40610 500 DO 510 J=1,4
40611 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+
40612 & P(IN(2)+2,4)*P(IN(2),J)
40613 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
40614 510 CONTINUE
40615 IF(P(I,4).LT.P(I,5)) GOTO 320
40616 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
40617 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
40618 IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
40619 KFL(1)=-KFL(3)
40620 PX(1)=-PX(3)
40621 PY(1)=-PY(3)
40622 GAM(1)=GAM(3)
40623 IF(IN(3).NE.IN(6)) THEN
40624 DO 520 J=1,4
40625 P(IN(6),J)=P(IN(3),J)
40626 P(IN(6)+1,J)=P(IN(3)+1,J)
40627 520 CONTINUE
40628 ENDIF
40629 DO 530 JQ=1,2
40630 IN(3+JQ)=IN(JQ)
40631 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
40632 P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
40633 530 CONTINUE
40634 GOTO 380
40635 ENDIF
40636
40637C...Junction strings: save quantities left after each string.
40638 IF(IABS(KFL(1)).GT.10) GOTO 320
40639 I=I-1
40640 KFJH(IU)=KFL(1)
40641 DO 540 J=1,4
40642 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
40643 540 CONTINUE
40644 550 CONTINUE
40645
40646C...Junction strings: put together to new effective string endpoint.
40647 NJS(JT)=I-ISTA
40648 KFJS(JT)=K(K(MJU(JT+2),3),2)
40649 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
40650 IF(KFJH(1).EQ.KFJH(2)) KFLS=3
40651 IF(ISTA.NE.I) KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),
40652 & IABS(KFJH(2)))+100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+
40653 & KFLS,KFJH(1))
40654 DO 560 J=1,4
40655 PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
40656 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
40657 560 CONTINUE
40658 PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
40659 & PJS(JT,3)**2))
40660 570 CONTINUE
40661
40662C...Open versus closed strings. Choose breakup region for latter.
40663 580 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
40664 NS=MJU(2)-MJU(1)
40665 NB=MJU(1)-N
40666 ELSEIF(MJU(1).NE.0) THEN
40667 NS=N+NR-MJU(1)
40668 NB=MJU(1)-N
40669 ELSEIF(MJU(2).NE.0) THEN
40670 NS=MJU(2)-N
40671 NB=1
40672 ELSEIF(IABS(K(N+1,2)).NE.21) THEN
40673 NS=NR-1
40674 NB=1
40675 ELSE
40676 NS=NR+1
40677 W2SUM=0D0
40678 DO 590 IS=1,NR
40679 P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR))
40680 W2SUM=W2SUM+P(N+NR+IS,1)
40681 590 CONTINUE
40682 W2RAN=PYR(0)*W2SUM
40683 NB=0
40684 600 NB=NB+1
40685 W2SUM=W2SUM-P(N+NR+NB,1)
40686 IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 600
40687 ENDIF
40688
40689C...Find longitudinal string directions (i.e. lightlike four-vectors).
40690 DO 630 IS=1,NS
40691 IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
40692 IS2=N+IS+NB-NR*((IS+NB-1)/NR)
40693 DO 610 J=1,5
40694 DP(1,J)=P(IS1,J)
40695 IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J)
40696 IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
40697 DP(2,J)=P(IS2,J)
40698 IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J)
40699 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
40700 610 CONTINUE
40701 DP(3,5)=DFOUR(1,1)
40702 DP(4,5)=DFOUR(2,2)
40703 DHKC=DFOUR(1,2)
40704 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
40705 DP(3,5)=DP(1,5)**2
40706 DP(4,5)=DP(2,5)**2
40707 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2+DP(1,5)**2)
40708 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2+DP(2,5)**2)
40709 DHKC=DFOUR(1,2)
40710 ENDIF
40711 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
40712 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
40713 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
40714 IN1=N+NR+4*IS-3
40715 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
40716 DO 620 J=1,4
40717 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
40718 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
40719 620 CONTINUE
40720 630 CONTINUE
40721
40722C...Begin initialization: sum up energy, set starting position.
40723 ISAV=I
40724 MSTU91=MSTU(90)
40725 640 NTRY=NTRY+1
40726 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
40727 PARU12=4D0*PARU12
40728 PARU13=2D0*PARU13
40729 GOTO 140
40730 ELSEIF(NTRY.GT.100) THEN
40731 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
40732 IF(MSTU(21).GE.1) RETURN
40733 ENDIF
40734 I=ISAV
40735 MSTU(90)=MSTU91
40736 DO 660 J=1,4
40737 P(N+NRS,J)=0D0
40738 DO 650 IS=1,NR
40739 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
40740 650 CONTINUE
40741 660 CONTINUE
40742 DO 680 JT=1,2
40743 IRANK(JT)=0
40744 IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
40745 IF(NS.GT.NR) IRANK(JT)=1
40746 IE(JT)=K(N+1+(JT/2)*(NP-1),3)
40747 IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
40748 IN(3*JT+2)=IN(3*JT+1)+1
40749 IN(3*JT+3)=N+NR+4*NS+2*JT-1
40750 DO 670 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
40751 P(IN1,1)=2-JT
40752 P(IN1,2)=JT-1
40753 P(IN1,3)=1D0
40754 670 CONTINUE
40755 680 CONTINUE
40756C.. MOPS variables and switches
40757 NRVMO=0
40758 XBMO=1D0
40759 MSTU(121)=0
40760 MSTU(122)=0
40761
40762C...Initialize flavour and pT variables for open string.
40763 IF(NS.LT.NR) THEN
40764 PX(1)=0D0
40765 PY(1)=0D0
40766 IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1))
40767 PX(2)=-PX(1)
40768 PY(2)=-PY(1)
40769 DO 690 JT=1,2
40770 KFL(JT)=K(IE(JT),2)
40771 IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
40772 MSTJ(93)=1
40773 PMQ(JT)=PYMASS(KFL(JT))
40774 GAM(JT)=0D0
40775 690 CONTINUE
40776
40777C...Closed string: random initial breakup flavour, pT and vertex.
40778 ELSE
40779 KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
40780 IBMO=0
40781 700 CALL PYKFDI(KFL(3),0,KFL(1),KDUMP)
40782C.. Closed string: first vertex diq attempt => enforced second
40783C.. vertex diq
40784 IF(IABS(KFL(1)).GT.10)THEN
40785 IBMO=1
40786 MSTU(121)=0
40787 GOTO 700
40788 ENDIF
40789 IF(IBMO.EQ.1) MSTU(121)=-1
40790 KFL(2)=-KFL(1)
40791 CALL PYPTDI(KFL(1),PX(1),PY(1))
40792 PX(2)=-PX(1)
40793 PY(2)=-PY(1)
40794 PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2)
40795 710 CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
40796 ZR=PR3/(Z*P(N+NR+1,5)**2)
40797 IF(ZR.GE.1D0) GOTO 710
40798 DO 720 JT=1,2
40799 MSTJ(93)=1
40800 PMQ(JT)=PYMASS(KFL(JT))
40801 GAM(JT)=PR3*(1D0-Z)/Z
40802 IN1=N+NR+3+4*(JT/2)*(NS-1)
40803 P(IN1,JT)=1D0-Z
40804 P(IN1,3-JT)=JT-1
40805 P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z
40806 P(IN1+1,JT)=ZR
40807 P(IN1+1,3-JT)=2-JT
40808 P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR
40809 720 CONTINUE
40810 ENDIF
40811C.. MOPS variables
40812 DO 730 JT=1,2
40813 XTMO(JT)=1D0
40814 PM2QMO(JT)=PMQ(JT)**2
40815 IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
40816 730 CONTINUE
40817
40818C...Find initial transverse directions (i.e. spacelike four-vectors).
40819 DO 770 JT=1,2
40820 IF(JT.EQ.1.OR.NS.EQ.NR-1) THEN
40821 IN1=IN(3*JT+1)
40822 IN3=IN(3*JT+3)
40823 DO 740 J=1,4
40824 DP(1,J)=P(IN1,J)
40825 DP(2,J)=P(IN1+1,J)
40826 DP(3,J)=0D0
40827 DP(4,J)=0D0
40828 740 CONTINUE
40829 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
40830 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
40831 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
40832 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
40833 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
40834 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
40835 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
40836 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
40837 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
40838 DHC12=DFOUR(1,2)
40839 DHCX1=DFOUR(3,1)/DHC12
40840 DHCX2=DFOUR(3,2)/DHC12
40841 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
40842 DHCY1=DFOUR(4,1)/DHC12
40843 DHCY2=DFOUR(4,2)/DHC12
40844 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
40845 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
40846 DO 750 J=1,4
40847 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
40848 P(IN3,J)=DP(3,J)
40849 P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
40850 & DHCYX*DP(3,J))
40851 750 CONTINUE
40852 ELSE
40853 DO 760 J=1,4
40854 P(IN3+2,J)=P(IN3,J)
40855 P(IN3+3,J)=P(IN3+1,J)
40856 760 CONTINUE
40857 ENDIF
40858 770 CONTINUE
40859
40860C...Remove energy used up in junction string fragmentation.
40861 IF(MJU(1)+MJU(2).GT.0) THEN
40862 DO 790 JT=1,2
40863 IF(NJS(JT).EQ.0) GOTO 790
40864 DO 780 J=1,4
40865 P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
40866 780 CONTINUE
40867 790 CONTINUE
40868 ENDIF
40869
40870C...Produce new particle: side, origin.
40871 800 I=I+1
40872 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
40873 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
40874 IF(MSTU(21).GE.1) RETURN
40875 ENDIF
40876C.. New side priority for popcorn systems
40877 IF(MSTU(121).LE.0)THEN
40878 JT=1.5D0+PYR(0)
40879 IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
40880 IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
40881 ENDIF
40882 JR=3-JT
40883 JS=3-2*JT
40884 IRANK(JT)=IRANK(JT)+1
40885 K(I,1)=1
40886 K(I,3)=IE(JT)
40887 K(I,4)=0
40888 K(I,5)=0
40889
40890C...Generate flavour, hadron and pT.
40891 810 CONTINUE
40892 CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
40893 IF(K(I,2).EQ.0) GOTO 640
40894 MU90MO=MSTU(90)
40895 IF(MSTU(121).EQ.-1) GOTO 840
40896 IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
40897 &IABS(KFL(3)).GT.10) THEN
40898 IF(PYR(0).GT.PARJ(19)) GOTO 810
40899 ENDIF
40900 P(I,5)=PYMASS(K(I,2))
40901 CALL PYPTDI(KFL(JT),PX(3),PY(3))
40902 PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
40903
40904C...Final hadrons for small invariant mass.
40905 MSTJ(93)=1
40906 PMQ(3)=PYMASS(KFL(3))
40907 PARJST=PARJ(33)
40908 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
40909 WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
40910 IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
40911 &WMIN-0.5D0*PARJ(36)*PMQ(3)
40912 WREM2=FOUR(N+NRS,N+NRS)
40913 IF(WREM2.LT.0.10D0) GOTO 640
40914 IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)),
40915 &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1010
40916
40917C...Choose z, which gives Gamma. Shift z for heavy flavours.
40918 CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z)
40919 IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
40920 &MSTU(90).LT.8) THEN
40921 MSTU(90)=MSTU(90)+1
40922 MSTU(90+MSTU(90))=I
40923 PARU(90+MSTU(90))=Z
40924 ENDIF
40925 KFL1A=IABS(KFL(1))
40926 KFL2A=IABS(KFL(2))
40927 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
40928 &MOD(KFL2A/1000,10)).GE.4) THEN
40929 PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
40930 PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2)))
40931 Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2)
40932 PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
40933 IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1010
40934 ENDIF
40935 GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z)
40936
40937C.. MOPS baryon model modification
40938 XTMO3=(1D0-Z)*XTMO(JT)
40939 IF(IABS(KFL(3)).LE.10) NRVMO=0
40940 IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN
40941 GTSTMO=1D0
40942 PTSTMO=1D0
40943 RTSTMO=PYR(0)
40944 IF(IABS(KFL(JT)).LE.10)THEN
40945 XBMO=MIN(XTMO3,1D0-(2D-10))
40946 GBMO=GAM(3)
40947 PMMO=0D0
40948 PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT)
40949 GTSTMO=1D0-PARF(192)**PGMO
40950 ELSE
40951 IF(IRANK(JT).EQ.1) THEN
40952 GBMO=GAM(JT)
40953 PMMO=0D0
40954 XBMO=1D0
40955 ENDIF
40956 IF(XBMO.LT.1D0-(1D-10))THEN
40957 PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3)
40958 GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO)
40959 PGMO=PGNMO
40960 ENDIF
40961 IF(MSTJ(12).GE.5)THEN
40962 PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO))
40963 PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3)
40964 PTSTMO=EXP((PMMO-PMNMO)*PARF(193))
40965 PMMO=PMNMO
40966 ENDIF
40967 ENDIF
40968
40969C.. MOPS Accepting popcorn system hadron.
40970 IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN
40971 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN
40972 NRVMO=I-N-NR
40973 IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN
40974 CALL PYERRM(11,
40975 & '(PYSTRF:) no more memory left in PYJETS')
40976 IF(MSTU(21).GE.1) RETURN
40977 ENDIF
40978 IMO=I
40979 KFLMO=KFL(JT)
40980 PMQMO=PMQ(JT)
40981 PXMO=PX(JT)
40982 PYMO=PY(JT)
40983 GAMMO=GAM(JT)
40984 IRMO=IRANK(JT)
40985 XMO=XTMO(JT)
40986 DO 830 J=1,9
40987 IF(J.LE.5) THEN
40988 DO 820 LINE=1,I-N-NR
40989 P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J)
40990 K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J)
40991 820 CONTINUE
40992 ENDIF
40993 INMO(J)=IN(J)
40994 830 CONTINUE
40995 ENDIF
40996 ELSE
40997C..Reject popcorn system, flag=-1 if enforcing new one
40998 MSTU(121)=-1
40999 IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2
41000 ENDIF
41001 ENDIF
41002
41003
41004C..Lift restoring string outside MOPS block
41005 840 IF(MSTU(121).LT.0) THEN
41006 IF(MSTU(121).EQ.-2) MSTU(121)=0
41007 MSTU(90)=MU90MO
41008 NRVMO=0
41009 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 810
41010 I=IMO
41011 KFL(JT)=KFLMO
41012 PMQ(JT)=PMQMO
41013 PX(JT)=PXMO
41014 PY(JT)=PYMO
41015 GAM(JT)=GAMMO
41016 IRANK(JT)=IRMO
41017 XTMO(JT)=XMO
41018 DO 860 J=1,9
41019 IF(J.LE.5) THEN
41020 DO 850 LINE=1,I-N-NR
41021 P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J)
41022 K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J)
41023 850 CONTINUE
41024 ENDIF
41025 IN(J)=INMO(J)
41026 860 CONTINUE
41027 GOTO 810
41028 ENDIF
41029 XTMO(JT)=XTMO3
41030C.. MOPS end of modification
41031
41032 DO 870 J=1,3
41033 IN(J)=IN(3*JT+J)
41034 870 CONTINUE
41035
41036C...Stepping within or from 'low' string region easy.
41037 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
41038 &P(IN(1),5)**2.GE.PR(JT)) THEN
41039 P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
41040 P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
41041 DO 880 J=1,4
41042 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
41043 880 CONTINUE
41044 GOTO 970
41045 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
41046 P(IN(JR)+2,4)=P(IN(JR)+2,3)
41047 P(IN(JR)+2,JT)=1D0
41048 IN(JR)=IN(JR)+4*JS
41049 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 640
41050 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
41051 P(IN(JT)+2,4)=P(IN(JT)+2,3)
41052 P(IN(JT)+2,JT)=0D0
41053 IN(JT)=IN(JT)+4*JS
41054 ENDIF
41055 ENDIF
41056
41057C...Find new transverse directions (i.e. spacelike string vectors).
41058 890 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
41059 &IN(1).GT.IN(2)) GOTO 640
41060 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
41061 DO 900 J=1,4
41062 DP(1,J)=P(IN(1),J)
41063 DP(2,J)=P(IN(2),J)
41064 DP(3,J)=0D0
41065 DP(4,J)=0D0
41066 900 CONTINUE
41067 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
41068 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
41069 DHC12=DFOUR(1,2)
41070 IF(DHC12.LE.1D-2) THEN
41071 P(IN(JT)+2,4)=P(IN(JT)+2,3)
41072 P(IN(JT)+2,JT)=0D0
41073 IN(JT)=IN(JT)+4*JS
41074 GOTO 890
41075 ENDIF
41076 IN(3)=N+NR+4*NS+5
41077 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
41078 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
41079 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
41080 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
41081 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
41082 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
41083 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
41084 DHCX1=DFOUR(3,1)/DHC12
41085 DHCX2=DFOUR(3,2)/DHC12
41086 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
41087 DHCY1=DFOUR(4,1)/DHC12
41088 DHCY2=DFOUR(4,2)/DHC12
41089 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
41090 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
41091 DO 910 J=1,4
41092 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
41093 P(IN(3),J)=DP(3,J)
41094 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
41095 & DHCYX*DP(3,J))
41096 910 CONTINUE
41097C...Express pT with respect to new axes, if sensible.
41098 PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
41099 & FOUR(IN(3*JT+3)+1,IN(3)))
41100 PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
41101 & FOUR(IN(3*JT+3)+1,IN(3)+1))
41102 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
41103 PX(3)=PXP
41104 PY(3)=PYP
41105 ENDIF
41106 ENDIF
41107
41108C...Sum up known four-momentum. Gives coefficients for m2 expression.
41109 DO 940 J=1,4
41110 DHG(J)=0D0
41111 P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
41112 & PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
41113 DO 920 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
41114 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
41115 920 CONTINUE
41116 DO 930 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
41117 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
41118 930 CONTINUE
41119 940 CONTINUE
41120 DHM(1)=FOUR(I,I)
41121 DHM(2)=2D0*FOUR(I,IN(1))
41122 DHM(3)=2D0*FOUR(I,IN(2))
41123 DHM(4)=2D0*FOUR(IN(1),IN(2))
41124
41125C...Find coefficients for Gamma expression.
41126 DO 960 IN2=IN(1)+1,IN(2),4
41127 DO 950 IN1=IN(1),IN2-1,4
41128 DHC=2D0*FOUR(IN1,IN2)
41129 DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
41130 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
41131 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
41132 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
41133 950 CONTINUE
41134 960 CONTINUE
41135
41136C...Solve (m2, Gamma) equation system for energies taken.
41137 DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
41138 IF(ABS(DHS1).LT.1D-4) GOTO 640
41139 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
41140 &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
41141 DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
41142 P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
41143 &ABS(DHS1)-DHS2/DHS1)
41144 IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 640
41145 P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
41146 &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
41147
41148C...Step to new region if necessary.
41149 IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
41150 P(IN(JR)+2,4)=P(IN(JR)+2,3)
41151 P(IN(JR)+2,JT)=1D0
41152 IN(JR)=IN(JR)+4*JS
41153 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 640
41154 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
41155 P(IN(JT)+2,4)=P(IN(JT)+2,3)
41156 P(IN(JT)+2,JT)=0D0
41157 IN(JT)=IN(JT)+4*JS
41158 ENDIF
41159 GOTO 890
41160 ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
41161 P(IN(JT)+2,4)=P(IN(JT)+2,3)
41162 P(IN(JT)+2,JT)=0D0
41163 IN(JT)=IN(JT)+4*JS
41164 GOTO 890
41165 ENDIF
41166
41167C...Four-momentum of particle. Remaining quantities. Loop back.
41168 970 DO 980 J=1,4
41169 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
41170 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
41171 980 CONTINUE
41172 IF(P(I,4).LT.P(I,5)) GOTO 640
41173 KFL(JT)=-KFL(3)
41174 PMQ(JT)=PMQ(3)
41175 PX(JT)=-PX(3)
41176 PY(JT)=-PY(3)
41177 GAM(JT)=GAM(3)
41178 IF(IN(3).NE.IN(3*JT+3)) THEN
41179 DO 990 J=1,4
41180 P(IN(3*JT+3),J)=P(IN(3),J)
41181 P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
41182 990 CONTINUE
41183 ENDIF
41184 DO 1000 JQ=1,2
41185 IN(3*JT+JQ)=IN(JQ)
41186 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
41187 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
41188 1000 CONTINUE
41189 GOTO 800
41190
41191C...Final hadron: side, flavour, hadron, mass.
41192 1010 I=I+1
41193 K(I,1)=1
41194 K(I,3)=IE(JR)
41195 K(I,4)=0
41196 K(I,5)=0
41197 CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
41198 IF(K(I,2).EQ.0) GOTO 640
41199 P(I,5)=PYMASS(K(I,2))
41200 PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
41201
41202C...Final two hadrons: find common setup of four-vectors.
41203 JQ=1
41204 IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.
41205 &P(IN(7)+2,3)*P(IN(8)+2,3)*FOUR(IN(7),IN(8))) JQ=2
41206 DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
41207 DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
41208 DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
41209 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
41210 PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
41211 PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
41212 PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
41213 & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
41214 ENDIF
41215
41216C...Solve kinematics for final two hadrons, if possible.
41217 WREM2=WREM2+(PX(1)+PX(2))**2+(PY(1)+PY(2))**2
41218 FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
41219 IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200
41220 IF(FD.GE.1D0) GOTO 640
41221 FA=WREM2+PR(JT)-PR(JR)
41222 FB=SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT)))
41223 PREVCF=PARJ(42)
41224 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
41225 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*FB)))
41226 FB=SIGN(FB,JS*(PYR(0)-PREV))
41227 KFL1A=IABS(KFL(1))
41228 KFL2A=IABS(KFL(2))
41229 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
41230 &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2-
41231 &4D0*WREM2*PR(JT))),DBLE(JS))
41232 DO 1020 J=1,4
41233 P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
41234 & P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
41235 & DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
41236 P(I,J)=P(N+NRS,J)-P(I-1,J)
41237 1020 CONTINUE
41238 IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 640
41239
41240C...Mark jets as fragmented and give daughter pointers.
41241 N=I-NRS+1
41242 DO 1030 I=NSAV+1,NSAV+NP
41243 IM=K(I,3)
41244 K(IM,1)=K(IM,1)+10
41245 IF(MSTU(16).NE.2) THEN
41246 K(IM,4)=NSAV+1
41247 K(IM,5)=NSAV+1
41248 ELSE
41249 K(IM,4)=NSAV+2
41250 K(IM,5)=N
41251 ENDIF
41252 1030 CONTINUE
41253
41254C...Document string system. Move up particles.
41255 NSAV=NSAV+1
41256 K(NSAV,1)=11
41257 K(NSAV,2)=92
41258 K(NSAV,3)=IP
41259 K(NSAV,4)=NSAV+1
41260 K(NSAV,5)=N
41261 DO 1040 J=1,4
41262 P(NSAV,J)=DPS(J)
41263 V(NSAV,J)=V(IP,J)
41264 1040 CONTINUE
41265 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
41266 V(NSAV,5)=0D0
41267 DO 1060 I=NSAV+1,N
41268 DO 1050 J=1,5
41269 K(I,J)=K(I+NRS-1,J)
41270 P(I,J)=P(I+NRS-1,J)
41271 V(I,J)=0D0
41272 1050 CONTINUE
41273 1060 CONTINUE
41274 MSTU91=MSTU(90)
41275 DO 1070 IZ=MSTU90+1,MSTU91
41276 MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
41277 PARU9T(IZ)=PARU(90+IZ)
41278 1070 CONTINUE
41279 MSTU(90)=MSTU90
41280
41281C...Order particles in rank along the chain. Update mother pointer.
41282 DO 1090 I=NSAV+1,N
41283 DO 1080 J=1,5
41284 K(I-NSAV+N,J)=K(I,J)
41285 P(I-NSAV+N,J)=P(I,J)
41286 1080 CONTINUE
41287 1090 CONTINUE
41288 I1=NSAV
41289 DO 1120 I=N+1,2*N-NSAV
41290 IF(K(I,3).NE.IE(1)) GOTO 1120
41291 I1=I1+1
41292 DO 1100 J=1,5
41293 K(I1,J)=K(I,J)
41294 P(I1,J)=P(I,J)
41295 1100 CONTINUE
41296 IF(MSTU(16).NE.2) K(I1,3)=NSAV
41297 DO 1110 IZ=MSTU90+1,MSTU91
41298 IF(MSTU9T(IZ).EQ.I) THEN
41299 MSTU(90)=MSTU(90)+1
41300 MSTU(90+MSTU(90))=I1
41301 PARU(90+MSTU(90))=PARU9T(IZ)
41302 ENDIF
41303 1110 CONTINUE
41304 1120 CONTINUE
41305 DO 1150 I=2*N-NSAV,N+1,-1
41306 IF(K(I,3).EQ.IE(1)) GOTO 1150
41307 I1=I1+1
41308 DO 1130 J=1,5
41309 K(I1,J)=K(I,J)
41310 P(I1,J)=P(I,J)
41311 1130 CONTINUE
41312 IF(MSTU(16).NE.2) K(I1,3)=NSAV
41313 DO 1140 IZ=MSTU90+1,MSTU91
41314 IF(MSTU9T(IZ).EQ.I) THEN
41315 MSTU(90)=MSTU(90)+1
41316 MSTU(90+MSTU(90))=I1
41317 PARU(90+MSTU(90))=PARU9T(IZ)
41318 ENDIF
41319 1140 CONTINUE
41320 1150 CONTINUE
41321
41322C...Boost back particle system. Set production vertices.
41323 IF(MBST.EQ.0) THEN
41324 MSTU(33)=1
41325 CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),
41326 & DPS(3)/DPS(4))
41327 ELSE
41328 DO 1160 I=NSAV+1,N
41329 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
41330 IF(P(I,3).GT.0D0) THEN
41331 HHPEZ=(P(I,4)+P(I,3))*HHBZ
41332 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
41333 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
41334 ELSE
41335 HHPEZ=(P(I,4)-P(I,3))/HHBZ
41336 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
41337 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
41338 ENDIF
41339 1160 CONTINUE
41340 ENDIF
41341 DO 1180 I=NSAV+1,N
41342 DO 1170 J=1,4
41343 V(I,J)=V(IP,J)
41344 1170 CONTINUE
41345 1180 CONTINUE
41346
41347 RETURN
41348 END
41349
41350C*********************************************************************
41351
41352C...PYINDF
41353C...Handles the fragmentation of a jet system (or a single
41354C...jet) according to independent fragmentation models.
41355
41356 SUBROUTINE PYINDF(IP)
41357
41358C...Double precision and integer declarations.
41359 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41360 IMPLICIT INTEGER(I-N)
41361 INTEGER PYK,PYCHGE,PYCOMP
41362C...Commonblocks.
41363 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
41364 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41365 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41366 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
41367C...Local arrays.
41368 DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
41369 &KFLO(2),PXO(2),PYO(2),WO(2)
41370
41371C.. MOPS error message
41372 IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
41373 &' are not treated as expected in independent fragmentation')
41374
41375C...Reset counters. Identify parton system and take copy. Check flavour.
41376 NSAV=N
41377 MSTU90=MSTU(90)
41378 NJET=0
41379 KQSUM=0
41380 DO 100 J=1,5
41381 DPS(J)=0D0
41382 100 CONTINUE
41383 I=IP-1
41384 110 I=I+1
41385 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
41386 CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
41387 IF(MSTU(21).GE.1) RETURN
41388 ENDIF
41389 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
41390 KC=PYCOMP(K(I,2))
41391 IF(KC.EQ.0) GOTO 110
41392 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
41393 IF(KQ.EQ.0) GOTO 110
41394 NJET=NJET+1
41395 IF(KQ.NE.2) KQSUM=KQSUM+KQ
41396 DO 120 J=1,5
41397 K(NSAV+NJET,J)=K(I,J)
41398 P(NSAV+NJET,J)=P(I,J)
41399 DPS(J)=DPS(J)+P(I,J)
41400 120 CONTINUE
41401 K(NSAV+NJET,3)=I
41402 IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
41403 &K(I+1,1).EQ.2)) GOTO 110
41404 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
41405 CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
41406 IF(MSTU(21).GE.1) RETURN
41407 ENDIF
41408
41409C...Boost copied system to CM frame. Find CM energy and sum flavours.
41410 IF(NJET.NE.1) THEN
41411 MSTU(33)=1
41412 CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
41413 & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
41414 ENDIF
41415 PECM=0D0
41416 DO 130 J=1,3
41417 NFI(J)=0
41418 130 CONTINUE
41419 DO 140 I=NSAV+1,NSAV+NJET
41420 PECM=PECM+P(I,4)
41421 KFA=IABS(K(I,2))
41422 IF(KFA.LE.3) THEN
41423 NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
41424 ELSEIF(KFA.GT.1000) THEN
41425 KFLA=MOD(KFA/1000,10)
41426 KFLB=MOD(KFA/100,10)
41427 IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
41428 IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
41429 ENDIF
41430 140 CONTINUE
41431
41432C...Loop over attempts made. Reset counters.
41433 NTRY=0
41434 150 NTRY=NTRY+1
41435 IF(NTRY.GT.200) THEN
41436 CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
41437 IF(MSTU(21).GE.1) RETURN
41438 ENDIF
41439 N=NSAV+NJET
41440 MSTU(90)=MSTU90
41441 DO 160 J=1,3
41442 NFL(J)=NFI(J)
41443 IFET(J)=0
41444 KFLF(J)=0
41445 160 CONTINUE
41446
41447C...Loop over jets to be fragmented.
41448 DO 230 IP1=NSAV+1,NSAV+NJET
41449 MSTJ(91)=0
41450 NSAV1=N
41451 MSTU91=MSTU(90)
41452
41453C...Initial flavour and momentum values. Jet along +z axis.
41454 KFLH=IABS(K(IP1,2))
41455 IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
41456 KFLO(2)=0
41457 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
41458
41459C...Initial values for quark or diquark jet.
41460 170 IF(IABS(K(IP1,2)).NE.21) THEN
41461 NSTR=1
41462 KFLO(1)=K(IP1,2)
41463 CALL PYPTDI(0,PXO(1),PYO(1))
41464 WO(1)=WF
41465
41466C...Initial values for gluon treated like random quark jet.
41467 ELSEIF(MSTJ(2).LE.2) THEN
41468 NSTR=1
41469 IF(MSTJ(2).EQ.2) MSTJ(91)=1
41470 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
41471 CALL PYPTDI(0,PXO(1),PYO(1))
41472 WO(1)=WF
41473
41474C...Initial values for gluon treated like quark-antiquark jet pair,
41475C...sharing energy according to Altarelli-Parisi splitting function.
41476 ELSE
41477 NSTR=2
41478 IF(MSTJ(2).EQ.4) MSTJ(91)=1
41479 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
41480 KFLO(2)=-KFLO(1)
41481 CALL PYPTDI(0,PXO(1),PYO(1))
41482 PXO(2)=-PXO(1)
41483 PYO(2)=-PYO(1)
41484 WO(1)=WF*PYR(0)**(1D0/3D0)
41485 WO(2)=WF-WO(1)
41486 ENDIF
41487
41488C...Initial values for rank, flavour, pT and W+.
41489 DO 220 ISTR=1,NSTR
41490 180 I=N
41491 MSTU(90)=MSTU91
41492 IRANK=0
41493 KFL1=KFLO(ISTR)
41494 PX1=PXO(ISTR)
41495 PY1=PYO(ISTR)
41496 W=WO(ISTR)
41497
41498C...New hadron. Generate flavour and hadron species.
41499 190 I=I+1
41500 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
41501 CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS')
41502 IF(MSTU(21).GE.1) RETURN
41503 ENDIF
41504 IRANK=IRANK+1
41505 K(I,1)=1
41506 K(I,3)=IP1
41507 K(I,4)=0
41508 K(I,5)=0
41509 200 CALL PYKFDI(KFL1,0,KFL2,K(I,2))
41510 IF(K(I,2).EQ.0) GOTO 180
41511 IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN
41512 IF(PYR(0).GT.PARJ(19)) GOTO 200
41513 ENDIF
41514
41515C...Find hadron mass. Generate four-momentum.
41516 P(I,5)=PYMASS(K(I,2))
41517 CALL PYPTDI(KFL1,PX2,PY2)
41518 P(I,1)=PX1+PX2
41519 P(I,2)=PY1+PY2
41520 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
41521 CALL PYZDIS(KFL1,KFL2,PR,Z)
41522 MZSAV=0
41523 IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
41524 MZSAV=1
41525 MSTU(90)=MSTU(90)+1
41526 MSTU(90+MSTU(90))=I
41527 PARU(90+MSTU(90))=Z
41528 ENDIF
41529 P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W))
41530 P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W))
41531 IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
41532 & P(I,3).LE.0.001D0) THEN
41533 IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180
41534 P(I,3)=0.0001D0
41535 P(I,4)=SQRT(PR)
41536 Z=P(I,4)/W
41537 ENDIF
41538
41539C...Remaining flavour and momentum.
41540 KFL1=-KFL2
41541 PX1=-PX2
41542 PY1=-PY2
41543 W=(1D0-Z)*W
41544 DO 210 J=1,5
41545 V(I,J)=0D0
41546 210 CONTINUE
41547
41548C...Check if pL acceptable. Go back for new hadron if enough energy.
41549 IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN
41550 I=I-1
41551 IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
41552 ENDIF
41553 IF(W.GT.PARJ(31)) GOTO 190
41554 N=I
41555 220 CONTINUE
41556 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32)
41557 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
41558
41559C...Rotate jet to new direction.
41560 THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
41561 PHI=PYANGL(P(IP1,1),P(IP1,2))
41562 MSTU(33)=1
41563 CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
41564 K(K(IP1,3),4)=NSAV1+1
41565 K(K(IP1,3),5)=N
41566
41567C...End of jet generation loop. Skip conservation in some cases.
41568 230 CONTINUE
41569 IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
41570 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
41571
41572C...Subtract off produced hadron flavours, finished if zero.
41573 DO 240 I=NSAV+NJET+1,N
41574 KFA=IABS(K(I,2))
41575 KFLA=MOD(KFA/1000,10)
41576 KFLB=MOD(KFA/100,10)
41577 KFLC=MOD(KFA/10,10)
41578 IF(KFLA.EQ.0) THEN
41579 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
41580 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
41581 ELSE
41582 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
41583 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
41584 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
41585 ENDIF
41586 240 CONTINUE
41587 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
41588 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
41589 IF(NREQ.EQ.0) GOTO 320
41590
41591C...Take away flavour of low-momentum particles until enough freedom.
41592 NREM=0
41593 250 IREM=0
41594 P2MIN=PECM**2
41595 DO 260 I=NSAV+NJET+1,N
41596 P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
41597 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
41598 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
41599 260 CONTINUE
41600 IF(IREM.EQ.0) GOTO 150
41601 K(IREM,1)=7
41602 KFA=IABS(K(IREM,2))
41603 KFLA=MOD(KFA/1000,10)
41604 KFLB=MOD(KFA/100,10)
41605 KFLC=MOD(KFA/10,10)
41606 IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
41607 IF(K(IREM,1).EQ.8) GOTO 250
41608 IF(KFLA.EQ.0) THEN
41609 ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
41610 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
41611 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
41612 ELSE
41613 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
41614 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
41615 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
41616 ENDIF
41617 NREM=NREM+1
41618 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
41619 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
41620 IF(NREQ.GT.NREM) GOTO 250
41621 DO 270 I=NSAV+NJET+1,N
41622 IF(K(I,1).EQ.8) K(I,1)=1
41623 270 CONTINUE
41624
41625C...Find combination of existing and new flavours for hadron.
41626 280 NFET=2
41627 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
41628 IF(NREQ.LT.NREM) NFET=1
41629 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
41630 DO 290 J=1,NFET
41631 IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0)
41632 KFLF(J)=ISIGN(1,NFL(1))
41633 IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
41634 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
41635 290 CONTINUE
41636 IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
41637 &GOTO 280
41638 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
41639 &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
41640 &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
41641 IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0))
41642 IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
41643 IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1))
41644 IF(NFET.LE.2) KFLF(3)=0
41645 IF(KFLF(3).NE.0) THEN
41646 KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
41647 & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
41648 IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0)
41649 & KFLFC=KFLFC+ISIGN(2,KFLFC)
41650 ELSE
41651 KFLFC=KFLF(1)
41652 ENDIF
41653 CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
41654 IF(KF.EQ.0) GOTO 280
41655 DO 300 J=1,MAX(2,NFET)
41656 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
41657 300 CONTINUE
41658
41659C...Store hadron at random among free positions.
41660 NPOS=MIN(1+INT(PYR(0)*NREM),NREM)
41661 DO 310 I=NSAV+NJET+1,N
41662 IF(K(I,1).EQ.7) NPOS=NPOS-1
41663 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
41664 K(I,1)=1
41665 K(I,2)=KF
41666 P(I,5)=PYMASS(K(I,2))
41667 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
41668 310 CONTINUE
41669 NREM=NREM-1
41670 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
41671 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
41672 IF(NREM.GT.0) GOTO 280
41673
41674C...Compensate for missing momentum in global scheme (3 options).
41675 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
41676 DO 340 J=1,3
41677 PSI(J)=0D0
41678 DO 330 I=NSAV+NJET+1,N
41679 PSI(J)=PSI(J)+P(I,J)
41680 330 CONTINUE
41681 340 CONTINUE
41682 PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
41683 PWS=0D0
41684 DO 350 I=NSAV+NJET+1,N
41685 IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
41686 IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
41687 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
41688 IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0
41689 350 CONTINUE
41690 DO 370 I=NSAV+NJET+1,N
41691 IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
41692 IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
41693 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
41694 IF(MOD(MSTJ(3),5).EQ.3) PW=1D0
41695 DO 360 J=1,3
41696 P(I,J)=P(I,J)-PSI(J)*PW/PWS
41697 360 CONTINUE
41698 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
41699 370 CONTINUE
41700
41701C...Compensate for missing momentum withing each jet separately.
41702 ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
41703 DO 390 I=N+1,N+NJET
41704 K(I,1)=0
41705 DO 380 J=1,5
41706 P(I,J)=0D0
41707 380 CONTINUE
41708 390 CONTINUE
41709 DO 410 I=NSAV+NJET+1,N
41710 IR1=K(I,3)
41711 IR2=N+IR1-NSAV
41712 K(IR2,1)=K(IR2,1)+1
41713 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
41714 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
41715 DO 400 J=1,3
41716 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
41717 400 CONTINUE
41718 P(IR2,4)=P(IR2,4)+P(I,4)
41719 P(IR2,5)=P(IR2,5)+PLS
41720 410 CONTINUE
41721 PSS=0D0
41722 DO 420 I=N+1,N+NJET
41723 IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0))
41724 420 CONTINUE
41725 DO 440 I=NSAV+NJET+1,N
41726 IR1=K(I,3)
41727 IR2=N+IR1-NSAV
41728 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
41729 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
41730 DO 430 J=1,3
41731 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)*
41732 & PLS*P(IR1,J)
41733 430 CONTINUE
41734 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
41735 440 CONTINUE
41736 ENDIF
41737
41738C...Scale momenta for energy conservation.
41739 IF(MOD(MSTJ(3),5).NE.0) THEN
41740 PMS=0D0
41741 PES=0D0
41742 PQS=0D0
41743 DO 450 I=NSAV+NJET+1,N
41744 PMS=PMS+P(I,5)
41745 PES=PES+P(I,4)
41746 PQS=PQS+P(I,5)**2/P(I,4)
41747 450 CONTINUE
41748 IF(PMS.GE.PECM) GOTO 150
41749 NECO=0
41750 460 NECO=NECO+1
41751 PFAC=(PECM-PQS)/(PES-PQS)
41752 PES=0D0
41753 PQS=0D0
41754 DO 480 I=NSAV+NJET+1,N
41755 DO 470 J=1,3
41756 P(I,J)=PFAC*P(I,J)
41757 470 CONTINUE
41758 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
41759 PES=PES+P(I,4)
41760 PQS=PQS+P(I,5)**2/P(I,4)
41761 480 CONTINUE
41762 IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
41763 ENDIF
41764
41765C...Origin of produced particles and parton daughter pointers.
41766 490 DO 500 I=NSAV+NJET+1,N
41767 IF(MSTU(16).NE.2) K(I,3)=NSAV+1
41768 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
41769 500 CONTINUE
41770 DO 510 I=NSAV+1,NSAV+NJET
41771 I1=K(I,3)
41772 K(I1,1)=K(I1,1)+10
41773 IF(MSTU(16).NE.2) THEN
41774 K(I1,4)=NSAV+1
41775 K(I1,5)=NSAV+1
41776 ELSE
41777 K(I1,4)=K(I1,4)-NJET+1
41778 K(I1,5)=K(I1,5)-NJET+1
41779 IF(K(I1,5).LT.K(I1,4)) THEN
41780 K(I1,4)=0
41781 K(I1,5)=0
41782 ENDIF
41783 ENDIF
41784 510 CONTINUE
41785
41786C...Document independent fragmentation system. Remove copy of jets.
41787 NSAV=NSAV+1
41788 K(NSAV,1)=11
41789 K(NSAV,2)=93
41790 K(NSAV,3)=IP
41791 K(NSAV,4)=NSAV+1
41792 K(NSAV,5)=N-NJET+1
41793 DO 520 J=1,4
41794 P(NSAV,J)=DPS(J)
41795 V(NSAV,J)=V(IP,J)
41796 520 CONTINUE
41797 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
41798 V(NSAV,5)=0D0
41799 DO 540 I=NSAV+NJET,N
41800 DO 530 J=1,5
41801 K(I-NJET+1,J)=K(I,J)
41802 P(I-NJET+1,J)=P(I,J)
41803 V(I-NJET+1,J)=V(I,J)
41804 530 CONTINUE
41805 540 CONTINUE
41806 N=N-NJET+1
41807 DO 550 IZ=MSTU90+1,MSTU(90)
41808 MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
41809 550 CONTINUE
41810
41811C...Boost back particle system. Set production vertices.
41812 IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
41813 &DPS(2)/DPS(4),DPS(3)/DPS(4))
41814 DO 570 I=NSAV+1,N
41815 DO 560 J=1,4
41816 V(I,J)=V(IP,J)
41817 560 CONTINUE
41818 570 CONTINUE
41819
41820 RETURN
41821 END
41822
41823C*********************************************************************
41824
41825C...PYDECY
41826C...Handles the decay of unstable particles.
41827
41828 SUBROUTINE PYDECY(IP)
41829
41830C...Double precision and integer declarations.
41831 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41832 IMPLICIT INTEGER(I-N)
41833 INTEGER PYK,PYCHGE,PYCOMP
41834C...Commonblocks.
41835 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
41836 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41837 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41838 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
41839 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
41840C...Local arrays.
41841 DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
41842 &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
41843 CHARACTER CIDC*4
41844 DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
41845
41846C...Functions: momentum in two-particle decays and four-product.
41847 PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
41848 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)
41849
41850C...Initial values.
41851 NTRY=0
41852 NSAV=N
41853 KFA=IABS(K(IP,2))
41854 KFS=ISIGN(1,K(IP,2))
41855 KC=PYCOMP(KFA)
41856 MSTJ(92)=0
41857
41858C...Choose lifetime and determine decay vertex.
41859 IF(K(IP,1).EQ.5) THEN
41860 V(IP,5)=0D0
41861 ELSEIF(K(IP,1).NE.4) THEN
41862 V(IP,5)=-PMAS(KC,4)*LOG(PYR(0))
41863 ENDIF
41864 DO 100 J=1,4
41865 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
41866 100 CONTINUE
41867
41868C...Determine whether decay allowed or not.
41869 MOUT=0
41870 IF(MSTJ(22).EQ.2) THEN
41871 IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
41872 ELSEIF(MSTJ(22).EQ.3) THEN
41873 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
41874 ELSEIF(MSTJ(22).EQ.4) THEN
41875 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
41876 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
41877 ENDIF
41878 IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
41879 K(IP,1)=4
41880 RETURN
41881 ENDIF
41882
41883C...Interface to external tau decay library (for tau polarization).
41884 IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
41885
41886C...Starting values for pointers and momenta.
41887 ITAU=IP
41888 DO 110 J=1,4
41889 PTAU(J)=P(ITAU,J)
41890 PCMTAU(J)=P(ITAU,J)
41891 110 CONTINUE
41892
41893C...Iterate to find position and code of mother of tau.
41894 IMTAU=ITAU
41895 120 IMTAU=K(IMTAU,3)
41896
41897 IF(IMTAU.EQ.0) THEN
41898C...If no known origin then impossible to do anything further.
41899 KFORIG=0
41900 IORIG=0
41901
41902 ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
41903C...If tau -> tau + gamma then add gamma energy and loop.
41904 IF(K(K(IMTAU,4),2).EQ.22) THEN
41905 DO 130 J=1,4
41906 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
41907 130 CONTINUE
41908 ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
41909 DO 140 J=1,4
41910 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
41911 140 CONTINUE
41912 ENDIF
41913 GOTO 120
41914
41915 ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
41916C...If coming from weak decay of hadron then W is not stored in record,
41917C...but can be reconstructed by adding neutrino momentum.
41918 KFORIG=-ISIGN(24,K(ITAU,2))
41919 IORIG=0
41920 DO 160 II=K(IMTAU,4),K(IMTAU,5)
41921 IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
41922 DO 150 J=1,4
41923 PCMTAU(J)=PCMTAU(J)+P(II,J)
41924 150 CONTINUE
41925 ENDIF
41926 160 CONTINUE
41927
41928 ELSE
41929C...If coming from resonance decay then find latest copy of this
41930C...resonance (may not completely agree).
41931 KFORIG=K(IMTAU,2)
41932 IORIG=IMTAU
41933 DO 170 II=IMTAU+1,IP-1
41934 IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
41935 & ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II
41936 170 CONTINUE
41937 DO 180 J=1,4
41938 PCMTAU(J)=P(IORIG,J)
41939 180 CONTINUE
41940 ENDIF
41941
41942C...Boost tau to rest frame of production process (where known)
41943C...and rotate it to sit along +z axis.
41944 DO 190 J=1,3
41945 DBETAU(J)=PCMTAU(J)/PCMTAU(4)
41946 190 CONTINUE
41947 IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1),
41948 & -DBETAU(2),-DBETAU(3))
41949 PHITAU=PYANGL(P(ITAU,1),P(ITAU,2))
41950 CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0)
41951 THETAU=PYANGL(P(ITAU,3),P(ITAU,1))
41952 CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0)
41953
41954C...Call tau decay routine (if meaningful) and fill extra info.
41955 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
41956 CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
41957 DO 200 II=NSAV+1,NSAV+NDECAY
41958 K(II,1)=1
41959 K(II,3)=IP
41960 K(II,4)=0
41961 K(II,5)=0
41962 200 CONTINUE
41963 N=NSAV+NDECAY
41964 ENDIF
41965
41966C...Boost back decay tau and decay products.
41967 DO 210 J=1,4
41968 P(ITAU,J)=PTAU(J)
41969 210 CONTINUE
41970 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
41971 CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
41972 IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1),
41973 & DBETAU(2),DBETAU(3))
41974
41975C...Skip past ordinary tau decay treatment.
41976 MMAT=0
41977 MBST=0
41978 ND=0
41979 GOTO 630
41980 ENDIF
41981 ENDIF
41982
41983C...B-Bbar mixing: flip sign of meson appropriately.
41984 MMIX=0
41985 IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
41986 XBBMIX=PARJ(76)
41987 IF(KFA.EQ.531) XBBMIX=PARJ(77)
41988 IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1
41989 IF(MMIX.EQ.1) KFS=-KFS
41990 ENDIF
41991
41992C...Check existence of decay channels. Particle/antiparticle rules.
41993 KCA=KC
41994 IF(MDCY(KC,2).GT.0) THEN
41995 MDMDCY=MDME(MDCY(KC,2),2)
41996 IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
41997 ENDIF
41998 IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
41999 CALL PYERRM(9,'(PYDECY:) no decay channel defined')
42000 RETURN
42001 ENDIF
42002 IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS
42003 IF(KCHG(KC,3).EQ.0) THEN
42004 KFSP=1
42005 KFSN=0
42006 IF(PYR(0).GT.0.5D0) KFS=-KFS
42007 ELSEIF(KFS.GT.0) THEN
42008 KFSP=1
42009 KFSN=0
42010 ELSE
42011 KFSP=0
42012 KFSN=1
42013 ENDIF
42014
42015C...Sum branching ratios of allowed decay channels.
42016 220 NOPE=0
42017 BRSU=0D0
42018 DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
42019 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
42020 & KFSN*MDME(IDL,1).NE.3) GOTO 230
42021 IF(MDME(IDL,2).GT.100) GOTO 230
42022 NOPE=NOPE+1
42023 BRSU=BRSU+BRAT(IDL)
42024 230 CONTINUE
42025 IF(NOPE.EQ.0) THEN
42026 CALL PYERRM(2,'(PYDECY:) all decay channels closed by user')
42027 RETURN
42028 ENDIF
42029
42030C...Select decay channel among allowed ones.
42031 240 RBR=BRSU*PYR(0)
42032 IDL=MDCY(KCA,2)-1
42033 250 IDL=IDL+1
42034 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
42035 &KFSN*MDME(IDL,1).NE.3) THEN
42036 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
42037 ELSEIF(MDME(IDL,2).GT.100) THEN
42038 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
42039 ELSE
42040 IDC=IDL
42041 RBR=RBR-BRAT(IDL)
42042 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250
42043 ENDIF
42044
42045C...Start readout of decay channel: matrix element, reset counters.
42046 MMAT=MDME(IDC,2)
42047 260 NTRY=NTRY+1
42048 IF(MOD(NTRY,200).EQ.0) THEN
42049 WRITE(CIDC,'(I4)') IDC
42050C...Do not print warning for some well-known special cases.
42051 IF(KFA.NE.113.AND.KFA.NE.115.AND.KFA.NE.215)
42052 & CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'//
42053 & CIDC)
42054 GOTO 240
42055 ENDIF
42056 IF(NTRY.GT.1000) THEN
42057 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
42058 IF(MSTU(21).GE.1) RETURN
42059 ENDIF
42060 I=N
42061 NP=0
42062 NQ=0
42063 MBST=0
42064 IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1
42065 DO 270 J=1,4
42066 PV(1,J)=0D0
42067 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
42068 270 CONTINUE
42069 IF(MBST.EQ.1) PV(1,4)=P(IP,5)
42070 PV(1,5)=P(IP,5)
42071 PS=0D0
42072 PSQ=0D0
42073 MREM=0
42074 MHADDY=0
42075 IF(KFA.GT.80) MHADDY=1
42076C.. Random flavour and popcorn system memory.
42077 IRNDMO=0
42078 JTMO=0
42079 MSTU(121)=0
42080 MSTU(125)=10
42081
42082C...Read out decay products. Convert to standard flavour code.
42083 JTMAX=5
42084 IF(MDME(IDC+1,2).EQ.101) JTMAX=10
42085 DO 280 JT=1,JTMAX
42086 IF(JT.LE.5) KP=KFDP(IDC,JT)
42087 IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
42088 IF(KP.EQ.0) GOTO 280
42089 KPA=IABS(KP)
42090 KCP=PYCOMP(KPA)
42091 IF(KPA.GT.80) MHADDY=1
42092 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
42093 KFP=KP
42094 ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
42095 KFP=KFS*KP
42096 ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
42097 KFP=-KFS*MOD(KFA/10,10)
42098 ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
42099 KFP=KFS*(100*MOD(KFA/10,100)+3)
42100 ELSEIF(KPA.EQ.81) THEN
42101 KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
42102 ELSEIF(KP.EQ.82) THEN
42103 CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP)
42104 IF(KFP.EQ.0) GOTO 260
42105 KFP=-KFP
42106 IRNDMO=1
42107 MSTJ(93)=1
42108 IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260
42109 ELSEIF(KP.EQ.-82) THEN
42110 KFP=MSTU(124)
42111 ENDIF
42112 IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP)
42113
42114C...Add decay product to event record or to quark flavour list.
42115 KFPA=IABS(KFP)
42116 KQP=KCHG(KCP,2)
42117 IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
42118 NQ=NQ+1
42119 KFLO(NQ)=KFP
42120C...set rndmflav popcorn system pointer
42121 IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ
42122 MSTJ(93)=2
42123 PSQ=PSQ+PYMASS(KFLO(NQ))
42124 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
42125 & MOD(NQ,2).EQ.1) THEN
42126 NQ=NQ-1
42127 PS=PS-P(I,5)
42128 K(I,1)=1
42129 KFI=K(I,2)
42130 CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2))
42131 IF(K(I,2).EQ.0) GOTO 260
42132 MSTJ(93)=1
42133 P(I,5)=PYMASS(K(I,2))
42134 PS=PS+P(I,5)
42135 ELSE
42136 I=I+1
42137 NP=NP+1
42138 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
42139 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
42140 K(I,1)=1+MOD(NQ,2)
42141 IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
42142 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
42143 K(I,2)=KFP
42144 K(I,3)=IP
42145 K(I,4)=0
42146 K(I,5)=0
42147 P(I,5)=PYMASS(KFP)
42148 PS=PS+P(I,5)
42149 ENDIF
42150 280 CONTINUE
42151
42152C...Check masses for resonance decays.
42153 IF(MHADDY.EQ.0) THEN
42154 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
42155 ENDIF
42156
42157C...Choose decay multiplicity in phase space model.
42158 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
42159 PSP=PS
42160 CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0))
42161 IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
42162 300 NTRY=NTRY+1
42163C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
42164 IF(IRNDMO.EQ.0) THEN
42165 MSTU(121)=0
42166 JTMO=0
42167 ELSEIF(IRNDMO.EQ.1) THEN
42168 IRNDMO=2
42169 ELSE
42170 GOTO 260
42171 ENDIF
42172 IF(NTRY.GT.1000) THEN
42173 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
42174 IF(MSTU(21).GE.1) RETURN
42175 ENDIF
42176 IF(MMAT.LE.20) THEN
42177 GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))*
42178 & SIN(PARU(2)*PYR(0))
42179 ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS
42180 IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
42181 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
42182 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
42183 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
42184 ELSE
42185 ND=MMAT-20
42186 ENDIF
42187C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
42188 MSTU(125)=ND-NQ/2
42189 IF(MSTU(121).GT.MSTU(125)) GOTO 300
42190
42191C...Form hadrons from flavour content.
42192 DO 310 JT=1,NQ
42193 KFL1(JT)=KFLO(JT)
42194 310 CONTINUE
42195 IF(ND.EQ.NP+NQ/2) GOTO 330
42196 DO 320 I=N+NP+1,N+ND-NQ/2
42197C.. Stick to started popcorn system, else pick side at random
42198 JT=JTMO
42199 IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0))
42200 CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2))
42201 IF(K(I,2).EQ.0) GOTO 300
42202 MSTU(125)=MSTU(125)-1
42203 JTMO=0
42204 IF(MSTU(121).GT.0) JTMO=JT
42205 KFL1(JT)=-KFL2
42206 320 CONTINUE
42207 330 JT=2
42208 JT2=3
42209 JT3=4
42210 IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4
42211 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
42212 & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
42213 IF(JT.EQ.3) JT2=2
42214 IF(JT.EQ.4) JT3=2
42215 CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
42216 IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
42217 IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
42218 IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
42219
42220C...Check that sum of decay product masses not too large.
42221 PS=PSP
42222 DO 340 I=N+NP+1,N+ND
42223 K(I,1)=1
42224 K(I,3)=IP
42225 K(I,4)=0
42226 K(I,5)=0
42227 P(I,5)=PYMASS(K(I,2))
42228 PS=PS+P(I,5)
42229 340 CONTINUE
42230 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
42231
42232C...Rescale energy to subtract off spectator quark mass.
42233 ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44)
42234 & .AND.NP.GE.3) THEN
42235 PS=PS-P(N+NP,5)
42236 PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
42237 DO 350 J=1,5
42238 P(N+NP,J)=PQT*PV(1,J)
42239 PV(1,J)=(1D0-PQT)*PV(1,J)
42240 350 CONTINUE
42241 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
42242 ND=NP-1
42243 MREM=1
42244
42245C...Fully specified final state: check mass broadening effects.
42246 ELSE
42247 IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
42248 ND=NP
42249 ENDIF
42250
42251C...Determine position of grandmother, number of sisters.
42252 NM=0
42253 KFAS=0
42254 MSGN=0
42255 IF(MMAT.EQ.3) THEN
42256 IM=K(IP,3)
42257 IF(IM.LT.0.OR.IM.GE.IP) IM=0
42258 IF(IM.NE.0) KFAM=IABS(K(IM,2))
42259 IF(IM.NE.0) THEN
42260 DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
42261 IF(K(IL,3).EQ.IM) NM=NM+1
42262 IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
42263 360 CONTINUE
42264 IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
42265 & MOD(KFAM/1000,10).NE.0) NM=0
42266 IF(NM.EQ.2) THEN
42267 KFAS=IABS(K(ISIS,2))
42268 IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
42269 & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
42270 ENDIF
42271 ENDIF
42272 ENDIF
42273
42274C...Kinematics of one-particle decays.
42275 IF(ND.EQ.1) THEN
42276 DO 370 J=1,4
42277 P(N+1,J)=P(IP,J)
42278 370 CONTINUE
42279 GOTO 630
42280 ENDIF
42281
42282C...Calculate maximum weight ND-particle decay.
42283 PV(ND,5)=P(N+ND,5)
42284 IF(ND.GE.3) THEN
42285 WTMAX=1D0/WTCOR(ND-2)
42286 PMAX=PV(1,5)-PS+P(N+ND,5)
42287 PMIN=0D0
42288 DO 380 IL=ND-1,1,-1
42289 PMAX=PMAX+P(N+IL,5)
42290 PMIN=PMIN+P(N+IL+1,5)
42291 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
42292 380 CONTINUE
42293 ENDIF
42294
42295C...Find virtual gamma mass in Dalitz decay.
42296 390 IF(ND.EQ.2) THEN
42297 ELSEIF(MMAT.EQ.2) THEN
42298 PMES=4D0*PMAS(11,1)**2
42299 PMRHO2=PMAS(131,1)**2
42300 PGRHO2=PMAS(131,2)**2
42301 400 PMST=PMES*(P(IP,5)**2/PMES)**PYR(0)
42302 WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))*
42303 & (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/
42304 & ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
42305 IF(WT.LT.PYR(0)) GOTO 400
42306 PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST))
42307
42308C...M-generator gives weight. If rejected, try again.
42309 ELSE
42310 410 RORD(1)=1D0
42311 DO 440 IL1=2,ND-1
42312 RSAV=PYR(0)
42313 DO 420 IL2=IL1-1,1,-1
42314 IF(RSAV.LE.RORD(IL2)) GOTO 430
42315 RORD(IL2+1)=RORD(IL2)
42316 420 CONTINUE
42317 430 RORD(IL2+1)=RSAV
42318 440 CONTINUE
42319 RORD(ND)=0D0
42320 WT=1D0
42321 DO 450 IL=ND-1,1,-1
42322 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
42323 & (PV(1,5)-PS)
42324 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
42325 450 CONTINUE
42326 IF(WT.LT.PYR(0)*WTMAX) GOTO 410
42327 ENDIF
42328
42329C...Perform two-particle decays in respective CM frame.
42330 460 DO 480 IL=1,ND-1
42331 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
42332 UE(3)=2D0*PYR(0)-1D0
42333 PHI=PARU(2)*PYR(0)
42334 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
42335 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
42336 DO 470 J=1,3
42337 P(N+IL,J)=PA*UE(J)
42338 PV(IL+1,J)=-PA*UE(J)
42339 470 CONTINUE
42340 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
42341 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
42342 480 CONTINUE
42343
42344C...Lorentz transform decay products to lab frame.
42345 DO 490 J=1,4
42346 P(N+ND,J)=PV(ND,J)
42347 490 CONTINUE
42348 DO 530 IL=ND-1,1,-1
42349 DO 500 J=1,3
42350 BE(J)=PV(IL,J)/PV(IL,4)
42351 500 CONTINUE
42352 GA=PV(IL,4)/PV(IL,5)
42353 DO 520 I=N+IL,N+ND
42354 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
42355 DO 510 J=1,3
42356 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
42357 510 CONTINUE
42358 P(I,4)=GA*(P(I,4)+BEP)
42359 520 CONTINUE
42360 530 CONTINUE
42361
42362C...Check that no infinite loop in matrix element weight.
42363 NTRY=NTRY+1
42364 IF(NTRY.GT.800) GOTO 560
42365
42366C...Matrix elements for omega and phi decays.
42367 IF(MMAT.EQ.1) THEN
42368 WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
42369 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
42370 & +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
42371 IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390
42372
42373C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
42374 ELSEIF(MMAT.EQ.2) THEN
42375 FOUR12=FOUR(N+1,N+2)
42376 FOUR13=FOUR(N+1,N+3)
42377 WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+
42378 & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
42379 IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460
42380
42381C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
42382C...V vector), of form cos**2(theta02) in V1 rest frame, and for
42383C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
42384 ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
42385 FOUR10=FOUR(IP,IM)
42386 FOUR12=FOUR(IP,N+1)
42387 FOUR02=FOUR(IM,N+1)
42388 PMS1=P(IP,5)**2
42389 PMS0=P(IM,5)**2
42390 PMS2=P(N+1,5)**2
42391 IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
42392 IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02-
42393 & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
42394 HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM)
42395 HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
42396 IF(HNUM.LT.PYR(0)*HDEN) GOTO 460
42397
42398C...Matrix element for "onium" -> g + g + g or gamma + g + g.
42399 ELSEIF(MMAT.EQ.4) THEN
42400 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
42401 HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2
42402 HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2
42403 WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+
42404 & ((1D0-HX3)/(HX1*HX2))**2
42405 IF(WT.LT.2D0*PYR(0)) GOTO 390
42406 IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2)
42407 & GOTO 390
42408
42409C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
42410 ELSEIF(MMAT.EQ.41) THEN
42411 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
42412 HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5)))
42413 IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390
42414
42415C...Matrix elements for weak decays (only semileptonic for c and b)
42416 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
42417 & .AND.ND.EQ.3) THEN
42418 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
42419 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
42420 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
42421 ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN
42422 DO 550 J=1,4
42423 P(N+NP+1,J)=0D0
42424 DO 540 IS=N+3,N+NP
42425 P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
42426 540 CONTINUE
42427 550 CONTINUE
42428 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
42429 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
42430 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
42431 ENDIF
42432
42433C...Scale back energy and reattach spectator.
42434 560 IF(MREM.EQ.1) THEN
42435 DO 570 J=1,5
42436 PV(1,J)=PV(1,J)/(1D0-PQT)
42437 570 CONTINUE
42438 ND=ND+1
42439 MREM=0
42440 ENDIF
42441
42442C...Low invariant mass for system with spectator quark gives particle,
42443C...not two jets. Readjust momenta accordingly.
42444 IF(MMAT.EQ.31.AND.ND.EQ.3) THEN
42445 MSTJ(93)=1
42446 PM2=PYMASS(K(N+2,2))
42447 MSTJ(93)=1
42448 PM3=PYMASS(K(N+3,2))
42449 IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE.
42450 & (PARJ(32)+PM2+PM3)**2) GOTO 630
42451 K(N+2,1)=1
42452 KFTEMP=K(N+2,2)
42453 CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
42454 IF(K(N+2,2).EQ.0) GOTO 260
42455 P(N+2,5)=PYMASS(K(N+2,2))
42456 PS=P(N+1,5)+P(N+2,5)
42457 PV(2,5)=P(N+2,5)
42458 MMAT=0
42459 ND=2
42460 GOTO 460
42461 ELSEIF(MMAT.EQ.44) THEN
42462 MSTJ(93)=1
42463 PM3=PYMASS(K(N+3,2))
42464 MSTJ(93)=1
42465 PM4=PYMASS(K(N+4,2))
42466 IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE.
42467 & (PARJ(32)+PM3+PM4)**2) GOTO 600
42468 K(N+3,1)=1
42469 KFTEMP=K(N+3,2)
42470 CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
42471 IF(K(N+3,2).EQ.0) GOTO 260
42472 P(N+3,5)=PYMASS(K(N+3,2))
42473 DO 580 J=1,3
42474 P(N+3,J)=P(N+3,J)+P(N+4,J)
42475 580 CONTINUE
42476 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)
42477 HA=P(N+1,4)**2-P(N+2,4)**2
42478 HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
42479 HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
42480 & (P(N+1,3)-P(N+2,3))**2
42481 HD=(PV(1,4)-P(N+3,4))**2
42482 HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
42483 HF=HD*HC-HB**2
42484 HG=HD*HC-HA*HB
42485 HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF)
42486 DO 590 J=1,3
42487 PCOR=HH*(P(N+1,J)-P(N+2,J))
42488 P(N+1,J)=P(N+1,J)+PCOR
42489 P(N+2,J)=P(N+2,J)-PCOR
42490 590 CONTINUE
42491 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)
42492 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)
42493 ND=ND-1
42494 ENDIF
42495
42496C...Check invariant mass of W jets. May give one particle or start over.
42497 600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
42498 &.AND.IABS(K(N+1,2)).LT.10) THEN
42499 PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2)))
42500 MSTJ(93)=1
42501 PM1=PYMASS(K(N+1,2))
42502 MSTJ(93)=1
42503 PM2=PYMASS(K(N+2,2))
42504 IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610
42505 KFLDUM=INT(1.5D0+PYR(0))
42506 CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
42507 CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
42508 IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260
42509 PSM=PYMASS(KF1)+PYMASS(KF2)
42510 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610
42511 IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610
42512 IF(MMAT.EQ.48) GOTO 390
42513 IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260
42514 K(N+1,1)=1
42515 KFTEMP=K(N+1,2)
42516 CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
42517 IF(K(N+1,2).EQ.0) GOTO 260
42518 P(N+1,5)=PYMASS(K(N+1,2))
42519 K(N+2,2)=K(N+3,2)
42520 P(N+2,5)=P(N+3,5)
42521 PS=P(N+1,5)+P(N+2,5)
42522 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
42523 PV(2,5)=P(N+3,5)
42524 MMAT=0
42525 ND=2
42526 GOTO 460
42527 ENDIF
42528
42529C...Phase space decay of partons from W decay.
42530 610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN
42531 KFLO(1)=K(N+1,2)
42532 KFLO(2)=K(N+2,2)
42533 K(N+1,1)=K(N+3,1)
42534 K(N+1,2)=K(N+3,2)
42535 DO 620 J=1,5
42536 PV(1,J)=P(N+1,J)+P(N+2,J)
42537 P(N+1,J)=P(N+3,J)
42538 620 CONTINUE
42539 PV(1,5)=PMR
42540 N=N+1
42541 NP=0
42542 NQ=2
42543 PS=0D0
42544 MSTJ(93)=2
42545 PSQ=PYMASS(KFLO(1))
42546 MSTJ(93)=2
42547 PSQ=PSQ+PYMASS(KFLO(2))
42548 MMAT=11
42549 GOTO 290
42550 ENDIF
42551
42552C...Boost back for rapidly moving particle.
42553 630 N=N+ND
42554 IF(MBST.EQ.1) THEN
42555 DO 640 J=1,3
42556 BE(J)=P(IP,J)/P(IP,4)
42557 640 CONTINUE
42558 GA=P(IP,4)/P(IP,5)
42559 DO 660 I=NSAV+1,N
42560 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
42561 DO 650 J=1,3
42562 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
42563 650 CONTINUE
42564 P(I,4)=GA*(P(I,4)+BEP)
42565 660 CONTINUE
42566 ENDIF
42567
42568C...Fill in position of decay vertex.
42569 DO 680 I=NSAV+1,N
42570 DO 670 J=1,4
42571 V(I,J)=VDCY(J)
42572 670 CONTINUE
42573 V(I,5)=0D0
42574 680 CONTINUE
42575
42576C...Set up for parton shower evolution from jets.
42577 IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
42578 K(NSAV+1,1)=3
42579 K(NSAV+2,1)=3
42580 K(NSAV+3,1)=3
42581 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
42582 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
42583 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
42584 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
42585 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
42586 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
42587 MSTJ(92)=-(NSAV+1)
42588 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
42589 K(NSAV+2,1)=3
42590 K(NSAV+3,1)=3
42591 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
42592 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
42593 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
42594 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
42595 MSTJ(92)=NSAV+2
42596 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
42597 & IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
42598 K(NSAV+1,1)=3
42599 K(NSAV+2,1)=3
42600 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
42601 K(NSAV+1,5)=MSTU(5)*(NSAV+2)
42602 K(NSAV+2,4)=MSTU(5)*(NSAV+1)
42603 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
42604 MSTJ(92)=NSAV+1
42605 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
42606 & IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
42607 MSTJ(92)=NSAV+1
42608 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
42609 & THEN
42610 K(NSAV+1,1)=3
42611 K(NSAV+2,1)=3
42612 K(NSAV+3,1)=3
42613 KCP=PYCOMP(K(NSAV+1,2))
42614 KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
42615 JCON=4
42616 IF(KQP.LT.0) JCON=5
42617 K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
42618 K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
42619 K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
42620 K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
42621 MSTJ(92)=NSAV+1
42622 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
42623 K(NSAV+1,1)=3
42624 K(NSAV+3,1)=3
42625 K(NSAV+1,4)=MSTU(5)*(NSAV+3)
42626 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
42627 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
42628 K(NSAV+3,5)=MSTU(5)*(NSAV+1)
42629 MSTJ(92)=NSAV+1
42630 ENDIF
42631
42632C...Mark decayed particle; special option for B-Bbar mixing.
42633 IF(K(IP,1).EQ.5) K(IP,1)=15
42634 IF(K(IP,1).LE.10) K(IP,1)=11
42635 IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
42636 K(IP,4)=NSAV+1
42637 K(IP,5)=N
42638
42639 RETURN
42640 END
42641
42642
42643C*********************************************************************
42644
42645C...PYDCYK
42646C...Handles flavour production in the decay of unstable particles
42647C...and small string clusters.
42648
42649 SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF)
42650
42651C...Double precision and integer declarations.
42652 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42653 IMPLICIT INTEGER(I-N)
42654 INTEGER PYK,PYCHGE,PYCOMP
42655C...Commonblocks.
42656 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42657 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42658 SAVE /PYDAT1/,/PYDAT2/
42659
42660
42661C.. Call PYKFDI directly if no popcorn option is on
42662 IF(MSTJ(12).LT.2) THEN
42663 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
42664 MSTU(124)=KFL3
42665 RETURN
42666 ENDIF
42667
42668 KFL3=0
42669 KF=0
42670 IF(KFL1.EQ.0) RETURN
42671 KF1A=IABS(KFL1)
42672 KF2A=IABS(KFL2)
42673
42674 NSTO=130
42675 NMAX=MIN(MSTU(125),10)
42676
42677C.. Identify rank 0 cluster qq
42678 IRANK=1
42679 IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0
42680
42681 IF(KF2A.GT.0)THEN
42682C.. Join jets: Fails if store not empty
42683 IF(MSTU(121).GT.0) THEN
42684 MSTU(121)=0
42685 RETURN
42686 ENDIF
42687 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
42688 ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN
42689C.. Pick popcorn meson from store, return same qq, decrease store
42690 KF=MSTU(NSTO+MSTU(121))
42691 KFL3=-KFL1
42692 MSTU(121)=MSTU(121)-1
42693 ELSE
42694C.. Generate new flavour. Then done if no diquark is generated
42695 100 CALL PYKFDI(KFL1,0,KFL3,KF)
42696 IF(MSTU(121).EQ.-1) GOTO 100
42697 MSTU(124)=KFL3
42698 IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN
42699
42700C.. Simple case if no dynamical popcorn suppressions are considered
42701 IF(MSTJ(12).LT.4) THEN
42702 IF(MSTU(121).EQ.0) RETURN
42703 NMES=1
42704 KFPREV=-KFL3
42705 CALL PYKFDI(KFPREV,0,KFL3,KFM)
42706C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
42707 IF(IABS(KFL3).LE.10)THEN
42708 KFL3=-KFPREV
42709 RETURN
42710 ENDIF
42711 GOTO 120
42712 ENDIF
42713
42714C test output qq against fake Gamma, then return if no popcorn.
42715 GB=2D0
42716 IF(IRANK.NE.0)THEN
42717 CALL PYZDIS(1,2103,5D0,Z)
42718 GB=5D0*(1D0-Z)/Z
42719 IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN
42720 MSTU(121)=0
42721 GOTO 100
42722 ENDIF
42723 ENDIF
42724 IF(MSTU(121).EQ.0) RETURN
42725
42726C..Set store size memory. Pick fake dynamical variables of qq.
42727 NMES=MSTU(121)
42728 CALL PYPTDI(1,PX3,PY3)
42729 X=1D0
42730 POPM=0D0
42731 G=GB
42732 POPG=GB
42733
42734C.. Pick next popcorn meson, test with fake dynamical variables
42735 110 KFPREV=-KFL3
42736 PX1=-PX3
42737 PY1=-PY3
42738 CALL PYKFDI(KFPREV,0,KFL3,KFM)
42739 IF(MSTU(121).EQ.-1) GOTO 100
42740 CALL PYPTDI(KFL3,PX3,PY3)
42741 PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2
42742 CALL PYZDIS(KFPREV,KFL3,PM,Z)
42743 G=(1D0-Z)*(G+PM/Z)
42744 X=(1D0-Z)*X
42745
42746 PTST=1D0
42747 GTST=1D0
42748 RTST=PYR(0)
42749 IF(MSTJ(12).GT.4)THEN
42750 POPMN=SQRT((1D0-X)*(G/X-GB))
42751 POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
42752 PTST=EXP((POPM-POPMN)*PARF(193))
42753 POPM=POPMN
42754 ENDIF
42755 IF(IRANK.NE.0)THEN
42756 POPGN=X*GB
42757 GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG)
42758 POPG=POPGN
42759 ENDIF
42760 IF(RTST.GT.PTST*GTST)THEN
42761 MSTU(121)=0
42762 IF(RTST.GT.PTST) MSTU(121)=-1
42763 GOTO 100
42764 ENDIF
42765
42766C.. Store meson
42767 120 IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM
42768 IF(MSTU(121).GT.0) GOTO 110
42769
42770C.. Test accepted system size. If OK set global popcorn size variable.
42771 IF(NMES.GT.NMAX)THEN
42772 KF=0
42773 KFL3=0
42774 RETURN
42775 ENDIF
42776 MSTU(121)=NMES
42777 ENDIF
42778
42779 RETURN
42780 END
42781
42782C********************************************************************
42783
42784C...PYKFDI
42785C...Generates a new flavour pair and combines off a hadron
42786
42787 SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF)
42788
42789C...Double precision and integer declarations.
42790 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42791 IMPLICIT INTEGER(I-N)
42792 INTEGER PYK,PYCHGE,PYCOMP
42793C...Commonblocks.
42794 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42795 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42796 SAVE /PYDAT1/,/PYDAT2/
42797C...Local arrays.
42798 DIMENSION PD(7)
42799
42800 IF(MSTU(123).EQ.0.AND.MSTJ(12).GT.0) CALL PYKFIN
42801
42802C...Default flavour values. Input consistency checks.
42803 KF1A=IABS(KFL1)
42804 KF2A=IABS(KFL2)
42805 KFL3=0
42806 KF=0
42807 IF(KF1A.EQ.0) RETURN
42808 IF(KF2A.NE.0)THEN
42809 IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
42810 IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
42811 IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
42812 ENDIF
42813
42814C...Check if tabulated flavour probabilities are to be used.
42815 IF(MSTJ(15).EQ.1) THEN
42816 IF(MSTJ(12).GE.5) CALL PYERRM(29,
42817 & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
42818 & ' together with MSTJ(12)>=5 modification')
42819 KTAB1=-1
42820 IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
42821 KFL1A=MOD(KF1A/1000,10)
42822 KFL1B=MOD(KF1A/100,10)
42823 KFL1S=MOD(KF1A,10)
42824 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
42825 & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
42826 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
42827 IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
42828 KTAB2=0
42829 IF(KF2A.NE.0) THEN
42830 KTAB2=-1
42831 IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
42832 KFL2A=MOD(KF2A/1000,10)
42833 KFL2B=MOD(KF2A/100,10)
42834 KFL2S=MOD(KF2A,10)
42835 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
42836 & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
42837 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
42838 ENDIF
42839 IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
42840 ENDIF
42841
42842C.. Recognize rank 0 diquark case
42843 100 IRANK=1
42844 KFDIQ=MAX(KF1A,KF2A)
42845 IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0
42846
42847C.. Join two flavours to meson or baryon. Test for popcorn.
42848 IF(KF2A.GT.0)THEN
42849 MBARY=0
42850 IF(KFDIQ.GT.10) THEN
42851 IF(IRANK.EQ.0.AND.MSTJ(12).LT.5)
42852 & CALL PYNMES(KFDIQ)
42853 IF(MSTU(121).NE.0) THEN
42854 MSTU(121)=0
42855 RETURN
42856 ENDIF
42857 MBARY=2
42858 ENDIF
42859 KFQOLD=KF1A
42860 KFQVER=KF2A
42861 GOTO 130
42862 ENDIF
42863
42864C.. Separate incoming flavours, curtain flavour consistency check
42865 KFIN=KFL1
42866 KFQOLD=KF1A
42867 KFQPOP=KF1A/10000
42868 IF(KF1A.GT.10)THEN
42869 KFIN=-KFL1
42870 KFL1A=MOD(KF1A/1000,10)
42871 KFL1B=MOD(KF1A/100,10)
42872 IF(IRANK.EQ.0)THEN
42873 QAWT=1D0
42874 IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4)
42875 IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4)
42876 KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0))
42877 ENDIF
42878 IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) THEN
42879 MSTU(121)=0
42880 RETURN
42881 ENDIF
42882 KFQOLD=KFL1A+KFL1B-KFQPOP
42883 ENDIF
42884
42885C...Meson/baryon choice. Set number of mesons if starting a popcorn
42886C...system.
42887 110 MBARY=0
42888 IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN
42889 IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN
42890 MBARY=1
42891 CALL PYNMES(0)
42892 ENDIF
42893 ELSEIF(KF1A.GT.10)THEN
42894 MBARY=2
42895 IF(IRANK.EQ.0) CALL PYNMES(KF1A)
42896 IF(MSTU(121).GT.0) MBARY=-1
42897 ENDIF
42898
42899C..x->H+q: Choose single vertex quark. Jump to form hadron.
42900 IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN
42901 KFQVER=1+INT((2D0+PARJ(2))*PYR(0))
42902 KFL3=ISIGN(KFQVER,-KFIN)
42903 GOTO 130
42904 ENDIF
42905
42906C..x->H+qq: (IDW=proper PARF position for diquark weights)
42907 IDW=160
42908 IF(MBARY.EQ.1)THEN
42909 IF(MSTU(121).EQ.0) IDW=150
42910 SQWT=PARF(IDW+1)
42911 IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121)
42912 KFQPOP=1+INT((2D0+SQWT)*PYR(0))
42913C.. Shift to s-curtain parameters if needed
42914 IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN
42915 PARF(194)=PARF(138)*PARF(139)
42916 PARF(193)=PARJ(8)+PARJ(9)
42917 ENDIF
42918 ENDIF
42919
42920C.. x->H+qq: Get vertex quark
42921 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
42922 IDW=MSTU(122)
42923 MSTU(121)=MSTU(121)-1
42924 IF(IDW.EQ.170) THEN
42925 IF(MSTU(121).EQ.0)THEN
42926 IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2)
42927 ELSE
42928 IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
42929 ENDIF
42930 ELSE
42931 IF(MSTU(121).EQ.0)THEN
42932 IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
42933 ELSE
42934 IPOS=3*5+5*4+MIN(KFQOLD-1,4)
42935 ENDIF
42936 ENDIF
42937 IPOS=200+30*IPOS+1
42938
42939 IMES=-1
42940 RMES=PYR(0)*PARF(194)
42941 120 IMES=IMES+1
42942 RMES=RMES-PARF(IPOS+IMES)
42943 IF(IMES.EQ.30) THEN
42944 MSTU(121)=-1
42945 KF=-111
42946 RETURN
42947 ENDIF
42948 IF(RMES.GT.0D0) GOTO 120
42949 KMUL=IMES/5
42950 KFJ=2*KMUL+1
42951 IF(KMUL.EQ.2) KFJ=10003
42952 IF(KMUL.EQ.3) KFJ=10001
42953 IF(KMUL.EQ.4) KFJ=20003
42954 IF(KMUL.EQ.5) KFJ=5
42955 IDIAG=0
42956 KFQVER=MOD(IMES,5)+1
42957 IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1
42958 IF(KFQVER.GT.3)THEN
42959 IDIAG=KFQVER-3
42960 KFQVER=KFQOLD
42961 ENDIF
42962 ELSE
42963 IF(MBARY.EQ.-1) IDW=170
42964 SQWT=PARF(IDW+2)
42965 IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3)
42966 IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0
42967 KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0)))
42968 IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN
42969 KFQVER=KFQPOP
42970 IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP
42971 ENDIF
42972 ENDIF
42973
42974C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
42975 KFLDS=3
42976 IF(KFQPOP.NE.KFQVER)THEN
42977 SWT=PARF(IDW+7)
42978 IF(KFQVER.EQ.3) SWT=PARF(IDW+6)
42979 IF(KFQPOP.GE.3) SWT=PARF(IDW+5)
42980 IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1
42981 ENDIF
42982 KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS
42983 & +10000*KFQPOP
42984 KFL3=ISIGN(KFDIQ,KFIN)
42985
42986C..x->M+y: flavour for meson.
42987 130 IF(MBARY.LE.0)THEN
42988 KFLA=MAX(KFQOLD,KFQVER)
42989 KFLB=MIN(KFQOLD,KFQVER)
42990 KFS=ISIGN(1,KFL1)
42991 IF(KFLA.NE.KFQOLD) KFS=-KFS
42992C... Form meson, with spin and flavour mixing for diagonal states.
42993 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
42994 IF(IDIAG.GT.0) KF=110*IDIAG+KFJ
42995 IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA
42996 RETURN
42997 ENDIF
42998 IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0))
42999 IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0))
43000 IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0))
43001 IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN
43002 IF(PYR(0).LT.PARJ(14)) KMUL=2
43003 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN
43004 RMUL=PYR(0)
43005 IF(RMUL.LT.PARJ(15)) KMUL=3
43006 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
43007 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
43008 ENDIF
43009 KFLS=3
43010 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
43011 IF(KMUL.EQ.5) KFLS=5
43012 IF(KFLA.NE.KFLB)THEN
43013 KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
43014 ELSE
43015 RMIX=PYR(0)
43016 IMIX=2*KFLA+10*KMUL
43017 IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
43018 & INT(RMIX+PARF(IMIX)))+KFLS
43019 IF(KFLA.GE.4) KF=110*KFLA+KFLS
43020 ENDIF
43021 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
43022 IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
43023
43024C..Optional extra suppression of eta and eta'.
43025C..Allow shift to qq->B+q in old version (set IRANK to 0)
43026 IF(KF.EQ.221.OR.KF.EQ.331)THEN
43027 IF(PYR(0).GT.PARJ(25+KF/300))THEN
43028 IF(KF2A.GT.0) GOTO 130
43029 IF(MSTJ(12).LT.4) IRANK=0
43030 GOTO 110
43031 ENDIF
43032 ENDIF
43033 MSTU(121)=0
43034
43035C.. x->B+y: Flavour for baryon
43036 ELSE
43037 KFLA=KFQVER
43038 IF(KF1A.LE.10) KFLA=KFQOLD
43039 KFLB=MOD(KFDIQ/1000,10)
43040 KFLC=MOD(KFDIQ/100,10)
43041 KFLDS=MOD(KFDIQ,10)
43042 KFLD=MAX(KFLA,KFLB,KFLC)
43043 KFLF=MIN(KFLA,KFLB,KFLC)
43044 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
43045
43046C... SU(6) factors for formation of baryon.
43047 KBARY=3
43048 KDMAX=5
43049 KFLG=KFLB
43050 IF(KFLB.NE.KFLC)THEN
43051 KBARY=2*KFLDS-1
43052 KDMAX=1+KFLDS/2
43053 IF(KFLB.GT.2) KDMAX=KDMAX+2
43054 ENDIF
43055 IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN
43056 KBARY=KBARY+1
43057 KFLG=KFLA
43058 ENDIF
43059
43060 SU6MAX=PARF(140+KDMAX)
43061 SU6DEC=PARJ(18)
43062 SU6S =PARF(146)
43063 IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN
43064 SU6MAX=1D0
43065 SU6DEC=1D0
43066 SU6S =1D0
43067 ENDIF
43068 SU6OCT=PARF(60+KBARY)
43069 IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN
43070 SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1)
43071 IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1)
43072 ELSE
43073 IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1)
43074 ENDIF
43075 SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY)
43076
43077C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
43078 IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN
43079 MSTU(121)=0
43080 IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1
43081 GOTO 110
43082 ENDIF
43083
43084C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
43085 KSIG=1
43086 KFLS=2
43087 IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4
43088 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN
43089 KSIG=KFLDS/3
43090 IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0))
43091 ENDIF
43092 KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
43093 IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
43094 ENDIF
43095 RETURN
43096
43097C...Use tabulated probabilities to select new flavour and hadron.
43098 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
43099 KT3L=1
43100 KT3U=6
43101 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
43102 KT3L=1
43103 KT3U=6
43104 ELSEIF(KTAB2.EQ.0) THEN
43105 KT3L=1
43106 KT3U=22
43107 ELSE
43108 KT3L=KTAB2
43109 KT3U=KTAB2
43110 ENDIF
43111 RFL=0D0
43112 DO 160 KTS=0,2
43113 DO 150 KT3=KT3L,KT3U
43114 RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
43115 150 CONTINUE
43116 160 CONTINUE
43117 RFL=PYR(0)*RFL
43118 DO 180 KTS=0,2
43119 KTABS=KTS
43120 DO 170 KT3=KT3L,KT3U
43121 KTAB3=KT3
43122 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
43123 IF(RFL.LE.0D0) GOTO 190
43124 170 CONTINUE
43125 180 CONTINUE
43126 190 CONTINUE
43127
43128C...Reconstruct flavour of produced quark/diquark.
43129 IF(KTAB3.LE.6) THEN
43130 KFL3A=KTAB3
43131 KFL3B=0
43132 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
43133 ELSE
43134 KFL3A=1
43135 IF(KTAB3.GE.8) KFL3A=2
43136 IF(KTAB3.GE.11) KFL3A=3
43137 IF(KTAB3.GE.16) KFL3A=4
43138 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
43139 KFL3=1000*KFL3A+100*KFL3B+1
43140 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
43141 & KFL3+2
43142 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
43143 ENDIF
43144
43145C...Reconstruct meson code.
43146 IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
43147 &KFL3B.NE.0)) THEN
43148 RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
43149 & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
43150 KF=110+2*KTABS+1
43151 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
43152 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
43153 & 25*KTABS)) KF=330+2*KTABS+1
43154 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
43155 KFLA=MAX(KTAB1,KTAB3)
43156 KFLB=MIN(KTAB1,KTAB3)
43157 KFS=ISIGN(1,KFL1)
43158 IF(KFLA.NE.KF1A) KFS=-KFS
43159 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
43160 ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
43161 KFS=ISIGN(1,KFL1)
43162 IF(KFL1A.EQ.KFL3A) THEN
43163 KFLA=MAX(KFL1B,KFL3B)
43164 KFLB=MIN(KFL1B,KFL3B)
43165 IF(KFLA.NE.KFL1B) KFS=-KFS
43166 ELSEIF(KFL1A.EQ.KFL3B) THEN
43167 KFLA=KFL3A
43168 KFLB=KFL1B
43169 KFS=-KFS
43170 ELSEIF(KFL1B.EQ.KFL3A) THEN
43171 KFLA=KFL1A
43172 KFLB=KFL3B
43173 ELSEIF(KFL1B.EQ.KFL3B) THEN
43174 KFLA=MAX(KFL1A,KFL3A)
43175 KFLB=MIN(KFL1A,KFL3A)
43176 IF(KFLA.NE.KFL1A) KFS=-KFS
43177 ELSE
43178 CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq')
43179 GOTO 100
43180 ENDIF
43181 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
43182
43183C...Reconstruct baryon code.
43184 ELSE
43185 IF(KTAB1.GE.7) THEN
43186 KFLA=KFL3A
43187 KFLB=KFL1A
43188 KFLC=KFL1B
43189 ELSE
43190 KFLA=KFL1A
43191 KFLB=KFL3A
43192 KFLC=KFL3B
43193 ENDIF
43194 KFLD=MAX(KFLA,KFLB,KFLC)
43195 KFLF=MIN(KFLA,KFLB,KFLC)
43196 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
43197 IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
43198 IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
43199 ENDIF
43200
43201C...Check that constructed flavour code is an allowed one.
43202 IF(KFL2.NE.0) KFL3=0
43203 KC=PYCOMP(KF)
43204 IF(KC.EQ.0) THEN
43205 CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '//
43206 & 'failed')
43207 GOTO 100
43208 ENDIF
43209
43210 RETURN
43211 END
43212
43213C*********************************************************************
43214
43215C...PYNMES
43216C...Generates number of popcorn mesons and stores some relevant
43217C...parameters.
43218
43219 SUBROUTINE PYNMES(KFDIQ)
43220
43221C...Double precision and integer declarations.
43222 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43223 IMPLICIT INTEGER(I-N)
43224 INTEGER PYK,PYCHGE,PYCOMP
43225C...Commonblocks.
43226 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43227 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43228 SAVE /PYDAT1/,/PYDAT2/
43229
43230 MSTU(121)=0
43231 IF(MSTJ(12).LT.2) RETURN
43232
43233C..Old version: Get 1 or 0 popcorn mesons
43234 IF(MSTJ(12).LT.5)THEN
43235 POPWT=PARF(131)
43236 IF(KFDIQ.NE.0) THEN
43237 KFDIQA=IABS(KFDIQ)
43238 KFA=MOD(KFDIQA/1000,10)
43239 KFB=MOD(KFDIQA/100,10)
43240 KFS=MOD(KFDIQA,10)
43241 POPWT=PARF(132)
43242 IF(KFA.EQ.3) POPWT=PARF(133)
43243 IF(KFB.EQ.3) POPWT=PARF(134)
43244 IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4))
43245 ENDIF
43246 MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0))
43247 RETURN
43248 ENDIF
43249
43250C..New version: Store popcorn- or rank 0 diquark parameters
43251 MSTU(122)=170
43252 PARF(193)=PARJ(8)
43253 PARF(194)=PARF(139)
43254 IF(KFDIQ.NE.0) THEN
43255 MSTU(122)=180
43256 PARF(193)=PARJ(10)
43257 PARF(194)=PARF(140)
43258 ENDIF
43259 IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN
43260 IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9,
43261 & '(PYNMES:) Neglecting too large popcorn possibility')
43262 RETURN
43263 ENDIF
43264
43265C..New version: Get number of popcorn mesons
43266 100 RTST=PYR(0)
43267 MSTU(121)=-1
43268 110 MSTU(121)=MSTU(121)+1
43269 RTST=RTST/PARF(194)
43270 IF(RTST.LT.1D0) GOTO 110
43271 IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)*PARF(161)).GT.
43272 & (2D0+PARF(135)*PARF(161)*PARF(138)**MSTU(121))) GOTO 100
43273 RETURN
43274 END
43275
43276C***************************************************************
43277
43278C...PYKFIN
43279C...Precalculates a set of diquark and popcorn weights.
43280
43281 SUBROUTINE PYKFIN
43282
43283C...Double precision and integer declarations.
43284 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43285 IMPLICIT INTEGER(I-N)
43286 INTEGER PYK,PYCHGE,PYCOMP
43287C...Commonblocks.
43288 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43289 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43290 SAVE /PYDAT1/,/PYDAT2/
43291
43292 DIMENSION SU6(12),SU6M(7),QBB(7),QBM(7),DMB(14)
43293
43294
43295 MSTU(123)=1
43296C..Diquark indices for dimensional variables
43297 IUD1=1
43298 IUU1=2
43299 IUS0=3
43300 ISU0=4
43301 IUS1=5
43302 ISU1=6
43303 ISS1=7
43304
43305C.. *** SU(6) factors **
43306C..Modify with decuplet- (and Sigma/Lambda-) suppression.
43307 PARF(146)=1D0
43308 IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0)
43309 IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9,
43310 & '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
43311 DO 100 I=1,6
43312 SU6(I)=PARF(60+I)
43313 SU6(6+I)=SU6(I)*4*PARF(146)/(3*PARF(146)+1)
43314 100 CONTINUE
43315 SU6(8)=SU6(2)*4/(3*PARF(146)+1)
43316 SU6(6)=SU6(6)*(3+PARF(146))/(3*PARF(146)+1)
43317 DO 110 I=1,6
43318 SU6(I)=SU6(I)+PARJ(18)*PARF(70+I)
43319 SU6(6+I)=SU6(6+I)+PARJ(18)*PARF(70+I)
43320 110 CONTINUE
43321
43322C..SU(6)max q q' s,c,b
43323 SU6MUD =MAX(SU6(1) , SU6(8) )
43324 SU6M(IUD1)=MAX(SU6(5) , SU6(12))
43325 SU6M(ISU0)=MAX(SU6(7) ,SU6(2),SU6MUD )
43326 SU6M(IUU1)=MAX(SU6(3) ,SU6(4),SU6(10))
43327 SU6M(ISU1)=MAX(SU6(11),SU6(6),SU6M(IUD1))
43328 SU6M(IUS0)=SU6M(ISU0)
43329 SU6M(ISS1)=SU6M(IUU1)
43330 SU6M(IUS1)=SU6M(ISU1)
43331
43332C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
43333 PARF(141)=SU6MUD
43334 PARF(142)=SU6M(IUD1)
43335 PARF(143)=SU6M(ISU0)
43336 PARF(144)=SU6M(ISU1)
43337 PARF(145)=SU6M(ISS1)
43338
43339C..diquark SU(6) survival =
43340C..sum over quark (quark tunnel weight)*(SU(6)).
43341 PUD0=(2D0*SU6(1)+PARJ(2)*SU6(8))
43342 DMB(ISU0)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
43343 DMB(IUS0)=DMB(ISU0)
43344 DMB(ISS1)=(2D0*SU6(4)+PARJ(2)*SU6(3))/PUD0
43345 DMB(IUU1)=(SU6(3)+SU6(4)+PARJ(2)*SU6(10))/PUD0
43346 DMB(ISU1)=(SU6(11)+SU6(6)+PARJ(2)*SU6(5))/PUD0
43347 DMB(IUS1)=DMB(ISU1)
43348 DMB(IUD1)=(2D0*SU6(5)+PARJ(2)*SU6(12))/PUD0
43349
43350C.. *** Tunneling factors for Diquark production***
43351C.. T: half a curtain pair = sqrt(curtain pair factor)
43352 IF(MSTJ(12).GE.5) THEN
43353 PMUD0=PYMASS(2101)
43354 PMUD1=PYMASS(2103)-PMUD0
43355 PMUS0=PYMASS(3201)-PMUD0
43356 PMUS1=PYMASS(3203)-PMUS0-PMUD0
43357 PMSS1=PYMASS(3303)-PMUS0-PMUD0
43358 QBB(ISU0)=EXP(-(PARJ(9)+PARJ(8))*PMUS0-PARJ(9)*PARF(191))
43359 QBB(IUS0)=EXP(-PARJ(8)*PMUS0)
43360 QBB(ISS1)=EXP(-(PARJ(9)+PARJ(8))*PMSS1)*QBB(ISU0)
43361 QBB(IUU1)=EXP(-PARJ(8)*PMUD1)
43362 QBB(ISU1)=EXP(-(PARJ(9)+PARJ(8))*PMUS1)*QBB(ISU0)
43363 QBB(IUS1)=EXP(-PARJ(8)*PMUS1)*QBB(IUS0)
43364 QBB(IUD1)=QBB(IUU1)
43365 ELSE
43366 PAR2M=SQRT(PARJ(2))
43367 PAR3M=SQRT(PARJ(3))
43368 PAR4M=SQRT(PARJ(4))
43369 QBB(ISU0)=PAR2M*PAR3M
43370 QBB(IUS0)=PAR3M
43371 QBB(ISS1)=PAR2M*PARJ(3)*PAR4M
43372 QBB(IUU1)=PAR4M
43373 QBB(ISU1)=PAR4M*QBB(ISU0)
43374 QBB(IUS1)=PAR4M*QBB(IUS0)
43375 QBB(IUD1)=PAR4M
43376 ENDIF
43377
43378C.. tau: spin*(vertex factor)*(T = half-curtain factor)
43379 QBM(ISU0)=QBB(ISU0)
43380 QBM(IUS0)=PARJ(2)*QBB(IUS0)
43381 QBM(ISS1)=PARJ(2)*6D0*QBB(ISS1)
43382 QBM(IUU1)=6D0*QBB(IUU1)
43383 QBM(ISU1)=3D0*QBB(ISU1)
43384 QBM(IUS1)=PARJ(2)*3D0*QBB(IUS1)
43385 QBM(IUD1)=3D0*QBB(IUD1)
43386
43387C.. Combine T and tau to diquark weight for q-> B+B+..
43388 DO 120 I=1,7
43389 QBB(I)=QBB(I)*QBM(I)
43390 120 CONTINUE
43391
43392 IF(MSTJ(12).GE.5)THEN
43393C..New version: tau for rank 0 diquark.
43394 DMB(7+ISU0)=EXP(-PARJ(10)*PMUS0)
43395 DMB(7+IUS0)=PARJ(2)*DMB(7+ISU0)
43396 DMB(7+ISS1)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*DMB(7+ISU0)
43397 DMB(7+IUU1)=6D0*EXP(-PARJ(10)*PMUD1)
43398 DMB(7+ISU1)=3D0*EXP(-PARJ(10)*PMUS1)*DMB(7+ISU0)
43399 DMB(7+IUS1)=PARJ(2)*DMB(7+ISU1)
43400 DMB(7+IUD1)=DMB(7+IUU1)/2D0
43401
43402C..New version: curtain flavour ratios.
43403C.. s/u for q->B+M+...
43404C.. s/u for rank 0 diquark: su -> ...M+B+...
43405C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
43406 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
43407 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
43408 WU=1D0+DMB(7+IUD1)+DMB(7+IUS0)+DMB(7+IUS1)+DMB(7+IUU1)
43409 PARF(136)=(2D0*(DMB(7+ISU0)+DMB(7+ISU1))+DMB(7+ISS1))/WU
43410 PARF(137)=(DMB(7+ISU0)+DMB(7+ISU1))*
43411 & (2D0+DMB(7+ISS1)/(2D0*DMB(7+ISU1)))/WU
43412 ELSE
43413C..Old version: reset unused rank 0 diquark weights and
43414C.. unused diquark SU(6) survival weights
43415 DO 130 I=1,7
43416 IF(MSTJ(12).LT.3) DMB(I)=1D0
43417 DMB(7+I)=1D0
43418 130 CONTINUE
43419
43420C..Old version: Shuffle PARJ(7) into tau
43421 QBM(IUS0)=QBM(IUS0)*PARJ(7)
43422 QBM(ISS1)=QBM(ISS1)*PARJ(7)
43423 QBM(IUS1)=QBM(IUS1)*PARJ(7)
43424
43425C..Old version: curtain flavour ratios.
43426C.. s/u for q->B+M+...
43427C.. s/u for rank 0 diquark: su -> ...M+B+...
43428C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
43429 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
43430 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
43431 PARF(136)=PARF(135)*PARJ(6)*QBM(ISU0)/QBM(IUS0)
43432 PARF(137)=(1D0+QBM(IUD1))*(2D0+QBM(IUS0))/WU
43433 ENDIF
43434
43435C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for:
43436C.. rank0 D->M+B+..; D->M+B+..; q->B+M+..; q->B+B..
43437 DO 140 I=1,7
43438 DMB(7+I)=DMB(7+I)*DMB(I)
43439 DMB(I)=DMB(I)*QBM(I)
43440 QBM(I)=QBM(I)*SU6M(I)/SU6MUD
43441 QBB(I)=QBB(I)*SU6M(I)/SU6MUD
43442 140 CONTINUE
43443
43444C.. *** Popcorn factors ***
43445
43446 IF(MSTJ(12).LT.5)THEN
43447C.. Old version: Resulting popcorn weights.
43448 PARF(138)=PARJ(6)
43449 WS=PARF(135)*PARF(138)
43450 WQ=WU*PARJ(5)/3D0
43451 PARF(132)=WQ*QBM(IUD1)/QBB(IUD1)
43452 PARF(133)=WQ*
43453 & (QBM(IUS1)/QBB(IUS1)+WS*QBM(ISU1)/QBB(ISU1))/2D0
43454 PARF(134)=WQ*WS*QBM(ISS1)/QBB(ISS1)
43455 PARF(131)=WQ*(1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1)+
43456 & WS*(QBM(ISU0)+QBM(ISU1)+QBM(ISS1)/2D0))/
43457 & (1D0+QBB(IUD1)+QBB(IUU1)+
43458 & 2D0*(QBB(IUS0)+QBB(IUS1))+QBB(ISS1)/2D0)
43459 ELSE
43460C..New version: Store weights for popcorn mesons,
43461C..get prel. popcorn weights.
43462 DO 150 IPOS=201,1400
43463 PARF(IPOS)=0D0
43464 150 CONTINUE
43465 DO 160 I=138,140
43466 PARF(I)=0D0
43467 160 CONTINUE
43468 IPOS=200
43469 PARF(193)=PARJ(8)
43470 DO 240 MR=0,7,7
43471 IF(MR.EQ.7) PARF(193)=PARJ(10)
43472 SQWT=2D0*(DMB(MR+IUS0)+DMB(MR+IUS1))/
43473 & (1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
43474 QQWT=DMB(MR+IUU1)/(1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
43475 DO 230 NMES=0,1
43476 IF(NMES.EQ.1) SQWT=PARJ(2)
43477 DO 220 KFQPOP=1,4
43478 IF(MR.EQ.0.AND.KFQPOP.GT.3) GOTO 220
43479 IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN
43480 SQWT=DMB(MR+ISS1)/(DMB(MR+ISU0)+DMB(MR+ISU1))
43481 QQWT=0.5D0
43482 IF(MR.EQ.0) PARF(193)=PARJ(8)+PARJ(9)
43483 IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/DMB(7+ISU1)+1D0)/2D0
43484 ENDIF
43485 DO 210 KFQOLD =1,5
43486 IF(MR.EQ.0.AND.KFQOLD.GT.3) GOTO 210
43487 IF(NMES.EQ.1) THEN
43488 IF(MR.EQ.0.AND.KFQPOP.EQ.1) GOTO 210
43489 IF(MR.EQ.7.AND.KFQPOP.NE.1) GOTO 210
43490 ENDIF
43491 WTTOT=0D0
43492 WTFAIL=0D0
43493 DO 190 KMUL=0,5
43494 PJWT=PARJ(12+KMUL)
43495 IF(KMUL.EQ.0) PJWT=1D0-PARJ(14)
43496 IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17)
43497 IF(PJWT.LE.0D0) GOTO 190
43498 IF(PJWT.GT.1D0) PJWT=1D0
43499 IMES=5*KMUL
43500 IMIX=2*KFQOLD+10*KMUL
43501 KFJ=2*KMUL+1
43502 IF(KMUL.EQ.2) KFJ=10003
43503 IF(KMUL.EQ.3) KFJ=10001
43504 IF(KMUL.EQ.4) KFJ=20003
43505 IF(KMUL.EQ.5) KFJ=5
43506 DO 180 KFQVER =1,3
43507 KFLA=MAX(KFQOLD,KFQVER)
43508 KFLB=MIN(KFQOLD,KFQVER)
43509 SWT=PARJ(11+KFLA/3+KFLA/4)
43510 IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT
43511 SWT=SWT*PJWT
43512 QWT=SQWT/(2D0+SQWT)
43513 IF(KFQVER.LT.3)THEN
43514 IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT
43515 IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT)
43516 ENDIF
43517 IF(KFQVER.NE.KFQOLD)THEN
43518 IMES=IMES+1
43519 KFM=100*KFLA+10*KFLB+KFJ
43520 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
43521 PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM)
43522 WTTOT=WTTOT+PARF(IPOS+IMES)
43523 ELSE
43524 DO 170 ID=3,5
43525 IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1)
43526 IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX)
43527 IF(ID.EQ.5) DWT=PARF(IMIX)
43528 KFM=110*(ID-2)+KFJ
43529 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
43530 PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM)
43531 IF(KMUL.EQ.0.AND.ID.GT.3) THEN
43532 WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID))
43533 PARF(IPOS+5*KMUL+ID)=
43534 & PARF(IPOS+5*KMUL+ID)*PARJ(21+ID)
43535 ENDIF
43536 WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID)
43537 170 CONTINUE
43538 ENDIF
43539 180 CONTINUE
43540 190 CONTINUE
43541 DO 200 IMES=1,30
43542 PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL)
43543 200 CONTINUE
43544 IF(MR.EQ.7) PARF(140)=
43545 & MAX(PARF(140),WTTOT/(1D0-WTFAIL))
43546 IF(MR.EQ.0) PARF(139-KFQPOP/3)=
43547 & MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL))
43548 IPOS=IPOS+30
43549 210 CONTINUE
43550 220 CONTINUE
43551 230 CONTINUE
43552 240 CONTINUE
43553 IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139)
43554 MSTU(121)=0
43555
43556 ENDIF
43557
43558C..Recombine diquark weights to flavour and spin ratios
43559 PARF(151)=(2D0*(QBB(ISU0)+QBB(ISU1))+QBB(ISS1))/
43560 & (1D0+QBB(IUD1)+QBB(IUU1)+QBB(IUS0)+QBB(IUS1))
43561 PARF(152)=2D0*(QBB(IUS0)+QBB(IUS1))/(1D0+QBB(IUD1)+QBB(IUU1))
43562 PARF(153)=QBB(ISS1)/(QBB(ISU0)+QBB(ISU1))
43563 PARF(154)=QBB(IUU1)/(1D0+QBB(IUD1)+QBB(IUU1))
43564 PARF(155)=QBB(ISU1)/QBB(ISU0)
43565 PARF(156)=QBB(IUS1)/QBB(IUS0)
43566 PARF(157)=QBB(IUD1)
43567
43568 PARF(161)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/
43569 & (1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1))
43570 PARF(162)=2D0*(QBM(IUS0)+QBM(IUS1))/(1D0+QBM(IUD1)+QBM(IUU1))
43571 PARF(163)=QBM(ISS1)/(QBM(ISU0)+QBM(ISU1))
43572 PARF(164)=QBM(IUU1)/(1D0+QBM(IUD1)+QBM(IUU1))
43573 PARF(165)=QBM(ISU1)/QBM(ISU0)
43574 PARF(166)=QBM(IUS1)/QBM(IUS0)
43575 PARF(167)=QBM(IUD1)
43576
43577 PARF(171)=(2D0*(DMB(ISU0)+DMB(ISU1))+DMB(ISS1))/
43578 & (1D0+DMB(IUD1)+DMB(IUU1)+DMB(IUS0)+DMB(IUS1))
43579 PARF(172)=2D0*(DMB(IUS0)+DMB(IUS1))/(1D0+DMB(IUD1)+DMB(IUU1))
43580 PARF(173)=DMB(ISS1)/(DMB(ISU0)+DMB(ISU1))
43581 PARF(174)=DMB(IUU1)/(1D0+DMB(IUD1)+DMB(IUU1))
43582 PARF(175)=DMB(ISU1)/DMB(ISU0)
43583 PARF(176)=DMB(IUS1)/DMB(IUS0)
43584 PARF(177)=DMB(IUD1)
43585
43586 PARF(185)=DMB(7+ISU1)/DMB(7+ISU0)
43587 PARF(186)=DMB(7+IUS1)/DMB(7+IUS0)
43588 PARF(187)=DMB(7+IUD1)
43589
43590 RETURN
43591 END
43592
43593
43594C*********************************************************************
43595
43596C...PYPTDI
43597C...Generates transverse momentum according to a Gaussian.
43598
43599 SUBROUTINE PYPTDI(KFL,PX,PY)
43600
43601C...Double precision and integer declarations.
43602 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43603 IMPLICIT INTEGER(I-N)
43604 INTEGER PYK,PYCHGE,PYCOMP
43605C...Commonblocks.
43606 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43607 SAVE /PYDAT1/
43608
43609C...Generate p_T and azimuthal angle, gives p_x and p_y.
43610 KFLA=IABS(KFL)
43611 PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0))))
43612 IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT
43613 IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
43614 IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0
43615 PHI=PARU(2)*PYR(0)
43616 PX=PT*COS(PHI)
43617 PY=PT*SIN(PHI)
43618
43619 RETURN
43620 END
43621
43622C*********************************************************************
43623
43624C...PYZDIS
43625C...Generates the longitudinal splitting variable z.
43626
43627 SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z)
43628
43629C...Double precision and integer declarations.
43630 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43631 IMPLICIT INTEGER(I-N)
43632 INTEGER PYK,PYCHGE,PYCOMP
43633C...Commonblocks.
43634 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43635 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43636 SAVE /PYDAT1/,/PYDAT2/
43637
43638C...Check if heavy flavour fragmentation.
43639 KFLA=IABS(KFL1)
43640 KFLB=IABS(KFL2)
43641 KFLH=KFLA
43642 IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
43643
43644C...Lund symmetric scaling function: determine parameters of shape.
43645 IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
43646 &MSTJ(11).GE.4) THEN
43647 FA=PARJ(41)
43648 IF(MSTJ(91).EQ.1) FA=PARJ(43)
43649 IF(KFLB.GE.10) FA=FA+PARJ(45)
43650 FBB=PARJ(42)
43651 IF(MSTJ(91).EQ.1) FBB=PARJ(44)
43652 FB=FBB*PR
43653 FC=1D0
43654 IF(KFLA.GE.10) FC=FC-PARJ(45)
43655 IF(KFLB.GE.10) FC=FC+PARJ(45)
43656 IF(MSTJ(11).GE.4.AND.KFLH.GE.4.AND.KFLH.LE.5) THEN
43657 FRED=PARJ(46)
43658 IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
43659 FC=FC+FRED*FBB*PARF(100+KFLH)**2
43660 ELSEIF(MSTJ(11).GE.4.AND.KFLH.GE.6.AND.KFLH.LE.8) THEN
43661 FRED=PARJ(46)
43662 IF(MSTJ(11).EQ.5) FRED=PARJ(48)
43663 FC=FC+FRED*FBB*PMAS(KFLH,1)**2
43664 ENDIF
43665 MC=1
43666 IF(ABS(FC-1D0).GT.0.01D0) MC=2
43667
43668C...Determine position of maximum. Special cases for a = 0 or a = c.
43669 IF(FA.LT.0.02D0) THEN
43670 MA=1
43671 ZMAX=1D0
43672 IF(FC.GT.FB) ZMAX=FB/FC
43673 ELSEIF(ABS(FC-FA).LT.0.01D0) THEN
43674 MA=2
43675 ZMAX=FB/(FB+FC)
43676 ELSE
43677 MA=3
43678 ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA)
43679 IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB)
43680 ENDIF
43681
43682C...Subdivide z range if distribution very peaked near endpoint.
43683 MMAX=2
43684 IF(ZMAX.LT.0.1D0) THEN
43685 MMAX=1
43686 ZDIV=2.75D0*ZMAX
43687 IF(MC.EQ.1) THEN
43688 FINT=1D0-LOG(ZDIV)
43689 ELSE
43690 ZDIVC=ZDIV**(1D0-FC)
43691 FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0)
43692 ENDIF
43693 ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN
43694 MMAX=3
43695 FSCB=SQRT(4D0+(FC/FB)**2)
43696 ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB))
43697 IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX)
43698 ZDIV=MIN(ZMAX,MAX(0D0,ZDIV))
43699 FINT=1D0+FB*(1D0-ZDIV)
43700 ENDIF
43701
43702C...Choice of z, preweighted for peaks at low or high z.
43703 100 Z=PYR(0)
43704 FPRE=1D0
43705 IF(MMAX.EQ.1) THEN
43706 IF(FINT*PYR(0).LE.1D0) THEN
43707 Z=ZDIV*Z
43708 ELSEIF(MC.EQ.1) THEN
43709 Z=ZDIV**Z
43710 FPRE=ZDIV/Z
43711 ELSE
43712 Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC))
43713 FPRE=(ZDIV/Z)**FC
43714 ENDIF
43715 ELSEIF(MMAX.EQ.3) THEN
43716 IF(FINT*PYR(0).LE.1D0) THEN
43717 Z=ZDIV+LOG(Z)/FB
43718 FPRE=EXP(FB*(Z-ZDIV))
43719 ELSE
43720 Z=ZDIV+Z*(1D0-ZDIV)
43721 ENDIF
43722 ENDIF
43723
43724C...Weighting according to correct formula.
43725 IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100
43726 FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z)
43727 IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX))
43728 FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP)))
43729 IF(FVAL.LT.PYR(0)*FPRE) GOTO 100
43730
43731C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
43732 ELSE
43733 FC=PARJ(50+MAX(1,KFLH))
43734 IF(MSTJ(91).EQ.1) FC=PARJ(59)
43735 110 Z=PYR(0)
43736 IF(FC.GE.0D0.AND.FC.LE.1D0) THEN
43737 IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0)
43738 ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN
43739 IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2)
43740 & GOTO 110
43741 ELSE
43742 IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
43743 IF(FC.LT.0D0) Z=Z**(-1D0/FC)
43744 ENDIF
43745 ENDIF
43746
43747 RETURN
43748 END
43749
43750C*********************************************************************
43751
43752C...PYSHOW
43753C...Generates timelike parton showers from given partons.
43754
43755 SUBROUTINE PYSHOW(IP1,IP2,QMAX)
43756
43757C...Double precision and integer declarations.
43758 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43759 IMPLICIT INTEGER(I-N)
43760 INTEGER PYK,PYCHGE,PYCOMP
43761C...Commonblocks.
43762 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43763 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43764 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43765 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
43766C...Local arrays.
43767 DIMENSION PMTH(5,50),PS(5),PMA(4),PMSD(4),IEP(4),IPA(4),
43768 &KFLA(4),KFLD(4),KFL(4),ITRY(4),ISI(4),ISL(4),DP(4),DPT(5,4),
43769 &KSH(0:40),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),PHIIIS(2,2),
43770 &ISII(2),ISSET(3)
43771
43772C...Check that QMAX not too low.
43773 IF(MSTJ(41).LE.0) THEN
43774 RETURN
43775 ELSEIF(MSTJ(41).EQ.1) THEN
43776 IF(QMAX.LE.PARJ(82).AND.IP2.GT.-5) RETURN
43777 ELSE
43778 IF(QMAX.LE.MIN(PARJ(82),PARJ(83),PARJ(90)).AND.IP2.GT.-5)
43779 & RETURN
43780 ENDIF
43781
43782C...Initialization of cutoff masses etc.
43783 DO 100 IFL=0,40
43784 KSH(IFL)=0
43785 100 CONTINUE
43786 KSH(21)=1
43787 PMTH(1,21)=PYMASS(21)
43788 PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2)
43789 PMTH(3,21)=2D0*PMTH(2,21)
43790 PMTH(4,21)=PMTH(3,21)
43791 PMTH(5,21)=PMTH(3,21)
43792 PMTH(1,22)=PYMASS(22)
43793 PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2)
43794 PMTH(3,22)=2D0*PMTH(2,22)
43795 PMTH(4,22)=PMTH(3,22)
43796 PMTH(5,22)=PMTH(3,22)
43797 PMQTH1=PARJ(82)
43798 IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
43799 PMQT1E=MIN(PMQTH1,PARJ(90))
43800 PMQTH2=PMTH(2,21)
43801 IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
43802 PMQT2E=MIN(PMQTH2,0.5D0*PARJ(90))
43803 DO 110 IFL=1,8
43804 KSH(IFL)=1
43805 PMTH(1,IFL)=PYMASS(IFL)
43806 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2)
43807 PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
43808 PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
43809 PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
43810 110 CONTINUE
43811 DO 120 IFL=11,17,2
43812 IF(MSTJ(41).GE.2) KSH(IFL)=1
43813 PMTH(1,IFL)=PYMASS(IFL)
43814 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(90)**2)
43815 PMTH(3,IFL)=PMTH(2,IFL)+0.5D0*PARJ(90)
43816 PMTH(4,IFL)=PMTH(3,IFL)
43817 PMTH(5,IFL)=PMTH(3,IFL)
43818 120 CONTINUE
43819 PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2
43820 ALAMS=PARJ(81)**2
43821 ALFM=LOG(PT2MIN/ALAMS)
43822
43823C...Store positions of shower initiating partons.
43824 MPSPD=0
43825 IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
43826 NPA=1
43827 IPA(1)=IP1
43828 ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
43829 & MSTU(32))) THEN
43830 NPA=2
43831 IPA(1)=IP1
43832 IPA(2)=IP2
43833 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
43834 & .AND.IP2.GE.-3) THEN
43835 NPA=IABS(IP2)
43836 DO 130 I=1,NPA
43837 IPA(I)=IP1+I-1
43838 130 CONTINUE
43839 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.
43840 &IP2.EQ.-8) THEN
43841 MPSPD=1
43842 NPA=2
43843 IPA(1)=IP1+6
43844 IPA(2)=IP1+7
43845 ELSE
43846 CALL PYERRM(12,
43847 & '(PYSHOW:) failed to reconstruct showering system')
43848 IF(MSTU(21).GE.1) RETURN
43849 ENDIF
43850
43851C...Check on phase space available for emission.
43852 IREJ=0
43853 DO 140 J=1,5
43854 PS(J)=0D0
43855 140 CONTINUE
43856 PM=0D0
43857 DO 160 I=1,NPA
43858 KFLA(I)=IABS(K(IPA(I),2))
43859 PMA(I)=P(IPA(I),5)
43860C...Special cutoff masses for t, l, h with variable masses.
43861 IFLA=KFLA(I)
43862 IF(KFLA(I).GE.6.AND.KFLA(I).LE.8) THEN
43863 IFLA=37+KFLA(I)+ISIGN(2,K(IPA(I),2))
43864 PMTH(1,IFLA)=PMA(I)
43865 PMTH(2,IFLA)=SQRT(PMTH(1,IFLA)**2+0.25D0*PMQTH1**2)
43866 PMTH(3,IFLA)=PMTH(2,IFLA)+PMQTH2
43867 PMTH(4,IFLA)=SQRT(PMTH(1,IFLA)**2+0.25D0*PARJ(82)**2)+
43868 & PMTH(2,21)
43869 PMTH(5,IFLA)=SQRT(PMTH(1,IFLA)**2+0.25D0*PARJ(83)**2)+
43870 & PMTH(2,22)
43871 ENDIF
43872 IF(KFLA(I).LE.40) THEN
43873 IF(KSH(KFLA(I)).EQ.1) PMA(I)=PMTH(3,IFLA)
43874 ENDIF
43875 PM=PM+PMA(I)
43876 IF(KFLA(I).GT.40) THEN
43877 IREJ=IREJ+1
43878 ELSE
43879 IF(KSH(KFLA(I)).EQ.0.OR.PMA(I).GT.QMAX) IREJ=IREJ+1
43880 ENDIF
43881 DO 150 J=1,4
43882 PS(J)=PS(J)+P(IPA(I),J)
43883 150 CONTINUE
43884 160 CONTINUE
43885 IF(IREJ.EQ.NPA.AND.IP2.GT.-5) RETURN
43886 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
43887 IF(NPA.EQ.1) PS(5)=PS(4)
43888 IF(PS(5).LE.PM+PMQT1E) RETURN
43889
43890C...Check if 3-jet matrix elements to be used.
43891 M3JC=0
43892 IF(NPA.EQ.2.AND.MSTJ(47).GE.1.AND.MPSPD.EQ.0) THEN
43893 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8.AND.KFLA(2).GE.1.AND.
43894 & KFLA(2).LE.8) M3JC=1
43895 IF((KFLA(1).EQ.11.OR.KFLA(1).EQ.13.OR.KFLA(1).EQ.15.OR.
43896 & KFLA(1).EQ.17).AND.KFLA(2).EQ.KFLA(1)) M3JC=1
43897 IF((KFLA(1).EQ.11.OR.KFLA(1).EQ.13.OR.KFLA(1).EQ.15.OR.
43898 & KFLA(1).EQ.17).AND.KFLA(2).EQ.KFLA(1)+1) M3JC=1
43899 IF((KFLA(1).EQ.12.OR.KFLA(1).EQ.14.OR.KFLA(1).EQ.16.OR.
43900 & KFLA(1).EQ.18).AND.KFLA(2).EQ.KFLA(1)-1) M3JC=1
43901 IF(MSTJ(47).EQ.2.OR.MSTJ(47).EQ.4) M3JC=1
43902 M3JCM=0
43903 IF(M3JC.EQ.1.AND.MSTJ(47).GE.3.AND.KFLA(1).EQ.KFLA(2)) THEN
43904 M3JCM=1
43905 PQMES=PMTH(1,KFLA(1))**2
43906 QME=4D0*PQMES/PS(5)**2
43907 RESCZ=MIN(1D0,LOG(PMTH(2,KFLA(1))/PS(5))/
43908 & LOG(PMTH(2,21)/PS(5)))
43909 ENDIF
43910 ENDIF
43911
43912C...Find if interference with initial state partons.
43913 MIIS=0
43914 IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2.AND.MPSPD.EQ.0)
43915 &MIIS=MSTJ(50)
43916 IF(MIIS.NE.0) THEN
43917 DO 180 I=1,2
43918 KCII(I)=0
43919 KCA=PYCOMP(KFLA(I))
43920 IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
43921 NIIS(I)=0
43922 IF(KCII(I).NE.0) THEN
43923 DO 170 J=1,2
43924 ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5))
43925 IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND.
43926 & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN
43927 NIIS(I)=NIIS(I)+1
43928 IIIS(I,NIIS(I))=ICSI
43929 ENDIF
43930 170 CONTINUE
43931 ENDIF
43932 180 CONTINUE
43933 IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
43934 ENDIF
43935
43936C...Boost interfering initial partons to rest frame
43937C...and reconstruct their polar and azimuthal angles.
43938 IF(MIIS.NE.0) THEN
43939 DO 200 I=1,2
43940 DO 190 J=1,5
43941 K(N+I,J)=K(IPA(I),J)
43942 P(N+I,J)=P(IPA(I),J)
43943 V(N+I,J)=0D0
43944 190 CONTINUE
43945 200 CONTINUE
43946 DO 220 I=3,2+NIIS(1)
43947 DO 210 J=1,5
43948 K(N+I,J)=K(IIIS(1,I-2),J)
43949 P(N+I,J)=P(IIIS(1,I-2),J)
43950 V(N+I,J)=0D0
43951 210 CONTINUE
43952 220 CONTINUE
43953 DO 240 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
43954 DO 230 J=1,5
43955 K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J)
43956 P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J)
43957 V(N+I,J)=0D0
43958 230 CONTINUE
43959 240 CONTINUE
43960 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4),
43961 & -PS(2)/PS(4),-PS(3)/PS(4))
43962 PHI=PYANGL(P(N+1,1),P(N+1,2))
43963 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0)
43964 THE=PYANGL(P(N+1,3),P(N+1,1))
43965 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0)
43966 DO 250 I=3,2+NIIS(1)
43967 THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2))
43968 PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2))
43969 250 CONTINUE
43970 DO 260 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
43971 THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3),
43972 & SQRT(P(N+I,1)**2+P(N+I,2)**2))
43973 PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2))
43974 260 CONTINUE
43975 ENDIF
43976
43977C...Define imagined single initiator of shower for parton system.
43978 NS=N
43979 IF(N.GT.MSTU(4)-MSTU(32)-5) THEN
43980 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
43981 IF(MSTU(21).GE.1) RETURN
43982 ENDIF
43983 265 N=NS
43984 IF(NPA.GE.2) THEN
43985 K(N+1,1)=11
43986 K(N+1,2)=21
43987 K(N+1,3)=0
43988 K(N+1,4)=0
43989 K(N+1,5)=0
43990 P(N+1,1)=0D0
43991 P(N+1,2)=0D0
43992 P(N+1,3)=0D0
43993 P(N+1,4)=PS(5)
43994 P(N+1,5)=PS(5)
43995 V(N+1,5)=PS(5)**2
43996 N=N+1
43997 ENDIF
43998
43999C...Loop over partons that may branch.
44000 NEP=NPA
44001 IM=NS
44002 IF(NPA.EQ.1) IM=NS-1
44003 270 IM=IM+1
44004 IF(N.GT.NS) THEN
44005 IF(IM.GT.N) GOTO 510
44006 KFLM=IABS(K(IM,2))
44007 IF(KFLM.GT.40) GOTO 270
44008 IF(KSH(KFLM).EQ.0) GOTO 270
44009 IFLM=KFLM
44010 IF(KFLM.GE.6.AND.KFLM.LE.8) IFLM=37+KFLM+ISIGN(2,K(IM,2))
44011 IF(P(IM,5).LT.PMTH(2,IFLM)) GOTO 270
44012 IGM=K(IM,3)
44013 ELSE
44014 IGM=-1
44015 ENDIF
44016 IF(N+NEP.GT.MSTU(4)-MSTU(32)-5) THEN
44017 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
44018 IF(MSTU(21).GE.1) RETURN
44019 ENDIF
44020
44021C...Position of aunt (sister to branching parton).
44022C...Origin and flavour of daughters.
44023 IAU=0
44024 IF(IGM.GT.0) THEN
44025 IF(K(IM-1,3).EQ.IGM) IAU=IM-1
44026 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
44027 ENDIF
44028 IF(IGM.GE.0) THEN
44029 K(IM,4)=N+1
44030 DO 280 I=1,NEP
44031 K(N+I,3)=IM
44032 280 CONTINUE
44033 ELSE
44034 K(N+1,3)=IPA(1)
44035 ENDIF
44036 IF(IGM.LE.0) THEN
44037 DO 290 I=1,NEP
44038 K(N+I,2)=K(IPA(I),2)
44039 290 CONTINUE
44040 ELSEIF(KFLM.NE.21) THEN
44041 K(N+1,2)=K(IM,2)
44042 K(N+2,2)=K(IM,5)
44043 ELSEIF(K(IM,5).EQ.21) THEN
44044 K(N+1,2)=21
44045 K(N+2,2)=21
44046 ELSE
44047 K(N+1,2)=K(IM,5)
44048 K(N+2,2)=-K(IM,5)
44049 ENDIF
44050
44051C...Reset flags on daughters and tries made.
44052 DO 300 IP=1,NEP
44053 K(N+IP,1)=3
44054 K(N+IP,4)=0
44055 K(N+IP,5)=0
44056 KFLD(IP)=IABS(K(N+IP,2))
44057 IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
44058 ITRY(IP)=0
44059 ISL(IP)=0
44060 ISI(IP)=0
44061 IF(KFLD(IP).LE.40) THEN
44062 IF(KSH(KFLD(IP)).EQ.1) ISI(IP)=1
44063 ENDIF
44064 300 CONTINUE
44065 ISLM=0
44066
44067C...Maximum virtuality of daughters.
44068 IF(IGM.LE.0) THEN
44069 DO 310 I=1,NPA
44070 IF(NPA.GE.3) P(N+I,4)=(PS(4)*P(IPA(I),4)-PS(1)*P(IPA(I),1)-
44071 & PS(2)*P(IPA(I),2)-PS(3)*P(IPA(I),3))/PS(5)
44072 P(N+I,5)=MIN(QMAX,PS(5))
44073 IF(IP2.LE.-5) P(N+I,5)=MAX(P(N+I,5),
44074 & 2D0*PMTH(3,IABS(K(N+I,2))))
44075 IF(NPA.GE.3) P(N+I,5)=MIN(P(N+I,5),P(N+I,4))
44076 IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
44077 310 CONTINUE
44078 ELSE
44079 IF(MSTJ(43).LE.2) PEM=V(IM,2)
44080 IF(MSTJ(43).GE.3) PEM=P(IM,4)
44081 P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
44082 P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM)
44083 IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
44084 ENDIF
44085 DO 320 I=1,NEP
44086 PMSD(I)=P(N+I,5)
44087 IF(ISI(I).EQ.1) THEN
44088 IFLD=KFLD(I)
44089 IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
44090 & ISIGN(2,K(N+I,2))
44091 IF(P(N+I,5).LE.PMTH(3,IFLD)) P(N+I,5)=PMTH(1,IFLD)
44092 ENDIF
44093 V(N+I,5)=P(N+I,5)**2
44094 320 CONTINUE
44095
44096C...Choose one of the daughters for evolution.
44097 330 INUM=0
44098 IF(NEP.EQ.1) INUM=1
44099 DO 340 I=1,NEP
44100 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
44101 340 CONTINUE
44102 DO 350 I=1,NEP
44103 IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
44104 IFLD=KFLD(I)
44105 IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
44106 & ISIGN(2,K(N+I,2))
44107 IF(P(N+I,5).GE.PMTH(2,IFLD)) INUM=I
44108 ENDIF
44109 350 CONTINUE
44110 IF(INUM.EQ.0) THEN
44111 RMAX=0D0
44112 DO 360 I=1,NEP
44113 IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQT2E) THEN
44114 RPM=P(N+I,5)/PMSD(I)
44115 IFLD=KFLD(I)
44116 IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
44117 & ISIGN(2,K(N+I,2))
44118 IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IFLD)) THEN
44119 RMAX=RPM
44120 INUM=I
44121 ENDIF
44122 ENDIF
44123 360 CONTINUE
44124 ENDIF
44125
44126C...Cancel choice of predetermined daughter already treated.
44127 INUM=MAX(1,INUM)
44128 INUMT=INUM
44129 IF(MPSPD.EQ.1.AND.IGM.EQ.0.AND.ITRY(INUMT).GE.1) THEN
44130 IF(K(IP1-1+INUM,4).GT.0) INUM=3-INUM
44131 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2.AND.ITRY(INUMT).GE.1) THEN
44132 IF(KFLD(INUMT).NE.21.AND.K(IP1+2,4).GT.0) INUM=3-INUM
44133 IF(KFLD(INUMT).EQ.21.AND.K(IP1+3,4).GT.0) INUM=3-INUM
44134 ENDIF
44135
44136C...Store information on choice of evolving daughter.
44137 IEP(1)=N+INUM
44138 DO 370 I=2,NEP
44139 IEP(I)=IEP(I-1)+1
44140 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
44141 370 CONTINUE
44142 DO 380 I=1,NEP
44143 KFL(I)=IABS(K(IEP(I),2))
44144 380 CONTINUE
44145 ITRY(INUM)=ITRY(INUM)+1
44146 IF(ITRY(INUM).GT.200) THEN
44147 CALL PYERRM(14,'(PYSHOW:) caught in infinite loop')
44148 IF(MSTU(21).GE.1) RETURN
44149 ENDIF
44150 Z=0.5D0
44151 IF(KFL(1).GT.40) GOTO 430
44152 IF(KSH(KFL(1)).EQ.0) GOTO 430
44153 IFL=KFL(1)
44154 IF(KFL(1).GE.6.AND.KFL(1).LE.8) IFL=37+KFL(1)+
44155 &ISIGN(2,K(IEP(1),2))
44156 IF(P(IEP(1),5).LT.PMTH(2,IFL)) GOTO 430
44157
44158C...Check if evolution already predetermined for daughter.
44159 IPSPD=0
44160 IF(MPSPD.EQ.1.AND.IGM.EQ.0) THEN
44161 IF(K(IP1-1+INUM,4).GT.0) IPSPD=IP1-1+INUM
44162 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2) THEN
44163 IF(KFL(1).NE.21.AND.K(IP1+2,4).GT.0) IPSPD=IP1+2
44164 IF(KFL(1).EQ.21.AND.K(IP1+3,4).GT.0) IPSPD=IP1+3
44165 ENDIF
44166 ISSET(INUM)=0
44167 IF(IPSPD.NE.0) ISSET(INUM)=1
44168
44169C...Select side for interference with initial state partons.
44170 IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
44171 III=IEP(1)-NS-1
44172 ISII(III)=0
44173 IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
44174 ISII(III)=1
44175 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
44176 IF(PYR(0).GT.0.5D0) ISII(III)=1
44177 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
44178 ISII(III)=1
44179 IF(PYR(0).GT.0.5D0) ISII(III)=2
44180 ENDIF
44181 ENDIF
44182
44183C...Calculate allowed z range.
44184 IF(NEP.EQ.1) THEN
44185 PMED=PS(4)
44186 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
44187 PMED=P(IM,5)
44188 ELSE
44189 IF(INUM.EQ.1) PMED=V(IM,1)*PEM
44190 IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM
44191 ENDIF
44192 IF(MOD(MSTJ(43),2).EQ.1) THEN
44193 ZC=PMTH(2,21)/PMED
44194 ZCE=PMTH(2,22)/PMED
44195 IF(KFL(1).GE.11.AND.KFL(1).LE.18) ZCE=0.5D0*PARJ(90)/PMED
44196 ELSE
44197 ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2)))
44198 IF(ZC.LT.1D-6) ZC=(PMTH(2,21)/PMED)**2
44199 PMTMPE=PMTH(2,22)
44200 IF(KFL(1).GE.11.AND.KFL(1).LE.18) PMTMPE=0.5D0*PARJ(90)
44201 ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTMPE/PMED)**2)))
44202 IF(ZCE.LT.1D-6) ZCE=(PMTMPE/PMED)**2
44203 ENDIF
44204 ZC=MIN(ZC,0.491D0)
44205 ZCE=MIN(ZCE,0.49991D0)
44206 IF(((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND.
44207 &MIN(ZC,ZCE).GT.0.4999D0)).AND.IPSPD.EQ.0) THEN
44208 P(IEP(1),5)=PMTH(1,IFL)
44209 V(IEP(1),5)=P(IEP(1),5)**2
44210 GOTO 430
44211 ENDIF
44212
44213C...Integral of Altarelli-Parisi z kernel for QCD.
44214 IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
44215 FBR=6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*0.5D0
44216 ELSEIF(MSTJ(49).EQ.0) THEN
44217 FBR=(8D0/3D0)*LOG((1D0-ZC)/ZC)
44218
44219C...Integral of Altarelli-Parisi z kernel for scalar gluon.
44220 ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
44221 FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC)
44222 ELSEIF(MSTJ(49).EQ.1) THEN
44223 FBR=(1D0-2D0*ZC)/3D0
44224 IF(IGM.EQ.0.AND.M3JC.EQ.1) FBR=4D0*FBR
44225
44226C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
44227 ELSEIF(KFL(1).EQ.21) THEN
44228 FBR=6D0*MSTJ(45)*(0.5D0-ZC)
44229 ELSE
44230 FBR=2D0*LOG((1D0-ZC)/ZC)
44231 ENDIF
44232
44233C...Reset QCD probability for lepton.
44234 IF(KFL(1).GE.11.AND.KFL(1).LE.18) FBR=0D0
44235
44236C...Integral of Altarelli-Parisi kernel for photon emission.
44237 IF(MSTJ(41).GE.2.AND.KFL(1).GE.1.AND.KFL(1).LE.18) THEN
44238 FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE)
44239 IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE
44240 ENDIF
44241
44242C...Inner veto algorithm starts. Find maximum mass for evolution.
44243 390 PMS=V(IEP(1),5)
44244 IF(IGM.GE.0) THEN
44245 PM2=0D0
44246 DO 400 I=2,NEP
44247 PM=P(IEP(I),5)
44248 IF(KFL(I).LE.40) THEN
44249 IFLI=KFL(I)
44250 IF(KFL(I).GE.6.AND.KFL(I).LE.8) IFLI=37+KFL(I)+
44251 & ISIGN(2,K(IEP(I),2))
44252 IF(KSH(KFL(I)).EQ.1) PM=PMTH(2,IFLI)
44253 ENDIF
44254 PM2=PM2+PM
44255 400 CONTINUE
44256 PMS=MIN(PMS,(P(IM,5)-PM2)**2)
44257 ENDIF
44258
44259C...Select mass for daughter in QCD evolution.
44260 B0=27D0/6D0
44261 DO 410 IFF=4,MSTJ(45)
44262 IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0
44263 410 CONTINUE
44264C...Already predetermined choice.
44265 IF(IPSPD.NE.0) THEN
44266 PMSQCD=P(IPSPD,5)**2
44267 ELSEIF(FBR.LT.1D-3) THEN
44268 PMSQCD=0D0
44269 ELSEIF(MSTJ(44).LE.0) THEN
44270 PMSQCD=PMS*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR)))
44271 ELSEIF(MSTJ(44).EQ.1) THEN
44272 PMSQCD=4D0*ALAMS*(0.25D0*PMS/ALAMS)**(PYR(0)**(B0/FBR))
44273 ELSE
44274 PMSQCD=PMS*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR))
44275 ENDIF
44276 IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IFL)**2) PMSQCD=
44277 & PMTH(2,IFL)**2
44278 V(IEP(1),5)=PMSQCD
44279 MCE=1
44280
44281C...Select mass for daughter in QED evolution.
44282 IF(MSTJ(41).GE.2.AND.KFL(1).GE.1.AND.KFL(1).LE.18.AND.
44283 &IPSPD.EQ.0) THEN
44284 PMSQED=PMS*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(101)*FBRE)))
44285 IF(ZCE.GT.0.4999D0.OR.PMSQED.LE.PMTH(5,IFL)**2) PMSQED=
44286 & PMTH(2,IFL)**2
44287 IF(PMSQED.GT.PMSQCD) THEN
44288 V(IEP(1),5)=PMSQED
44289 MCE=2
44290 ENDIF
44291 ENDIF
44292
44293C...Check whether daughter mass below cutoff.
44294 P(IEP(1),5)=SQRT(V(IEP(1),5))
44295 IF(P(IEP(1),5).LE.PMTH(3,IFL)) THEN
44296 P(IEP(1),5)=PMTH(1,IFL)
44297 V(IEP(1),5)=P(IEP(1),5)**2
44298 GOTO 430
44299 ENDIF
44300
44301C...Already predetermined choice of z, and flavour in g -> qqbar.
44302 IF(IPSPD.NE.0) THEN
44303 IPSGD1=K(IPSPD,4)
44304 IPSGD2=K(IPSPD,5)
44305 PMSGD1=P(IPSGD1,5)**2
44306 PMSGD2=P(IPSGD2,5)**2
44307 ALAMPS=SQRT(MAX(1D-10,(PMSQCD-PMSGD1-PMSGD2)**2-
44308 & 4D0*PMSGD1*PMSGD2))
44309 Z=0.5D0*(PMSQCD*(2D0*P(IPSGD1,4)/P(IPSPD,4)-1D0)+ALAMPS-
44310 & PMSGD1+PMSGD2)/ALAMPS
44311 Z=MAX(0.00001D0,MIN(0.99999D0,Z))
44312 IF(KFL(1).NE.21) THEN
44313 K(IEP(1),5)=21
44314 ELSE
44315 K(IEP(1),5)=IABS(K(IPSGD1,2))
44316 ENDIF
44317
44318C...Select z value of branching: q -> qgamma.
44319 ELSEIF(MCE.EQ.2) THEN
44320 Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0)
44321 IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 390
44322 K(IEP(1),5)=22
44323
44324C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
44325 ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
44326 Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
44327 IF(IGM.EQ.0.AND.M3JCM.EQ.1) Z=1D0-(1D0-Z)**RESCZ
44328 IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 390
44329 K(IEP(1),5)=21
44330 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*0.5D0.LT.PYR(0)*FBR) THEN
44331 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
44332 IF(PYR(0).GT.0.5D0) Z=1D0-Z
44333 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 390
44334 K(IEP(1),5)=21
44335 ELSEIF(MSTJ(49).NE.1) THEN
44336 Z=PYR(0)
44337 IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 390
44338 KFLB=1+INT(MSTJ(45)*PYR(0))
44339 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
44340 IF(PMQ.GE.1D0) GOTO 390
44341 IF(MSTJ(44).LE.2) THEN
44342 IF(Z.LT.ZC.OR.Z.GT.1D0-ZC) GOTO 390
44343 PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5)
44344 IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ)
44345 & .LT.PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 390
44346 ELSE
44347 IF((1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.PYR(0)) GOTO 390
44348 ENDIF
44349 K(IEP(1),5)=KFLB
44350
44351C...Ditto for scalar gluon model.
44352 ELSEIF(KFL(1).NE.21) THEN
44353 Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC))
44354 K(IEP(1),5)=21
44355 ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
44356 Z=ZC+(1D0-2D0*ZC)*PYR(0)
44357 K(IEP(1),5)=21
44358 ELSE
44359 Z=ZC+(1D0-2D0*ZC)*PYR(0)
44360 KFLB=1+INT(MSTJ(45)*PYR(0))
44361 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
44362 IF(PMQ.GE.1D0) GOTO 390
44363 K(IEP(1),5)=KFLB
44364 ENDIF
44365
44366C...Correct to alpha_s(pT^2) (optionally m^2/4 for g -> q qbar).
44367 IF(MCE.EQ.1.AND.MSTJ(44).GE.2.AND.IPSPD.EQ.0) THEN
44368 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.MSTJ(44).EQ.3) THEN
44369 IF(ALFM/LOG(V(IEP(1),5)*0.25D0/ALAMS).LT.PYR(0)) GOTO 390
44370 ELSE
44371 IF(Z*(1D0-Z)*V(IEP(1),5).LT.PT2MIN) GOTO 390
44372 IF(ALFM/LOG(V(IEP(1),5)*Z*(1D0-Z)/ALAMS).LT.PYR(0)) GOTO 390
44373 ENDIF
44374 ENDIF
44375
44376C...Check if z consistent with chosen m.
44377 IF(KFL(1).EQ.21) THEN
44378 KFLGD1=IABS(K(IEP(1),5))
44379 KFLGD2=KFLGD1
44380 ELSE
44381 KFLGD1=KFL(1)
44382 KFLGD2=IABS(K(IEP(1),5))
44383 ENDIF
44384 IF(NEP.EQ.1) THEN
44385 PED=PS(4)
44386 ELSEIF(NEP.GE.3) THEN
44387 PED=P(IEP(1),4)
44388 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
44389 PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
44390 ELSE
44391 IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
44392 IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM
44393 ENDIF
44394 IF(MOD(MSTJ(43),2).EQ.1) THEN
44395 IFLGD1=KFLGD1
44396 IF(KFLGD1.GE.6.AND.KFLGD1.LE.8) IFLGD1=IFL
44397 PMQTH3=0.5D0*PARJ(82)
44398 IF(KFLGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
44399 IF(KFL(1).GE.11.AND.KFL(1).LE.18) PMQTH3=0.5D0*PARJ(90)
44400 PMQ1=(PMTH(1,IFLGD1)**2+PMQTH3**2)/V(IEP(1),5)
44401 PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(IEP(1),5)
44402 ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
44403 & 4D0*PMQ1*PMQ2)))
44404 ZH=1D0+PMQ1-PMQ2
44405 ELSE
44406 ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2))
44407 ZH=1D0
44408 ENDIF
44409 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.MSTJ(44).EQ.3) THEN
44410 ELSEIF(IPSPD.NE.0) THEN
44411 ELSE
44412 ZL=0.5D0*(ZH-ZD)
44413 ZU=0.5D0*(ZH+ZD)
44414 IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 390
44415 ENDIF
44416 IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL*
44417 &(1D0-ZU)))
44418 IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
44419
44420C...Width suppression for q -> q + g.
44421 IF(MSTJ(40).NE.0.AND.KFL(1).NE.21.AND.IPSPD.EQ.0) THEN
44422 IF(IGM.EQ.0) THEN
44423 EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5))
44424 ELSE
44425 EGLU=PMED*(1D0-Z)
44426 ENDIF
44427 CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2)
44428 IF(MSTJ(40).EQ.1) THEN
44429 IF(CHI.LT.PYR(0)) GOTO 390
44430 ELSEIF(MSTJ(40).EQ.2) THEN
44431 IF(1D0-CHI.LT.PYR(0)) GOTO 390
44432 ENDIF
44433 ENDIF
44434
44435C...Three-jet matrix element correction (on both sides).
44436 IF(IGM.EQ.0.AND.M3JC.EQ.1) THEN
44437 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
44438 X2=1D0-V(IEP(1),5)/V(NS+1,5)
44439 X3=(1D0-X1)+(1D0-X2)
44440 IF(MCE.EQ.2) THEN
44441 KI1=K(IPA(INUM),2)
44442 KI2=K(IPA(3-INUM),2)
44443 QF1=KCHG(IABS(KI1),1)*ISIGN(1,KI1)/3D0
44444 QF2=KCHG(IABS(KI2),1)*ISIGN(1,KI2)/3D0
44445 WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+
44446 & QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2)
44447 WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2)
44448 ELSEIF(MSTJ(49).NE.1.AND.M3JCM.NE.1) THEN
44449 WSHOW=1D0+(1D0-X1)/X3*(X1/(2D0-X2))**2+
44450 & (1D0-X2)/X3*(X2/(2D0-X1))**2
44451 WME=X1**2+X2**2
44452 ELSEIF(MSTJ(49).NE.1) THEN
44453 X1=(1D0+(V(IEP(1),5)-PQMES)/V(NS+1,5))*
44454 & (Z+(1D0-Z)*PQMES/V(IEP(1),5))
44455 X2=1D0-(V(IEP(1),5)-PQMES)/V(NS+1,5)
44456 X3=(1D0-X1)+(1D0-X2)
44457 Z1SH=(X1-(PQMES/V(NS+1,5))*(X3/MAX(1D-10,1D0-X2)))/(2D0-X2)
44458 Z2SH=(X2-(PQMES/V(NS+1,5))*(X3/MAX(1D-10,1D0-X1)))/(2D0-X1)
44459 WSHOW=(((1D0-X1)/(2D0-X2))*(1D0+Z1SH**2)/MAX(1D-10,1D0-Z1SH)+
44460 & ((1D0-X2)/(2D0-X1))*(1D0+Z2SH**2)/MAX(1D-10,1D0-Z2SH))/RESCZ
44461 WME=X1**2+X2**2-QME*X3-0.5D0*QME**2-
44462 & (0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/MAX(1D-10,1D0-X1)+
44463 & (1D0-X1)/MAX(1D-10,1D0-X2))
44464 ELSE
44465 WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2)
44466 WME=X3**2
44467 IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*
44468 & PARJ(171)
44469 ENDIF
44470 IF(WME.LT.PYR(0)*WSHOW) GOTO 390
44471
44472C...Impose angular ordering by rejection of nonordered emission.
44473 ELSEIF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2.AND.IPSPD.EQ.0)
44474 &THEN
44475 PEMAO=V(IM,1)*P(IM,4)
44476 IF(IEP(1).EQ.N+2) PEMAO=(1D0-V(IM,1))*P(IM,4)
44477 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.MSTJ(42).EQ.4) THEN
44478 MAOD=0
44479 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.MSTJ(42).EQ.3)
44480 & THEN
44481 MAOD=1
44482 PMDAO=PMTH(2,K(IEP(1),5))
44483 THE2ID=Z*(1D0-Z)*PEMAO**2/(V(IEP(1),5)-4D0*PMDAO**2)
44484 ELSE
44485 MAOD=1
44486 THE2ID=Z*(1D0-Z)*PEMAO**2/V(IEP(1),5)
44487 ENDIF
44488 MAOM=1
44489 IAOM=IM
44490 420 IF(K(IAOM,5).EQ.22) THEN
44491 IAOM=K(IAOM,3)
44492 IF(K(IAOM,3).LE.NS) MAOM=0
44493 IF(MAOM.EQ.1) GOTO 420
44494 ENDIF
44495 IF(MAOM.EQ.1.AND.MAOD.EQ.1) THEN
44496 THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
44497 IF(THE2ID.LT.THE2IM) GOTO 390
44498 ENDIF
44499 ENDIF
44500
44501C...Impose user-defined maximum angle at first branching.
44502 IF(MSTJ(48).EQ.1.AND.IPSPD.EQ.0) THEN
44503 IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
44504 THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5)
44505 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 390
44506 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
44507 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
44508 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 390
44509 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
44510 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
44511 IF(PARJ(86)**2*THE2ID.LT.1D0) GOTO 390
44512 ENDIF
44513 ENDIF
44514
44515C...Impose angular constraint in first branching from interference
44516C...with initial state partons.
44517 IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN
44518 THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2
44519 IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN
44520 IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 390
44521 ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN
44522 IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 390
44523 ENDIF
44524 ENDIF
44525
44526C...End of inner veto algorithm. Check if only one leg evolved so far.
44527 430 V(IEP(1),1)=Z
44528 ISL(1)=0
44529 ISL(2)=0
44530 IF(NEP.EQ.1) GOTO 460
44531 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 330
44532 DO 440 I=1,NEP
44533 IF(ITRY(I).EQ.0.AND.KFLD(I).LE.40) THEN
44534 IF(KSH(KFLD(I)).EQ.1) THEN
44535 IFLD=KFLD(I)
44536 IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
44537 & ISIGN(2,K(N+I,2))
44538 IF(P(N+I,5).GE.PMTH(2,IFLD)) GOTO 330
44539 ENDIF
44540 ENDIF
44541 440 CONTINUE
44542
44543C...Check if chosen multiplet m1,m2,z1,z2 is physical.
44544 IF(NEP.EQ.3) THEN
44545 PA1S=(P(N+1,4)+P(N+1,5))*(P(N+1,4)-P(N+1,5))
44546 PA2S=(P(N+2,4)+P(N+2,5))*(P(N+2,4)-P(N+2,5))
44547 PA3S=(P(N+3,4)+P(N+3,5))*(P(N+3,4)-P(N+3,5))
44548 PTS=0.25D0*(2D0*PA1S*PA2S+2D0*PA1S*PA3S+2D0*PA2S*PA3S-
44549 & PA1S**2-PA2S**2-PA3S**2)/PA1S
44550 IF(PTS.LE.0D0) GOTO 330
44551 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
44552 DO 450 I1=N+1,N+2
44553 KFLDA=IABS(K(I1,2))
44554 IF(KFLDA.GT.40) GOTO 450
44555 IF(KSH(KFLDA).EQ.0) GOTO 450
44556 IFLDA=KFLDA
44557 IF(KFLDA.GE.6.AND.KFLDA.LE.8) IFLDA=37+KFLDA+
44558 & ISIGN(2,K(I1,2))
44559 IF(P(I1,5).LT.PMTH(2,IFLDA)) GOTO 450
44560 IF(KFLDA.EQ.21) THEN
44561 KFLGD1=IABS(K(I1,5))
44562 KFLGD2=KFLGD1
44563 ELSE
44564 KFLGD1=KFLDA
44565 KFLGD2=IABS(K(I1,5))
44566 ENDIF
44567 I2=2*N+3-I1
44568 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
44569 PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
44570 ELSE
44571 IF(I1.EQ.N+1) ZM=V(IM,1)
44572 IF(I1.EQ.N+2) ZM=1D0-V(IM,1)
44573 PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
44574 & 4D0*V(N+1,5)*V(N+2,5))
44575 PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/
44576 & V(IM,5)
44577 ENDIF
44578 IF(MOD(MSTJ(43),2).EQ.1) THEN
44579 PMQTH3=0.5D0*PARJ(82)
44580 IF(KFLGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
44581 IF(KFLDA.GE.11.AND.KFLDA.LE.18) PMQTH3=0.5D0*PARJ(90)
44582 IFLGD1=KFLGD1
44583 IF(KFLGD1.GE.6.AND.KFLGD1.LE.8) IFLGD1=IFLDA
44584 PMQ1=(PMTH(1,IFLGD1)**2+PMQTH3**2)/V(I1,5)
44585 PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(I1,5)
44586 ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
44587 & 4D0*PMQ1*PMQ2)))
44588 ZH=1D0+PMQ1-PMQ2
44589 ELSE
44590 ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2))
44591 ZH=1D0
44592 ENDIF
44593 IF(KFLDA.EQ.21.AND.KFLGD1.LT.10.AND.MSTJ(44).EQ.3) THEN
44594 ELSE
44595 ZL=0.5D0*(ZH-ZD)
44596 ZU=0.5D0*(ZH+ZD)
44597 IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
44598 & ISSET(1).EQ.0) THEN
44599 ISL(1)=1
44600 ELSEIF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
44601 & ISSET(2).EQ.0) THEN
44602 ISL(2)=1
44603 ENDIF
44604 ENDIF
44605 IF(KFLDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20,
44606 & ZL*(1D0-ZU)))
44607 IF(KFLDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
44608 450 CONTINUE
44609 IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
44610 ISL(3-ISLM)=0
44611 ISLM=3-ISLM
44612 ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
44613 ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0)
44614 ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0)
44615 IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0
44616 IF(ISL(1).EQ.1) ISL(2)=0
44617 IF(ISL(1).EQ.0) ISLM=1
44618 IF(ISL(2).EQ.0) ISLM=2
44619 ENDIF
44620 IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 330
44621 ENDIF
44622 IFLD1=KFLD(1)
44623 IF(KFLD(1).GE.6.AND.KFLD(1).LE.8) IFLD1=37+KFLD(1)+
44624 &ISIGN(2,K(N+1,2))
44625 IFLD2=KFLD(2)
44626 IF(KFLD(2).GE.6.AND.KFLD(2).LE.8) IFLD2=37+KFLD(2)+
44627 &ISIGN(2,K(N+2,2))
44628 IF(IGM.GT.0) THEN
44629 IF(MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
44630 & PMTH(2,IFLD1).OR.P(N+2,5).GE.PMTH(2,IFLD2))) THEN
44631 PMQ1=V(N+1,5)/V(IM,5)
44632 PMQ2=V(N+2,5)/V(IM,5)
44633 ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2-
44634 & 4D0*PMQ1*PMQ2)))
44635 ZH=1D0+PMQ1-PMQ2
44636 ZL=0.5D0*(ZH-ZD)
44637 ZU=0.5D0*(ZH+ZD)
44638 IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 330
44639 ENDIF
44640 ENDIF
44641
44642C...Accepted branch. Construct four-momentum for initial partons.
44643 460 MAZIP=0
44644 MAZIC=0
44645 IF(NEP.EQ.1) THEN
44646 P(N+1,1)=0D0
44647 P(N+1,2)=0D0
44648 P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
44649 & P(N+1,5))))
44650 P(N+1,4)=P(IPA(1),4)
44651 V(N+1,2)=P(N+1,4)
44652 ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
44653 PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
44654 P(N+1,1)=0D0
44655 P(N+1,2)=0D0
44656 P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
44657 P(N+1,4)=PED1
44658 P(N+2,1)=0D0
44659 P(N+2,2)=0D0
44660 P(N+2,3)=-P(N+1,3)
44661 P(N+2,4)=P(IM,5)-PED1
44662 V(N+1,2)=P(N+1,4)
44663 V(N+2,2)=P(N+2,4)
44664 ELSEIF(NEP.EQ.3) THEN
44665 P(N+1,1)=0D0
44666 P(N+1,2)=0D0
44667 P(N+1,3)=SQRT(MAX(0D0,PA1S))
44668 P(N+2,1)=SQRT(PTS)
44669 P(N+2,2)=0D0
44670 P(N+2,3)=0.5D0*(PA3S-PA2S-PA1S)/P(N+1,3)
44671 P(N+3,1)=-P(N+2,1)
44672 P(N+3,2)=0D0
44673 P(N+3,3)=-(P(N+1,3)+P(N+2,3))
44674 V(N+1,2)=P(N+1,4)
44675 V(N+2,2)=P(N+2,4)
44676 V(N+3,2)=P(N+3,4)
44677
44678C...Construct transverse momentum for ordinary branching in shower.
44679 ELSE
44680 ZM=V(IM,1)
44681 LOOPPT=0
44682 465 LOOPPT=LOOPPT+1
44683 PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5))))
44684 PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5)
44685 IF(PZM.LE.0D0) THEN
44686 PTS=0D0
44687 ELSEIF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
44688 & MSTJ(44).EQ.3) THEN
44689 PTS=PMLS*ZM*(1D0-ZM)/V(IM,5)
44690 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
44691 PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)-
44692 & ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2
44693 ELSE
44694 PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2
44695 ENDIF
44696 IF(PTS.LT.0D0.AND.LOOPPT.LT.10) THEN
44697 ZM=0.05D0+0.9D0*ZM
44698 GOTO 465
44699 ELSEIF(PTS.LT.0D0) THEN
44700 GOTO 265
44701 ENDIF
44702 PT=SQRT(MAX(0D0,PTS))
44703
44704C...Find coefficient of azimuthal asymmetry due to gluon polarization.
44705 HAZIP=0D0
44706 IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21
44707 & .AND.IAU.NE.0) THEN
44708 IF(K(IGM,3).NE.0) MAZIP=1
44709 ZAU=V(IGM,1)
44710 IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1)
44711 IF(MAZIP.EQ.0) ZAU=0D0
44712 IF(K(IGM,2).NE.21) THEN
44713 HAZIP=2D0*ZAU/(1D0+ZAU**2)
44714 ELSE
44715 HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2
44716 ENDIF
44717 IF(K(N+1,2).NE.21) THEN
44718 HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM))
44719 ELSE
44720 HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2
44721 ENDIF
44722 ENDIF
44723
44724C...Find coefficient of azimuthal asymmetry due to soft gluon
44725C...interference.
44726 HAZIC=0D0
44727 IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
44728 & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
44729 IF(K(IGM,3).NE.0) MAZIC=N+1
44730 IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
44731 IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
44732 & ZM.GT.0.5D0) MAZIC=N+2
44733 IF(K(IAU,2).EQ.22) MAZIC=0
44734 ZS=ZM
44735 IF(MAZIC.EQ.N+2) ZS=1D0-ZM
44736 ZGM=V(IGM,1)
44737 IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1)
44738 IF(MAZIC.EQ.0) ZGM=1D0
44739 IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))*
44740 & SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM))
44741 HAZIC=MIN(0.95D0,HAZIC)
44742 ENDIF
44743 ENDIF
44744
44745C...Construct energies for ordinary branching in shower.
44746 470 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
44747 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
44748 & MSTJ(44).EQ.3) THEN
44749 P(N+1,4)=0.5D0*(PEM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
44750 & PZM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
44751 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
44752 P(N+1,4)=PEM*V(IM,1)
44753 ELSE
44754 P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
44755 & SQRT(PMLS)*ZM)/V(IM,5)
44756 ENDIF
44757
44758C...Already predetermined choice of phi angle or not
44759 PHI=PARU(2)*PYR(0)
44760 IF(MPSPD.EQ.1.AND.IGM.EQ.NS+1) THEN
44761 IPSPD=IP1+IM-NS-2
44762 IF(K(IPSPD,4).GT.0) THEN
44763 IPSGD1=K(IPSPD,4)
44764 IF(IM.EQ.NS+2) THEN
44765 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
44766 ELSE
44767 PHI=PYANGL(-P(IPSGD1,1),P(IPSGD1,2))
44768 ENDIF
44769 ENDIF
44770 ELSEIF(MPSPD.EQ.1.AND.IGM.EQ.NS+2) THEN
44771 IPSPD=IP1+IM-NS-2
44772 IF(K(IPSPD,4).GT.0) THEN
44773 IPSGD1=K(IPSPD,4)
44774 PHIPSM=PYANGL(P(IPSPD,1),P(IPSPD,2))
44775 THEPSM=PYANGL(P(IPSPD,3),SQRT(P(IPSPD,1)**2+P(IPSPD,2)**2))
44776 CALL PYROBO(IPSGD1,IPSGD1,0D0,-PHIPSM,0D0,0D0,0D0)
44777 CALL PYROBO(IPSGD1,IPSGD1,-THEPSM,0D0,0D0,0D0,0D0)
44778 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
44779 CALL PYROBO(IPSGD1,IPSGD1,THEPSM,PHIPSM,0D0,0D0,0D0)
44780 ENDIF
44781 ENDIF
44782
44783C...Construct momenta for ordinary branching in shower.
44784 P(N+1,1)=PT*COS(PHI)
44785 P(N+1,2)=PT*SIN(PHI)
44786 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
44787 & MSTJ(44).EQ.3) THEN
44788 P(N+1,3)=0.5D0*(PZM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
44789 & PEM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
44790 ELSEIF(PZM.GT.0D0) THEN
44791 P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+
44792 & 2D0*PEM*P(N+1,4))/PZM
44793 ELSE
44794 P(N+1,3)=0D0
44795 ENDIF
44796 P(N+2,1)=-P(N+1,1)
44797 P(N+2,2)=-P(N+1,2)
44798 P(N+2,3)=PZM-P(N+1,3)
44799 P(N+2,4)=PEM-P(N+1,4)
44800 IF(MSTJ(43).LE.2) THEN
44801 V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
44802 V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
44803 ENDIF
44804 ENDIF
44805
44806C...Rotate and boost daughters.
44807 IF(IGM.GT.0) THEN
44808 IF(MSTJ(43).LE.2) THEN
44809 BEX=P(IGM,1)/P(IGM,4)
44810 BEY=P(IGM,2)/P(IGM,4)
44811 BEZ=P(IGM,3)/P(IGM,4)
44812 GA=P(IGM,4)/P(IGM,5)
44813 GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)-
44814 & P(IM,4))
44815 ELSE
44816 BEX=0D0
44817 BEY=0D0
44818 BEZ=0D0
44819 GA=1D0
44820 GABEP=0D0
44821 ENDIF
44822 PTIMB=SQRT((P(IM,1)+GABEP*BEX)**2+(P(IM,2)+GABEP*BEY)**2)
44823 THE=PYANGL(P(IM,3)+GABEP*BEZ,PTIMB)
44824 IF(PTIMB.GT.1D-4) THEN
44825 PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
44826 ELSE
44827 PHI=0D0
44828 ENDIF
44829 DO 480 I=N+1,N+2
44830 DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
44831 & SIN(THE)*COS(PHI)*P(I,3)
44832 DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
44833 & SIN(THE)*SIN(PHI)*P(I,3)
44834 DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
44835 DP(4)=P(I,4)
44836 DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
44837 DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
44838 P(I,1)=DP(1)+DGABP*BEX
44839 P(I,2)=DP(2)+DGABP*BEY
44840 P(I,3)=DP(3)+DGABP*BEZ
44841 P(I,4)=GA*(DP(4)+DBP)
44842 480 CONTINUE
44843 ENDIF
44844
44845C...Weight with azimuthal distribution, if required.
44846 IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
44847 DO 490 J=1,3
44848 DPT(1,J)=P(IM,J)
44849 DPT(2,J)=P(IAU,J)
44850 DPT(3,J)=P(N+1,J)
44851 490 CONTINUE
44852 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
44853 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
44854 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
44855 DO 500 J=1,3
44856 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
44857 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
44858 500 CONTINUE
44859 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
44860 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
44861 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
44862 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
44863 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
44864 IF(MAZIP.NE.0) THEN
44865 IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP)))
44866 & GOTO 470
44867 ENDIF
44868 IF(MAZIC.NE.0) THEN
44869 IF(MAZIC.EQ.N+2) CAD=-CAD
44870 IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD)
44871 & .LT.PYR(0)) GOTO 470
44872 ENDIF
44873 ENDIF
44874 ENDIF
44875
44876C...Azimuthal anisotropy due to interference with initial state partons.
44877 IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR.
44878 &K(N+2,2).EQ.21)) THEN
44879 III=IM-NS-1
44880 IF(ISII(III).GE.1) THEN
44881 IAZIID=N+1
44882 IF(K(N+1,2).NE.21) IAZIID=N+2
44883 IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
44884 & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2
44885 THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2))
44886 IF(III.EQ.2) THEIID=PARU(1)-THEIID
44887 PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2))
44888 HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III)))
44889 CAD=COS(PHIIID-PHIIIS(III,ISII(III)))
44890 PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III)))
44891 IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL
44892 IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD)
44893 & .LT.PYR(0)) GOTO 470
44894 ENDIF
44895 ENDIF
44896
44897C...Continue loop over partons that may branch, until none left.
44898 IF(IGM.GE.0) K(IM,1)=14
44899 N=N+NEP
44900 NEP=2
44901 IF(N.GT.MSTU(4)-MSTU(32)-5) THEN
44902 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
44903 IF(MSTU(21).GE.1) N=NS
44904 IF(MSTU(21).GE.1) RETURN
44905 ENDIF
44906 GOTO 270
44907
44908C...Set information on imagined shower initiator.
44909 510 IF(NPA.GE.2) THEN
44910 K(NS+1,1)=11
44911 K(NS+1,2)=94
44912 K(NS+1,3)=IP1
44913 IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
44914 K(NS+1,4)=NS+2
44915 K(NS+1,5)=NS+1+NPA
44916 IIM=1
44917 ELSE
44918 IIM=0
44919 ENDIF
44920
44921C...Reconstruct string drawing information.
44922 DO 520 I=NS+1+IIM,N
44923 IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
44924 K(I,1)=1
44925 ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
44926 & IABS(K(I,2)).LE.18) THEN
44927 K(I,1)=1
44928 ELSEIF(K(I,1).LE.10) THEN
44929 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
44930 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
44931 ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
44932 ID1=MOD(K(I,4),MSTU(5))
44933 IF(K(I,2).GE.1.AND.K(I,2).LE.8) ID1=MOD(K(I,4),MSTU(5))+1
44934 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
44935 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
44936 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
44937 K(ID1,4)=K(ID1,4)+MSTU(5)*I
44938 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
44939 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
44940 K(ID2,5)=K(ID2,5)+MSTU(5)*I
44941 ELSE
44942 ID1=MOD(K(I,4),MSTU(5))
44943 ID2=ID1+1
44944 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
44945 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
44946 IF(IABS(K(I,2)).LE.10.OR.K(ID1,1).GE.11) THEN
44947 K(ID1,4)=K(ID1,4)+MSTU(5)*I
44948 K(ID1,5)=K(ID1,5)+MSTU(5)*I
44949 ELSE
44950 K(ID1,4)=0
44951 K(ID1,5)=0
44952 ENDIF
44953 K(ID2,4)=0
44954 K(ID2,5)=0
44955 ENDIF
44956 520 CONTINUE
44957
44958C...Transformation from CM frame.
44959 IF(NPA.GE.2) THEN
44960 BEX=PS(1)/PS(4)
44961 BEY=PS(2)/PS(4)
44962 BEZ=PS(3)/PS(4)
44963 GA=PS(4)/PS(5)
44964 GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
44965 & /(1D0+GA)-P(IPA(1),4))
44966 ELSE
44967 BEX=0D0
44968 BEY=0D0
44969 BEZ=0D0
44970 GABEP=0D0
44971 ENDIF
44972 THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
44973 &+GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
44974 PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
44975 IF(NPA.EQ.3) THEN
44976 CHI=PYANGL(COS(THE)*COS(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(THE)*
44977 & SIN(PHI)*(P(IPA(2),2)+GABEP*BEY)-SIN(THE)*(P(IPA(2),3)+GABEP*
44978 & BEZ),-SIN(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(PHI)*(P(IPA(2),2)+
44979 & GABEP*BEY))
44980 MSTU(33)=1
44981 CALL PYROBO(NS+1,N,0D0,CHI,0D0,0D0,0D0)
44982 ENDIF
44983 MSTU(33)=1
44984 CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ)
44985
44986C...Decay vertex of shower.
44987 DO 540 I=NS+1,N
44988 DO 530 J=1,5
44989 V(I,J)=V(IP1,J)
44990 530 CONTINUE
44991 540 CONTINUE
44992
44993C...Delete trivial shower, else connect initiators.
44994 IF(N.LE.NS+NPA+IIM) THEN
44995 N=NS
44996 ELSE
44997 DO 550 IP=1,NPA
44998 K(IPA(IP),1)=14
44999 K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
45000 K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
45001 K(NS+IIM+IP,3)=IPA(IP)
45002 IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
45003 IF(K(NS+IIM+IP,1).NE.1) THEN
45004 K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
45005 K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
45006 ENDIF
45007 550 CONTINUE
45008 ENDIF
45009
45010 RETURN
45011 END
45012
45013C*********************************************************************
45014
45015C...PYBOEI
45016C...Modifies an event so as to approximately take into account
45017C...Bose-Einstein effects according to a simple phenomenological
45018C...parametrization.
45019
45020 SUBROUTINE PYBOEI(NSAV)
45021
45022C...Double precision and integer declarations.
45023 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45024 IMPLICIT INTEGER(I-N)
45025 INTEGER PYK,PYCHGE,PYCOMP
45026 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
45027C...Commonblocks.
45028 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
45029 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45030 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45031 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
45032C...Local arrays and data.
45033 DIMENSION DPS(4),KFBE(9),NBE(0:10),BEI(100),BEI3(100),
45034 &BEIW(100),BEI3W(100)
45035 DATA KFBE/211,-211,111,321,-321,130,310,221,331/
45036C...Statement function: squared invariant mass.
45037 SDIP(I,J)=((P(I,4)+P(J,4))**2-(P(I,3)+P(J,3))**2-
45038 &(P(I,2)+P(J,2))**2-(P(I,1)+P(J,1))**2)
45039
45040C...Boost event to overall CM frame. Calculate CM energy.
45041 IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
45042 DO 100 J=1,4
45043 DPS(J)=0D0
45044 100 CONTINUE
45045 DO 120 I=1,N
45046 KFA=IABS(K(I,2))
45047 IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22)
45048 & .AND.K(I,3).GT.0) THEN
45049 KFMA=IABS(K(K(I,3),2))
45050 IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
45051 ENDIF
45052 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
45053 DO 110 J=1,4
45054 DPS(J)=DPS(J)+P(I,J)
45055 110 CONTINUE
45056 120 CONTINUE
45057 CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
45058 &-DPS(3)/DPS(4))
45059 PECM=0D0
45060 DO 130 I=1,N
45061 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
45062 130 CONTINUE
45063
45064C...Reserve copy of particles by species at end of record.
45065 IWP=0
45066 IWN=0
45067 NBE(0)=N+MSTU(3)
45068 NMAX=NBE(0)
45069 SMMIN=PECM
45070 DO 180 IBE=1,MIN(10,MSTJ(52)+1)
45071 NBE(IBE)=NBE(IBE-1)
45072 DO 170 I=NSAV+1,N
45073 IF(IBE.EQ.MIN(10,MSTJ(52)+1)) THEN
45074 DO 140 IIBE=1,IBE-1
45075 IF(K(I,2).EQ.KFBE(IIBE)) GOTO 170
45076 140 CONTINUE
45077 ELSE
45078 IF(K(I,2).NE.KFBE(IBE)) GOTO 170
45079 ENDIF
45080 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
45081 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
45082 CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS')
45083 RETURN
45084 ENDIF
45085 NBE(IBE)=NBE(IBE)+1
45086 NMAX=NBE(IBE)
45087 K(NBE(IBE),1)=I
45088 K(NBE(IBE),5)=0
45089 SMMIN=MIN(SMMIN,P(I,5))
45090 IF(MSTJ(53).NE.0.OR.MSTJ(56).GT.0) THEN
45091 IM=I
45092 150 IF(K(IM,3).GT.0) THEN
45093 IM=K(IM,3)
45094 IF(ABS(K(IM,2)).NE.24) GOTO 150
45095 K(NBE(IBE),5)=K(IM,2)
45096 IF(IWP.EQ.0.AND.K(IM,2).EQ.24) IWP=IM
45097 IF(IWN.EQ.0.AND.K(IM,2).EQ.-24) IWN=IM
45098 ENDIF
45099 ENDIF
45100 DO 160 J=1,3
45101 P(NBE(IBE),J)=0D0
45102 V(NBE(IBE),J)=0D0
45103 160 CONTINUE
45104 P(NBE(IBE),5)=-1.0D0
45105 170 CONTINUE
45106 180 CONTINUE
45107 IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 500
45108
45109C...Calculate separation between W+ and W-
45110 SIGW=PARJ(93)
45111 IF(IWP.GT.0.AND.IWN.GT.0.AND.MSTJ(56).GT.0) THEN
45112 DMW=PMAS(24,1)
45113 DGW=PMAS(24,2)
45114 DMP=P(IWP,5)
45115 DMN=P(IWN,5)
45116 TAUPD=DMP/SQRT((DMP**2-DMW**2)**2+(DGW*(DMP**2)/DMW)**2)
45117 TAUND=DMN/SQRT((DMN**2-DMW**2)**2+(DGW*(DMN**2)/DMW)**2)
45118 TAUP=-TAUPD*LOG(PYR(IDUM))
45119 TAUN=-TAUND*LOG(PYR(IDUM))
45120 DXP=TAUP*PYP(IWP,8)/DMP
45121 DXN=TAUN*PYP(IWN,8)/DMN
45122 DX=DXP+DXN
45123 SIGW=1.0D0/(1.0D0/PARJ(93)+REAL(MSTJ(56))*DX)
45124 ELSE
45125 SIGW=PARJ(93)
45126 ENDIF
45127
45128 IF(MSTJ(57).EQ.1.AND.MSTJ(54).LT.0) THEN
45129 DO 210 IBE=1,MIN(9,MSTJ(52))
45130 DO 200 I1M=NBE(IBE-1)+1,NBE(IBE)-1
45131 Q2MIN=PECM**2
45132 I1=K(I1M,1)
45133 DO 190 I2M=NBE(IBE-1)+1,NBE(IBE)-1
45134 IF(I2M.EQ.I1M) GOTO 190
45135 I2=K(I2M,1)
45136 Q2=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-
45137 & (P(I1,2)+P(I2,2))**2-(P(I1,3)+P(I2,3))**2-
45138 & (P(I1,5)+P(I2,5))**2
45139 IF(Q2.GT.0.0D0.AND.Q2.LT.Q2MIN) THEN
45140 Q2MIN=Q2
45141 ENDIF
45142 190 CONTINUE
45143 P(I1M,5)=Q2MIN
45144 200 CONTINUE
45145 210 CONTINUE
45146 ENDIF
45147
45148C...Tabulate integral for subsequent momentum shift.
45149 DO 390 IBE=1,MIN(9,MSTJ(52))
45150 IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 260
45151 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
45152 & .LE.1) GOTO 260
45153 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
45154 & NBE(7)-NBE(6)).LE.1) GOTO 260
45155 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 260
45156 IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211)
45157 IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321)
45158 IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221)
45159 IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331)
45160 QDEL=0.1D0*MIN(PMHQ,PARJ(93))
45161 QDEL3=0.1D0*MIN(PMHQ,PARJ(93)*3.0D0)
45162 QDELW=0.1D0*MIN(PMHQ,SIGW)
45163 QDEL3W=0.1D0*MIN(PMHQ,SIGW*3.0D0)
45164 IF(MSTJ(51).EQ.1) THEN
45165 NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL))
45166 NBIN3=MIN(100,NINT(27D0*PARJ(93)/QDEL3))
45167 NBINW=MIN(100,NINT(9D0*SIGW/QDELW))
45168 NBIN3W=MIN(100,NINT(27D0*SIGW/QDEL3W))
45169 BEEX=EXP(0.5D0*QDEL/PARJ(93))
45170 BEEX3=EXP(0.5D0*QDEL3/(3.0D0*PARJ(93)))
45171 BEEXW=EXP(0.5D0*QDELW/SIGW)
45172 BEEX3W=EXP(0.5D0*QDEL3W/(3.0D0*SIGW))
45173 BERT=EXP(-QDEL/PARJ(93))
45174 BERT3=EXP(-QDEL3/(3.0D0*PARJ(93)))
45175 BERTW=EXP(-QDELW/SIGW)
45176 BERT3W=EXP(-QDEL3W/(3.0D0*SIGW))
45177 ELSE
45178 NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL))
45179 NBIN3=MIN(100,NINT(9D0*PARJ(93)/QDEL3))
45180 NBINW=MIN(100,NINT(3D0*SIGW/QDELW))
45181 NBIN3W=MIN(100,NINT(9D0*SIGW/QDEL3W))
45182 ENDIF
45183 DO 220 IBIN=1,NBIN
45184 QBIN=QDEL*(IBIN-0.5D0)
45185 BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2)
45186 IF(MSTJ(51).EQ.1) THEN
45187 BEEX=BEEX*BERT
45188 BEI(IBIN)=BEI(IBIN)*BEEX
45189 ELSE
45190 BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
45191 ENDIF
45192 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
45193 220 CONTINUE
45194 DO 230 IBIN=1,NBIN3
45195 QBIN=QDEL3*(IBIN-0.5D0)
45196 BEI3(IBIN)=QDEL3*(QBIN**2+QDEL3**2/12D0)/SQRT(QBIN**2+PMHQ**2)
45197 IF(MSTJ(51).EQ.1) THEN
45198 BEEX3=BEEX3*BERT3
45199 BEI3(IBIN)=BEI3(IBIN)*BEEX3
45200 ELSE
45201 BEI3(IBIN)=BEI3(IBIN)*EXP(-(QBIN/(3.0D0*PARJ(93)))**2)
45202 ENDIF
45203 IF(IBIN.GE.2) BEI3(IBIN)=BEI3(IBIN)+BEI3(IBIN-1)
45204 230 CONTINUE
45205 DO 240 IBIN=1,NBINW
45206 QBIN=QDELW*(IBIN-0.5D0)
45207 BEIW(IBIN)=QDELW*(QBIN**2+QDELW**2/12D0)/SQRT(QBIN**2+PMHQ**2)
45208 IF(MSTJ(51).EQ.1) THEN
45209 BEEXW=BEEXW*BERTW
45210 BEIW(IBIN)=BEIW(IBIN)*BEEXW
45211 ELSE
45212 BEIW(IBIN)=BEIW(IBIN)*EXP(-(QBIN/SIGW)**2)
45213 ENDIF
45214 IF(IBIN.GE.2) BEIW(IBIN)=BEIW(IBIN)+BEIW(IBIN-1)
45215 240 CONTINUE
45216 DO 250 IBIN=1,NBIN3W
45217 QBIN=QDEL3W*(IBIN-0.5D0)
45218 BEI3W(IBIN)=QDEL3W*(QBIN**2+QDEL3W**2/12D0)/
45219 & SQRT(QBIN**2+PMHQ**2)
45220 IF(MSTJ(51).EQ.1) THEN
45221 BEEX3W=BEEX3W*BERT3W
45222 BEI3W(IBIN)=BEI3W(IBIN)*BEEX3W
45223 ELSE
45224 BEI3W(IBIN)=BEI3W(IBIN)*EXP(-(QBIN/(3.0D0*SIGW))**2)
45225 ENDIF
45226 IF(IBIN.GE.2) BEI3W(IBIN)=BEI3W(IBIN)+BEI3W(IBIN-1)
45227 250 CONTINUE
45228
45229C...Loop through particle pairs and find old relative momentum.
45230 260 DO 380 I1M=NBE(IBE-1)+1,NBE(IBE)-1
45231 I1=K(I1M,1)
45232 DO 370 I2M=I1M+1,NBE(IBE)
45233 IF(MSTJ(53).EQ.1.AND.K(I1M,5).NE.K(I2M,5)) GOTO 370
45234 IF(MSTJ(53).EQ.2.AND.K(I1M,5).EQ.K(I2M,5)) GOTO 370
45235 I2=K(I2M,1)
45236 Q2OLD=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
45237 & P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2
45238 IF(Q2OLD.LE.0.0D0) GOTO 370
45239 QOLD=SQRT(Q2OLD)
45240
45241C...Calculate new relative momentum.
45242 QMOV=0.0D0
45243 QMOV3=0.0D0
45244 QMOVW=0.0D0
45245 QMOV3W=0.0D0
45246 IF(QOLD.LT.1D-3*QDEL) THEN
45247 GOTO 270
45248 ELSEIF(QOLD.LE.QDEL) THEN
45249 QMOV=QOLD/3D0
45250 ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN
45251 RBIN=QOLD/QDEL
45252 IBIN=RBIN
45253 RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
45254 QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
45255 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
45256 ELSE
45257 QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
45258 ENDIF
45259 270 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0)
45260 IF(QOLD.LT.1D-3*QDEL3) THEN
45261 GOTO 280
45262 ELSEIF(QOLD.LE.QDEL3) THEN
45263 QMOV3=QOLD/3D0
45264 ELSEIF(QOLD.LT.(NBIN3-0.1D0)*QDEL3) THEN
45265 RBIN3=QOLD/QDEL3
45266 IBIN3=RBIN3
45267 RINP3=(RBIN3**3-IBIN3**3)/(3*IBIN3*(IBIN3+1)+1)
45268 QMOV3=(BEI3(IBIN3)+RINP3*(BEI3(IBIN3+1)-BEI3(IBIN3)))*
45269 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
45270 ELSE
45271 QMOV3=BEI3(NBIN3)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
45272 ENDIF
45273 280 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3))**(2D0/3D0)
45274 RSCALE=1.0D0
45275 IF(MSTJ(54).EQ.2)
45276 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*PARJ(93)))**2)
45277 IF(MSTJ(56).LE.0.OR.IWP.EQ.0.OR.IWN.EQ.0.OR.
45278 & K(I1M,5).EQ.K(I2M,5)) GOTO 310
45279
45280 IF(QOLD.LT.1D-3*QDELW) THEN
45281 GOTO 290
45282 ELSEIF(QOLD.LE.QDELW) THEN
45283 QMOVW=QOLD/3D0
45284 ELSEIF(QOLD.LT.(NBINW-0.1D0)*QDELW) THEN
45285 RBINW=QOLD/QDELW
45286 IBINW=RBINW
45287 RINPW=(RBINW**3-IBINW**3)/(3*IBINW*(IBINW+1)+1)
45288 QMOVW=(BEIW(IBINW)+RINPW*(BEIW(IBINW+1)-BEIW(IBINW)))*
45289 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
45290 ELSE
45291 QMOVW=BEIW(NBINW)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
45292 ENDIF
45293 290 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOVW))**(2D0/3D0)
45294 IF(QOLD.LT.1D-3*QDEL3W) THEN
45295 GOTO 300
45296 ELSEIF(QOLD.LE.QDEL3W) THEN
45297 QMOV3W=QOLD/3D0
45298 ELSEIF(QOLD.LT.(NBIN3W-0.1D0)*QDEL3W) THEN
45299 RBIN3W=QOLD/QDEL3W
45300 IBIN3W=RBIN3W
45301 RINP3W=(RBIN3W**3-IBIN3W**3)/(3*IBIN3W*(IBIN3W+1)+1)
45302 QMOV3W=(BEI3W(IBIN3W)+RINP3W*(BEI3W(IBIN3W+1)-
45303 & BEI3W(IBIN3W)))*SQRT(Q2OLD+PMHQ**2)/Q2OLD
45304 ELSE
45305 QMOV3W=BEI3W(NBIN3W)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
45306 ENDIF
45307 300 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3W))**(2D0/3D0)
45308 IF(MSTJ(54).EQ.2)
45309 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*SIGW))**2)
45310
45311 310 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW)
45312 DO 320 J=1,3
45313 P(I1M,J)=P(I1M,J)+P(NMAX+1,J)
45314 P(I2M,J)=P(I2M,J)+P(NMAX+2,J)
45315 320 CONTINUE
45316 IF(MSTJ(54).GE.1) THEN
45317 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW3)
45318 DO 330 J=1,3
45319 V(I1M,J)=V(I1M,J)+P(NMAX+1,J)*RSCALE
45320 V(I2M,J)=V(I2M,J)+P(NMAX+2,J)*RSCALE
45321 330 CONTINUE
45322 ELSEIF(MSTJ(54).LE.-1) THEN
45323 EDEL=P(I1,4)+P(I2,4)-
45324 & SQRT(MAX(Q2NEW-Q2OLD+(P(I1,4)+P(I2,4))**2,0.0D0))
45325 A2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
45326 & (P(I1,3)-P(I2,3))**2
45327 WMAX=-1.0D20
45328 MI3=0
45329 MI4=0
45330 S12=SDIP(I1,I2)
45331 SM1=(P(I1,5)+SMMIN)**2
45332 DO 350 I3M=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
45333 IF(I3M.EQ.I1M.OR.I3M.EQ.I2M) GOTO 350
45334 IF(MSTJ(53).EQ.1.AND.K(I3M,5).NE.K(I1M,5)) GOTO 350
45335 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
45336 & K(I3M,5).NE.K(I1M,5)) GOTO 350
45337 I3=K(I3M,1)
45338 IF(K(I3,2).EQ.K(I1,2)) GOTO 350
45339 S13=SDIP(I1,I3)
45340 S23=SDIP(I2,I3)
45341 SM3=(P(I3,5)+SMMIN)**2
45342 IF(MSTJ(54).EQ.-2) THEN
45343 WI=(MIN(S12*SM3,S13*MIN(SM1,SM3),
45344 & S23*MIN(SM1,SM3))*SM1)
45345 ELSE
45346 WI=((P(I1,4)+P(I2,4)+P(I3,4))**2-
45347 & (P(I1,3)+P(I2,3)+P(I3,3))**2-
45348 & (P(I1,2)+P(I2,2)+P(I3,2))**2-
45349 & (P(I1,1)+P(I2,1)+P(I3,1))**2)
45350 ENDIF
45351 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0) THEN
45352 IF (WMAX*WI.GE.(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2))))
45353 & GOTO 350
45354 ELSE
45355 IF(WMAX*WI.GE.1.0) GOTO 350
45356 ENDIF
45357 DO 340 I4M=I3M+1,NBE(MIN(10,MSTJ(52)+1))
45358 IF(I4M.EQ.I1M.OR.I4M.EQ.I2M) GOTO 340
45359 IF(MSTJ(53).EQ.1.AND.K(I4M,5).NE.K(I1M,5)) GOTO 340
45360 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
45361 & K(I4M,5).NE.K(I1M,5)) GOTO 340
45362 I4=K(I4M,1)
45363 IF(K(I3,2).EQ.K(I4,2).OR.K(I4,2).EQ.K(I1,2))
45364 & GOTO 340
45365 IF((P(I3,4)+P(I4,4)+EDEL)**2.LT.
45366 & (P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
45367 & (P(I3,3)+P(I4,3))**2+(P(I3,5)+P(I4,5))**2)
45368 & GOTO 340
45369 IF(MSTJ(54).EQ.-2) THEN
45370 S14=SDIP(I1,I4)
45371 S24=SDIP(I2,I4)
45372 S34=SDIP(I3,I4)
45373 W=S12*MIN(MIN(S23,S24),MIN(S13,S14))*S34
45374 W=MIN(W,S13*MIN(MIN(S23,S34),S12)*S24)
45375 W=MIN(W,S14*MIN(MIN(S24,S34),S12)*S23)
45376 W=MIN(W,MIN(S23,S24)*S13*S14)
45377 W=1.0D0/W
45378 ELSE
45379C...weight=1-cos(theta)/mtot2
45380 S1234=(P(I1,4)+P(I2,4)+P(I3,4)+P(I4,4))**2-
45381 & (P(I1,3)+P(I2,3)+P(I3,3)+P(I4,3))**2-
45382 & (P(I1,2)+P(I2,2)+P(I3,2)+P(I4,2))**2-
45383 & (P(I1,1)+P(I2,1)+P(I3,1)+P(I4,1))**2
45384 W=1.0D0/S1234
45385 IF(W.LE.WMAX) GOTO 340
45386 ENDIF
45387 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0)
45388 & W=W*(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2)))
45389 IF(MSTJ(57).EQ.1.AND.P(I4M,5).GT.0)
45390 & W=W*(1.0D0-EXP(-P(I4M,5)/(PARJ(93)**2)))
45391 IF(W.LE.WMAX) GOTO 340
45392 MI3=I3M
45393 MI4=I4M
45394 WMAX=W
45395 340 CONTINUE
45396 350 CONTINUE
45397 IF(MI4.EQ.0) GOTO 370
45398 I3=K(MI3,1)
45399 I4=K(MI4,1)
45400 EOLD=P(I3,4)+P(I4,4)
45401 ENEW=EOLD+EDEL
45402 P2=(P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
45403 & (P(I3,3)+P(I4,3))**2
45404 Q2NEWP=MAX(0.0D0,ENEW**2-P2-(P(I3,5)+P(I4,5))**2)
45405 Q2OLDP=MAX(0.0D0,EOLD**2-P2-(P(I3,5)+P(I4,5))**2)
45406 CALL PYBESQ(I3,I4,NMAX,Q2OLDP,Q2NEWP)
45407 DO 360 J=1,3
45408 V(MI3,J)=V(MI3,J)+P(NMAX+1,J)
45409 V(MI4,J)=V(MI4,J)+P(NMAX+2,J)
45410 360 CONTINUE
45411 ENDIF
45412 370 CONTINUE
45413 380 CONTINUE
45414 390 CONTINUE
45415
45416C...Shift momenta and recalculate energies.
45417 ESUMP=0.0D0
45418 ESUM=0.0D0
45419 PROD=0.0D0
45420 DO 420 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
45421 I=K(IM,1)
45422 ESUMP=ESUMP+P(I,4)
45423 DO 400 J=1,3
45424 P(I,J)=P(I,J)+P(IM,J)
45425 400 CONTINUE
45426 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
45427 ESUM=ESUM+P(I,4)
45428 DO 410 J=1,3
45429 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
45430 410 CONTINUE
45431 420 CONTINUE
45432
45433 PARJ(96)=0.0D0
45434 IF(MSTJ(54).NE.0.AND.PROD.NE.0.0D0) THEN
45435 430 ALPHA=(ESUMP-ESUM)/PROD
45436 PARJ(96)=PARJ(96)+ALPHA
45437 PROD=0.0D0
45438 ESUM=0.0D0
45439 DO 460 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
45440 I=K(IM,1)
45441 DO 440 J=1,3
45442 P(I,J)=P(I,J)+ALPHA*V(IM,J)
45443 440 CONTINUE
45444 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
45445 ESUM=ESUM+P(I,4)
45446 DO 450 J=1,3
45447 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
45448 450 CONTINUE
45449 460 CONTINUE
45450 IF(PROD.NE.0.0D0.AND.ABS(ESUMP-ESUM)/PECM.GT.0.00001D0)
45451 & GOTO 430
45452 ENDIF
45453
45454C...Rescale all momenta for energy conservation.
45455 PES=0D0
45456 PQS=0D0
45457 DO 470 I=1,N
45458 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 470
45459 PES=PES+P(I,4)
45460 PQS=PQS+P(I,5)**2/P(I,4)
45461 470 CONTINUE
45462 PARJ(95)=PES-PECM
45463 FAC=(PECM-PQS)/(PES-PQS)
45464 DO 490 I=1,N
45465 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 490
45466 DO 480 J=1,3
45467 P(I,J)=FAC*P(I,J)
45468 480 CONTINUE
45469 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
45470 490 CONTINUE
45471
45472C...Boost back to correct reference frame.
45473 500 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
45474 DO 510 I=1,N
45475 IF(K(I,1).LT.0) K(I,1)=-K(I,1)
45476 510 CONTINUE
45477
45478 RETURN
45479 END
45480
45481C*********************************************************************
45482
45483C...PYBESQ
45484C...Calculates the momentum shift in a system of two particles assuming
45485C...the relative momentum squared should be shifted to Q2NEW. NI is the
45486C...last position occupied in /PYJETS/.
45487
45488 SUBROUTINE PYBESQ(I1,I2,NI,Q2OLD,Q2NEW)
45489
45490C...Double precision and integer declarations.
45491 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45492 IMPLICIT INTEGER(I-N)
45493 INTEGER PYK,PYCHGE,PYCOMP
45494 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
45495C...Commonblocks.
45496 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
45497 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45498 SAVE /PYJETS/,/PYDAT1/
45499C...Local arrays and data.
45500 DIMENSION DP(5)
45501 SAVE HC1
45502
45503 IF(MSTJ(55).EQ.0) THEN
45504 DQ2=Q2NEW-Q2OLD
45505 DP2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
45506 & (P(I1,3)-P(I2,3))**2
45507 DP12=P(I1,1)**2+P(I1,2)**2+P(I1,3)**2
45508 & -P(I2,1)**2-P(I2,2)**2-P(I2,3)**2
45509 SE=P(I1,4)+P(I2,4)
45510 DE=P(I1,4)-P(I2,4)
45511 DQ2SE=DQ2+SE**2
45512 DA=SE*DE*DP12-DP2*DQ2SE
45513 DB=DP2*DQ2SE-DP12**2
45514 HA=(DA+SQRT(MAX(DA**2+DQ2*(DQ2+SE**2-DE**2)*DB,0D0)))/(2D0*DB)
45515 DO 100 J=1,3
45516 PD=HA*(P(I1,J)-P(I2,J))
45517 P(NI+1,J)=PD
45518 P(NI+2,J)=-PD
45519 100 CONTINUE
45520 RETURN
45521 ENDIF
45522
45523 K(NI+1,1)=1
45524 K(NI+2,1)=1
45525 DO 110 J=1,5
45526 P(NI+1,J)=P(I1,J)
45527 P(NI+2,J)=P(I2,J)
45528 DP(J)=P(I1,J)+P(I2,J)
45529 110 CONTINUE
45530
45531C...Boost to cms and rotate first particle to z-axis
45532 CALL PYROBO(NI+1,NI+2,0.0D0,0.0D0,
45533 &-DP(1)/DP(4),-DP(2)/DP(4),-DP(3)/DP(4))
45534 PHI=PYANGL(P(NI+1,1),P(NI+1,2))
45535 THE=PYANGL(P(NI+1,3),SQRT(P(NI+1,1)**2+P(NI+1,2)**2))
45536 S=Q2NEW+(P(I1,5)+P(I2,5))**2
45537 PZ=0.5D0*SQRT(Q2NEW*(S-(P(I1,5)-P(I2,5))**2)/S)
45538 P(NI+1,1)=0.0D0
45539 P(NI+1,2)=0.0D0
45540 P(NI+1,3)=PZ
45541 P(NI+1,4)=SQRT(PZ**2+P(I1,5)**2)
45542 P(NI+2,1)=0.0D0
45543 P(NI+2,2)=0.0D0
45544 P(NI+2,3)=-PZ
45545 P(NI+2,4)=SQRT(PZ**2+P(I2,5)**2)
45546 DP(4)=SQRT(DP(1)**2+DP(2)**2+DP(3)**2+S)
45547 CALL PYROBO(NI+1,NI+2,THE,PHI,
45548 &DP(1)/DP(4),DP(2)/DP(4),DP(3)/DP(4))
45549
45550 DO 120 J=1,3
45551 P(NI+1,J)=P(NI+1,J)-P(I1,J)
45552 P(NI+2,J)=P(NI+2,J)-P(I2,J)
45553 120 CONTINUE
45554
45555 RETURN
45556 END
45557
45558C*********************************************************************
45559
45560C...PYMASS
45561C...Gives the mass of a particle/parton.
45562
45563 FUNCTION PYMASS(KF)
45564
45565C...Double precision and integer declarations.
45566 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45567 IMPLICIT INTEGER(I-N)
45568 INTEGER PYK,PYCHGE,PYCOMP
45569C...Commonblocks.
45570 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45571 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45572 SAVE /PYDAT1/,/PYDAT2/
45573
45574C...Reset variables. Compressed code. Special case for popcorn diquarks.
45575 PYMASS=0D0
45576 KFA=IABS(KF)
45577 KC=PYCOMP(KF)
45578 IF(KC.EQ.0) THEN
45579 MSTJ(93)=0
45580 RETURN
45581 ENDIF
45582
45583C...Guarantee use of constituent masses for internal checks.
45584 IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.
45585 &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN
45586 PARF(106)=PMAS(6,1)
45587 PARF(107)=PMAS(7,1)
45588 PARF(108)=PMAS(8,1)
45589 IF(KFA.LE.10) THEN
45590 PYMASS=PARF(100+KFA)
45591 IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121))
45592 ELSEIF(MSTJ(93).EQ.1) THEN
45593 PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10))
45594 ELSE
45595 PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0)
45596 ENDIF
45597
45598C...Other masses can be read directly off table.
45599 ELSE
45600 PYMASS=PMAS(KC,1)
45601 ENDIF
45602
45603C...Optional mass broadening according to truncated Breit-Wigner
45604C...(either in m or in m^2).
45605 IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN
45606 IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
45607 PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)*
45608 & ATAN(2D0*PMAS(KC,3)/PMAS(KC,2)))
45609 ELSE
45610 PM0=PYMASS
45611 PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/
45612 & (PM0*PMAS(KC,2)))
45613 PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
45614 PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
45615 & (PMUPP-PMLOW)*PYR(0))))
45616 ENDIF
45617 ENDIF
45618 MSTJ(93)=0
45619
45620 RETURN
45621 END
45622
45623C*********************************************************************
45624
45625C...PYMRUN
45626C...Gives the running, current-algebra mass of a d, u, s, c or b quark,
45627C...for Higgs couplings. Everything else sent on to PYMASS.
45628
45629 FUNCTION PYMRUN(KF,Q2)
45630
45631C...Double precision and integer declarations.
45632 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45633 IMPLICIT INTEGER(I-N)
45634 INTEGER PYK,PYCHGE,PYCOMP
45635C...Commonblocks.
45636 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45637 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45638 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
45639 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/
45640
45641C...Most masses not handled here.
45642 KFA=IABS(KF)
45643 IF(KFA.EQ.0.OR.KFA.GT.5) THEN
45644 PYMRUN=PYMASS(KF)
45645
45646C...Current-algebra masses, but no Q2 dependence.
45647 ELSEIF(MSTP(37).NE.1.OR.MSTP(2).LE.0) THEN
45648 PYMRUN=PARF(90+KFA)
45649
45650C...Running current-algebra masses.
45651 ELSE
45652 AS=PYALPS(Q2)
45653 PYMRUN=PARF(90+KFA)*
45654 & (LOG(MAX(4D0,PARP(37)**2*PARF(90+KFA)**2/PARU(117)**2))/
45655 & LOG(MAX(4D0,Q2/PARU(117)**2)))**(12D0/(33D0-2D0*MSTU(118)))
45656 ENDIF
45657
45658 RETURN
45659 END
45660
45661C*********************************************************************
45662
45663C...PYNAME
45664C...Gives the particle/parton name as a character string.
45665
45666 SUBROUTINE PYNAME(KF,CHAU)
45667
45668C...Double precision and integer declarations.
45669 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45670 IMPLICIT INTEGER(I-N)
45671 INTEGER PYK,PYCHGE,PYCOMP
45672C...Commonblocks.
45673 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45674 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45675 COMMON/PYDAT4/CHAF(500,2)
45676 CHARACTER CHAF*16
45677 SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/
45678C...Local character variable.
45679 CHARACTER CHAU*16
45680
45681C...Read out code with distinction particle/antiparticle.
45682 CHAU=' '
45683 KC=PYCOMP(KF)
45684 IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2)
45685
45686
45687 RETURN
45688 END
45689
45690C*********************************************************************
45691
45692C...PYCHGE
45693C...Gives three times the charge for a particle/parton.
45694
45695 FUNCTION PYCHGE(KF)
45696
45697C...Double precision and integer declarations.
45698 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45699 IMPLICIT INTEGER(I-N)
45700 INTEGER PYK,PYCHGE,PYCOMP
45701C...Commonblocks.
45702 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45703 SAVE /PYDAT2/
45704
45705C...Read out charge and change sign for antiparticle.
45706 PYCHGE=0
45707 KC=PYCOMP(KF)
45708 IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF)
45709
45710 RETURN
45711 END
45712
45713C*********************************************************************
45714
45715C...PYCOMP
45716C...Compress the standard KF codes for use in mass and decay arrays;
45717C...also checks whether a given code actually is defined.
45718
45719 FUNCTION PYCOMP(KF)
45720
45721C...Double precision and integer declarations.
45722 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45723 IMPLICIT INTEGER(I-N)
45724 INTEGER PYK,PYCHGE,PYCOMP
45725C...Commonblocks.
45726 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45727 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45728 SAVE /PYDAT1/,/PYDAT2/
45729C...Local arrays and saved data.
45730 DIMENSION KFORD(100:500),KCORD(101:500)
45731 SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST
45732
45733C...Whenever necessary reorder codes for faster search.
45734 IF(MSTU(20).EQ.0) THEN
45735 NFORD=100
45736 KFORD(100)=0
45737 DO 120 I=101,500
45738 KFA=KCHG(I,4)
45739 IF(KFA.LE.100) GOTO 120
45740 NFORD=NFORD+1
45741 DO 100 I1=NFORD-1,0,-1
45742 IF(KFA.GE.KFORD(I1)) GOTO 110
45743 KFORD(I1+1)=KFORD(I1)
45744 KCORD(I1+1)=KCORD(I1)
45745 100 CONTINUE
45746 110 KFORD(I1+1)=KFA
45747 KCORD(I1+1)=I
45748 120 CONTINUE
45749 MSTU(20)=1
45750 KFLAST=0
45751 KCLAST=0
45752 ENDIF
45753
45754C...Fast action if same code as in latest call.
45755 IF(KF.EQ.KFLAST) THEN
45756 PYCOMP=KCLAST
45757 RETURN
45758 ENDIF
45759
45760C...Starting values. Remove internal diquark flags.
45761 PYCOMP=0
45762 KFA=IABS(KF)
45763 IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000
45764 & .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000)
45765
45766C...Simple cases: direct translation.
45767 IF(KFA.GT.KFORD(NFORD)) THEN
45768 ELSEIF(KFA.LE.100) THEN
45769 PYCOMP=KFA
45770
45771C...Else binary search.
45772 ELSE
45773 IMIN=100
45774 IMAX=NFORD+1
45775 130 IAVG=(IMIN+IMAX)/2
45776 IF(KFORD(IAVG).GT.KFA) THEN
45777 IMAX=IAVG
45778 IF(IMAX.GT.IMIN+1) GOTO 130
45779 ELSEIF(KFORD(IAVG).LT.KFA) THEN
45780 IMIN=IAVG
45781 IF(IMAX.GT.IMIN+1) GOTO 130
45782 ELSE
45783 PYCOMP=KCORD(IAVG)
45784 ENDIF
45785 ENDIF
45786
45787C...Check if antiparticle allowed.
45788 IF(PYCOMP.NE.0.AND.KF.LT.0) THEN
45789 IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0
45790 ENDIF
45791
45792C...Save codes for possible future fast action.
45793 KFLAST=KF
45794 KCLAST=PYCOMP
45795
45796 RETURN
45797 END
45798
45799C*********************************************************************
45800
45801C...PYERRM
45802C...Informs user of errors in program execution.
45803
45804 SUBROUTINE PYERRM(MERR,CHMESS)
45805
45806C...Double precision and integer declarations.
45807 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45808 IMPLICIT INTEGER(I-N)
45809 INTEGER PYK,PYCHGE,PYCOMP
45810C...Commonblocks.
45811 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
45812 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45813 SAVE /PYJETS/,/PYDAT1/
45814C...Local character variable.
45815 CHARACTER CHMESS*(*)
45816
45817C...Write first few warnings, then be silent.
45818 IF(MERR.LE.10) THEN
45819 MSTU(27)=MSTU(27)+1
45820 MSTU(28)=MERR
45821 IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
45822 & MERR,MSTU(31),CHMESS
45823
45824C...Write first few errors, then be silent or stop program.
45825 ELSEIF(MERR.LE.20) THEN
45826 MSTU(23)=MSTU(23)+1
45827 MSTU(24)=MERR-10
45828 IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
45829 & MERR-10,MSTU(31),CHMESS
45830 IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
45831 WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
45832 WRITE(MSTU(11),5200)
45833 IF(MERR.NE.17) CALL PYLIST(2)
45834 STOP
45835 ENDIF
45836
45837C...Stop program in case of irreparable error.
45838 ELSE
45839 WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
45840 STOP
45841 ENDIF
45842
45843C...Formats for output.
45844 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9,
45845 &' PYEXEC calls:'/5X,A)
45846 5100 FORMAT(/5X,'Error type',I2,' has occured after',I9,
45847 &' PYEXEC calls:'/5X,A)
45848 5200 FORMAT(5X,'Execution will be stopped after listing of last ',
45849 &'event!')
45850 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9,
45851 &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
45852
45853 RETURN
45854 END
45855
45856C*********************************************************************
45857
45858C...PYALEM
45859C...Calculates the running alpha_electromagnetic.
45860
45861 FUNCTION PYALEM(Q2)
45862
45863C...Double precision and integer declarations.
45864 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45865 IMPLICIT INTEGER(I-N)
45866 INTEGER PYK,PYCHGE,PYCOMP
45867C...Commonblocks.
45868 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45869 SAVE /PYDAT1/
45870
45871C...Calculate real part of photon vacuum polarization.
45872C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
45873C...For hadrons use parametrization of H. Burkhardt et al.
45874C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
45875 AEMPI=PARU(101)/(3D0*PARU(1))
45876 IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
45877 RPIGG=0D0
45878 ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
45879 RPIGG=0D0
45880 ELSEIF(MSTU(101).EQ.2) THEN
45881 RPIGG=1D0-PARU(101)/PARU(103)
45882 ELSEIF(Q2.LT.0.09D0) THEN
45883 RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2)
45884 ELSEIF(Q2.LT.9D0) THEN
45885 RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+
45886 & 0.00238D0*LOG(1D0+3.927D0*Q2)
45887 ELSEIF(Q2.LT.1D4) THEN
45888 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+
45889 & 0.00299D0*LOG(1D0+Q2)
45890 ELSE
45891 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+
45892 & 0.00293D0*LOG(1D0+Q2)
45893 ENDIF
45894
45895C...Calculate running alpha_em.
45896 PYALEM=PARU(101)/(1D0-RPIGG)
45897 PARU(108)=PYALEM
45898
45899 RETURN
45900 END
45901
45902C*********************************************************************
45903
45904C...PYALPS
45905C...Gives the value of alpha_strong.
45906
45907 FUNCTION PYALPS(Q2)
45908
45909C...Double precision and integer declarations.
45910 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45911 IMPLICIT INTEGER(I-N)
45912 INTEGER PYK,PYCHGE,PYCOMP
45913C...Commonblocks.
45914 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45915 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45916 SAVE /PYDAT1/,/PYDAT2/
45917
45918C...Constant alpha_strong trivial. Pick artificial Lambda.
45919 IF(MSTU(111).LE.0) THEN
45920 PYALPS=PARU(111)
45921 MSTU(118)=MSTU(112)
45922 PARU(117)=0.2D0
45923 IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/
45924 & ((33D0-2D0*MSTU(112))*PARU(111)))
45925 PARU(118)=PARU(111)
45926 RETURN
45927 ENDIF
45928
45929C...Find effective Q2, number of flavours and Lambda.
45930 Q2EFF=Q2
45931 IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
45932 NF=MSTU(112)
45933 ALAM2=PARU(112)**2
45934 100 IF(NF.GT.MAX(2,MSTU(113))) THEN
45935 Q2THR=PARU(113)*PMAS(NF,1)**2
45936 IF(Q2EFF.LT.Q2THR) THEN
45937 NF=NF-1
45938 ALAM2=ALAM2*(Q2THR/ALAM2)**(2D0/(33D0-2D0*NF))
45939 GOTO 100
45940 ENDIF
45941 ENDIF
45942 110 IF(NF.LT.MIN(8,MSTU(114))) THEN
45943 Q2THR=PARU(113)*PMAS(NF+1,1)**2
45944 IF(Q2EFF.GT.Q2THR) THEN
45945 NF=NF+1
45946 ALAM2=ALAM2*(ALAM2/Q2THR)**(2D0/(33D0-2D0*NF))
45947 GOTO 110
45948 ENDIF
45949 ENDIF
45950 IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
45951 PARU(117)=SQRT(ALAM2)
45952
45953C...Evaluate first or second order alpha_strong.
45954 B0=(33D0-2D0*NF)/6D0
45955 ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2))
45956 IF(MSTU(111).EQ.1) THEN
45957 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
45958 ELSE
45959 B1=(153D0-19D0*NF)/6D0
45960 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/
45961 & (B0**2*ALGQ)))
45962 ENDIF
45963 MSTU(118)=NF
45964 PARU(118)=PYALPS
45965
45966 RETURN
45967 END
45968
45969C*********************************************************************
45970
45971C...PYANGL
45972C...Reconstructs an angle from given x and y coordinates.
45973
45974 FUNCTION PYANGL(X,Y)
45975
45976C...Double precision and integer declarations.
45977 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45978 IMPLICIT INTEGER(I-N)
45979 INTEGER PYK,PYCHGE,PYCOMP
45980C...Commonblocks.
45981 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45982 SAVE /PYDAT1/
45983
45984 PYANGL=0D0
45985 R=SQRT(X**2+Y**2)
45986 IF(R.LT.1D-20) RETURN
45987 IF(ABS(X)/R.LT.0.8D0) THEN
45988 PYANGL=SIGN(ACOS(X/R),Y)
45989 ELSE
45990 PYANGL=ASIN(Y/R)
45991 IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN
45992 PYANGL=PARU(1)-PYANGL
45993 ELSEIF(X.LT.0D0) THEN
45994 PYANGL=-PARU(1)-PYANGL
45995 ENDIF
45996 ENDIF
45997
45998 RETURN
45999 END
46000
65fb704d 46001*C*********************************************************************
46002*
46003*C...PYR
46004*C...Generates random numbers uniformly distributed between
46005*C...0 and 1, excluding the endpoints.
46006*
46007* FUNCTION PYR(IDUMMY)
46008*
46009*C...Double precision and integer declarations.
46010* IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46011* IMPLICIT INTEGER(I-N)
46012* INTEGER PYK,PYCHGE,PYCOMP
46013*C...Commonblocks.
46014* COMMON/PYDATR/MRPY(6),RRPY(100)
46015* SAVE /PYDATR/
46016*C...Equivalence between commonblock and local variables.
46017* EQUIVALENCE (MRPY1,MRPY(1)),(MRPY2,MRPY(2)),(MRPY3,MRPY(3)),
46018* &(MRPY4,MRPY(4)),(MRPY5,MRPY(5)),(MRPY6,MRPY(6)),
46019* &(RRPY98,RRPY(98)),(RRPY99,RRPY(99)),(RRPY00,RRPY(100))
46020*
46021*C...Initialize generation from given seed.
46022* IF(MRPY2.EQ.0) THEN
46023* IJ=MOD(MRPY1/30082,31329)
46024* KL=MOD(MRPY1,30082)
46025* I=MOD(IJ/177,177)+2
46026* J=MOD(IJ,177)+2
46027* K=MOD(KL/169,178)+1
46028* L=MOD(KL,169)
46029* DO 110 II=1,97
46030* S=0D0
46031* T=0.5D0
46032* DO 100 JJ=1,48
46033* M=MOD(MOD(I*J,179)*K,179)
46034* I=J
46035* J=K
46036* K=M
46037* L=MOD(53*L+1,169)
46038* IF(MOD(L*M,64).GE.32) S=S+T
46039* T=0.5D0*T
46040* 100 CONTINUE
46041* RRPY(II)=S
46042* 110 CONTINUE
46043* TWOM24=1D0
46044* DO 120 I24=1,24
46045* TWOM24=0.5D0*TWOM24
46046* 120 CONTINUE
46047* RRPY98=362436D0*TWOM24
46048* RRPY99=7654321D0*TWOM24
46049* RRPY00=16777213D0*TWOM24
46050* MRPY2=1
46051* MRPY3=0
46052* MRPY4=97
46053* MRPY5=33
46054* ENDIF
46055*
46056*C...Generate next random number.
46057* 130 RUNI=RRPY(MRPY4)-RRPY(MRPY5)
46058* IF(RUNI.LT.0D0) RUNI=RUNI+1D0
46059* RRPY(MRPY4)=RUNI
46060* MRPY4=MRPY4-1
46061* IF(MRPY4.EQ.0) MRPY4=97
46062* MRPY5=MRPY5-1
46063* IF(MRPY5.EQ.0) MRPY5=97
46064* RRPY98=RRPY98-RRPY99
46065* IF(RRPY98.LT.0D0) RRPY98=RRPY98+RRPY00
46066* RUNI=RUNI-RRPY98
46067* IF(RUNI.LT.0D0) RUNI=RUNI+1D0
46068* IF(RUNI.LE.0D0.OR.RUNI.GE.1D0) GOTO 130
46069*
46070*C...Update counters. Random number to output.
46071* MRPY3=MRPY3+1
46072* IF(MRPY3.EQ.1000000000) THEN
46073* MRPY2=MRPY2+1
46074* MRPY3=0
46075* ENDIF
46076* PYR=RUNI
46077*
46078* RETURN
46079* END
46080*
46081*C*********************************************************************
46082*
46083*C...PYRGET
46084*C...Dumps the state of the random number generator on a file
46085*C...for subsequent startup from this state onwards.
46086*
46087* SUBROUTINE PYRGET(LFN,MOVE)
46088*
46089*C...Double precision and integer declarations.
46090* IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46091* IMPLICIT INTEGER(I-N)
46092* INTEGER PYK,PYCHGE,PYCOMP
46093*C...Commonblocks.
46094* COMMON/PYDATR/MRPY(6),RRPY(100)
46095* SAVE /PYDATR/
46096*C...Local character variable.
46097* CHARACTER CHERR*8
46098*
46099*C...Backspace required number of records (or as many as there are).
46100* IF(MOVE.LT.0) THEN
46101* NBCK=MIN(MRPY(6),-MOVE)
46102* DO 100 IBCK=1,NBCK
46103* BACKSPACE(LFN,ERR=110,IOSTAT=IERR)
46104* 100 CONTINUE
46105* MRPY(6)=MRPY(6)-NBCK
46106* ENDIF
46107*
46108*C...Unformatted write on unit LFN.
46109* WRITE(LFN,ERR=110,IOSTAT=IERR) (MRPY(I1),I1=1,5),
46110* &(RRPY(I2),I2=1,100)
46111* MRPY(6)=MRPY(6)+1
46112* RETURN
46113*
46114*C...Write error.
46115* 110 WRITE(CHERR,'(I8)') IERR
46116* CALL PYERRM(18,'(PYRGET:) error when accessing file, IOSTAT ='//
46117* &CHERR)
46118*
46119* RETURN
46120* END
46121*
46122*C*********************************************************************
46123*
46124*C...PYRSET
46125*C...Reads a state of the random number generator from a file
46126*C...for subsequent generation from this state onwards.
46127*
46128* SUBROUTINE PYRSET(LFN,MOVE)
46129*
46130*C...Double precision and integer declarations.
46131* IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46132* IMPLICIT INTEGER(I-N)
46133* INTEGER PYK,PYCHGE,PYCOMP
46134*C...Commonblocks.
46135* COMMON/PYDATR/MRPY(6),RRPY(100)
46136* SAVE /PYDATR/
46137*C...Local character variable.
46138* CHARACTER CHERR*8
46139*
46140*C...Backspace required number of records (or as many as there are).
46141* IF(MOVE.LT.0) THEN
46142* NBCK=MIN(MRPY(6),-MOVE)
46143* DO 100 IBCK=1,NBCK
46144* BACKSPACE(LFN,ERR=120,IOSTAT=IERR)
46145* 100 CONTINUE
46146* MRPY(6)=MRPY(6)-NBCK
46147* ENDIF
46148*
46149*C...Unformatted read from unit LFN.
46150* NFOR=1+MAX(0,MOVE)
46151* DO 110 IFOR=1,NFOR
46152* READ(LFN,ERR=120,IOSTAT=IERR) (MRPY(I1),I1=1,5),
46153* & (RRPY(I2),I2=1,100)
46154* 110 CONTINUE
46155* MRPY(6)=MRPY(6)+NFOR
46156* RETURN
46157*
46158*C...Write error.
46159* 120 WRITE(CHERR,'(I8)') IERR
46160* CALL PYERRM(18,'(PYRSET:) error when accessing file, IOSTAT ='//
46161* &CHERR)
46162*
46163* RETURN
46164* END
46165*
952cc209 46166C*********************************************************************
46167
46168C...PYROBO
46169C...Performs rotations and boosts.
46170
46171 SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
46172
46173C...Double precision and integer declarations.
46174 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46175 IMPLICIT INTEGER(I-N)
46176 INTEGER PYK,PYCHGE,PYCOMP
46177C...Commonblocks.
46178 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
46179 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46180 SAVE /PYJETS/,/PYDAT1/
46181C...Local arrays.
46182 DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
46183
46184C...Find and check range of rotation/boost.
46185 IMIN=IMI
46186 IF(IMIN.LE.0) IMIN=1
46187 IF(MSTU(1).GT.0) IMIN=MSTU(1)
46188 IMAX=IMA
46189 IF(IMAX.LE.0) IMAX=N
46190 IF(MSTU(2).GT.0) IMAX=MSTU(2)
46191 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
46192 CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory')
46193 RETURN
46194 ENDIF
46195
46196C...Optional resetting of V (when not set before.)
46197 IF(MSTU(33).NE.0) THEN
46198 DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
46199 DO 100 J=1,5
46200 V(I,J)=0D0
46201 100 CONTINUE
46202 110 CONTINUE
46203 MSTU(33)=0
46204 ENDIF
46205
46206C...Rotate, typically from z axis to direction (theta,phi).
46207 IF(THE**2+PHI**2.GT.1D-20) THEN
46208 ROT(1,1)=COS(THE)*COS(PHI)
46209 ROT(1,2)=-SIN(PHI)
46210 ROT(1,3)=SIN(THE)*COS(PHI)
46211 ROT(2,1)=COS(THE)*SIN(PHI)
46212 ROT(2,2)=COS(PHI)
46213 ROT(2,3)=SIN(THE)*SIN(PHI)
46214 ROT(3,1)=-SIN(THE)
46215 ROT(3,2)=0D0
46216 ROT(3,3)=COS(THE)
46217 DO 140 I=IMIN,IMAX
46218 IF(K(I,1).LE.0) GOTO 140
46219 DO 120 J=1,3
46220 PR(J)=P(I,J)
46221 VR(J)=V(I,J)
46222 120 CONTINUE
46223 DO 130 J=1,3
46224 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
46225 V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
46226 130 CONTINUE
46227 140 CONTINUE
46228 ENDIF
46229
46230C...Boost, typically from rest to momentum/energy=beta.
46231 IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN
46232 DBX=BEX
46233 DBY=BEY
46234 DBZ=BEZ
46235 DB=SQRT(DBX**2+DBY**2+DBZ**2)
46236 EPS1=1D0-1D-12
46237 IF(DB.GT.EPS1) THEN
46238C...Rescale boost vector if too close to unity.
46239 CALL PYERRM(3,'(PYROBO:) boost vector too large')
46240 DBX=DBX*(EPS1/DB)
46241 DBY=DBY*(EPS1/DB)
46242 DBZ=DBZ*(EPS1/DB)
46243 DB=EPS1
46244 ENDIF
46245 DGA=1D0/SQRT(1D0-DB**2)
46246 DO 160 I=IMIN,IMAX
46247 IF(K(I,1).LE.0) GOTO 160
46248 DO 150 J=1,4
46249 DP(J)=P(I,J)
46250 DV(J)=V(I,J)
46251 150 CONTINUE
46252 DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
46253 DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
46254 P(I,1)=DP(1)+DGABP*DBX
46255 P(I,2)=DP(2)+DGABP*DBY
46256 P(I,3)=DP(3)+DGABP*DBZ
46257 P(I,4)=DGA*(DP(4)+DBP)
46258 DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
46259 DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
46260 V(I,1)=DV(1)+DGABV*DBX
46261 V(I,2)=DV(2)+DGABV*DBY
46262 V(I,3)=DV(3)+DGABV*DBZ
46263 V(I,4)=DGA*(DV(4)+DBV)
46264 160 CONTINUE
46265 ENDIF
46266
46267 RETURN
46268 END
46269
46270C*********************************************************************
46271
46272C...PYEDIT
46273C...Performs global manipulations on the event record, in particular
46274C...to exclude unstable or undetectable partons/particles.
46275
46276 SUBROUTINE PYEDIT(MEDIT)
46277
46278C...Double precision and integer declarations.
46279 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46280 IMPLICIT INTEGER(I-N)
46281 INTEGER PYK,PYCHGE,PYCOMP
46282C...Commonblocks.
46283 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
46284 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46285 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46286 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
46287C...Local arrays.
46288 DIMENSION NS(2),PTS(2),PLS(2)
46289
46290C...Remove unwanted partons/particles.
46291 IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
46292 IMAX=N
46293 IF(MSTU(2).GT.0) IMAX=MSTU(2)
46294 I1=MAX(1,MSTU(1))-1
46295 DO 110 I=MAX(1,MSTU(1)),IMAX
46296 IF(K(I,1).EQ.0.OR.K(I,1).GT.20) GOTO 110
46297 IF(MEDIT.EQ.1) THEN
46298 IF(K(I,1).GT.10) GOTO 110
46299 ELSEIF(MEDIT.EQ.2) THEN
46300 IF(K(I,1).GT.10) GOTO 110
46301 KC=PYCOMP(K(I,2))
46302 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.KC.EQ.18)
46303 & GOTO 110
46304 ELSEIF(MEDIT.EQ.3) THEN
46305 IF(K(I,1).GT.10) GOTO 110
46306 KC=PYCOMP(K(I,2))
46307 IF(KC.EQ.0) GOTO 110
46308 IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110
46309 ELSEIF(MEDIT.EQ.5) THEN
46310 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) GOTO 110
46311 KC=PYCOMP(K(I,2))
46312 IF(KC.EQ.0) GOTO 110
46313 IF(K(I,1).GE.11.AND.KCHG(KC,2).EQ.0) GOTO 110
46314 ENDIF
46315
46316C...Pack remaining partons/particles. Origin no longer known.
46317 I1=I1+1
46318 DO 100 J=1,5
46319 K(I1,J)=K(I,J)
46320 P(I1,J)=P(I,J)
46321 V(I1,J)=V(I,J)
46322 100 CONTINUE
46323 K(I1,3)=0
46324 110 CONTINUE
46325 IF(I1.LT.N) MSTU(3)=0
46326 IF(I1.LT.N) MSTU(70)=0
46327 N=I1
46328
46329C...Selective removal of class of entries. New position of retained.
46330 ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
46331 I1=0
46332 DO 120 I=1,N
46333 K(I,3)=MOD(K(I,3),MSTU(5))
46334 IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
46335 IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
46336 IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
46337 & K(I,1).EQ.15).AND.K(I,2).NE.94) GOTO 120
46338 IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
46339 & K(I,2).EQ.94)) GOTO 120
46340 IF(MEDIT.EQ.15.AND.K(I,1).GE.21) GOTO 120
46341 I1=I1+1
46342 K(I,3)=K(I,3)+MSTU(5)*I1
46343 120 CONTINUE
46344
46345C...Find new event history information and replace old.
46346 DO 140 I=1,N
46347 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,3)/MSTU(5).EQ.0)
46348 & GOTO 140
46349 ID=I
46350 130 IM=MOD(K(ID,3),MSTU(5))
46351 IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
46352 IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15).AND.
46353 & K(IM,2).NE.94) THEN
46354 ID=IM
46355 GOTO 130
46356 ENDIF
46357 ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
46358 IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,2).EQ.94) THEN
46359 ID=IM
46360 GOTO 130
46361 ENDIF
46362 ENDIF
46363 K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
46364 IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
46365 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
46366 IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
46367 & K(K(I,4),3)/MSTU(5)
46368 IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
46369 & K(K(I,5),3)/MSTU(5)
46370 ELSE
46371 KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
46372 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
46373 KCD=MOD(K(I,4),MSTU(5))
46374 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
46375 K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
46376 KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
46377 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
46378 KCD=MOD(K(I,5),MSTU(5))
46379 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
46380 K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
46381 ENDIF
46382 140 CONTINUE
46383
46384C...Pack remaining entries.
46385 I1=0
46386 MSTU90=MSTU(90)
46387 MSTU(90)=0
46388 DO 170 I=1,N
46389 IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
46390 I1=I1+1
46391 DO 150 J=1,5
46392 K(I1,J)=K(I,J)
46393 P(I1,J)=P(I,J)
46394 V(I1,J)=V(I,J)
46395 150 CONTINUE
46396 K(I1,3)=MOD(K(I1,3),MSTU(5))
46397 DO 160 IZ=1,MSTU90
46398 IF(I.EQ.MSTU(90+IZ)) THEN
46399 MSTU(90)=MSTU(90)+1
46400 MSTU(90+MSTU(90))=I1
46401 PARU(90+MSTU(90))=PARU(90+IZ)
46402 ENDIF
46403 160 CONTINUE
46404 170 CONTINUE
46405 IF(I1.LT.N) MSTU(3)=0
46406 IF(I1.LT.N) MSTU(70)=0
46407 N=I1
46408
46409C...Fill in some missing daughter pointers (lost in colour flow).
46410 ELSEIF(MEDIT.EQ.16) THEN
46411 DO 220 I=1,N
46412 IF(K(I,1).LE.10.OR.K(I,1).GT.20) GOTO 220
46413 IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220
46414C...Find daughters who point to mother.
46415 DO 180 I1=I+1,N
46416 IF(K(I1,3).NE.I) THEN
46417 ELSEIF(K(I,4).EQ.0) THEN
46418 K(I,4)=I1
46419 ELSE
46420 K(I,5)=I1
46421 ENDIF
46422 180 CONTINUE
46423 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
46424 IF(K(I,4).NE.0) GOTO 220
46425C...Find daughters who point to documentation version of mother.
46426 IM=K(I,3)
46427 IF(IM.LE.0.OR.IM.GE.I) GOTO 220
46428 IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220
46429 IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220
46430 DO 190 I1=I+1,N
46431 IF(K(I1,3).NE.IM) THEN
46432 ELSEIF(K(I,4).EQ.0) THEN
46433 K(I,4)=I1
46434 ELSE
46435 K(I,5)=I1
46436 ENDIF
46437 190 CONTINUE
46438 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
46439 IF(K(I,4).NE.0) GOTO 220
46440C...Find daughters who point to documentation daughters who,
46441C...in their turn, point to documentation mother.
46442 ID1=IM
46443 ID2=IM
46444 DO 200 I1=IM+1,I-1
46445 IF(K(I1,3).EQ.IM.AND.K(I1,1).GT.20.AND.K(I1,1).LE.30) THEN
46446 ID2=I1
46447 IF(ID1.EQ.IM) ID1=I1
46448 ENDIF
46449 200 CONTINUE
46450 DO 210 I1=I+1,N
46451 IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
46452 ELSEIF(K(I,4).EQ.0) THEN
46453 K(I,4)=I1
46454 ELSE
46455 K(I,5)=I1
46456 ENDIF
46457 210 CONTINUE
46458 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
46459 220 CONTINUE
46460
46461C...Save top entries at bottom of PYJETS commonblock.
46462 ELSEIF(MEDIT.EQ.21) THEN
46463 IF(2*N.GE.MSTU(4)) THEN
46464 CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS')
46465 RETURN
46466 ENDIF
46467 DO 240 I=1,N
46468 DO 230 J=1,5
46469 K(MSTU(4)-I,J)=K(I,J)
46470 P(MSTU(4)-I,J)=P(I,J)
46471 V(MSTU(4)-I,J)=V(I,J)
46472 230 CONTINUE
46473 240 CONTINUE
46474 MSTU(32)=N
46475
46476C...Restore bottom entries of commonblock PYJETS to top.
46477 ELSEIF(MEDIT.EQ.22) THEN
46478 DO 260 I=1,MSTU(32)
46479 DO 250 J=1,5
46480 K(I,J)=K(MSTU(4)-I,J)
46481 P(I,J)=P(MSTU(4)-I,J)
46482 V(I,J)=V(MSTU(4)-I,J)
46483 250 CONTINUE
46484 260 CONTINUE
46485 N=MSTU(32)
46486
46487C...Mark primary entries at top of commonblock PYJETS as untreated.
46488 ELSEIF(MEDIT.EQ.23) THEN
46489 I1=0
46490 DO 270 I=1,N
46491 KH=K(I,3)
46492 IF(KH.GE.1) THEN
46493 IF(K(KH,1).GT.20) KH=0
46494 ENDIF
46495 IF(KH.NE.0) GOTO 280
46496 I1=I1+1
46497 IF(K(I,1).GT.10.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
46498 270 CONTINUE
46499 280 N=I1
46500
46501C...Place largest axis along z axis and second largest in xy plane.
46502 ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
46503 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1),
46504 & P(MSTU(61),2)),0D0,0D0,0D0)
46505 CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3),
46506 & P(MSTU(61),1)),0D0,0D0,0D0,0D0)
46507 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1),
46508 & P(MSTU(61)+1,2)),0D0,0D0,0D0)
46509 IF(MEDIT.EQ.31) RETURN
46510
46511C...Rotate to put slim jet along +z axis.
46512 DO 290 IS=1,2
46513 NS(IS)=0
46514 PTS(IS)=0D0
46515 PLS(IS)=0D0
46516 290 CONTINUE
46517 DO 300 I=1,N
46518 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300
46519 IF(MSTU(41).GE.2) THEN
46520 KC=PYCOMP(K(I,2))
46521 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
46522 & KC.EQ.18) GOTO 300
46523 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
46524 & .EQ.0) GOTO 300
46525 ENDIF
46526 IS=2D0-SIGN(0.5D0,P(I,3))
46527 NS(IS)=NS(IS)+1
46528 PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
46529 300 CONTINUE
46530 IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
46531 & CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0)
46532
46533C...Rotate to put second largest jet into -z,+x quadrant.
46534 DO 310 I=1,N
46535 IF(P(I,3).GE.0D0) GOTO 310
46536 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310
46537 IF(MSTU(41).GE.2) THEN
46538 KC=PYCOMP(K(I,2))
46539 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
46540 & KC.EQ.18) GOTO 310
46541 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
46542 & .EQ.0) GOTO 310
46543 ENDIF
46544 IS=2D0-SIGN(0.5D0,P(I,1))
46545 PLS(IS)=PLS(IS)-P(I,3)
46546 310 CONTINUE
46547 IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1),
46548 & 0D0,0D0,0D0)
46549 ENDIF
46550
46551 RETURN
46552 END
46553
46554C*********************************************************************
46555
46556C...PYLIST
46557C...Gives program heading, or lists an event, or particle
46558C...data, or current parameter values.
46559
46560 SUBROUTINE PYLIST(MLIST)
46561
46562C...Double precision and integer declarations.
46563 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46564 IMPLICIT INTEGER(I-N)
46565 INTEGER PYK,PYCHGE,PYCOMP
46566C...Parameter statement to help give large particle numbers.
46567 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
46568C...Commonblocks.
46569 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
46570 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46571 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46572 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
46573 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
46574C...Local arrays, character variables and data.
46575 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
46576 DIMENSION PS(6)
46577 DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/
46578
46579C...Initialization printout: version number and date of last change.
46580 IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
46581 CALL PYLOGO
46582 MSTU(12)=0
46583 IF(MLIST.EQ.0) RETURN
46584 ENDIF
46585
46586C...List event data, including additional lines after N.
46587 IF(MLIST.GE.1.AND.MLIST.LE.3) THEN
46588 IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
46589 IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
46590 IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
46591 LMX=12
46592 IF(MLIST.GE.2) LMX=16
46593 ISTR=0
46594 IMAX=N
46595 IF(MSTU(2).GT.0) IMAX=MSTU(2)
46596 DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
46597 IF((I.GT.IMAX.AND.I.LE.N).OR.K(I,1).LT.0) GOTO 120
46598
46599C...Get particle name, pad it and check it is not too long.
46600 CALL PYNAME(K(I,2),CHAP)
46601 LEN=0
46602 DO 100 LEM=1,16
46603 IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
46604 100 CONTINUE
46605 MDL=(K(I,1)+19)/10
46606 LDL=0
46607 IF(MDL.EQ.2.OR.MDL.GE.8) THEN
46608 CHAC=CHAP
46609 IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
46610 ELSE
46611 LDL=1
46612 IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
46613 IF(LEN.EQ.0) THEN
46614 CHAC=CHDL(MDL)(1:2*LDL)//' '
46615 ELSE
46616 CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
46617 & CHDL(MDL)(LDL+1:2*LDL)//' '
46618 IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
46619 ENDIF
46620 ENDIF
46621
46622C...Add information on string connection.
46623 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
46624 & THEN
46625 KC=PYCOMP(K(I,2))
46626 KCC=0
46627 IF(KC.NE.0) KCC=KCHG(KC,2)
46628 IF(IABS(K(I,2)).EQ.39) THEN
46629 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
46630 ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
46631 ISTR=1
46632 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
46633 ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
46634 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
46635 ELSEIF(KCC.NE.0) THEN
46636 ISTR=0
46637 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
46638 ENDIF
46639 ENDIF
46640
46641C...Write data for particle/jet.
46642 IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) THEN
46643 WRITE(MSTU(11),5400) I,CHAC(1:12),(K(I,J1),J1=1,3),
46644 & (P(I,J2),J2=1,5)
46645 ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999D0) THEN
46646 WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
46647 & (P(I,J2),J2=1,5)
46648 ELSEIF(MLIST.EQ.1) THEN
46649 WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
46650 & (P(I,J2),J2=1,5)
46651 ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
46652 & K(I,1).EQ.14)) THEN
46653 WRITE(MSTU(11),5700) I,CHAC,(K(I,J1),J1=1,3),
46654 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
46655 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
46656 & (P(I,J2),J2=1,5)
46657 ELSE
46658 WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,5),
46659 & (P(I,J2),J2=1,5)
46660 ENDIF
46661 IF(MLIST.EQ.3) WRITE(MSTU(11),5900) (V(I,J),J=1,5)
46662
46663C...Insert extra separator lines specified by user.
46664 IF(MSTU(70).GE.1) THEN
46665 ISEP=0
46666 DO 110 J=1,MIN(10,MSTU(70))
46667 IF(I.EQ.MSTU(70+J)) ISEP=1
46668 110 CONTINUE
46669 IF(ISEP.EQ.1.AND.MLIST.EQ.1) WRITE(MSTU(11),6000)
46670 IF(ISEP.EQ.1.AND.MLIST.GE.2) WRITE(MSTU(11),6100)
46671 ENDIF
46672 120 CONTINUE
46673
46674C...Sum of charges and momenta.
46675 DO 130 J=1,6
46676 PS(J)=PYP(0,J)
46677 130 CONTINUE
46678 IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999D0) THEN
46679 WRITE(MSTU(11),6200) PS(6),(PS(J),J=1,5)
46680 ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN
46681 WRITE(MSTU(11),6300) PS(6),(PS(J),J=1,5)
46682 ELSEIF(MLIST.EQ.1) THEN
46683 WRITE(MSTU(11),6400) PS(6),(PS(J),J=1,5)
46684 ELSE
46685 WRITE(MSTU(11),6500) PS(6),(PS(J),J=1,5)
46686 ENDIF
46687
46688C...Give simple list of KF codes defined in program.
46689 ELSEIF(MLIST.EQ.11) THEN
46690 WRITE(MSTU(11),6600)
46691 DO 140 KF=1,80
46692 CALL PYNAME(KF,CHAP)
46693 CALL PYNAME(-KF,CHAN)
46694 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
46695 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
46696 140 CONTINUE
46697 DO 170 KFLS=1,3,2
46698 DO 160 KFLA=1,5
46699 DO 150 KFLB=1,KFLA-(3-KFLS)/2
46700 KF=1000*KFLA+100*KFLB+KFLS
46701 CALL PYNAME(KF,CHAP)
46702 CALL PYNAME(-KF,CHAN)
46703 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
46704 150 CONTINUE
46705 160 CONTINUE
46706 170 CONTINUE
46707 KF=130
46708 CALL PYNAME(KF,CHAP)
46709 WRITE(MSTU(11),6700) KF,CHAP
46710 KF=310
46711 CALL PYNAME(KF,CHAP)
46712 WRITE(MSTU(11),6700) KF,CHAP
46713 DO 200 KMUL=0,5
46714 KFLS=3
46715 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
46716 IF(KMUL.EQ.5) KFLS=5
46717 KFLR=0
46718 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
46719 IF(KMUL.EQ.4) KFLR=2
46720 DO 190 KFLB=1,5
46721 DO 180 KFLC=1,KFLB-1
46722 KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
46723 CALL PYNAME(KF,CHAP)
46724 CALL PYNAME(-KF,CHAN)
46725 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
46726 180 CONTINUE
46727 KF=10000*KFLR+110*KFLB+KFLS
46728 CALL PYNAME(KF,CHAP)
46729 WRITE(MSTU(11),6700) KF,CHAP
46730 190 CONTINUE
46731 200 CONTINUE
46732 KF=100443
46733 CALL PYNAME(KF,CHAP)
46734 WRITE(MSTU(11),6700) KF,CHAP
46735 KF=100553
46736 CALL PYNAME(KF,CHAP)
46737 WRITE(MSTU(11),6700) KF,CHAP
46738 DO 240 KFLSP=1,3
46739 KFLS=2+2*(KFLSP/3)
46740 DO 230 KFLA=1,5
46741 DO 220 KFLB=1,KFLA
46742 DO 210 KFLC=1,KFLB
46743 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC))
46744 & GOTO 210
46745 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 210
46746 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
46747 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
46748 CALL PYNAME(KF,CHAP)
46749 CALL PYNAME(-KF,CHAN)
46750 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
46751 210 CONTINUE
46752 220 CONTINUE
46753 230 CONTINUE
46754 240 CONTINUE
46755 DO 250 KF=KSUSY1+1,KSUSY1+40
46756 CALL PYNAME(KF,CHAP)
46757 CALL PYNAME(-KF,CHAN)
46758 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
46759 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
46760 250 CONTINUE
46761 DO 260 KF=KSUSY2+1,KSUSY2+40
46762 CALL PYNAME(KF,CHAP)
46763 CALL PYNAME(-KF,CHAN)
46764 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
46765 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
46766 260 CONTINUE
46767 DO 270 KF=KEXCIT+1,KEXCIT+40
46768 CALL PYNAME(KF,CHAP)
46769 CALL PYNAME(-KF,CHAN)
46770 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
46771 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
46772 270 CONTINUE
46773
46774C...List parton/particle data table. Check whether to be listed.
46775 ELSEIF(MLIST.EQ.12) THEN
46776 WRITE(MSTU(11),6800)
46777 DO 300 KC=1,MSTU(6)
46778 KF=KCHG(KC,4)
46779 IF(KF.EQ.0) GOTO 300
46780 IF(KF.LT.MSTU(1).OR.(MSTU(2).GT.0.AND.KF.GT.MSTU(2)))
46781 & GOTO 300
46782
46783C...Find particle name and mass. Print information.
46784 CALL PYNAME(KF,CHAP)
46785 IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 300
46786 CALL PYNAME(-KF,CHAN)
46787 WRITE(MSTU(11),6900) KF,KC,CHAP,CHAN,(KCHG(KC,J1),J1=1,3),
46788 & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
46789
46790C...Particle decay: channel number, branching ratios, matrix element,
46791C...decay products.
46792 DO 290 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
46793 DO 280 J=1,5
46794 CALL PYNAME(KFDP(IDC,J),CHAD(J))
46795 280 CONTINUE
46796 WRITE(MSTU(11),7000) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
46797 & (CHAD(J),J=1,5)
46798 290 CONTINUE
46799 300 CONTINUE
46800
46801C...List parameter value table.
46802 ELSEIF(MLIST.EQ.13) THEN
46803 WRITE(MSTU(11),7100)
46804 DO 310 I=1,200
46805 WRITE(MSTU(11),7200) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
46806 310 CONTINUE
46807 ENDIF
46808
46809C...Format statements for output on unit MSTU(11) (by default 6).
46810 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
46811 &5X,'KF orig p_x p_y p_z E m'/)
46812 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet',
46813 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
46814 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
46815 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j',
46816 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
46817 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X,
46818 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
46819 5400 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3)
46820 5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2)
46821 5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1)
46822 5700 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5)
46823 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5)
46824 5900 FORMAT(66X,5(1X,F12.3))
46825 6000 FORMAT(1X,78('='))
46826 6100 FORMAT(1X,130('='))
46827 6200 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
46828 6300 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
46829 6400 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
46830 6500 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
46831 &5F13.5)
46832 6600 FORMAT(///20X,'List of KF codes in program'/)
46833 6700 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16)
46834 6800 FORMAT(///30X,'Particle/parton data table'//8X,'KF',5X,'KC',4X,
46835 &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X,
46836 &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
46837 &1X,'ME',3X,'Br.rat.',4X,'decay products')
46838 6900 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
46839 &1X,1P,E13.5,3X,I2)
46840 7000 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16)
46841 7100 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
46842 &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
46843 7200 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
46844
46845 RETURN
46846 END
46847
46848C*********************************************************************
46849
46850C...PYLOGO
46851C...Writes a logo for the program.
46852
46853 SUBROUTINE PYLOGO
46854
46855C...Double precision and integer declarations.
46856 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46857 IMPLICIT INTEGER(I-N)
46858 INTEGER PYK,PYCHGE,PYCOMP
46859C...Parameter for length of information block.
46860 PARAMETER (IREFER=17)
46861C...Commonblocks.
46862 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46863 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
46864 SAVE /PYDAT1/,/PYPARS/
46865C...Local arrays and character variables.
46866 INTEGER IDATI(6)
46867 CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79,
46868 &VERS*1, SUBV*3, DATE*2, YEAR*4, HOUR*2, MINU*2, SECO*2
46869
46870C...Data on months, logo, titles, and references.
46871 DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
46872 &'Oct','Nov','Dec'/
46873 DATA (LOGO(J),J=1,19)/
46874 &' *......* ',
46875 &' *:::!!:::::::::::* ',
46876 &' *::::::!!::::::::::::::* ',
46877 &' *::::::::!!::::::::::::::::* ',
46878 &' *:::::::::!!:::::::::::::::::* ',
46879 &' *:::::::::!!:::::::::::::::::* ',
46880 &' *::::::::!!::::::::::::::::*! ',
46881 &' *::::::!!::::::::::::::* !! ',
46882 &' !! *:::!!:::::::::::* !! ',
46883 &' !! !* -><- * !! ',
46884 &' !! !! !! ',
46885 &' !! !! !! ',
46886 &' !! !! ',
46887 &' !! ep !! ',
46888 &' !! !! ',
46889 &' !! pp !! ',
46890 &' !! e+e- !! ',
46891 &' !! !! ',
46892 &' !! '/
46893 DATA (LOGO(J),J=20,38)/
46894 &'Welcome to the Lund Monte Carlo!',
46895 &' ',
46896 &'PPP Y Y TTTTT H H III A ',
46897 &'P P Y Y T H H I A A ',
46898 &'PPP Y T HHHHH I AAAAA',
46899 &'P Y T H H I A A',
46900 &'P Y T H H III A A',
46901 &' ',
46902 &'This is PYTHIA version x.xxx ',
46903 &'Last date of change: xx xxx 199x',
46904 &' ',
46905 &'Now is xx xxx 199x at xx:xx:xx ',
46906 &' ',
46907 &'Disclaimer: this program comes ',
46908 &'without any guarantees. Beware ',
46909 &'of errors and use common sense ',
46910 &'when interpreting results. ',
46911 &' ',
46912 &'Copyright T. Sjostrand (2000) '/
46913 DATA (REFER(J),J=1,18)/
46914 &'An archive of program versions and d',
46915 &'ocumentation is found on the web: ',
46916 &'http://www.thep.lu.se/~torbjorn/Pyth',
46917 &'ia.html ',
46918 &' ',
46919 &' ',
46920 &'When you cite this program, currentl',
46921 &'y the official reference is ',
46922 &'T. Sjostrand, Computer Physics Commu',
46923 &'n. 82 (1994) 74. ',
46924 &'The supersymmetry extensions are des',
46925 &'cribed in ',
46926 &'S. Mrenna, Computer Physics Commun. ',
46927 &'101 (1997) 232 ',
46928 &'Also remember that the program, to a',
46929 &' large extent, represents original ',
46930 &'physics research. Other publications',
46931 &' of special relevance to your '/
46932 DATA (REFER(J),J=19,2*IREFER)/
46933 &'studies may therefore deserve separa',
46934 &'te mention. ',
46935 &' ',
46936 &' ',
46937 &'Main author: Torbjorn Sjostrand; Dep',
46938 &'artment of Theoretical Physics 2, ',
46939 &' Lund University, Solvegatan 14A, S',
46940 &'-223 62 Lund, Sweden; ',
46941 &' phone: + 46 - 46 - 222 48 16; e-ma',
46942 &'il: torbjorn@thep.lu.se ',
46943 &'SUSY author: Stephen Mrenna, Physics',
46944 &' Department, UC Davis, ',
46945 &' One Shields Avenue, Davis, CA 9561',
46946 &'6, USA; ',
46947 &' phone: + 1 - 530 - 752 - 2661; e-m',
46948 &'ail: mrenna@physics.ucdavis.edu '/
46949
46950C...Check that PYDATA linked.
46951 IF(MSTP(183)/10.NE.199.AND.MSTP(183)/10.NE.200) THEN
46952 WRITE(*,'(1X,A)')
46953 & 'Error: PYDATA has not been linked.'
46954 WRITE(*,'(1X,A)') 'Execution stopped!'
46955 STOP
46956
46957C...Write current version number and current date+time.
46958 ELSE
46959 WRITE(VERS,'(I1)') MSTP(181)
46960 LOGO(28)(24:24)=VERS
46961 WRITE(SUBV,'(I3)') MSTP(182)
46962 LOGO(28)(26:28)=SUBV
46963 IF(MSTP(182).LT.100) LOGO(28)(26:26)='0'
46964 WRITE(DATE,'(I2)') MSTP(185)
46965 LOGO(29)(22:23)=DATE
46966 LOGO(29)(25:27)=MONTH(MSTP(184))
46967 WRITE(YEAR,'(I4)') MSTP(183)
46968 LOGO(29)(29:32)=YEAR
46969 CALL PYTIME(IDATI)
46970 IF(IDATI(1).LE.0) THEN
46971 LOGO(31)=' '
46972 ELSE
46973 WRITE(DATE,'(I2)') IDATI(3)
46974 LOGO(31)(8:9)=DATE
46975 LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2))))
46976 WRITE(YEAR,'(I4)') IDATI(1)
46977 LOGO(31)(15:18)=YEAR
46978 WRITE(HOUR,'(I2)') IDATI(4)
46979 LOGO(31)(23:24)=HOUR
46980 WRITE(MINU,'(I2)') IDATI(5)
46981 LOGO(31)(26:27)=MINU
46982 IF(IDATI(5).LT.10) LOGO(31)(26:26)='0'
46983 WRITE(SECO,'(I2)') IDATI(6)
46984 LOGO(31)(29:30)=SECO
46985 IF(IDATI(6).LT.10) LOGO(31)(29:29)='0'
46986 ENDIF
46987 ENDIF
46988
46989C...Loop over lines in header. Define page feed and side borders.
46990 DO 100 ILIN=1,29+IREFER
46991 LINE=' '
46992 IF(ILIN.EQ.1) THEN
46993 LINE(1:1)='1'
46994 ELSE
46995 LINE(2:3)='**'
46996 LINE(78:79)='**'
46997 ENDIF
46998
46999C...Separator lines and logos.
47000 IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN
47001 LINE(4:77)='***********************************************'//
47002 & '***************************'
47003 ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN
47004 LINE(6:37)=LOGO(ILIN-5)
47005 LINE(44:75)=LOGO(ILIN+14)
47006 ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN
47007 LINE(5:40)=REFER(2*ILIN-51)
47008 LINE(41:76)=REFER(2*ILIN-50)
47009 ENDIF
47010
47011C...Write lines to appropriate unit.
47012 WRITE(MSTU(11),'(A79)') LINE
47013 100 CONTINUE
47014
47015 RETURN
47016 END
47017
47018C*********************************************************************
47019
47020C...PYUPDA
47021C...Facilitates the updating of particle and decay data
47022C...by allowing it to be done in an external file.
47023
47024 SUBROUTINE PYUPDA(MUPDA,LFN)
47025
47026C...Double precision and integer declarations.
47027 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47028 IMPLICIT INTEGER(I-N)
47029 INTEGER PYK,PYCHGE,PYCOMP
47030C...Commonblocks.
47031 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47032 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47033 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
47034 COMMON/PYDAT4/CHAF(500,2)
47035 CHARACTER CHAF*16
47036 COMMON/PYINT4/MWID(500),WIDS(500,5)
47037 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/
47038C...Local arrays, character variables and data.
47039 CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72,
47040 &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24
47041 DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
47042 &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
47043 &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
47044 &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
47045 &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
47046
47047C...Write header if not yet done.
47048 IF(MSTU(12).GE.1) CALL PYLIST(0)
47049
47050C...Write information on file for editing.
47051 IF(MUPDA.EQ.1) THEN
47052 DO 110 KC=1,500
47053 WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
47054 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
47055 & MWID(KC),MDCY(KC,1)
47056 DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
47057 WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
47058 & (KFDP(IDC,J),J=1,5)
47059 100 CONTINUE
47060 110 CONTINUE
47061
47062C...Read complete set of information from edited file or
47063C...read partial set of new or updated information from edited file.
47064 ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN
47065
47066C...Reset counters.
47067 KCC=100
47068 NDC=0
47069 CHKF=' '
47070 IF(MUPDA.EQ.2) THEN
47071 DO 120 I=1,MSTU(6)
47072 KCHG(I,4)=0
47073 120 CONTINUE
47074 ELSE
47075 DO 130 KC=1,MSTU(6)
47076 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
47077 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
47078 130 CONTINUE
47079 ENDIF
47080
47081C...Begin of loop: read new line; unknown whether particle or
47082C...decay data.
47083 140 READ(LFN,5200,END=190) CHINL
47084
47085C...Identify particle code and whether already defined (for MUPDA=3).
47086 IF(CHINL(2:10).NE.' ') THEN
47087 CHKF=CHINL(2:10)
47088 READ(CHKF,5300) KF
47089 IF(MUPDA.EQ.2) THEN
47090 IF(KF.LE.100) THEN
47091 KC=KF
47092 ELSE
47093 KCC=KCC+1
47094 KC=KCC
47095 ENDIF
47096 ELSE
47097 KCREP=0
47098 IF(KF.LE.100) THEN
47099 KCREP=KF
47100 ELSE
47101 DO 150 KCR=101,KCC
47102 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
47103 150 CONTINUE
47104 ENDIF
47105C...Remove duplicate old decay data.
47106 IF(KCREP.NE.0.AND.MDCY(KCREP,3).GT.0) THEN
47107 IDCREP=MDCY(KCREP,2)
47108 NDCREP=MDCY(KCREP,3)
47109 DO 160 I=1,KCC
47110 IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP
47111 160 CONTINUE
47112 DO 180 I=IDCREP,NDC-NDCREP
47113 MDME(I,1)=MDME(I+NDCREP,1)
47114 MDME(I,2)=MDME(I+NDCREP,2)
47115 BRAT(I)=BRAT(I+NDCREP)
47116 DO 170 J=1,5
47117 KFDP(I,J)=KFDP(I+NDCREP,J)
47118 170 CONTINUE
47119 180 CONTINUE
47120 NDC=NDC-NDCREP
47121 KC=KCREP
47122 ELSEIF(KCREP.NE.0) THEN
47123 KC=KCREP
47124 ELSE
47125 KCC=KCC+1
47126 KC=KCC
47127 ENDIF
47128 ENDIF
47129
47130C...Study line with particle data.
47131 IF(KC.GT.MSTU(6)) CALL PYERRM(27,
47132 & '(PYUPDA:) Particle arrays full by KF ='//CHKF)
47133 READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
47134 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
47135 & MWID(KC),MDCY(KC,1)
47136 MDCY(KC,2)=0
47137 MDCY(KC,3)=0
47138
47139C...Study line with decay data.
47140 ELSE
47141 NDC=NDC+1
47142 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
47143 & '(PYUPDA:) Decay data arrays full by KF ='//CHKF)
47144 IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC
47145 MDCY(KC,3)=MDCY(KC,3)+1
47146 READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC),
47147 & (KFDP(NDC,J),J=1,5)
47148 ENDIF
47149
47150C...End of loop; ensure that PYCOMP tables are updated.
47151 GOTO 140
47152 190 CONTINUE
47153 MSTU(20)=0
47154
47155C...Perform possible tests that new information is consistent.
47156 DO 220 KC=1,MSTU(6)
47157 KF=KCHG(KC,4)
47158 IF(KF.EQ.0) GOTO 220
47159 WRITE(CHKF,5300) KF
47160 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
47161 & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17,
47162 & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF)
47163 BRSUM=0D0
47164 DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
47165 IF(MDME(IDC,2).GT.80) GOTO 210
47166 KQ=KCHG(KC,1)
47167 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
47168 MERR=0
47169 DO 200 J=1,5
47170 KP=KFDP(IDC,J)
47171 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
47172 IF(KP.EQ.81) KQ=0
47173 ELSEIF(PYCOMP(KP).EQ.0) THEN
47174 MERR=3
47175 ELSE
47176 KQ=KQ-PYCHGE(KP)
47177 KPC=PYCOMP(KP)
47178 PMS=PMS-PMAS(KPC,1)
47179 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
47180 & PMAS(KPC,3))
47181 ENDIF
47182 200 CONTINUE
47183 IF(KQ.NE.0) MERR=MAX(2,MERR)
47184 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
47185 & MERR=MAX(1,MERR)
47186 IF(MERR.EQ.3) CALL PYERRM(17,
47187 & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF)
47188 IF(MERR.EQ.2) CALL PYERRM(17,
47189 & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF)
47190 IF(MERR.EQ.1) CALL PYERRM(7,
47191 & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF)
47192 BRSUM=BRSUM+BRAT(IDC)
47193 210 CONTINUE
47194 WRITE(CHTMP,5500) BRSUM
47195 IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0)
47196 & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '//
47197 & CHTMP(9:16)//' for KF ='//CHKF)
47198 220 CONTINUE
47199
47200C...Write DATA statements for inclusion in program.
47201 ELSEIF(MUPDA.EQ.4) THEN
47202
47203C...Find out how many codes and decay channels are actually used.
47204 KCC=0
47205 NDC=0
47206 DO 230 I=1,MSTU(6)
47207 IF(KCHG(I,4).NE.0) THEN
47208 KCC=I
47209 NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1)
47210 ENDIF
47211 230 CONTINUE
47212
47213C...Initialize writing of DATA statements for inclusion in program.
47214 DO 300 IVAR=1,22
47215 NDIM=MSTU(6)
47216 IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7)
47217 NLIN=1
47218 CHLIN=' '
47219 CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/'
47220 LLIN=35
47221 CHOLD='START'
47222
47223C...Loop through variables for conversion to characters.
47224 DO 280 IDIM=1,NDIM
47225 IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
47226 IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
47227 IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
47228 IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4)
47229 IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1)
47230 IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2)
47231 IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3)
47232 IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4)
47233 IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1)
47234 IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2)
47235 IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3)
47236 IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1)
47237 IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2)
47238 IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM)
47239 IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1)
47240 IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2)
47241 IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3)
47242 IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4)
47243 IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5)
47244 IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1)
47245 IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2)
47246 IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM)
47247
47248C...Replace variables beyond what is properly defined.
47249 IF(IVAR.LE.4) THEN
47250 IF(IDIM.GT.KCC) CHTMP=' 0'
47251 ELSEIF(IVAR.LE.8) THEN
47252 IF(IDIM.GT.KCC) CHTMP=' 0.0'
47253 ELSEIF(IVAR.LE.11) THEN
47254 IF(IDIM.GT.KCC) CHTMP=' 0'
47255 ELSEIF(IVAR.LE.13) THEN
47256 IF(IDIM.GT.NDC) CHTMP=' 0'
47257 ELSEIF(IVAR.LE.14) THEN
47258 IF(IDIM.GT.NDC) CHTMP=' 0.0'
47259 ELSEIF(IVAR.LE.19) THEN
47260 IF(IDIM.GT.NDC) CHTMP=' 0'
47261 ELSEIF(IVAR.LE.21) THEN
47262 IF(IDIM.GT.KCC) CHTMP=' '
47263 ELSE
47264 IF(IDIM.GT.KCC) CHTMP=' 0'
47265 ENDIF
47266
47267C...Length of variable, trailing decimal zeros, quotation marks.
47268 LLOW=1
47269 LHIG=1
47270 DO 240 LL=1,16
47271 IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL
47272 IF(CHTMP(LL:LL).NE.' ') LHIG=LL
47273 240 CONTINUE
47274 CHNEW=CHTMP(LLOW:LHIG)//' '
47275 LNEW=1+LHIG-LLOW
47276 IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN
47277 LNEW=LNEW+1
47278 250 LNEW=LNEW-1
47279 IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250
47280 IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1
47281 IF(LNEW.EQ.0) THEN
47282 CHNEW(1:3)='0D0'
47283 LNEW=3
47284 ELSE
47285 CHNEW(LNEW+1:LNEW+2)='D0'
47286 LNEW=LNEW+2
47287 ENDIF
47288 ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN
47289 DO 260 LL=LNEW,1,-1
47290 IF(CHNEW(LL:LL).EQ.'''') THEN
47291 CHTMP=CHNEW
47292 CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
47293 LNEW=LNEW+1
47294 ENDIF
47295 260 CONTINUE
47296 LNEW=MIN(14,LNEW)
47297 CHTMP=CHNEW
47298 CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
47299 LNEW=LNEW+2
47300 ENDIF
47301
47302C...Form composite character string, often including repetition counter.
47303 IF(CHNEW.NE.CHOLD) THEN
47304 NRPT=1
47305 CHOLD=CHNEW
47306 CHCOM=CHNEW
47307 LCOM=LNEW
47308 ELSE
47309 LRPT=LNEW+1
47310 IF(NRPT.GE.2) LRPT=LNEW+3
47311 IF(NRPT.GE.10) LRPT=LNEW+4
47312 IF(NRPT.GE.100) LRPT=LNEW+5
47313 IF(NRPT.GE.1000) LRPT=LNEW+6
47314 LLIN=LLIN-LRPT
47315 NRPT=NRPT+1
47316 WRITE(CHTMP,5400) NRPT
47317 LRPT=1
47318 IF(NRPT.GE.10) LRPT=2
47319 IF(NRPT.GE.100) LRPT=3
47320 IF(NRPT.GE.1000) LRPT=4
47321 CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW)
47322 LCOM=LRPT+1+LNEW
47323 ENDIF
47324
47325C...Add characters to end of line, to new line (after storing old line),
47326C...or to new block of lines (after writing old block).
47327 IF(LLIN+LCOM.LE.70) THEN
47328 CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
47329 LLIN=LLIN+LCOM+1
47330 ELSEIF(NLIN.LE.19) THEN
47331 CHLIN(LLIN+1:72)=' '
47332 CHBLK(NLIN)=CHLIN
47333 NLIN=NLIN+1
47334 CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
47335 LLIN=6+LCOM+1
47336 ELSE
47337 CHLIN(LLIN:72)='/'//' '
47338 CHBLK(NLIN)=CHLIN
47339 WRITE(CHTMP,5400) IDIM-NRPT
47340 CHBLK(1)(30:33)=CHTMP(13:16)
47341 DO 270 ILIN=1,NLIN
47342 WRITE(LFN,5700) CHBLK(ILIN)
47343 270 CONTINUE
47344 NLIN=1
47345 CHLIN=' '
47346 CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//
47347 & ',I= , )/'//CHCOM(1:LCOM)//','
47348 WRITE(CHTMP,5400) IDIM-NRPT+1
47349 CHLIN(25:28)=CHTMP(13:16)
47350 LLIN=35+LCOM+1
47351 ENDIF
47352 280 CONTINUE
47353
47354C...Write final block of lines.
47355 CHLIN(LLIN:72)='/'//' '
47356 CHBLK(NLIN)=CHLIN
47357 WRITE(CHTMP,5400) NDIM
47358 CHBLK(1)(30:33)=CHTMP(13:16)
47359 DO 290 ILIN=1,NLIN
47360 WRITE(LFN,5700) CHBLK(ILIN)
47361 290 CONTINUE
47362 300 CONTINUE
47363 ENDIF
47364
47365C...Formats for reading and writing particle data.
47366 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3)
47367 5100 FORMAT(10X,2I5,F12.6,5I10)
47368 5200 FORMAT(A120)
47369 5300 FORMAT(I9)
47370 5400 FORMAT(I16)
47371 5500 FORMAT(F16.5)
47372 5600 FORMAT(F16.6)
47373 5700 FORMAT(A72)
47374
47375 RETURN
47376 END
47377
47378C*********************************************************************
47379
47380C...PYK
47381C...Provides various integer-valued event related data.
47382
47383 FUNCTION PYK(I,J)
47384
47385C...Double precision and integer declarations.
47386 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47387 IMPLICIT INTEGER(I-N)
47388 INTEGER PYK,PYCHGE,PYCOMP
47389C...Commonblocks.
47390 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
47391 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47392 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47393 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
47394
47395C...Default value. For I=0 number of entries, number of stable entries
47396C...or 3 times total charge.
47397 PYK=0
47398 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
47399 ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
47400 PYK=N
47401 ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
47402 DO 100 I1=1,N
47403 IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1
47404 IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+
47405 & PYCHGE(K(I1,2))
47406 100 CONTINUE
47407 ELSEIF(I.EQ.0) THEN
47408
47409C...For I > 0 direct readout of K matrix or charge.
47410 ELSEIF(J.LE.5) THEN
47411 PYK=K(I,J)
47412 ELSEIF(J.EQ.6) THEN
47413 PYK=PYCHGE(K(I,2))
47414
47415C...Status (existing/fragmented/decayed), parton/hadron separation.
47416 ELSEIF(J.LE.8) THEN
47417 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1
47418 IF(J.EQ.8) PYK=PYK*K(I,2)
47419 ELSEIF(J.LE.12) THEN
47420 KFA=IABS(K(I,2))
47421 KC=PYCOMP(KFA)
47422 KQ=0
47423 IF(KC.NE.0) KQ=KCHG(KC,2)
47424 IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2)
47425 IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2)
47426 IF(J.EQ.11) PYK=KC
47427 IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2))
47428
47429C...Heaviest flavour in hadron/diquark.
47430 ELSEIF(J.EQ.13) THEN
47431 KFA=IABS(K(I,2))
47432 PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
47433 IF(KFA.LT.10) PYK=KFA
47434 IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10)
47435 PYK=PYK*ISIGN(1,K(I,2))
47436
47437C...Particle history: generation, ancestor, rank.
47438 ELSEIF(J.LE.15) THEN
47439 I2=I
47440 I1=I
47441 110 PYK=PYK+1
47442 I2=I1
47443 I1=K(I1,3)
47444 IF(I1.GT.0) THEN
47445 IF(K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
47446 ENDIF
47447 IF(J.EQ.15) PYK=I2
47448 ELSEIF(J.EQ.16) THEN
47449 KFA=IABS(K(I,2))
47450 IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
47451 & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
47452 I1=I
47453 120 I2=I1
47454 I1=K(I1,3)
47455 IF(I1.GT.0) THEN
47456 KFAM=IABS(K(I1,2))
47457 ILP=1
47458 IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
47459 IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
47460 & ILP=0
47461 IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
47462 IF(ILP.EQ.1) GOTO 120
47463 ENDIF
47464 IF(K(I1,1).EQ.12) THEN
47465 DO 130 I3=I1+1,I2
47466 IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
47467 & .AND.K(I3,2).NE.93) PYK=PYK+1
47468 130 CONTINUE
47469 ELSE
47470 I3=I2
47471 140 PYK=PYK+1
47472 I3=I3+1
47473 IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
47474 ENDIF
47475 ENDIF
47476
47477C...Particle coming from collapsing jet system or not.
47478 ELSEIF(J.EQ.17) THEN
47479 I1=I
47480 150 PYK=PYK+1
47481 I3=I1
47482 I1=K(I1,3)
47483 I0=MAX(1,I1)
47484 KC=PYCOMP(K(I0,2))
47485 IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
47486 IF(PYK.EQ.1) PYK=-1
47487 IF(PYK.GT.1) PYK=0
47488 RETURN
47489 ENDIF
47490 IF(KCHG(KC,2).EQ.0) GOTO 150
47491 IF(K(I1,1).NE.12) PYK=0
47492 IF(K(I1,1).NE.12) RETURN
47493 I2=I1
47494 160 I2=I2+1
47495 IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
47496 K3M=K(I3-1,3)
47497 IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0
47498 K3P=K(I3+1,3)
47499 IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0
47500
47501C...Number of decay products. Colour flow.
47502 ELSEIF(J.EQ.18) THEN
47503 IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1)
47504 IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0
47505 ELSEIF(J.LE.22) THEN
47506 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
47507 IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5))
47508 IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5))
47509 IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5))
47510 IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5))
47511 ELSE
47512 ENDIF
47513
47514 RETURN
47515 END
47516
47517C*********************************************************************
47518
47519C...PYP
47520C...Provides various real-valued event related data.
47521
47522 FUNCTION PYP(I,J)
47523
47524C...Double precision and integer declarations.
47525 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47526 IMPLICIT INTEGER(I-N)
47527 INTEGER PYK,PYCHGE,PYCOMP
47528C...Commonblocks.
47529 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
47530 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47531 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47532 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
47533C...Local array.
47534 DIMENSION PSUM(4)
47535
47536C...Set default value. For I = 0 sum of momenta or charges,
47537C...or invariant mass of system.
47538 PYP=0D0
47539 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
47540 ELSEIF(I.EQ.0.AND.J.LE.4) THEN
47541 DO 100 I1=1,N
47542 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J)
47543 100 CONTINUE
47544 ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
47545 DO 120 J1=1,4
47546 PSUM(J1)=0D0
47547 DO 110 I1=1,N
47548 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+
47549 & P(I1,J1)
47550 110 CONTINUE
47551 120 CONTINUE
47552 PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
47553 ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
47554 DO 130 I1=1,N
47555 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0
47556 130 CONTINUE
47557 ELSEIF(I.EQ.0) THEN
47558
47559C...Direct readout of P matrix.
47560 ELSEIF(J.LE.5) THEN
47561 PYP=P(I,J)
47562
47563C...Charge, total momentum, transverse momentum, transverse mass.
47564 ELSEIF(J.LE.12) THEN
47565 IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0
47566 IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2
47567 IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2
47568 IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2
47569 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP)
47570
47571C...Theta and phi angle in radians or degrees.
47572 ELSEIF(J.LE.16) THEN
47573 IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
47574 IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2))
47575 IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1)
47576
47577C...True rapidity, rapidity with pion mass, pseudorapidity.
47578 ELSEIF(J.LE.19) THEN
47579 PMR=0D0
47580 IF(J.EQ.17) PMR=P(I,5)
47581 IF(J.EQ.18) PMR=PYMASS(211)
47582 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
47583 PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
47584 & 1D20)),P(I,3))
47585
47586C...Energy and momentum fractions (only to be used in CM frame).
47587 ELSEIF(J.LE.25) THEN
47588 IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
47589 IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21)
47590 IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
47591 IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21)
47592 IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21)
47593 IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21)
47594 ENDIF
47595
47596 RETURN
47597 END
47598
47599C*********************************************************************
47600
47601C...PYSPHE
47602C...Performs sphericity tensor analysis to give sphericity,
47603C...aplanarity and the related event axes.
47604
47605 SUBROUTINE PYSPHE(SPH,APL)
47606
47607C...Double precision and integer declarations.
47608 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47609 IMPLICIT INTEGER(I-N)
47610 INTEGER PYK,PYCHGE,PYCOMP
47611C...Commonblocks.
47612 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
47613 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47614 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47615 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
47616C...Local arrays.
47617 DIMENSION SM(3,3),SV(3,3)
47618
47619C...Calculate matrix to be diagonalized.
47620 NP=0
47621 DO 110 J1=1,3
47622 DO 100 J2=J1,3
47623 SM(J1,J2)=0D0
47624 100 CONTINUE
47625 110 CONTINUE
47626 PS=0D0
47627 DO 140 I=1,N
47628 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
47629 IF(MSTU(41).GE.2) THEN
47630 KC=PYCOMP(K(I,2))
47631 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
47632 & KC.EQ.18) GOTO 140
47633 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
47634 & GOTO 140
47635 ENDIF
47636 NP=NP+1
47637 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
47638 PWT=1D0
47639 IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT=
47640 & MAX(1D-10,PA)**(PARU(41)-2D0)
47641 DO 130 J1=1,3
47642 DO 120 J2=J1,3
47643 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
47644 120 CONTINUE
47645 130 CONTINUE
47646 PS=PS+PWT*PA**2
47647 140 CONTINUE
47648
47649C...Very low multiplicities (0 or 1) not considered.
47650 IF(NP.LE.1) THEN
47651 CALL PYERRM(8,'(PYSPHE:) too few particles for analysis')
47652 SPH=-1D0
47653 APL=-1D0
47654 RETURN
47655 ENDIF
47656 DO 160 J1=1,3
47657 DO 150 J2=J1,3
47658 SM(J1,J2)=SM(J1,J2)/PS
47659 150 CONTINUE
47660 160 CONTINUE
47661
47662C...Find eigenvalues to matrix (third degree equation).
47663 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
47664 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
47665 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
47666 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
47667 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
47668 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
47669 P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
47670 P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP)
47671 P(N+2,4)=1D0-P(N+1,4)-P(N+3,4)
47672 IF(P(N+2,4).LT.1D-5) THEN
47673 CALL PYERRM(8,'(PYSPHE:) all particles back-to-back')
47674 SPH=-1D0
47675 APL=-1D0
47676 RETURN
47677 ENDIF
47678
47679C...Find first and last eigenvector by solving equation system.
47680 DO 240 I=1,3,2
47681 DO 180 J1=1,3
47682 SV(J1,J1)=SM(J1,J1)-P(N+I,4)
47683 DO 170 J2=J1+1,3
47684 SV(J1,J2)=SM(J1,J2)
47685 SV(J2,J1)=SM(J1,J2)
47686 170 CONTINUE
47687 180 CONTINUE
47688 SMAX=0D0
47689 DO 200 J1=1,3
47690 DO 190 J2=1,3
47691 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
47692 JA=J1
47693 JB=J2
47694 SMAX=ABS(SV(J1,J2))
47695 190 CONTINUE
47696 200 CONTINUE
47697 SMAX=0D0
47698 DO 220 J3=JA+1,JA+2
47699 J1=J3-3*((J3-1)/3)
47700 RL=SV(J1,JB)/SV(JA,JB)
47701 DO 210 J2=1,3
47702 SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
47703 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
47704 JC=J1
47705 SMAX=ABS(SV(J1,J2))
47706 210 CONTINUE
47707 220 CONTINUE
47708 JB1=JB+1-3*(JB/3)
47709 JB2=JB+2-3*((JB+1)/3)
47710 P(N+I,JB1)=-SV(JC,JB2)
47711 P(N+I,JB2)=SV(JC,JB1)
47712 P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
47713 & SV(JA,JB)
47714 PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
47715 SGN=(-1D0)**INT(PYR(0)+0.5D0)
47716 DO 230 J=1,3
47717 P(N+I,J)=SGN*P(N+I,J)/PA
47718 230 CONTINUE
47719 240 CONTINUE
47720
47721C...Middle axis orthogonal to other two. Fill other codes.
47722 SGN=(-1D0)**INT(PYR(0)+0.5D0)
47723 P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
47724 P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
47725 P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
47726 DO 260 I=1,3
47727 K(N+I,1)=31
47728 K(N+I,2)=95
47729 K(N+I,3)=I
47730 K(N+I,4)=0
47731 K(N+I,5)=0
47732 P(N+I,5)=0D0
47733 DO 250 J=1,5
47734 V(I,J)=0D0
47735 250 CONTINUE
47736 260 CONTINUE
47737
47738C...Calculate sphericity and aplanarity. Select storing option.
47739 SPH=1.5D0*(P(N+2,4)+P(N+3,4))
47740 APL=1.5D0*P(N+3,4)
47741 MSTU(61)=N+1
47742 MSTU(62)=NP
47743 IF(MSTU(43).LE.1) MSTU(3)=3
47744 IF(MSTU(43).GE.2) N=N+3
47745
47746 RETURN
47747 END
47748
47749C*********************************************************************
47750
47751C...PYTHRU
47752C...Performs thrust analysis to give thrust, oblateness
47753C...and the related event axes.
47754
47755 SUBROUTINE PYTHRU(THR,OBL)
47756
47757C...Double precision and integer declarations.
47758 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47759 IMPLICIT INTEGER(I-N)
47760 INTEGER PYK,PYCHGE,PYCOMP
47761C...Commonblocks.
47762 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
47763 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47764 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47765 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
47766C...Local arrays.
47767 DIMENSION TDI(3),TPR(3)
47768
47769C...Take copy of particles that are to be considered in thrust analysis.
47770 NP=0
47771 PS=0D0
47772 DO 100 I=1,N
47773 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
47774 IF(MSTU(41).GE.2) THEN
47775 KC=PYCOMP(K(I,2))
47776 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
47777 & KC.EQ.18) GOTO 100
47778 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
47779 & GOTO 100
47780 ENDIF
47781 IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
47782 CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS')
47783 THR=-2D0
47784 OBL=-2D0
47785 RETURN
47786 ENDIF
47787 NP=NP+1
47788 K(N+NP,1)=23
47789 P(N+NP,1)=P(I,1)
47790 P(N+NP,2)=P(I,2)
47791 P(N+NP,3)=P(I,3)
47792 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
47793 P(N+NP,5)=1D0
47794 IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)=
47795 & P(N+NP,4)**(PARU(42)-1D0)
47796 PS=PS+P(N+NP,4)*P(N+NP,5)
47797 100 CONTINUE
47798
47799C...Very low multiplicities (0 or 1) not considered.
47800 IF(NP.LE.1) THEN
47801 CALL PYERRM(8,'(PYTHRU:) too few particles for analysis')
47802 THR=-1D0
47803 OBL=-1D0
47804 RETURN
47805 ENDIF
47806
47807C...Loop over thrust and major. T axis along z direction in latter case.
47808 DO 320 ILD=1,2
47809 IF(ILD.EQ.2) THEN
47810 K(N+NP+1,1)=31
47811 PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2))
47812 MSTU(33)=1
47813 CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0)
47814 THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1))
47815 CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0)
47816 ENDIF
47817
47818C...Find and order particles with highest p (pT for major).
47819 DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
47820 P(ILF,4)=0D0
47821 110 CONTINUE
47822 DO 160 I=N+1,N+NP
47823 IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
47824 DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
47825 IF(P(I,4).LE.P(ILF,4)) GOTO 140
47826 DO 120 J=1,5
47827 P(ILF+1,J)=P(ILF,J)
47828 120 CONTINUE
47829 130 CONTINUE
47830 ILF=N+NP+3
47831 140 DO 150 J=1,5
47832 P(ILF+1,J)=P(I,J)
47833 150 CONTINUE
47834 160 CONTINUE
47835
47836C...Find and order initial axes with highest thrust (major).
47837 DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
47838 P(ILG,4)=0D0
47839 170 CONTINUE
47840 NC=2**(MIN(MSTU(44),NP)-1)
47841 DO 250 ILC=1,NC
47842 DO 180 J=1,3
47843 TDI(J)=0D0
47844 180 CONTINUE
47845 DO 200 ILF=1,MIN(MSTU(44),NP)
47846 SGN=P(N+NP+ILF+3,5)
47847 IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
47848 DO 190 J=1,4-ILD
47849 TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
47850 190 CONTINUE
47851 200 CONTINUE
47852 TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
47853 DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
47854 IF(TDS.LE.P(ILG,4)) GOTO 230
47855 DO 210 J=1,4
47856 P(ILG+1,J)=P(ILG,J)
47857 210 CONTINUE
47858 220 CONTINUE
47859 ILG=N+NP+MSTU(44)+4
47860 230 DO 240 J=1,3
47861 P(ILG+1,J)=TDI(J)
47862 240 CONTINUE
47863 P(ILG+1,4)=TDS
47864 250 CONTINUE
47865
47866C...Iterate direction of axis until stable maximum.
47867 P(N+NP+ILD,4)=0D0
47868 ILG=0
47869 260 ILG=ILG+1
47870 THP=0D0
47871 270 THPS=THP
47872 DO 280 J=1,3
47873 IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
47874 IF(THP.GT.1D-10) TDI(J)=TPR(J)
47875 TPR(J)=0D0
47876 280 CONTINUE
47877 DO 300 I=N+1,N+NP
47878 SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
47879 DO 290 J=1,4-ILD
47880 TPR(J)=TPR(J)+SGN*P(I,J)
47881 290 CONTINUE
47882 300 CONTINUE
47883 THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
47884 IF(THP.GE.THPS+PARU(48)) GOTO 270
47885
47886C...Save good axis. Try new initial axis until a number of tries agree.
47887 IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260
47888 IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
47889 IAGR=0
47890 SGN=(-1D0)**INT(PYR(0)+0.5D0)
47891 DO 310 J=1,3
47892 P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
47893 310 CONTINUE
47894 P(N+NP+ILD,4)=THP
47895 P(N+NP+ILD,5)=0D0
47896 ENDIF
47897 IAGR=IAGR+1
47898 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
47899 320 CONTINUE
47900
47901C...Find minor axis and value by orthogonality.
47902 SGN=(-1D0)**INT(PYR(0)+0.5D0)
47903 P(N+NP+3,1)=-SGN*P(N+NP+2,2)
47904 P(N+NP+3,2)=SGN*P(N+NP+2,1)
47905 P(N+NP+3,3)=0D0
47906 THP=0D0
47907 DO 330 I=N+1,N+NP
47908 THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
47909 330 CONTINUE
47910 P(N+NP+3,4)=THP/PS
47911 P(N+NP+3,5)=0D0
47912
47913C...Fill axis information. Rotate back to original coordinate system.
47914 DO 350 ILD=1,3
47915 K(N+ILD,1)=31
47916 K(N+ILD,2)=96
47917 K(N+ILD,3)=ILD
47918 K(N+ILD,4)=0
47919 K(N+ILD,5)=0
47920 DO 340 J=1,5
47921 P(N+ILD,J)=P(N+NP+ILD,J)
47922 V(N+ILD,J)=0D0
47923 340 CONTINUE
47924 350 CONTINUE
47925 CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0)
47926
47927C...Calculate thrust and oblateness. Select storing option.
47928 THR=P(N+1,4)
47929 OBL=P(N+2,4)-P(N+3,4)
47930 MSTU(61)=N+1
47931 MSTU(62)=NP
47932 IF(MSTU(43).LE.1) MSTU(3)=3
47933 IF(MSTU(43).GE.2) N=N+3
47934
47935 RETURN
47936 END
47937
47938C*********************************************************************
47939
47940C...PYCLUS
47941C...Subdivides the particle content of an event into jets/clusters.
47942
47943 SUBROUTINE PYCLUS(NJET)
47944
47945C...Double precision and integer declarations.
47946 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47947 IMPLICIT INTEGER(I-N)
47948 INTEGER PYK,PYCHGE,PYCOMP
47949C...Commonblocks.
47950 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
47951 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47952 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47953 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
47954C...Local arrays and saved variables.
47955 DIMENSION PS(5)
47956 SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
47957
47958C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
47959 R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
47960 &P(I1,3)*P(I2,3))*2D0*P(I1,5)*P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2
47961 R2M(I1,I2)=2D0*P(I1,4)*P(I2,4)*(1D0-(P(I1,1)*P(I2,1)+P(I1,2)*
47962 &P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
47963 R2D(I1,I2)=2D0*MIN(P(I1,4),P(I2,4))**2*(1D0-(P(I1,1)*P(I2,1)+
47964 &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
47965
47966C...If first time, reset. If reentering, skip preliminaries.
47967 IF(MSTU(48).LE.0) THEN
47968 NP=0
47969 DO 100 J=1,5
47970 PS(J)=0D0
47971 100 CONTINUE
47972 PSS=0D0
47973 PIMASS=PMAS(PYCOMP(211),1)
47974 ELSE
47975 NJET=NSAV
47976 IF(MSTU(43).GE.2) N=N-NJET
47977 DO 110 I=N+1,N+NJET
47978 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
47979 110 CONTINUE
47980 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
47981 R2ACC=PARU(44)**2
47982 ELSE
47983 R2ACC=PARU(45)*PS(5)**2
47984 ENDIF
47985 NLOOP=0
47986 GOTO 300
47987 ENDIF
47988
47989C...Find which particles are to be considered in cluster search.
47990 DO 140 I=1,N
47991 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
47992 IF(MSTU(41).GE.2) THEN
47993 KC=PYCOMP(K(I,2))
47994 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
47995 & KC.EQ.18) GOTO 140
47996 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
47997 & GOTO 140
47998 ENDIF
47999 IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
48000 CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS')
48001 NJET=-1
48002 RETURN
48003 ENDIF
48004
48005C...Take copy of these particles, with space left for jets later on.
48006 NP=NP+1
48007 K(N+NP,3)=I
48008 DO 120 J=1,5
48009 P(N+NP,J)=P(I,J)
48010 120 CONTINUE
48011 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
48012 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
48013 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
48014 P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
48015 DO 130 J=1,4
48016 PS(J)=PS(J)+P(N+NP,J)
48017 130 CONTINUE
48018 PSS=PSS+P(N+NP,5)
48019 140 CONTINUE
48020 DO 160 I=N+1,N+NP
48021 K(I+NP,3)=K(I,3)
48022 DO 150 J=1,5
48023 P(I+NP,J)=P(I,J)
48024 150 CONTINUE
48025 160 CONTINUE
48026 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
48027
48028C...Very low multiplicities not considered.
48029 IF(NP.LT.MSTU(47)) THEN
48030 CALL PYERRM(8,'(PYCLUS:) too few particles for analysis')
48031 NJET=-1
48032 RETURN
48033 ENDIF
48034
48035C...Find precluster configuration. If too few jets, make harder cuts.
48036 NLOOP=0
48037 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
48038 R2ACC=PARU(44)**2
48039 ELSE
48040 R2ACC=PARU(45)*PS(5)**2
48041 ENDIF
48042 RINIT=1.25D0*PARU(43)
48043 IF(NP.LE.MSTU(47)+2) RINIT=0D0
48044 170 RINIT=0.8D0*RINIT
48045 NPRE=0
48046 NREM=NP
48047 DO 180 I=N+NP+1,N+2*NP
48048 K(I,4)=0
48049 180 CONTINUE
48050
48051C...Sum up small momentum region. Jet if enough absolute momentum.
48052 IF(MSTU(46).LE.2) THEN
48053 DO 190 J=1,4
48054 P(N+1,J)=0D0
48055 190 CONTINUE
48056 DO 210 I=N+NP+1,N+2*NP
48057 IF(P(I,5).GT.2D0*RINIT) GOTO 210
48058 NREM=NREM-1
48059 K(I,4)=1
48060 DO 200 J=1,4
48061 P(N+1,J)=P(N+1,J)+P(I,J)
48062 200 CONTINUE
48063 210 CONTINUE
48064 P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
48065 IF(P(N+1,5).GT.2D0*RINIT) NPRE=1
48066 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
48067 IF(NREM.EQ.0) GOTO 170
48068 ENDIF
48069
48070C...Find fastest remaining particle.
48071 220 NPRE=NPRE+1
48072 PMAX=0D0
48073 DO 230 I=N+NP+1,N+2*NP
48074 IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230
48075 IMAX=I
48076 PMAX=P(I,5)
48077 230 CONTINUE
48078 DO 240 J=1,5
48079 P(N+NPRE,J)=P(IMAX,J)
48080 240 CONTINUE
48081 NREM=NREM-1
48082 K(IMAX,4)=NPRE
48083
48084C...Sum up precluster around it according to pT separation.
48085 IF(MSTU(46).LE.2) THEN
48086 DO 260 I=N+NP+1,N+2*NP
48087 IF(K(I,4).NE.0) GOTO 260
48088 R2=R2T(I,IMAX)
48089 IF(R2.GT.RINIT**2) GOTO 260
48090 NREM=NREM-1
48091 K(I,4)=NPRE
48092 DO 250 J=1,4
48093 P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
48094 250 CONTINUE
48095 260 CONTINUE
48096 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
48097
48098C...Sum up precluster around it according to mass or
48099C...Durham pT separation.
48100 ELSE
48101 270 IMIN=0
48102 R2MIN=RINIT**2
48103 DO 280 I=N+NP+1,N+2*NP
48104 IF(K(I,4).NE.0) GOTO 280
48105 IF(MSTU(46).LE.4) THEN
48106 R2=R2M(I,N+NPRE)
48107 ELSE
48108 R2=R2D(I,N+NPRE)
48109 ENDIF
48110 IF(R2.GE.R2MIN) GOTO 280
48111 IMIN=I
48112 R2MIN=R2
48113 280 CONTINUE
48114 IF(IMIN.NE.0) THEN
48115 DO 290 J=1,4
48116 P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
48117 290 CONTINUE
48118 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
48119 NREM=NREM-1
48120 K(IMIN,4)=NPRE
48121 GOTO 270
48122 ENDIF
48123 ENDIF
48124
48125C...Check if more preclusters to be found. Start over if too few.
48126 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
48127 IF(NREM.GT.0) GOTO 220
48128 NJET=NPRE
48129
48130C...Reassign all particles to nearest jet. Sum up new jet momenta.
48131 300 TSAV=0D0
48132 PSJT=0D0
48133 310 IF(MSTU(46).LE.1) THEN
48134 DO 330 I=N+1,N+NJET
48135 DO 320 J=1,4
48136 V(I,J)=0D0
48137 320 CONTINUE
48138 330 CONTINUE
48139 DO 360 I=N+NP+1,N+2*NP
48140 R2MIN=PSS**2
48141 DO 340 IJET=N+1,N+NJET
48142 IF(P(IJET,5).LT.RINIT) GOTO 340
48143 R2=R2T(I,IJET)
48144 IF(R2.GE.R2MIN) GOTO 340
48145 IMIN=IJET
48146 R2MIN=R2
48147 340 CONTINUE
48148 K(I,4)=IMIN-N
48149 DO 350 J=1,4
48150 V(IMIN,J)=V(IMIN,J)+P(I,J)
48151 350 CONTINUE
48152 360 CONTINUE
48153 PSJT=0D0
48154 DO 380 I=N+1,N+NJET
48155 DO 370 J=1,4
48156 P(I,J)=V(I,J)
48157 370 CONTINUE
48158 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
48159 PSJT=PSJT+P(I,5)
48160 380 CONTINUE
48161 ENDIF
48162
48163C...Find two closest jets.
48164 R2MIN=2D0*MAX(R2ACC,PS(5)**2)
48165 DO 400 ITRY1=N+1,N+NJET-1
48166 DO 390 ITRY2=ITRY1+1,N+NJET
48167 IF(MSTU(46).LE.2) THEN
48168 R2=R2T(ITRY1,ITRY2)
48169 ELSEIF(MSTU(46).LE.4) THEN
48170 R2=R2M(ITRY1,ITRY2)
48171 ELSE
48172 R2=R2D(ITRY1,ITRY2)
48173 ENDIF
48174 IF(R2.GE.R2MIN) GOTO 390
48175 IMIN1=ITRY1
48176 IMIN2=ITRY2
48177 R2MIN=R2
48178 390 CONTINUE
48179 400 CONTINUE
48180
48181C...If allowed, join two closest jets and start over.
48182 IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
48183 IREC=MIN(IMIN1,IMIN2)
48184 IDEL=MAX(IMIN1,IMIN2)
48185 DO 410 J=1,4
48186 P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
48187 410 CONTINUE
48188 P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
48189 DO 430 I=IDEL+1,N+NJET
48190 DO 420 J=1,5
48191 P(I-1,J)=P(I,J)
48192 420 CONTINUE
48193 430 CONTINUE
48194 IF(MSTU(46).GE.2) THEN
48195 DO 440 I=N+NP+1,N+2*NP
48196 IORI=N+K(I,4)
48197 IF(IORI.EQ.IDEL) K(I,4)=IREC-N
48198 IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
48199 440 CONTINUE
48200 ENDIF
48201 NJET=NJET-1
48202 GOTO 300
48203
48204C...Divide up broad jet if empty cluster in list of final ones.
48205 ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
48206 DO 450 I=N+1,N+NJET
48207 K(I,5)=0
48208 450 CONTINUE
48209 DO 460 I=N+NP+1,N+2*NP
48210 K(N+K(I,4),5)=K(N+K(I,4),5)+1
48211 460 CONTINUE
48212 IEMP=0
48213 DO 470 I=N+1,N+NJET
48214 IF(K(I,5).EQ.0) IEMP=I
48215 470 CONTINUE
48216 IF(IEMP.NE.0) THEN
48217 NLOOP=NLOOP+1
48218 ISPL=0
48219 R2MAX=0D0
48220 DO 480 I=N+NP+1,N+2*NP
48221 IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
48222 IJET=N+K(I,4)
48223 R2=R2T(I,IJET)
48224 IF(R2.LE.R2MAX) GOTO 480
48225 ISPL=I
48226 R2MAX=R2
48227 480 CONTINUE
48228 IF(ISPL.NE.0) THEN
48229 IJET=N+K(ISPL,4)
48230 DO 490 J=1,4
48231 P(IEMP,J)=P(ISPL,J)
48232 P(IJET,J)=P(IJET,J)-P(ISPL,J)
48233 490 CONTINUE
48234 P(IEMP,5)=P(ISPL,5)
48235 P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
48236 IF(NLOOP.LE.2) GOTO 300
48237 ENDIF
48238 ENDIF
48239 ENDIF
48240
48241C...If generalized thrust has not yet converged, continue iteration.
48242 IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
48243 &THEN
48244 TSAV=PSJT/PSS
48245 GOTO 310
48246 ENDIF
48247
48248C...Reorder jets according to energy.
48249 DO 510 I=N+1,N+NJET
48250 DO 500 J=1,5
48251 V(I,J)=P(I,J)
48252 500 CONTINUE
48253 510 CONTINUE
48254 DO 540 INEW=N+1,N+NJET
48255 PEMAX=0D0
48256 DO 520 ITRY=N+1,N+NJET
48257 IF(V(ITRY,4).LE.PEMAX) GOTO 520
48258 IMAX=ITRY
48259 PEMAX=V(ITRY,4)
48260 520 CONTINUE
48261 K(INEW,1)=31
48262 K(INEW,2)=97
48263 K(INEW,3)=INEW-N
48264 K(INEW,4)=0
48265 DO 530 J=1,5
48266 P(INEW,J)=V(IMAX,J)
48267 530 CONTINUE
48268 V(IMAX,4)=-1D0
48269 K(IMAX,5)=INEW
48270 540 CONTINUE
48271
48272C...Clean up particle-jet assignments and jet information.
48273 DO 550 I=N+NP+1,N+2*NP
48274 IORI=K(N+K(I,4),5)
48275 K(I,4)=IORI-N
48276 IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
48277 K(IORI,4)=K(IORI,4)+1
48278 550 CONTINUE
48279 IEMP=0
48280 PSJT=0D0
48281 DO 570 I=N+1,N+NJET
48282 K(I,5)=0
48283 PSJT=PSJT+P(I,5)
48284 P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0))
48285 DO 560 J=1,5
48286 V(I,J)=0D0
48287 560 CONTINUE
48288 IF(K(I,4).EQ.0) IEMP=I
48289 570 CONTINUE
48290
48291C...Select storing option. Output variables. Check for failure.
48292 MSTU(61)=N+1
48293 MSTU(62)=NP
48294 MSTU(63)=NPRE
48295 PARU(61)=PS(5)
48296 PARU(62)=PSJT/PSS
48297 PARU(63)=SQRT(R2MIN)
48298 IF(NJET.LE.1) PARU(63)=0D0
48299 IF(IEMP.NE.0) THEN
48300 CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested')
48301 NJET=-1
48302 RETURN
48303 ENDIF
48304 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
48305 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
48306 NSAV=NJET
48307
48308 RETURN
48309 END
48310
48311C*********************************************************************
48312
48313C...PYCELL
48314C...Provides a simple way of jet finding in eta-phi-ET coordinates,
48315C...as used for calorimeters at hadron colliders.
48316
48317 SUBROUTINE PYCELL(NJET)
48318
48319C...Double precision and integer declarations.
48320 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48321 IMPLICIT INTEGER(I-N)
48322 INTEGER PYK,PYCHGE,PYCOMP
48323C...Commonblocks.
48324 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
48325 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48326 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48327 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
48328
48329C...Loop over all particles. Find cell that was hit by given particle.
48330 PTLRAT=1D0/SINH(PARU(51))**2
48331 NP=0
48332 NC=N
48333 DO 110 I=1,N
48334 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
48335 IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
48336 IF(MSTU(41).GE.2) THEN
48337 KC=PYCOMP(K(I,2))
48338 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
48339 & KC.EQ.18) GOTO 110
48340 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
48341 & GOTO 110
48342 ENDIF
48343 NP=NP+1
48344 PT=SQRT(P(I,1)**2+P(I,2)**2)
48345 ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
48346 IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0*
48347 & (ETA/PARU(51)+1D0))))
48348 PHI=PYANGL(P(I,1),P(I,2))
48349 IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0*
48350 & (PHI/PARU(1)+1D0))))
48351 IETPH=MSTU(52)*IETA+IPHI
48352
48353C...Add to cell already hit, or book new cell.
48354 DO 100 IC=N+1,NC
48355 IF(IETPH.EQ.K(IC,3)) THEN
48356 K(IC,4)=K(IC,4)+1
48357 P(IC,5)=P(IC,5)+PT
48358 GOTO 110
48359 ENDIF
48360 100 CONTINUE
48361 IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
48362 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
48363 NJET=-2
48364 RETURN
48365 ENDIF
48366 NC=NC+1
48367 K(NC,3)=IETPH
48368 K(NC,4)=1
48369 K(NC,5)=2
48370 P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
48371 P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
48372 P(NC,5)=PT
48373 110 CONTINUE
48374
48375C...Smear true bin content by calorimeter resolution.
48376 IF(MSTU(53).GE.1) THEN
48377 DO 130 IC=N+1,NC
48378 PEI=P(IC,5)
48379 IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1))
48380 120 PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)*
48381 & COS(PARU(2)*PYR(0))
48382 IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120
48383 P(IC,5)=PEF
48384 IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
48385 130 CONTINUE
48386 ENDIF
48387
48388C...Remove cells below threshold.
48389 IF(PARU(58).GT.0D0) THEN
48390 NCC=NC
48391 NC=N
48392 DO 140 IC=N+1,NCC
48393 IF(P(IC,5).GT.PARU(58)) THEN
48394 NC=NC+1
48395 K(NC,3)=K(IC,3)
48396 K(NC,4)=K(IC,4)
48397 K(NC,5)=K(IC,5)
48398 P(NC,1)=P(IC,1)
48399 P(NC,2)=P(IC,2)
48400 P(NC,5)=P(IC,5)
48401 ENDIF
48402 140 CONTINUE
48403 ENDIF
48404
48405C...Find initiator cell: the one with highest pT of not yet used ones.
48406 NJ=NC
48407 150 ETMAX=0D0
48408 DO 160 IC=N+1,NC
48409 IF(K(IC,5).NE.2) GOTO 160
48410 IF(P(IC,5).LE.ETMAX) GOTO 160
48411 ICMAX=IC
48412 ETA=P(IC,1)
48413 PHI=P(IC,2)
48414 ETMAX=P(IC,5)
48415 160 CONTINUE
48416 IF(ETMAX.LT.PARU(52)) GOTO 220
48417 IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
48418 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
48419 NJET=-2
48420 RETURN
48421 ENDIF
48422 K(ICMAX,5)=1
48423 NJ=NJ+1
48424 K(NJ,4)=0
48425 K(NJ,5)=1
48426 P(NJ,1)=ETA
48427 P(NJ,2)=PHI
48428 P(NJ,3)=0D0
48429 P(NJ,4)=0D0
48430 P(NJ,5)=0D0
48431
48432C...Sum up unused cells within required distance of initiator.
48433 DO 170 IC=N+1,NC
48434 IF(K(IC,5).EQ.0) GOTO 170
48435 IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
48436 DPHIA=ABS(P(IC,2)-PHI)
48437 IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
48438 PHIC=P(IC,2)
48439 IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
48440 IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170
48441 K(IC,5)=-K(IC,5)
48442 K(NJ,4)=K(NJ,4)+K(IC,4)
48443 P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
48444 P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
48445 P(NJ,5)=P(NJ,5)+P(IC,5)
48446 170 CONTINUE
48447
48448C...Reject cluster below minimum ET, else accept.
48449 IF(P(NJ,5).LT.PARU(53)) THEN
48450 NJ=NJ-1
48451 DO 180 IC=N+1,NC
48452 IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
48453 180 CONTINUE
48454 ELSEIF(MSTU(54).LE.2) THEN
48455 P(NJ,3)=P(NJ,3)/P(NJ,5)
48456 P(NJ,4)=P(NJ,4)/P(NJ,5)
48457 IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
48458 & P(NJ,4))
48459 DO 190 IC=N+1,NC
48460 IF(K(IC,5).LT.0) K(IC,5)=0
48461 190 CONTINUE
48462 ELSE
48463 DO 200 J=1,4
48464 P(NJ,J)=0D0
48465 200 CONTINUE
48466 DO 210 IC=N+1,NC
48467 IF(K(IC,5).GE.0) GOTO 210
48468 P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
48469 P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
48470 P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
48471 P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
48472 K(IC,5)=0
48473 210 CONTINUE
48474 ENDIF
48475 GOTO 150
48476
48477C...Arrange clusters in falling ET sequence.
48478 220 DO 250 I=1,NJ-NC
48479 ETMAX=0D0
48480 DO 230 IJ=NC+1,NJ
48481 IF(K(IJ,5).EQ.0) GOTO 230
48482 IF(P(IJ,5).LT.ETMAX) GOTO 230
48483 IJMAX=IJ
48484 ETMAX=P(IJ,5)
48485 230 CONTINUE
48486 K(IJMAX,5)=0
48487 K(N+I,1)=31
48488 K(N+I,2)=98
48489 K(N+I,3)=I
48490 K(N+I,4)=K(IJMAX,4)
48491 K(N+I,5)=0
48492 DO 240 J=1,5
48493 P(N+I,J)=P(IJMAX,J)
48494 V(N+I,J)=0D0
48495 240 CONTINUE
48496 250 CONTINUE
48497 NJET=NJ-NC
48498
48499C...Convert to massless or massive four-vectors.
48500 IF(MSTU(54).EQ.2) THEN
48501 DO 260 I=N+1,N+NJET
48502 ETA=P(I,3)
48503 P(I,1)=P(I,5)*COS(P(I,4))
48504 P(I,2)=P(I,5)*SIN(P(I,4))
48505 P(I,3)=P(I,5)*SINH(ETA)
48506 P(I,4)=P(I,5)*COSH(ETA)
48507 P(I,5)=0D0
48508 260 CONTINUE
48509 ELSEIF(MSTU(54).GE.3) THEN
48510 DO 270 I=N+1,N+NJET
48511 P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
48512 270 CONTINUE
48513 ENDIF
48514
48515C...Information about storage.
48516 MSTU(61)=N+1
48517 MSTU(62)=NP
48518 MSTU(63)=NC-N
48519 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
48520 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
48521
48522 RETURN
48523 END
48524
48525C*********************************************************************
48526
48527C...PYJMAS
48528C...Determines, approximately, the two jet masses that minimize
48529C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
48530
48531 SUBROUTINE PYJMAS(PMH,PML)
48532
48533C...Double precision and integer declarations.
48534 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48535 IMPLICIT INTEGER(I-N)
48536 INTEGER PYK,PYCHGE,PYCOMP
48537C...Commonblocks.
48538 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
48539 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48540 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48541 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
48542C...Local arrays.
48543 DIMENSION SM(3,3),SAX(3),PS(3,5)
48544
48545C...Reset.
48546 NP=0
48547 DO 120 J1=1,3
48548 DO 100 J2=J1,3
48549 SM(J1,J2)=0D0
48550 100 CONTINUE
48551 DO 110 J2=1,4
48552 PS(J1,J2)=0D0
48553 110 CONTINUE
48554 120 CONTINUE
48555 PSS=0D0
48556 PIMASS=PMAS(PYCOMP(211),1)
48557
48558C...Take copy of particles that are to be considered in mass analysis.
48559 DO 170 I=1,N
48560 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
48561 IF(MSTU(41).GE.2) THEN
48562 KC=PYCOMP(K(I,2))
48563 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
48564 & KC.EQ.18) GOTO 170
48565 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
48566 & GOTO 170
48567 ENDIF
48568 IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
48569 CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS')
48570 PMH=-2D0
48571 PML=-2D0
48572 RETURN
48573 ENDIF
48574 NP=NP+1
48575 DO 130 J=1,5
48576 P(N+NP,J)=P(I,J)
48577 130 CONTINUE
48578 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
48579 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
48580 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
48581
48582C...Fill information in sphericity tensor and total momentum vector.
48583 DO 150 J1=1,3
48584 DO 140 J2=J1,3
48585 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
48586 140 CONTINUE
48587 150 CONTINUE
48588 PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
48589 DO 160 J=1,4
48590 PS(3,J)=PS(3,J)+P(N+NP,J)
48591 160 CONTINUE
48592 170 CONTINUE
48593
48594C...Very low multiplicities (0 or 1) not considered.
48595 IF(NP.LE.1) THEN
48596 CALL PYERRM(8,'(PYJMAS:) too few particles for analysis')
48597 PMH=-1D0
48598 PML=-1D0
48599 RETURN
48600 ENDIF
48601 PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-
48602 &PS(3,3)**2))
48603
48604C...Find largest eigenvalue to matrix (third degree equation).
48605 DO 190 J1=1,3
48606 DO 180 J2=J1,3
48607 SM(J1,J2)=SM(J1,J2)/PSS
48608 180 CONTINUE
48609 190 CONTINUE
48610 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
48611 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
48612 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
48613 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
48614 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
48615 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
48616 SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
48617
48618C...Find largest eigenvector by solving equation system.
48619 DO 210 J1=1,3
48620 SM(J1,J1)=SM(J1,J1)-SMA
48621 DO 200 J2=J1+1,3
48622 SM(J2,J1)=SM(J1,J2)
48623 200 CONTINUE
48624 210 CONTINUE
48625 SMAX=0D0
48626 DO 230 J1=1,3
48627 DO 220 J2=1,3
48628 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
48629 JA=J1
48630 JB=J2
48631 SMAX=ABS(SM(J1,J2))
48632 220 CONTINUE
48633 230 CONTINUE
48634 SMAX=0D0
48635 DO 250 J3=JA+1,JA+2
48636 J1=J3-3*((J3-1)/3)
48637 RL=SM(J1,JB)/SM(JA,JB)
48638 DO 240 J2=1,3
48639 SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
48640 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
48641 JC=J1
48642 SMAX=ABS(SM(J1,J2))
48643 240 CONTINUE
48644 250 CONTINUE
48645 JB1=JB+1-3*(JB/3)
48646 JB2=JB+2-3*((JB+1)/3)
48647 SAX(JB1)=-SM(JC,JB2)
48648 SAX(JB2)=SM(JC,JB1)
48649 SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
48650
48651C...Divide particles into two initial clusters by hemisphere.
48652 DO 270 I=N+1,N+NP
48653 PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
48654 IS=1
48655 IF(PSAX.LT.0D0) IS=2
48656 K(I,3)=IS
48657 DO 260 J=1,4
48658 PS(IS,J)=PS(IS,J)+P(I,J)
48659 260 CONTINUE
48660 270 CONTINUE
48661 PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
48662 &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
48663
48664C...Reassign one particle at a time; find maximum decrease of m^2 sum.
48665 280 PMD=0D0
48666 IM=0
48667 DO 290 J=1,4
48668 PS(3,J)=PS(1,J)-PS(2,J)
48669 290 CONTINUE
48670 DO 300 I=N+1,N+NP
48671 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)
48672 IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS)
48673 IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS)
48674 IF(PMDI.LT.PMD) THEN
48675 PMD=PMDI
48676 IM=I
48677 ENDIF
48678 300 CONTINUE
48679
48680C...Loop back if significant reduction in sum of m^2.
48681 IF(PMD.LT.-PARU(48)*PMS) THEN
48682 PMS=PMS+PMD
48683 IS=K(IM,3)
48684 DO 310 J=1,4
48685 PS(IS,J)=PS(IS,J)-P(IM,J)
48686 PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
48687 310 CONTINUE
48688 K(IM,3)=3-IS
48689 GOTO 280
48690 ENDIF
48691
48692C...Final masses and output.
48693 MSTU(61)=N+1
48694 MSTU(62)=NP
48695 PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
48696 PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
48697 PMH=MAX(PS(1,5),PS(2,5))
48698 PML=MIN(PS(1,5),PS(2,5))
48699
48700 RETURN
48701 END
48702
48703C*********************************************************************
48704
48705C...PYFOWO
48706C...Calculates the first few Fox-Wolfram moments.
48707
48708 SUBROUTINE PYFOWO(H10,H20,H30,H40)
48709
48710C...Double precision and integer declarations.
48711 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48712 IMPLICIT INTEGER(I-N)
48713 INTEGER PYK,PYCHGE,PYCOMP
48714C...Commonblocks.
48715 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
48716 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48717 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48718 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
48719
48720C...Copy momenta for particles and calculate H0.
48721 NP=0
48722 H0=0D0
48723 HD=0D0
48724 DO 110 I=1,N
48725 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
48726 IF(MSTU(41).GE.2) THEN
48727 KC=PYCOMP(K(I,2))
48728 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
48729 & KC.EQ.18) GOTO 110
48730 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
48731 & GOTO 110
48732 ENDIF
48733 IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
48734 CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS')
48735 H10=-1D0
48736 H20=-1D0
48737 H30=-1D0
48738 H40=-1D0
48739 RETURN
48740 ENDIF
48741 NP=NP+1
48742 DO 100 J=1,3
48743 P(N+NP,J)=P(I,J)
48744 100 CONTINUE
48745 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
48746 H0=H0+P(N+NP,4)
48747 HD=HD+P(N+NP,4)**2
48748 110 CONTINUE
48749 H0=H0**2
48750
48751C...Very low multiplicities (0 or 1) not considered.
48752 IF(NP.LE.1) THEN
48753 CALL PYERRM(8,'(PYFOWO:) too few particles for analysis')
48754 H10=-1D0
48755 H20=-1D0
48756 H30=-1D0
48757 H40=-1D0
48758 RETURN
48759 ENDIF
48760
48761C...Calculate H1 - H4.
48762 H10=0D0
48763 H20=0D0
48764 H30=0D0
48765 H40=0D0
48766 DO 130 I1=N+1,N+NP
48767 DO 120 I2=I1+1,N+NP
48768 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
48769 & (P(I1,4)*P(I2,4))
48770 H10=H10+P(I1,4)*P(I2,4)*CTHE
48771 H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0)
48772 H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE)
48773 H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+
48774 & 0.375D0)
48775 120 CONTINUE
48776 130 CONTINUE
48777
48778C...Calculate H1/H0 - H4/H0. Output.
48779 MSTU(61)=N+1
48780 MSTU(62)=NP
48781 H10=(HD+2D0*H10)/H0
48782 H20=(HD+2D0*H20)/H0
48783 H30=(HD+2D0*H30)/H0
48784 H40=(HD+2D0*H40)/H0
48785
48786 RETURN
48787 END
48788
48789C*********************************************************************
48790
48791C...PYTABU
48792C...Evaluates various properties of an event, with statistics
48793C...accumulated during the course of the run and
48794C...printed at the end.
48795
48796 SUBROUTINE PYTABU(MTABU)
48797
48798C...Double precision and integer declarations.
48799 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48800 IMPLICIT INTEGER(I-N)
48801 INTEGER PYK,PYCHGE,PYCOMP
48802C...Commonblocks.
48803 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
48804 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48805 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48806 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
48807 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
48808C...Local arrays, character variables, saved variables and data.
48809 DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
48810 &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
48811 &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
48812 &KFDM(8),KFDC(200,0:8),NPDC(200)
48813 SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
48814 &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
48815 &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
48816 CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
48817 DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
48818 &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/,
48819 &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/,
48820 &NEVDC/0/,NKFDC/0/,NREDC/0/
48821
48822C...Reset statistics on initial parton state.
48823 IF(MTABU.EQ.10) THEN
48824 NEVIS=0
48825 NKFIS=0
48826
48827C...Identify and order flavour content of initial state.
48828 ELSEIF(MTABU.EQ.11) THEN
48829 NEVIS=NEVIS+1
48830 KFM1=2*IABS(MSTU(161))
48831 IF(MSTU(161).GT.0) KFM1=KFM1-1
48832 KFM2=2*IABS(MSTU(162))
48833 IF(MSTU(162).GT.0) KFM2=KFM2-1
48834 KFMN=MIN(KFM1,KFM2)
48835 KFMX=MAX(KFM1,KFM2)
48836 DO 100 I=1,NKFIS
48837 IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
48838 IKFIS=-I
48839 GOTO 110
48840 ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
48841 & KFMX.LT.KFIS(I,2))) THEN
48842 IKFIS=I
48843 GOTO 110
48844 ENDIF
48845 100 CONTINUE
48846 IKFIS=NKFIS+1
48847 110 IF(IKFIS.LT.0) THEN
48848 IKFIS=-IKFIS
48849 ELSE
48850 IF(NKFIS.GE.100) RETURN
48851 DO 130 I=NKFIS,IKFIS,-1
48852 KFIS(I+1,1)=KFIS(I,1)
48853 KFIS(I+1,2)=KFIS(I,2)
48854 DO 120 J=0,10
48855 NPIS(I+1,J)=NPIS(I,J)
48856 120 CONTINUE
48857 130 CONTINUE
48858 NKFIS=NKFIS+1
48859 KFIS(IKFIS,1)=KFMN
48860 KFIS(IKFIS,2)=KFMX
48861 DO 140 J=0,10
48862 NPIS(IKFIS,J)=0
48863 140 CONTINUE
48864 ENDIF
48865 NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
48866
48867C...Count number of partons in initial state.
48868 NP=0
48869 DO 160 I=1,N
48870 IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
48871 ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
48872 ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
48873 & THEN
48874 ELSE
48875 IM=I
48876 150 IM=K(IM,3)
48877 IF(IM.LE.0.OR.IM.GT.N) THEN
48878 NP=NP+1
48879 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
48880 NP=NP+1
48881 ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
48882 ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10)
48883 & .NE.0) THEN
48884 ELSE
48885 GOTO 150
48886 ENDIF
48887 ENDIF
48888 160 CONTINUE
48889 NPCO=MAX(NP,1)
48890 IF(NP.GE.6) NPCO=6
48891 IF(NP.GE.8) NPCO=7
48892 IF(NP.GE.11) NPCO=8
48893 IF(NP.GE.16) NPCO=9
48894 IF(NP.GE.26) NPCO=10
48895 NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
48896 MSTU(62)=NP
48897
48898C...Write statistics on initial parton state.
48899 ELSEIF(MTABU.EQ.12) THEN
48900 FAC=1D0/MAX(1,NEVIS)
48901 WRITE(MSTU(11),5000) NEVIS
48902 DO 170 I=1,NKFIS
48903 KFMN=KFIS(I,1)
48904 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
48905 KFM1=(KFMN+1)/2
48906 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
48907 CALL PYNAME(KFM1,CHAU)
48908 CHIS(1)=CHAU(1:12)
48909 IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
48910 KFMX=KFIS(I,2)
48911 IF(KFIS(I,1).EQ.0) KFMX=0
48912 KFM2=(KFMX+1)/2
48913 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
48914 CALL PYNAME(KFM2,CHAU)
48915 CHIS(2)=CHAU(1:12)
48916 IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
48917 WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
48918 & (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10)
48919 170 CONTINUE
48920
48921C...Copy statistics on initial parton state into /PYJETS/.
48922 ELSEIF(MTABU.EQ.13) THEN
48923 FAC=1D0/MAX(1,NEVIS)
48924 DO 190 I=1,NKFIS
48925 KFMN=KFIS(I,1)
48926 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
48927 KFM1=(KFMN+1)/2
48928 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
48929 KFMX=KFIS(I,2)
48930 IF(KFIS(I,1).EQ.0) KFMX=0
48931 KFM2=(KFMX+1)/2
48932 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
48933 K(I,1)=32
48934 K(I,2)=99
48935 K(I,3)=KFM1
48936 K(I,4)=KFM2
48937 K(I,5)=NPIS(I,0)
48938 DO 180 J=1,5
48939 P(I,J)=FAC*NPIS(I,J)
48940 V(I,J)=FAC*NPIS(I,J+5)
48941 180 CONTINUE
48942 190 CONTINUE
48943 N=NKFIS
48944 DO 200 J=1,5
48945 K(N+1,J)=0
48946 P(N+1,J)=0D0
48947 V(N+1,J)=0D0
48948 200 CONTINUE
48949 K(N+1,1)=32
48950 K(N+1,2)=99
48951 K(N+1,5)=NEVIS
48952 MSTU(3)=1
48953
48954C...Reset statistics on number of particles/partons.
48955 ELSEIF(MTABU.EQ.20) THEN
48956 NEVFS=0
48957 NPRFS=0
48958 NFIFS=0
48959 NCHFS=0
48960 NKFFS=0
48961
48962C...Identify whether particle/parton is primary or not.
48963 ELSEIF(MTABU.EQ.21) THEN
48964 NEVFS=NEVFS+1
48965 MSTU(62)=0
48966 DO 260 I=1,N
48967 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260
48968 MSTU(62)=MSTU(62)+1
48969 KC=PYCOMP(K(I,2))
48970 MPRI=0
48971 IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
48972 MPRI=1
48973 ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
48974 MPRI=1
48975 ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
48976 MPRI=1
48977 ELSEIF(KC.EQ.0) THEN
48978 ELSEIF(K(K(I,3),1).EQ.13) THEN
48979 IM=K(K(I,3),3)
48980 IF(IM.LE.0.OR.IM.GT.N) THEN
48981 MPRI=1
48982 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
48983 MPRI=1
48984 ENDIF
48985 ELSEIF(KCHG(KC,2).EQ.0) THEN
48986 KCM=PYCOMP(K(K(I,3),2))
48987 IF(KCM.NE.0) THEN
48988 IF(KCHG(KCM,2).NE.0) MPRI=1
48989 ENDIF
48990 ENDIF
48991 IF(KC.NE.0.AND.MPRI.EQ.1) THEN
48992 IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
48993 ENDIF
48994 IF(K(I,1).LE.10) THEN
48995 NFIFS=NFIFS+1
48996 IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
48997 ENDIF
48998
48999C...Fill statistics on number of particles/partons in event.
49000 KFA=IABS(K(I,2))
49001 KFS=3-ISIGN(1,K(I,2))-MPRI
49002 DO 210 IP=1,NKFFS
49003 IF(KFA.EQ.KFFS(IP)) THEN
49004 IKFFS=-IP
49005 GOTO 220
49006 ELSEIF(KFA.LT.KFFS(IP)) THEN
49007 IKFFS=IP
49008 GOTO 220
49009 ENDIF
49010 210 CONTINUE
49011 IKFFS=NKFFS+1
49012 220 IF(IKFFS.LT.0) THEN
49013 IKFFS=-IKFFS
49014 ELSE
49015 IF(NKFFS.GE.400) RETURN
49016 DO 240 IP=NKFFS,IKFFS,-1
49017 KFFS(IP+1)=KFFS(IP)
49018 DO 230 J=1,4
49019 NPFS(IP+1,J)=NPFS(IP,J)
49020 230 CONTINUE
49021 240 CONTINUE
49022 NKFFS=NKFFS+1
49023 KFFS(IKFFS)=KFA
49024 DO 250 J=1,4
49025 NPFS(IKFFS,J)=0
49026 250 CONTINUE
49027 ENDIF
49028 NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
49029 260 CONTINUE
49030
49031C...Write statistics on particle/parton composition of events.
49032 ELSEIF(MTABU.EQ.22) THEN
49033 FAC=1D0/MAX(1,NEVFS)
49034 WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
49035 DO 270 I=1,NKFFS
49036 CALL PYNAME(KFFS(I),CHAU)
49037 KC=PYCOMP(KFFS(I))
49038 MDCYF=0
49039 IF(KC.NE.0) MDCYF=MDCY(KC,1)
49040 WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
49041 & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
49042 270 CONTINUE
49043
49044C...Copy particle/parton composition information into /PYJETS/.
49045 ELSEIF(MTABU.EQ.23) THEN
49046 FAC=1D0/MAX(1,NEVFS)
49047 DO 290 I=1,NKFFS
49048 K(I,1)=32
49049 K(I,2)=99
49050 K(I,3)=KFFS(I)
49051 K(I,4)=0
49052 K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
49053 DO 280 J=1,4
49054 P(I,J)=FAC*NPFS(I,J)
49055 V(I,J)=0D0
49056 280 CONTINUE
49057 P(I,5)=FAC*K(I,5)
49058 V(I,5)=0D0
49059 290 CONTINUE
49060 N=NKFFS
49061 DO 300 J=1,5
49062 K(N+1,J)=0
49063 P(N+1,J)=0D0
49064 V(N+1,J)=0D0
49065 300 CONTINUE
49066 K(N+1,1)=32
49067 K(N+1,2)=99
49068 K(N+1,5)=NEVFS
49069 P(N+1,1)=FAC*NPRFS
49070 P(N+1,2)=FAC*NFIFS
49071 P(N+1,3)=FAC*NCHFS
49072 MSTU(3)=1
49073
49074C...Reset factorial moments statistics.
49075 ELSEIF(MTABU.EQ.30) THEN
49076 NEVFM=0
49077 NMUFM=0
49078 DO 330 IM=1,3
49079 DO 320 IB=1,10
49080 DO 310 IP=1,4
49081 FM1FM(IM,IB,IP)=0D0
49082 FM2FM(IM,IB,IP)=0D0
49083 310 CONTINUE
49084 320 CONTINUE
49085 330 CONTINUE
49086
49087C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
49088 ELSEIF(MTABU.EQ.31) THEN
49089 NEVFM=NEVFM+1
49090 NLOW=N+MSTU(3)
49091 NUPP=NLOW
49092 DO 410 I=1,N
49093 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410
49094 IF(MSTU(41).GE.2) THEN
49095 KC=PYCOMP(K(I,2))
49096 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
49097 & KC.EQ.18) GOTO 410
49098 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
49099 & PYCHGE(K(I,2)).EQ.0) GOTO 410
49100 ENDIF
49101 PMR=0D0
49102 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
49103 IF(MSTU(42).GE.2) PMR=P(I,5)
49104 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
49105 YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
49106 & 1D20)),P(I,3))
49107 IF(ABS(YETA).GT.PARU(57)) GOTO 410
49108 PHI=PYANGL(P(I,1),P(I,2))
49109 IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57))
49110 IYETA=MAX(0,MIN(511,IYETA))
49111 IPHI=512D0*(PHI+PARU(1))/PARU(2)
49112 IPHI=MAX(0,MIN(511,IPHI))
49113 IYEP=0
49114 DO 340 IB=0,9
49115 IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
49116 340 CONTINUE
49117
49118C...Order particles in (pseudo)rapidity and/or azimuth.
49119 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
49120 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
49121 RETURN
49122 ENDIF
49123 NUPP=NUPP+1
49124 IF(NUPP.EQ.NLOW+1) THEN
49125 K(NUPP,1)=IYETA
49126 K(NUPP,2)=IPHI
49127 K(NUPP,3)=IYEP
49128 ELSE
49129 DO 350 I1=NUPP-1,NLOW+1,-1
49130 IF(IYETA.GE.K(I1,1)) GOTO 360
49131 K(I1+1,1)=K(I1,1)
49132 350 CONTINUE
49133 360 K(I1+1,1)=IYETA
49134 DO 370 I1=NUPP-1,NLOW+1,-1
49135 IF(IPHI.GE.K(I1,2)) GOTO 380
49136 K(I1+1,2)=K(I1,2)
49137 370 CONTINUE
49138 380 K(I1+1,2)=IPHI
49139 DO 390 I1=NUPP-1,NLOW+1,-1
49140 IF(IYEP.GE.K(I1,3)) GOTO 400
49141 K(I1+1,3)=K(I1,3)
49142 390 CONTINUE
49143 400 K(I1+1,3)=IYEP
49144 ENDIF
49145 410 CONTINUE
49146 K(NUPP+1,1)=2**10
49147 K(NUPP+1,2)=2**10
49148 K(NUPP+1,3)=4**10
49149
49150C...Calculate sum of factorial moments in event.
49151 DO 480 IM=1,3
49152 DO 430 IB=1,10
49153 DO 420 IP=1,4
49154 FEVFM(IB,IP)=0D0
49155 420 CONTINUE
49156 430 CONTINUE
49157 DO 450 IB=1,10
49158 IF(IM.LE.2) IBIN=2**(10-IB)
49159 IF(IM.EQ.3) IBIN=4**(10-IB)
49160 IAGR=K(NLOW+1,IM)/IBIN
49161 NAGR=1
49162 DO 440 I=NLOW+2,NUPP+1
49163 ICUT=K(I,IM)/IBIN
49164 IF(ICUT.EQ.IAGR) THEN
49165 NAGR=NAGR+1
49166 ELSE
49167 IF(NAGR.EQ.1) THEN
49168 ELSEIF(NAGR.EQ.2) THEN
49169 FEVFM(IB,1)=FEVFM(IB,1)+2D0
49170 ELSEIF(NAGR.EQ.3) THEN
49171 FEVFM(IB,1)=FEVFM(IB,1)+6D0
49172 FEVFM(IB,2)=FEVFM(IB,2)+6D0
49173 ELSEIF(NAGR.EQ.4) THEN
49174 FEVFM(IB,1)=FEVFM(IB,1)+12D0
49175 FEVFM(IB,2)=FEVFM(IB,2)+24D0
49176 FEVFM(IB,3)=FEVFM(IB,3)+24D0
49177 ELSE
49178 FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0)
49179 FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0)
49180 FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
49181 & (NAGR-3D0)
49182 FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
49183 & (NAGR-3D0)*(NAGR-4D0)
49184 ENDIF
49185 IAGR=ICUT
49186 NAGR=1
49187 ENDIF
49188 440 CONTINUE
49189 450 CONTINUE
49190
49191C...Add results to total statistics.
49192 DO 470 IB=10,1,-1
49193 DO 460 IP=1,4
49194 IF(FEVFM(1,IP).LT.0.5D0) THEN
49195 FEVFM(IB,IP)=0D0
49196 ELSEIF(IM.LE.2) THEN
49197 FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
49198 ELSE
49199 FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
49200 ENDIF
49201 FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
49202 FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
49203 460 CONTINUE
49204 470 CONTINUE
49205 480 CONTINUE
49206 NMUFM=NMUFM+(NUPP-NLOW)
49207 MSTU(62)=NUPP-NLOW
49208
49209C...Write accumulated statistics on factorial moments.
49210 ELSEIF(MTABU.EQ.32) THEN
49211 FAC=1D0/MAX(1,NEVFM)
49212 IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
49213 IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
49214 IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y '
49215 DO 510 IM=1,3
49216 WRITE(MSTU(11),5500)
49217 DO 500 IB=1,10
49218 BYETA=2D0*PARU(57)
49219 IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
49220 BPHI=PARU(2)
49221 IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
49222 IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1))
49223 IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1))
49224 DO 490 IP=1,4
49225 FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
49226 FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
49227 & FMOMA(IP)**2)))
49228 490 CONTINUE
49229 WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
49230 & IP=1,4)
49231 500 CONTINUE
49232 510 CONTINUE
49233
49234C...Copy statistics on factorial moments into /PYJETS/.
49235 ELSEIF(MTABU.EQ.33) THEN
49236 FAC=1D0/MAX(1,NEVFM)
49237 DO 540 IM=1,3
49238 DO 530 IB=1,10
49239 I=10*(IM-1)+IB
49240 K(I,1)=32
49241 K(I,2)=99
49242 K(I,3)=1
49243 IF(IM.NE.2) K(I,3)=2**(IB-1)
49244 K(I,4)=1
49245 IF(IM.NE.1) K(I,4)=2**(IB-1)
49246 K(I,5)=0
49247 P(I,1)=2D0*PARU(57)/K(I,3)
49248 V(I,1)=PARU(2)/K(I,4)
49249 DO 520 IP=1,4
49250 P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
49251 V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
49252 & P(I,IP+1)**2)))
49253 520 CONTINUE
49254 530 CONTINUE
49255 540 CONTINUE
49256 N=30
49257 DO 550 J=1,5
49258 K(N+1,J)=0
49259 P(N+1,J)=0D0
49260 V(N+1,J)=0D0
49261 550 CONTINUE
49262 K(N+1,1)=32
49263 K(N+1,2)=99
49264 K(N+1,5)=NEVFM
49265 MSTU(3)=1
49266
49267C...Reset statistics on Energy-Energy Correlation.
49268 ELSEIF(MTABU.EQ.40) THEN
49269 NEVEE=0
49270 DO 560 J=1,25
49271 FE1EC(J)=0D0
49272 FE2EC(J)=0D0
49273 FE1EC(51-J)=0D0
49274 FE2EC(51-J)=0D0
49275 FE1EA(J)=0D0
49276 FE2EA(J)=0D0
49277 560 CONTINUE
49278
49279C...Find particles to include, with proper assumed mass.
49280 ELSEIF(MTABU.EQ.41) THEN
49281 NEVEE=NEVEE+1
49282 NLOW=N+MSTU(3)
49283 NUPP=NLOW
49284 ECM=0D0
49285 DO 570 I=1,N
49286 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570
49287 IF(MSTU(41).GE.2) THEN
49288 KC=PYCOMP(K(I,2))
49289 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
49290 & KC.EQ.18) GOTO 570
49291 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
49292 & PYCHGE(K(I,2)).EQ.0) GOTO 570
49293 ENDIF
49294 PMR=0D0
49295 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
49296 IF(MSTU(42).GE.2) PMR=P(I,5)
49297 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
49298 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
49299 RETURN
49300 ENDIF
49301 NUPP=NUPP+1
49302 P(NUPP,1)=P(I,1)
49303 P(NUPP,2)=P(I,2)
49304 P(NUPP,3)=P(I,3)
49305 P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
49306 P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
49307 ECM=ECM+P(NUPP,4)
49308 570 CONTINUE
49309 IF(NUPP.EQ.NLOW) RETURN
49310
49311C...Analyze Energy-Energy Correlation in event.
49312 FAC=(2D0/ECM**2)*50D0/PARU(1)
49313 DO 580 J=1,50
49314 FEVEE(J)=0D0
49315 580 CONTINUE
49316 DO 600 I1=NLOW+2,NUPP
49317 DO 590 I2=NLOW+1,I1-1
49318 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
49319 & (P(I1,5)*P(I2,5))
49320 THE=ACOS(MAX(-1D0,MIN(1D0,CTHE)))
49321 ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1))))
49322 FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
49323 590 CONTINUE
49324 600 CONTINUE
49325 DO 610 J=1,25
49326 FE1EC(J)=FE1EC(J)+FEVEE(J)
49327 FE2EC(J)=FE2EC(J)+FEVEE(J)**2
49328 FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
49329 FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
49330 FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
49331 FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
49332 610 CONTINUE
49333 MSTU(62)=NUPP-NLOW
49334
49335C...Write statistics on Energy-Energy Correlation.
49336 ELSEIF(MTABU.EQ.42) THEN
49337 FAC=1D0/MAX(1,NEVEE)
49338 WRITE(MSTU(11),5700) NEVEE
49339 DO 620 J=1,25
49340 FEEC1=FAC*FE1EC(J)
49341 FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2)))
49342 FEEC2=FAC*FE1EC(51-J)
49343 FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
49344 FEECA=FAC*FE1EA(J)
49345 FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2)))
49346 WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1,
49347 & FEEC2,FEES2,FEECA,FEESA
49348 620 CONTINUE
49349
49350C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
49351 ELSEIF(MTABU.EQ.43) THEN
49352 FAC=1D0/MAX(1,NEVEE)
49353 DO 630 I=1,25
49354 K(I,1)=32
49355 K(I,2)=99
49356 K(I,3)=0
49357 K(I,4)=0
49358 K(I,5)=0
49359 P(I,1)=FAC*FE1EC(I)
49360 V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
49361 P(I,2)=FAC*FE1EC(51-I)
49362 V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
49363 P(I,3)=FAC*FE1EA(I)
49364 V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
49365 P(I,4)=PARU(1)*(I-1)/50D0
49366 P(I,5)=PARU(1)*I/50D0
49367 V(I,4)=3.6D0*(I-1)
49368 V(I,5)=3.6D0*I
49369 630 CONTINUE
49370 N=25
49371 DO 640 J=1,5
49372 K(N+1,J)=0
49373 P(N+1,J)=0D0
49374 V(N+1,J)=0D0
49375 640 CONTINUE
49376 K(N+1,1)=32
49377 K(N+1,2)=99
49378 K(N+1,5)=NEVEE
49379 MSTU(3)=1
49380
49381C...Reset statistics on decay channels.
49382 ELSEIF(MTABU.EQ.50) THEN
49383 NEVDC=0
49384 NKFDC=0
49385 NREDC=0
49386
49387C...Identify and order flavour content of final state.
49388 ELSEIF(MTABU.EQ.51) THEN
49389 NEVDC=NEVDC+1
49390 NDS=0
49391 DO 670 I=1,N
49392 IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
49393 NDS=NDS+1
49394 IF(NDS.GT.8) THEN
49395 NREDC=NREDC+1
49396 RETURN
49397 ENDIF
49398 KFM=2*IABS(K(I,2))
49399 IF(K(I,2).LT.0) KFM=KFM-1
49400 DO 650 IDS=NDS-1,1,-1
49401 IIN=IDS+1
49402 IF(KFM.LT.KFDM(IDS)) GOTO 660
49403 KFDM(IDS+1)=KFDM(IDS)
49404 650 CONTINUE
49405 IIN=1
49406 660 KFDM(IIN)=KFM
49407 670 CONTINUE
49408
49409C...Find whether old or new final state.
49410 DO 690 IDC=1,NKFDC
49411 IF(NDS.LT.KFDC(IDC,0)) THEN
49412 IKFDC=IDC
49413 GOTO 700
49414 ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
49415 DO 680 I=1,NDS
49416 IF(KFDM(I).LT.KFDC(IDC,I)) THEN
49417 IKFDC=IDC
49418 GOTO 700
49419 ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
49420 GOTO 690
49421 ENDIF
49422 680 CONTINUE
49423 IKFDC=-IDC
49424 GOTO 700
49425 ENDIF
49426 690 CONTINUE
49427 IKFDC=NKFDC+1
49428 700 IF(IKFDC.LT.0) THEN
49429 IKFDC=-IKFDC
49430 ELSEIF(NKFDC.GE.200) THEN
49431 NREDC=NREDC+1
49432 RETURN
49433 ELSE
49434 DO 720 IDC=NKFDC,IKFDC,-1
49435 NPDC(IDC+1)=NPDC(IDC)
49436 DO 710 I=0,8
49437 KFDC(IDC+1,I)=KFDC(IDC,I)
49438 710 CONTINUE
49439 720 CONTINUE
49440 NKFDC=NKFDC+1
49441 KFDC(IKFDC,0)=NDS
49442 DO 730 I=1,NDS
49443 KFDC(IKFDC,I)=KFDM(I)
49444 730 CONTINUE
49445 NPDC(IKFDC)=0
49446 ENDIF
49447 NPDC(IKFDC)=NPDC(IKFDC)+1
49448
49449C...Write statistics on decay channels.
49450 ELSEIF(MTABU.EQ.52) THEN
49451 FAC=1D0/MAX(1,NEVDC)
49452 WRITE(MSTU(11),5900) NEVDC
49453 DO 750 IDC=1,NKFDC
49454 DO 740 I=1,KFDC(IDC,0)
49455 KFM=KFDC(IDC,I)
49456 KF=(KFM+1)/2
49457 IF(2*KF.NE.KFM) KF=-KF
49458 CALL PYNAME(KF,CHAU)
49459 CHDC(I)=CHAU(1:12)
49460 IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
49461 740 CONTINUE
49462 WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
49463 750 CONTINUE
49464 IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
49465
49466C...Copy statistics on decay channels into /PYJETS/.
49467 ELSEIF(MTABU.EQ.53) THEN
49468 FAC=1D0/MAX(1,NEVDC)
49469 DO 780 IDC=1,NKFDC
49470 K(IDC,1)=32
49471 K(IDC,2)=99
49472 K(IDC,3)=0
49473 K(IDC,4)=0
49474 K(IDC,5)=KFDC(IDC,0)
49475 DO 760 J=1,5
49476 P(IDC,J)=0D0
49477 V(IDC,J)=0D0
49478 760 CONTINUE
49479 DO 770 I=1,KFDC(IDC,0)
49480 KFM=KFDC(IDC,I)
49481 KF=(KFM+1)/2
49482 IF(2*KF.NE.KFM) KF=-KF
49483 IF(I.LE.5) P(IDC,I)=KF
49484 IF(I.GE.6) V(IDC,I-5)=KF
49485 770 CONTINUE
49486 V(IDC,5)=FAC*NPDC(IDC)
49487 780 CONTINUE
49488 N=NKFDC
49489 DO 790 J=1,5
49490 K(N+1,J)=0
49491 P(N+1,J)=0D0
49492 V(N+1,J)=0D0
49493 790 CONTINUE
49494 K(N+1,1)=32
49495 K(N+1,2)=99
49496 K(N+1,5)=NEVDC
49497 V(N+1,5)=FAC*NREDC
49498 MSTU(3)=1
49499 ENDIF
49500
49501C...Format statements for output on unit MSTU(11) (default 6).
49502 5000 FORMAT(///20X,'Event statistics - initial state'/
49503 &20X,'based on an analysis of ',I6,' events'//
49504 &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
49505 &'according to fragmenting system multiplicity'/
49506 &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
49507 &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
49508 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
49509 5200 FORMAT(///20X,'Event statistics - final state'/
49510 &20X,'based on an analysis of ',I7,' events'//
49511 &5X,'Mean primary multiplicity =',F10.4/
49512 &5X,'Mean final multiplicity =',F10.4/
49513 &5X,'Mean charged multiplicity =',F10.4//
49514 &5X,'Number of particles produced per event (directly and via ',
49515 &'decays/branchings)'/
49516 &8X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles',
49517 &8X,'Total'/35X,'prim seco prim seco'/)
49518 5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6))
49519 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
49520 &20X,'based on an analysis of ',I6,' events'//
49521 &3X,'delta-',A3,' delta-phi <n>/bin',10X,'<F2>',18X,'<F3>',
49522 &18X,'<F4>',18X,'<F5>'/35X,4(' value error '))
49523 5500 FORMAT(10X)
49524 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
49525 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
49526 &20X,'based on an analysis of ',I6,' events'//
49527 &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
49528 &'EECA(theta)'/2X,'in degrees ',3(' value error')/)
49529 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
49530 5900 FORMAT(///20X,'Decay channel analysis - final state'/
49531 &20X,'based on an analysis of ',I6,' events'//
49532 &2X,'Probability',10X,'Complete final state'/)
49533 6000 FORMAT(2X,F9.5,5X,8(A12,1X))
49534 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
49535 &'or table overflow)')
49536
49537 RETURN
49538 END
49539
49540C*********************************************************************
49541
49542C...PYEEVT
49543C...Handles the generation of an e+e- annihilation jet event.
49544
49545 SUBROUTINE PYEEVT(KFL,ECM)
49546
49547C...Double precision and integer declarations.
49548 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49549 IMPLICIT INTEGER(I-N)
49550 INTEGER PYK,PYCHGE,PYCOMP
49551C...Commonblocks.
49552 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
49553 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49554 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49555 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
49556
49557C...Check input parameters.
49558 IF(MSTU(12).GE.1) CALL PYLIST(0)
49559 IF(KFL.LT.0.OR.KFL.GT.8) THEN
49560 CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code')
49561 IF(MSTU(21).GE.1) RETURN
49562 ENDIF
49563 IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL))
49564 IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1)
49565 IF(ECM.LT.ECMMIN) THEN
49566 CALL PYERRM(16,'(PYEEVT:) called with too small CM energy')
49567 IF(MSTU(21).GE.1) RETURN
49568 ENDIF
49569
49570C...Check consistency of MSTJ options set.
49571 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
49572 CALL PYERRM(6,
49573 & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
49574 MSTJ(110)=1
49575 ENDIF
49576 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
49577 CALL PYERRM(6,
49578 & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
49579 MSTJ(111)=0
49580 ENDIF
49581
49582C...Initialize alpha_strong and total cross-section.
49583 MSTU(111)=MSTJ(108)
49584 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
49585 &MSTU(111)=1
49586 PARU(112)=PARJ(121)
49587 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
49588 IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
49589 &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM,
49590 &XTOT)
49591 IF(MSTJ(116).GE.3) MSTJ(116)=1
49592 PARJ(171)=0D0
49593
49594C...Add initial e+e- to event record (documentation only).
49595 NTRY=0
49596 100 NTRY=NTRY+1
49597 IF(NTRY.GT.100) THEN
49598 CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop')
49599 RETURN
49600 ENDIF
49601 MSTU(24)=0
49602 NC=0
49603 IF(MSTJ(115).GE.2) THEN
49604 NC=NC+2
49605 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
49606 K(NC-1,1)=21
49607 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
49608 K(NC,1)=21
49609 ENDIF
49610
49611C...Radiative photon (in initial state).
49612 MK=0
49613 ECMC=ECM
49614 IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK,
49615 &THEK,PHIK,ALPK)
49616 IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2D0*PAK))
49617 IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
49618 NC=NC+1
49619 CALL PY1ENT(NC,22,PAK,THEK,PHIK)
49620 K(NC,3)=MIN(MSTJ(115)/2,1)
49621 ENDIF
49622
49623C...Virtual exchange boson (gamma or Z0).
49624 IF(MSTJ(115).GE.3) THEN
49625 NC=NC+1
49626 KF=22
49627 IF(MSTJ(102).EQ.2) KF=23
49628 MSTU10=MSTU(10)
49629 MSTU(10)=1
49630 P(NC,5)=ECMC
49631 CALL PY1ENT(NC,KF,ECMC,0D0,0D0)
49632 K(NC,1)=21
49633 K(NC,3)=1
49634 MSTU(10)=MSTU10
49635 ENDIF
49636
49637C...Choice of flavour and jet configuration.
49638 CALL PYXKFL(KFL,ECM,ECMC,KFLC)
49639 IF(KFLC.EQ.0) GOTO 100
49640 CALL PYXJET(ECMC,NJET,CUT)
49641 KFLN=21
49642 IF(NJET.EQ.4) CALL PYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
49643 &X12,X14)
49644 IF(NJET.EQ.3) CALL PYX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
49645 IF(NJET.EQ.2) MSTJ(120)=1
49646
49647C...Fill jet configuration and origin.
49648 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL PY2ENT(NC+1,KFLC,-KFLC,ECMC)
49649 IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL PY2ENT(-(NC+1),KFLC,-KFLC,
49650 &ECMC)
49651 IF(NJET.EQ.3) CALL PY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
49652 IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,
49653 &-KFLC,ECMC,X1,X2,X4,X12,X14)
49654 IF(NJET.EQ.4.AND.KFLN.NE.21) CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,
49655 &-KFLC,ECMC,X1,X2,X4,X12,X14)
49656 IF(MSTU(24).NE.0) GOTO 100
49657 DO 110 IP=NC+1,N
49658 K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
49659 110 CONTINUE
49660
49661C...Angular orientation according to matrix element.
49662 IF(MSTJ(106).EQ.1) THEN
49663 CALL PYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
49664 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
49665 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
49666 ENDIF
49667
49668C...Rotation and boost from radiative photon.
49669 IF(MK.EQ.1) THEN
49670 DBEK=-PAK/(ECM-PAK)
49671 NMIN=NC+1-MSTJ(115)/3
49672 CALL PYROBO(NMIN,N,0D0,-PHIK,0D0,0D0,0D0)
49673 CALL PYROBO(NMIN,N,ALPK,0D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
49674 CALL PYROBO(NMIN,N,0D0,PHIK,0D0,0D0,0D0)
49675 ENDIF
49676
49677C...Generate parton shower. Rearrange along strings and check.
49678 IF(MSTJ(101).EQ.5) THEN
49679 CALL PYSHOW(N-1,N,ECMC)
49680 MSTJ14=MSTJ(14)
49681 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
49682 IF(MSTJ(105).GE.0) MSTU(28)=0
49683 CALL PYPREP(0)
49684 MSTJ(14)=MSTJ14
49685 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
49686 ENDIF
49687
49688C...Fragmentation/decay generation. Information for PYTABU.
49689 IF(MSTJ(105).EQ.1) CALL PYEXEC
49690 MSTU(161)=KFLC
49691 MSTU(162)=-KFLC
49692
49693 RETURN
49694 END
49695
49696C*********************************************************************
49697
49698C...PYXTEE
49699C...Calculates total cross-section, including initial state
49700C...radiation effects.
49701
49702 SUBROUTINE PYXTEE(KFL,ECM,XTOT)
49703
49704C...Double precision and integer declarations.
49705 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49706 IMPLICIT INTEGER(I-N)
49707 INTEGER PYK,PYCHGE,PYCOMP
49708C...Commonblocks.
49709 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49710 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49711 SAVE /PYDAT1/,/PYDAT2/
49712
49713C...Status, (optimized) Q^2 scale, alpha_strong.
49714 PARJ(151)=ECM
49715 MSTJ(119)=10*MSTJ(102)+KFL
49716 IF(MSTJ(111).EQ.0) THEN
49717 Q2R=ECM**2
49718 ELSEIF(MSTU(111).EQ.0) THEN
49719 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
49720 & ((33D0-2D0*MSTU(112))*PARU(111)))))
49721 Q2R=PARJ(168)*ECM**2
49722 ELSE
49723 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
49724 & (2D0*PARU(112)/ECM)**2))
49725 Q2R=PARJ(168)*ECM**2
49726 ENDIF
49727 ALSPI=PYALPS(Q2R)/PARU(1)
49728
49729C...QCD corrections factor in R.
49730 IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
49731 RQCD=1D0
49732 ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
49733 RQCD=1D0+ALSPI
49734 ELSEIF(MSTJ(109).EQ.0) THEN
49735 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
49736 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0*
49737 & LOG(PARJ(168))*ALSPI**2)
49738 ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
49739 RQCD=1D0+(3D0/4D0)*ALSPI
49740 ELSE
49741 RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2
49742 ENDIF
49743
49744C...Calculate Z0 width if default value not acceptable.
49745 IF(MSTJ(102).GE.3) THEN
49746 RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+
49747 & (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2)
49748 DO 100 KFLC=5,6
49749 VQ=1D0
49750 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-
49751 & (2D0*PYMASS(KFLC)/ ECM)**2))
49752 IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0
49753 IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0
49754 RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3)
49755 100 CONTINUE
49756 PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)*
49757 & (1D0-PARU(102)))
49758 ENDIF
49759
49760C...Calculate propagator and related constants for QFD case.
49761 POLL=1D0-PARJ(131)*PARJ(132)
49762 IF(MSTJ(102).GE.2) THEN
49763 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
49764 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
49765 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
49766 VE=4D0*PARU(102)-1D0
49767 SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
49768 SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
49769 HF1I=SFI*SF1I
49770 HF1W=SFW*SF1W
49771 ENDIF
49772
49773C...Loop over different flavours: charge, velocity.
49774 RTOT=0D0
49775 RQQ=0D0
49776 RQV=0D0
49777 RVA=0D0
49778 DO 110 KFLC=1,MAX(MSTJ(104),KFL)
49779 IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
49780 MSTJ(93)=1
49781 PMQ=PYMASS(KFLC)
49782 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110
49783 QF=KCHG(KFLC,1)/3D0
49784 VQ=1D0
49785 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2)
49786
49787C...Calculate R and sum of charges for QED or QFD case.
49788 RQQ=RQQ+3D0*QF**2*POLL
49789 IF(MSTJ(102).LE.1) THEN
49790 RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL
49791 ELSE
49792 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
49793 RQV=RQV-6D0*QF*VF*SF1I
49794 RVA=RVA+3D0*(VF**2+1D0)*SF1W
49795 RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-
49796 & 2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W)
49797 ENDIF
49798 110 CONTINUE
49799 RSUM=RQQ
49800 IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
49801
49802C...Calculate cross-section, including QCD corrections.
49803 PARJ(141)=RQQ
49804 PARJ(142)=RTOT
49805 PARJ(143)=RTOT*RQCD
49806 PARJ(144)=PARJ(143)
49807 PARJ(145)=PARJ(141)*86.8D0/ECM**2
49808 PARJ(146)=PARJ(142)*86.8D0/ECM**2
49809 PARJ(147)=PARJ(143)*86.8D0/ECM**2
49810 PARJ(148)=PARJ(147)
49811 PARJ(157)=RSUM*RQCD
49812 PARJ(158)=0D0
49813 PARJ(159)=0D0
49814 XTOT=PARJ(147)
49815 IF(MSTJ(107).LE.0) RETURN
49816
49817C...Virtual cross-section.
49818 XKL=PARJ(135)
49819 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
49820 ALE=2D0*LOG(ECM/PYMASS(11))-1D0
49821 SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+
49822 &1.526D0*LOG(ECM**2/0.932D0)
49823
49824C...Soft and hard radiative cross-section in QED case.
49825 IF(MSTJ(102).LE.1) THEN
49826 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV
49827 SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL)
49828 SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL))
49829
49830C...Soft and hard radiative cross-section in QFD case.
49831 ELSE
49832 SZM=1D0-(PARJ(123)/ECM)**2
49833 SZW=PARJ(123)*PARJ(124)/ECM**2
49834 PARJ(161)=-RQQ/RSUM
49835 PARJ(162)=-(RQQ+RQV+RVA)/RSUM
49836 PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM
49837 PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2-
49838 & 4D0+3D0*SZM-SZM**2))/(SZW*RSUM)
49839 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/
49840 & RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0
49841 SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+
49842 & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
49843 & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
49844 SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/
49845 & (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)*
49846 & LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+
49847 & PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW)))
49848 ENDIF
49849
49850C...Total cross-section and fraction of hard photon events.
49851 PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
49852 PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
49853 PARJ(144)=PARJ(157)
49854 PARJ(148)=PARJ(144)*86.8D0/ECM**2
49855 XTOT=PARJ(148)
49856
49857 RETURN
49858 END
49859
49860C*********************************************************************
49861
49862C...PYRADK
49863C...Generates initial state photon radiation.
49864
49865 SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
49866
49867C...Double precision and integer declarations.
49868 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49869 IMPLICIT INTEGER(I-N)
49870 INTEGER PYK,PYCHGE,PYCOMP
49871C...Commonblocks.
49872 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49873 SAVE /PYDAT1/
49874
49875C...Function: cumulative hard photon spectrum in QFD case.
49876 FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+
49877 &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
49878
49879C...Determine whether radiative photon or not.
49880 MK=0
49881 PAK=0D0
49882 IF(PARJ(160).LT.PYR(0)) RETURN
49883 MK=1
49884
49885C...Photon energy range. Find photon momentum in QED case.
49886 XKL=PARJ(135)
49887 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
49888 IF(MSTJ(102).LE.1) THEN
49889 100 XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0))
49890 IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100
49891
49892C...Ditto in QFD case, by numerical inversion of integrated spectrum.
49893 ELSE
49894 SZM=1D0-(PARJ(123)/ECM)**2
49895 SZW=PARJ(123)*PARJ(124)/ECM**2
49896 FXKL=FXK(XKL)
49897 FXKU=FXK(XKU)
49898 FXKD=1D-4*(FXKU-FXKL)
49899 FXKR=FXKL+PYR(0)*(FXKU-FXKL)
49900 NXK=0
49901 110 NXK=NXK+1
49902 XK=0.5D0*(XKL+XKU)
49903 FXKV=FXK(XK)
49904 IF(FXKV.GT.FXKR) THEN
49905 XKU=XK
49906 FXKU=FXKV
49907 ELSE
49908 XKL=XK
49909 FXKL=FXKV
49910 ENDIF
49911 IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
49912 XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
49913 ENDIF
49914 PAK=0.5D0*ECM*XK
49915
49916C...Photon polar and azimuthal angle.
49917 PME=2D0*(PYMASS(11)/ECM)**2
49918 120 CTHM=PME*(2D0/PME)**PYR(0)
49919 IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME,
49920 &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120
49921 CTHE=1D0-CTHM
49922 IF(PYR(0).GT.0.5D0) CTHE=-CTHE
49923 STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM)))
49924 THEK=PYANGL(CTHE,STHE)
49925 PHIK=PARU(2)*PYR(0)
49926
49927C...Rotation angle for hadronic system.
49928 SGN=1D0
49929 IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT.
49930 &PYR(0)) SGN=-1D0
49931 ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/
49932 &(2D0-XK*(1D0-SGN*CTHE)))
49933
49934 RETURN
49935 END
49936
49937C*********************************************************************
49938
49939C...PYXKFL
49940C...Selects flavour for produced qqbar pair.
49941
49942 SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC)
49943
49944C...Double precision and integer declarations.
49945 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49946 IMPLICIT INTEGER(I-N)
49947 INTEGER PYK,PYCHGE,PYCOMP
49948C...Commonblocks.
49949 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49950 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49951 SAVE /PYDAT1/,/PYDAT2/
49952
49953C...Calculate maximum weight in QED or QFD case.
49954 IF(MSTJ(102).LE.1) THEN
49955 RFMAX=4D0/9D0
49956 ELSE
49957 POLL=1D0-PARJ(131)*PARJ(132)
49958 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
49959 SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
49960 SFI=SFW*(1D0-(PARJ(123)/ECMC)**2)
49961 VE=4D0*PARU(102)-1D0
49962 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
49963 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
49964 RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+
49965 & ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0*
49966 & (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+
49967 & 1D0)*HF1W)
49968 ENDIF
49969
49970C...Choose flavour. Gives charge and velocity.
49971 NTRY=0
49972 100 NTRY=NTRY+1
49973 IF(NTRY.GT.100) THEN
49974 CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop')
49975 KFLC=0
49976 RETURN
49977 ENDIF
49978 KFLC=KFL
49979 IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0))
49980 MSTJ(93)=1
49981 PMQ=PYMASS(KFLC)
49982 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100
49983 QF=KCHG(KFLC,1)/3D0
49984 VQ=1D0
49985 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2))
49986
49987C...Calculate weight in QED or QFD case.
49988 IF(MSTJ(102).LE.1) THEN
49989 RF=QF**2
49990 RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2
49991 ELSE
49992 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
49993 RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W
49994 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+
49995 & VQ**3*HF1W
49996 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
49997 ENDIF
49998
49999C...Weighting or new event (radiative photon). Cross-section update.
50000 IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100
50001 PARJ(158)=PARJ(158)+1D0
50002 IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0
50003 IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
50004 IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0
50005 PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
50006 PARJ(148)=PARJ(144)*86.8D0/ECM**2
50007
50008 RETURN
50009 END
50010
50011C*********************************************************************
50012
50013C...PYXJET
50014C...Selects number of jets in matrix element approach.
50015
50016 SUBROUTINE PYXJET(ECM,NJET,CUT)
50017
50018C...Double precision and integer declarations.
50019 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50020 IMPLICIT INTEGER(I-N)
50021 INTEGER PYK,PYCHGE,PYCOMP
50022C...Commonblocks.
50023 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50024 SAVE /PYDAT1/
50025C...Local array and data.
50026 DIMENSION ZHUT(5)
50027 DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/
50028
50029C...Trivial result for two-jets only, including parton shower.
50030 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
50031 CUT=0D0
50032
50033C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
50034 ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
50035 CF=4D0/3D0
50036 IF(MSTJ(109).EQ.2) CF=1D0
50037 IF(MSTJ(111).EQ.0) THEN
50038 Q2=ECM**2
50039 Q2R=ECM**2
50040 ELSEIF(MSTU(111).EQ.0) THEN
50041 PARJ(169)=MIN(1D0,PARJ(129))
50042 Q2=PARJ(169)*ECM**2
50043 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
50044 & ((33D0-2D0*MSTU(112))*PARU(111)))))
50045 Q2R=PARJ(168)*ECM**2
50046 ELSE
50047 PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2))
50048 Q2=PARJ(169)*ECM**2
50049 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
50050 & (2D0*PARU(112)/ECM)**2))
50051 Q2R=PARJ(168)*ECM**2
50052 ENDIF
50053
50054C...alpha_strong for R and R itself.
50055 ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1)
50056 IF(IABS(MSTJ(101)).EQ.1) THEN
50057 RQCD=1D0+ALSPI
50058 ELSEIF(MSTJ(109).EQ.0) THEN
50059 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
50060 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+
50061 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2)
50062 ELSE
50063 RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2
50064 ENDIF
50065
50066C...alpha_strong for jet rate. Initial value for y cut.
50067 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
50068 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2)
50069 IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
50070 & CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0)
50071 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
50072
50073C...Parametrization of first order three-jet cross-section.
50074 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN
50075 PARJ(152)=0D0
50076 ELSE
50077 PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))*
50078 & LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)*
50079 & (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0*
50080 & (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD
50081 IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
50082 & PARJ(152)=0D0
50083 ENDIF
50084
50085C...Parametrization of second order three-jet cross-section.
50086 IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
50087 & CUT.GE.0.25D0) THEN
50088 PARJ(153)=0D0
50089 ELSEIF(MSTJ(110).LE.1) THEN
50090 CT=LOG(1D0/CUT-2D0)
50091 PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2-
50092 & 0.2661D0*CT**3+0.01159D0*CT**4)/RQCD
50093
50094C...Interpolation in second/first order ratio for Zhu parametrization.
50095 ELSEIF(MSTJ(110).EQ.2) THEN
50096 IZA=0
50097 DO 110 IY=1,5
50098 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
50099 110 CONTINUE
50100 IF(IZA.NE.0) THEN
50101 ZHURAT=ZHUT(IZA)
50102 ELSE
50103 IZ=100D0*CUT
50104 ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
50105 ENDIF
50106 PARJ(153)=ALSPI*PARJ(152)*ZHURAT
50107 ENDIF
50108
50109C...Shift in second order three-jet cross-section with optimized Q^2.
50110 IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3
50111 & .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+
50112 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152)
50113
50114C...Parametrization of second order four-jet cross-section.
50115 IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN
50116 PARJ(154)=0D0
50117 ELSE
50118 CT=LOG(1D0/CUT-5D0)
50119 IF(CUT.LE.0.018D0) THEN
50120 XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2
50121 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+
50122 & 0.4059D0*CT**2)
50123 XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2)
50124 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
50125 ELSE
50126 XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3
50127 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+
50128 & 0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3)
50129 XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+
50130 & 0.002093D0*CT**3)
50131 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
50132 ENDIF
50133 PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
50134 PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
50135 ENDIF
50136
50137C...If negative three-jet rate, change y' optimization parameter.
50138 IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND.
50139 & PARJ(169).LT.0.99D0) THEN
50140 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
50141 Q2=PARJ(169)*ECM**2
50142 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
50143 GOTO 100
50144 ENDIF
50145
50146C...If too high cross-section, use harder cuts, or fail.
50147 IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
50148 IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND.
50149 & PARJ(169).LT.0.99D0) THEN
50150 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
50151 Q2=PARJ(169)*ECM**2
50152 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
50153 GOTO 100
50154 ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN
50155 CALL PYERRM(26,
50156 & '(PYXJET:) no allowed y cut value for Zhu parametrization')
50157 ENDIF
50158 CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+
50159 & PARJ(154))**(-1D0/3D0)
50160 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
50161 GOTO 100
50162 ENDIF
50163
50164C...Scalar gluon (first order only).
50165 ELSE
50166 ALSPI=PYALPS(ECM**2)/PARU(1)
50167 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI))
50168 PARJ(152)=0D0
50169 IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)*
50170 & LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0))
50171 PARJ(153)=0D0
50172 PARJ(154)=0D0
50173 ENDIF
50174
50175C...Select number of jets.
50176 PARJ(150)=CUT
50177 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
50178 NJET=2
50179 ELSEIF(MSTJ(101).LE.0) THEN
50180 NJET=MIN(4,2-MSTJ(101))
50181 ELSE
50182 RNJ=PYR(0)
50183 NJET=2
50184 IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
50185 IF(PARJ(154).GT.RNJ) NJET=4
50186 ENDIF
50187
50188 RETURN
50189 END
50190
50191C*********************************************************************
50192
50193C...PYX3JT
50194C...Selects the kinematical variables of three-jet events.
50195
50196 SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2)
50197
50198C...Double precision and integer declarations.
50199 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50200 IMPLICIT INTEGER(I-N)
50201 INTEGER PYK,PYCHGE,PYCOMP
50202C...Commonblocks.
50203 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50204 SAVE /PYDAT1/
50205C...Local array.
50206 DIMENSION ZHUP(5,12)
50207
50208C...Coefficients of Zhu second order parametrization.
50209 DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
50210 &18.29D0, 89.56D0, 4.541D0, -52.09D0, -109.8D0, 24.90D0,
50211 &11.63D0, 3.683D0, 17.50D0,0.002440D0, -1.362D0,-0.3537D0,
50212 &11.42D0, 6.299D0, -22.55D0, -8.915D0, 59.25D0, -5.855D0,
50213 &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0,
50214 &7.847D0, -3.964D0, -35.83D0, 1.178D0, 29.39D0, 0.2806D0,
50215 &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0,
50216 &5.441D0, -56.89D0, -50.27D0, 15.13D0, 114.3D0, -18.19D0,
50217 &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0,
50218 &-17.65D0, 51.44D0, -58.32D0, 70.95D0, -255.7D0, -78.99D0,
50219 &476.9D0, 29.65D0, -239.3D0, 0.4745D0, -1.174D0, 6.081D0/
50220
50221C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
50222 DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+
50223 &X**7/49D0
50224
50225C...Event type. Mass effect factors and other common constants.
50226 MSTJ(120)=2
50227 MSTJ(121)=0
50228 PMQ=PYMASS(KFL)
50229 QME=(2D0*PMQ/ECM)**2
50230 IF(MSTJ(109).NE.1) THEN
50231 CUTL=LOG(CUT)
50232 CUTD=LOG(1D0/CUT-2D0)
50233 IF(MSTJ(109).EQ.0) THEN
50234 CF=4D0/3D0
50235 CN=3D0
50236 TR=2D0
50237 WTMX=MIN(20D0,37D0-6D0*CUTD)
50238 IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT)
50239 ELSE
50240 CF=1D0
50241 CN=0D0
50242 TR=12D0
50243 WTMX=0D0
50244 ENDIF
50245
50246C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
50247 ALS2PI=PARU(118)/PARU(2)
50248 WTOPT=0D0
50249 IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0*
50250 & LOG(PARJ(169))*ALS2PI
50251 WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX)
50252
50253C...Choose three-jet events in allowed region.
50254 100 NJET=3
50255 110 Y13L=CUTL+CUTD*PYR(0)
50256 Y23L=CUTL+CUTD*PYR(0)
50257 Y13=EXP(Y13L)
50258 Y23=EXP(Y23L)
50259 Y12=1D0-Y13-Y23
50260 IF(Y12.LE.CUT) GOTO 110
50261 IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110
50262
50263C...Second order corrections.
50264 IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
50265 Y12L=LOG(Y12)
50266 Y13M=LOG(1D0-Y13)
50267 Y23M=LOG(1D0-Y23)
50268 Y12M=LOG(1D0-Y12)
50269 IF(Y13.LE.0.5D0) Y13I=DILOG(Y13)
50270 IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13)
50271 IF(Y23.LE.0.5D0) Y23I=DILOG(Y23)
50272 IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23)
50273 IF(Y12.LE.0.5D0) Y12I=DILOG(Y12)
50274 IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12)
50275 WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23)
50276 WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+
50277 & 2D0*(2D0*CUTL-Y12L)*CUT/Y12)+
50278 & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-
50279 & 11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+
50280 & (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+
50281 & TR*(2D0*CUTL/3D0-10D0/9D0)+
50282 & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
50283 & Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/
50284 & (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+
50285 & Y13*Y23)/(Y12+Y13)**2)/WT1+
50286 & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)*
50287 & ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
50288 & Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
50289 & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/
50290 & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
50291 & 2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1-
50292 & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I)
50293 IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1
50294 IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
50295 PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2)
50296
50297 ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
50298C...Second order corrections; Zhu parametrization of ERT.
50299 ZX=(Y23-Y13)**2
50300 ZY=1D0-Y12
50301 IZA=0
50302 DO 120 IY=1,5
50303 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
50304 120 CONTINUE
50305 IF(IZA.NE.0) THEN
50306 IZ=IZA
50307 WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
50308 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
50309 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
50310 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
50311 ELSE
50312 IZ=100D0*CUT
50313 WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
50314 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
50315 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
50316 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
50317 IZ=IZ+1
50318 WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
50319 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
50320 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
50321 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
50322 WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ)
50323 ENDIF
50324 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1
50325 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
50326 PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2)
50327 ENDIF
50328
50329C...Impose mass cuts (gives two jets). For fixed jet number new try.
50330 X1=1D0-Y23
50331 X2=1D0-Y13
50332 X3=1D0-Y12
50333 IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
50334 IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
50335 & 0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+
50336 & (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2
50337 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
50338
50339C...Scalar gluon model (first order only, no mass effects).
50340 ELSE
50341 130 NJET=3
50342 140 X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2))
50343 IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140
50344 YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0)
50345 X1=1D0-0.5D0*(X3+YD)
50346 X2=1D0-0.5D0*(X3-YD)
50347 IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2
50348 IF(MSTJ(102).GE.2) THEN
50349 IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT.
50350 & X3**2*PYR(0)) NJET=2
50351 ENDIF
50352 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
50353 ENDIF
50354
50355 RETURN
50356 END
50357
50358C*********************************************************************
50359
50360C...PYX4JT
50361C...Selects the kinematical variables of four-jet events.
50362
50363 SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
50364
50365C...Double precision and integer declarations.
50366 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50367 IMPLICIT INTEGER(I-N)
50368 INTEGER PYK,PYCHGE,PYCOMP
50369C...Commonblocks.
50370 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50371 SAVE /PYDAT1/
50372C...Local arrays.
50373 DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
50374
50375C...Common constants. Colour factors for QCD and Abelian gluon theory.
50376 PMQ=PYMASS(KFL)
50377 QME=(2D0*PMQ/ECM)**2
50378 CT=LOG(1D0/CUT-5D0)
50379 IF(MSTJ(109).EQ.0) THEN
50380 CF=4D0/3D0
50381 CN=3D0
50382 TR=2.5D0
50383 ELSE
50384 CF=1D0
50385 CN=0D0
50386 TR=15D0
50387 ENDIF
50388
50389C...Choice of process (qqbargg or qqbarqqbar).
50390 100 NJET=4
50391 IT=1
50392 IF(PARJ(155).GT.PYR(0)) IT=2
50393 IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
50394 IF(IT.EQ.1) WTMX=0.7D0/CUT**2
50395 IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2
50396 IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2
50397 ID=1
50398
50399C...Sample the five kinematical variables (for qqgg preweighted in y34).
50400 110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
50401 Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
50402 IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0))
50403 IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0)
50404 IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110
50405 VT=PYR(0)
50406 CP=COS(PARU(1)*PYR(0))
50407 Y14=(Y134-Y34)*VT
50408 Y13=Y134-Y14-Y34
50409 VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
50410 Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)*
50411 &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB))
50412 Y23=Y234-Y34-Y24
50413 Y12=1D0-Y134-Y23-Y24
50414 IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
50415 Y123=Y12+Y13+Y23
50416 Y124=Y12+Y14+Y24
50417
50418C...Calculate matrix elements for qqgg or qqqq process.
50419 IC=0
50420 WTTOT=0D0
50421 120 IC=IC+1
50422 IF(IT.EQ.1) THEN
50423 WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+
50424 & 3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24-
50425 & Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12*
50426 & Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+
50427 & 2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/
50428 & (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-
50429 & Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/
50430 & (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24)
50431 WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12*
50432 & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14*
50433 & Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+
50434 & Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24)
50435 WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+
50436 & 2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+
50437 & Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-
50438 & 3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-
50439 & 3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+
50440 & (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+
50441 & 3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+
50442 & 2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24-
50443 & 2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+
50444 & 3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+
50445 & 2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2-
50446 & 2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34)
50447 WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+
50448 & 4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34-
50449 & Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+
50450 & 4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+
50451 & 2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+
50452 & 4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/
50453 & (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34-
50454 & 2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+
50455 & 2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24-
50456 & 4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-
50457 & Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2-
50458 & 4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34-
50459 & 4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34-
50460 & 2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23-
50461 & 2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14-
50462 & Y12*Y13**2)/(4D0*Y34**2*Y134**2)
50463 WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+
50464 & CN*WTC(IC))/8D0
50465 ELSE
50466 WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12*
50467 & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
50468 & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
50469 & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
50470 & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
50471 & Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
50472 & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
50473 & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
50474 & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
50475 WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
50476 & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
50477 & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
50478 & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
50479 & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
50480 & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
50481 & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
50482 & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
50483 WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0
50484 ENDIF
50485
50486C...Permutations of momenta in matrix element. Weighting.
50487 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
50488 YSAV=Y13
50489 Y13=Y14
50490 Y14=YSAV
50491 YSAV=Y23
50492 Y23=Y24
50493 Y24=YSAV
50494 YSAV=Y123
50495 Y123=Y124
50496 Y124=YSAV
50497 ENDIF
50498 IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
50499 YSAV=Y13
50500 Y13=Y23
50501 Y23=YSAV
50502 YSAV=Y14
50503 Y14=Y24
50504 Y24=YSAV
50505 YSAV=Y134
50506 Y134=Y234
50507 Y234=YSAV
50508 ENDIF
50509 IF(IC.LE.3) GOTO 120
50510 IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110
50511 IC=5
50512
50513C...qqgg events: string configuration and event type.
50514 IF(IT.EQ.1) THEN
50515 IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
50516 PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+
50517 & WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT)
50518 IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+
50519 & WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
50520 IF(ID.EQ.2) GOTO 130
50521 ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
50522 PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT)
50523 IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
50524 IF(ID.EQ.2) GOTO 130
50525 ENDIF
50526 MSTJ(120)=3
50527 IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+
50528 & WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4
50529 KFLN=21
50530
50531C...Mass cuts. Kinematical variables out.
50532 IF(Y12.LE.CUT+QME) NJET=2
50533 IF(NJET.EQ.2) GOTO 150
50534 Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12))
50535 X1=1D0-(1D0-Q12)*Y234-Q12*Y134
50536 X4=1D0-(1D0-Q12)*Y134-Q12*Y234
50537 X2=1D0-Y124
50538 X12=(1D0-Q12)*Y13+Q12*Y23
50539 X14=Y12-0.5D0*QME
50540 IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
50541
50542C...qqbarqqbar events: string configuration, choose new flavour.
50543 ELSE
50544 IF(ID.EQ.1) THEN
50545 WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
50546 IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
50547 IF(WTR.LT.WTD(3)+WTD(4)) ID=3
50548 IF(WTR.LT.WTD(4)) ID=4
50549 IF(ID.GE.2) GOTO 130
50550 ENDIF
50551 MSTJ(120)=5
50552 PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT)
50553 140 KFLN=1+INT(5D0*PYR(0))
50554 IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140
50555 IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140
50556 IF(KFLN.GT.MSTJ(104)) NJET=2
50557 PMQN=PYMASS(KFLN)
50558 QMEN=(2D0*PMQN/ECM)**2
50559
50560C...Mass cuts. Kinematical variables out.
50561 IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2
50562 IF(NJET.EQ.2) GOTO 150
50563 Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24))
50564 Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13))
50565 X1=1D0-(1D0-Q24)*Y123-Q24*Y134
50566 X4=1D0-(1D0-Q24)*Y134-Q24*Y123
50567 X2=1D0-(1D0-Q13)*Y234-Q13*Y124
50568 X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+
50569 & Q13*Y23)
50570 X14=Y24-0.5D0*QME
50571 X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+
50572 & Q13*Y14)
50573 IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
50574 & (PARJ(127)+PMQ+PMQN)**2) NJET=2
50575 IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
50576 ENDIF
50577 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
50578
50579 RETURN
50580 END
50581
50582C*********************************************************************
50583
50584C...PYXDIF
50585C...Gives the angular orientation of events.
50586
50587 SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
50588
50589C...Double precision and integer declarations.
50590 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50591 IMPLICIT INTEGER(I-N)
50592 INTEGER PYK,PYCHGE,PYCOMP
50593C...Commonblocks.
50594 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
50595 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50596 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50597 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
50598
50599C...Charge. Factors depending on polarization for QED case.
50600 QF=KCHG(KFL,1)/3D0
50601 POLL=1D0-PARJ(131)*PARJ(132)
50602 POLD=PARJ(132)-PARJ(131)
50603 IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
50604 HF1=POLL
50605 HF2=0D0
50606 HF3=PARJ(133)**2
50607 HF4=0D0
50608
50609C...Factors depending on flavour, energy and polarization for QFD case.
50610 ELSE
50611 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
50612 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
50613 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
50614 AE=-1D0
50615 VE=4D0*PARU(102)-1D0
50616 AF=SIGN(1D0,QF)
50617 VF=AF-4D0*QF*PARU(102)
50618 HF1=QF**2*POLL-2D0*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
50619 & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2D0*VE*AE*POLD)
50620 HF2=-2D0*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2D0*VF*AF*SFW*SFF**2*
50621 & (2D0*VE*AE*POLL-(VE**2+AE**2)*POLD)
50622 HF3=PARJ(133)**2*(QF**2-2D0*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
50623 & SFW*SFF**2*(VE**2-AE**2))
50624 HF4=-PARJ(133)**2*2D0*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
50625 & SFF*AE
50626 ENDIF
50627
50628C...Mass factor. Differential cross-sections for two-jet events.
50629 SQ2=SQRT(2D0)
50630 QME=0D0
50631 IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
50632 &MSTJ(109).NE.1) QME=(2D0*PYMASS(KFL)/ECM)**2
50633 IF(NJET.EQ.2) THEN
50634 SIGU=4D0*SQRT(1D0-QME)
50635 SIGL=2D0*QME*SQRT(1D0-QME)
50636 SIGT=0D0
50637 SIGI=0D0
50638 SIGA=0D0
50639 SIGP=4D0
50640
50641C...Kinematical variables. Reduce four-jet event to three-jet one.
50642 ELSE
50643 IF(NJET.EQ.3) THEN
50644 X1=2D0*P(NC+1,4)/ECM
50645 X2=2D0*P(NC+3,4)/ECM
50646 ELSE
50647 ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
50648 & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
50649 X1=2D0*P(NC+1,4)/ECMR
50650 X2=2D0*P(NC+4,4)/ECMR
50651 ENDIF
50652
50653C...Differential cross-sections for three-jet (or reduced four-jet).
50654 XQ=(1D0-X1)/(1D0-X2)
50655 CT12=(X1*X2-2D0*X1-2D0*X2+2D0+QME)/SQRT((X1**2-QME)*(X2**2-QME))
50656 ST12=SQRT(1D0-CT12**2)
50657 IF(MSTJ(109).NE.1) THEN
50658 SIGU=2D0*X1**2+X2**2*(1D0+CT12**2)-QME*(3D0+CT12**2-X1-X2)-
50659 & QME*X1/XQ+0.5D0*QME*((X2**2-QME)*ST12**2-2D0*X2)*XQ
50660 SIGL=(X2*ST12)**2-QME*(3D0-CT12**2-2.5D0*(X1+X2)+X1*X2+QME)+
50661 & 0.5D0*QME*(X1**2-X1-QME)/XQ+0.5D0*QME*((X2**2-QME)*CT12**2-
50662 & X2)*XQ
50663 SIGT=0.5D0*(X2**2-QME-0.5D0*QME*(X2**2-QME)/XQ)*ST12**2
50664 SIGI=((1D0-0.5D0*QME*XQ)*(X2**2-QME)*ST12*CT12+
50665 & QME*(1D0-X1-X2+0.5D0*X1*X2+0.5D0*QME)*ST12/CT12)/SQ2
50666 SIGA=X2**2*ST12/SQ2
50667 SIGP=2D0*(X1**2-X2**2*CT12)
50668
50669C...Differential cross-sect for scalar gluons (no mass effects).
50670 ELSE
50671 X3=2D0-X1-X2
50672 XT=X2*ST12
50673 CT13=SQRT(MAX(0D0,1D0-(XT/X3)**2))
50674 SIGU=(1D0-PARJ(171))*(X3**2-0.5D0*XT**2)+
50675 & PARJ(171)*(X3**2-0.5D0*XT**2-4D0*(1D0-X1)*(1D0-X2)**2/X1)
50676 SIGL=(1D0-PARJ(171))*0.5D0*XT**2+
50677 & PARJ(171)*0.5D0*(1D0-X1)**2*XT**2
50678 SIGT=(1D0-PARJ(171))*0.25D0*XT**2+
50679 & PARJ(171)*0.25D0*XT**2*(1D0-2D0*X1)
50680 SIGI=-(0.5D0/SQ2)*((1D0-PARJ(171))*XT*X3*CT13+
50681 & PARJ(171)*XT*((1D0-2D0*X1)*X3*CT13-X1*(X1-X2)))
50682 SIGA=(0.25D0/SQ2)*XT*(2D0*(1D0-X1)-X1*X3)
50683 SIGP=X3**2-2D0*(1D0-X1)*(1D0-X2)/X1
50684 ENDIF
50685 ENDIF
50686
50687C...Upper bounds for differential cross-section.
50688 HF1A=ABS(HF1)
50689 HF2A=ABS(HF2)
50690 HF3A=ABS(HF3)
50691 HF4A=ABS(HF4)
50692 SIGMAX=(2D0*HF1A+HF3A+HF4A)*ABS(SIGU)+2D0*(HF1A+HF3A+HF4A)*
50693 &ABS(SIGL)+2D0*(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGT)+2D0*SQ2*
50694 &(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGI)+4D0*SQ2*HF2A*ABS(SIGA)+
50695 &2D0*HF2A*ABS(SIGP)
50696
50697C...Generate angular orientation according to differential cross-sect.
50698 100 CHI=PARU(2)*PYR(0)
50699 CTHE=2D0*PYR(0)-1D0
50700 PHI=PARU(2)*PYR(0)
50701 CCHI=COS(CHI)
50702 SCHI=SIN(CHI)
50703 C2CHI=COS(2D0*CHI)
50704 S2CHI=SIN(2D0*CHI)
50705 THE=ACOS(CTHE)
50706 STHE=SIN(THE)
50707 C2PHI=COS(2D0*(PHI-PARJ(134)))
50708 S2PHI=SIN(2D0*(PHI-PARJ(134)))
50709 SIG=((1D0+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
50710 &2D0*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
50711 &2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*C2CHI*C2PHI-2D0*CTHE*S2CHI*
50712 &S2PHI)*HF3-((1D0+CTHE**2)*C2CHI*S2PHI+2D0*CTHE*S2CHI*C2PHI)*HF4)*
50713 &SIGT-2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*(CTHE*CCHI*C2PHI-
50714 &SCHI*S2PHI)*HF3+2D0*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
50715 &4D0*SQ2*STHE*CCHI*HF2*SIGA+2D0*CTHE*HF2*SIGP
50716 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100
50717
50718 RETURN
50719 END
50720
50721C*********************************************************************
50722
50723C...PYONIA
50724C...Generates Upsilon and toponium decays into three gluons
50725C...or two gluons and a photon.
50726
50727 SUBROUTINE PYONIA(KFL,ECM)
50728
50729C...Double precision and integer declarations.
50730 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50731 IMPLICIT INTEGER(I-N)
50732 INTEGER PYK,PYCHGE,PYCOMP
50733C...Commonblocks.
50734 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
50735 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50736 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50737 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
50738
50739C...Printout. Check input parameters.
50740 IF(MSTU(12).GE.1) CALL PYLIST(0)
50741 IF(KFL.LT.0.OR.KFL.GT.8) THEN
50742 CALL PYERRM(16,'(PYONIA:) called with unknown flavour code')
50743 IF(MSTU(21).GE.1) RETURN
50744 ENDIF
50745 IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN
50746 CALL PYERRM(16,'(PYONIA:) called with too small CM energy')
50747 IF(MSTU(21).GE.1) RETURN
50748 ENDIF
50749
50750C...Initial e+e- and onium state (optional).
50751 NC=0
50752 IF(MSTJ(115).GE.2) THEN
50753 NC=NC+2
50754 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
50755 K(NC-1,1)=21
50756 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
50757 K(NC,1)=21
50758 ENDIF
50759 KFLC=IABS(KFL)
50760 IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
50761 NC=NC+1
50762 KF=110*KFLC+3
50763 MSTU10=MSTU(10)
50764 MSTU(10)=1
50765 P(NC,5)=ECM
50766 CALL PY1ENT(NC,KF,ECM,0D0,0D0)
50767 K(NC,1)=21
50768 K(NC,3)=1
50769 MSTU(10)=MSTU10
50770 ENDIF
50771
50772C...Choose x1 and x2 according to matrix element.
50773 NTRY=0
50774 100 X1=PYR(0)
50775 X2=PYR(0)
50776 X3=2D0-X1-X2
50777 IF(X3.GE.1D0.OR.((1D0-X1)/(X2*X3))**2+((1D0-X2)/(X1*X3))**2+
50778 &((1D0-X3)/(X1*X2))**2.LE.2D0*PYR(0)) GOTO 100
50779 NTRY=NTRY+1
50780 NJET=3
50781 IF(MSTJ(101).LE.4) CALL PY3ENT(NC+1,21,21,21,ECM,X1,X3)
50782 IF(MSTJ(101).GE.5) CALL PY3ENT(-(NC+1),21,21,21,ECM,X1,X3)
50783
50784C...Photon-gluon-gluon events. Small system modifications. Jet origin.
50785 MSTU(111)=MSTJ(108)
50786 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
50787 &MSTU(111)=1
50788 PARU(112)=PARJ(121)
50789 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
50790 QF=0D0
50791 IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3D0
50792 RGAM=7.2D0*QF**2*PARU(101)/PYALPS(ECM**2)
50793 MK=0
50794 ECMC=ECM
50795 IF(PYR(0).GT.RGAM/(1D0+RGAM)) THEN
50796 IF(1D0-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
50797 & NJET=2
50798 IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL PY2ENT(NC+1,21,21,ECM)
50799 IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL PY2ENT(-(NC+1),21,21,ECM)
50800 ELSE
50801 MK=1
50802 ECMC=SQRT(1D0-X1)*ECM
50803 IF(ECMC.LT.2D0*PARJ(127)) GOTO 100
50804 K(NC+1,1)=1
50805 K(NC+1,2)=22
50806 K(NC+1,4)=0
50807 K(NC+1,5)=0
50808 IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
50809 IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
50810 IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
50811 IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
50812 NJET=2
50813 IF(ECMC.LT.4D0*PARJ(127)) THEN
50814 MSTU10=MSTU(10)
50815 MSTU(10)=1
50816 P(NC+2,5)=ECMC
50817 CALL PY1ENT(NC+2,83,0.5D0*(X2+X3)*ECM,PARU(1),0D0)
50818 MSTU(10)=MSTU10
50819 NJET=0
50820 ENDIF
50821 ENDIF
50822 DO 110 IP=NC+1,N
50823 K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
50824 110 CONTINUE
50825
50826C...Differential cross-sections. Upper limit for cross-section.
50827 IF(MSTJ(106).EQ.1) THEN
50828 SQ2=SQRT(2D0)
50829 HF1=1D0-PARJ(131)*PARJ(132)
50830 HF3=PARJ(133)**2
50831 CT13=(X1*X3-2D0*X1-2D0*X3+2D0)/(X1*X3)
50832 ST13=SQRT(1D0-CT13**2)
50833 SIGL=0.5D0*X3**2*((1D0-X2)**2+(1D0-X3)**2)*ST13**2
50834 SIGU=(X1*(1D0-X1))**2+(X2*(1D0-X2))**2+(X3*(1D0-X3))**2-SIGL
50835 SIGT=0.5D0*SIGL
50836 SIGI=(SIGL*CT13/ST13+0.5D0*X1*X3*(1D0-X2)**2*ST13)/SQ2
50837 SIGMAX=(2D0*HF1+HF3)*ABS(SIGU)+2D0*(HF1+HF3)*ABS(SIGL)+2D0*(HF1+
50838 & 2D0*HF3)*ABS(SIGT)+2D0*SQ2*(HF1+2D0*HF3)*ABS(SIGI)
50839
50840C...Angular orientation of event.
50841 120 CHI=PARU(2)*PYR(0)
50842 CTHE=2D0*PYR(0)-1D0
50843 PHI=PARU(2)*PYR(0)
50844 CCHI=COS(CHI)
50845 SCHI=SIN(CHI)
50846 C2CHI=COS(2D0*CHI)
50847 S2CHI=SIN(2D0*CHI)
50848 THE=ACOS(CTHE)
50849 STHE=SIN(THE)
50850 C2PHI=COS(2D0*(PHI-PARJ(134)))
50851 S2PHI=SIN(2D0*(PHI-PARJ(134)))
50852 SIG=((1D0+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2D0*(STHE**2*HF1-
50853 & STHE**2*C2PHI*HF3)*SIGL+2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*
50854 & C2CHI*C2PHI-2D0*CTHE*S2CHI*S2PHI)*HF3)*SIGT-
50855 & 2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*
50856 & (CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
50857 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 120
50858 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
50859 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
50860 ENDIF
50861
50862C...Generate parton shower. Rearrange along strings and check.
50863 IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
50864 CALL PYSHOW(NC+MK+1,-NJET,ECMC)
50865 MSTJ14=MSTJ(14)
50866 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
50867 IF(MSTJ(105).GE.0) MSTU(28)=0
50868 CALL PYPREP(0)
50869 MSTJ(14)=MSTJ14
50870 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
50871 ENDIF
50872
50873C...Generate fragmentation. Information for PYTABU:
50874 IF(MSTJ(105).EQ.1) CALL PYEXEC
50875 MSTU(161)=110*KFLC+3
50876 MSTU(162)=0
50877
50878 RETURN
50879 END
50880
50881C*********************************************************************
50882
50883C...PYBOOK
50884C...Books a histogram.
50885
50886 SUBROUTINE PYBOOK(ID,TITLE,NX,XL,XU)
50887
50888C...Double precision declaration.
50889 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50890 IMPLICIT INTEGER(I-N)
50891C...Commonblock.
50892 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
50893 SAVE /PYBINS/
50894C...Local character variables.
50895 CHARACTER TITLE*(*), TITFX*60
50896
50897C...Check that input is sensible. Find initial address in memory.
50898 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
50899 &'(PYBOOK:) not allowed histogram number')
50900 IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28,
50901 &'(PYBOOK:) not allowed number of bins')
50902 IF(XL.GE.XU) CALL PYERRM(28,
50903 &'(PYBOOK:) x limits in wrong order')
50904 INDX(ID)=IHIST(4)
50905 IHIST(4)=IHIST(4)+28+NX
50906 IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28,
50907 &'(PYBOOK:) out of histogram space')
50908 IS=INDX(ID)
50909
50910C...Store histogram size and reset contents.
50911 BIN(IS+1)=NX
50912 BIN(IS+2)=XL
50913 BIN(IS+3)=XU
50914 BIN(IS+4)=(XU-XL)/NX
50915 CALL PYNULL(ID)
50916
50917C...Store title by conversion to integer to double precision.
50918 TITFX=TITLE//' '
50919 DO 100 IT=1,20
50920 BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+
50921 & 256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT))
50922 100 CONTINUE
50923
50924 RETURN
50925 END
50926
50927C*********************************************************************
50928
50929C...PYFILL
50930C...Fills entry in histogram.
50931
50932 SUBROUTINE PYFILL(ID,X,W)
50933
50934C...Double precision declaration.
50935 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50936 IMPLICIT INTEGER(I-N)
50937C...Commonblock.
50938 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
50939 SAVE /PYBINS/
50940
50941C...Find initial address in memory. Increase number of entries.
50942 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
50943 &'(PYFILL:) not allowed histogram number')
50944 IS=INDX(ID)
50945 IF(IS.EQ.0) CALL PYERRM(28,
50946 &'(PYFILL:) filling unbooked histogram')
50947 BIN(IS+5)=BIN(IS+5)+1D0
50948
50949C...Find bin in x, including under/overflow, and fill.
50950 IF(X.LT.BIN(IS+2)) THEN
50951 BIN(IS+6)=BIN(IS+6)+W
50952 ELSEIF(X.GE.BIN(IS+3)) THEN
50953 BIN(IS+8)=BIN(IS+8)+W
50954 ELSE
50955 BIN(IS+7)=BIN(IS+7)+W
50956 IX=(X-BIN(IS+2))/BIN(IS+4)
50957 IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX))
50958 BIN(IS+9+IX)=BIN(IS+9+IX)+W
50959 ENDIF
50960
50961 RETURN
50962 END
50963
50964C*********************************************************************
50965
50966C...PYFACT
50967C...Multiplies histogram contents by factor.
50968
50969 SUBROUTINE PYFACT(ID,F)
50970
50971C...Double precision declaration.
50972 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50973 IMPLICIT INTEGER(I-N)
50974C...Commonblock.
50975 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
50976 SAVE /PYBINS/
50977
50978C...Find initial address in memory. Multiply all contents bins.
50979 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
50980 &'(PYFACT:) not allowed histogram number')
50981 IS=INDX(ID)
50982 IF(IS.EQ.0) CALL PYERRM(28,
50983 &'(PYFACT:) scaling unbooked histogram')
50984 DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1))
50985 BIN(IX)=F*BIN(IX)
50986 100 CONTINUE
50987
50988 RETURN
50989 END
50990
50991C*********************************************************************
50992
50993C...PYOPER
50994C...Performs operations between histograms.
50995
50996 SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2)
50997
50998C...Double precision declaration.
50999 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51000 IMPLICIT INTEGER(I-N)
51001C...Commonblock.
51002 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
51003 SAVE /PYBINS/
51004C...Character variable.
51005 CHARACTER OPER*(*)
51006
51007C...Find initial addresses in memory, and histogram size.
51008 IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28,
51009 &'(PYFACT:) not allowed histogram number')
51010 IS1=INDX(ID1)
51011 IS2=INDX(MIN(IHIST(1),MAX(1,ID2)))
51012 IS3=INDX(MIN(IHIST(1),MAX(1,ID3)))
51013 NX=NINT(BIN(IS3+1))
51014 IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1))
51015
51016C...Update info on number of histogram entries.
51017 IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN
51018 BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5)
51019 ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN
51020 BIN(IS3+5)=BIN(IS1+5)
51021 ENDIF
51022
51023C...Operations on pair of histograms: addition, subtraction,
51024C...multiplication, division.
51025 IF(OPER.EQ.'+') THEN
51026 DO 100 IX=6,8+NX
51027 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX)
51028 100 CONTINUE
51029 ELSEIF(OPER.EQ.'-') THEN
51030 DO 110 IX=6,8+NX
51031 BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX)
51032 110 CONTINUE
51033 ELSEIF(OPER.EQ.'*') THEN
51034 DO 120 IX=6,8+NX
51035 BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX)
51036 120 CONTINUE
51037 ELSEIF(OPER.EQ.'/') THEN
51038 DO 130 IX=6,8+NX
51039 FA2=F2*BIN(IS2+IX)
51040 IF(ABS(FA2).LE.1D-20) THEN
51041 BIN(IS3+IX)=0D0
51042 ELSE
51043 BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2
51044 ENDIF
51045 130 CONTINUE
51046
51047C...Operations on single histogram: multiplication+addition,
51048C...square root+addition, logarithm+addition.
51049 ELSEIF(OPER.EQ.'A') THEN
51050 DO 140 IX=6,8+NX
51051 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2
51052 140 CONTINUE
51053 ELSEIF(OPER.EQ.'S') THEN
51054 DO 150 IX=6,8+NX
51055 BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2
51056 150 CONTINUE
51057 ELSEIF(OPER.EQ.'L') THEN
51058 ZMIN=1D20
51059 DO 160 IX=9,8+NX
51060 IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20)
51061 & ZMIN=0.8D0*BIN(IS1+IX)
51062 160 CONTINUE
51063 DO 170 IX=6,8+NX
51064 BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2
51065 170 CONTINUE
51066
51067C...Operation on two or three histograms: average and
51068C...standard deviation.
51069 ELSEIF(OPER.EQ.'M') THEN
51070 DO 180 IX=6,8+NX
51071 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
51072 BIN(IS2+IX)=0D0
51073 ELSE
51074 BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX)
51075 ENDIF
51076 IF(ID3.NE.0) THEN
51077 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
51078 BIN(IS3+IX)=0D0
51079 ELSE
51080 BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)-
51081 & BIN(IS2+IX)**2))
51082 ENDIF
51083 ENDIF
51084 BIN(IS1+IX)=F1*BIN(IS1+IX)
51085 180 CONTINUE
51086 ENDIF
51087
51088 RETURN
51089 END
51090
51091C*********************************************************************
51092
51093C...PYHIST
51094C...Prints and resets all histograms.
51095
51096 SUBROUTINE PYHIST
51097
51098C...Double precision declaration.
51099 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51100 IMPLICIT INTEGER(I-N)
51101C...Commonblock.
51102 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
51103 SAVE /PYBINS/
51104
51105C...Loop over histograms, print and reset used ones.
51106 DO 100 ID=1,IHIST(1)
51107 IS=INDX(ID)
51108 IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN
51109 CALL PYPLOT(ID)
51110 CALL PYNULL(ID)
51111 ENDIF
51112 100 CONTINUE
51113
51114 RETURN
51115 END
51116
51117C*********************************************************************
51118
51119C...PYPLOT
51120C...Prints a histogram (but does not reset it).
51121
51122 SUBROUTINE PYPLOT(ID)
51123
51124C...Double precision declaration.
51125 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51126 IMPLICIT INTEGER(I-N)
51127C...Commonblocks.
51128 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51129 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
51130 SAVE /PYDAT1/,/PYBINS/
51131C...Local arrays and character variables.
51132 DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10)
51133 CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
51134
51135C...Steps in histogram scale. Character sequence.
51136 DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
51137 DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/
51138
51139C...Find initial address in memory; skip if empty histogram.
51140 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
51141 IS=INDX(ID)
51142 IF(IS.EQ.0) RETURN
51143 IF(NINT(BIN(IS+5)).LE.0) THEN
51144 WRITE(MSTU(11),5000) ID
51145 RETURN
51146 ENDIF
51147
51148C...Number of histogram lines and x bins.
51149 LIN=IHIST(3)-18
51150 NX=NINT(BIN(IS+1))
51151
51152C...Extract title by conversion from double precision via integer.
51153 DO 100 IT=1,20
51154 IEQ=NINT(BIN(IS+8+NX+IT))
51155 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256)
51156 & //CHAR(MOD(IEQ,256))
51157 100 CONTINUE
51158
51159C...Find time; print title.
51160 CALL PYTIME(IDATI)
51161 IF(IDATI(1).GT.0) THEN
51162 WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5)
51163 ELSE
51164 WRITE(MSTU(11),5200) ID, TITLE
51165 ENDIF
51166
51167C...Find minimum and maximum bin content.
51168 YMIN=BIN(IS+9)
51169 YMAX=BIN(IS+9)
51170 DO 110 IX=IS+10,IS+8+NX
51171 IF(BIN(IX).LT.YMIN) YMIN=BIN(IX)
51172 IF(BIN(IX).GT.YMAX) YMAX=BIN(IX)
51173 110 CONTINUE
51174
51175C...Determine scale and step size for y axis.
51176 IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN
51177 IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0
51178 IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0
51179 IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10
51180 IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1
51181 IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1
51182 DELY=DYAC(1)
51183 DO 120 IDEL=1,9
51184 IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1)
51185 120 CONTINUE
51186 DY=DELY*10D0**IPOT
51187
51188C...Convert bin contents to integer form; fractional fill in top row.
51189 DO 130 IX=1,NX
51190 CTA=ABS(BIN(IS+8+IX))/DY
51191 IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX))
51192 IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0)))
51193 130 CONTINUE
51194 IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN)
51195 IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX)
51196
51197C...Print histogram row by row.
51198 DO 150 IR=IRMA,IRMI,-1
51199 IF(IR.EQ.0) GOTO 150
51200 OUT=' '
51201 DO 140 IX=1,NX
51202 IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX))
51203 IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10)
51204 140 CONTINUE
51205 WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT
51206 150 CONTINUE
51207
51208C...Print sign and value of bin contents.
51209 IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10
51210 OUT=' '
51211 DO 160 IX=1,NX
51212 IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11)
51213 IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX)))
51214 160 CONTINUE
51215 WRITE(MSTU(11),5400) OUT
51216 DO 180 IR=4,1,-1
51217 DO 170 IX=1,NX
51218 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
51219 170 CONTINUE
51220 WRITE(MSTU(11),5500) IPOT+IR-4, OUT
51221 180 CONTINUE
51222
51223C...Print sign and value of lower bin edge.
51224 IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+
51225 & 10.0001D0)-10
51226 OUT=' '
51227 DO 190 IX=1,NX
51228 IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3))
51229 & OUT(IX:IX)=CHA(11)
51230 IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4)))
51231 190 CONTINUE
51232 WRITE(MSTU(11),5600) OUT
51233 DO 210 IR=3,1,-1
51234 DO 200 IX=1,NX
51235 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
51236 200 CONTINUE
51237 WRITE(MSTU(11),5500) IPOT+IR-3, OUT
51238 210 CONTINUE
51239 ENDIF
51240
51241C...Calculate and print statistics.
51242 CSUM=0D0
51243 CXSUM=0D0
51244 CXXSUM=0D0
51245 DO 220 IX=1,NX
51246 CTA=ABS(BIN(IS+8+IX))
51247 X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4)
51248 CSUM=CSUM+CTA
51249 CXSUM=CXSUM+CTA*X
51250 CXXSUM=CXXSUM+CTA*X**2
51251 220 CONTINUE
51252 XMEAN=CXSUM/MAX(CSUM,1D-20)
51253 XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2))
51254 WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6),
51255 &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3)
51256
51257C...Formats for output.
51258 5000 FORMAT(/5X,'Histogram no',I5,' : no entries')
51259 5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X,
51260 &I2,':',I2/)
51261 5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/)
51262 5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100)
51263 5400 FORMAT(/8X,'Contents',3X,A100)
51264 5500 FORMAT(9X,'*10**',I2,3X,A100)
51265 5600 FORMAT(/8X,'Low edge',3X,A100)
51266 5700 FORMAT(/5X,'Entries =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow ='
51267 &,D12.4,6X,'Low edge =',D12.4/5X,'All chan =',D12.4,6X,
51268 &'Rms =',D12.4,6X,'Overflow =',D12.4,6X,'High edge =',D12.4)
51269
51270 RETURN
51271 END
51272
51273C*********************************************************************
51274
51275C...PYNULL
51276C...Resets bin contents of a histogram.
51277
51278 SUBROUTINE PYNULL(ID)
51279
51280C...Double precision declaration.
51281 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51282 IMPLICIT INTEGER(I-N)
51283C...Commonblock.
51284 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
51285 SAVE /PYBINS/
51286
51287 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
51288 IS=INDX(ID)
51289 IF(IS.EQ.0) RETURN
51290 DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1))
51291 BIN(IX)=0D0
51292 100 CONTINUE
51293
51294 RETURN
51295 END
51296
51297C*********************************************************************
51298
51299C...PYDUMP
51300C...Dumps histogram contents on file for reading by other program.
51301C...Can also read back own dump.
51302
51303 SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI)
51304
51305C...Double precision declaration.
51306 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51307 IMPLICIT INTEGER(I-N)
51308C...Commonblock.
51309 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
51310 SAVE /PYBINS/
51311C...Local arrays and character variables.
51312 DIMENSION IHI(*),ISS(100),VAL(5)
51313 CHARACTER TITLE*60,FORMAT*13
51314
51315C...Dump all histograms that have been booked,
51316C...including titles and ranges, one after the other.
51317 IF(MDUMP.EQ.1) THEN
51318
51319C...Loop over histograms and find which are wanted and booked.
51320 IF(NHI.LE.0) THEN
51321 NW=IHIST(1)
51322 ELSE
51323 NW=NHI
51324 ENDIF
51325 DO 130 IW=1,NW
51326 IF(NHI.EQ.0) THEN
51327 ID=IW
51328 ELSE
51329 ID=IHI(IW)
51330 ENDIF
51331 IS=INDX(ID)
51332 IF(IS.NE.0) THEN
51333
51334C...Write title, histogram size, filling statistics.
51335 NX=NINT(BIN(IS+1))
51336 DO 100 IT=1,20
51337 IEQ=NINT(BIN(IS+8+NX+IT))
51338 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//
51339 & CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256))
51340 100 CONTINUE
51341 WRITE(LFN,5100) ID,TITLE
51342 WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3)
51343 WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7),
51344 & BIN(IS+8)
51345
51346
51347C...Write histogram contents, in groups of five.
51348 DO 120 IXG=1,(NX+4)/5
51349 DO 110 IXV=1,5
51350 IX=5*IXG+IXV-5
51351 IF(IX.LE.NX) THEN
51352 VAL(IXV)=BIN(IS+8+IX)
51353 ELSE
51354 VAL(IXV)=0D0
51355 ENDIF
51356 110 CONTINUE
51357 WRITE(LFN,5400) (VAL(IXV),IXV=1,5)
51358 120 CONTINUE
51359
51360C...Go to next histogram; finish.
51361 ELSEIF(NHI.GT.0) THEN
51362 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
51363 ENDIF
51364 130 CONTINUE
51365
51366C...Read back in histograms dumped MDUMP=1.
51367 ELSEIF(MDUMP.EQ.2) THEN
51368
51369C...Read histogram number, title and range, and book.
51370 140 READ(LFN,5100,END=170) ID,TITLE
51371 READ(LFN,5200) NX,XL,XU
51372 CALL PYBOOK(ID,TITLE,NX,XL,XU)
51373 IS=INDX(ID)
51374
51375C...Read filling statistics.
51376 READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8)
51377 BIN(IS+5)=DBLE(NENTRY)
51378
51379C...Read histogram contents, in groups of five.
51380 DO 160 IXG=1,(NX+4)/5
51381 READ(LFN,5400) (VAL(IXV),IXV=1,5)
51382 DO 150 IXV=1,5
51383 IX=5*IXG+IXV-5
51384 IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV)
51385 150 CONTINUE
51386 160 CONTINUE
51387
51388C...Go to next histogram; finish.
51389 GOTO 140
51390 170 CONTINUE
51391
51392C...Write histogram contents in column format,
51393C...convenient e.g. for GNUPLOT input.
51394 ELSEIF(MDUMP.EQ.3) THEN
51395
51396C...Find addresses to wanted histograms.
51397 NSS=0
51398 IF(NHI.LE.0) THEN
51399 NW=IHIST(1)
51400 ELSE
51401 NW=NHI
51402 ENDIF
51403 DO 180 IW=1,NW
51404 IF(NHI.EQ.0) THEN
51405 ID=IW
51406 ELSE
51407 ID=IHI(IW)
51408 ENDIF
51409 IS=INDX(ID)
51410 IF(IS.NE.0.AND.NSS.LT.100) THEN
51411 NSS=NSS+1
51412 ISS(NSS)=IS
51413 ELSEIF(NSS.GE.100) THEN
51414 CALL PYERRM(8,'(PYDUMP:) too many histograms requested')
51415 ELSEIF(NHI.GT.0) THEN
51416 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
51417 ENDIF
51418 180 CONTINUE
51419
51420C...Check that they have common number of x bins. Fix format.
51421 NX=NINT(BIN(ISS(1)+1))
51422 DO 190 IW=2,NSS
51423 IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN
51424 CALL PYERRM(8,'(PYDUMP:) different number of bins')
51425 RETURN
51426 ENDIF
51427 190 CONTINUE
51428 FORMAT='(1P,000E12.4)'
51429 WRITE(FORMAT(5:7),'(I3)') NSS+1
51430
51431C...Write histogram contents; first column x values.
51432 DO 200 IX=1,NX
51433 X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4)
51434 WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS)
51435 200 CONTINUE
51436
51437 ENDIF
51438
51439C...Formats for output.
51440 5100 FORMAT(I5,5X,A60)
51441 5200 FORMAT(I5,1P,2D12.4)
51442 5300 FORMAT(I12,1P,3D12.4)
51443 5400 FORMAT(1P,5D12.4)
51444
51445 RETURN
51446 END
51447
51448C*********************************************************************
51449
51450C...PYKCUT
51451C...Dummy routine, which the user can replace in order to make cuts on
51452C...the kinematics on the parton level before the matrix elements are
51453C...evaluated and the event is generated. The cross-section estimates
51454C...will automatically take these cuts into account, so the given
51455C...values are for the allowed phase space region only. MCUT=0 means
51456C...that the event has passed the cuts, MCUT=1 that it has failed.
51457
51458 SUBROUTINE PYKCUT(MCUT)
51459
51460C...Double precision and integer declarations.
51461 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51462 IMPLICIT INTEGER(I-N)
51463 INTEGER PYK,PYCHGE,PYCOMP
51464C...Commonblocks.
51465 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51466 COMMON/PYINT1/MINT(400),VINT(400)
51467 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
51468 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
51469
51470C...Set default value (accepting event) for MCUT.
51471 MCUT=0
51472
51473C...Read out subprocess number.
51474 ISUB=MINT(1)
51475 ISTSB=ISET(ISUB)
51476
51477C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
51478 TAU=VINT(21)
51479 YST=VINT(22)
51480 CTH=0D0
51481 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
51482 TAUP=0D0
51483 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
51484
51485C...Calculate x_1, x_2, x_F.
51486 IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN
51487 X1=SQRT(TAU)*EXP(YST)
51488 X2=SQRT(TAU)*EXP(-YST)
51489 ELSE
51490 X1=SQRT(TAUP)*EXP(YST)
51491 X2=SQRT(TAUP)*EXP(-YST)
51492 ENDIF
51493 XF=X1-X2
51494
51495C...Calculate shat, that, uhat, p_T^2.
51496 SHAT=TAU*VINT(2)
51497 SQM3=VINT(63)
51498 SQM4=VINT(64)
51499 RM3=SQM3/SHAT
51500 RM4=SQM4/SHAT
51501 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
51502 RPTS=4D0*VINT(71)**2/SHAT
51503 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
51504 RM34=2D0*RM3*RM4
51505 RSQM=1D0+RM34
51506 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
51507 THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
51508 UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
51509 PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2))
51510
51511C...Decisions by user to be put here.
51512
51513C...Stop program if this routine is ever called.
51514C...You should not copy these lines to your own routine.
51515 WRITE(MSTU(11),5000)
51516 IF(PYR(0).LT.10D0) STOP
51517
51518C...Format for error printout.
51519 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ',
51520 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
51521 &1X,'Execution stopped!')
51522
51523 RETURN
51524 END
51525
51526C*********************************************************************
51527
51528C...PYEVWT
51529C...Dummy routine, which the user can replace in order to multiply the
51530C...standard PYTHIA differential cross-section by a process- and
51531C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
51532C...to generation of weighted events, with weight 1/WTXS, while for
51533C...MSTP(142)=2 it corresponds to a modification of the underlying
51534C...physics.
51535
51536 SUBROUTINE PYEVWT(WTXS)
51537
51538C...Double precision and integer declarations.
51539 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51540 IMPLICIT INTEGER(I-N)
51541 INTEGER PYK,PYCHGE,PYCOMP
51542C...Commonblocks.
51543 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51544 COMMON/PYINT1/MINT(400),VINT(400)
51545 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
51546 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
51547
51548C...Set default weight for WTXS.
51549 WTXS=1D0
51550
51551C...Read out subprocess number.
51552 ISUB=MINT(1)
51553 ISTSB=ISET(ISUB)
51554
51555C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
51556 TAU=VINT(21)
51557 YST=VINT(22)
51558 CTH=0D0
51559 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
51560 TAUP=0D0
51561 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
51562
51563C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
51564 X1=VINT(41)
51565 X2=VINT(42)
51566 XF=X1-X2
51567 SHAT=VINT(44)
51568 THAT=VINT(45)
51569 UHAT=VINT(46)
51570 PT2=VINT(48)
51571
51572C...Modifications by user to be put here.
51573
51574C...Stop program if this routine is ever called.
51575C...You should not copy these lines to your own routine.
51576 WRITE(MSTU(11),5000)
51577 IF(PYR(0).LT.10D0) STOP
51578
51579C...Format for error printout.
51580 5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ',
51581 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
51582 &1X,'Execution stopped!')
51583
51584 RETURN
51585 END
51586
51587C*********************************************************************
51588
51589C...PYUPIN
51590C...Dummy copy of routine to be called by user to set up a user-defined
51591C...process.
51592
51593 SUBROUTINE PYUPIN(ISUB,TITLE,SIGMAX)
51594
51595C...Double precision and integer declarations.
51596 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51597 IMPLICIT INTEGER(I-N)
51598 INTEGER PYK,PYCHGE,PYCOMP
51599C...Commonblocks.
51600 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51601 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
51602 COMMON/PYINT6/PROC(0:500)
51603 CHARACTER PROC*28
51604 SAVE /PYDAT1/,/PYINT2/,/PYINT6/
51605C...Local character variable.
51606 CHARACTER*(*) TITLE
51607
51608C...Check that subprocess number free.
51609 IF(ISUB.LT.1.OR.ISUB.GT.500.OR.ISET(ISUB).GE.0) THEN
51610 WRITE(MSTU(11),5000) ISUB
51611 STOP
51612 ENDIF
51613
51614C...Fill information on new process.
51615 ISET(ISUB)=11
51616 COEF(ISUB,1)=SIGMAX
51617 PROC(ISUB)=TITLE//' '
51618
51619C...Format for error output.
51620 5000 FORMAT(1X,'Error: user-defined subprocess code ',I4,
51621 &' not allowed.'//1X,'Execution stopped!')
51622
51623 RETURN
51624 END
51625
51626C*********************************************************************
51627
51628C...PYUPEV
51629C...Dummy routine, to be replaced by user. When called from PYTHIA
51630C...the subprocess number ISUB will be given, and PYUPEV is supposed
51631C...to generate an event of this type, to be stored in the PYUPPR
51632C...commonblock. SIGEV gives the differential cross-section associated
51633C...with the event, i.e. the acceptance probability of the event is
51634C...taken to be SIGEV/SIGMAX, where SIGMAX was given in the PYUPIN
51635C...call.
51636
51637 SUBROUTINE PYUPEV(ISUB,SIGEV)
51638
51639C...Double precision and integer declarations.
51640 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51641 IMPLICIT INTEGER(I-N)
51642 INTEGER PYK,PYCHGE,PYCOMP
51643C...Commonblocks.
51644 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51645 COMMON/PYUPPR/NUP,KUP(20,7),NFUP,IFUP(10,2),PUP(20,5),Q2UP(0:10)
51646 SAVE /PYDAT1/,/PYUPPR/
51647
51648C...Stop program if this routine is ever called.
51649C...You should not copy these lines to your own routine.
51650 WRITE(MSTU(11),5000)
51651 IF(PYR(0).LT.10D0) STOP
51652 SIGEV=ISUB
51653
51654C...Format for error printout.
51655 5000 FORMAT(1X,'Error: you did not link your PYUPEV routine ',
51656 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
51657 &1X,'Execution stopped!')
51658
51659 RETURN
51660 END
51661
51662C*********************************************************************
51663C...PYTAUD
51664C...Dummy routine, to be replaced by user, to handle the decay of a
51665C...polarized tau lepton.
51666C...Input:
51667C...ITAU is the position where the decaying tau is stored in /PYJETS/.
51668C...IORIG is the position where the mother of the tau is stored;
51669C... is 0 when the mother is not stored.
51670C...KFORIG is the flavour of the mother of the tau;
51671C... is 0 when the mother is not known.
51672C...Note that IORIG=0 does not necessarily imply KFORIG=0;
51673C... e.g. in B hadron semileptonic decays the W propagator
51674C... is not explicitly stored but the W code is still unambiguous.
51675C...Output:
51676C...NDECAY is the number of decay products in the current tau decay.
51677C...These decay products should be added to the /PYJETS/ common block,
51678C...in positions N+1 through N+NDECAY. For each product I you must
51679C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
51680C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
51681
51682 SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
51683
51684C...Double precision and integer declarations.
51685 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51686 IMPLICIT INTEGER(I-N)
51687 INTEGER PYK,PYCHGE,PYCOMP
51688C...Commonblocks.
51689 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
51690 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51691 SAVE /PYJETS/,/PYDAT1/
51692
51693C...Stop program if this routine is ever called.
51694C...You should not copy these lines to your own routine.
51695 NDECAY=ITAU+IORIG+KFORIG
51696 WRITE(MSTU(11),5000)
51697 IF(PYR(0).LT.10D0) STOP
51698
51699C...Format for error printout.
51700 5000 FORMAT(1X,'Error: you did not link your PYTAUD routine ',
51701 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
51702 &1X,'Execution stopped!')
51703
51704 RETURN
51705 END
51706
51707C*********************************************************************
51708
51709C...PYTIME
51710C...Finds current date and time.
51711C...Since this task is not standardized in Fortran 77, the routine
51712C...is dummy, to be replaced by the user. Examples are given for
51713C...the Fortran 90 routine and DEC Fortran 77, and what to do if
51714C...you do not have access to suitable routines.
51715
51716 SUBROUTINE PYTIME(IDATI)
51717
51718C...Double precision and integer declarations.
51719 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51720 IMPLICIT INTEGER(I-N)
51721 INTEGER PYK,PYCHGE,PYCOMP
51722 CHARACTER*8 ATIME
51723C...Local array.
51724 INTEGER IDATI(6),IDTEMP(3)
51725
51726C...Example 0: if you do not have suitable routines.
51727 DO 100 J=1,6
51728 IDATI(J)=0
51729 100 CONTINUE
51730
51731C...Example 1: Fortran 90 routine.
51732C INTEGER IVAL(8)
51733C CALL DATE_AND_TIME(VALUES=IVAL)
51734C IDATI(1)=IVAL(1)
51735C IDATI(2)=IVAL(2)
51736C IDATI(3)=IVAL(3)
51737C IDATI(4)=IVAL(5)
51738C IDATI(5)=IVAL(6)
51739C IDATI(6)=IVAL(7)
51740
51741C...Example 2: DEC Fortran 77. AIX.
51742C CALL IDATE(IMON,IDAY,IYEAR)
51743C IF(IYEAR.LT.70) THEN
51744C IDATI(1)=2000+IYEAR
51745C ELSEIF(IYEAR.LT.100) THEN
51746C IDATI(1)=1900+IYEAR
51747C ELSE
51748C IDATI(1)=IYEAR
51749C ENDIF
51750C IDATI(2)=IMON
51751C IDATI(3)=IDAY
51752C CALL ITIME(IHOUR,IMIN,ISEC)
51753C IDATI(4)=IHOUR
51754C IDATI(5)=IMIN
51755C IDATI(6)=ISEC
51756
51757C...Example 3: DEC Fortran, IRIX, IRIX64.
51758C CALL IDATE(IMON,IDAY,IYEAR)
51759C IF(IYEAR.LT.70) THEN
51760C IDATI(1)=2000+IYEAR
51761C ELSEIF(IYEAR.LT.100) THEN
51762C IDATI(1)=1900+IYEAR
51763C ELSE
51764C IDATI(1)=IYEAR
51765C ENDIF
51766C IDATI(2)=IMON
51767C IDATI(3)=IDAY
51768C CALL TIME(ATIME)
51769C IHOUR=0
51770C IMIN=0
51771C ISEC=0
51772C READ(ATIME(1:2),'(I2)') IHOUR
51773C READ(ATIME(4:5),'(I2)') IMIN
51774C READ(ATIME(7:8),'(I2)') ISEC
51775C IDATI(4)=IHOUR
51776C IDATI(5)=IMIN
51777C IDATI(6)=ISEC
51778
51779C...Example 4: GNU LINUX libU77, SunOS.
51780C CALL IDATE(IDTEMP)
51781C IDATI(1)=IDTEMP(3)
51782C IDATI(2)=IDTEMP(2)
51783C IDATI(3)=IDTEMP(1)
51784C CALL ITIME(IDTEMP)
51785C IDATI(4)=IDTEMP(1)
51786C IDATI(5)=IDTEMP(2)
51787C IDATI(6)=IDTEMP(3)
51788
51789 RETURN
51790 END