]> git.uio.no Git - u/mrichter/AliRoot.git/blame - PYTHIA6/pythia6203.f
git://git.uio.no / u / mrichter / AliRoot.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
added the delete of EMCAL object posted in the folder when new file is opened
[u/mrichter/AliRoot.git] / PYTHIA6 / pythia6203.f
CommitLineData
b6778262 1C*********************************************************************
2C*********************************************************************
3C* **
4C* August 2001 **
5C* **
6C* The Lund Monte Carlo **
7C* **
8C* PYTHIA version 6.2 **
9C* **
10C* Torbjorn Sjostrand **
11C* Department of Theoretical Physics **
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 and Technicolor 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* PYTHIA 7 efforts coordinated by **
25C* Leif Lonnblad **
26C* Department of Theoretical Physics **
27C* Lund University **
28C* Solvegatan 14A, S-223 62 Lund, Sweden **
29C* phone +46 - 46 - 222 77 80 **
30C* E-mail leif@thep.lu.se **
31C* **
32C* Several parts are written by Hans-Uno Bengtsson **
33C* PYSHOW is written together with Mats Bengtsson **
34C* PYMAEL is written by Emanuel Norrbin **
35C* advanced popcorn baryon production written by Patrik Eden **
36C* code for virtual photons mainly written by Christer Friberg **
37C* code for low-mass strings mainly written by Emanuel Norrbin **
38C* Bose-Einstein code mainly written by Leif Lonnblad **
39C* Lepton number violation code by Peter Skands **
40C* CTEQ parton distributions are by the CTEQ collaboration **
41C* GRV 94 parton distributions are by Glueck, Reya and Vogt **
42C* SaS photon parton distributions together with Gerhard Schuler **
43C* g + g and q + qbar -> t + tbar + H code by Zoltan Kunszt **
44C* MSSM Higgs mass calculation code by M. Carena, **
45C* J.R. Espinosa, M. Quiros and C.E.M. Wagner **
46C* PYGAUS adapted from CERN library (K.S. Kolbig) **
47C* **
48C* The latest program version and documentation is found on WWW **
49C* http://www.thep.lu.se/~torbjorn/Pythia.html **
50C* **
51C* Copyright Torbjorn Sjostrand, Lund 2001 **
52C* **
53C*********************************************************************
54C*********************************************************************
55C *
56C List of subprograms in order of appearance, with main purpose *
57C (S = subroutine, F = function, B = block data) *
58C *
59C B PYDATA to contain all default values *
60C S PYTEST to test the proper functioning of the package *
61C S PYHEPC to convert between /PYJETS/ and /HEPEVT/ records *
62C *
63C S PYINIT to administer the initialization procedure *
64C S PYEVNT to administer the generation of an event *
65C S PYSTAT to print cross-section and other information *
66C S PYINRE to initialize treatment of resonances *
67C S PYINBM to read in beam, target and frame choices *
68C S PYINKI to initialize kinematics of incoming particles *
69C S PYINPR to set up the selection of included processes *
70C S PYXTOT to give total, elastic and diffractive cross-sect. *
71C S PYMAXI to find differential cross-section maxima *
72C S PYPILE to select multiplicity of pileup events *
73C S PYSAVE to save alternatives for gamma-p and gamma-gamma *
74C S PYGAGA to handle lepton -> lepton + gamma branchings *
75C S PYRAND to select subprocess and kinematics for event *
76C S PYSCAT to set up kinematics and colour flow of event *
77C S PYSSPA to simulate initial state spacelike showers *
78C S PYMEMX auxiliary to PYSSPA for ME correction maximum *
79C S PYMEWT auxiliary to PYSSPA for matrix element correction *
80C S PYADSH to administrate sequential final-state showers *
81C S PYRESD to perform resonance decays *
82C S PYMULT to generate multiple interactions *
83C S PYREMN to add on target remnants *
84C S PYDIFF to set up kinematics for diffractive events *
85C S PYDISG to set up kinematics, remnant and showers for DIS *
86C S PYDOCU to compute cross-sections and handle documentation *
87C S PYFRAM to perform boosts between different frames *
88C S PYWIDT to calculate full and partial widths of resonances *
89C S PYOFSH to calculate partial width into off-shell channels *
90C S PYRECO to handle colour reconnection in W+W- events *
91C S PYKLIM to calculate borders of allowed kinematical region *
92C S PYKMAP to construct value of kinematical variable *
93C S PYSIGH to calculate differential cross-sections *
94C S PYPDFU to evaluate parton distributions *
95C S PYPDFL to evaluate parton distributions at low x and Q^2 *
96C S PYPDEL to evaluate electron parton distributions *
97C S PYPDGA to evaluate photon parton distributions (generic) *
98C S PYGGAM to evaluate photon parton distributions (SaS sets) *
99C S PYGVMD to evaluate VMD part of photon parton distributions *
100C S PYGANO to evaluate anomalous part of photon pdf's *
101C S PYGBEH to evaluate Bethe-Heitler part of photon pdf's *
102C S PYGDIR to evaluate direct contribution to photon pdf's *
103C S PYPDPI to evaluate pion parton distributions *
104C S PYPDPR to evaluate proton parton distributions *
105C F PYCTEQ to evaluate the CTEQ 3 proton parton distributions *
106C S PYGRVL to evaluate the GRV 94L proton parton distributions *
107C S PYGRVM to evaluate the GRV 94M proton parton distributions *
108C S PYGRVD to evaluate the GRV 94D proton parton distributions *
109C F PYGRVV auxiliary to the PYGRV* routines *
110C F PYGRVW auxiliary to the PYGRV* routines *
111C F PYGRVS auxiliary to the PYGRV* routines *
112C F PYCT5L to evaluate the CTEQ 5L proton parton distributions *
113C F PYCT5M to evaluate the CTEQ 5M1 proton parton distributions *
114C S PYPDPO to evaluate old proton parton distributions *
115C F PYHFTH to evaluate threshold factor for heavy flavour *
116C S PYSPLI to find flavours left in hadron when one removed *
117C F PYGAMM to evaluate ordinary Gamma function Gamma(x) *
118C S PYWAUX to evaluate auxiliary functions W1(s) and W2(s) *
119C S PYI3AU to evaluate auxiliary function I3(s,t,u,v) *
120C F PYSPEN to evaluate Spence (dilogarithm) function Sp(x) *
121C S PYQQBH to evaluate matrix element for g + g -> Q + Qbar + H *
122C *
123C S PYMSIN to initialize the supersymmetry simulation *
124C S PYAPPS to determine MSSM parameters from SUGRA input *
125C F PYRNMQ to determine running quark masses *
126C F PYRNMT to determine running top mass *
127C S PYTHRG to calculate sfermion third-gen. mass eigenstates *
128C S PYINOM to calculate neutralino/chargino mass eigenstates *
129C F PYRNM3 to determine running M3, gluino mass *
130C S PYEIG4 to calculate eigenvalues and -vectors in 4*4 matrix *
131C S PYHGGM to determine Higgs mass spectrum *
132C S PYSUBH to determine Higgs masses in the MSSM *
133C S PYPOLE to determine Higgs masses in the MSSM *
134C S PYRGHM auxiliary to PYPOLE *
135C S PYGFXX auxiliary to PYRGHM *
136C F PYFINT auxiliary to PYPOLE *
137C F PYFISB auxiliary to PYFINT *
138C S PYSFDC to calculate sfermion decay partial widths *
139C S PYGLUI to calculate gluino decay partial widths *
140C S PYTBBN to calculate 3-body decay of gluino to neutralino *
141C S PYTBBC to calculate 3-body decay of gluino to chargino *
142C S PYNJDC to calculate neutralino decay partial widths *
143C S PYCJDC to calculate chargino decay partial widths *
144C F PYXXZ6 auxiliary for ino 3-body decays *
145C F PYXXGA auxiliary for ino -> ino + gamma decay *
146C F PYX2XG auxiliary for ino -> ino + gauge boson decay *
147C F PYX2XH auxiliary for ino -> ino + Higgs decay *
148C S PYHEXT to calculate non-SM Higgs decay partial widths *
149C F PYH2XX auxiliary for H -> ino + ino decay *
150C F PYGAUS to perform Gaussian integration *
151C F PYSIMP to perform Simpson integration *
152C F PYLAMF to evaluate the lambda kinematics function *
153C S PYTBDY to perform 3-body decay of gauginos *
154C S PYTECM to calculate techni_rho/omega masses *
155C S PYEICG to calculate eigenvalues of a 4*4 complex matrix *
156C S PYCMQR auxiliary to PYEICG *
157C S PYCMQ2 auxiliary to PYEICG *
158C S PYCDIV auxiliary to PYCMQR *
159C S PYCSRT auxiliary to PYCMQR *
160C S PYTHAG auxiliary to PYCMQR *
161C S PYCBAL auxiliary to PYEICG *
162C S PYCBA2 auxiliary to PYEICG *
163C S PYCRTH auxiliary to PYEICG *
164C S PYLDCM auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
165C S PYBKSB auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
166C S PYWIDX to calculate decay widths from within PYWIDT *
167C S PYRVSF to calculate R-violating sfermion decay widths *
168C S PYRVNE to calculate R-violating neutralino decay widths *
169C S PYRVCH to calculate R-violating chargino decay widths *
170C F PYRVSB auxiliary to PYRVSF *
171C S PYRVGW to calculate R-Violating 3-body widths *
172C F PYRVI1 auxiliary to PYRVGW, to do PS integration for res. *
173C F PYRVI2 auxiliary to PYRVGW, to do PS integration for LR-int.*
174C F PYRVI3 auxiliary to PYRVGW, to do PS X integral for int. *
175C F PYRVG1 auxiliary to PYRVI1, general matrix element, res. *
176C F PYRVG2 auxiliary to PYRVI2, general matrix element, LR-int. *
177C F PYRVG3 auxiliary to PYRVI3, to do PS Y integral for int. *
178C F PYRVG4 auxiliary to PYRVG3, general matrix element, int. *
179C F PYRVR auxiliary to PYRVG1, Breit-Wigner *
180C F PYRVS auxiliary to PYRVG2 & PYRVG4 *
181C *
182C S PY1ENT to fill one entry (= parton or particle) *
183C S PY2ENT to fill two entries *
184C S PY3ENT to fill three entries *
185C S PY4ENT to fill four entries *
186C S PY2FRM to interface to generic two-fermion generator *
187C S PY4FRM to interface to generic four-fermion generator *
188C S PY6FRM to interface to generic six-fermion generator *
189C S PY4JET to generate a shower from a given 4-parton config *
190C S PY4JTW to evaluate the weight od a shower history for above *
191C S PY4JTS to set up the parton configuration for above *
192C S PYJOIN to connect entries with colour flow information *
193C S PYGIVE to fill (or query) commonblock variables *
194C S PYEXEC to administrate fragmentation and decay chain *
195C S PYPREP to rearrange showered partons along strings *
196C S PYSTRF to do string fragmentation of jet system *
197C S PYINDF to do independent fragmentation of one or many jets *
198C S PYDECY to do the decay of a particle *
199C S PYDCYK to select parton and hadron flavours in decays *
200C S PYKFDI to select parton and hadron flavours in fragm *
201C S PYNMES to select number of popcorn mesons *
202C S PYKFIN to calculate falvour prod. ratios from input params. *
203C S PYPTDI to select transverse momenta in fragm *
204C S PYZDIS to select longitudinal scaling variable in fragm *
205C S PYSHOW to do timelike parton shower evolution *
206C F PYMAEL auxiliary to PYSHOW, with gluon emission ME's *
207C S PYBOEI to include Bose-Einstein effects (crudely) *
208C S PYBESQ auxiliary to PYBOEI *
209C F PYMASS to give the mass of a particle or parton *
210C F PYMRUN to give the running MSbar mass of a quark *
211C S PYNAME to give the name of a particle or parton *
212C F PYCHGE to give three times the electric charge *
213C F PYCOMP to compress standard KF flavour code to internal KC *
214C S PYERRM to write error messages and abort faulty run *
215C F PYALEM to give the alpha_electromagnetic value *
216C F PYALPS to give the alpha_strong value *
217C F PYANGL to give the angle from known x and y components *
218C F PYR to provide a random number generator *
219C S PYRGET to save the state of the random number generator *
220C S PYRSET to set the state of the random number generator *
221C S PYROBO to rotate and/or boost an event *
222C S PYEDIT to remove unwanted entries from record *
223C S PYLIST to list event record or particle data *
224C S PYLOGO to write a logo *
225C S PYUPDA to update particle data *
226C F PYK to provide integer-valued event information *
227C F PYP to provide real-valued event information *
228C S PYSPHE to perform sphericity analysis *
229C S PYTHRU to perform thrust analysis *
230C S PYCLUS to perform three-dimensional cluster analysis *
231C S PYCELL to perform cluster analysis in (eta, phi, E_T) *
232C S PYJMAS to give high and low jet mass of event *
233C S PYFOWO to give Fox-Wolfram moments *
234C S PYTABU to analyze events, with tabular output *
235C *
236C S PYEEVT to administrate the generation of an e+e- event *
237C S PYXTEE to give the total cross-section at given CM energy *
238C S PYRADK to generate initial state photon radiation *
239C S PYXKFL to select flavour of primary qqbar pair *
240C S PYXJET to select (matrix element) jet multiplicity *
241C S PYX3JT to select kinematics of three-jet event *
242C S PYX4JT to select kinematics of four-jet event *
243C S PYXDIF to select angular orientation of event *
244C S PYONIA to perform generation of onium decay to gluons *
245C *
246C S PYBOOK to book a histogram *
247C S PYFILL to fill an entry in a histogram *
248C S PYFACT to multiply histogram contents by a factor *
249C S PYOPER to perform operations between histograms *
250C S PYHIST to print and reset all histograms *
251C S PYPLOT to print a single histogram *
252C S PYNULL to reset contents of a single histogram *
253C S PYDUMP to dump histogram contents onto a file *
254C *
255C S PYKCUT dummy routine for user kinematical cuts *
256C S PYEVWT dummy routine for weighting events *
257C S UPINIT dummy routine to initialize user processes *
258C S UPEVNT dummy routine to generate a user process event *
259C S PDFSET dummy routine to be removed when using PDFLIB *
260C S STRUCTM dummy routine to be removed when using PDFLIB *
261C S STRUCTP dummy routine to be removed when using PDFLIB *
262C S PYTAUD dummy routine for interface to tau decay libraries *
263C S PYTIME dummy routine for giving date and time *
264C *
265C*********************************************************************
266
267C...PYDATA
268C...Default values for switches and parameters,
269C...and particle, decay and process data.
270
271 BLOCK DATA PYDATA
272
273C...Double precision and integer declarations.
274 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
275 IMPLICIT INTEGER(I-N)
276 INTEGER PYK,PYCHGE,PYCOMP
277C...Commonblocks.
278 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
279 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
280 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
281 COMMON/PYDAT4/CHAF(500,2)
282 CHARACTER CHAF*16
283 COMMON/PYDATR/MRPY(6),RRPY(100)
284 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
285 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
286 COMMON/PYINT1/MINT(400),VINT(400)
287 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
288 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
289 COMMON/PYINT4/MWID(500),WIDS(500,5)
290 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
291 COMMON/PYINT6/PROC(0:500)
292 CHARACTER PROC*28
293 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
294 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
295 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
296 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
297 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
298 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
299 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,/PYSUBS/,
300 &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
301 &/PYINT6/,/PYINT7/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYBINS/
302
303C...PYDAT1, containing status codes and most parameters.
304 DATA MSTU/
305 & 0, 0, 0, 4000,10000, 500, 8000, 0, 0, 2,
306 1 6, 1, 1, 0, 0, 1, 0, 0, 0, 0,
307 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
308 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
309 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
310 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
311 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
312 7 30*0,
313 1 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
314 2 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
315 & 80*0/
316 DATA (PARU(I),I=1,100)/
317 & 3.141592653589793D0, 6.283185307179586D0,
318 & 0.197327D0, 5.06773D0, 0.389380D0, 2.56819D0, 4*0D0,
319 1 0.001D0, 0.09D0, 0.01D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
320 2 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
321 3 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
322 4 2.0D0, 1.0D0, 0.25D0, 2.5D0, 0.05D0,
323 4 0D0, 0D0, 0.0001D0, 0D0, 0D0,
324 5 2.5D0,1.5D0,7.0D0,1.0D0,0.5D0,2.0D0,3.2D0, 0D0, 0D0, 0D0,
325 6 40*0D0/
326 DATA (PARU(I),I=101,200)/
327 & 0.00729735D0, 0.232D0, 0.007764D0, 1.0D0, 1.16639D-5,
328 & 0D0, 0D0, 0D0, 0D0, 0D0,
329 1 0.20D0, 0.25D0, 1.0D0, 4.0D0, 10D0, 0D0, 0D0, 0D0, 0D0, 0D0,
330 2 -0.693D0, -1.0D0, 0.387D0, 1.0D0, -0.08D0,
331 2 -1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,
332 3 1.0D0,-1.0D0, 1.0D0,-1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
333 4 5.0D0, 1.0D0, 1.0D0, 0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0,
334 5 1.0D0, 0D0, 0D0, 0D0, 1000D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0,0D0,
335 6 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
336 7 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
337 8 1.0D0, 1.0D0, 1.0D0, 0.0D0, 0.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
338 9 0D0, 0D0, 0D0, 0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0/
339 DATA MSTJ/
340 & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
341 1 4, 2, 0, 1, 0, 2, 2, 0, 0, 0,
342 2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0,
343 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
344 4 2, 2, 4, 2, 5, 3, 3, 0, 0, 3,
345 5 0, 3, 0, 2, 0, 0, 1, 0, 0, 0,
346 6 40*0,
347 & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2,
348 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
349 2 80*0/
350 DATA PARJ/
351 & 0.10D0, 0.30D0, 0.40D0, 0.05D0, 0.50D0,
352 & 0.50D0, 0.50D0, 0.6D0, 1.2D0, 0.6D0,
353 1 0.50D0,0.60D0,0.75D0, 0D0, 0D0, 0D0, 0D0, 1.0D0, 1.0D0, 0D0,
354 2 0.36D0, 1.0D0,0.01D0, 2.0D0,1.0D0,0.4D0, 0D0, 0D0, 0D0, 0D0,
355 3 0.10D0, 1.0D0, 0.8D0, 1.5D0,0D0,2.0D0,0.2D0, 0D0,0.08D0,0D0,
356 4 0.3D0, 0.58D0, 0.5D0, 0.9D0,0.5D0,1.0D0,1.0D0, 0D0, 0D0,0D0,
357 5 0.77D0, 0.77D0, 0.77D0, -0.05D0, -0.005D0,
358 5 0D0, 0D0, 0D0, 1.0D0, 0D0,
359 6 4.5D0, 0.7D0, 0D0,0.003D0, 0.5D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
360 7 10D0, 1000D0, 100D0, 1000D0, 0D0, 0.7D0,10D0, 0D0,0D0,0.5D0,
361 8 0.29D0, 1.0D0, 1.0D0, 0D0, 10D0, 10D0, 0D0, 0D0, 0D0,1D-4,
362 9 0.02D0, 1.0D0, 0.2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
363 & 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
364 1 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
365 2 1.0D0, 0.25D0,91.187D0,2.489D0, 0.01D0,
366 2 2.0D0, 1.0D0, 0.25D0,0.002D0, 0D0,
367 3 0D0, 0D0, 0D0, 0D0, 0.01D0, 0.99D0, 0D0, 0D0, 0.2D0, 0D0,
368 4 10*0D0,
369 5 10*0D0,
370 6 10*0D0,
371 7 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, -0.693D0,
372 8 -1.0D0, 0.387D0, 1.0D0, -0.08D0, -1.0D0,
373 8 1.0D0, 1.0D0, -0.693D0, -1.0D0, 0.387D0,
374 9 1.0D0, -0.08D0, -1.0D0, 1.0D0, 1.0D0,
375 9 5*0D0/
376
377C...PYDAT2, with particle data and flavour treatment parameters.
378 DATA (KCHG(I,1),I= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
379 &-3,0,-3,6*0,3,9*0,3,2*0,3,4*0,-1,41*0,2,-1,20*0,3*3,7*0,3*3,3*0,
380 &3*3,3*0,3*3,6*0,3*3,3*0,3*3,4*0,-2,-3,2*1,2*0,4,2*3,6,2*-2,2*-3,
381 &0,2*1,2*0,2*3,-2,2*-3,2*0,-3,2*1,2*0,3,0,2*4,2*3,2*6,3,2*1,2*0,
382 &2*3,2*0,4,2*3,2*6,2*3,6,2*-2,2*-3,0,-3,0,2*1,2*0,2*3,0,3,2*-2,
383 &2*-3,2*0,2*-3,0,2*1,2*0,2*3,2*0,2*3,-2,2*-3,2*0,2*-3,2*0,-3,2*0,
384 &2*3,4*0,2*3,2*0,2*3,2*0,2*3,4*0,2*3,2*0,2*3,3*0,3,2*0,3,0,3,0,3,
385 &2*0,3,0,3,3*0,-1,2,-1,2,-1,2,-3,0,-3,0,-3,4*0,3,2*0,3,0,-1,2,-1,
386 &2,-1,2,-3,0,-3,0,-3,2*0,3,3*0,3,8*0,-1,2,-3,6*0,3,2*6,0,3,4*0,3,
387 &139*0/
388 DATA (KCHG(I,2),I= 1, 500)/8*1,12*0,2,20*0,1,107*0,-1,0,2*-1,
389 &2*0,-1,3*0,2*-1,3*0,2*-1,4*0,-1,5*0,2*-1,4*0,2*-1,5*0,2*-1,6*0,
390 &-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,
391 &6*1,9*0,2,3*0,2,0,5*2,2*1,156*0/
392 DATA (KCHG(I,3),I= 1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,3*0,
393 &2*1,39*0,1,0,2*1,20*0,3*1,4*0,6*1,3*0,9*1,3*0,12*1,4*0,100*1,2*0,
394 &2*1,2*0,4*1,2*0,6*1,2*0,8*1,3*0,1,0,2*1,0,3*1,0,4*1,3*0,12*1,3*0,
395 &1,2*0,1,0,12*1,0,1,3*0,1,8*0,4*1,5*0,3*1,0,1,3*0,2*1,139*0/
396 DATA (KCHG(I,4),I= 1, 290)/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,
397 &16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,
398 &37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,
399 &58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,
400 &79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,
401 &100,110,111,113,115,130,211,213,215,221,223,225,310,311,313,315,
402 &321,323,325,331,333,335,411,413,415,421,423,425,431,433,435,441,
403 &443,445,511,513,515,521,523,525,531,533,535,541,543,545,551,553,
404 &555,990,1103,1114,2101,2103,2112,2114,2203,2212,2214,2224,3101,
405 &3103,3112,3114,3122,3201,3203,3212,3214,3222,3224,3303,3312,3314,
406 &3322,3324,3334,4101,4103,4112,4114,4122,4132,4201,4203,4212,4214,
407 &4222,4224,4232,4301,4303,4312,4314,4322,4324,4332,4334,4403,4412,
408 &4414,4422,4424,4432,4434,4444,5101,5103,5112,5114,5122,5132,5142,
409 &5201,5203,5212,5214,5222,5224,5232,5242,5301,5303,5312,5314,5322,
410 &5324,5332,5334,5342,5401,5403,5412,5414,5422,5424,5432,5434,5442,
411 &5444,5503,5512,5514,5522,5524,5532,5534,5542,5544,5554,10111,
412 &10113,10211,10213,10221,10223,10311,10313,10321,10323,10331,
413 &10333,10411,10413,10421,10423,10431,10433,10441,10443,10511,
414 &10513,10521,10523,10531,10533,10541,10543,10551,10553,20113,
415 &20213,20223,20313,20323,20333,20413,20423,20433,20443,20513/
416 DATA (KCHG(I,4),I= 291, 500)/20523,20533,20543,20553,100443,
417 &100553,1000001,1000002,1000003,1000004,1000005,1000006,1000011,
418 &1000012,1000013,1000014,1000015,1000016,1000021,1000022,1000023,
419 &1000024,1000025,1000035,1000037,1000039,2000001,2000002,2000003,
420 &2000004,2000005,2000006,2000011,2000012,2000013,2000014,2000015,
421 &2000016,3000111,3000211,3000221,3000331,3000113,3000213,3000223,
422 &3100021,3100111,3200111,3100113,3200113,3300113,3400113,4000001,
423 &4000002,4000011,4000012,5000039,9900012,9900014,9900016,9900023,
424 &9900024,9900041,9900042,9900110,9900210,9900220,9900330,9900440,
425 &9902110,9902210,139*0/
426 DATA (PMAS(I,1),I= 1, 217)/2*0.33D0,0.5D0,1.5D0,4.8D0,175D0,
427 &2*400D0,2*0D0,0.00051D0,0D0,0.10566D0,0D0,1.777D0,0D0,400D0,
428 &5*0D0,91.188D0,80.45D0,115D0,6*0D0,500D0,900D0,500D0,3*300D0,
429 &3*0D0,5000D0,200D0,40*0D0,1D0,2D0,5D0,16*0D0,0.13498D0,0.7685D0,
430 &1.318D0,0.49767D0,0.13957D0,0.7669D0,1.318D0,0.54745D0,0.78194D0,
431 &1.275D0,2*0.49767D0,0.8961D0,1.432D0,0.4936D0,0.8916D0,1.425D0,
432 &0.95777D0,1.0194D0,1.525D0,1.8693D0,2.01D0,2.46D0,1.8645D0,
433 &2.0067D0,2.46D0,1.9685D0,2.1124D0,2.5735D0,2.9798D0,3.09688D0,
434 &3.5562D0,5.2792D0,5.3248D0,5.83D0,5.2789D0,5.3248D0,5.83D0,
435 &5.3693D0,5.4163D0,6.07D0,6.594D0,6.602D0,7.35D0,9.4D0,9.4603D0,
436 &9.9132D0,0D0,0.77133D0,1.234D0,0.57933D0,0.77133D0,0.93957D0,
437 &1.233D0,0.77133D0,0.93827D0,1.232D0,1.231D0,0.80473D0,0.92953D0,
438 &1.19744D0,1.3872D0,1.11568D0,0.80473D0,0.92953D0,1.19255D0,
439 &1.3837D0,1.18937D0,1.3828D0,1.09361D0,1.3213D0,1.535D0,1.3149D0,
440 &1.5318D0,1.67245D0,1.96908D0,2.00808D0,2.4521D0,2.5D0,2.2849D0,
441 &2.4703D0,1.96908D0,2.00808D0,2.4535D0,2.5D0,2.4529D0,2.5D0,
442 &2.4656D0,2.15432D0,2.17967D0,2.55D0,2.63D0,2.55D0,2.63D0,2.704D0,
443 &2.8D0,3.27531D0,3.59798D0,3.65648D0,3.59798D0,3.65648D0,
444 &3.78663D0,3.82466D0,4.91594D0,5.38897D0,5.40145D0,5.8D0,5.81D0,
445 &5.641D0,5.84D0,7.00575D0,5.38897D0,5.40145D0,5.8D0,5.81D0,5.8D0/
446 DATA (PMAS(I,1),I= 218, 500)/5.81D0,5.84D0,7.00575D0,5.56725D0,
447 &5.57536D0,5.96D0,5.97D0,5.96D0,5.97D0,6.12D0,6.13D0,7.19099D0,
448 &6.67143D0,6.67397D0,7.03724D0,7.0485D0,7.03724D0,7.0485D0,
449 &7.21101D0,7.219D0,8.30945D0,8.31325D0,10.07354D0,10.42272D0,
450 &10.44144D0,10.42272D0,10.44144D0,10.60209D0,10.61426D0,
451 &11.70767D0,11.71147D0,15.11061D0,0.9835D0,1.231D0,0.9835D0,
452 &1.231D0,1D0,1.17D0,1.429D0,1.29D0,1.429D0,1.29D0,2*1.4D0,2.272D0,
453 &2.424D0,2.272D0,2.424D0,2.5D0,2.536D0,3.4151D0,3.46D0,5.68D0,
454 &5.73D0,5.68D0,5.73D0,5.92D0,5.97D0,7.25D0,7.3D0,9.8598D0,9.875D0,
455 &2*1.23D0,1.282D0,2*1.402D0,1.427D0,2*2.372D0,2.56D0,3.5106D0,
456 &2*5.78D0,6.02D0,7.3D0,9.8919D0,3.686D0,10.0233D0,32*500D0,
457 &3*110D0,350D0,3*210D0,500D0,125D0,250D0,400D0,2*350D0,300D0,
458 &4*400D0,1000D0,3*500D0,1200D0,750D0,2*200D0,7*0D0,139*0D0/
459 DATA (PMAS(I,2),I= 1, 500)/5*0D0,1.39816D0,16*0D0,2.47813D0,
460 &2.07115D0,0.00367D0,6*0D0,14.54029D0,0D0,16.66099D0,8.38842D0,
461 &3.3752D0,4.17669D0,3*0D0,417.29147D0,0.39162D0,60*0D0,0.151D0,
462 &0.107D0,2*0D0,0.149D0,0.107D0,0D0,0.00843D0,0.185D0,2*0D0,
463 &0.0505D0,0.109D0,0D0,0.0498D0,0.098D0,0.0002D0,0.00443D0,0.076D0,
464 &2*0D0,0.023D0,2*0D0,0.023D0,2*0D0,0.015D0,0.0013D0,0D0,0.002D0,
465 &2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,5*0D0,0.12D0,
466 &3*0D0,0.12D0,2*0D0,2*0.12D0,3*0D0,0.0394D0,4*0D0,0.036D0,0D0,
467 &0.0358D0,2*0D0,0.0099D0,0D0,0.0091D0,74*0D0,0.06D0,0.142D0,
468 &0.06D0,0.142D0,0D0,0.36D0,0.287D0,0.09D0,0.287D0,0.09D0,0.25D0,
469 &0.08D0,0.05D0,0.02D0,0.05D0,0.02D0,0.05D0,0D0,0.014D0,0.01D0,
470 &8*0.05D0,0D0,0.01D0,2*0.4D0,0.025D0,2*0.174D0,0.053D0,3*0.05D0,
471 &0.0009D0,4*0.05D0,3*0D0,19*1D0,0D0,7*1D0,0D0,1D0,0D0,1D0,0D0,
472 &0.02911D0,0.01741D0,0.04536D0,0.09511D0,0.8686D0,0.62395D0,
473 &0.19192D0,123.27638D0,0.02296D0,0.18886D0,23.26819D0,2.86306D0,
474 &0D0,3.45903D0,2.59359D0,2.59687D0,0.42896D0,0.41912D0,0.14153D0,
475 &2*0.00098D0,0.00097D0,26.7245D0,21.74916D0,0.88159D0,0.88001D0,
476 &7*0D0,139*0D0/
477 DATA (PMAS(I,3),I= 1, 500)/5*0D0,13.98156D0,16*0D0,24.78129D0,
478 &20.71149D0,0.03669D0,6*0D0,145.40294D0,0D0,166.60993D0,
479 &83.88423D0,33.75195D0,41.76694D0,3*0D0,4172.91467D0,3.91621D0,
480 &60*0D0,0.4D0,0.25D0,2*0D0,0.4D0,0.25D0,0D0,0.1D0,0.17D0,2*0D0,
481 &0.2D0,0.12D0,0D0,0.2D0,0.12D0,0.002D0,0.015D0,0.2D0,2*0D0,0.12D0,
482 &2*0D0,0.12D0,2*0D0,0.05D0,0.005D0,0D0,0.01D0,2*0D0,0.05D0,2*0D0,
483 &0.05D0,2*0D0,0.05D0,2*0D0,0.05D0,5*0D0,0.14D0,3*0D0,0.14D0,2*0D0,
484 &2*0.14D0,3*0D0,0.04D0,4*0D0,0.035D0,0D0,0.035D0,2*0D0,0.05D0,0D0,
485 &0.05D0,74*0D0,0.05D0,0.25D0,0.05D0,0.25D0,0D0,0.2D0,0.4D0,
486 &0.005D0,0.4D0,0.01D0,0.35D0,0.001D0,0.1D0,0.08D0,0.1D0,0.08D0,
487 &0.1D0,0D0,0.05D0,0.02D0,6*0.1D0,0.05D0,0.1D0,0D0,0.02D0,2*0.3D0,
488 &0.05D0,2*0.3D0,0.02D0,2*0.1D0,0.03D0,0.001D0,4*0.1D0,3*0D0,
489 &19*10D0,0.00001D0,7*10D0,0.00001D0,10D0,0.00001D0,10D0,0.00001D0,
490 &0.29108D0,0.17412D0,0.45362D0,0.95114D0,8.68604D0,6.23946D0,
491 &1.91923D0,450D0,0.22959D0,1.88863D0,232.68185D0,28.63059D0,0D0,
492 &34.59032D0,25.93594D0,25.96873D0,4.28961D0,4.19124D0,1.41528D0,
493 &0.00977D0,0.00976D0,0.00973D0,267.24501D0,217.49162D0,8.81592D0,
494 &8.80013D0,7*0D0,139*0D0/
495 DATA (PMAS(I,4),I= 1, 500)/12*0D0,658654D0,0D0,0.0872D0,68*0D0,
496 &0.1D0,0.387D0,16*0D0,0.00003D0,2*0D0,15500D0,7804.5D0,5*0D0,
497 &26.762D0,3*0D0,3709D0,5*0D0,0.317D0,2*0D0,0.1244D0,2*0D0,0.14D0,
498 &5*0D0,0.468D0,2*0D0,0.462D0,2*0D0,0.483D0,2*0D0,0.15D0,18*0D0,
499 &44.34D0,0D0,78.88D0,4*0D0,23.96D0,2*0D0,49.1D0,0D0,87.1D0,0D0,
500 &24.6D0,4*0D0,0.0618D0,0.029D0,6*0D0,0.106D0,6*0D0,0.019D0,2*0D0,
501 &7*0.1D0,4*0D0,0.342D0,2*0.387D0,6*0D0,2*0.387D0,6*0D0,0.387D0,
502 &0D0,0.387D0,2*0D0,8*0.387D0,0D0,9*0.387D0,112*0D0,139*0D0/
503 DATA PARF/
504 & 0.5D0,0.25D0, 0.5D0,0.25D0, 1D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
505 1 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
506 2 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
507 3 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
508 4 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
509 5 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
510 6 0.75D0, 0.5D0, 0D0,0.1667D0,0.0833D0,0.1667D0,0D0,0D0,0D0, 0D0,
511 7 0D0, 0D0, 1D0,0.3333D0,0.6667D0,0.3333D0,0D0,0D0,0D0, 0D0,
512 8 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
513 9 0.0099D0, 0.0056D0, 0.199D0, 1.35D0, 4.5D0, 165D0, 4*0D0,
514 & 0.325D0,0.325D0,0.5D0,1.6D0, 5.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
515 1 0D0,0.11D0,0.16D0,0.048D0,0.50D0,0.45D0,0.55D0,0.60D0,0D0,0D0,
516 2 0.2D0, 0.1D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
517 3 60*0D0,
518 4 0.2D0, 0.5D0, 8*0D0,
519 5 1800*0D0/
520 DATA ((VCKM(I,J),J=1,4),I=1,4)/
521 & 0.95113D0, 0.04884D0, 0.00003D0, 0.00000D0,
522 & 0.04884D0, 0.94940D0, 0.00176D0, 0.00000D0,
523 & 0.00003D0, 0.00176D0, 0.99821D0, 0.00000D0,
524 & 0.00000D0, 0.00000D0, 0.00000D0, 1.00000D0/
525
526C...PYDAT3, with particle decay parameters and data.
527 DATA (MDCY(I,1),I= 1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,
528 &4*1,3*0,2*1,40*0,3*1,16*0,3*1,2*0,9*1,0,32*1,2*0,1,3*0,1,2*0,2*1,
529 &2*0,3*1,2*0,4*1,0,5*1,2*0,4*1,2*0,5*1,2*0,6*1,0,7*1,2*0,5*1,2*0,
530 &6*1,2*0,7*1,2*0,8*1,0,75*1,0,7*1,0,1,0,1,0,26*1,146*0/
531 DATA (MDCY(I,2),I= 1, 351)/1,9,17,25,33,41,56,66,2*0,76,80,82,
532 &87,89,143,145,150,2*0,153,162,174,190,210,6*0,289,0,311,334,420,
533 &503,3*0,530,539,40*0,540,541,545,16*0,554,556,561,570,579,581,
534 &583,590,598,604,613,615,617,620,630,636,639,650,656,667,673,736,
535 &739,747,808,810,818,851,853,857,858,861,863,899,900,908,944,945,
536 &953,992,993,997,1028,1029,1033,1034,1043,2*0,1045,3*0,1046,2*0,
537 &1049,1052,2*0,1053,1055,1058,2*0,1062,1063,1066,1069,0,1072,1077,
538 &1079,1082,1084,2*0,1088,1089,1090,1166,2*0,1170,1171,1172,1173,
539 &1174,2*0,1178,1179,1181,1182,1184,1188,0,1189,1193,1197,1201,
540 &1205,1209,1213,2*0,1217,1218,1219,1236,1245,2*0,1254,1255,1256,
541 &1257,1258,1267,2*0,1276,1277,1278,1279,1280,1289,1290,2*0,1299,
542 &1308,1317,1326,1335,1344,1353,1362,0,1371,1380,1389,1398,1407,
543 &1416,1425,1434,1443,1452,1453,1454,1455,1456,1461,1464,1466,1471,
544 &1473,1478,1485,1489,1491,1493,1495,1497,1499,1501,1503,1504,1506,
545 &1508,1510,1512,1514,1516,1518,1520,1522,1523,1525,1527,1541,1543,
546 &1545,1549,1551,1553,1555,1557,1559,1561,1563,1565,1567,1578,1592,
547 &1631,1652,1691,1712,1751,1775,1806,1832,1864,1890,1922,1948,2009,
548 &2160,2406,2615,2877,3155,0,3388,3431,3456,3499,3524,3567,3592,0,
549 &3628,0,3664,0,3700,3708,3716,3724,3727,3751,3777,3801,3807,3814,
550 &3821,3828,3834,3840,3849,3853,3857,3860,3862,3883,3905,3927,3949/
551 DATA (MDCY(I,2),I= 352, 500)/3964,3976,3983,146*0/
552 DATA (MDCY(I,3),I= 1, 500)/5*8,15,2*10,2*0,4,2,5,2,54,2,5,3,
553 &2*0,9,12,16,20,79,6*0,22,0,23,86,83,27,3*0,9,1,40*0,1,4,9,16*0,2,
554 &5,2*9,2*2,7,8,6,9,2*2,3,10,6,3,11,6,11,6,63,3,8,61,2,8,33,2,4,1,
555 &3,2,36,1,8,36,1,8,39,1,4,31,1,4,1,9,2,2*0,1,3*0,3,2*0,3,1,2*0,2,
556 &3,4,2*0,1,3*3,0,5,2,3,2,4,2*0,2*1,76,4,2*0,4*1,4,2*0,1,2,1,2,4,1,
557 &0,7*4,2*0,2*1,17,2*9,2*0,4*1,2*9,2*0,4*1,9,1,9,2*0,8*9,0,9*9,4*1,
558 &5,3,2,5,2,5,7,4,7*2,1,9*2,1,2*2,14,2*2,4,9*2,11,14,39,21,39,21,
559 &39,24,31,26,32,26,32,26,61,151,246,209,262,278,233,0,43,25,43,25,
560 &43,25,36,0,36,0,36,0,3*8,3,24,26,24,6,3*7,2*6,9,2*4,3,2,21,3*22,
561 &15,12,2*7,146*0/
562 DATA (MDME(I,1),I= 1,8000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
563 &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,
564 &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,
565 &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,
566 &3*1,4*-1,6*1,2*-1,3*1,-1,12*1,62*-1,6*1,2*-1,3*1,-1,9*1,62*-1,
567 &3*1,-1,3*1,-1,1,18*-1,4*1,2*-1,2*1,-1,1225*1,2*-1,248*1,2*-1,
568 &1725*1,2*-1,6*1,2*-1,9*1,-1,3*1,-1,3*1,5*-1,3*1,-1,14*1,2*-1,6*1,
569 &2*-1,67*1,2*-1,6*1,2*-1,4*1,-1,107*1,4011*0/
570 DATA (MDME(I,2),I= 1,8000)/43*102,4*0,102,0,6*53,3*102,4*0,102,
571 &2*0,3*102,4*0,102,2*0,6*102,42,6*102,2*42,2*0,8*41,2*0,36*41,
572 &8*102,0,102,0,102,2*0,21*102,8*32,8*0,16*32,4*0,8*32,9*0,62*53,
573 &8*32,14*0,16*32,7*0,8*32,16*0,62*53,8*32,13*0,62*53,4*32,5*0,
574 &18*53,6*32,4*0,12,2*42,2*11,9*42,0,2,3,15*0,4*42,5*0,3,12*0,2,
575 &3*0,1,0,3,16*0,2*3,15*0,2*42,2*3,18*0,2*3,3*0,1,11*0,22*42,41*0,
576 &2*3,9*0,16*42,45*0,3,10*0,10*42,20*0,2*13,6*0,12,2*0,12,0,12,
577 &14*42,16*0,48,3*13,2*42,9*0,14*42,16*0,48,3*13,2*42,9*0,14*42,
578 &19*0,48,3*13,2*42,6*0,2*11,28*42,5*0,32,3*0,4*32,2*4,0,32,45*0,
579 &14*42,52*0,10*13,2*42,2*11,4*0,2*42,2*11,6*0,2*42,2*11,0,2*42,
580 &2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,
581 &2*0,3*42,8*0,48,3*13,20*42,4*0,18*42,4*0,9*42,0,162*42,50*0,2*12,
582 &17*0,2*32,33*0,12,9*0,32,2*0,12,11*0,4*32,2*4,5*0,2108*53,4*32,
583 &3*0,6*32,3*0,4*32,3*0,4*32,8*0,8*32,14*0,16*32,12*0,8*32,8*0,
584 &46*32,3*53,12*0,8*32,13*0,66*51,6*32,9*0,9*32,4028*0/
585 DATA (BRAT(I) ,I= 1, 346)/43*0D0,0.00003D0,0.001765D0,
586 &0.998205D0,35*0D0,1D0,6*0D0,0.1783D0,0.1735D0,0.1131D0,0.2494D0,
587 &0.003D0,0.09D0,0.0027D0,0.01D0,0.0014D0,0.0012D0,2*0.00025D0,
588 &0.0071D0,0.012D0,0.0004D0,0.00075D0,0.00006D0,2*0.00078D0,
589 &0.0034D0,0.08D0,0.011D0,0.0191D0,0.00006D0,0.005D0,0.0133D0,
590 &0.0067D0,0.0005D0,0.0035D0,0.0006D0,0.0015D0,0.00021D0,0.0002D0,
591 &0.00075D0,0.0001D0,0.0002D0,0.0011D0,3*0.0002D0,0.00022D0,
592 &0.0004D0,0.0001D0,2*0.00205D0,2*0.00069D0,0.00025D0,0.00051D0,
593 &0.00025D0,35*0D0,0.153995D0,0.11942D0,0.153984D0,0.119259D0,
594 &0.152272D0,3*0D0,0.033576D0,0.066806D0,0.033576D0,0.066806D0,
595 &0.0335D0,0.066806D0,2*0D0,0.321369D0,0.016494D0,2*0D0,0.016502D0,
596 &0.320615D0,2*0D0,0.00001D0,0.000591D0,6*0D0,2*0.108166D0,
597 &0.108087D0,0D0,0.000001D0,0D0,0.000349D0,0.048707D0,0.768308D0,
598 &4*0D0,0.000227D0,0.064048D0,0D0,0.040621D0,0.002043D0,0.000615D0,
599 &0.006981D0,0.068099D0,62*0D0,0.145835D0,0.113276D0,0.145835D0,
600 &0.113271D0,0.145781D0,0.049002D0,2*0D0,0.032025D0,0.063642D0,
601 &0.032025D0,0.063642D0,0.032022D0,0.063642D0,8*0D0,0.251225D0,
602 &0.0129D0,0.000006D0,0D0,0.0129D0,0.250764D0,0.00038D0,0D0,
603 &0.000008D0,0.000465D0,0.215418D0,5*0D0,2*0.085312D0,0.08531D0,
604 &7*0D0,0.000049D0,0.000774D0,5*0D0,0.000074D0,0D0,0.000417D0/
605 DATA (BRAT(I) ,I= 347, 651)/0.000015D0,0.000061D0,0.30671D0,
606 &0.689011D0,0D0,0.002889D0,69*0D0,0.000001D0,0.000121D0,
607 &0.001924D0,4*0D0,0.000001D0,0.000184D0,0D0,0.003106D0,0.000015D0,
608 &0.000003D0,2*0D0,0.994646D0,66*0D0,0.000021D0,0.090135D0,2*0D0,
609 &0.000013D0,0.003714D0,0D0,0.906117D0,18*0D0,3*0.215119D0,
610 &0.214724D0,2*0D0,0.06996D0,0.069959D0,0D0,2*1D0,2*0.08D0,0.76D0,
611 &0.08D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,
612 &0.005D0,0.988D0,0.012D0,0.998739D0,0.00079D0,0.00038D0,
613 &0.000046D0,0.000045D0,2*0.34725D0,0.144D0,0.104D0,0.0245D0,
614 &2*0.01225D0,0.0028D0,0.0057D0,0.2112D0,0.1256D0,2*0.1939D0,
615 &2*0.1359D0,0.002D0,0.001D0,0.0006D0,0.999877D0,0.000123D0,
616 &0.99955D0,0.00045D0,2*0.34725D0,0.144D0,0.104D0,0.049D0,0.0028D0,
617 &0.0057D0,0.3923D0,0.321D0,0.2317D0,0.0478D0,0.0049D0,0.0013D0,
618 &0.0003D0,0.0007D0,0.89D0,0.08693D0,0.0221D0,0.00083D0,
619 &2*0.00007D0,0.564D0,0.282D0,0.072D0,0.028D0,0.023D0,2*0.0115D0,
620 &0.005D0,0.003D0,0.6861D0,0.3139D0,2*0.5D0,0.665D0,0.333D0,
621 &0.002D0,0.333D0,0.166D0,0.168D0,0.084D0,0.087D0,0.043D0,0.059D0,
622 &2*0.029D0,0.002D0,0.6352D0,0.2116D0,0.0559D0,0.0173D0,0.0482D0,
623 &0.0318D0,0.666D0,0.333D0,0.001D0,0.332D0,0.166D0,0.168D0,0.084D0,
624 &0.086D0,0.043D0,0.059D0,2*0.029D0,2*0.002D0,0.437D0,0.208D0/
625 DATA (BRAT(I) ,I= 652, 823)/0.302D0,0.0302D0,0.0212D0,0.0016D0,
626 &0.48947D0,0.34D0,3*0.043D0,0.027D0,0.0126D0,0.0013D0,0.0003D0,
627 &0.00025D0,0.00008D0,0.444D0,2*0.222D0,0.104D0,2*0.004D0,0.07D0,
628 &0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,0.07D0,0.065D0,2*0.005D0,
629 &2*0.011D0,5*0.001D0,0.026D0,0.019D0,0.066D0,0.041D0,0.045D0,
630 &0.076D0,0.0073D0,2*0.0047D0,0.026D0,0.001D0,0.0006D0,0.0066D0,
631 &0.005D0,2*0.003D0,2*0.0006D0,2*0.001D0,0.006D0,0.005D0,0.012D0,
632 &0.0057D0,0.067D0,0.008D0,0.0022D0,0.027D0,0.004D0,0.019D0,
633 &0.012D0,0.002D0,0.009D0,0.0218D0,0.001D0,0.022D0,0.087D0,0.001D0,
634 &0.0019D0,0.0015D0,0.0028D0,0.683D0,0.306D0,0.011D0,0.3D0,0.15D0,
635 &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.034D0,0.027D0,
636 &2*0.002D0,2*0.004D0,2*0.002D0,0.034D0,0.027D0,2*0.002D0,
637 &2*0.004D0,2*0.002D0,0.0365D0,0.045D0,0.073D0,0.062D0,3*0.021D0,
638 &0.0061D0,0.015D0,0.025D0,0.0088D0,0.074D0,0.0109D0,0.0041D0,
639 &0.002D0,0.0035D0,0.0011D0,0.001D0,0.0027D0,2*0.0016D0,0.0018D0,
640 &0.011D0,0.0063D0,0.0052D0,0.018D0,0.016D0,0.0034D0,0.0036D0,
641 &0.0009D0,0.0006D0,0.015D0,0.0923D0,0.018D0,0.022D0,0.0077D0,
642 &0.009D0,0.0075D0,0.024D0,0.0085D0,0.067D0,0.0511D0,0.017D0,
643 &0.0004D0,0.0028D0,0.619D0,0.381D0,0.3D0,0.15D0,0.16D0,0.08D0,
644 &0.13D0,0.06D0,0.08D0,0.04D0,0.01D0,2*0.02D0,0.03D0,2*0.005D0/
645 DATA (BRAT(I) ,I= 824, 991)/2*0.02D0,0.03D0,2*0.005D0,0.015D0,
646 &0.037D0,0.028D0,0.079D0,0.095D0,0.052D0,0.0078D0,4*0.001D0,
647 &0.028D0,0.033D0,0.026D0,0.05D0,0.01D0,4*0.005D0,0.25D0,0.0952D0,
648 &0.94D0,0.06D0,2*0.4D0,2*0.1D0,1D0,0.0602D0,0.0601D0,0.8797D0,
649 &0.135D0,0.865D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.02D0,
650 &0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,
651 &0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,0.0135D0,
652 &0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,0.0019D0,0.0025D0,
653 &0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0,
654 &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.02D0,0.055D0,
655 &2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
656 &0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,
657 &0.018D0,0.015D0,0.0185D0,0.0135D0,0.025D0,0.0004D0,0.0007D0,
658 &0.0008D0,0.0014D0,0.0019D0,0.0025D0,0.4291D0,0.08D0,0.07D0,
659 &0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,
660 &0.06D0,0.08D0,0.04D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,
661 &0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,
662 &0.011D0,0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,
663 &0.0135D0,0.025D0,2*0.0002D0,0.0007D0,2*0.0004D0,0.0014D0,0.001D0,
664 &0.0009D0,0.0025D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0/
665 DATA (BRAT(I) ,I= 992,1183)/1D0,2*0.3D0,2*0.2D0,0.047D0,0.122D0,
666 &0.006D0,0.012D0,0.035D0,0.012D0,0.035D0,0.003D0,0.007D0,0.15D0,
667 &0.037D0,0.008D0,0.002D0,0.05D0,0.015D0,0.003D0,0.001D0,0.014D0,
668 &0.042D0,0.014D0,0.042D0,0.24D0,0.065D0,0.012D0,0.003D0,0.001D0,
669 &0.002D0,0.001D0,0.002D0,0.014D0,0.003D0,1D0,2*0.3D0,2*0.2D0,1D0,
670 &0.0252D0,0.0248D0,0.0267D0,0.015D0,0.045D0,0.015D0,0.045D0,
671 &0.7743D0,0.029D0,0.22D0,0.78D0,1D0,0.331D0,0.663D0,0.006D0,
672 &0.663D0,0.331D0,0.006D0,1D0,0.999D0,0.001D0,0.88D0,2*0.06D0,
673 &0.639D0,0.358D0,0.002D0,0.001D0,1D0,0.88D0,2*0.06D0,0.516D0,
674 &0.483D0,0.001D0,0.88D0,2*0.06D0,0.9988D0,0.0001D0,0.0006D0,
675 &0.0004D0,0.0001D0,0.667D0,0.333D0,0.9954D0,0.0011D0,0.0035D0,
676 &0.333D0,0.667D0,0.676D0,0.234D0,0.085D0,0.005D0,2*1D0,0.018D0,
677 &2*0.005D0,0.003D0,0.002D0,2*0.006D0,0.018D0,2*0.005D0,0.003D0,
678 &0.002D0,2*0.006D0,0.0066D0,0.025D0,0.016D0,0.0088D0,2*0.005D0,
679 &0.0058D0,0.005D0,0.0055D0,4*0.004D0,2*0.002D0,2*0.004D0,0.003D0,
680 &0.002D0,2*0.003D0,3*0.002D0,2*0.001D0,0.002D0,2*0.001D0,
681 &2*0.002D0,0.0013D0,0.0018D0,5*0.001D0,4*0.003D0,2*0.005D0,
682 &2*0.002D0,2*0.001D0,2*0.002D0,2*0.001D0,0.2432D0,0.057D0,
683 &2*0.035D0,0.15D0,2*0.075D0,0.03D0,2*0.015D0,2*0.08D0,0.76D0,
684 &0.08D0,4*1D0,2*0.08D0,0.76D0,0.08D0,1D0,2*0.5D0,1D0,2*0.5D0/
685 DATA (BRAT(I) ,I=1184,1377)/2*0.08D0,0.76D0,0.08D0,1D0,2*0.08D0,
686 &0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,
687 &0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,0.08D0,2*1D0,2*0.105D0,
688 &0.04D0,0.0077D0,0.02D0,0.0235D0,0.0285D0,0.0435D0,0.0011D0,
689 &0.0022D0,0.0044D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,
690 &2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,
691 &2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,
692 &4*1D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,
693 &0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,
694 &0.005D0,4*1D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
695 &0.015D0,0.005D0,1D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
696 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
697 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
698 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
699 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
700 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
701 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
702 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
703 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
704 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0/
705 DATA (BRAT(I) ,I=1378,1580)/0.015D0,0.005D0,2*0.105D0,0.04D0,
706 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
707 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
708 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
709 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
710 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
711 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
712 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
713 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,0.52D0,0.26D0,
714 &0.11D0,2*0.055D0,0.333D0,0.334D0,0.333D0,0.667D0,0.333D0,0.28D0,
715 &0.14D0,0.313D0,0.157D0,0.11D0,0.667D0,0.333D0,0.28D0,0.14D0,
716 &0.313D0,0.157D0,0.11D0,0.36D0,0.18D0,0.03D0,2*0.015D0,2*0.2D0,
717 &4*0.25D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,
718 &0.333D0,4*0.5D0,0.007D0,0.993D0,1D0,0.667D0,0.333D0,0.667D0,
719 &0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,8*0.5D0,0.02D0,0.98D0,
720 &1D0,4*0.5D0,3*0.146D0,3*0.05D0,0.15D0,2*0.05D0,4*0.024D0,0.066D0,
721 &0.667D0,0.333D0,0.667D0,0.333D0,4*0.25D0,0.667D0,0.333D0,0.667D0,
722 &0.333D0,2*0.5D0,0.273D0,0.727D0,0.667D0,0.333D0,0.667D0,0.333D0,
723 &4*0.5D0,0.35D0,0.65D0,2*0.0083D0,0.1866D0,0.324D0,0.184D0,
724 &0.027D0,0.001D0,0.093D0,0.087D0,0.078D0,0.0028D0,3*0.014D0/
725 DATA (BRAT(I) ,I=1581,3853)/0.008D0,0.024D0,0.008D0,0.024D0,
726 &0.425D0,0.02D0,0.185D0,0.088D0,0.043D0,0.067D0,0.066D0,2108*0D0,
727 &0.017431D0,0.054048D0,0.857694D0,2*0D0,0.00025D0,0.070578D0,0D0,
728 &0.022748D0,0.026576D0,0.359486D0,0.561581D0,2*0D0,0.000104D0,
729 &0.029504D0,0.011185D0,0.034681D0,0.550354D0,2*0D0,0.00016D0,
730 &0.045287D0,0.358333D0,0.445781D0,0D0,0.554219D0,0.144051D0,
731 &2*0.351902D0,0D0,0.082107D0,0.029566D0,0.001511D0,0.000726D0,
732 &0.004518D0,0.006522D0,0.004518D0,0.006522D0,0.004513D0,3*0D0,
733 &0.002908D0,0.000973D0,0.002908D0,0.000973D0,0.002908D0,
734 &0.000973D0,2*0D0,0.143982D0,0.489888D0,0.1951D0,0D0,0.114302D0,
735 &0.008426D0,0.014868D0,0.000763D0,2*0D0,0.000763D0,0.01484D0,
736 &0.000003D0,2*0D0,0.000027D0,0.001945D0,5*0D0,3*0.00503D0,0D0,
737 &0.133776D0,0.003284D0,0.37169D0,0.006838D0,2*0.030954D0,
738 &0.00163D0,0D0,0.047224D0,0.073737D0,0.047224D0,0.073732D0,
739 &0.047179D0,3*0D0,0.034761D0,0.009166D0,0.034761D0,0.009166D0,
740 &0.034759D0,0.009166D0,2*0D0,4*0.009069D0,0.510147D0,0.453576D0,
741 &6*0D0,1D0,6*0D0,1D0,4*0.001128D0,0.571047D0,0.382288D0,
742 &0.042153D0,4*0.016597D0,0.93361D0,0D0,4*0.016597D0,0.93361D0,0D0,
743 &4*0.05515D0,0.34469D0,0D0,0.228998D0,0.164208D0,0.041503D0,
744 &0.850973D0,0.005411D0,0.045025D0,0.098591D0,0.849898D0/
745 DATA (BRAT(I) ,I=3854,3984)/0.021617D0,0.030018D0,0.098466D0,
746 &0.294448D0,0.10945D0,0.596102D0,0.389906D0,0.610094D0,3*0.0633D0,
747 &0.063299D0,0.063295D0,0.056281D0,2*0D0,6*0.020495D0,2*0D0,
748 &0.327919D0,0.04099D0,0.045236D0,0.090112D0,0D0,0.19874D0,
749 &0.010204D0,0.000003D0,0.010205D0,0.198356D0,0.000151D0,
750 &0.000006D0,0.000367D0,0.081967D0,0.19874D0,0.010204D0,0.000003D0,
751 &0.010205D0,0.198356D0,0.000151D0,0.000006D0,0.000367D0,
752 &0.081967D0,4*0D0,0.198776D0,0.010206D0,0.000003D0,0.010207D0,
753 &0.19839D0,0.000151D0,0.000006D0,0.000367D0,0.081893D0,0.198776D0,
754 &0.010206D0,0.000003D0,0.010207D0,0.19839D0,0.000151D0,0.000006D0,
755 &0.000367D0,0.081893D0,4*0D0,0.199344D0,0.010234D0,0.000003D0,
756 &0.010236D0,0.198928D0,0.000149D0,0.000006D0,0.000368D0,
757 &0.080733D0,0.199344D0,0.010234D0,0.000003D0,0.010236D0,
758 &0.198928D0,0.000149D0,0.000006D0,0.000368D0,0.080733D0,4*0D0,
759 &0.184738D0,0.104588D0,0.184738D0,0.104587D0,0.184731D0,0.09582D0,
760 &0.022902D0,0.008429D0,0.015602D0,0.022902D0,0.008429D0,
761 &0.015602D0,0.022902D0,0.008429D0,0.015602D0,0.28959D0,0.01487D0,
762 &0.000008D0,0.01487D0,0.289061D0,0.000492D0,0.000009D0,0.000536D0,
763 &0.27911D0,2*0.037151D0,0.03715D0,0.090266D0,2*0.001805D0,
764 &0.090266D0,0.001805D0,0.812263D0,0.00179D0,0.090428D0,0.001809D0/
765 DATA (BRAT(I) ,I=3985,8000)/0.001808D0,0.090428D0,0.001808D0,
766 &0.81372D0,0D0,4011*0D0/
767 DATA (KFDP(I,1),I= 1, 377)/21,22,23,4*-24,25,21,22,23,4*24,25,
768 &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
769 &4*24,25,37,1000022,1000023,1000025,1000035,1000021,1000039,21,22,
770 &23,4*-24,25,2*-37,21,22,23,4*24,25,2*37,22,23,-24,25,23,24,-12,
771 &22,23,-24,25,23,24,-12,-14,48*16,22,23,-24,25,23,24,22,23,-24,25,
772 &-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,
773 &3,4,5,6,7,8,11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,-13,
774 &-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1000022,
775 &2*1000023,3*1000025,4*1000035,2*1000024,2*1000037,1000001,
776 &2000001,1000001,-1000001,1000002,2000002,1000002,-1000002,
777 &1000003,2000003,1000003,-1000003,1000004,2000004,1000004,
778 &-1000004,1000005,2000005,1000005,-1000005,1000006,2000006,
779 &1000006,-1000006,1000011,2000011,1000011,-1000011,1000012,
780 &2000012,1000012,-1000012,1000013,2000013,1000013,-1000013,
781 &1000014,2000014,1000014,-1000014,1000015,2000015,1000015,
782 &-1000015,1000016,2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,12,
783 &13,14,15,16,17,18,24,37,2*23,25,35,4*-1,4*-3,4*-5,4*-7,-11,-13,
784 &-15,-17,3*24,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,25,24,
785 &37,23,25,36,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
786 &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002/
787 DATA (KFDP(I,1),I= 378, 580)/1000002,-1000002,1000003,2000003,
788 &1000003,-1000003,1000004,2000004,1000004,-1000004,1000005,
789 &2000005,1000005,-1000005,1000006,2000006,1000006,-1000006,
790 &1000011,2000011,1000011,-1000011,1000012,2000012,1000012,
791 &-1000012,1000013,2000013,1000013,-1000013,1000014,2000014,
792 &1000014,-1000014,1000015,2000015,1000015,-1000015,1000016,
793 &2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,
794 &24,23,25,24,37,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
795 &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002,
796 &1000002,-1000002,1000003,2000003,1000003,-1000003,1000004,
797 &2000004,1000004,-1000004,1000005,2000005,1000005,-1000005,
798 &1000006,2000006,1000006,-1000006,1000011,2000011,1000011,
799 &-1000011,1000012,2000012,1000012,-1000012,1000013,2000013,
800 &1000013,-1000013,1000014,2000014,1000014,-1000014,1000015,
801 &2000015,1000015,-1000015,1000016,2000016,1000016,-1000016,-1,-3,
802 &-5,-7,-11,-13,-15,-17,24,2*1000022,2*1000023,2*1000025,2*1000035,
803 &1000006,2000006,1000006,2000006,-1000001,-1000003,-1000011,
804 &-1000013,-1000015,-2000015,1,2,3,4,5,6,11,13,15,2,82,-11,-13,2*2,
805 &-12,-14,-16,2*-2,2*-4,-2,-4,2*22,211,111,221,13,11,213,-213,221,
806 &223,321,130,310,111,331,111,211,-12,12,-14,14,211,111,22,-13,-11/
807 DATA (KFDP(I,1),I= 581, 992)/2*211,213,113,221,223,321,211,331,
808 &22,111,211,2*22,211,22,111,211,22,211,221,111,11,211,111,2*211,
809 &321,130,310,221,111,211,111,130,310,321,2*311,321,311,323,313,
810 &323,313,321,3*311,-13,3*211,12,14,311,2*321,311,321,313,323,313,
811 &323,311,4*321,211,111,3*22,111,321,130,-213,113,213,211,22,111,
812 &11,13,211,321,130,310,221,211,111,11*-11,11*-13,-311,-313,-311,
813 &-313,-20313,2*-311,-313,-311,-313,2*111,2*221,2*331,2*113,2*223,
814 &2*333,-311,-313,2*-321,211,-311,-321,333,-311,-313,-321,211,
815 &2*-321,2*-311,-321,211,113,421,2*411,421,411,423,413,423,413,421,
816 &411,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,-313,2*-311,
817 &-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,3*-321,-311,
818 &-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,-321,3*-311,
819 &211,113,321,2*421,411,421,413,423,413,423,411,421,-15,5*-11,
820 &5*-13,221,331,333,221,331,333,10221,211,213,211,213,321,323,321,
821 &323,2212,221,331,333,221,2*2,2*431,421,411,423,413,82,11,13,82,
822 &443,82,6*12,6*14,2*16,3*-411,3*-413,2*-411,2*-413,2*441,2*443,
823 &2*20443,2*2,2*4,2,4,511,521,511,523,513,523,513,521,511,6*12,
824 &6*14,2*16,3*-421,3*-423,2*-421,2*-423,2*441,2*443,2*20443,2*2,
825 &2*4,2,4,521,511,521,513,523,513,523,511,521,6*12,6*14,2*16,
826 &3*-431,3*-433,2*-431,2*-433,3*441,3*443,3*20443,2*2,2*4,2,4,531/
827 DATA (KFDP(I,1),I= 993,1402)/521,511,523,513,16,2*4,2*12,2*14,
828 &2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,2*-1,541,511,521,
829 &513,523,21,11,13,15,1,2,3,4,21,22,553,21,2112,2212,2*2112,2212,
830 &2112,2*2212,2112,-12,3122,3212,3112,2212,2*2112,-12,2*3122,3222,
831 &3112,2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,3322,
832 &3312,2*3122,3212,3322,3312,3122,3322,3312,-12,2*4122,7*-11,7*-13,
833 &2*2224,2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,
834 &3324,2*2224,7*2212,5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,
835 &2*3222,2*3224,4*2,3,2*2,1,2*2,-11,-13,2*2,4*4122,-11,-13,2*2,
836 &3*4132,3*4232,-11,-13,2*2,4332,-11,-13,2*2,-11,-13,2*2,-11,-13,
837 &2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,2*5122,-12,
838 &-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
839 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,4*5122,-12,-14,-16,2*-2,
840 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,2*5132,2*5232,-12,-14,-16,
841 &2*-2,2*-4,-2,-4,5332,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
842 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
843 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
844 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
845 &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
846 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2/
847 DATA (KFDP(I,1),I=1403,1708)/2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
848 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
849 &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,221,223,221,
850 &223,211,111,321,130,310,213,113,-213,321,311,321,311,323,313,
851 &2*311,321,311,321,313,323,321,211,111,321,130,310,2*211,313,-313,
852 &323,-323,421,411,423,413,411,421,413,423,411,421,423,413,443,
853 &2*82,521,511,523,513,511,521,513,523,521,511,523,513,511,521,513,
854 &523,553,2*21,213,-213,113,213,10211,10111,-10211,2*221,213,2*113,
855 &-213,2*321,2*311,113,323,2*313,323,313,-313,323,-323,423,2*413,
856 &2*423,413,443,82,523,2*513,2*523,2*513,523,553,21,11,13,82,4*443,
857 &10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,10551,20553,555,
858 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
859 &1000002,2000002,1000002,2000002,1000021,3*-12,3*-14,3*-16,12,11,
860 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,1000039,1000024,
861 &1000037,1000022,1000023,1000025,1000035,1000001,2000001,1000001,
862 &2000001,1000021,3*-11,3*-13,3*-15,1000039,-1000024,-1000037,
863 &1000022,1000023,1000025,1000035,1000004,2000004,1000004,2000004,
864 &1000021,3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,
865 &15,16,15,16,15,1000039,1000024,1000037,1000022,1000023,1000025,
866 &1000035,1000003,2000003,1000003,2000003,1000021,3*-11,3*-13/
867 DATA (KFDP(I,1),I=1709,1966)/3*-15,1000039,-1000024,-1000037,
868 &1000022,1000023,1000025,1000035,1000006,2000006,1000006,2000006,
869 &1000021,3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,
870 &15,16,15,16,15,1000039,1000024,1000037,1000022,1000023,1000025,
871 &1000035,1000005,2000005,1000005,2000005,1000021,1000022,1000016,
872 &-1000015,3*-11,3*-13,3*-15,1000039,-1000024,-1000037,1000022,
873 &1000023,1000025,1000035,1000012,2000012,1000012,2*12,2*14,2*16,
874 &3*-14,3*-16,3*-2,3*-4,3*-6,1000039,1000024,1000037,1000022,
875 &1000023,1000025,1000035,1000011,2000011,1000011,2000011,3*-13,
876 &3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,1000022,1000023,
877 &1000025,1000035,1000014,2000014,1000014,2000014,2*12,2*14,2*16,
878 &3*-12,3*-16,3*-2,3*-4,3*-6,1000039,1000024,1000037,1000022,
879 &1000023,1000025,1000035,1000013,2000013,1000013,2000013,3*-11,
880 &3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,1000022,1000023,
881 &1000025,1000035,1000016,2000016,1000016,2000016,2*12,2*14,2*16,
882 &3*-12,3*-14,3*-2,3*-4,3*-6,1000039,1000024,1000037,1000022,
883 &1000023,1000025,1000035,1000015,2000015,1000015,2000015,3*-11,
884 &3*-13,3*-1,3*-3,3*-5,1000039,1000001,-1000001,2000001,-2000001,
885 &1000002,-1000002,2000002,-2000002,1000003,-1000003,2000003,
886 &-2000003,1000004,-1000004,2000004,-2000004,1000005,-1000005/
887 DATA (KFDP(I,1),I=1967,2235)/2000005,-2000005,1000006,-1000006,
888 &2000006,-2000006,6*1000022,6*1000023,6*1000025,6*1000035,1000024,
889 &-1000024,1000024,-1000024,1000024,-1000024,1000037,-1000037,
890 &1000037,-1000037,1000037,-1000037,5*1000039,4,1,-12,12,-12,12,
891 &-12,12,-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,14,-14,14,
892 &-14,14,-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,12,-11,11,
893 &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,
894 &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,
895 &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,
896 &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,
897 &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,
898 &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,5*1000039,
899 &16*1000022,1000024,-1000024,1000024,-1000024,1000024,-1000024,
900 &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000037,
901 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,
902 &1000037,-1000037,1000037,-1000037,1000024,-1000024,1000037,
903 &-1000037,1000001,-1000001,2000001,-2000001,1000002,-1000002,
904 &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,
905 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
906 &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011/
907 DATA (KFDP(I,1),I=2236,2523)/-2000011,1000012,-1000012,2000012,
908 &-2000012,1000013,-1000013,2000013,-2000013,1000014,-1000014,
909 &2000014,-2000014,1000015,-1000015,2000015,-2000015,1000016,
910 &-1000016,2000016,-2000016,5*1000021,-12,12,-12,12,-12,12,-12,12,
911 &-12,12,-12,12,-14,14,-14,14,-14,14,-14,14,-14,14,-14,14,-16,16,
912 &-16,16,-16,16,-16,16,-16,16,-16,16,-12,12,-11,11,-12,12,-11,11,
913 &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,
914 &-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,-14,14,-13,13,
915 &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,
916 &-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,-16,16,-15,15,
917 &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,
918 &-15,15,-16,16,-15,15,-16,16,-15,15,2*1000039,6*1000022,6*1000023,
919 &6*1000025,6*1000035,1000022,1000023,1000025,1000035,1000002,
920 &2000002,-1000001,-2000001,1000004,2000004,-1000003,-2000003,
921 &1000006,2000006,-1000005,-2000005,1000012,2000012,-1000011,
922 &-2000011,1000014,2000014,-1000013,-2000013,1000016,2000016,
923 &-1000015,-2000015,2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,
924 &12,-11,-12,12,-11,-12,12,-11,-14,-13,-14,-13,-14,-13,-14,14,-13,
925 &-14,14,-13,-14,14,-13,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,
926 &-16,-15,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12/
927 DATA (KFDP(I,1),I=2524,2794)/2*-11,12,-12,2*-11,12,-12,2*-11,12,
928 &-12,2*-11,12,-12,2*-11,12,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,
929 &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,
930 &-14,2*-13,14,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,
931 &-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,
932 &5*1000039,16*1000022,16*1000023,1000024,-1000024,1000024,
933 &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
934 &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037,
935 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,
936 &1000024,-1000024,1000037,-1000037,1000001,-1000001,2000001,
937 &-2000001,1000002,-1000002,2000002,-2000002,1000003,-1000003,
938 &2000003,-2000003,1000004,-1000004,2000004,-2000004,1000005,
939 &-1000005,2000005,-2000005,1000006,-1000006,2000006,-2000006,
940 &1000011,-1000011,2000011,-2000011,1000012,-1000012,2000012,
941 &-2000012,1000013,-1000013,2000013,-2000013,1000014,-1000014,
942 &2000014,-2000014,1000015,-1000015,2000015,-2000015,1000016,
943 &-1000016,2000016,-2000016,5*1000021,-12,12,-12,12,-12,12,-12,12,
944 &-12,12,-12,12,-14,14,-14,14,-14,14,-14,14,-14,14,-14,14,-16,16,
945 &-16,16,-16,16,-16,16,-16,16,-16,16,-12,12,-11,11,-12,12,-11,11,
946 &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12/
947 DATA (KFDP(I,1),I=2795,3070)/-11,11,-12,12,-11,11,-12,12,-11,11,
948 &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,
949 &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,
950 &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,
951 &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,
952 &5*1000039,16*1000022,16*1000023,16*1000025,1000024,-1000024,
953 &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000024,
954 &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,
955 &1000037,-1000037,1000037,-1000037,1000037,-1000037,1000037,
956 &-1000037,1000024,-1000024,1000037,-1000037,1000001,-1000001,
957 &2000001,-2000001,1000002,-1000002,2000002,-2000002,1000003,
958 &-1000003,2000003,-2000003,1000004,-1000004,2000004,-2000004,
959 &1000005,-1000005,2000005,-2000005,1000006,-1000006,2000006,
960 &-2000006,1000011,-1000011,2000011,-2000011,1000012,-1000012,
961 &2000012,-2000012,1000013,-1000013,2000013,-2000013,1000014,
962 &-1000014,2000014,-2000014,1000015,-1000015,2000015,-2000015,
963 &1000016,-1000016,2000016,-2000016,5*1000021,-12,12,-12,12,-12,12,
964 &-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,14,-14,14,-14,14,
965 &-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,12,-11,11,-12,12,
966 &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11/
967 DATA (KFDP(I,1),I=3071,3398)/-12,12,-11,11,-12,12,-11,11,-12,12,
968 &-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,
969 &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,
970 &-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,
971 &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,
972 &-15,15,2*1000039,15*1000024,6*1000022,6*1000023,6*1000025,
973 &6*1000035,1000022,1000023,1000025,1000035,1000002,2000002,
974 &-1000001,-2000001,1000004,2000004,-1000003,-2000003,1000006,
975 &2000006,-1000005,-2000005,1000012,2000012,-1000011,-2000011,
976 &1000014,2000014,-1000013,-2000013,1000016,2000016,-1000015,
977 &-2000015,2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,
978 &-12,12,-11,-12,12,-11,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,
979 &-13,-14,14,-13,-14,14,-13,-16,16,-15,-16,16,-15,-16,16,-15,-16,
980 &16,-15,-16,16,-15,-16,16,-15,-12,2*-11,12,-12,2*-11,12,-12,2*-11,
981 &12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,
982 &12,-12,2*-11,12,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,
983 &14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,
984 &14,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,
985 &16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,1000039,
986 &-1000024,-1000037,1000022,1000023,1000025,1000035,4*1000001/
987 DATA (KFDP(I,1),I=3399,3676)/1000002,2000002,1000002,2000002,
988 &1000021,3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,
989 &15,16,15,16,15,1000039,1000024,1000037,1000022,1000023,1000025,
990 &1000035,4*1000002,1000001,2000001,1000001,2000001,1000021,3*-11,
991 &3*-13,3*-15,1000039,-1000024,-1000037,1000022,1000023,1000025,
992 &1000035,4*1000003,1000004,2000004,1000004,2000004,1000021,3*-12,
993 &3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,
994 &15,1000039,1000024,1000037,1000022,1000023,1000025,1000035,
995 &4*1000004,1000003,2000003,1000003,2000003,1000021,3*-11,3*-13,
996 &3*-15,1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
997 &4*1000005,1000006,2000006,1000006,2000006,1000021,3*-12,3*-14,
998 &3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,
999 &1000039,1000024,1000037,1000022,1000023,1000025,1000035,
1000 &4*1000006,1000005,2000005,1000005,2000005,1000021,3*-11,3*-13,
1001 &3*-15,1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
1002 &4*1000011,1000012,2000012,1000012,2000012,2*12,2*14,2*16,3*-14,
1003 &3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,1000022,1000023,
1004 &1000025,1000035,4*1000013,1000014,2000014,1000014,2000014,2*12,
1005 &2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,
1006 &1000022,1000023,1000025,1000035,4*1000015,1000016,2000016/
1007 DATA (KFDP(I,1),I=3677,8000)/1000016,2000016,2*12,2*14,2*16,
1008 &3*-12,3*-14,3*-2,3*-4,3*-6,3,4,5,6,11,13,15,21,2*4,2,4,24,-11,
1009 &-13,-15,3,4,5,6,11,13,15,21,5,6,21,2*24,2*3000211,2*22,2*23,1,2,
1010 &3,4,5,6,7,8,11,12,13,14,15,16,17,18,2*24,3*3000211,24,4*-1,4*-3,
1011 &4*-5,4*-7,-11,-13,-15,-17,22,23,22,23,24,3000211,24,3000211,1,2,
1012 &3,4,5,6,7,8,11,12,13,14,15,16,17,18,1,2,3,4,5,6,1,2,3,4,5,6,21,1,
1013 &2,3,4,5,6,21,1,2,3,4,5,6,21,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,
1014 &21,3100111,3200111,21,22,23,-24,21,22,23,24,22,23,-24,23,24,1,2,
1015 &3,4,5,6,7,8,11,12,13,14,15,16,17,18,21,22,23,24,0,9*11,9*-11,
1016 &2*11,2*-11,9*13,9*-13,2*13,2*-13,9*15,9*-15,2*15,2*-15,1,2,3,4,5,
1017 &6,11,12,9900012,13,14,9900014,15,16,9900016,3*-1,3*-3,3*-5,-11,
1018 &-13,-15,3*-11,2*-13,-15,24,3*-11,2*-13,-15,9900024,4011*0/
1019 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,
1020 &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,
1021 &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,
1022 &13,11,13,-211,-213,-211,-213,-211,-213,-211,-213,2*-211,-321,
1023 &-323,-321,2*-323,3*-321,4*-211,-213,-211,-213,-211,-213,-211,
1024 &-213,-211,-213,3*-211,-213,4*-211,-323,-321,2*-211,2*-321,3*-211,
1025 &2*15,16,15,16,15,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,
1026 &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,
1027 &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,
1028 &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,
1029 &-24,2*1000022,1000023,1000022,1000023,1000025,1000022,1000023,
1030 &1000025,1000035,-1000024,-1000037,-1000024,-1000037,-1000001,
1031 &2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
1032 &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1033 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1034 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1035 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1036 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1037 &-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,22,25,2*36,2,4,6,8,
1038 &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/
1039 DATA (KFDP(I,2),I= 340, 533)/-7,-8,-11,-13,-15,-17,21,22,2*23,
1040 &-24,2*25,-37,-24,3*36,2*1000022,1000023,1000022,1000023,1000025,
1041 &1000022,1000023,1000025,1000035,-1000024,-1000037,-1000024,
1042 &-1000037,-1000001,2*-2000001,2000001,-1000002,2*-2000002,2000002,
1043 &-1000003,2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1044 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1045 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1046 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1047 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1048 &-7,-8,-11,-13,-15,-17,21,22,2*23,-24,2*25,-37,-24,2*1000022,
1049 &1000023,1000022,1000023,1000025,1000022,1000023,1000025,1000035,
1050 &-1000024,-1000037,-1000024,-1000037,-1000001,2*-2000001,2000001,
1051 &-1000002,2*-2000002,2000002,-1000003,2*-2000003,2000003,-1000004,
1052 &2*-2000004,2000004,-1000005,2*-2000005,2000005,-1000006,
1053 &2*-2000006,2000006,-1000011,2*-2000011,2000011,-1000012,
1054 &2*-2000012,2000012,-1000013,2*-2000013,2000013,-1000014,
1055 &2*-2000014,2000014,-1000015,2*-2000015,2000015,-1000016,
1056 &2*-2000016,2000016,2,4,6,8,12,14,16,18,25,1000024,1000037,
1057 &1000024,1000037,1000024,1000037,1000024,1000037,2*-1000005,
1058 &2*-2000005,1000002,1000004,1000012,1000014,2*1000016,-3,-4,-5,-6/
1059 DATA (KFDP(I,2),I= 534, 938)/-7,-8,-13,-15,-17,11,-82,12,14,-1,
1060 &-3,11,13,15,1,4,3,4,1,3,22,11,-211,2*22,-13,-11,-211,211,111,211,
1061 &-321,130,310,22,2*111,-211,11,-11,13,-13,-211,111,22,14,12,111,
1062 &22,111,3*211,-311,22,211,22,111,-211,211,11,-211,13,22,-211,111,
1063 &-211,22,111,-11,-211,111,2*-211,-321,130,310,221,111,-211,111,
1064 &2*0,-211,111,22,-211,111,-211,111,-211,211,-213,113,223,221,14,
1065 &111,211,111,-11,-13,211,111,22,211,111,211,111,2*211,213,113,223,
1066 &221,22,-211,111,113,223,22,111,-321,310,211,111,2*-211,221,22,
1067 &-11,-13,-211,-321,130,310,221,-211,111,11*12,11*14,2*211,2*213,
1068 &211,20213,2*321,2*323,211,213,211,213,211,213,211,213,211,213,
1069 &211,213,3*211,213,211,2*321,8*211,2*113,3*211,111,22,211,111,211,
1070 &111,4*211,8*12,8*14,2*211,2*213,2*111,221,2*113,223,333,20213,
1071 &211,2*321,323,2*311,313,-211,111,113,2*211,321,2*211,311,321,310,
1072 &211,-211,4*211,321,4*211,113,2*211,-321,111,22,-211,111,-211,111,
1073 &-211,211,-211,211,16,5*12,5*14,3*211,3*213,211,2*111,2*113,
1074 &2*-311,2*-313,-2112,3*321,323,2*-1,22,111,321,311,321,311,-82,
1075 &-11,-13,-82,22,-82,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,
1076 &431,433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,22,
1077 &-211,111,-211,111,-211,211,-211,211,6*-11,6*-13,2*-15,211,213,
1078 &20213,211,213,20213,431,433,431,433,321,323,321,323,321,323,-1/
1079 DATA (KFDP(I,2),I= 939,1352)/-4,-3,-4,-1,-3,22,211,111,211,111,
1080 &4*211,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,433,431,
1081 &433,221,331,333,221,331,333,221,331,333,-1,-4,-3,-4,-1,-3,22,
1082 &-321,-311,-321,-311,-15,-3,-1,2*-11,2*-13,2*-15,-1,-4,-3,-4,-3,
1083 &-4,-1,-4,2*12,2*14,2,3,2,3,2*12,2*14,2,1,22,411,421,411,421,21,
1084 &-11,-13,-15,-1,-2,-3,-4,2*21,22,21,2*-211,111,22,111,211,22,211,
1085 &-211,11,2*-211,111,-211,111,22,11,22,111,-211,211,111,211,22,211,
1086 &111,211,-211,22,11,13,11,-211,2*111,2*22,111,211,-321,-211,111,
1087 &11,2*-211,7*12,7*14,-321,-323,-311,-313,-311,-313,211,213,211,
1088 &213,211,213,111,221,331,113,223,111,221,113,223,321,323,321,-211,
1089 &-213,111,221,331,113,223,333,10221,111,221,331,113,223,211,213,
1090 &211,213,321,323,321,323,321,323,311,313,311,313,2*-1,-3,-1,2203,
1091 &3201,3203,2203,2101,2103,12,14,-1,-3,2*111,2*211,12,14,-1,-3,22,
1092 &111,2*22,111,22,12,14,-1,-3,22,12,14,-1,-3,12,14,-1,-3,12,14,-1,
1093 &-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,2*-211,11,13,
1094 &15,-211,-213,-20213,-431,-433,3*3122,1,4,3,4,1,3,11,13,15,1,4,3,
1095 &4,1,3,11,13,15,1,4,3,4,1,3,2*111,2*211,11,13,15,1,4,3,4,1,3,11,
1096 &13,15,1,4,3,4,1,3,4*22,11,13,15,1,4,3,4,1,3,22,11,13,15,1,4,3,4,
1097 &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,
1098 &3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3/
1099 DATA (KFDP(I,2),I=1353,1822)/11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,
1100 &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,
1101 &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,
1102 &3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,
1103 &2*111,2*211,-211,111,-321,130,310,-211,111,211,-211,111,-213,113,
1104 &-211,111,223,211,111,213,113,211,111,223,-211,111,-321,130,310,
1105 &2*-211,-311,311,-321,321,211,111,211,111,-211,111,-211,111,311,
1106 &2*321,311,22,2*-82,-211,111,-211,111,211,111,211,111,-321,-311,
1107 &-321,-311,411,421,411,421,22,2*21,-211,2*211,111,-211,111,2*211,
1108 &111,-211,211,111,211,-321,2*-311,-321,22,-211,111,211,111,-311,
1109 &311,-321,321,211,111,-211,111,321,311,22,-82,-211,111,211,111,
1110 &-321,-311,411,421,22,21,-11,-13,-82,211,111,221,111,4*22,-11,-13,
1111 &-15,-1,-2,-3,-4,2*21,211,111,3*22,1,2*2,4*1,2*-24,2*-37,2*1,3,5,
1112 &1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,2,2*1,4*2,2*24,
1113 &2*37,2,1,3,5,1,3,5,1,3,5,3,2*4,4*3,2*-24,2*-37,3,1,3,5,1,3,5,1,3,
1114 &5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,4,2*3,4*4,2*24,2*37,4,1,3,
1115 &5,1,3,5,1,3,2*5,2*6,4*5,2*-24,2*-37,5,1,3,5,1,3,5,1,3,5,1,2,3,4,
1116 &5,6,1,2,3,4,5,6,1,2,3,4,5,2*6,2*5,4*6,2*24,2*37,6,4,-15,16,1,3,5,
1117 &1,3,5,1,3,5,11,2*12,4*11,2*-24,-37,13,15,11,15,11,13,11,13,15,11,
1118 &13,15,1,3,5,1,3,5,1,3,5,12,2*11,4*12,2*24,2*37,11,13,15,11,13,15/
1119 DATA (KFDP(I,2),I=1823,2288)/1,3,5,1,3,5,1,3,5,13,2*14,4*13,
1120 &2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,5,1,3,5,1,3,
1121 &5,14,2*13,4*14,2*24,2*37,11,13,15,11,13,15,1,3,5,1,3,5,1,3,5,15,
1122 &2*16,4*15,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,5,
1123 &1,3,5,1,3,5,16,2*15,4*16,2*24,2*37,11,13,15,11,13,15,1,3,5,1,3,5,
1124 &1,3,5,21,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,5,-6,6,
1125 &-6,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6,1,-1,3,-3,5,
1126 &-5,1,-1,3,-3,5,-5,22,23,25,35,36,-1,-3,-13,13,-13,13,-13,13,-15,
1127 &15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,-11,
1128 &11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,1,
1129 &-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,
1130 &-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,
1131 &-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,
1132 &-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,22,23,25,35,36,
1133 &22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,-11,13,-13,
1134 &15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-37,37,
1135 &-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,5,-6,6,-6,
1136 &6,-11,11,-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,14,-15,15,
1137 &-15,15,-16,16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,-15,15,-15,
1138 &15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,-11,11,-11/
1139 DATA (KFDP(I,2),I=2289,2743)/11,-11,11,-13,13,-13,13,-13,13,-1,1,
1140 &-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,
1141 &-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,
1142 &-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,
1143 &-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,
1144 &-6,6,24,37,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,
1145 &-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,2*-1,2*2,2*-3,2*4,2*-5,2*6,
1146 &2*-11,2*12,2*-13,2*14,2*-15,2*16,-1,-3,-13,14,2*-13,14,2*-13,14,
1147 &-13,-15,16,2*-15,16,2*-15,16,-15,6*-11,-15,16,2*-15,16,2*-15,16,
1148 &-15,6*-11,6*-13,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,
1149 &-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,
1150 &-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,
1151 &6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,
1152 &-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,22,
1153 &23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,
1154 &13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,-11,13,-13,15,-15,1,
1155 &-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,
1156 &-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,
1157 &-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,14,-15,15,-15,15,
1158 &-16,16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,-15,15,-15,15,-15/
1159 DATA (KFDP(I,2),I=2744,3191)/15,-11,11,-11,11,-11,11,-15,15,-15,
1160 &15,-15,15,-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,
1161 &1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,
1162 &6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,
1163 &3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,
1164 &2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,22,
1165 &23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,
1166 &13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,16,1,3,5,
1167 &2,4,25,35,36,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,
1168 &13,-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,
1169 &-3,3,-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,
1170 &-13,13,-13,13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,
1171 &4,-13,13,-13,13,-13,13,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,
1172 &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,
1173 &-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,
1174 &-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,
1175 &-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,
1176 &-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,
1177 &-5,5,-6,6,24,37,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,24,-11,
1178 &-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11/
1179 DATA (KFDP(I,2),I=3192,3692)/-13,-15,-1,-3,4*37,2*-1,2*2,2*-3,
1180 &2*4,2*-5,2*6,2*-11,2*12,2*-13,2*14,2*-15,2*16,-1,-3,-13,14,2*-13,
1181 &14,2*-13,14,-13,-15,16,2*-15,16,2*-15,16,-15,-11,12,2*-11,12,
1182 &2*-11,12,-11,-15,16,2*-15,16,2*-15,16,-15,-11,12,2*-11,12,2*-11,
1183 &12,-11,-13,14,2*-13,14,2*-13,14,-13,-1,-2,-1,2,-1,-2,-1,2,-1,-2,
1184 &-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,
1185 &-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,
1186 &-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,
1187 &2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,
1188 &-5,6,-5,-6,-5,6,1,2*2,4*1,23,25,35,36,2*-24,2*-37,2*1,3,5,1,3,5,
1189 &1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,2,2*1,4*2,23,25,35,36,
1190 &2*24,2*37,2,1,3,5,1,3,5,1,3,5,3,2*4,4*3,23,25,35,36,2*-24,2*-37,
1191 &3,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,4,2*3,
1192 &4*4,23,25,35,36,2*24,2*37,4,1,3,5,1,3,5,1,3,2*5,2*6,4*5,23,25,35,
1193 &36,2*-24,2*-37,5,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,
1194 &4,5,2*6,2*5,4*6,23,25,35,36,2*24,2*37,6,1,3,5,1,3,5,1,3,5,11,
1195 &2*12,4*11,23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
1196 &13,15,1,3,5,1,3,5,1,3,5,13,2*14,4*13,23,25,35,36,2*-24,2*-37,13,
1197 &15,11,15,11,13,11,13,15,11,13,15,1,3,5,1,3,5,1,3,5,15,2*16,4*15,
1198 &23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3/
1199 DATA (KFDP(I,2),I=3693,8000)/5,1,3,5,1,3,5,-3,-4,-5,-6,-11,-13,
1200 &-15,21,-1,-3,2*-5,5,12,14,16,-3,-4,-5,-6,-11,-13,-15,21,-5,-6,21,
1201 &-24,-3000211,-24,-3000211,3000111,3000221,3000111,3000221,-1,-2,
1202 &-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,23,3000111,23,
1203 &3000111,22,3000221,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,
1204 &2*3000111,2*3000221,-3000211,2*-24,-3000211,-1,-2,-3,-4,-5,-6,-7,
1205 &-8,-11,-12,-13,-14,-15,-16,-17,-18,-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,
1206 &-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,-4,
1207 &-5,-6,-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,3*21,3*1,4*2,1,2*11,
1208 &2*12,11,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,
1209 &21,22,23,-24,0,3*-1,3*-3,3*-5,3*1,3*3,3*5,2*-13,2*15,3*-1,3*-3,
1210 &3*-5,3*1,3*3,3*5,2*-11,2*15,3*-1,3*-3,3*-5,3*1,3*3,3*5,2*-11,
1211 &2*13,-1,-2,-3,-4,-5,-6,-11,-12,9900012,-13,-14,9900014,-15,-16,
1212 &9900016,2,4,6,2,4,6,2,4,6,9900012,9900014,9900016,-11,-13,-15,
1213 &-13,2*-15,24,-11,-13,-15,-13,2*-15,9900024,4011*0/
1214 DATA (KFDP(I,3),I= 1,1021)/81*0,14,6*0,2*16,2*0,6*111,310,130,
1215 &2*0,3*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,
1216 &2*113,221,2*113,2*213,-213,113,2*111,310,130,310,130,2*310,130,
1217 &402*0,4*3,4*4,1,4,3,2*2,0,-11,8*0,-211,5*0,2*111,211,-211,211,
1218 &-211,10*0,111,4*0,2*111,-211,-11,11,-13,22,111,3*0,22,3*0,111,
1219 &211,4*0,111,11*0,111,-211,6*0,-211,3*111,7*0,111,-211,5*0,2*221,
1220 &3*0,111,5*0,111,11*0,-311,-313,-311,-321,-313,-323,111,221,331,
1221 &113,223,-311,-313,-311,-321,-313,-323,111,221,331,113,223,22*0,
1222 &111,113,2*211,-211,-311,211,111,3*211,-211,7*211,7*0,111,-211,
1223 &111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,-323,-311,
1224 &-321,-313,-323,-211,-213,22*0,111,113,-311,2*-211,211,-211,310,
1225 &-211,2*111,211,2*-211,-321,-211,2*211,-211,111,-211,2*211,6*0,
1226 &111,-211,111,-211,0,221,331,333,321,311,221,331,333,321,311,20*0,
1227 &3,13*0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413,
1228 &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1229 &111,-211,-421,-423,-10423,-10421,-20423,-425,-421,-423,-10423,
1230 &-10421,-20423,-425,-421,-423,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1231 &111,-211,-431,-433,-10433,-10431,-20433,-435,-431,-433,-10433,
1232 &-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,-3,2*-2,8*0,441,443,
1233 &441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,533,531,533,3,2,3,2/
1234 DATA (KFDP(I,3),I=1022,2197)/511,513,511,513,1,2,13*0,2*21,11*0,
1235 &2112,6*0,2212,12*0,2*3122,3212,10*0,3322,2*0,3122,3212,3214,2112,
1236 &2114,2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,6*0,
1237 &4*3,4*0,4*3,6*0,4*3,0,28*3,2*0,3*4122,8*0,4,1,4,3,2*2,4*4,1,4,3,
1238 &2*2,4*4,1,4,3,2*2,4*0,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*0,4*4,1,4,3,
1239 &2*2,0,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,
1240 &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,
1241 &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,
1242 &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,
1243 &3,2*2,31*0,211,111,45*0,-211,2*111,-211,3*111,-211,111,211,30*0,
1244 &-211,111,13*0,2*21,-211,111,175*0,2*5,207*0,-1,-3,-5,-2,-4,-6,-1,
1245 &-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-2,2,-4,4,-6,
1246 &6,-2,2,-4,4,-6,6,5*0,11,12,11,-11,13,-13,15,-15,11,-11,13,-13,15,
1247 &-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,
1248 &-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,
1249 &3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,
1250 &3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,
1251 &5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,
1252 &5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,7*0,-11,-13,-15,-12,-14,-16,
1253 &-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,-14/
1254 DATA (KFDP(I,3),I=2198,2789)/14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,
1255 &-2,-4,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,
1256 &-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,
1257 &-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,
1258 &1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,
1259 &1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,
1260 &3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,
1261 &3,-3,5,-5,5,-5,3*0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,0,
1262 &12,14,16,2,4,28*0,2,4,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,
1263 &-13,13,16,-15,15,12,11,14,13,16,15,12,-11,11,14,-13,13,16,-15,15,
1264 &12,11,14,13,16,15,12,11,14,13,16,15,2*2,1,-1,2*4,3,-3,2*6,5,-5,
1265 &2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,
1266 &2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,
1267 &2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,
1268 &2*2,1,-1,2*4,3,-3,2*6,5,-5,7*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,
1269 &-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,
1270 &14,-16,16,-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,
1271 &-3,-5,-2,-4,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,
1272 &-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,
1273 &-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5/
1274 DATA (KFDP(I,3),I=2790,3335)/-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,
1275 &-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,
1276 &-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,
1277 &-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,7*0,-11,-13,
1278 &-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,
1279 &-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,
1280 &-14,14,-16,16,-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,
1281 &-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,
1282 &13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,
1283 &13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,
1284 &5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,
1285 &5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,
1286 &1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,
1287 &1,-1,3,-3,3,-3,5,-5,5,-5,3*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,
1288 &-4,4*0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,
1289 &28*0,2,4,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,
1290 &-15,15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,
1291 &15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,15,
1292 &2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,
1293 &2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3/
1294 DATA (KFDP(I,3),I=3336,8000)/2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,
1295 &2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,
1296 &2*4,3,-3,2*6,5,-5,324*0,-5,170*0,2,4,6,2,4,6,2,4,6,-2,-4,-6,-2,
1297 &-4,-6,-2,-4,-6,2*9900014,2*9900016,2,4,6,2,4,6,2,4,6,-2,-4,-6,-2,
1298 &-4,-6,-2,-4,-6,2*9900012,2*9900016,2,4,6,2,4,6,2,4,6,-2,-4,-6,-2,
1299 &-4,-6,-2,-4,-6,2*9900012,2*9900014,4052*0/
1300 DATA (KFDP(I,4),I= 1,8000)/94*0,4*111,6*0,111,2*0,-211,0,-211,
1301 &3*0,111,2*-211,0,111,0,2*111,113,221,2*111,-213,-211,211,113,
1302 &6*111,310,2*130,402*0,13*81,41*0,-11,10*0,111,-211,4*0,111,62*0,
1303 &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,
1304 &-211,2*211,2*-211,13*0,-211,111,-211,111,4*0,-211,111,-211,111,
1305 &34*0,111,-211,3*111,3*-211,2*111,3*-211,14*0,-321,-311,3*0,-321,
1306 &-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,
1307 &2*-5,67*0,-211,111,5*0,-211,111,52*0,2101,2103,2*2101,6*0,4*81,
1308 &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,
1309 &162*81,31*0,-211,111,6516*0/
1310 DATA (KFDP(I,5),I= 1,8000)/96*0,2*111,17*0,111,7*0,2*111,0,
1311 &3*111,0,111,597*0,-211,2*111,-211,111,-211,111,65*0,111,-211,
1312 &3*111,-211,111,7193*0/
1313
1314C...PYDAT4, with particle names (character strings).
1315 DATA (CHAF(I,1),I= 1, 202)/'d','u','s','c','b','t','b''','t''',
1316 &2*' ','e-','nu_e','mu-','nu_mu','tau-','nu_tau','tau''-',
1317 &'nu''_tau',2*' ','g','gamma','Z0','W+','h0',6*' ','Z''0','Z"0',
1318 &'W''+','H0','A0','H+',' ','Graviton',' ','R0','LQ_ue',38*' ',
1319 &'specflav','rndmflav','phasespa','c-hadron','b-hadron',4*' ',
1320 &'system','cluster','string','indep.','CMshower','SPHEaxis',
1321 &'THRUaxis','CLUSjet','CELLjet','table',' ','reggeon','pi0',
1322 &'rho0','a_20','K_L0','pi+','rho+','a_2+','eta','omega','f_2',
1323 &'K_S0','K0','K*0','K*_20','K+','K*+','K*_2+','eta''','phi',
1324 &'f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+','D*_s+',
1325 &'D*_2s+','eta_c','J/psi','chi_2c','B0','B*0','B*_20','B+','B*+',
1326 &'B*_2+','B_s0','B*_s0','B*_2s0','B_c+','B*_c+','B*_2c+','eta_b',
1327 &'Upsilon','chi_2b','pomeron','dd_1','Delta-','ud_0','ud_1','n0',
1328 &'Delta0','uu_1','p+','Delta+','Delta++','sd_0','sd_1','Sigma-',
1329 &'Sigma*-','Lambda0','su_0','su_1','Sigma0','Sigma*0','Sigma+',
1330 &'Sigma*+','ss_1','Xi-','Xi*-','Xi0','Xi*0','Omega-','cd_0',
1331 &'cd_1','Sigma_c0','Sigma*_c0','Lambda_c+','Xi_c0','cu_0','cu_1',
1332 &'Sigma_c+','Sigma*_c+','Sigma_c++','Sigma*_c++','Xi_c+','cs_0',
1333 &'cs_1','Xi''_c0','Xi*_c0','Xi''_c+','Xi*_c+','Omega_c0',
1334 &'Omega*_c0','cc_1','Xi_cc+','Xi*_cc+','Xi_cc++','Xi*_cc++'/
1335 DATA (CHAF(I,1),I= 203, 332)/'Omega_cc+','Omega*_cc+',
1336 &'Omega*_ccc++','bd_0','bd_1','Sigma_b-','Sigma*_b-','Lambda_b0',
1337 &'Xi_b-','Xi_bc0','bu_0','bu_1','Sigma_b0','Sigma*_b0','Sigma_b+',
1338 &'Sigma*_b+','Xi_b0','Xi_bc+','bs_0','bs_1','Xi''_b-','Xi*_b-',
1339 &'Xi''_b0','Xi*_b0','Omega_b-','Omega*_b-','Omega_bc0','bc_0',
1340 &'bc_1','Xi''_bc0','Xi*_bc0','Xi''_bc+','Xi*_bc+','Omega''_bc0',
1341 &'Omega*_bc0','Omega_bcc+','Omega*_bcc+','bb_1','Xi_bb-',
1342 &'Xi*_bb-','Xi_bb0','Xi*_bb0','Omega_bb-','Omega*_bb-',
1343 &'Omega_bbc0','Omega*_bbc0','Omega*_bbb-','a_00','b_10','a_0+',
1344 &'b_1+','f_0','h_1','K*_00','K_10','K*_0+','K_1+','f''_0','h''_1',
1345 &'D*_0+','D_1+','D*_00','D_10','D*_0s+','D_1s+','chi_0c','h_1c',
1346 &'B*_00','B_10','B*_0+','B_1+','B*_0s0','B_1s0','B*_0c+','B_1c+',
1347 &'chi_0b','h_1b','a_10','a_1+','f_1','K*_10','K*_1+','f''_1',
1348 &'D*_1+','D*_10','D*_1s+','chi_1c','B*_10','B*_1+','B*_1s0',
1349 &'B*_1c+','chi_1b','psi''','Upsilon''','~d_L','~u_L','~s_L',
1350 &'~c_L','~b_1','~t_1','~e_L-','~nu_eL','~mu_L-','~nu_muL',
1351 &'~tau_1-','~nu_tauL','~g','~chi_10','~chi_20','~chi_1+',
1352 &'~chi_30','~chi_40','~chi_2+','~Gravitino','~d_R','~u_R','~s_R',
1353 &'~c_R','~b_2','~t_2','~e_R-','~nu_eR','~mu_R-','~nu_muR',
1354 &'~tau_2-','~nu_tauR','pi_tc0','pi_tc+','pi''_tc0','eta_tc0'/
1355 DATA (CHAF(I,1),I= 333, 500)/'rho_tc0','rho_tc+','omega_tc',
1356 &'V8_tc','pi_22_1_tc','pi_22_8_tc','rho_11_tc','rho_12_tc',
1357 &'rho_21_tc','rho_22_tc','d*','u*','e*-','nu*_e0','Graviton*',
1358 &'nu_Re','nu_Rmu','nu_Rtau','Z_R0','W_R+','H_L++','H_R++',
1359 &'rho_diff0','pi_diffr+','omega_di','phi_diff','J/psi_di',
1360 &'n_diffr0','p_diffr+',139*' '/
1361 DATA (CHAF(I,2),I= 1, 205)/'dbar','ubar','sbar','cbar','bbar',
1362 &'tbar','b''bar','t''bar',2*' ','e+','nu_ebar','mu+','nu_mubar',
1363 &'tau+','nu_taubar','tau''+','nu''_taubar',5*' ','W-',9*' ',
1364 &'W''-',2*' ','H-',3*' ','Rbar0','LQ_uebar',39*' ','rndmflavbar',
1365 &' ','c-hadronbar','b-hadronbar',20*' ','pi-','rho-','a_2-',4*' ',
1366 &'Kbar0','K*bar0','K*_2bar0','K-','K*-','K*_2-',3*' ','D-','D*-',
1367 &'D*_2-','Dbar0','D*bar0','D*_2bar0','D_s-','D*_s-','D*_2s-',
1368 &3*' ','Bbar0','B*bar0','B*_2bar0','B-','B*-','B*_2-','B_sbar0',
1369 &'B*_sbar0','B*_2sbar0','B_c-','B*_c-','B*_2c-',4*' ','dd_1bar',
1370 &'Deltabar+','ud_0bar','ud_1bar','nbar0','Deltabar0','uu_1bar',
1371 &'pbar-','Deltabar-','Deltabar--','sd_0bar','sd_1bar','Sigmabar+',
1372 &'Sigma*bar+','Lambdabar0','su_0bar','su_1bar','Sigmabar0',
1373 &'Sigma*bar0','Sigmabar-','Sigma*bar-','ss_1bar','Xibar+',
1374 &'Xi*bar+','Xibar0','Xi*bar0','Omegabar+','cd_0bar','cd_1bar',
1375 &'Sigma_cbar0','Sigma*_cbar0','Lambda_cbar-','Xi_cbar0','cu_0bar',
1376 &'cu_1bar','Sigma_cbar-','Sigma*_cbar-','Sigma_cbar--',
1377 &'Sigma*_cbar--','Xi_cbar-','cs_0bar','cs_1bar','Xi''_cbar0',
1378 &'Xi*_cbar0','Xi''_cbar-','Xi*_cbar-','Omega_cbar0',
1379 &'Omega*_cbar0','cc_1bar','Xi_ccbar-','Xi*_ccbar-','Xi_ccbar--',
1380 &'Xi*_ccbar--','Omega_ccbar-','Omega*_ccbar-','Omega*_cccbar-'/
1381 DATA (CHAF(I,2),I= 206, 325)/'bd_0bar','bd_1bar','Sigma_bbar+',
1382 &'Sigma*_bbar+','Lambda_bbar0','Xi_bbar+','Xi_bcbar0','bu_0bar',
1383 &'bu_1bar','Sigma_bbar0','Sigma*_bbar0','Sigma_bbar-',
1384 &'Sigma*_bbar-','Xi_bbar0','Xi_bcbar-','bs_0bar','bs_1bar',
1385 &'Xi''_bbar+','Xi*_bbar+','Xi''_bbar0','Xi*_bbar0','Omega_bbar+',
1386 &'Omega*_bbar+','Omega_bcbar0','bc_0bar','bc_1bar','Xi''_bcbar0',
1387 &'Xi*_bcbar0','Xi''_bcbar-','Xi*_bcbar-','Omega''_bcba',
1388 &'Omega*_bcbar0','Omega_bccbar-','Omega*_bccbar-','bb_1bar',
1389 &'Xi_bbbar+','Xi*_bbbar+','Xi_bbbar0','Xi*_bbbar0','Omega_bbbar+',
1390 &'Omega*_bbbar+','Omega_bbcbar0','Omega*_bbcbar0',
1391 &'Omega*_bbbbar+',2*' ','a_0-','b_1-',2*' ','K*_0bar0','K_1bar0',
1392 &'K*_0-','K_1-',2*' ','D*_0-','D_1-','D*_0bar0','D_1bar0',
1393 &'D*_0s-','D_1s-',2*' ','B*_0bar0','B_1bar0','B*_0-','B_1-',
1394 &'B*_0sbar0','B_1sbar0','B*_0c-','B_1c-',3*' ','a_1-',' ',
1395 &'K*_1bar0','K*_1-',' ','D*_1-','D*_1bar0','D*_1s-',' ',
1396 &'B*_1bar0','B*_1-','B*_1sbar0','B*_1c-',3*' ','~d_Lbar',
1397 &'~u_Lbar','~s_Lbar','~c_Lbar','~b_1bar','~t_1bar','~e_L+',
1398 &'~nu_eLbar','~mu_L+','~nu_muLbar','~tau_1+','~nu_tauLbar',3*' ',
1399 &'~chi_1-',2*' ','~chi_2-',' ','~d_Rbar','~u_Rbar','~s_Rbar',
1400 &'~c_Rbar','~b_2bar','~t_2bar','~e_R+','~nu_eRbar','~mu_R+'/
1401 DATA (CHAF(I,2),I= 326, 500)/'~nu_muRbar','~tau_2+',
1402 &'~nu_tauRbar',' ','pi_tc-',3*' ','rho_tc-',8*' ','d*bar','u*bar',
1403 &'e*bar+','nu*_ebar0',5*' ','W_R-','H_L--','H_R--',' ',
1404 &'pi_diffr-',3*' ','n_diffrbar0','p_diffrbar-',139*' '/
1405
1406C...PYDATR, with initial values for the random number generator.
1407 DATA MRPY/19780503,0,0,97,33,0/
1408
1409C...Default values for allowed processes and kinematics constraints.
1410 DATA MSEL/1/
1411 DATA MSUB/500*0/
1412 DATA ((KFIN(I,J),J=-40,40),I=1,2)/16*0,4*1,4*0,6*1,5*0,5*1,0,
1413 &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,
1414 &6*1,4*0,4*1,16*0/
1415 DATA CKIN/
1416 & 2.0D0, -1.0D0, 0.0D0, -1.0D0, 1.0D0,
1417 & 1.0D0, -10D0, 10D0, -40D0, 40D0,
1418 1 -40D0, 40D0, -40D0, 40D0, -40D0,
1419 1 40D0, -1.0D0, 1.0D0, -1.0D0, 1.0D0,
1420 2 0.0D0, 1.0D0, 0.0D0, 1.0D0, -1.0D0,
1421 2 1.0D0, -1.0D0, 1.0D0, 0D0, 0D0,
1422 3 2.0D0, -1.0D0, 0D0, 0D0, 0.0D0,
1423 3 -1.0D0, 0.0D0, -1.0D0, 4.0D0, -1.0D0,
1424 4 12.0D0, -1.0D0, 12.0D0, -1.0D0, 12.0D0,
1425 4 -1.0D0, 12.0D0, -1.0D0, 0D0, 0D0,
1426 5 0.0D0, -1.0D0, 0.0D0, -1.0D0, 0.0D0,
1427 5 -1.0D0, 0D0, 0D0, 0D0, 0D0,
1428 6 0.0001D0, 0.99D0, 0.0001D0, 0.99D0, 0D0,
1429 6 -1D0, 0D0, -1D0, 0D0, -1D0,
1430 7 0D0, -1D0, 0.0001D0, 0.99D0, 0.0001D0,
1431 7 0.99D0, 2D0, -1D0, 0D0, 0D0,
1432 8 120*0D0/
1433
1434C...Default values for main switches and parameters. Reset information.
1435 DATA (MSTP(I),I=1,100)/
1436 & 3, 1, 2, 0, 0, 0, 0, 0, 0, 0,
1437 1 1, 0, 1, 30, 0, 1, 4, 3, 4, 3,
1438 2 1, 0, 1, 0, 0, 0, 0, 0, 0, 1,
1439 3 1, 8, 0, 1, 0, 2, 1, 5, 2, 0,
1440 4 2, 1, 3, 7, 3, 1, 1, 0, 1, 0,
1441 5 7, 1, 3, 1, 5, 1, 1, 5, 1, 7,
1442 6 2, 3, 2, 2, 1, 5, 2, 1, 0, 0,
1443 7 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1444 8 1, 1, 100, 0, 0, 2, 0, 0, 0, 0,
1445 9 1, 3, 1, 3, 0, 0, 0, 0, 0, 0/
1446 DATA (MSTP(I),I=101,200)/
1447 & 3, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1448 1 1, 1, 1, 0, 0, 0, 0, 0, 0, 0,
1449 2 0, 1, 2, 1, 1, 100, 0, 0, 10, 0,
1450 3 0, 4, 0, 1, 0, 0, 0, 0, 0, 0,
1451 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1452 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1453 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1454 7 0, 2, 0, 0, 0, 0, 0, 0, 0, 0,
1455 8 6, 203, 2001, 11, 13, 0, 0, 0, 0, 0,
1456 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1457 DATA (PARP(I),I=1,100)/
1458 & 0.25D0, 10D0, 8*0D0,
1459 1 0D0, 0D0, 1.0D0, 0.01D0, 0.5D0, 1.0D0, 1.0D0, 0.4D0, 2*0D0,
1460 2 10*0D0,
1461 3 1.5D0,2.0D0,0.075D0,1.0D0,0.2D0,0D0,2.0D0,0.70D0,0.006D0,0D0,
1462 4 0.02D0,2.0D0,0.10D0,1000D0,2054D0,123D0,246D0,50D0,0D0,0.054D0,
1463 5 10*0D0,
1464 6 0.25D0, 1.0D0,0.25D0, 1.0D0, 2.0D0,1D-3, 1.0D0,1D-3,2*0D0,
1465 7 4.0D0, 0.25D0, 8*0D0,
1466 8 1.90D0, 1.90D0, 0.5D0, 0.2D0, 0.33D0,
1467 8 0.66D0, 0.7D0, 0.5D0, 1000D0, 0.16D0,
1468 9 1.0D0,0.40D0,5.0D0,1.0D0,0D0,3.0D0,1.0D0,0.75D0,1.0D0,5.0D0/
1469 DATA (PARP(I),I=101,200)/
1470 & 0.5D0, 0.28D0, 1.0D0, 0.8D0, 0D0, 0D0, 0D0, 0D0, 0D0, 1D0,
1471 1 2.0D0, 3*0D0, 1.5D0, 0.5D0, 0.6D0, 2.5D0, 2.0D0, 1.0D0,
1472 2 1.0D0, 0.4D0, 8*0D0,
1473 3 0.01D0, 5*0D0, 200D0, 200D0, 0.333D0, 0.05D0,
1474 4 0.33333D0, 82D0, 1.33333D0, 4D0, 1D0,
1475 4 1D0, .0182D0, 1D0, 0D0, 1.33333D0,
1476 5 0D0, 0D0, 0D0, 0D0, 0.3651480D0, 200D0, 0D0, 0D0, 0D0, 0D0,
1477 6 2.20D0, 23.6D0, 18.4D0, 11.5D0, 0.5D0, 0D0, 0D0, 0D0, 2*0D0,
1478 7 0D0, 0D0, 0D0, 1.0D0, 6*0D0,
1479 8 0.1D0, 0.01D0, 0.01D0, 0.01D0, 0.1D0, 0.01D0, 0.01D0, 0.01D0,
1480 8 0.3D0, 0.64D0,
1481 9 0.64D0, 5.0D0, 8*0D0/
1482 DATA MSTI/200*0/
1483 DATA PARI/200*0D0/
1484 DATA MINT/400*0/
1485 DATA VINT/400*0D0/
1486
1487C...Constants for the generation of the various processes.
1488 DATA (ISET(I),I=1,100)/
1489 & 1, 1, 1, -1, 3, -1, -1, 3, -2, 2,
1490 1 2, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1491 2 -1, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1492 3 2, 2, 2, 2, 2, 2, -1, -1, -1, -1,
1493 4 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
1494 5 -1, -1, 2, 2, -1, -1, -1, 2, -1, -1,
1495 6 -1, -1, -1, -1, -1, -1, -1, 2, 2, 2,
1496 7 4, 4, 4, -1, -1, 4, 4, -1, -1, 2,
1497 8 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1498 9 0, 0, 0, 0, 0, 9, -2, -2, 8, -2/
1499 DATA (ISET(I),I=101,200)/
1500 & -1, 1, 1, 1, 1, 2, 2, 2, -2, 2,
1501 1 2, 2, 2, 2, 2, -1, -1, -1, -2, -2,
1502 2 5, 5, 5, 5, -2, -2, -2, -2, -2, -2,
1503 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1504 4 1, 1, 1, 1, 1, 1, 1, 1, 1, -2,
1505 5 1, 1, 1, -2, -2, 1, 1, 1, -2, -2,
1506 6 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1507 7 2, 2, 5, 5, -2, 2, 2, 5, 5, -2,
1508 8 5, 5, 2, 2, 2, 5, 5, 2, 2, 2,
1509 9 1, 1, 1, 2, 2, -2, -2, -2, -2, -2/
1510 DATA (ISET(I),I=201,300)/
1511 & 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1512 1 2, 2, 2, 2, -2, 2, 2, 2, 2, 2,
1513 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1514 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1515 4 2, 2, 2, 2, -1, 2, 2, 2, 2, 2,
1516 5 2, 2, 2, 2, -1, 2, -1, 2, 2, -2,
1517 6 2, 2, 2, 2, 2, -1, -1, -1, -1, -1,
1518 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1519 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1520 9 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
1521 DATA (ISET(I),I=301,500)/
1522 & 2, 39*-2,
1523 4 1, 1, 2, 2, 2, 2, 2, 2, 2, 2,
1524 5 5, 5, 1, 1, -1, -1, -1, -1, -1, -1,
1525 6 2, 2, 2, 2, 2, 2, 2, 2, -1, 2,
1526 7 2, 2, 2, 2, 2, 2, 2, -1, -1, -1,
1527 8 10*-2,
1528 9 1, 1, 2, 2, 2, 5*-2,
1529 & 100*-2/
1530 DATA ((KFPR(I,J),J=1,2),I=1,50)/
1531 & 23, 0, 24, 0, 25, 0, 24, 0, 25, 0,
1532 & 24, 0, 23, 0, 25, 0, 0, 0, 0, 0,
1533 1 0, 0, 0, 0, 21, 21, 21, 22, 21, 23,
1534 1 21, 24, 21, 25, 22, 22, 22, 23, 22, 24,
1535 2 22, 25, 23, 23, 23, 24, 23, 25, 24, 24,
1536 2 24, 25, 25, 25, 0, 21, 0, 22, 0, 23,
1537 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1538 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1539 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1540 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23/
1541 DATA ((KFPR(I,J),J=1,2),I=51,100)/
1542 5 0, 24, 0, 25, 0, 0, 0, 0, 0, 0,
1543 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1544 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1545 6 0, 0, 0, 0, 21, 21, 24, 24, 23, 24,
1546 7 23, 23, 24, 24, 23, 24, 23, 25, 22, 22,
1547 7 23, 23, 24, 24, 24, 25, 25, 25, 0, 211,
1548 8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1549 8 443, 21,10441, 21,20443, 21, 445, 21, 0, 0,
1550 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1551 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1552 DATA ((KFPR(I,J),J=1,2),I=101,150)/
1553 & 23, 0, 25, 0, 25, 0,10441, 0, 445, 0,
1554 & 443, 22, 443, 21, 443, 22, 0, 0, 22, 25,
1555 1 21, 25, 0, 25, 21, 25, 22, 22, 21, 22,
1556 1 22, 23, 23, 23, 24, 24, 0, 0, 0, 0,
1557 2 25, 6, 25, 6, 25, 0, 25, 0, 0, 0,
1558 2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1559 3 0, 21, 0, 21, 0, 22, 0, 22, 0, 0,
1560 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1561 4 32, 0, 34, 0, 37, 0, 41, 0, 42, 0,
1562 4 4000011, 0, 4000001, 0, 4000002, 0, 3000331, 0, 0, 0/
1563 DATA ((KFPR(I,J),J=1,2),I=151,200)/
1564 5 35, 0, 35, 0, 35, 0, 0, 0, 0, 0,
1565 5 36, 0, 36, 0, 36, 0, 0, 0, 0, 0,
1566 6 6, 37, 42, 0, 42, 42, 42, 42, 11, 0,
1567 6 11, 0, 0, 4000001, 0, 4000002, 0, 4000011, 0, 0,
1568 7 23, 35, 24, 35, 35, 0, 35, 0, 0, 0,
1569 7 23, 36, 24, 36, 36, 0, 36, 0, 0, 0,
1570 8 35, 6, 35, 6, 21, 35, 0, 35, 21, 35,
1571 8 36, 6, 36, 6, 21, 36, 0, 36, 21, 36,
1572 9 3000113, 0, 3000213, 0, 3000223, 0, 11, 0, 11, 0,
1573 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1574 DATA ((KFPR(I,J),J=1,2),I=201,250)/
1575 & 1000011, 1000011, 2000011, 2000011, 1000011,
1576 & 2000011, 1000013, 1000013, 2000013, 2000013,
1577 & 1000013, 2000013, 1000015, 1000015, 2000015,
1578 & 2000015, 1000015, 2000015, 1000011, 1000012,
1579 1 1000015, 1000016, 2000015, 1000016, 1000012,
1580 1 1000012, 1000016, 1000016, 0, 0,
1581 1 1000022, 1000022, 1000023, 1000023, 1000025,
1582 1 1000025, 1000035, 1000035, 1000022, 1000023,
1583 2 1000022, 1000025, 1000022, 1000035, 1000023,
1584 2 1000025, 1000023, 1000035, 1000025, 1000035,
1585 2 1000024, 1000024, 1000037, 1000037, 1000024,
1586 2 1000037, 1000022, 1000024, 1000023, 1000024,
1587 3 1000025, 1000024, 1000035, 1000024, 1000022,
1588 3 1000037, 1000023, 1000037, 1000025, 1000037,
1589 3 1000035, 1000037, 1000021, 1000022, 1000021,
1590 3 1000023, 1000021, 1000025, 1000021, 1000035,
1591 4 1000021, 1000024, 1000021, 1000037, 1000021,
1592 4 1000021, 1000021, 1000021, 0, 0,
1593 4 1000002, 1000022, 2000002, 1000022, 1000002,
1594 4 1000023, 2000002, 1000023, 1000002, 1000025/
1595 DATA ((KFPR(I,J),J=1,2),I=251,300)/
1596 5 2000002, 1000025, 1000002, 1000035, 2000002,
1597 5 1000035, 1000001, 1000024, 2000005, 1000024,
1598 5 1000001, 1000037, 2000005, 1000037, 1000002,
1599 5 1000021, 2000002, 1000021, 0, 0,
1600 6 1000006, 1000006, 2000006, 2000006, 1000006,
1601 6 2000006, 1000006, 1000006, 2000006, 2000006,
1602 6 0, 0, 0, 0, 0,
1603 6 0, 0, 0, 0, 0,
1604 7 1000002, 1000002, 2000002, 2000002, 1000002,
1605 7 2000002, 1000002, 1000002, 2000002, 2000002,
1606 7 1000002, 2000002, 1000002, 1000002, 2000002,
1607 7 2000002, 1000002, 1000002, 2000002, 2000002,
1608 8 1000005, 1000002, 2000005, 2000002, 1000005,
1609 8 2000002, 1000005, 1000002, 2000005, 2000002,
1610 8 1000005, 2000002, 1000005, 1000005, 2000005,
1611 8 2000005, 1000005, 1000005, 2000005, 2000005,
1612 9 1000005, 1000005, 2000005, 2000005, 1000005,
1613 9 2000005, 1000005, 1000021, 2000005, 1000021,
1614 9 1000005, 2000005, 37, 25, 37,
1615 9 35, 36, 25, 36, 35/
1616 DATA ((KFPR(I,J),J=1,2),I=301,500)/
1617 & 37, 37, 78*0,
1618 4 9900041, 0, 9900042, 0, 9900041,
1619 4 11, 9900042, 11, 9900041, 13,
1620 4 9900042, 13, 9900041, 15, 9900042,
1621 4 15, 9900041, 9900041, 9900042, 9900042,
1622 5 9900041, 0, 9900042, 0, 9900023,
1623 5 0, 9900024, 0, 0, 0,
1624 5 0, 0, 0, 0, 0,
1625 5 0, 0, 0, 0, 0,
1626 6 24, 24, 24, 3000211, 3000211,
1627 6 3000211, 22, 3000111, 22, 3000221,
1628 6 23, 3000111, 23, 3000221, 24,
1629 6 3000211, 0, 0, 24, 23,
1630 7 24, 3000111, 3000211, 23, 3000211,
1631 7 3000111, 22, 3000211, 23, 3000211,
1632 7 24, 3000111, 24, 3000221, 0,
1633 7 0, 0, 0, 0, 0,
1634 8 20*0,
1635 9 5000039, 0, 5000039, 0, 21,
1636 9 5000039, 0, 5000039, 21, 5000039,
1637 9 10*0,
1638 & 200*0/
1639 DATA COEF/10000*0D0/
1640 DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/
1641 &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,
1642 &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,
1643 &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,
1644 &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,
1645 &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,
1646 &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,
1647 &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,
1648 &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,
1649 &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,
1650 &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/
1651
1652C...Treatment of resonances.
1653 DATA (MWID(I) ,I= 1, 500)/5*0,3*1,8*0,1,5*0,3*1,6*0,1,0,4*1,
1654 &3*0,2*1,254*0,19*2,0,7*2,0,2,0,2,0,26*1,146*0/
1655
1656C...Character constants: name of processes.
1657 DATA PROC(0)/ 'All included subprocesses '/
1658 DATA (PROC(I),I=1,20)/
1659 &'f + fbar -> gamma*/Z0 ', 'f + fbar'' -> W+/- ',
1660 &'f + fbar -> h0 ', 'gamma + W+/- -> W+/- ',
1661 &'Z0 + Z0 -> h0 ', 'Z0 + W+/- -> W+/- ',
1662 &' ', 'W+ + W- -> h0 ',
1663 &' ', 'f + f'' -> f + f'' (QFD) ',
1664 1'f + f'' -> f + f'' (QCD) ','f + fbar -> f'' + fbar'' ',
1665 1'f + fbar -> g + g ', 'f + fbar -> g + gamma ',
1666 1'f + fbar -> g + Z0 ', 'f + fbar'' -> g + W+/- ',
1667 1'f + fbar -> g + h0 ', 'f + fbar -> gamma + gamma ',
1668 1'f + fbar -> gamma + Z0 ', 'f + fbar'' -> gamma + W+/- '/
1669 DATA (PROC(I),I=21,40)/
1670 2'f + fbar -> gamma + h0 ', 'f + fbar -> Z0 + Z0 ',
1671 2'f + fbar'' -> Z0 + W+/- ', 'f + fbar -> Z0 + h0 ',
1672 2'f + fbar -> W+ + W- ', 'f + fbar'' -> W+/- + h0 ',
1673 2'f + fbar -> h0 + h0 ', 'f + g -> f + g ',
1674 2'f + g -> f + gamma ', 'f + g -> f + Z0 ',
1675 3'f + g -> f'' + W+/- ', 'f + g -> f + h0 ',
1676 3'f + gamma -> f + g ', 'f + gamma -> f + gamma ',
1677 3'f + gamma -> f + Z0 ', 'f + gamma -> f'' + W+/- ',
1678 3'f + gamma -> f + h0 ', 'f + Z0 -> f + g ',
1679 3'f + Z0 -> f + gamma ', 'f + Z0 -> f + Z0 '/
1680 DATA (PROC(I),I=41,60)/
1681 4'f + Z0 -> f'' + W+/- ', 'f + Z0 -> f + h0 ',
1682 4'f + W+/- -> f'' + g ', 'f + W+/- -> f'' + gamma ',
1683 4'f + W+/- -> f'' + Z0 ', 'f + W+/- -> f'' + W+/- ',
1684 4'f + W+/- -> f'' + h0 ', 'f + h0 -> f + g ',
1685 4'f + h0 -> f + gamma ', 'f + h0 -> f + Z0 ',
1686 5'f + h0 -> f'' + W+/- ', 'f + h0 -> f + h0 ',
1687 5'g + g -> f + fbar ', 'g + gamma -> f + fbar ',
1688 5'g + Z0 -> f + fbar ', 'g + W+/- -> f + fbar'' ',
1689 5'g + h0 -> f + fbar ', 'gamma + gamma -> f + fbar ',
1690 5'gamma + Z0 -> f + fbar ', 'gamma + W+/- -> f + fbar'' '/
1691 DATA (PROC(I),I=61,80)/
1692 6'gamma + h0 -> f + fbar ', 'Z0 + Z0 -> f + fbar ',
1693 6'Z0 + W+/- -> f + fbar'' ', 'Z0 + h0 -> f + fbar ',
1694 6'W+ + W- -> f + fbar ', 'W+/- + h0 -> f + fbar'' ',
1695 6'h0 + h0 -> f + fbar ', 'g + g -> g + g ',
1696 6'gamma + gamma -> W+ + W- ', 'gamma + W+/- -> Z0 + W+/- ',
1697 7'Z0 + Z0 -> Z0 + Z0 ', 'Z0 + Z0 -> W+ + W- ',
1698 7'Z0 + W+/- -> Z0 + W+/- ', 'Z0 + Z0 -> Z0 + h0 ',
1699 7'W+ + W- -> gamma + gamma ', 'W+ + W- -> Z0 + Z0 ',
1700 7'W+/- + W+/- -> W+/- + W+/- ', 'W+/- + h0 -> W+/- + h0 ',
1701 7'h0 + h0 -> h0 + h0 ', 'q + gamma -> q'' + pi+/- '/
1702 DATA (PROC(I),I=81,100)/
1703 8'q + qbar -> Q + Qbar, mass ', 'g + g -> Q + Qbar, massive ',
1704 8'f + q -> f'' + Q, massive ', 'g + gamma -> Q + Qbar, mass ',
1705 8'gamma + gamma -> F + Fbar, m', 'g + g -> J/Psi + g ',
1706 8'g + g -> chi_0c + g ', 'g + g -> chi_1c + g ',
1707 8'g + g -> chi_2c + g ', ' ',
1708 9'Elastic scattering ', 'Single diffractive (XB) ',
1709 9'Single diffractive (AX) ', 'Double diffractive ',
1710 9'Low-pT scattering ', 'Semihard QCD 2 -> 2 ',
1711 9' ', ' ',
1712 9'q + gamma* -> q ', ' '/
1713 DATA (PROC(I),I=101,120)/
1714 &'g + g -> gamma*/Z0 ', 'g + g -> h0 ',
1715 &'gamma + gamma -> h0 ', 'g + g -> chi_0c ',
1716 &'g + g -> chi_2c ', 'g + g -> J/Psi + gamma ',
1717 &'gamma + g -> J/Psi + g ', 'gamma+gamma -> J/Psi + gamma',
1718 &' ', 'f + fbar -> gamma + h0 ',
1719 1'q + qbar -> g + h0 ', 'q + g -> q + h0 ',
1720 1'g + g -> g + h0 ', 'g + g -> gamma + gamma ',
1721 1'g + g -> g + gamma ', 'g + g -> gamma + Z0 ',
1722 1'g + g -> Z0 + Z0 ', 'g + g -> W+ + W- ',
1723 1' ', ' '/
1724 DATA (PROC(I),I=121,140)/
1725 2'g + g -> Q + Qbar + h0 ', 'q + qbar -> Q + Qbar + h0 ',
1726 2'f + f'' -> f + f'' + h0 ',
1727 2'f + f'' -> f" + f"'' + h0 ',
1728 2' ', ' ',
1729 2' ', ' ',
1730 2' ', ' ',
1731 3'f + gamma*_T -> f + g ', 'f + gamma*_L -> f + g ',
1732 3'f + gamma*_T -> f + gamma ', 'f + gamma*_L -> f + gamma ',
1733 3'g + gamma*_T -> f + fbar ', 'g + gamma*_L -> f + fbar ',
1734 3'gamma*_T+gamma*_T -> f+fbar ', 'gamma*_T+gamma*_L -> f+fbar ',
1735 3'gamma*_L+gamma*_T -> f+fbar ', 'gamma*_L+gamma*_L -> f+fbar '/
1736 DATA (PROC(I),I=141,160)/
1737 4'f + fbar -> gamma*/Z0/Z''0 ', 'f + fbar'' -> W''+/- ',
1738 4'f + fbar'' -> H+/- ', 'f + fbar'' -> R ',
1739 4'q + l -> LQ ', 'e + gamma -> e* ',
1740 4'd + g -> d* ', 'u + g -> u* ',
1741 4'g + g -> eta_tc ', ' ',
1742 5'f + fbar -> H0 ', 'g + g -> H0 ',
1743 5'gamma + gamma -> H0 ', ' ',
1744 5' ', 'f + fbar -> A0 ',
1745 5'g + g -> A0 ', 'gamma + gamma -> A0 ',
1746 5' ', ' '/
1747 DATA (PROC(I),I=161,180)/
1748 6'f + g -> f'' + H+/- ', 'q + g -> LQ + lbar ',
1749 6'g + g -> LQ + LQbar ', 'q + qbar -> LQ + LQbar ',
1750 6'f + fbar -> f'' + fbar'' (g/Z)',
1751 6'f +fbar'' -> f" + fbar"'' (W) ',
1752 6'q + q'' -> q" + d* ', 'q + q'' -> q" + u* ',
1753 6'q + qbar -> e + e* ', ' ',
1754 7'f + fbar -> Z0 + H0 ', 'f + fbar'' -> W+/- + H0 ',
1755 7'f + f'' -> f + f'' + H0 ',
1756 7'f + f'' -> f" + f"'' + H0 ',
1757 7' ', 'f + fbar -> Z0 + A0 ',
1758 7'f + fbar'' -> W+/- + A0 ',
1759 7'f + f'' -> f + f'' + A0 ',
1760 7'f + f'' -> f" + f"'' + A0 ',
1761 7' '/
1762 DATA (PROC(I),I=181,200)/
1763 8'g + g -> Q + Qbar + H0 ', 'q + qbar -> Q + Qbar + H0 ',
1764 8'q + qbar -> g + H0 ', 'q + g -> q + H0 ',
1765 8'g + g -> g + H0 ', 'g + g -> Q + Qbar + A0 ',
1766 8'q + qbar -> Q + Qbar + A0 ', 'q + qbar -> g + A0 ',
1767 8'q + g -> q + A0 ', 'g + g -> g + A0 ',
1768 9'f + fbar -> rho_tc0 ', 'f + f'' -> rho_tc+/- ',
1769 9'f + fbar -> omega_tc0 ', 'f+fbar -> f''+fbar'' (ETC) ',
1770 9'f+fbar'' -> f"+fbar"'' (ETC)',' ',
1771 9' ', ' ',
1772 9' ', ' '/
1773 DATA (PROC(I),I=201,220)/
1774 &'f + fbar -> ~e_L + ~e_Lbar ', 'f + fbar -> ~e_R + ~e_Rbar ',
1775 &'f + fbar -> ~e_R + ~e_Lbar ', 'f + fbar -> ~mu_L + ~mu_Lbar',
1776 &'f + fbar -> ~mu_R + ~mu_Rbar', 'f + fbar -> ~mu_L + ~mu_Rbar',
1777 &'f+fbar -> ~tau_1 + ~tau_1bar', 'f+fbar -> ~tau_2 + ~tau_2bar',
1778 &'f+fbar -> ~tau_1 + ~tau_2bar', 'q + qbar'' -> ~l_L + ~nulbar ',
1779 1'q+qbar''-> ~tau_1 + ~nutaubar', 'q+qbar''-> ~tau_2 + ~nutaubar',
1780 1'f + fbar -> ~nul + ~nulbar ', 'f+fbar -> ~nutau + ~nutaubar',
1781 1' ', 'f + fbar -> ~chi1 + ~chi1 ',
1782 1'f + fbar -> ~chi2 + ~chi2 ', 'f + fbar -> ~chi3 + ~chi3 ',
1783 1'f + fbar -> ~chi4 + ~chi4 ', 'f + fbar -> ~chi1 + ~chi2 '/
1784 DATA (PROC(I),I=221,240)/
1785 2'f + fbar -> ~chi1 + ~chi3 ', 'f + fbar -> ~chi1 + ~chi4 ',
1786 2'f + fbar -> ~chi2 + ~chi3 ', 'f + fbar -> ~chi2 + ~chi4 ',
1787 2'f + fbar -> ~chi3 + ~chi4 ', 'f+fbar -> ~chi+-1 + ~chi-+1 ',
1788 2'f+fbar -> ~chi+-2 + ~chi-+2 ', 'f+fbar -> ~chi+-1 + ~chi-+2 ',
1789 2'q + qbar'' -> ~chi1 + ~chi+-1', 'q + qbar'' -> ~chi2 + ~chi+-1',
1790 3'q + qbar'' -> ~chi3 + ~chi+-1', 'q + qbar'' -> ~chi4 + ~chi+-1',
1791 3'q + qbar'' -> ~chi1 + ~chi+-2', 'q + qbar'' -> ~chi2 + ~chi+-2',
1792 3'q + qbar'' -> ~chi3 + ~chi+-2', 'q + qbar'' -> ~chi4 + ~chi+-2',
1793 3'q + qbar -> ~chi1 + ~g ', 'q + qbar -> ~chi2 + ~g ',
1794 3'q + qbar -> ~chi3 + ~g ', 'q + qbar -> ~chi4 + ~g '/
1795 DATA (PROC(I),I=241,260)/
1796 4'q + qbar'' -> ~chi+-1 + ~g ', 'q + qbar'' -> ~chi+-2 + ~g ',
1797 4'q + qbar -> ~g + ~g ', 'g + g -> ~g + ~g ',
1798 4' ', 'qj + g -> ~qj_L + ~chi1 ',
1799 4'qj + g -> ~qj_R + ~chi1 ', 'qj + g -> ~qj_L + ~chi2 ',
1800 4'qj + g -> ~qj_R + ~chi2 ', 'qj + g -> ~qj_L + ~chi3 ',
1801 5'qj + g -> ~qj_R + ~chi3 ', 'qj + g -> ~qj_L + ~chi4 ',
1802 5'qj + g -> ~qj_R + ~chi4 ', 'qj + g -> ~qk_L + ~chi+-1 ',
1803 5'qj + g -> ~qk_R + ~chi+-1 ', 'qj + g -> ~qk_L + ~chi+-2 ',
1804 5'qj + g -> ~qk_R + ~chi+-2 ', 'qj + g -> ~qj_L + ~g ',
1805 5'qj + g -> ~qj_R + ~g ', ' '/
1806 DATA (PROC(I),I=261,300)/
1807 6'f + fbar -> ~t_1 + ~t_1bar ', 'f + fbar -> ~t_2 + ~t_2bar ',
1808 6'f + fbar -> ~t_1 + ~t_2bar ', 'g + g -> ~t_1 + ~t_1bar ',
1809 6'g + g -> ~t_2 + ~t_2bar ', ' ',
1810 6' ', ' ',
1811 6' ', ' ',
1812 7'qi + qj -> ~qi_L + ~qj_L ', 'qi + qj -> ~qi_R + ~qj_R ',
1813 7'qi + qj -> ~qi_L + ~qj_R ', 'qi+qjbar -> ~qi_L + ~qj_Lbar',
1814 7'qi+qjbar -> ~qi_R + ~qj_Rbar', 'qi+qjbar -> ~qi_L + ~qj_Rbar',
1815 7'f + fbar -> ~qi_L + ~qi_Lbar', 'f + fbar -> ~qi_R + ~qi_Rbar',
1816 7'g + g -> ~qi_L + ~qi_Lbar ', 'g + g -> ~qi_R + ~qi_Rbar ',
1817 8'b + qj -> ~b_1 + ~qj_L ', 'b + qj -> ~b_2 + ~qj_R ',
1818 8'b + qj -> ~b_1 + ~qj_R ', 'b + qjbar -> ~b_1 + ~qj_Lbar',
1819 8'b + qjbar -> ~b_2 + ~qj_Rbar', 'b + qjbar -> ~b_1 + ~qj_Rbar',
1820 8'f + fbar -> ~b_1 + ~b_1bar ', 'f + fbar -> ~b_2 + ~b_2bar ',
1821 8'g + g -> ~b_1 + ~b_1bar ', 'g + g -> ~b_2 + ~b_2bar ',
1822 9'b + b -> ~b_1 + ~b_1 ', 'b + b -> ~b_2 + ~b_2 ',
1823 9'b + b -> ~b_1 + ~b_2 ', 'b + g -> ~b_1 + ~g ',
1824 9'b + g -> ~b_2 + ~g ', 'b + bbar -> ~b_1 + ~b_2bar ',
1825 9'f + fbar'' -> H+/- + h0 ', 'f + fbar -> H+/- + H0 ',
1826 9'f + fbar -> A0 + h0 ', 'f + fbar -> A0 + H0 '/
1827 DATA (PROC(I),I=301,340)/
1828 &'f + fbar -> H+ + H- ', 39*' '/
1829 DATA (PROC(I),I=341,380)/
1830 4'l + l -> H_L++/-- ', 'l + l -> H_R++/-- ',
1831 4'l + gamma -> H_L++/-- e-/+ ', 'l + gamma -> H_R++/-- e-/+ ',
1832 4'l + gamma -> H_L++/-- mu-/+ ', 'l + gamma -> H_R++/-- mu-/+ ',
1833 4'l + gamma -> H_L++/-- tau-/+', 'l + gamma -> H_R++/-- tau-/+',
1834 4'f + fbar -> H_L++ + H_L-- ', 'f + fbar -> H_R++ + H_R-- ',
1835 5'f + f -> f'' + f'' + H_L++/-- ',
1836 5'f + f -> f'' + f'' + H_R++/-- ','f + fbar -> Z_R0 ',
1837 5'f + fbar'' -> W_R+/- ',5*' ',
1838 6' ', 'f + fbar -> W_L+ W_L- ',
1839 6'f + fbar -> W_L+/- pi_T-/+ ', 'f + fbar -> pi_T+ pi_T- ',
1840 6'f + fbar -> gamma pi_T0 ', 'f + fbar -> gamma pi_T0'' ',
1841 6'f + fbar -> Z0 pi_T0 ', 'f + fbar -> Z0 pi_T0'' ',
1842 6'f + fbar -> W+/- pi_T-/+ ', ' ',
1843 7'f + fbar'' -> W_L+/- Z_L0 ', 'f + fbar'' -> W_L+/- pi_T0 ',
1844 7'f + fbar'' -> pi_T+/- Z_L0 ', 'f + fbar'' -> pi_T+/- pi_T0 ',
1845 7'f + fbar'' -> gamma pi_T+/- ', 'f + fbar'' -> Z0 pi_T+/- ',
1846 7'f + fbar'' -> W+/- pi_T0 ',
1847 7'f + fbar'' -> W+/- pi_T0'' ',
1848 7' ',' ',
1849 7' '/
1850 DATA (PROC(I),I=381,500)/
1851 8 10* ' ',
1852 9'f + fbar -> G* ','g + g -> G* ',
1853 9'q + qbar -> g + G* ','q + g -> q + G* ',
1854 9'g + g -> g + G* ',' ',
1855 & 104*' '/
1856
1857C...Cross sections and slope offsets.
1858 DATA SIGT/294*0D0/
1859
1860C...Supersymmetry switches and parameters.
1861 DATA IMSS/0,
1862 & 0, 0, 0, 1, 0, 0, 0, 1, 0, 0,
1863 1 89*0/
1864 DATA RMSS/0D0,
1865 & 80D0,160D0,500D0,800D0,2D0,250D0,200D0,800D0,700D0,800D0,
1866 1 700D0,500D0,250D0,200D0,800D0,400D0,0D0,0.1D0,850D0,0.041D0,
1867 2 1D0,800D0,1D4,1D4,1D4,0D0,0D0,0D0,24D17,0D0,
1868 3 69*0D0/
1869C...Initial values for R-violating SUSY couplings.
1870C...Should not be changed here. See PYMSIN.
1871 DATA RVLAM/27*0D0/
1872 DATA RVLAMP/27*0D0/
1873 DATA RVLAMB/27*0D0/
1874
1875C...Data for histogramming routines.
1876 DATA IHIST/1000,20000,55,1/
1877 DATA INDX/1000*0/
1878
1879 END
1880
1881C*********************************************************************
1882
1883C...PYTEST
1884C...A simple program (disguised as subroutine) to run at installation
1885C...as a check that the program works as intended.
1886
1887 SUBROUTINE PYTEST(MTEST)
1888
1889C...Double precision and integer declarations.
1890 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
1891 IMPLICIT INTEGER(I-N)
1892 INTEGER PYK,PYCHGE,PYCOMP
1893C...Commonblocks.
1894 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
1895 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1896 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
1897 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
1898 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
1899 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
1900 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
1901C...Local arrays.
1902 DIMENSION PSUM(5),PINI(6),PFIN(6)
1903
1904C...Save defaults for values that are changed.
1905 MSTJ1=MSTJ(1)
1906 MSTJ3=MSTJ(3)
1907 MSTJ11=MSTJ(11)
1908 MSTJ42=MSTJ(42)
1909 MSTJ43=MSTJ(43)
1910 MSTJ44=MSTJ(44)
1911 PARJ17=PARJ(17)
1912 PARJ22=PARJ(22)
1913 PARJ43=PARJ(43)
1914 PARJ54=PARJ(54)
1915 MST101=MSTJ(101)
1916 MST104=MSTJ(104)
1917 MST105=MSTJ(105)
1918 MST107=MSTJ(107)
1919 MST116=MSTJ(116)
1920
1921C...First part: loop over simple events to be generated.
1922 IF(MTEST.GE.1) CALL PYTABU(20)
1923 NERR=0
1924 DO 180 IEV=1,500
1925
1926C...Reset parameter values. Switch on some nonstandard features.
1927 MSTJ(1)=1
1928 MSTJ(3)=0
1929 MSTJ(11)=1
1930 MSTJ(42)=2
1931 MSTJ(43)=4
1932 MSTJ(44)=2
1933 PARJ(17)=0.1D0
1934 PARJ(22)=1.5D0
1935 PARJ(43)=1D0
1936 PARJ(54)=-0.05D0
1937 MSTJ(101)=5
1938 MSTJ(104)=5
1939 MSTJ(105)=0
1940 MSTJ(107)=1
1941 IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3
1942
1943C...Ten events each for some single jets configurations.
1944 IF(IEV.LE.50) THEN
1945 ITY=(IEV+9)/10
1946 MSTJ(3)=-1
1947 IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2
1948 IF(ITY.EQ.1) CALL PY1ENT(1,1,15D0,0D0,0D0)
1949 IF(ITY.EQ.2) CALL PY1ENT(1,3101,15D0,0D0,0D0)
1950 IF(ITY.EQ.3) CALL PY1ENT(1,-2203,15D0,0D0,0D0)
1951 IF(ITY.EQ.4) CALL PY1ENT(1,-4,30D0,0D0,0D0)
1952 IF(ITY.EQ.5) CALL PY1ENT(1,21,15D0,0D0,0D0)
1953
1954C...Ten events each for some simple jet systems; string fragmentation.
1955 ELSEIF(IEV.LE.130) THEN
1956 ITY=(IEV-41)/10
1957 IF(ITY.EQ.1) CALL PY2ENT(1,1,-1,40D0)
1958 IF(ITY.EQ.2) CALL PY2ENT(1,4,-4,30D0)
1959 IF(ITY.EQ.3) CALL PY2ENT(1,2,2103,100D0)
1960 IF(ITY.EQ.4) CALL PY2ENT(1,21,21,40D0)
1961 IF(ITY.EQ.5) CALL PY3ENT(1,2101,21,-3203,30D0,0.6D0,0.8D0)
1962 IF(ITY.EQ.6) CALL PY3ENT(1,5,21,-5,40D0,0.9D0,0.8D0)
1963 IF(ITY.EQ.7) CALL PY3ENT(1,21,21,21,60D0,0.7D0,0.5D0)
1964 IF(ITY.EQ.8) CALL PY4ENT(1,2,21,21,-2,40D0,
1965 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
1966
1967C...Seventy events with independent fragmentation and momentum cons.
1968 ELSEIF(IEV.LE.200) THEN
1969 ITY=1+(IEV-131)/16
1970 MSTJ(2)=1+MOD(IEV-131,4)
1971 MSTJ(3)=1+MOD((IEV-131)/4,4)
1972 IF(ITY.EQ.1) CALL PY2ENT(1,4,-5,40D0)
1973 IF(ITY.EQ.2) CALL PY3ENT(1,3,21,-3,40D0,0.9D0,0.4D0)
1974 IF(ITY.EQ.3) CALL PY4ENT(1,2,21,21,-2,40D0,
1975 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
1976 IF(ITY.GE.4) CALL PY4ENT(1,2,-3,3,-2,40D0,
1977 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
1978
1979C...A hundred events with random jets (check invariant mass).
1980 ELSEIF(IEV.LE.300) THEN
1981 100 DO 110 J=1,5
1982 PSUM(J)=0D0
1983 110 CONTINUE
1984 NJET=2D0+6D0*PYR(0)
1985 DO 130 I=1,NJET
1986 KFL=21
1987 IF(I.EQ.1) KFL=INT(1D0+4D0*PYR(0))
1988 IF(I.EQ.NJET) KFL=-INT(1D0+4D0*PYR(0))
1989 EJET=5D0+20D0*PYR(0)
1990 THETA=ACOS(2D0*PYR(0)-1D0)
1991 PHI=6.2832D0*PYR(0)
1992 IF(I.LT.NJET) CALL PY1ENT(-I,KFL,EJET,THETA,PHI)
1993 IF(I.EQ.NJET) CALL PY1ENT(I,KFL,EJET,THETA,PHI)
1994 IF(I.EQ.1.OR.I.EQ.NJET) MSTJ(93)=1
1995 IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+PYMASS(KFL)
1996 DO 120 J=1,4
1997 PSUM(J)=PSUM(J)+P(I,J)
1998 120 CONTINUE
1999 130 CONTINUE
2000 IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT.
2001 & (PSUM(5)+PARJ(32))**2) GOTO 100
2002
2003C...Fifty e+e- continuum events with matrix elements.
2004 ELSEIF(IEV.LE.350) THEN
2005 MSTJ(101)=2
2006 CALL PYEEVT(0,40D0)
2007
2008C...Fifty e+e- continuum event with varying shower options.
2009 ELSEIF(IEV.LE.400) THEN
2010 MSTJ(42)=1+MOD(IEV,2)
2011 MSTJ(43)=1+MOD(IEV/2,4)
2012 MSTJ(44)=MOD(IEV/8,3)
2013 CALL PYEEVT(0,90D0)
2014
2015C...Fifty e+e- continuum events with coherent shower.
2016 ELSEIF(IEV.LE.450) THEN
2017 CALL PYEEVT(0,500D0)
2018
2019C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
2020 ELSE
2021 CALL PYONIA(5,9.46D0)
2022 ENDIF
2023
2024C...Generate event. Find total momentum, energy and charge.
2025 DO 140 J=1,4
2026 PINI(J)=PYP(0,J)
2027 140 CONTINUE
2028 PINI(6)=PYP(0,6)
2029 CALL PYEXEC
2030 DO 150 J=1,4
2031 PFIN(J)=PYP(0,J)
2032 150 CONTINUE
2033 PFIN(6)=PYP(0,6)
2034
2035C...Check conservation of energy, momentum and charge;
2036C...usually exact, but only approximate for single jets.
2037 MERR=0
2038 IF(IEV.LE.50) THEN
2039 IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.10D0)
2040 & MERR=MERR+1
2041 EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)
2042 IF(EPZREM.LT.0D0.OR.EPZREM.GT.2D0*PARJ(31)) MERR=MERR+1
2043 IF(ABS(PFIN(6)-PINI(6)).GT.2.1D0) MERR=MERR+1
2044 ELSE
2045 DO 160 J=1,4
2046 IF(ABS(PFIN(J)-PINI(J)).GT.0.0001D0*PINI(4)) MERR=MERR+1
2047 160 CONTINUE
2048 IF(ABS(PFIN(6)-PINI(6)).GT.0.1D0) MERR=MERR+1
2049 ENDIF
2050 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
2051 & (PFIN(J),J=1,4),PFIN(6)
2052
2053C...Check that all KF codes are known ones, and that partons/particles
2054C...satisfy energy-momentum-mass relation. Store particle statistics.
2055 DO 170 I=1,N
2056 IF(K(I,1).GT.20) GOTO 170
2057 IF(PYCOMP(K(I,2)).EQ.0) THEN
2058 WRITE(MSTU(11),5100) I
2059 MERR=MERR+1
2060 ENDIF
2061 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
2062 IF(ABS(PD).GT.MAX(0.1D0,0.001D0*P(I,4)**2).OR.P(I,4).LT.0D0)
2063 & THEN
2064 WRITE(MSTU(11),5200) I
2065 MERR=MERR+1
2066 ENDIF
2067 170 CONTINUE
2068 IF(MTEST.GE.1) CALL PYTABU(21)
2069
2070C...List all erroneous events and some normal ones.
2071 IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN
2072 IF(MERR.GE.1) WRITE(MSTU(11),6400)
2073 CALL PYLIST(2)
2074 ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN
2075 CALL PYLIST(1)
2076 ENDIF
2077
2078C...Stop execution if too many errors.
2079 IF(MERR.NE.0) NERR=NERR+1
2080 IF(NERR.GE.10) THEN
2081 WRITE(MSTU(11),6300)
2082 CALL PYLIST(1)
2083 STOP
2084 ENDIF
2085 180 CONTINUE
2086
2087C...Summarize result of run.
2088 IF(MTEST.GE.1) CALL PYTABU(22)
2089
2090C...Reset commonblock variables changed during run.
2091 MSTJ(1)=MSTJ1
2092 MSTJ(3)=MSTJ3
2093 MSTJ(11)=MSTJ11
2094 MSTJ(42)=MSTJ42
2095 MSTJ(43)=MSTJ43
2096 MSTJ(44)=MSTJ44
2097 PARJ(17)=PARJ17
2098 PARJ(22)=PARJ22
2099 PARJ(43)=PARJ43
2100 PARJ(54)=PARJ54
2101 MSTJ(101)=MST101
2102 MSTJ(104)=MST104
2103 MSTJ(105)=MST105
2104 MSTJ(107)=MST107
2105 MSTJ(116)=MST116
2106
2107C...Second part: complete events of various kinds.
2108C...Common initial values. Loop over initiating conditions.
2109 MSTP(122)=MAX(0,MIN(2,MTEST))
2110 MDCY(PYCOMP(111),1)=0
2111 DO 230 IPROC=1,8
2112
2113C...Reset process type, kinematics cuts, and the flags used.
2114 MSEL=0
2115 DO 190 ISUB=1,500
2116 MSUB(ISUB)=0
2117 190 CONTINUE
2118 CKIN(1)=2D0
2119 CKIN(3)=0D0
2120 MSTP(2)=1
2121 MSTP(11)=0
2122 MSTP(33)=0
2123 MSTP(81)=1
2124 MSTP(82)=1
2125 MSTP(111)=1
2126 MSTP(131)=0
2127 MSTP(133)=0
2128 PARP(131)=0.01D0
2129
2130C...Prompt photon production at fixed target.
2131 IF(IPROC.EQ.1) THEN
2132 PZSUM=300D0
2133 PESUM=SQRT(PZSUM**2+PYMASS(211)**2)+PYMASS(2212)
2134 PQSUM=2D0
2135 MSEL=10
2136 CKIN(3)=5D0
2137 CALL PYINIT('FIXT','pi+','p',PZSUM)
2138
2139C...QCD processes at ISR energies.
2140 ELSEIF(IPROC.EQ.2) THEN
2141 PESUM=63D0
2142 PZSUM=0D0
2143 PQSUM=2D0
2144 MSEL=1
2145 CKIN(3)=5D0
2146 CALL PYINIT('CMS','p','p',PESUM)
2147
2148C...W production + multiple interactions at CERN Collider.
2149 ELSEIF(IPROC.EQ.3) THEN
2150 PESUM=630D0
2151 PZSUM=0D0
2152 PQSUM=0D0
2153 MSEL=12
2154 CKIN(1)=20D0
2155 MSTP(82)=4
2156 MSTP(2)=2
2157 MSTP(33)=3
2158 CALL PYINIT('CMS','p','pbar',PESUM)
2159
2160C...W/Z gauge boson pairs + pileup events at the Tevatron.
2161 ELSEIF(IPROC.EQ.4) THEN
2162 PESUM=1800D0
2163 PZSUM=0D0
2164 PQSUM=0D0
2165 MSUB(22)=1
2166 MSUB(23)=1
2167 MSUB(25)=1
2168 CKIN(1)=200D0
2169 MSTP(111)=0
2170 MSTP(131)=1
2171 MSTP(133)=2
2172 PARP(131)=0.04D0
2173 CALL PYINIT('CMS','p','pbar',PESUM)
2174
2175C...Higgs production at LHC.
2176 ELSEIF(IPROC.EQ.5) THEN
2177 PESUM=15400D0
2178 PZSUM=0D0
2179 PQSUM=2D0
2180 MSUB(3)=1
2181 MSUB(102)=1
2182 MSUB(123)=1
2183 MSUB(124)=1
2184 PMAS(25,1)=300D0
2185 CKIN(1)=200D0
2186 MSTP(81)=0
2187 MSTP(111)=0
2188 CALL PYINIT('CMS','p','p',PESUM)
2189
2190C...Z' production at SSC.
2191 ELSEIF(IPROC.EQ.6) THEN
2192 PESUM=40000D0
2193 PZSUM=0D0
2194 PQSUM=2D0
2195 MSEL=21
2196 PMAS(32,1)=600D0
2197 CKIN(1)=400D0
2198 MSTP(81)=0
2199 MSTP(111)=0
2200 CALL PYINIT('CMS','p','p',PESUM)
2201
2202C...W pair production at 1 TeV e+e- collider.
2203 ELSEIF(IPROC.EQ.7) THEN
2204 PESUM=1000D0
2205 PZSUM=0D0
2206 PQSUM=0D0
2207 MSUB(25)=1
2208 MSUB(69)=1
2209 MSTP(11)=1
2210 CALL PYINIT('CMS','e+','e-',PESUM)
2211
2212C...Deep inelastic scattering at a LEP+LHC ep collider.
2213 ELSEIF(IPROC.EQ.8) THEN
2214 P(1,1)=0D0
2215 P(1,2)=0D0
2216 P(1,3)=8000D0
2217 P(2,1)=0D0
2218 P(2,2)=0D0
2219 P(2,3)=-80D0
2220 PESUM=8080D0
2221 PZSUM=7920D0
2222 PQSUM=0D0
2223 MSUB(10)=1
2224 CKIN(3)=50D0
2225 MSTP(111)=0
2226 CALL PYINIT('3MOM','p','e-',PESUM)
2227 ENDIF
2228
2229C...Generate 20 events of each required type.
2230 DO 220 IEV=1,20
2231 CALL PYEVNT
2232 PESUMM=PESUM
2233 IF(IPROC.EQ.4) PESUMM=MSTI(41)*PESUM
2234
2235C...Check conservation of energy/momentum/flavour.
2236 PINI(1)=0D0
2237 PINI(2)=0D0
2238 PINI(3)=PZSUM
2239 PINI(4)=PESUMM
2240 PINI(6)=PQSUM
2241 DO 200 J=1,4
2242 PFIN(J)=PYP(0,J)
2243 200 CONTINUE
2244 PFIN(6)=PYP(0,6)
2245 MERR=0
2246 DEVE=ABS(PFIN(4)-PINI(4))+ABS(PFIN(3)-PINI(3))
2247 DEVT=ABS(PFIN(1)-PINI(1))+ABS(PFIN(2)-PINI(2))
2248 DEVQ=ABS(PFIN(6)-PINI(6))
2249 IF(DEVE.GT.2D-3*PESUM.OR.DEVT.GT.MAX(0.01D0,1D-4*PESUM).OR.
2250 & DEVQ.GT.0.1D0) MERR=1
2251 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
2252 & (PFIN(J),J=1,4),PFIN(6)
2253
2254C...Check that all KF codes are known ones, and that partons/particles
2255C...satisfy energy-momentum-mass relation.
2256 DO 210 I=1,N
2257 IF(K(I,1).GT.20) GOTO 210
2258 IF(PYCOMP(K(I,2)).EQ.0) THEN
2259 WRITE(MSTU(11),5100) I
2260 MERR=MERR+1
2261 ENDIF
2262 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2*
2263 & SIGN(1D0,P(I,5))
2264 IF(ABS(PD).GT.MAX(0.1D0,0.002D0*P(I,4)**2,0.002D0*P(I,5)**2)
2265 & .OR.(P(I,5).GE.0D0.AND.P(I,4).LT.0D0)) THEN
2266 WRITE(MSTU(11),5200) I
2267 MERR=MERR+1
2268 ENDIF
2269 210 CONTINUE
2270
2271C...Listing of erroneous events, and first event of each type.
2272 IF(MERR.GE.1) NERR=NERR+1
2273 IF(NERR.GE.10) THEN
2274 WRITE(MSTU(11),6300)
2275 CALL PYLIST(1)
2276 STOP
2277 ENDIF
2278 IF(MTEST.GE.1.AND.(MERR.GE.1.OR.IEV.EQ.1)) THEN
2279 IF(MERR.GE.1) WRITE(MSTU(11),6400)
2280 CALL PYLIST(1)
2281 ENDIF
2282 220 CONTINUE
2283
2284C...List statistics for each process type.
2285 IF(MTEST.GE.1) CALL PYSTAT(1)
2286 230 CONTINUE
2287
2288C...Summarize result of run.
2289 IF(NERR.EQ.0) WRITE(MSTU(11),6500)
2290 IF(NERR.GT.0) WRITE(MSTU(11),6600) NERR
2291
2292C...Format statements for output.
2293 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
2294 &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X,
2295 &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X,
2296 &4(1X,F12.5),1X,F8.2)
2297 5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
2298 5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
2299 &'kinematics')
2300 6300 FORMAT(/5X,'This is the tenth error experienced! Something is ',
2301 &'wrong.'/5X,'Execution will be stopped after listing of event.')
2302 6400 FORMAT(5X,'Faulty event follows:')
2303 6500 FORMAT(//5X,'End result of PYTEST: no errors detected.')
2304 6600 FORMAT(//5X,'End result of PYTEST:',I2,' errors detected.'/
2305 &5X,'This should not have happened!')
2306
2307 RETURN
2308 END
2309
2310C*********************************************************************
2311
2312C...PYHEPC
2313C...Converts PYTHIA event record contents to or from
2314C...the standard event record commonblock.
2315
2316 SUBROUTINE PYHEPC(MCONV)
2317
2318C...Double precision and integer declarations.
2319 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2320 IMPLICIT INTEGER(I-N)
2321 INTEGER PYK,PYCHGE,PYCOMP
2322C...Commonblocks.
2323 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2324 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2325 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2326 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
2327C...HEPEVT commonblock.
2328 PARAMETER (NMXHEP=4000)
2329 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
2330 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
2331 DOUBLE PRECISION PHEP,VHEP
2332 SAVE /HEPEVT/
2333
2334C...Conversion from PYTHIA to standard, the easy part.
2335 IF(MCONV.EQ.1) THEN
2336 NEVHEP=0
2337 IF(N.GT.NMXHEP) CALL PYERRM(8,
2338 & '(PYHEPC:) no more space in /HEPEVT/')
2339 NHEP=MIN(N,NMXHEP)
2340 DO 140 I=1,NHEP
2341 ISTHEP(I)=0
2342 IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1
2343 IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2
2344 IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3
2345 IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1)
2346 IDHEP(I)=K(I,2)
2347 JMOHEP(1,I)=K(I,3)
2348 JMOHEP(2,I)=0
2349 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
2350 JDAHEP(1,I)=K(I,4)
2351 JDAHEP(2,I)=K(I,5)
2352 ELSE
2353 JDAHEP(1,I)=0
2354 JDAHEP(2,I)=0
2355 ENDIF
2356 DO 100 J=1,5
2357 PHEP(J,I)=P(I,J)
2358 100 CONTINUE
2359 DO 110 J=1,4
2360 VHEP(J,I)=V(I,J)
2361 110 CONTINUE
2362
2363C...Check if new event (from pileup).
2364 IF(I.EQ.1) THEN
2365 INEW=1
2366 ELSE
2367 IF(K(I,1).EQ.21.AND.K(I-1,1).NE.21) INEW=I
2368 ENDIF
2369
2370C...Fill in missing mother information.
2371 IF(I.GE.INEW+2.AND.K(I,1).EQ.21.AND.K(I,3).EQ.0) THEN
2372 IMO1=I-2
2373 IF(I.GE.INEW+3.AND.K(I-1,1).EQ.21.AND.K(I-1,3).EQ.0)
2374 & IMO1=IMO1-1
2375 JMOHEP(1,I)=IMO1
2376 JMOHEP(2,I)=IMO1+1
2377 ELSEIF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN
2378 I1=K(I,3)-1
2379 120 I1=I1+1
2380 IF(I1.GE.I) CALL PYERRM(8,
2381 & '(PYHEPC:) translation of inconsistent event history')
2382 IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 120
2383 KC=PYCOMP(K(I1,2))
2384 IF(I1.LT.I.AND.KC.EQ.0) GOTO 120
2385 IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 120
2386 JMOHEP(2,I)=I1
2387 ELSEIF(K(I,2).EQ.94) THEN
2388 NJET=2
2389 IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3
2390 IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4
2391 JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5))
2392 IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)=
2393 & MOD(K(I+1,4)/MSTU(5),MSTU(5))
2394 ENDIF
2395
2396C...Fill in missing daughter information.
2397 IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN
2398 DO 130 I1=JDAHEP(1,I),JDAHEP(2,I)
2399 I2=MOD(K(I1,4)/MSTU(5),MSTU(5))
2400 JDAHEP(1,I2)=I
2401 130 CONTINUE
2402 ENDIF
2403 IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 140
2404 I1=JMOHEP(1,I)
2405 IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 140
2406 IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 140
2407 IF(JDAHEP(1,I1).EQ.0) THEN
2408 JDAHEP(1,I1)=I
2409 ELSE
2410 JDAHEP(2,I1)=I
2411 ENDIF
2412 140 CONTINUE
2413 DO 150 I=1,NHEP
2414 IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 150
2415 IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I)
2416 150 CONTINUE
2417
2418C...Conversion from standard to PYTHIA, the easy part.
2419 ELSE
2420 IF(NHEP.GT.MSTU(4)) CALL PYERRM(8,
2421 & '(PYHEPC:) no more space in /PYJETS/')
2422 N=MIN(NHEP,MSTU(4))
2423 NKQ=0
2424 KQSUM=0
2425 DO 180 I=1,N
2426 K(I,1)=0
2427 IF(ISTHEP(I).EQ.1) K(I,1)=1
2428 IF(ISTHEP(I).EQ.2) K(I,1)=11
2429 IF(ISTHEP(I).EQ.3) K(I,1)=21
2430 K(I,2)=IDHEP(I)
2431 K(I,3)=JMOHEP(1,I)
2432 K(I,4)=JDAHEP(1,I)
2433 K(I,5)=JDAHEP(2,I)
2434 DO 160 J=1,5
2435 P(I,J)=PHEP(J,I)
2436 160 CONTINUE
2437 DO 170 J=1,4
2438 V(I,J)=VHEP(J,I)
2439 170 CONTINUE
2440 V(I,5)=0D0
2441 IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN
2442 I1=JDAHEP(1,I)
2443 IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))*
2444 & PHEP(5,I)/PHEP(4,I)
2445 ENDIF
2446
2447C...Fill in missing information on colour connection in jet systems.
2448 IF(ISTHEP(I).EQ.1) THEN
2449 KC=PYCOMP(K(I,2))
2450 KQ=0
2451 IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
2452 IF(KQ.NE.0) NKQ=NKQ+1
2453 IF(KQ.NE.2) KQSUM=KQSUM+KQ
2454 IF(KQ.NE.0.AND.KQSUM.NE.0) THEN
2455 K(I,1)=2
2456 ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN
2457 IF(K(I+1,2).EQ.21) K(I,1)=2
2458 ENDIF
2459 ENDIF
2460 180 CONTINUE
2461 IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL PYERRM(8,
2462 & '(PYHEPC:) input parton configuration not colour singlet')
2463 ENDIF
2464
2465 END
2466
2467C*********************************************************************
2468
2469C...PYINIT
2470C...Initializes the generation procedure; finds maxima of the
2471C...differential cross-sections to be used for weighting.
2472
2473 SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN)
2474
2475C...Double precision and integer declarations.
2476 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2477 IMPLICIT INTEGER(I-N)
2478 INTEGER PYK,PYCHGE,PYCOMP
2479C...Commonblocks.
2480 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2481 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2482 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2483 COMMON/PYDAT4/CHAF(500,2)
2484 CHARACTER CHAF*16
2485 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2486 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2487 COMMON/PYINT1/MINT(400),VINT(400)
2488 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2489 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2490 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
2491 &/PYINT1/,/PYINT2/,/PYINT5/
2492C...Local arrays and character variables.
2493 DIMENSION ALAMIN(20),NFIN(20)
2494 CHARACTER*(*) FRAME,BEAM,TARGET
2495 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHLH(2)*6
2496
2497C...Interface to PDFLIB.
2498 COMMON/W50512/QCDL4,QCDL5
2499 SAVE /W50512/
2500 DOUBLE PRECISION VALUE(20),QCDL4,QCDL5
2501 CHARACTER*20 PARM(20)
2502 DATA VALUE/20*0D0/,PARM/20*' '/
2503
2504C...Data:Lambda and n_f values for parton distributions..
2505 DATA ALAMIN/0.177D0,0.239D0,0.247D0,0.2322D0,0.248D0,0.248D0,
2506 &0.192D0,0.326D0,2*0.2D0,0.2D0,0.2D0,0.29D0,0.2D0,0.4D0,5*0.2D0/,
2507 &NFIN/20*4/
2508 DATA CHLH/'lepton','hadron'/
2509
2510C...Reset MINT and VINT arrays. Write headers.
2511 MSTI(53)=0
2512 DO 100 J=1,400
2513 MINT(J)=0
2514 VINT(J)=0D0
2515 100 CONTINUE
2516 IF(MSTU(12).GE.1) CALL PYLIST(0)
2517 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
2518
2519C...Call user process initialization routine.
2520 IF(FRAME(1:1).EQ.'u'.OR.FRAME(1:1).EQ.'U') THEN
2521 MSEL=0
2522 CALL UPINIT
2523 MSEL=0
2524 ENDIF
2525
2526C...Maximum 4 generations; set maximum number of allowed flavours.
2527 MSTP(1)=MIN(4,MSTP(1))
2528 MSTU(114)=MIN(MSTU(114),2*MSTP(1))
2529 MSTP(58)=MIN(MSTP(58),2*MSTP(1))
2530
2531C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
2532 DO 120 I=-20,20
2533 VINT(180+I)=0D0
2534 IA=IABS(I)
2535 IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN
2536 DO 110 J=1,MSTP(1)
2537 IB=2*J-1+MOD(IA,2)
2538 IF(IB.GE.6.AND.MSTP(9).EQ.0) GOTO 110
2539 IPM=(5-ISIGN(1,I))/2
2540 IDC=J+MDCY(IA,2)+2
2541 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)=
2542 & VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2)
2543 110 CONTINUE
2544 ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN
2545 VINT(180+I)=1D0
2546 ENDIF
2547 120 CONTINUE
2548
2549C...Initialize parton distributions: PDFLIB.
2550 IF(MSTP(52).EQ.2) THEN
2551 PARM(1)='NPTYPE'
2552 VALUE(1)=1
2553 PARM(2)='NGROUP'
2554 VALUE(2)=MSTP(51)/1000
2555 PARM(3)='NSET'
2556 VALUE(3)=MOD(MSTP(51),1000)
2557 PARM(4)='TMAS'
2558 VALUE(4)=PMAS(6,1)
2559C.... ALICE
2560 CALL PDFSET_ALICE(PARM,VALUE)
2561 MINT(93)=1000000+MSTP(51)
2562 ENDIF
2563
2564C...Choose Lambda value to use in alpha-strong.
2565 MSTU(111)=MSTP(2)
2566 IF(MSTP(3).GE.2) THEN
2567 ALAM=0.2D0
2568 NF=4
2569 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
2570 ALAM=ALAMIN(MSTP(51))
2571 NF=NFIN(MSTP(51))
2572 ELSEIF(MSTP(52).EQ.2) THEN
2573 ALAM=QCDL4
2574 NF=4
2575 ENDIF
2576 PARP(1)=ALAM
2577 PARP(61)=ALAM
2578 PARP(72)=ALAM
2579 PARU(112)=ALAM
2580 MSTU(112)=NF
2581 IF(MSTP(3).EQ.3) PARJ(81)=ALAM
2582 ENDIF
2583
2584C...Initialize the SUSY generation: couplings, masses,
2585C...decay modes, branching ratios, and so on.
2586 CALL PYMSIN
2587C...Initialize widths and partial widths for resonances.
2588 CALL PYINRE
2589C...Set Z0 mass and width for e+e- routines.
2590 PARJ(123)=PMAS(23,1)
2591 PARJ(124)=PMAS(23,2)
2592
2593C...Identify beam and target particles and frame of process.
2594 CHFRAM=FRAME//' '
2595 CHBEAM=BEAM//' '
2596 CHTARG=TARGET//' '
2597 CALL PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
2598 IF(MINT(65).EQ.1) GOTO 170
2599
2600C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
2601C...For e-gamma allow 2 alternatives.
2602 MINT(121)=1
2603 IF(MSTP(14).EQ.10.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2604 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2605 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
2606 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=6
2607 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2608 & (IABS(MINT(11)).EQ.11.OR.IABS(MINT(12)).EQ.11)) MINT(121)=2
2609 ELSEIF(MSTP(14).EQ.20.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2610 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2611 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
2612 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=9
2613 ELSEIF(MSTP(14).EQ.25.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2614 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2615 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=2
2616 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=4
2617 ELSEIF(MSTP(14).EQ.30.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2618 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2619 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=4
2620 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=13
2621 ENDIF
2622 MINT(123)=MSTP(14)
2623 IF((MSTP(14).EQ.10.OR.MSTP(14).EQ.20.OR.MSTP(14).EQ.25.OR.
2624 &MSTP(14).EQ.30).AND.MSEL.NE.1.AND.MSEL.NE.2) MINT(123)=0
2625 IF(MSTP(14).GE.11.AND.MSTP(14).LE.19) THEN
2626 IF(MSTP(14).EQ.11) MINT(123)=0
2627 IF(MSTP(14).EQ.12.OR.MSTP(14).EQ.14) MINT(123)=5
2628 IF(MSTP(14).EQ.13.OR.MSTP(14).EQ.17) MINT(123)=6
2629 IF(MSTP(14).EQ.15) MINT(123)=2
2630 IF(MSTP(14).EQ.16.OR.MSTP(14).EQ.18) MINT(123)=7
2631 IF(MSTP(14).EQ.19) MINT(123)=3
2632 ELSEIF(MSTP(14).GE.21.AND.MSTP(14).LE.24) THEN
2633 IF(MSTP(14).EQ.21) MINT(123)=0
2634 IF(MSTP(14).EQ.22.OR.MSTP(14).EQ.23) MINT(123)=4
2635 IF(MSTP(14).EQ.24) MINT(123)=1
2636 ELSEIF(MSTP(14).GE.26.AND.MSTP(14).LE.29) THEN
2637 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28) MINT(123)=8
2638 IF(MSTP(14).EQ.27.OR.MSTP(14).EQ.29) MINT(123)=9
2639 ENDIF
2640
2641C...Set up kinematics of process.
2642 CALL PYINKI(0)
2643
2644C...Set up kinematics for photons inside leptons.
2645 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(1,WTGAGA)
2646
2647C...Precalculate flavour selection weights.
2648 CALL PYKFIN
2649
2650C...Loop over gamma-p or gamma-gamma alternatives.
2651 CKIN3=CKIN(3)
2652 MSAV48=0
2653 DO 160 IGA=1,MINT(121)
2654 CKIN(3)=CKIN3
2655 MINT(122)=IGA
2656
2657C...Select partonic subprocesses to be included in the simulation.
2658 CALL PYINPR
2659 MINT(101)=1
2660 MINT(102)=1
2661 MINT(103)=MINT(11)
2662 MINT(104)=MINT(12)
2663
2664C...Count number of subprocesses on.
2665 MINT(48)=0
2666 DO 130 ISUB=1,500
2667 IF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
2668 & MSUB(ISUB).EQ.1.AND.MINT(121).GT.1) THEN
2669 MSUB(ISUB)=0
2670 ELSEIF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
2671 & MSUB(ISUB).EQ.1) THEN
2672 WRITE(MSTU(11),5200) ISUB,CHLH(MINT(41)),CHLH(MINT(42))
2673 STOP
2674 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
2675 WRITE(MSTU(11),5300) ISUB
2676 STOP
2677 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
2678 WRITE(MSTU(11),5400) ISUB
2679 STOP
2680 ELSEIF(MSUB(ISUB).EQ.1) THEN
2681 MINT(48)=MINT(48)+1
2682 ENDIF
2683 130 CONTINUE
2684
2685C...Stop or raise warning flag if no subprocesses on.
2686 IF(MINT(121).EQ.1.AND.MINT(48).EQ.0) THEN
2687 IF(MSTP(127).NE.1) THEN
2688 WRITE(MSTU(11),5500)
2689 STOP
2690 ELSE
2691 WRITE(MSTU(11),5700)
2692 MSTI(53)=1
2693 ENDIF
2694 ENDIF
2695 MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94)
2696 MSAV48=MSAV48+MINT(48)
2697
2698C...Reset variables for cross-section calculation.
2699 DO 150 I=0,500
2700 DO 140 J=1,3
2701 NGEN(I,J)=0
2702 XSEC(I,J)=0D0
2703 140 CONTINUE
2704 150 CONTINUE
2705
2706C...Find parametrized total cross-sections.
2707 CALL PYXTOT
2708 VINT(318)=VINT(317)
2709
2710C...Maxima of differential cross-sections.
2711 IF(MSTP(121).LE.1) CALL PYMAXI
2712
2713C...Initialize possibility of pileup events.
2714 IF(MINT(121).GT.1) MSTP(131)=0
2715 IF(MSTP(131).NE.0) CALL PYPILE(1)
2716
2717C...Initialize multiple interactions with variable impact parameter.
2718 IF(MINT(50).EQ.1.AND.(MINT(49).NE.0.OR.MSTP(131).NE.0).AND.
2719 & MSTP(82).GE.2) CALL PYMULT(1)
2720
2721C...Save results for gamma-p and gamma-gamma alternatives.
2722 IF(MINT(121).GT.1) CALL PYSAVE(1,IGA)
2723 160 CONTINUE
2724
2725C...Initialization finished.
2726 IF(MSAV48.EQ.0) THEN
2727 IF(MSTP(127).NE.1) THEN
2728 WRITE(MSTU(11),5500)
2729 STOP
2730 ELSE
2731 WRITE(MSTU(11),5700)
2732 MSTI(53)=1
2733 ENDIF
2734 ENDIF
2735 170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600)
2736
2737C...Formats for initialization information.
2738 5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ',
2739 &'routines',1X,17('*'))
2740 5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,
2741 &'-',A6,' interactions.'/1X,'Execution stopped!')
2742 5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/
2743 &1X,'Execution stopped!')
2744 5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/
2745 &1X,'Execution stopped!')
2746 5500 FORMAT(1X,'Error: no subprocess switched on.'/
2747 &1X,'Execution stopped.')
2748 5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X,
2749 &22('*'))
2750 5700 FORMAT(1X,'Error: no subprocess switched on.'/
2751 &1X,'Execution will stop if you try to generate events.')
2752
2753 RETURN
2754 END
2755
2756C*********************************************************************
2757
2758C...PYEVNT
2759C...Administers the generation of a high-pT event via calls to
2760C...a number of subroutines.
2761
2762 SUBROUTINE PYEVNT
2763
2764C...Double precision and integer declarations.
2765 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2766 IMPLICIT INTEGER(I-N)
2767 INTEGER PYK,PYCHGE,PYCOMP
2768C...Commonblocks.
2769 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2770 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2771 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2772 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2773 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2774 COMMON/PYINT1/MINT(400),VINT(400)
2775 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2776 COMMON/PYINT4/MWID(500),WIDS(500,5)
2777 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2778 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,
2779 &/PYINT2/,/PYINT4/,/PYINT5/
2780C...Local array.
2781 DIMENSION VTX(4)
2782
2783C...Stop if no subprocesses on.
2784 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
2785 WRITE(MSTU(11),5100)
2786 STOP
2787 ENDIF
2788
2789C...Initial values for some counters.
2790 N=0
2791 MINT(5)=MINT(5)+1
2792 MINT(7)=0
2793 MINT(8)=0
2794 MINT(83)=0
2795 MINT(84)=MSTP(126)
2796 MSTU(24)=0
2797 MSTU70=0
2798 MSTJ14=MSTJ(14)
2799
2800C...If variable energies: redo incoming kinematics and cross-section.
2801 MSTI(61)=0
2802 IF(MSTP(171).EQ.1) THEN
2803 CALL PYINKI(1)
2804 IF(MSTI(61).EQ.1) THEN
2805 MINT(5)=MINT(5)-1
2806 RETURN
2807 ENDIF
2808 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
2809 CALL PYXTOT
2810 ENDIF
2811
2812C...Loop over number of pileup events; check space left.
2813 IF(MSTP(131).LE.0) THEN
2814 NPILE=1
2815 ELSE
2816 CALL PYPILE(2)
2817 NPILE=MINT(81)
2818 ENDIF
2819 DO 250 IPILE=1,NPILE
2820 IF(MINT(84)+100.GE.MSTU(4)) THEN
2821 CALL PYERRM(11,
2822 & '(PYEVNT:) no more space in PYJETS for pileup events')
2823 IF(MSTU(21).GE.1) GOTO 260
2824 ENDIF
2825 MINT(82)=IPILE
2826
2827C...Generate variables of hard scattering.
2828 MINT(51)=0
2829 MSTI(52)=0
2830 100 CONTINUE
2831 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
2832 MINT(31)=0
2833 MINT(51)=0
2834 MINT(57)=0
2835 CALL PYRAND
2836 IF(MSTI(61).EQ.1) THEN
2837 MINT(5)=MINT(5)-1
2838 RETURN
2839 ENDIF
2840 IF(MINT(51).EQ.2) RETURN
2841 ISUB=MINT(1)
2842 IF(MSTP(111).EQ.-1) GOTO 240
2843
2844 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
2845C...Hard scattering (including low-pT):
2846C...reconstruct kinematics and colour flow of hard scattering.
2847 MINT31=MINT(31)
2848 110 MINT(31)=MINT31
2849 MINT(51)=0
2850 CALL PYSCAT
2851 IF(MINT(51).EQ.1) GOTO 100
2852 IPU1=MINT(84)+1
2853 IPU2=MINT(84)+2
2854 IF(ISUB.EQ.95) GOTO 120
2855
2856C...Showering of initial state partons (optional).
2857 NFIN=N
2858 ALAMSV=PARJ(81)
2859 PARJ(81)=PARP(72)
2860 IF(MSTP(61).GE.1.AND.MINT(47).GE.2) CALL PYSSPA(IPU1,IPU2)
2861 PARJ(81)=ALAMSV
2862 IF(MINT(51).EQ.1) GOTO 100
2863
2864C...Showering of final state partons (optional).
2865 ALAMSV=PARJ(81)
2866 PARJ(81)=PARP(72)
2867 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.2.AND.ISET(ISUB).LE.10)
2868 & THEN
2869 IPU3=MINT(84)+3
2870 IPU4=MINT(84)+4
2871 IF(ISET(ISUB).EQ.5) IPU4=-3
2872 QMAX=VINT(55)
2873 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
2874 CALL PYSHOW(IPU3,IPU4,QMAX)
2875 ELSEIF(ISET(ISUB).EQ.11) THEN
2876 CALL PYADSH(NFIN)
2877 ENDIF
2878 PARJ(81)=ALAMSV
2879
2880C...Decay of final state resonances.
2881 MINT(32)=0
2882 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) CALL PYRESD(0)
2883 IF(MINT(51).EQ.1) GOTO 100
2884 MINT(52)=N
2885
2886C...Multiple interactions.
2887 IF(MSTP(81).GE.1.AND.MINT(50).EQ.1) CALL PYMULT(6)
2888 MINT(53)=N
2889
2890C...Hadron remnants and primordial kT.
2891 120 CALL PYREMN(IPU1,IPU2)
2892 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO 110
2893 IF(MINT(51).EQ.1) GOTO 100
2894
2895 ELSEIF(ISUB.NE.99) THEN
2896C...Diffractive and elastic scattering.
2897 CALL PYDIFF
2898
2899 ELSE
2900C...DIS scattering (photon flux external).
2901 CALL PYDISG
2902 IF(MINT(51).EQ.1) GOTO 100
2903 ENDIF
2904
2905C...Check that no odd resonance left undecayed.
2906 IF(MSTP(111).GE.1) THEN
2907 NFIX=N
2908 DO 130 I=MINT(84)+1,NFIX
2909 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
2910 & K(I,2).NE.22) THEN
2911 KCA=PYCOMP(K(I,2))
2912 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
2913 CALL PYRESD(I)
2914 IF(MINT(51).EQ.1) GOTO 100
2915 ENDIF
2916 ENDIF
2917 130 CONTINUE
2918 ENDIF
2919
2920C...Boost hadronic subsystem to overall rest frame.
2921C..(Only relevant when photon inside lepton beam.)
2922 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
2923
2924C...Recalculate energies from momenta and masses (if desired).
2925 IF(MSTP(113).GE.1) THEN
2926 DO 140 I=MINT(83)+1,N
2927 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
2928 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
2929 140 CONTINUE
2930 NRECAL=N
2931 ENDIF
2932
2933C...Rearrange partons along strings, check invariant mass cuts.
2934 MSTU(28)=0
2935 IF(MSTP(111).LE.0) MSTJ(14)=-1
2936 CALL PYPREP(MINT(84)+1)
2937 MSTJ(14)=MSTJ14
2938 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
2939 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
2940 DO 170 I=MINT(84)+1,N
2941 IF(K(I,2).EQ.94) THEN
2942 DO 160 I1=I+1,MIN(N,I+3)
2943 IF(K(I1,3).EQ.I) THEN
2944 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
2945 IF(K(I1,3).EQ.0) THEN
2946 DO 150 II=MINT(84)+1,I-1
2947 IF(K(II,2).EQ.K(I1,2)) THEN
2948 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
2949 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
2950 ENDIF
2951 150 CONTINUE
2952 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
2953 ENDIF
2954 ENDIF
2955 160 CONTINUE
2956 ENDIF
2957 170 CONTINUE
2958 CALL PYEDIT(12)
2959 CALL PYEDIT(14)
2960 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
2961 IF(MSTP(125).EQ.0) MINT(4)=0
2962 DO 190 I=MINT(83)+1,N
2963 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
2964 DO 180 I1=I+1,N
2965 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
2966 IF(K(I1,3).EQ.I) K(I,5)=I1
2967 180 CONTINUE
2968 ENDIF
2969 190 CONTINUE
2970 ENDIF
2971
2972C...Introduce separators between sections in PYLIST event listing.
2973 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
2974 MSTU70=1
2975 MSTU(71)=N
2976 ELSEIF(IPILE.EQ.1) THEN
2977 MSTU70=3
2978 MSTU(71)=2
2979 MSTU(72)=MINT(4)
2980 MSTU(73)=N
2981 ENDIF
2982
2983C...Go back to lab frame (needed for vertices, also in fragmentation).
2984 CALL PYFRAM(1)
2985
2986C...Set nonvanishing production vertex (optional).
2987 IF(MSTP(151).EQ.1) THEN
2988 DO 200 J=1,4
2989 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
2990 & SIN(PARU(2)*PYR(0))
2991 200 CONTINUE
2992 DO 220 I=MINT(83)+1,N
2993 DO 210 J=1,4
2994 V(I,J)=V(I,J)+VTX(J)
2995 210 CONTINUE
2996 220 CONTINUE
2997 ENDIF
2998
2999C...Perform hadronization (if desired).
3000 IF(MSTP(111).GE.1) THEN
3001 CALL PYEXEC
3002 IF(MSTU(24).NE.0) GOTO 100
3003 ENDIF
3004 IF(MSTP(113).GE.1) THEN
3005 DO 230 I=NRECAL,N
3006 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3007 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3008 230 CONTINUE
3009 ENDIF
3010 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3011
3012C...Store event information and calculate Monte Carlo estimates of
3013C...subprocess cross-sections.
3014 240 IF(IPILE.EQ.1) CALL PYDOCU
3015
3016C...Set counters for current pileup event and loop to next one.
3017 MSTI(41)=IPILE
3018 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3019 IF(MSTU70.LT.10) THEN
3020 MSTU70=MSTU70+1
3021 MSTU(70+MSTU70)=N
3022 ENDIF
3023 MINT(83)=N
3024 MINT(84)=N+MSTP(126)
3025 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
3026 250 CONTINUE
3027
3028C...Generic information on pileup events. Reconstruct missing history.
3029 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
3030 PARI(91)=VINT(132)
3031 PARI(92)=VINT(133)
3032 PARI(93)=VINT(134)
3033 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
3034 ENDIF
3035 CALL PYEDIT(16)
3036
3037C...Transform to the desired coordinate frame.
3038 260 CALL PYFRAM(MSTP(124))
3039 MSTU(70)=MSTU70
3040 PARU(21)=VINT(1)
3041
3042C...Error messages
3043 5100 FORMAT(1X,'Error: no subprocess switched on.'/
3044 &1X,'Execution stopped.')
3045
3046 RETURN
3047 END
3048
3049C***********************************************************************
3050
3051C...PYSTAT
3052C...Prints out information about cross-sections, decay widths, branching
3053C...ratios, kinematical limits, status codes and parameter values.
3054
3055 SUBROUTINE PYSTAT(MSTAT)
3056
3057C...Double precision and integer declarations.
3058 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3059 IMPLICIT INTEGER(I-N)
3060 INTEGER PYK,PYCHGE,PYCOMP
3061C...Parameter statement to help give large particle numbers.
3062 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
3063 &KEXCIT=4000000,KDIMEN=5000000)
3064 PARAMETER (EPS=1D-3)
3065C...Commonblocks.
3066 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3067 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3068 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3069 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3070 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3071 COMMON/PYINT1/MINT(400),VINT(400)
3072 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3073 COMMON/PYINT4/MWID(500),WIDS(500,5)
3074 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3075 COMMON/PYINT6/PROC(0:500)
3076 CHARACTER PROC*28, CHTMP*16
3077 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
3078 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
3079 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
3080 &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/,/PYMSRV/
3081C...Local arrays, character variables and data.
3082 DIMENSION WDTP(0:300),WDTE(0:300,0:5),NMODES(0:20),PBRAT(10)
3083 CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16,
3084 &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28,
3085 &PROGG9(13)*28,PROGG4(4)*28,PROGG2(2)*28,PROGP4(4)*28
3086 CHARACTER*24 CHD0, CHDC(10)
3087 CHARACTER*6 DNAME(3)
3088 DATA PROGA/
3089 &'VMD/hadron * VMD ','VMD/hadron * direct ',
3090 &'VMD/hadron * anomalous ','direct * direct ',
3091 &'direct * anomalous ','anomalous * anomalous '/
3092 DATA DISGA/'e * VMD','e * anomalous'/
3093 DATA PROGG9/
3094 &'direct * direct ','direct * VMD ',
3095 &'direct * anomalous ','VMD * direct ',
3096 &'VMD * VMD ','VMD * anomalous ',
3097 &'anomalous * direct ','anomalous * VMD ',
3098 &'anomalous * anomalous ','DIS * VMD ',
3099 &'DIS * anomalous ','VMD * DIS ',
3100 &'anomalous * DIS '/
3101 DATA PROGG4/
3102 &'direct * direct ','direct * resolved ',
3103 &'resolved * direct ','resolved * resolved '/
3104 DATA PROGG2/
3105 &'direct * hadron ','resolved * hadron '/
3106 DATA PROGP4/
3107 &'VMD * hadron ','direct * hadron ',
3108 &'anomalous * hadron ','DIS * hadron '/
3109 DATA STATE/'----','off ','on ','on/+','on/-','on/1','on/2'/,
3110 &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
3111 &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ',
3112 &' y*_small ',' eta*_large ',' eta*_small ',
3113 &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ',
3114 &' x_2 ',' x_F ',' cos(theta_hard) ',
3115 &'m''_hard (GeV/c^2) ',' tau ',' y* ',
3116 &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ',
3117 &' tau'' '/
3118 DATA DNAME /'q ','lepton','nu '/
3119
3120C...Cross-sections.
3121 IF(MSTAT.LE.1) THEN
3122 IF(MINT(121).GT.1) CALL PYSAVE(5,0)
3123 WRITE(MSTU(11),5000)
3124 WRITE(MSTU(11),5100)
3125 WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)
3126 DO 100 I=1,500
3127 IF(MSUB(I).NE.1) GOTO 100
3128 WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)
3129 100 CONTINUE
3130 IF(MINT(121).GT.1) THEN
3131 WRITE(MSTU(11),5300)
3132 DO 110 IGA=1,MINT(121)
3133 CALL PYSAVE(3,IGA)
3134 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
3135 WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1),
3136 & XSEC(0,3)
3137 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
3138 WRITE(MSTU(11),5200) IGA,PROGG9(IGA),NGEN(0,3),NGEN(0,1),
3139 & XSEC(0,3)
3140 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.30) THEN
3141 WRITE(MSTU(11),5200) IGA,PROGP4(IGA),NGEN(0,3),NGEN(0,1),
3142 & XSEC(0,3)
3143 ELSEIF(MINT(121).EQ.4) THEN
3144 WRITE(MSTU(11),5200) IGA,PROGG4(IGA),NGEN(0,3),NGEN(0,1),
3145 & XSEC(0,3)
3146 ELSEIF(MINT(121).EQ.2) THEN
3147 WRITE(MSTU(11),5200) IGA,PROGG2(IGA),NGEN(0,3),NGEN(0,1),
3148 & XSEC(0,3)
3149 ELSE
3150 WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1),
3151 & XSEC(0,3)
3152 ENDIF
3153 110 CONTINUE
3154 CALL PYSAVE(5,0)
3155 ENDIF
3156 WRITE(MSTU(11),5400) 1D0-DBLE(NGEN(0,3))/
3157 & MAX(1D0,DBLE(NGEN(0,2)))
3158
3159C...Decay widths and branching ratios.
3160 ELSEIF(MSTAT.EQ.2) THEN
3161 WRITE(MSTU(11),5500)
3162 WRITE(MSTU(11),5600)
3163 DO 140 KC=1,500
3164 KF=KCHG(KC,4)
3165 CALL PYNAME(KF,CHKF)
3166 IOFF=0
3167 IF(KC.LE.22) THEN
3168 IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140
3169 IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140
3170 IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1
3171 IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1
3172 IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1
3173 ELSE
3174 IF(MWID(KC).LE.0) GOTO 140
3175 IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR.
3176 & KF/KSUSY1.EQ.2)) GOTO 140
3177 ENDIF
3178C...Off-shell branchings.
3179 IF(IOFF.EQ.1) THEN
3180 NGP=0
3181 IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2
3182 IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10),
3183 & PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0
3184 DO 120 J=1,MDCY(KC,3)
3185 IDC=J+MDCY(KC,2)-1
3186 NGP1=0
3187 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
3188 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
3189 NGP2=0
3190 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
3191 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
3192 CALL PYNAME(KFDP(IDC,1),CHD1)
3193 CALL PYNAME(KFDP(IDC,2),CHD2)
3194 IF(KFDP(IDC,3).EQ.0) THEN
3195 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
3196 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10),
3197 & CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
3198 ELSE
3199 CALL PYNAME(KFDP(IDC,3),CHD3)
3200 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
3201 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10),
3202 & CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
3203 ENDIF
3204 120 CONTINUE
3205C...On-shell decays.
3206 ELSE
3207 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
3208 BRFIN=1D0
3209 IF(WDTE(0,0).LE.0D0) BRFIN=0D0
3210 WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0,
3211 & STATE(MDCY(KC,1)),BRFIN
3212 DO 130 J=1,MDCY(KC,3)
3213 IDC=J+MDCY(KC,2)-1
3214 NGP1=0
3215 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
3216 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
3217 NGP2=0
3218 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
3219 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
3220 BRFIN=0D0
3221 IF(WDTE(0,0).GT.0D0) BRFIN=WDTE(J,0)/WDTE(0,0)
3222 CALL PYNAME(KFDP(IDC,1),CHD1)
3223 CALL PYNAME(KFDP(IDC,2),CHD2)
3224 IF(KFDP(IDC,3).EQ.0) THEN
3225 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
3226 & WRITE(MSTU(11),5800) IDC,CHD1(1:10),
3227 & CHD2(1:10),WDTP(J),WDTP(J)/WDTP(0),
3228 & STATE(MDME(IDC,1)),BRFIN
3229 ELSE
3230 CALL PYNAME(KFDP(IDC,3),CHD3)
3231 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
3232 & WRITE(MSTU(11),5900) IDC,CHD1(1:10),
3233 & CHD2(1:10),CHD3(1:10),WDTP(J),WDTP(J)/WDTP(0),
3234 & STATE(MDME(IDC,1)),BRFIN
3235 ENDIF
3236 130 CONTINUE
3237 ENDIF
3238 140 CONTINUE
3239 WRITE(MSTU(11),6000)
3240
3241C...Allowed incoming partons/particles at hard interaction.
3242 ELSEIF(MSTAT.EQ.3) THEN
3243 WRITE(MSTU(11),6100)
3244 CALL PYNAME(MINT(11),CHAU)
3245 CHIN(1)=CHAU(1:12)
3246 CALL PYNAME(MINT(12),CHAU)
3247 CHIN(2)=CHAU(1:12)
3248 WRITE(MSTU(11),6200) CHIN(1),CHIN(2)
3249 DO 150 I=-20,22
3250 IF(I.EQ.0) GOTO 150
3251 IA=IABS(I)
3252 IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150
3253 IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150
3254 CALL PYNAME(I,CHAU)
3255 WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU,
3256 & STATE(KFIN(2,I))
3257 150 CONTINUE
3258 WRITE(MSTU(11),6400)
3259
3260C...User-defined limits on kinematical variables.
3261 ELSEIF(MSTAT.EQ.4) THEN
3262 WRITE(MSTU(11),6500)
3263 WRITE(MSTU(11),6600)
3264 SHRMAX=CKIN(2)
3265 IF(SHRMAX.LT.0D0) SHRMAX=VINT(1)
3266 WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX
3267 PTHMIN=MAX(CKIN(3),CKIN(5))
3268 PTHMAX=CKIN(4)
3269 IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX
3270 WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX
3271 WRITE(MSTU(11),6900) CHKIN(3),CKIN(6)
3272 DO 160 I=4,14
3273 WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I)
3274 160 CONTINUE
3275 SPRMAX=CKIN(32)
3276 IF(SPRMAX.LT.0D0) SPRMAX=VINT(1)
3277 WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX
3278 WRITE(MSTU(11),7000)
3279
3280C...Status codes and parameter values.
3281 ELSEIF(MSTAT.EQ.5) THEN
3282 WRITE(MSTU(11),7100)
3283 WRITE(MSTU(11),7200)
3284 DO 170 I=1,100
3285 WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
3286 & PARP(100+I)
3287 170 CONTINUE
3288
3289C...List of all processes implemented in the program.
3290 ELSEIF(MSTAT.EQ.6) THEN
3291 WRITE(MSTU(11),7400)
3292 WRITE(MSTU(11),7500)
3293 DO 180 I=1,500
3294 IF(ISET(I).LT.0) GOTO 180
3295 WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2)
3296 180 CONTINUE
3297 WRITE(MSTU(11),7700)
3298
3299 ELSEIF(MSTAT.EQ.7) THEN
3300 WRITE (MSTU(11),8000)
3301 NMODES(0)=0
3302 NMODES(10)=0
3303 NMODES(9)=0
3304 DO 290 ILR=1,2
3305 DO 280 KFSM=1,16
3306 KFSUSY=ILR*KSUSY1+KFSM
3307 NRVDC=0
3308C...SDOWN DECAYS
3309 IF (KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5) THEN
3310 NRVDC=2
3311 DO 190 I=1,NRVDC
3312 PBRAT(I)=0D0
3313 NMODES(I)=0
3314 190 CONTINUE
3315 CALL PYNAME(KFSUSY,CHTMP)
3316 CHD0=CHTMP//' '
3317 CHDC(1)=DNAME(3) // ' + ' // DNAME(1)
3318 CHDC(2)=DNAME(2) // ' + ' // DNAME(1)
3319 KC=PYCOMP(KFSUSY)
3320 DO 200 J=1,MDCY(KC,3)
3321 IDC=J+MDCY(KC,2)-1
3322 ID1=IABS(KFDP(IDC,1))
3323 ID2=IABS(KFDP(IDC,2))
3324 IF (KFDP(IDC,3).EQ.0) THEN
3325 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
3326 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
3327 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3328 NMODES(1)=NMODES(1)+1
3329 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3330 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3331 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3332 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6)) THEN
3333 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3334 NMODES(2)=NMODES(2)+1
3335 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3336 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3337 ENDIF
3338 ENDIF
3339 200 CONTINUE
3340 ENDIF
3341C...SUP DECAYS
3342 IF (KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6) THEN
3343 NRVDC=1
3344 DO 210 I=1,NRVDC
3345 NMODES(I)=0
3346 PBRAT(I)=0D0
3347 210 CONTINUE
3348 CALL PYNAME(KFSUSY,CHTMP)
3349 CHD0=CHTMP//' '
3350 CHDC(1)=DNAME(2) // ' + ' // DNAME(1)
3351 KC=PYCOMP(KFSUSY)
3352 DO 220 J=1,MDCY(KC,3)
3353 IDC=J+MDCY(KC,2)-1
3354 ID1=IABS(KFDP(IDC,1))
3355 ID2=IABS(KFDP(IDC,2))
3356 IF (KFDP(IDC,3).EQ.0) THEN
3357 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
3358 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
3359 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3360 NMODES(1)=NMODES(1)+1
3361 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3362 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3363 ENDIF
3364 ENDIF
3365 220 CONTINUE
3366 ENDIF
3367C...SLEPTON DECAYS
3368 IF (KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15) THEN
3369 NRVDC=2
3370 DO 230 I=1,NRVDC
3371 PBRAT(I)=0D0
3372 NMODES(I)=0
3373 230 CONTINUE
3374 CALL PYNAME(KFSUSY,CHTMP)
3375 CHD0=CHTMP//' '
3376 CHDC(1)=DNAME(3) // ' + ' // DNAME(2)
3377 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
3378 KC=PYCOMP(KFSUSY)
3379 DO 240 J=1,MDCY(KC,3)
3380 IDC=J+MDCY(KC,2)-1
3381 ID1=IABS(KFDP(IDC,1))
3382 ID2=IABS(KFDP(IDC,2))
3383 IF (KFDP(IDC,3).EQ.0) THEN
3384 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
3385 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
3386 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3387 NMODES(1)=NMODES(1)+1
3388 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3389 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3390 ENDIF
3391 IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND.(ID2
3392 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
3393 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3394 NMODES(2)=NMODES(2)+1
3395 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3396 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3397 ENDIF
3398 ENDIF
3399 240 CONTINUE
3400 ENDIF
3401C...SNEUTRINO DECAYS
3402 IF ((KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16).AND.ILR.EQ.1)
3403 & THEN
3404 NRVDC=2
3405 DO 250 I=1,NRVDC
3406 PBRAT(I)=0D0
3407 NMODES(I)=0
3408 250 CONTINUE
3409 CALL PYNAME(KFSUSY,CHTMP)
3410 CHD0=CHTMP//' '
3411 CHDC(1)=DNAME(2) // ' + ' // DNAME(2)
3412 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
3413 KC=PYCOMP(KFSUSY)
3414 DO 260 J=1,MDCY(KC,3)
3415 IDC=J+MDCY(KC,2)-1
3416 ID1=IABS(KFDP(IDC,1))
3417 ID2=IABS(KFDP(IDC,2))
3418 IF (KFDP(IDC,3).EQ.0) THEN
3419 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
3420 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
3421 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3422 NMODES(1)=NMODES(1)+1
3423 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3424 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3425 ENDIF
3426 IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
3427 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
3428 NMODES(2)=NMODES(2)+1
3429 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3430 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3431 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3432 ENDIF
3433 ENDIF
3434 260 CONTINUE
3435 ENDIF
3436 IF (NRVDC.NE.0) THEN
3437 DO 270 I=1,NRVDC
3438 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
3439 NMODES(0)=NMODES(0)+NMODES(I)
3440 270 CONTINUE
3441 ENDIF
3442 280 CONTINUE
3443 290 CONTINUE
3444 DO 350 KFSM=22,37
3445 KFSUSY=KSUSY1+KFSM
3446 NRVDC=0
3447C...NEUTRALINO DECAYS
3448 IF (KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
3449 NRVDC=3
3450 DO 300 I=1,NRVDC
3451 PBRAT(I)=0D0
3452 NMODES(I)=0
3453 300 CONTINUE
3454 CALL PYNAME(KFSUSY,CHTMP)
3455 CHD0=CHTMP//' '
3456 CHDC(1)=DNAME(3) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
3457 CHDC(2)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3458 CHDC(3)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3459 KC=PYCOMP(KFSUSY)
3460 DO 310 J=1,MDCY(KC,3)
3461 IDC=J+MDCY(KC,2)-1
3462 ID1=IABS(KFDP(IDC,1))
3463 ID2=IABS(KFDP(IDC,2))
3464 ID3=IABS(KFDP(IDC,3))
3465 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
3466 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.11.OR
3467 & .ID3.EQ.13.OR.ID3.EQ.15)) THEN
3468 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3469 NMODES(1)=NMODES(1)+1
3470 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3471 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3472 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
3473 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
3474 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3475 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3476 NMODES(2)=NMODES(2)+1
3477 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3478 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3479 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3480 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
3481 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3482 PBRAT(3)=PBRAT(3)+BRAT(IDC)
3483 NMODES(3)=NMODES(3)+1
3484 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3485 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3486 ENDIF
3487 310 CONTINUE
3488 ENDIF
3489C...CHARGINO DECAYS
3490 IF (KFSM.EQ.24.OR.KFSM.EQ.37) THEN
3491 NRVDC=4
3492 DO 320 I=1,NRVDC
3493 PBRAT(I)=0D0
3494 NMODES(I)=0
3495 320 CONTINUE
3496 CALL PYNAME(KFSUSY,CHTMP)
3497 CHD0=CHTMP//' '
3498 CHDC(1)=DNAME(3) // ' + ' // DNAME(3) // ' + ' // DNAME(2)
3499 CHDC(2)=DNAME(2) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
3500 CHDC(3)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3501 CHDC(4)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3502 KC=PYCOMP(KFSUSY)
3503 DO 330 J=1,MDCY(KC,3)
3504 IDC=J+MDCY(KC,2)-1
3505 ID1=IABS(KFDP(IDC,1))
3506 ID2=IABS(KFDP(IDC,2))
3507 ID3=IABS(KFDP(IDC,3))
3508 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
3509 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.12.OR
3510 & .ID3.EQ.14.OR.ID3.EQ.16)) THEN
3511 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3512 NMODES(1)=NMODES(1)+1
3513 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3514 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3515 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
3516 & .(ID2.EQ.12.OR.ID2.EQ.14.OR.ID2.EQ.16).AND.(ID3.EQ
3517 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
3518 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3519 NMODES(1)=NMODES(1)+1
3520 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3521 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3522 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3523 & .(ID2.EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ
3524 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
3525 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3526 NMODES(2)=NMODES(2)+1
3527 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3528 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3529 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
3530 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
3531 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
3532 PBRAT(3)=PBRAT(3)+BRAT(IDC)
3533 NMODES(3)=NMODES(3)+1
3534 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3535 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3536 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
3537 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
3538 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3539 PBRAT(3)=PBRAT(3)+BRAT(IDC)
3540 NMODES(3)=NMODES(3)+1
3541 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3542 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3543 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3544 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
3545 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
3546 PBRAT(4)=PBRAT(4)+BRAT(IDC)
3547 NMODES(4)=NMODES(4)+1
3548 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3549 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3550 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3551 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
3552 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3553 PBRAT(4)=PBRAT(4)+BRAT(IDC)
3554 NMODES(4)=NMODES(4)+1
3555 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3556 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3557 ENDIF
3558 330 CONTINUE
3559 ENDIF
3560 IF (NRVDC.NE.0) THEN
3561 DO 340 I=1,NRVDC
3562 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
3563 NMODES(0)=NMODES(0)+NMODES(I)
3564 340 CONTINUE
3565 ENDIF
3566 350 CONTINUE
3567 WRITE (MSTU(11),8100) NMODES(0), NMODES(10), NMODES(9)
3568
3569 IF (IMSS(51).GE.1.OR.IMSS(52).GE.1) THEN
3570 WRITE (MSTU(11),8500)
3571 DO 380 IRV=1,3
3572 DO 370 JRV=1,3
3573 DO 360 KRV=1,3
3574 WRITE (MSTU(11),8700) IRV,JRV,KRV,RVLAM(IRV,JRV,KRV)
3575 & ,RVLAMP(IRV,JRV,KRV), 0D0
3576 360 CONTINUE
3577 370 CONTINUE
3578 380 CONTINUE
3579 WRITE (MSTU(11),8600)
3580 ENDIF
3581
3582
3583 ENDIF
3584
3585C...Formats for printouts.
3586 5000 FORMAT('1',9('*'),1X,'PYSTAT: Statistics on Number of ',
3587 &'Events and Cross-sections',1X,9('*'))
3588 5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
3589 &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
3590 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
3591 &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
3592 &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
3593 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
3594 &'I',12X,'I')
3595 5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
3596 &D10.3,1X,'I')
3597 5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/
3598 &1X,'I',34X,'I',28X,'I',12X,'I')
3599 5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
3600 &1X,'********* Fraction of events that fail fragmentation ',
3601 &'cuts =',1X,F8.5,' *********'/)
3602 5500 FORMAT('1',27('*'),1X,'PYSTAT: Decay Widths and Branching ',
3603 &'Ratios',1X,27('*'))
3604 5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
3605 &1X,'I',5X,'Mother --> Branching/Decay Channel',8X,'I',1X,
3606 &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,
3607 &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
3608 &1X,98('='))
3609 5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
3610 &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X,
3611 &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I')
3612 5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X,
3613 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
3614 &1P,D10.3,0P,1X,'I')
3615 5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X,
3616 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
3617 &1P,D10.3,0P,1X,'I')
3618 6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('='))
3619 6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
3620 &'Particles at Hard Interaction',1X,7('*'))
3621 6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
3622 &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X,
3623 &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X,
3624 &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X,
3625 &78('=')/1X,'I',38X,'I',37X,'I')
3626 6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I')
3627 6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
3628 6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
3629 &'Kinematical Variables',1X,12('*'))
3630 6600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
3631 6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P,
3632 &16X,'I')
3633 6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A,
3634 &1X,'<',1X,1P,D10.3,0P,16X,'I')
3635 6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I')
3636 7000 FORMAT(1X,'I',76X,'I'/1X,78('='))
3637 7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
3638 &'Parameter Values',1X,12('*'))
3639 7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
3640 &'PARP(I)'/)
3641 7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3)
3642 7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes',
3643 &1X,13('*'))
3644 7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X,
3645 &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X,
3646 &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I')
3647 7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I')
3648 7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('='))
3649 8000 FORMAT(1X/ 1X/
3650 & 17X,'Sums over R-Violating branching ratios',1X/ 1X
3651 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I'/1X,'I',4X
3652 & ,'Mother --> Sum over final state flavours',4X,'I',2X
3653 & ,'BR(sum)',2X,'I',2X,'N',2X,'I'/1X,'I',50X,'I',11X,'I',5X,'I'
3654 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I')
3655 8100 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I'/1X,70('=')/1X,'I',1X
3656 & ,'Total number of R-Violating modes :',3X,I5,24X,'I'/
3657 & 1X,'I',1X,'Total number with non-vanishing BR :',2X,I5,24X
3658 & ,'I'/1X,'I',1X,'Total number with BR > 0.001 :',8X,I5,24X,'I'
3659 & /1X,70('='))
3660 8200 FORMAT(1X,'I',1X,A9,1X,'-->',1X,A24,11X,
3661 & 'I',2X,1P,D8.2,0P,1X,'I',2X,I2,1X,'I')
3662 8300 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I')
3663 8500 FORMAT(1X/ 1X/
3664 & 1X,'R-Violating couplings',1X/ 1X /
3665 & 1X,55('=')/
3666 & 1X,'I',1X,'IJK',1X,'I',2X,'LAMBDA(IJK)',2X,'I',2X
3667 & ,'LAMBDA''(IJK)',1X,'I',1X,"LAMBDA''(IJK)",1X,'I'/1X,'I',5X
3668 & ,'I',15X,'I',15X,'I',15X,'I')
3669 8600 FORMAT(1X,55('='))
3670 8700 FORMAT(1X,'I',1X,I1,I1,I1,1X,'I',1X,1P,D13.3,0P,1X,'I',1X,1P
3671 & ,D13.3,0P,1X,'I',1X,1P,D13.3,0P,1X,'I')
3672
3673 RETURN
3674 END
3675
3676C*********************************************************************
3677
3678C...PYINRE
3679C...Calculates full and effective widths of gauge bosons, stores
3680C...masses and widths, rescales coefficients to be used for
3681C...resonance production generation.
3682
3683 SUBROUTINE PYINRE
3684
3685C...Double precision and integer declarations.
3686 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3687 IMPLICIT INTEGER(I-N)
3688 INTEGER PYK,PYCHGE,PYCOMP
3689C...Parameter statement to help give large particle numbers.
3690 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
3691 &KEXCIT=4000000,KDIMEN=5000000)
3692C...Commonblocks.
3693 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3694 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3695 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3696 COMMON/PYDAT4/CHAF(500,2)
3697 CHARACTER CHAF*16
3698 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3699 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3700 COMMON/PYINT1/MINT(400),VINT(400)
3701 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3702 COMMON/PYINT4/MWID(500),WIDS(500,5)
3703 COMMON/PYINT6/PROC(0:500)
3704 CHARACTER PROC*28
3705 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
3706 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
3707 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/
3708C...Local arrays and data.
3709 DIMENSION WDTP(0:300),WDTE(0:300,0:5),WDTPM(0:300),
3710 &WDTEM(0:300,0:5),KCORD(500),PMORD(500)
3711
3712C...Born level couplings in MSSM Higgs doublet sector.
3713 XW=PARU(102)
3714 XWV=XW
3715 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
3716 XW1=1D0-XW
3717 IF(MSTP(4).EQ.2) THEN
3718 TANBE=PARU(141)
3719 RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2
3720 SQMZ=PMAS(23,1)**2
3721 SQMW=PMAS(24,1)**2
3722 SQMH=PMAS(25,1)**2
3723 SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH)
3724 SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE))
3725 SQMHC=SQMA+SQMW
3726 IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN
3727 WRITE(MSTU(11),5000)
3728 STOP
3729 ENDIF
3730 PMAS(35,1)=SQRT(SQMHP)
3731 PMAS(36,1)=SQRT(SQMA)
3732 PMAS(37,1)=SQRT(SQMHC)
3733 ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)*
3734 & (SQMA-SQMZ)))
3735 BESU=ATAN(TANBE)
3736 PARU(142)=1D0
3737 PARU(143)=1D0
3738 PARU(161)=-SIN(ALSU)/COS(BESU)
3739 PARU(162)=COS(ALSU)/SIN(BESU)
3740 PARU(163)=PARU(161)
3741 PARU(164)=SIN(BESU-ALSU)
3742 PARU(165)=PARU(164)
3743 PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW
3744 PARU(171)=COS(ALSU)/COS(BESU)
3745 PARU(172)=SIN(ALSU)/SIN(BESU)
3746 PARU(173)=PARU(171)
3747 PARU(174)=COS(BESU-ALSU)
3748 PARU(175)=PARU(174)
3749 PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)*
3750 & SIN(BESU+ALSU)
3751 PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU)
3752 PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW
3753 PARU(181)=TANBE
3754 PARU(182)=1D0/TANBE
3755 PARU(183)=PARU(181)
3756 PARU(184)=0D0
3757 PARU(185)=PARU(184)
3758 PARU(186)=COS(BESU-ALSU)
3759 PARU(187)=SIN(BESU-ALSU)
3760 PARU(188)=PARU(186)
3761 PARU(189)=PARU(187)
3762 PARU(190)=0D0
3763 PARU(195)=COS(BESU-ALSU)
3764 ENDIF
3765
3766C...Reset effective widths of gauge bosons.
3767 DO 110 I=1,500
3768 DO 100 J=1,5
3769 WIDS(I,J)=1D0
3770 100 CONTINUE
3771 110 CONTINUE
3772
3773C...Order resonances by increasing mass (except Z0 and W+/-).
3774 NRES=0
3775 DO 140 KC=1,500
3776 KF=KCHG(KC,4)
3777 IF(KF.EQ.0) GOTO 140
3778 IF(MWID(KC).EQ.0) GOTO 140
3779 IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN
3780 IF(MSTP(1).LE.3) GOTO 140
3781 ENDIF
3782 IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN
3783 IF(IMSS(1).LE.0) GOTO 140
3784 ENDIF
3785 NRES=NRES+1
3786 PMRES=PMAS(KC,1)
3787 IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0
3788 DO 120 I1=NRES-1,1,-1
3789 IF(PMRES.GE.PMORD(I1)) GOTO 130
3790 KCORD(I1+1)=KCORD(I1)
3791 PMORD(I1+1)=PMORD(I1)
3792 120 CONTINUE
3793 130 KCORD(I1+1)=KC
3794 PMORD(I1+1)=PMRES
3795 140 CONTINUE
3796
3797C...Loop over possible resonances.
3798 DO 180 I=1,NRES
3799 KC=KCORD(I)
3800 KF=KCHG(KC,4)
3801
3802C...Check that no fourth generation channels on by mistake.
3803 IF(MSTP(1).LE.3) THEN
3804 DO 150 J=1,MDCY(KC,3)
3805 IDC=J+MDCY(KC,2)-1
3806 KFA1=IABS(KFDP(IDC,1))
3807 KFA2=IABS(KFDP(IDC,2))
3808 IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR.
3809 & KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18)
3810 & MDME(IDC,1)=-1
3811 150 CONTINUE
3812 ENDIF
3813
3814C...Check that no supersymmetric channels on by mistake.
3815 IF(IMSS(1).LE.0) THEN
3816 DO 160 J=1,MDCY(KC,3)
3817 IDC=J+MDCY(KC,2)-1
3818 KFA1S=IABS(KFDP(IDC,1))/KSUSY1
3819 KFA2S=IABS(KFDP(IDC,2))/KSUSY1
3820 IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2)
3821 & MDME(IDC,1)=-1
3822 160 CONTINUE
3823 ENDIF
3824
3825C...Find mass and evaluate width.
3826 PMR=PMAS(KC,1)
3827 IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1
3828 IF(MWID(KC).EQ.3) MINT(63)=1
3829 CALL PYWIDT(KF,PMR**2,WDTP,WDTE)
3830 MINT(51)=0
3831
3832C...Evaluate suppression factors due to non-simulated channels.
3833 IF(KCHG(KC,3).EQ.0) THEN
3834 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+
3835 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
3836 & 2D0*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
3837 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
3838 WIDS(KC,3)=0D0
3839 WIDS(KC,4)=0D0
3840 WIDS(KC,5)=0D0
3841 ELSE
3842 IF(MWID(KC).EQ.3) MINT(63)=1
3843 CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM)
3844 MINT(51)=0
3845 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+
3846 & (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+
3847 & (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+
3848 & WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))/WDTP(0)**2
3849 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
3850 WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))/WDTP(0)
3851 WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+
3852 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
3853 & 2D0*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
3854 WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+
3855 & 2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+
3856 & 2D0*WDTEM(0,4)*WDTEM(0,5))/WDTP(0)**2
3857 ENDIF
3858
3859C...Set resonance widths and branching ratios;
3860C...also on/off switch for decays.
3861 IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN
3862 PMAS(KC,2)=WDTP(0)
3863 PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2))
3864 IF(MSTP(41).EQ.0.OR.MSTP(41).EQ.1) MDCY(KC,1)=MSTP(41)
3865 DO 170 J=1,MDCY(KC,3)
3866 IDC=J+MDCY(KC,2)-1
3867 BRAT(IDC)=0D0
3868 IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0)
3869 170 CONTINUE
3870 ENDIF
3871 180 CONTINUE
3872
3873C...Flavours of leptoquark: redefine charge and name.
3874 KFLQQ=KFDP(MDCY(42,2),1)
3875 KFLQL=KFDP(MDCY(42,2),2)
3876 KCHG(42,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+
3877 &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL)
3878 LL=1
3879 IF(IABS(KFLQL).EQ.13) LL=2
3880 IF(IABS(KFLQL).EQ.15) LL=3
3881 CHAF(42,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)//
3882 &CHAF(IABS(KFLQL),1)(1:LL)//' '
3883 CHAF(42,2)=CHAF(42,2)(1:4+LL)//'bar '
3884
3885C...Special cases in treatment of gamma*/Z0: redefine process name.
3886 IF(MSTP(43).EQ.1) THEN
3887 PROC(1)='f + fbar -> gamma*'
3888 PROC(15)='f + fbar -> g + gamma*'
3889 PROC(19)='f + fbar -> gamma + gamma*'
3890 PROC(30)='f + g -> f + gamma*'
3891 PROC(35)='f + gamma -> f + gamma*'
3892 ELSEIF(MSTP(43).EQ.2) THEN
3893 PROC(1)='f + fbar -> Z0'
3894 PROC(15)='f + fbar -> g + Z0'
3895 PROC(19)='f + fbar -> gamma + Z0'
3896 PROC(30)='f + g -> f + Z0'
3897 PROC(35)='f + gamma -> f + Z0'
3898 ELSEIF(MSTP(43).EQ.3) THEN
3899 PROC(1)='f + fbar -> gamma*/Z0'
3900 PROC(15)='f + fbar -> g + gamma*/Z0'
3901 PROC(19)='f + fbar -> gamma + gamma*/Z0'
3902 PROC(30)='f + g -> f + gamma*/Z0'
3903 PROC(35)='f + gamma -> f + gamma*/Z0'
3904 ENDIF
3905
3906C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
3907 IF(MSTP(44).EQ.1) THEN
3908 PROC(141)='f + fbar -> gamma*'
3909 ELSEIF(MSTP(44).EQ.2) THEN
3910 PROC(141)='f + fbar -> Z0'
3911 ELSEIF(MSTP(44).EQ.3) THEN
3912 PROC(141)='f + fbar -> Z''0'
3913 ELSEIF(MSTP(44).EQ.4) THEN
3914 PROC(141)='f + fbar -> gamma*/Z0'
3915 ELSEIF(MSTP(44).EQ.5) THEN
3916 PROC(141)='f + fbar -> gamma*/Z''0'
3917 ELSEIF(MSTP(44).EQ.6) THEN
3918 PROC(141)='f + fbar -> Z0/Z''0'
3919 ELSEIF(MSTP(44).EQ.7) THEN
3920 PROC(141)='f + fbar -> gamma*/Z0/Z''0'
3921 ENDIF
3922
3923C...Special cases in treatment of WW -> WW: redefine process name.
3924 IF(MSTP(45).EQ.1) THEN
3925 PROC(77)='W+ + W+ -> W+ + W+'
3926 ELSEIF(MSTP(45).EQ.2) THEN
3927 PROC(77)='W+ + W- -> W+ + W-'
3928 ELSEIF(MSTP(45).EQ.3) THEN
3929 PROC(77)='W+/- + W+/- -> W+/- + W+/-'
3930 ENDIF
3931
3932C...Format for error information.
3933 5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ',
3934 &'combination'/1X,'Execution stopped!')
3935
3936 RETURN
3937 END
3938
3939C*********************************************************************
3940
3941C...PYINBM
3942C...Identifies the two incoming particles and the choice of frame.
3943
3944 SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
3945
3946C...Double precision and integer declarations.
3947 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3948 IMPLICIT INTEGER(I-N)
3949 INTEGER PYK,PYCHGE,PYCOMP
3950
3951C...User process initialization commonblock.
3952 INTEGER MAXPUP
3953 PARAMETER (MAXPUP=100)
3954 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
3955 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
3956 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
3957 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
3958 &LPRUP(MAXPUP)
3959 SAVE /HEPRUP/
3960
3961C...Commonblocks.
3962 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3963 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3964 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3965 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3966 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3967 COMMON/PYINT1/MINT(400),VINT(400)
3968 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
3969
3970C...Local arrays, character variables and data.
3971 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26,
3972 &CHIDNT(3)*12,CHTEMP*12,CHCDE(39)*12,CHINIT*76,CHNAME*16
3973 DIMENSION LEN(3),KCDE(39),PM(2)
3974 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
3975 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
3976 DATA CHCDE/ 'e- ','e+ ','nu_e ',
3977 &'nu_ebar ','mu- ','mu+ ','nu_mu ',
3978 &'nu_mubar ','tau- ','tau+ ','nu_tau ',
3979 &'nu_taubar ','pi+ ','pi- ','n0 ',
3980 &'nbar0 ','p+ ','pbar- ','gamma ',
3981 &'lambda0 ','sigma- ','sigma0 ','sigma+ ',
3982 &'xi- ','xi0 ','omega- ','pi0 ',
3983 &'reggeon ','pomeron ','gamma/e- ','gamma/e+ ',
3984 &'gamma/mu- ','gamma/mu+ ','gamma/tau- ','gamma/tau+ ',
3985 &'k+ ','k- ','ks0 ','kl0 '/
3986 DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
3987 &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
3988 &3312,3322,3334,111,110,990,6*22,321,-321,310,130/
3989
3990C...Store initial energy. Default frame.
3991 VINT(290)=WIN
3992 MINT(111)=0
3993
3994C...Special user process initialization; convert to normal input.
3995 IF(CHFRAM(1:1).EQ.'u'.OR.CHFRAM(1:1).EQ.'U') THEN
3996 MINT(111)=11
3997 CALL PYNAME(IDBMUP(1),CHNAME)
3998 CHBEAM=CHNAME(1:12)
3999 CALL PYNAME(IDBMUP(2),CHNAME)
4000 CHTARG=CHNAME(1:12)
4001 ENDIF
4002
4003C...Convert character variables to lowercase and find their length.
4004 CHCOM(1)=CHFRAM
4005 CHCOM(2)=CHBEAM
4006 CHCOM(3)=CHTARG
4007 DO 130 I=1,3
4008 LEN(I)=12
4009 DO 110 LL=12,1,-1
4010 IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
4011 DO 100 LA=1,26
4012 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
4013 & CHALP(1)(LA:LA)
4014 100 CONTINUE
4015 110 CONTINUE
4016 CHIDNT(I)=CHCOM(I)
4017
4018C...Fix up bar, underscore and charge in particle name (if needed).
4019 DO 120 LL=1,10
4020 IF(CHIDNT(I)(LL:LL).EQ.'~') THEN
4021 CHTEMP=CHIDNT(I)
4022 CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:10)//' '
4023 ENDIF
4024 120 CONTINUE
4025 IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN
4026 CHTEMP=CHIDNT(I)
4027 CHIDNT(I)='nu_'//CHTEMP(3:7)
4028 ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN
4029 CHIDNT(I)(1:3)='n0 '
4030 ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN
4031 CHIDNT(I)(1:5)='nbar0'
4032 ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN
4033 CHIDNT(I)(1:3)='p+ '
4034 ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR.
4035 & CHIDNT(I)(1:2).EQ.'p-') THEN
4036 CHIDNT(I)(1:5)='pbar-'
4037 ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN
4038 CHIDNT(I)(7:7)='0'
4039 ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN
4040 CHIDNT(I)(1:7)='reggeon'
4041 ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN
4042 CHIDNT(I)(1:7)='pomeron'
4043 ENDIF
4044 130 CONTINUE
4045
4046C...Identify free initialization.
4047 IF(CHCOM(1)(1:2).EQ.'no') THEN
4048 MINT(65)=1
4049 RETURN
4050 ENDIF
4051
4052C...Identify incoming beam and target particles.
4053 DO 160 I=1,2
4054 DO 140 J=1,39
4055 IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J)
4056 140 CONTINUE
4057 PM(I)=PYMASS(MINT(10+I))
4058 VINT(2+I)=PM(I)
4059 MINT(140+I)=0
4060 IF(MINT(10+I).EQ.22.AND.CHIDNT(I+1)(6:6).EQ.'/') THEN
4061 CHTEMP=CHIDNT(I+1)(7:12)//' '
4062 DO 150 J=1,12
4063 IF(CHTEMP.EQ.CHCDE(J)) MINT(140+I)=KCDE(J)
4064 150 CONTINUE
4065 PM(I)=PYMASS(MINT(140+I))
4066 VINT(302+I)=PM(I)
4067 ENDIF
4068 160 CONTINUE
4069 IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2))
4070 IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3))
4071 IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) STOP
4072
4073C...Identify choice of frame and input energies.
4074 CHINIT=' '
4075
4076C...Events defined in the CM frame.
4077 IF(CHCOM(1)(1:2).EQ.'cm') THEN
4078 MINT(111)=1
4079 S=WIN**2
4080 IF(MSTP(122).GE.1) THEN
4081 IF(CHCOM(2)(1:1).NE.'e') THEN
4082 LOFFS=(31-(LEN(2)+LEN(3)))/2
4083 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
4084 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4085 & ' collider'//' '
4086 ELSE
4087 LOFFS=(30-(LEN(2)+LEN(3)))/2
4088 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
4089 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4090 & ' collider'//' '
4091 ENDIF
4092 WRITE(MSTU(11),5200) CHINIT
4093 WRITE(MSTU(11),5300) WIN
4094 ENDIF
4095
4096C...Events defined in fixed target frame.
4097 ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
4098 MINT(111)=2
4099 S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2)
4100 IF(MSTP(122).GE.1) THEN
4101 LOFFS=(29-(LEN(2)+LEN(3)))/2
4102 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4103 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4104 & ' fixed target'//' '
4105 WRITE(MSTU(11),5200) CHINIT
4106 WRITE(MSTU(11),5400) WIN
4107 WRITE(MSTU(11),5500) SQRT(S)
4108 ENDIF
4109
4110C...Frame defined by user three-vectors.
4111 ELSEIF(CHCOM(1)(1:1).EQ.'3') THEN
4112 MINT(111)=3
4113 P(1,5)=PM(1)
4114 P(2,5)=PM(2)
4115 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
4116 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
4117 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
4118 & (P(1,3)+P(2,3))**2
4119 IF(MSTP(122).GE.1) THEN
4120 LOFFS=(22-(LEN(2)+LEN(3)))/2
4121 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4122 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4123 & ' user configuration'//' '
4124 WRITE(MSTU(11),5200) CHINIT
4125 WRITE(MSTU(11),5600)
4126 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
4127 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
4128 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
4129 ENDIF
4130
4131C...Frame defined by user four-vectors.
4132 ELSEIF(CHCOM(1)(1:1).EQ.'4') THEN
4133 MINT(111)=4
4134 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
4135 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
4136 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
4137 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
4138 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
4139 & (P(1,3)+P(2,3))**2
4140 IF(MSTP(122).GE.1) THEN
4141 LOFFS=(22-(LEN(2)+LEN(3)))/2
4142 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4143 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4144 & ' user configuration'//' '
4145 WRITE(MSTU(11),5200) CHINIT
4146 WRITE(MSTU(11),5600)
4147 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
4148 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
4149 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
4150 ENDIF
4151
4152C...Frame defined by user five-vectors.
4153 ELSEIF(CHCOM(1)(1:1).EQ.'5') THEN
4154 MINT(111)=5
4155 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
4156 & (P(1,3)+P(2,3))**2
4157 IF(MSTP(122).GE.1) THEN
4158 LOFFS=(22-(LEN(2)+LEN(3)))/2
4159 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4160 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4161 & ' user configuration'//' '
4162 WRITE(MSTU(11),5200) CHINIT
4163 WRITE(MSTU(11),5600)
4164 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
4165 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
4166 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
4167 ENDIF
4168
4169C...Frame defined by HEPRUP common block.
4170 ELSEIF(MINT(111).EQ.11) THEN
4171 S=(EBMUP(1)+EBMUP(2))**2-(SQRT(MAX(0D0,EBMUP(1)**2-PM(1)**2))-
4172 & SQRT(MAX(0D0,EBMUP(2)**2-PM(2)**2)))**2
4173 IF(MSTP(122).GE.1) THEN
4174 LOFFS=(22-(LEN(2)+LEN(3)))/2
4175 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4176 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4177 & ' user configuration'//' '
4178 WRITE(MSTU(11),5200) CHINIT
4179 WRITE(MSTU(11),6000) EBMUP(1),EBMUP(2)
4180 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
4181 ENDIF
4182
4183C...Unknown frame. Error for too low CM energy.
4184 ELSE
4185 WRITE(MSTU(11),5800) CHFRAM(1:LEN(1))
4186 STOP
4187 ENDIF
4188 IF(S.LT.PARP(2)**2) THEN
4189 WRITE(MSTU(11),5900) SQRT(S)
4190 STOP
4191 ENDIF
4192
4193C...Formats for initialization and error information.
4194 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/
4195 &1X,'Execution stopped!')
4196 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/
4197 &1X,'Execution stopped!')
4198 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
4199 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
4200 &19X,'I'/1X,'I',76X,'I'/1X,78('='))
4201 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
4202 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
4203 &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
4204 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X,
4205 &'pz (GeV/c)',6X,'E (GeV)',9X,'I')
4206 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I')
4207 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/
4208 &1X,'Execution stopped!')
4209 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
4210 &'generation.'/1X,'Execution stopped!')
4211 6000 FORMAT(1X,'I',12X,'with',1X,F10.3,1X,'GeV on',1X,F10.3,1X,
4212 &'GeV beam energies',13X,'I')
4213
4214 RETURN
4215 END
4216
4217C*********************************************************************
4218
4219C...PYINKI
4220C...Sets up kinematics, including rotations and boosts to/from CM frame.
4221
4222 SUBROUTINE PYINKI(MODKI)
4223
4224C...Double precision and integer declarations.
4225 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4226 IMPLICIT INTEGER(I-N)
4227 INTEGER PYK,PYCHGE,PYCOMP
4228
4229C...User process initialization commonblock.
4230 INTEGER MAXPUP
4231 PARAMETER (MAXPUP=100)
4232 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
4233 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
4234 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
4235 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
4236 &LPRUP(MAXPUP)
4237 SAVE /HEPRUP/
4238
4239C...Commonblocks.
4240 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
4241 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4242 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4243 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4244 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4245 COMMON/PYINT1/MINT(400),VINT(400)
4246 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
4247
4248C...Set initial flavour state.
4249 N=2
4250 DO 100 I=1,2
4251 K(I,1)=1
4252 K(I,2)=MINT(10+I)
4253 IF(MINT(140+I).NE.0) K(I,2)=MINT(140+I)
4254 100 CONTINUE
4255
4256C...Reset boost. Do kinematics for various cases.
4257 DO 110 J=6,10
4258 VINT(J)=0D0
4259 110 CONTINUE
4260
4261C...Set up kinematics for events defined in CM frame.
4262 IF(MINT(111).EQ.1) THEN
4263 WIN=VINT(290)
4264 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
4265 S=WIN**2
4266 P(1,5)=VINT(3)
4267 P(2,5)=VINT(4)
4268 IF(MINT(141).NE.0) P(1,5)=VINT(303)
4269 IF(MINT(142).NE.0) P(2,5)=VINT(304)
4270 P(1,1)=0D0
4271 P(1,2)=0D0
4272 P(2,1)=0D0
4273 P(2,2)=0D0
4274 P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/
4275 & (4D0*S))
4276 P(2,3)=-P(1,3)
4277 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
4278 P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
4279
4280C...Set up kinematics for fixed target events.
4281 ELSEIF(MINT(111).EQ.2) THEN
4282 WIN=VINT(290)
4283 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
4284 P(1,5)=VINT(3)
4285 P(2,5)=VINT(4)
4286 IF(MINT(141).NE.0) P(1,5)=VINT(303)
4287 IF(MINT(142).NE.0) P(2,5)=VINT(304)
4288 P(1,1)=0D0
4289 P(1,2)=0D0
4290 P(2,1)=0D0
4291 P(2,2)=0D0
4292 P(1,3)=WIN
4293 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
4294 P(2,3)=0D0
4295 P(2,4)=P(2,5)
4296 S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4)
4297 VINT(10)=P(1,3)/(P(1,4)+P(2,4))
4298 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
4299
4300C...Set up kinematics for events in user-defined frame.
4301 ELSEIF(MINT(111).EQ.3) THEN
4302 P(1,5)=VINT(3)
4303 P(2,5)=VINT(4)
4304 IF(MINT(141).NE.0) P(1,5)=VINT(303)
4305 IF(MINT(142).NE.0) P(2,5)=VINT(304)
4306 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
4307 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
4308 DO 120 J=1,3
4309 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
4310 120 CONTINUE
4311 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
4312 VINT(7)=PYANGL(P(1,1),P(1,2))
4313 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
4314 VINT(6)=PYANGL(P(1,3),P(1,1))
4315 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
4316 S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
4317
4318C...Set up kinematics for events with user-defined four-vectors.
4319 ELSEIF(MINT(111).EQ.4) THEN
4320 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
4321 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
4322 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
4323 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
4324 DO 130 J=1,3
4325 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
4326 130 CONTINUE
4327 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
4328 VINT(7)=PYANGL(P(1,1),P(1,2))
4329 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
4330 VINT(6)=PYANGL(P(1,3),P(1,1))
4331 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
4332 S=(P(1,4)+P(2,4))**2
4333
4334C...Set up kinematics for events with user-defined five-vectors.
4335 ELSEIF(MINT(111).EQ.5) THEN
4336 DO 140 J=1,3
4337 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
4338 140 CONTINUE
4339 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
4340 VINT(7)=PYANGL(P(1,1),P(1,2))
4341 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
4342 VINT(6)=PYANGL(P(1,3),P(1,1))
4343 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
4344 S=(P(1,4)+P(2,4))**2
4345
4346C...Set up kinematics for events with external user processes.
4347 ELSEIF(MINT(111).EQ.11) THEN
4348 P(1,5)=VINT(3)
4349 P(2,5)=VINT(4)
4350 IF(MINT(141).NE.0) P(1,5)=VINT(303)
4351 IF(MINT(142).NE.0) P(2,5)=VINT(304)
4352 P(1,1)=0D0
4353 P(1,2)=0D0
4354 P(2,1)=0D0
4355 P(2,2)=0D0
4356 P(1,3)=SQRT(MAX(0D0,EBMUP(1)**2-P(1,5)**2))
4357 P(2,3)=-SQRT(MAX(0D0,EBMUP(2)**2-P(2,5)**2))
4358 P(1,4)=EBMUP(1)
4359 P(2,4)=EBMUP(2)
4360 VINT(10)=(P(1,3)+P(2,3))/(P(1,4)+P(2,4))
4361 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
4362 S=(P(1,4)+P(2,4))**2
4363 ENDIF
4364
4365C...Return or error for too low CM energy.
4366 IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN
4367 IF(MSTP(172).LE.1) THEN
4368 CALL PYERRM(23,
4369 & '(PYINKI:) too low invariant mass in this event')
4370 ELSE
4371 MSTI(61)=1
4372 RETURN
4373 ENDIF
4374 ENDIF
4375
4376C...Save information on incoming particles.
4377 VINT(1)=SQRT(S)
4378 VINT(2)=S
4379 IF(MINT(111).GE.4) THEN
4380 IF(MINT(141).EQ.0) THEN
4381 VINT(3)=P(1,5)
4382 IF(MINT(11).EQ.22.AND.P(1,5).LT.0) VINT(307)=P(1,5)**2
4383 ELSE
4384 VINT(303)=P(1,5)
4385 ENDIF
4386 IF(MINT(142).EQ.0) THEN
4387 VINT(4)=P(2,5)
4388 IF(MINT(12).EQ.22.AND.P(2,5).LT.0) VINT(308)=P(2,5)**2
4389 ELSE
4390 VINT(304)=P(2,5)
4391 ENDIF
4392 ENDIF
4393 VINT(5)=P(1,3)
4394 IF(MODKI.EQ.0) VINT(289)=S
4395 DO 150 J=1,5
4396 V(1,J)=0D0
4397 V(2,J)=0D0
4398 VINT(290+J)=P(1,J)
4399 VINT(295+J)=P(2,J)
4400 150 CONTINUE
4401
4402C...Store pT cut-off and related constants to be used in generation.
4403 IF(MODKI.EQ.0) VINT(285)=CKIN(3)
4404 IF(MSTP(82).LE.1) THEN
4405 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
4406 ELSE
4407 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
4408 ENDIF
4409 VINT(149)=4D0*PTMN**2/S
4410 VINT(154)=PTMN
4411
4412 RETURN
4413 END
4414
4415C*********************************************************************
4416
4417C...PYINPR
4418C...Selects partonic subprocesses to be included in the simulation.
4419
4420 SUBROUTINE PYINPR
4421
4422C...Double precision and integer declarations.
4423 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4424 IMPLICIT INTEGER(I-N)
4425 INTEGER PYK,PYCHGE,PYCOMP
4426
4427C...User process initialization commonblock.
4428 INTEGER MAXPUP
4429 PARAMETER (MAXPUP=100)
4430 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
4431 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
4432 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
4433 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
4434 &LPRUP(MAXPUP)
4435 SAVE /HEPRUP/
4436
4437C...Commonblocks and character variables.
4438 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4439 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
4440 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4441 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4442 COMMON/PYINT1/MINT(400),VINT(400)
4443 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4444 COMMON/PYINT6/PROC(0:500)
4445 CHARACTER PROC*28
4446 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
4447 &/PYINT6/
4448 CHARACTER CHIPR*10
4449
4450C...Reset processes to be included.
4451 IF(MSEL.NE.0) THEN
4452 DO 100 I=1,500
4453 MSUB(I)=0
4454 100 CONTINUE
4455 ENDIF
4456
4457C...Set running pTmin scale.
4458 IF(MSTP(82).LE.1) THEN
4459 PTMRUN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
4460 ELSE
4461 PTMRUN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
4462 ENDIF
4463
4464C...Begin by assuming incoming photon to enter subprocess.
4465 IF(MINT(11).EQ.22) MINT(15)=22
4466 IF(MINT(12).EQ.22) MINT(16)=22
4467
4468C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous.
4469 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
4470 MSUB(10)=1
4471 MINT(123)=MINT(122)+1
4472
4473C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30
4474C...allow mixture.
4475C...Here also set a few parameters otherwise normally not touched.
4476 ELSEIF(MINT(121).GT.1) THEN
4477
4478C...Parton distributions dampened at small Q2; go to low energies,
4479C...alpha_s <1; no minimum pT cut-off a priori.
4480 IF(MSTP(18).EQ.2) THEN
4481 MSTP(57)=3
4482 PARP(2)=2D0
4483 PARU(115)=1D0
4484 CKIN(5)=0.2D0
4485 CKIN(6)=0.2D0
4486 ENDIF
4487
4488C...Define pT cut-off parameters and whether run involves low-pT.
4489 PTMVMD=PTMRUN
4490 VINT(154)=PTMVMD
4491 PTMDIR=PTMVMD
4492 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
4493 PTMANO=PTMVMD
4494 IF(MSTP(15).EQ.5) PTMANO=0.60D0+
4495 & 0.125D0*LOG(1D0+0.10D0*VINT(1))**2
4496 IPTL=1
4497 IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0
4498 IF(MSEL.EQ.2) IPTL=1
4499
4500C...Set up for p/gamma * gamma; real or virtual photons.
4501 IF(MINT(121).EQ.3.OR.MINT(121).EQ.6.OR.(MINT(121).EQ.4.AND.
4502 & MSTP(14).EQ.30)) THEN
4503
4504C...Set up for p/VMD * VMD.
4505 IF(MINT(122).EQ.1) THEN
4506 MINT(123)=2
4507 MSUB(11)=1
4508 MSUB(12)=1
4509 MSUB(13)=1
4510 MSUB(28)=1
4511 MSUB(53)=1
4512 MSUB(68)=1
4513 IF(IPTL.EQ.1) MSUB(95)=1
4514 IF(MSEL.EQ.2) THEN
4515 MSUB(91)=1
4516 MSUB(92)=1
4517 MSUB(93)=1
4518 MSUB(94)=1
4519 ENDIF
4520 IF(IPTL.EQ.1) CKIN(3)=0D0
4521
4522C...Set up for p/VMD * direct gamma.
4523 ELSEIF(MINT(122).EQ.2) THEN
4524 MINT(123)=0
4525 IF(MINT(121).EQ.6) MINT(123)=5
4526 MSUB(131)=1
4527 MSUB(132)=1
4528 MSUB(135)=1
4529 MSUB(136)=1
4530 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4531
4532C...Set up for p/VMD * anomalous gamma.
4533 ELSEIF(MINT(122).EQ.3) THEN
4534 MINT(123)=3
4535 IF(MINT(121).EQ.6) MINT(123)=7
4536 MSUB(11)=1
4537 MSUB(12)=1
4538 MSUB(13)=1
4539 MSUB(28)=1
4540 MSUB(53)=1
4541 MSUB(68)=1
4542 IF(IPTL.EQ.1) MSUB(95)=1
4543 IF(MSEL.EQ.2) THEN
4544 MSUB(91)=1
4545 MSUB(92)=1
4546 MSUB(93)=1
4547 MSUB(94)=1
4548 ENDIF
4549 IF(IPTL.EQ.1) CKIN(3)=0D0
4550
4551C...Set up for DIS * p.
4552 ELSEIF(MINT(122).EQ.4.AND.(IABS(MINT(11)).GT.100.OR.
4553 & IABS(MINT(12)).GT.100)) THEN
4554 MINT(123)=8
4555 IF(IPTL.EQ.1) MSUB(99)=1
4556
4557C...Set up for direct * direct gamma (switch off leptons).
4558 ELSEIF(MINT(122).EQ.4) THEN
4559 MINT(123)=0
4560 MSUB(137)=1
4561 MSUB(138)=1
4562 MSUB(139)=1
4563 MSUB(140)=1
4564 DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
4565 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
4566 110 CONTINUE
4567 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4568
4569C...Set up for direct * anomalous gamma.
4570 ELSEIF(MINT(122).EQ.5) THEN
4571 MINT(123)=6
4572 MSUB(131)=1
4573 MSUB(132)=1
4574 MSUB(135)=1
4575 MSUB(136)=1
4576 IF(IPTL.EQ.1) CKIN(3)=PTMANO
4577
4578C...Set up for anomalous * anomalous gamma.
4579 ELSEIF(MINT(122).EQ.6) THEN
4580 MINT(123)=3
4581 MSUB(11)=1
4582 MSUB(12)=1
4583 MSUB(13)=1
4584 MSUB(28)=1
4585 MSUB(53)=1
4586 MSUB(68)=1
4587 IF(IPTL.EQ.1) MSUB(95)=1
4588 IF(MSEL.EQ.2) THEN
4589 MSUB(91)=1
4590 MSUB(92)=1
4591 MSUB(93)=1
4592 MSUB(94)=1
4593 ENDIF
4594 IF(IPTL.EQ.1) CKIN(3)=0D0
4595 ENDIF
4596
4597C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom.
4598 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
4599
4600C...Set up for direct * direct gamma (switch off leptons).
4601 IF(MINT(122).EQ.1) THEN
4602 MINT(123)=0
4603 MSUB(137)=1
4604 MSUB(138)=1
4605 MSUB(139)=1
4606 MSUB(140)=1
4607 DO 120 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
4608 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
4609 120 CONTINUE
4610 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4611
4612C...Set up for direct * VMD and VMD * direct gamma.
4613 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.4) THEN
4614 MINT(123)=5
4615 MSUB(131)=1
4616 MSUB(132)=1
4617 MSUB(135)=1
4618 MSUB(136)=1
4619 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4620
4621C...Set up for direct * anomalous and anomalous * direct gamma.
4622 ELSEIF(MINT(122).EQ.3.OR.MINT(122).EQ.7) THEN
4623 MINT(123)=6
4624 MSUB(131)=1
4625 MSUB(132)=1
4626 MSUB(135)=1
4627 MSUB(136)=1
4628 IF(IPTL.EQ.1) CKIN(3)=PTMANO
4629
4630C...Set up for VMD*VMD.
4631 ELSEIF(MINT(122).EQ.5) THEN
4632 MINT(123)=2
4633 MSUB(11)=1
4634 MSUB(12)=1
4635 MSUB(13)=1
4636 MSUB(28)=1
4637 MSUB(53)=1
4638 MSUB(68)=1
4639 IF(IPTL.EQ.1) MSUB(95)=1
4640 IF(MSEL.EQ.2) THEN
4641 MSUB(91)=1
4642 MSUB(92)=1
4643 MSUB(93)=1
4644 MSUB(94)=1
4645 ENDIF
4646 IF(IPTL.EQ.1) CKIN(3)=0D0
4647
4648C...Set up for VMD * anomalous and anomalous * VMD gamma.
4649 ELSEIF(MINT(122).EQ.6.OR.MINT(122).EQ.8) THEN
4650 MINT(123)=7
4651 MSUB(11)=1
4652 MSUB(12)=1
4653 MSUB(13)=1
4654 MSUB(28)=1
4655 MSUB(53)=1
4656 MSUB(68)=1
4657 IF(IPTL.EQ.1) MSUB(95)=1
4658 IF(MSEL.EQ.2) THEN
4659 MSUB(91)=1
4660 MSUB(92)=1
4661 MSUB(93)=1
4662 MSUB(94)=1
4663 ENDIF
4664 IF(IPTL.EQ.1) CKIN(3)=0D0
4665
4666C...Set up for anomalous * anomalous gamma.
4667 ELSEIF(MINT(122).EQ.9) THEN
4668 MINT(123)=3
4669 MSUB(11)=1
4670 MSUB(12)=1
4671 MSUB(13)=1
4672 MSUB(28)=1
4673 MSUB(53)=1
4674 MSUB(68)=1
4675 IF(IPTL.EQ.1) MSUB(95)=1
4676 IF(MSEL.EQ.2) THEN
4677 MSUB(91)=1
4678 MSUB(92)=1
4679 MSUB(93)=1
4680 MSUB(94)=1
4681 ENDIF
4682 IF(IPTL.EQ.1) CKIN(3)=0D0
4683
4684C...Set up for DIS * VMD and VMD * DIS gamma.
4685 ELSEIF(MINT(122).EQ.10.OR.MINT(122).EQ.12) THEN
4686 MINT(123)=8
4687 IF(IPTL.EQ.1) MSUB(99)=1
4688
4689C...Set up for DIS * anomalous and anomalous * DIS gamma.
4690 ELSEIF(MINT(122).EQ.11.OR.MINT(122).EQ.13) THEN
4691 MINT(123)=9
4692 IF(IPTL.EQ.1) MSUB(99)=1
4693 ENDIF
4694
4695C...Set up for gamma* * p; virtual photons = dir, res.
4696 ELSEIF(MINT(121).EQ.2) THEN
4697
4698C...Set up for direct * p.
4699 IF(MINT(122).EQ.1) THEN
4700 MINT(123)=0
4701 MSUB(131)=1
4702 MSUB(132)=1
4703 MSUB(135)=1
4704 MSUB(136)=1
4705 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4706
4707C...Set up for resolved * p.
4708 ELSEIF(MINT(122).EQ.2) THEN
4709 MINT(123)=1
4710 MSUB(11)=1
4711 MSUB(12)=1
4712 MSUB(13)=1
4713 MSUB(28)=1
4714 MSUB(53)=1
4715 MSUB(68)=1
4716 IF(IPTL.EQ.1) MSUB(95)=1
4717 IF(MSEL.EQ.2) THEN
4718 MSUB(91)=1
4719 MSUB(92)=1
4720 MSUB(93)=1
4721 MSUB(94)=1
4722 ENDIF
4723 IF(IPTL.EQ.1) CKIN(3)=0D0
4724 ENDIF
4725
4726C...Set up for gamma* * gamma*; virtual photons = dir, res.
4727 ELSEIF(MINT(121).EQ.4) THEN
4728
4729C...Set up for direct * direct gamma (switch off leptons).
4730 IF(MINT(122).EQ.1) THEN
4731 MINT(123)=0
4732 MSUB(137)=1
4733 MSUB(138)=1
4734 MSUB(139)=1
4735 MSUB(140)=1
4736 DO 130 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
4737 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
4738 130 CONTINUE
4739 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4740
4741C...Set up for direct * resolved and resolved * direct gamma.
4742 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.3) THEN
4743 MINT(123)=5
4744 MSUB(131)=1
4745 MSUB(132)=1
4746 MSUB(135)=1
4747 MSUB(136)=1
4748 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4749
4750C...Set up for resolved * resolved gamma.
4751 ELSEIF(MINT(122).EQ.4) THEN
4752 MINT(123)=2
4753 MSUB(11)=1
4754 MSUB(12)=1
4755 MSUB(13)=1
4756 MSUB(28)=1
4757 MSUB(53)=1
4758 MSUB(68)=1
4759 IF(IPTL.EQ.1) MSUB(95)=1
4760 IF(MSEL.EQ.2) THEN
4761 MSUB(91)=1
4762 MSUB(92)=1
4763 MSUB(93)=1
4764 MSUB(94)=1
4765 ENDIF
4766 IF(IPTL.EQ.1) CKIN(3)=0D0
4767 ENDIF
4768
4769C...End of special set up for gamma-p and gamma-gamma.
4770 ENDIF
4771 CKIN(1)=2D0*CKIN(3)
4772 ENDIF
4773
4774C...Flavour information for individual beams.
4775 DO 140 I=1,2
4776 MINT(40+I)=1
4777 IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2
4778 IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2
4779 MINT(44+I)=MINT(40+I)
4780 IF(MSTP(11).GE.1.AND.(IABS(MINT(10+I)).EQ.11.OR.
4781 & IABS(MINT(10+I)).EQ.13.OR.IABS(MINT(10+I)).EQ.15)) MINT(44+I)=3
4782 140 CONTINUE
4783
4784C...If two real gammas, whereof one direct, pick the first.
4785C...For two virtual photons, keep requested order.
4786 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
4787 IF(MSTP(14).LE.10.AND.MINT(123).GE.4.AND.MINT(123).LE.6) THEN
4788 MINT(41)=1
4789 MINT(45)=1
4790 ELSEIF(MSTP(14).EQ.12.OR.MSTP(14).EQ.13.OR.MSTP(14).EQ.22.OR.
4791 & MSTP(14).EQ.26.OR.MSTP(14).EQ.27) THEN
4792 MINT(41)=1
4793 MINT(45)=1
4794 ELSEIF(MSTP(14).EQ.14.OR.MSTP(14).EQ.17.OR.MSTP(14).EQ.23.OR.
4795 & MSTP(14).EQ.28.OR.MSTP(14).EQ.29) THEN
4796 MINT(42)=1
4797 MINT(46)=1
4798 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.2
4799 & .OR.MINT(122).EQ.3.OR.MINT(122).EQ.10.OR.MINT(122).EQ.11)) THEN
4800 MINT(41)=1
4801 MINT(45)=1
4802 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.4
4803 & .OR.MINT(122).EQ.7.OR.MINT(122).EQ.12.OR.MINT(122).EQ.13)) THEN
4804 MINT(42)=1
4805 MINT(46)=1
4806 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.2) THEN
4807 MINT(41)=1
4808 MINT(45)=1
4809 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.3) THEN
4810 MINT(42)=1
4811 MINT(46)=1
4812 ENDIF
4813 ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN
4814 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28.OR.MINT(122).EQ.4) THEN
4815 IF(MINT(11).EQ.22) THEN
4816 MINT(41)=1
4817 MINT(45)=1
4818 ELSE
4819 MINT(42)=1
4820 MINT(46)=1
4821 ENDIF
4822 ENDIF
4823 IF(MINT(123).GE.4.AND.MINT(123).LE.7) CALL PYERRM(26,
4824 & '(PYINPR:) unallowed MSTP(14) code for single photon')
4825 ENDIF
4826
4827C...Flavour information on combination of incoming particles.
4828 MINT(43)=2*MINT(41)+MINT(42)-2
4829 MINT(44)=MINT(43)
4830 IF(MINT(123).LE.0) THEN
4831 IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2
4832 IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1
4833 ELSEIF(MINT(123).LE.3) THEN
4834 IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2
4835 IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1
4836 ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
4837 MINT(43)=4
4838 MINT(44)=1
4839 ENDIF
4840 MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2
4841 IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5
4842 IF(MINT(45).EQ.1.AND.MINT(46).EQ.3) MINT(47)=6
4843 IF(MINT(45).EQ.3.AND.MINT(46).EQ.1) MINT(47)=7
4844 MINT(50)=0
4845 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) MINT(50)=1
4846 MINT(107)=0
4847 MINT(108)=0
4848 IF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
4849 IF((MINT(122).GE.4.AND.MINT(122).LE.6).OR.MINT(122).EQ.12)
4850 & MINT(107)=2
4851 IF((MINT(122).GE.7.AND.MINT(122).LE.9).OR.MINT(122).EQ.13)
4852 & MINT(107)=3
4853 IF(MINT(122).EQ.10.OR.MINT(122).EQ.11) MINT(107)=4
4854 IF(MINT(122).EQ.2.OR.MINT(122).EQ.5.OR.MINT(122).EQ.8.OR.
4855 & MINT(122).EQ.10) MINT(108)=2
4856 IF(MINT(122).EQ.3.OR.MINT(122).EQ.6.OR.MINT(122).EQ.9.OR.
4857 & MINT(122).EQ.11) MINT(108)=3
4858 IF(MINT(122).EQ.12.OR.MINT(122).EQ.13) MINT(108)=4
4859 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.25) THEN
4860 IF(MINT(122).GE.3) MINT(107)=1
4861 IF(MINT(122).EQ.2.OR.MINT(122).EQ.4) MINT(108)=1
4862 ELSEIF(MINT(121).EQ.2) THEN
4863 IF(MINT(122).EQ.2.AND.MINT(11).EQ.22) MINT(107)=1
4864 IF(MINT(122).EQ.2.AND.MINT(12).EQ.22) MINT(108)=1
4865 ELSE
4866 IF(MINT(11).EQ.22) THEN
4867 MINT(107)=MINT(123)
4868 IF(MINT(123).GE.4) MINT(107)=0
4869 IF(MINT(123).EQ.7) MINT(107)=2
4870 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.27) MINT(107)=4
4871 IF(MSTP(14).EQ.28) MINT(107)=2
4872 IF(MSTP(14).EQ.29) MINT(107)=3
4873 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
4874 & MINT(107)=4
4875 ENDIF
4876 IF(MINT(12).EQ.22) THEN
4877 MINT(108)=MINT(123)
4878 IF(MINT(123).GE.4) MINT(108)=MINT(123)-3
4879 IF(MINT(123).EQ.7) MINT(108)=3
4880 IF(MSTP(14).EQ.26) MINT(108)=2
4881 IF(MSTP(14).EQ.27) MINT(108)=3
4882 IF(MSTP(14).EQ.28.OR.MSTP(14).EQ.29) MINT(108)=4
4883 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
4884 & MINT(108)=4
4885 ENDIF
4886 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.(MSTP(14).EQ.14.OR.
4887 & MSTP(14).EQ.17.OR.MSTP(14).EQ.18.OR.MSTP(14).EQ.23)) THEN
4888 MINTTP=MINT(107)
4889 MINT(107)=MINT(108)
4890 MINT(108)=MINTTP
4891 ENDIF
4892 ENDIF
4893 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
4894 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
4895
4896C...Select default processes according to incoming beams
4897C...(already done for gamma-p and gamma-gamma with
4898C...MSTP(14) = 10, 20, 25 or 30).
4899 IF(MINT(121).GT.1) THEN
4900 ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN
4901
4902 IF(MINT(43).EQ.1) THEN
4903C...Lepton + lepton -> gamma/Z0 or W.
4904 IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
4905 IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
4906
4907 ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND.
4908 & (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN
4909C...Unresolved photon + lepton: Compton scattering.
4910 MSUB(133)=1
4911 MSUB(134)=1
4912
4913 ELSEIF((MINT(123).EQ.8.OR.MINT(123).EQ.9).AND.(MINT(11).EQ.22
4914 & .OR.MINT(12).EQ.22)) THEN
4915C...DIS as pure gamma* + f -> f process.
4916 MSUB(99)=1
4917
4918 ELSEIF(MINT(43).LE.3) THEN
4919C...Lepton + hadron: deep inelastic scattering.
4920 MSUB(10)=1
4921
4922 ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND.
4923 & MINT(12).EQ.22) THEN
4924C...Two unresolved photons: fermion pair production,
4925C...exclude lepton pairs.
4926 DO 150 ISUB=137,140
4927 MSUB(ISUB)=1
4928 150 CONTINUE
4929 DO 160 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
4930 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
4931 160 CONTINUE
4932 PTMDIR=PTMRUN
4933 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
4934 IF(CKIN(3).LT.PTMRUN.OR.MSEL.EQ.2) CKIN(3)=PTMDIR
4935 CKIN(1)=MAX(CKIN(1),2D0*CKIN(3))
4936
4937 ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22))
4938 & .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND.
4939 & MINT(12).EQ.22)) THEN
4940C...Unresolved photon + hadron: photon-parton scattering.
4941 DO 170 ISUB=131,136
4942 MSUB(ISUB)=1
4943 170 CONTINUE
4944
4945 ELSEIF(MSEL.EQ.1) THEN
4946C...High-pT QCD processes:
4947 MSUB(11)=1
4948 MSUB(12)=1
4949 MSUB(13)=1
4950 MSUB(28)=1
4951 MSUB(53)=1
4952 MSUB(68)=1
4953 PTMN=PTMRUN
4954 VINT(154)=PTMN
4955 IF(CKIN(3).LT.PTMN) MSUB(95)=1
4956 IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0
4957
4958 ELSE
4959C...All QCD processes:
4960 MSUB(11)=1
4961 MSUB(12)=1
4962 MSUB(13)=1
4963 MSUB(28)=1
4964 MSUB(53)=1
4965 MSUB(68)=1
4966 MSUB(91)=1
4967 MSUB(92)=1
4968 MSUB(93)=1
4969 MSUB(94)=1
4970 MSUB(95)=1
4971 ENDIF
4972
4973 ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
4974C...Heavy quark production.
4975 MSUB(81)=1
4976 MSUB(82)=1
4977 MSUB(84)=1
4978 DO 180 J=1,MIN(8,MDCY(21,3))
4979 MDME(MDCY(21,2)+J-1,1)=0
4980 180 CONTINUE
4981 MDME(MDCY(21,2)+MSEL-1,1)=1
4982 MSUB(85)=1
4983 DO 190 J=1,MIN(12,MDCY(22,3))
4984 MDME(MDCY(22,2)+J-1,1)=0
4985 190 CONTINUE
4986 MDME(MDCY(22,2)+MSEL-1,1)=1
4987
4988 ELSEIF(MSEL.EQ.10) THEN
4989C...Prompt photon production:
4990 MSUB(14)=1
4991 MSUB(18)=1
4992 MSUB(29)=1
4993
4994 ELSEIF(MSEL.EQ.11) THEN
4995C...Z0/gamma* production:
4996 MSUB(1)=1
4997
4998 ELSEIF(MSEL.EQ.12) THEN
4999C...W+/- production:
5000 MSUB(2)=1
5001
5002 ELSEIF(MSEL.EQ.13) THEN
5003C...Z0 + jet:
5004 MSUB(15)=1
5005 MSUB(30)=1
5006
5007 ELSEIF(MSEL.EQ.14) THEN
5008C...W+/- + jet:
5009 MSUB(16)=1
5010 MSUB(31)=1
5011
5012 ELSEIF(MSEL.EQ.15) THEN
5013C...Z0 & W+/- pair production:
5014 MSUB(19)=1
5015 MSUB(20)=1
5016 MSUB(22)=1
5017 MSUB(23)=1
5018 MSUB(25)=1
5019
5020 ELSEIF(MSEL.EQ.16) THEN
5021C...h0 production:
5022 MSUB(3)=1
5023 MSUB(102)=1
5024 MSUB(103)=1
5025 MSUB(123)=1
5026 MSUB(124)=1
5027
5028 ELSEIF(MSEL.EQ.17) THEN
5029C...h0 & Z0 or W+/- pair production:
5030 MSUB(24)=1
5031 MSUB(26)=1
5032
5033 ELSEIF(MSEL.EQ.18) THEN
5034C...h0 production; interesting processes in e+e-.
5035 MSUB(24)=1
5036 MSUB(103)=1
5037 MSUB(123)=1
5038 MSUB(124)=1
5039
5040 ELSEIF(MSEL.EQ.19) THEN
5041C...h0, H0 and A0 production; interesting processes in e+e-.
5042 MSUB(24)=1
5043 MSUB(103)=1
5044 MSUB(123)=1
5045 MSUB(124)=1
5046 MSUB(153)=1
5047 MSUB(171)=1
5048 MSUB(173)=1
5049 MSUB(174)=1
5050 MSUB(158)=1
5051 MSUB(176)=1
5052 MSUB(178)=1
5053 MSUB(179)=1
5054
5055 ELSEIF(MSEL.EQ.21) THEN
5056C...Z'0 production:
5057 MSUB(141)=1
5058
5059 ELSEIF(MSEL.EQ.22) THEN
5060C...W'+/- production:
5061 MSUB(142)=1
5062
5063 ELSEIF(MSEL.EQ.23) THEN
5064C...H+/- production:
5065 MSUB(143)=1
5066
5067 ELSEIF(MSEL.EQ.24) THEN
5068C...R production:
5069 MSUB(144)=1
5070
5071 ELSEIF(MSEL.EQ.25) THEN
5072C...LQ (leptoquark) production.
5073 MSUB(145)=1
5074 MSUB(162)=1
5075 MSUB(163)=1
5076 MSUB(164)=1
5077
5078 ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN
5079C...Production of one heavy quark (W exchange):
5080 MSUB(83)=1
5081 DO 200 J=1,MIN(8,MDCY(21,3))
5082 MDME(MDCY(21,2)+J-1,1)=0
5083 200 CONTINUE
5084 MDME(MDCY(21,2)+MSEL-31,1)=1
5085
5086CMRENNA++Define SUSY alternatives.
5087 ELSEIF(MSEL.EQ.39) THEN
5088C...Turn on all SUSY processes.
5089 IF(MINT(43).EQ.4) THEN
5090C...Hadron-hadron processes.
5091 DO 210 I=201,301
5092 IF(ISET(I).GE.0) MSUB(I)=1
5093 210 CONTINUE
5094 ELSEIF(MINT(43).EQ.1) THEN
5095C...Lepton-lepton processes: QED production of squarks.
5096 DO 220 I=201,214
5097 MSUB(I)=1
5098 220 CONTINUE
5099 MSUB(210)=0
5100 MSUB(211)=0
5101 MSUB(212)=0
5102 DO 230 I=216,228
5103 MSUB(I)=1
5104 230 CONTINUE
5105 DO 240 I=261,263
5106 MSUB(I)=1
5107 240 CONTINUE
5108 MSUB(277)=1
5109 MSUB(278)=1
5110 ENDIF
5111
5112 ELSEIF(MSEL.EQ.40) THEN
5113C...Gluinos and squarks.
5114 IF(MINT(43).EQ.4) THEN
5115 MSUB(243)=1
5116 MSUB(244)=1
5117 MSUB(258)=1
5118 MSUB(259)=1
5119 MSUB(261)=1
5120 MSUB(262)=1
5121 MSUB(264)=1
5122 MSUB(265)=1
5123 DO 250 I=271,296
5124 MSUB(I)=1
5125 250 CONTINUE
5126 ELSEIF(MINT(43).EQ.1) THEN
5127 MSUB(277)=1
5128 MSUB(278)=1
5129 ENDIF
5130
5131 ELSEIF(MSEL.EQ.41) THEN
5132C...Stop production.
5133 MSUB(261)=1
5134 MSUB(262)=1
5135 MSUB(263)=1
5136 IF(MINT(43).EQ.4) THEN
5137 MSUB(264)=1
5138 MSUB(265)=1
5139 ENDIF
5140
5141 ELSEIF(MSEL.EQ.42) THEN
5142C...Slepton production.
5143 DO 260 I=201,214
5144 MSUB(I)=1
5145 260 CONTINUE
5146 IF(MINT(43).NE.4) THEN
5147 MSUB(210)=0
5148 MSUB(211)=0
5149 MSUB(212)=0
5150 ENDIF
5151
5152 ELSEIF(MSEL.EQ.43) THEN
5153C...Neutralino/Chargino + Gluino/Squark.
5154 IF(MINT(43).EQ.4) THEN
5155 DO 270 I=237,242
5156 MSUB(I)=1
5157 270 CONTINUE
5158 DO 280 I=246,257
5159 MSUB(I)=1
5160 280 CONTINUE
5161 ENDIF
5162
5163 ELSEIF(MSEL.EQ.44) THEN
5164C...Neutralino/Chargino pair production.
5165 IF(MINT(43).EQ.4) THEN
5166 DO 290 I=216,236
5167 MSUB(I)=1
5168 290 CONTINUE
5169 ELSEIF(MINT(43).EQ.1) THEN
5170 DO 300 I=216,228
5171 MSUB(I)=1
5172 300 CONTINUE
5173 ENDIF
5174
5175 ELSEIF(MSEL.EQ.45) THEN
5176C...Sbottom production.
5177 MSUB(287)=1
5178 MSUB(288)=1
5179 IF(MINT(43).EQ.4) THEN
5180 DO 310 I=281,296
5181 MSUB(I)=1
5182 310 CONTINUE
5183 ENDIF
5184
5185 ELSEIF(MSEL.EQ.50) THEN
5186 DO 320 I=361,368
5187 MSUB(I)=1
5188 320 CONTINUE
5189 IF(MINT(43).EQ.4) THEN
5190 DO 330 I=370,377
5191 MSUB(I)=1
5192 330 CONTINUE
5193 ENDIF
5194
5195 ENDIF
5196
5197C...Find heaviest new quark flavour allowed in processes 81-84.
5198 KFLQM=1
5199 DO 340 I=1,MIN(8,MDCY(21,3))
5200 IDC=I+MDCY(21,2)-1
5201 IF(MDME(IDC,1).LE.0) GOTO 340
5202 KFLQM=I
5203 340 CONTINUE
5204 IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9))
5205 &KFLQM=MSTP(7)
5206 MINT(55)=KFLQM
5207 KFPR(81,1)=KFLQM
5208 KFPR(81,2)=KFLQM
5209 KFPR(82,1)=KFLQM
5210 KFPR(82,2)=KFLQM
5211 KFPR(83,1)=KFLQM
5212 KFPR(84,1)=KFLQM
5213 KFPR(84,2)=KFLQM
5214
5215C...Find heaviest new fermion flavour allowed in process 85.
5216 KFLFM=1
5217 DO 350 I=1,MIN(12,MDCY(22,3))
5218 IDC=I+MDCY(22,2)-1
5219 IF(MDME(IDC,1).LE.0) GOTO 350
5220 KFLFM=KFDP(IDC,1)
5221 350 CONTINUE
5222 IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND.
5223 &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7)
5224 MINT(56)=KFLFM
5225 KFPR(85,1)=KFLFM
5226 KFPR(85,2)=KFLFM
5227
5228C...Import relevant information on external user processes.
5229 IF(MINT(111).EQ.11) THEN
5230 IPYPR=0
5231 DO 380 IUP=1,NPRUP
5232C...Find next empty PYTHIA process number slot and enable it.
5233 360 IPYPR=IPYPR+1
5234 IF(IPYPR.GT.500) CALL PYERRM(26,
5235 & '(PYINPR.) no more empty slots for user processes')
5236 IF(ISET(IPYPR).GE.0.AND.ISET(IPYPR).LE.9) GOTO 360
5237 ISET(IPYPR)=11
5238C...Overwrite KFPR with references back to process number and ID.
5239 KFPR(IPYPR,1)=IUP
5240 KFPR(IPYPR,2)=LPRUP(IUP)
5241C...Process title.
5242 WRITE(CHIPR,'(I10)') LPRUP(IUP)
5243 ICHIN=1
5244 DO 370 ICH=1,9
5245 IF(CHIPR(ICH:ICH).EQ.' ') ICHIN=ICH+1
5246 370 CONTINUE
5247 PROC(IPYPR)='User process '//CHIPR(ICHIN:10)//' '
5248C...Switch on process.
5249 MSUB(IPYPR)=1
5250 380 CONTINUE
5251 ENDIF
5252
5253 RETURN
5254 END
5255
5256C*********************************************************************
5257
5258C...PYXTOT
5259C...Parametrizes total, elastic and diffractive cross-sections
5260C...for different energies and beams. Donnachie-Landshoff for
5261C...total and Schuler-Sjostrand for elastic and diffractive.
5262C...Process code IPROC:
5263C...= 1 : p + p;
5264C...= 2 : pbar + p;
5265C...= 3 : pi+ + p;
5266C...= 4 : pi- + p;
5267C...= 5 : pi0 + p;
5268C...= 6 : phi + p;
5269C...= 7 : J/psi + p;
5270C...= 11 : rho + rho;
5271C...= 12 : rho + phi;
5272C...= 13 : rho + J/psi;
5273C...= 14 : phi + phi;
5274C...= 15 : phi + J/psi;
5275C...= 16 : J/psi + J/psi;
5276C...= 21 : gamma + p (DL);
5277C...= 22 : gamma + p (VDM).
5278C...= 23 : gamma + pi (DL);
5279C...= 24 : gamma + pi (VDM);
5280C...= 25 : gamma + gamma (DL);
5281C...= 26 : gamma + gamma (VDM).
5282
5283 SUBROUTINE PYXTOT
5284
5285C...Double precision and integer declarations.
5286 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5287 IMPLICIT INTEGER(I-N)
5288 INTEGER PYK,PYCHGE,PYCOMP
5289C...Commonblocks.
5290 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5291 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5292 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5293 COMMON/PYINT1/MINT(400),VINT(400)
5294 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5295 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
5296 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/
5297C...Local arrays.
5298 DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20),
5299 &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8),
5300 &CEFFD(10,9),SIGTMP(6,0:5)
5301
5302C...Common constants.
5303 DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/,
5304 &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/,
5305 &FACDD/0.0084D0/
5306
5307C...Number of multiple processes to be evaluated (= 0 : undefined).
5308 DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
5309C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
5310 DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0,
5311 &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0,
5312 &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/
5313 DATA YPAR/
5314 &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0,
5315 &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0,
5316 &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/
5317
5318C...Beam and target hadron class:
5319C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
5320 DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
5321 DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/
5322C...Characteristic class masses, slope parameters, beta = sqrt(X).
5323 DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/
5324 DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
5325 DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/
5326
5327C...Fitting constants used in parametrizations of diffractive results.
5328 DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
5329 DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
5330 DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/
5331 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0,
5332 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0,
5333 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0,
5334 &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0,
5335 &0.267D0, 0.0D0, -0.46D0, 75D0, 0.267D0, 0.0D0, -0.46D0, 75D0,
5336 &0.232D0, 0.0D0, -0.46D0, 85D0, 0.267D0, 0.0D0, -0.48D0, 100D0,
5337 &0.115D0, 0.0D0, -0.50D0, 90D0, 0.267D0, 6.0D0, -0.56D0, 420D0,
5338 &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0,
5339 &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0,
5340 &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/
5341 DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/
5342 &3.11D0, -7.34D0, 9.71D0, 0.068D0, -0.42D0, 1.31D0,
5343 &-1.37D0, 35.0D0, 118D0, 3.11D0, -7.10D0, 10.6D0,
5344 &0.073D0, -0.41D0, 1.17D0, -1.41D0, 31.6D0, 95D0,
5345 &3.12D0, -7.43D0, 9.21D0, 0.067D0, -0.44D0, 1.41D0,
5346 &-1.35D0, 36.5D0, 132D0, 3.13D0, -8.18D0, -4.20D0,
5347 &0.056D0, -0.71D0, 3.12D0, -1.12D0, 55.2D0, 1298D0,
5348 &3.11D0, -6.90D0, 11.4D0, 0.078D0, -0.40D0, 1.05D0,
5349 &-1.40D0, 28.4D0, 78D0, 3.11D0, -7.13D0, 10.0D0,
5350 &0.071D0, -0.41D0, 1.23D0, -1.34D0, 33.1D0, 105D0,
5351 &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0, 2.72D0,
5352 &-1.13D0, 53.1D0, 995D0, 3.11D0, -7.39D0, 8.22D0,
5353 &0.065D0, -0.44D0, 1.45D0, -1.36D0, 38.1D0, 148D0,
5354 &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0, 3.32D0,
5355 &-1.12D0, 55.6D0, 1472D0, 4.18D0, -29.2D0, 56.2D0,
5356 &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/
5357
5358C...Parameters. Combinations of the energy.
5359 AEM=PARU(101)
5360 PMTH=PARP(102)
5361 S=VINT(2)
5362 SRT=VINT(1)
5363 SEPS=S**EPS
5364 SETA=S**ETA
5365 SLOG=LOG(S)
5366
5367C...Ratio of gamma/pi (for rescaling in parton distributions).
5368 VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/
5369 &(XPAR(5)*SEPS+YPAR(5)*SETA)
5370 VINT(317)=1D0
5371 IF(MINT(50).NE.1) RETURN
5372
5373C...Order flavours of incoming particles: KF1 < KF2.
5374 IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN
5375 KF1=IABS(MINT(11))
5376 KF2=IABS(MINT(12))
5377 IORD=1
5378 ELSE
5379 KF1=IABS(MINT(12))
5380 KF2=IABS(MINT(11))
5381 IORD=2
5382 ENDIF
5383 ISGN12=ISIGN(1,MINT(11)*MINT(12))
5384
5385C...Find process number (for lookup tables).
5386 IF(KF1.GT.1000) THEN
5387 IPROC=1
5388 IF(ISGN12.LT.0) IPROC=2
5389 ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN
5390 IPROC=3
5391 IF(ISGN12.LT.0) IPROC=4
5392 IF(KF1.EQ.111) IPROC=5
5393 ELSEIF(KF1.GT.100) THEN
5394 IPROC=11
5395 ELSEIF(KF2.GT.1000) THEN
5396 IPROC=21
5397 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=22
5398 ELSEIF(KF2.GT.100) THEN
5399 IPROC=23
5400 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=24
5401 ELSE
5402 IPROC=25
5403 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7) IPROC=26
5404 ENDIF
5405
5406C... Number of multiple processes to be stored; beam/target side.
5407 NPR=NPROC(IPROC)
5408 MINT(101)=1
5409 MINT(102)=1
5410 IF(NPR.EQ.3) THEN
5411 MINT(100+IORD)=4
5412 ELSEIF(NPR.EQ.6) THEN
5413 MINT(101)=4
5414 MINT(102)=4
5415 ENDIF
5416 N1=0
5417 IF(MINT(101).EQ.4) N1=4
5418 N2=0
5419 IF(MINT(102).EQ.4) N2=4
5420
5421C...Do not do any more for user-set or undefined cross-sections.
5422 IF(MSTP(31).LE.0) RETURN
5423 IF(NPR.EQ.0) CALL PYERRM(26,
5424 &'(PYXTOT:) cross section for this process not yet implemented')
5425
5426C...Parameters. Combinations of the energy.
5427 AEM=PARU(101)
5428 PMTH=PARP(102)
5429 S=VINT(2)
5430 SRT=VINT(1)
5431 SEPS=S**EPS
5432 SETA=S**ETA
5433 SLOG=LOG(S)
5434
5435C...Loop over multiple processes (for VDM).
5436 DO 110 I=1,NPR
5437 IF(NPR.EQ.1) THEN
5438 IPR=IPROC
5439 ELSEIF(NPR.EQ.3) THEN
5440 IPR=I+4
5441 IF(KF2.LT.1000) IPR=I+10
5442 ELSEIF(NPR.EQ.6) THEN
5443 IPR=I+10
5444 ENDIF
5445
5446C...Evaluate hadron species, mass, slope contribution and fit number.
5447 IHA=IHADA(IPR)
5448 IHB=IHADB(IPR)
5449 PMA=PMHAD(IHA)
5450 PMB=PMHAD(IHB)
5451 BHA=BHAD(IHA)
5452 BHB=BHAD(IHB)
5453 ISD=IFITSD(IPR)
5454 IDD=IFITDD(IPR)
5455
5456C...Skip if energy too low relative to masses.
5457 DO 100 J=0,5
5458 SIGTMP(I,J)=0D0
5459 100 CONTINUE
5460 IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110
5461
5462C...Total cross-section. Elastic slope parameter and cross-section.
5463 SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA
5464 BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0
5465 SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL
5466
5467C...Diffractive scattering A + B -> X + B.
5468 BSD=2D0*BHB
5469 SQML=(PMA+PMTH)**2
5470 SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2)
5471 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
5472 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
5473 BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
5474 SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/
5475 & (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
5476 SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2)
5477
5478C...Diffractive scattering A + B -> A + X.
5479 BSD=2D0*BHA
5480 SQML=(PMB+PMTH)**2
5481 SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6)
5482 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
5483 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
5484 BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
5485 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/
5486 & (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
5487 SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2)
5488
5489C...Order single diffractive correctly.
5490 IF(IORD.EQ.2) THEN
5491 SIGSAV=SIGTMP(I,2)
5492 SIGTMP(I,2)=SIGTMP(I,3)
5493 SIGTMP(I,3)=SIGSAV
5494 ENDIF
5495
5496C...Double diffractive scattering A + B -> X1 + X2.
5497 YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2)
5498 DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2
5499 SUM1=DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0)/(2D0*ALP)
5500 IF(YEFF.LE.0) SUM1=0D0
5501 SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2)
5502 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC))))
5503 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC))))
5504 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/
5505 & (2D0*ALP)
5506 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC))))
5507 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC))))
5508 SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/
5509 & (2D0*ALP)
5510 BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S
5511 SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB*PMRC)))
5512 SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*
5513 & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX)
5514 SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4)
5515
5516C...Non-diffractive by unitarity.
5517 SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)-
5518 & SIGTMP(I,4)
5519 110 CONTINUE
5520
5521C...Put temporary results in output array: only one process.
5522 IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN
5523 DO 120 J=0,5
5524 SIGT(0,0,J)=SIGTMP(1,J)
5525 120 CONTINUE
5526
5527C...Beam multiple processes.
5528 ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN
5529 IF(MINT(107).EQ.2) THEN
5530 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
5531 ELSE
5532 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
5533 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
5534 ENDIF
5535 IF(MSTP(20).GT.0) THEN
5536 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)))**MSTP(20)
5537 ENDIF
5538 DO 140 I=1,4
5539 IF(MINT(107).EQ.2) THEN
5540 CONV=(AEM/PARP(160+I))*VINT(317)
5541 ELSEIF(VINT(154).GT.PARP(15)) THEN
5542 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
5543 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
5544 ELSE
5545 CONV=0D0
5546 ENDIF
5547 I1=MAX(1,I-1)
5548 DO 130 J=0,5
5549 SIGT(I,0,J)=CONV*SIGTMP(I1,J)
5550 130 CONTINUE
5551 140 CONTINUE
5552 DO 150 J=0,5
5553 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
5554 150 CONTINUE
5555
5556C...Target multiple processes.
5557 ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN
5558 IF(MINT(108).EQ.2) THEN
5559 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
5560 ELSE
5561 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
5562 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
5563 ENDIF
5564 IF(MSTP(20).GT.0) THEN
5565 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(308)))**MSTP(20)
5566 ENDIF
5567 DO 170 I=1,4
5568 IF(MINT(108).EQ.2) THEN
5569 CONV=(AEM/PARP(160+I))*VINT(317)
5570 ELSEIF(VINT(154).GT.PARP(15)) THEN
5571 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
5572 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
5573 ELSE
5574 CONV=0D0
5575 ENDIF
5576 IV=MAX(1,I-1)
5577 DO 160 J=0,5
5578 SIGT(0,I,J)=CONV*SIGTMP(IV,J)
5579 160 CONTINUE
5580 170 CONTINUE
5581 DO 180 J=0,5
5582 SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J)
5583 180 CONTINUE
5584
5585C...Both beam and target multiple processes.
5586 ELSE
5587 IF(MINT(107).EQ.2) THEN
5588 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
5589 ELSE
5590 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
5591 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
5592 ENDIF
5593 IF(MINT(108).EQ.2) THEN
5594 VINT(317)=VINT(317)*(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
5595 ELSE
5596 VINT(317)=VINT(317)*16D0*PARP(15)**2*VINT(154)**2/
5597 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
5598 ENDIF
5599 IF(MSTP(20).GT.0) THEN
5600 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)+
5601 & VINT(308)))**MSTP(20)
5602 ENDIF
5603 DO 210 I1=1,4
5604 DO 200 I2=1,4
5605 IF(MINT(107).EQ.2) THEN
5606 CONV=(AEM/PARP(160+I1))*VINT(317)
5607 ELSEIF(VINT(154).GT.PARP(15)) THEN
5608 CONV=(AEM/PARU(1))*(KCHG(I1,1)/3D0)**2*PARP(18)**2*
5609 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
5610 ELSE
5611 CONV=0D0
5612 ENDIF
5613 IF(MINT(108).EQ.2) THEN
5614 CONV=CONV*(AEM/PARP(160+I2))
5615 ELSEIF(VINT(154).GT.PARP(15)) THEN
5616 CONV=CONV*(AEM/PARU(1))*(KCHG(I2,1)/3D0)**2*PARP(18)**2*
5617 & (1D0/PARP(15)**2-1D0/VINT(154)**2)
5618 ELSE
5619 CONV=0D0
5620 ENDIF
5621 IF(I1.LE.2) THEN
5622 IV=MAX(1,I2-1)
5623 ELSEIF(I2.LE.2) THEN
5624 IV=MAX(1,I1-1)
5625 ELSEIF(I1.EQ.I2) THEN
5626 IV=2*I1-2
5627 ELSE
5628 IV=5
5629 ENDIF
5630 DO 190 J=0,5
5631 JV=J
5632 IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J
5633 SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV)
5634 190 CONTINUE
5635 200 CONTINUE
5636 210 CONTINUE
5637 DO 230 J=0,5
5638 DO 220 I=1,4
5639 SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J)
5640 SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J)
5641 220 CONTINUE
5642 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
5643 230 CONTINUE
5644 ENDIF
5645
5646C...Scale up uniformly for Donnachie-Landshoff parametrization.
5647 IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN
5648 RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0)
5649 DO 260 I1=0,N1
5650 DO 250 I2=0,N2
5651 DO 240 J=0,5
5652 SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J)
5653 240 CONTINUE
5654 250 CONTINUE
5655 260 CONTINUE
5656 ENDIF
5657
5658 RETURN
5659 END
5660
5661C*********************************************************************
5662
5663C...PYMAXI
5664C...Finds optimal set of coefficients for kinematical variable selection
5665C...and the maximum of the part of the differential cross-section used
5666C...in the event weighting.
5667
5668 SUBROUTINE PYMAXI
5669
5670C...Double precision and integer declarations.
5671 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5672 IMPLICIT INTEGER(I-N)
5673 INTEGER PYK,PYCHGE,PYCOMP
5674C...Parameter statement to help give large particle numbers.
5675 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
5676 &KEXCIT=4000000,KDIMEN=5000000)
5677
5678C...User process initialization commonblock.
5679 INTEGER MAXPUP
5680 PARAMETER (MAXPUP=100)
5681 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5682 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5683 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5684 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5685 &LPRUP(MAXPUP)
5686 SAVE /HEPRUP/
5687
5688C...Commonblocks.
5689 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5690 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5691 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
5692 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5693 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5694 COMMON/PYINT1/MINT(400),VINT(400)
5695 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5696 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
5697 COMMON/PYINT4/MWID(500),WIDS(500,5)
5698 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5699 COMMON/PYINT6/PROC(0:500)
5700 CHARACTER PROC*28
5701 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
5702 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
5703 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/
5704C...Local arrays, character variables and data.
5705 CHARACTER CVAR(4)*4
5706 DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500),
5707 &NAREL(7),WTREL(7),WTMAT(7,7),WTRELN(7),COEFU(7),COEFO(7),
5708 &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2)
5709 DATA CVAR/'tau ','tau''','y* ','cth '/
5710 DATA SIGSSM/3*0D0/
5711
5712C...Initial values and loop over subprocesses.
5713 NPOSI=0
5714 VINT(143)=1D0
5715 VINT(144)=1D0
5716 XSEC(0,1)=0D0
5717 DO 460 ISUB=1,500
5718 MINT(1)=ISUB
5719 MINT(51)=0
5720
5721C...Find maximum weight factors for photon flux.
5722 IF(MSUB(ISUB).EQ.1.OR.(ISUB.GE.91.AND.ISUB.LE.100)) THEN
5723 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(2,WTGAGA)
5724 ENDIF
5725
5726C...Select subprocess to study: skip cases not applicable.
5727 IF(ISET(ISUB).EQ.11) THEN
5728 IF(MSUB(ISUB).NE.1) GOTO 460
5729C...User process intialization: cross section model dependent.
5730 IF(IABS(IDWTUP).EQ.1) THEN
5731 IF(IDWTUP.GT.0.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
5732 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
5733 XSEC(ISUB,1)=1.00000001D-9*ABS(XMAXUP(KFPR(ISUB,1)))
5734 ELSE
5735 IF((IDWTUP.EQ.2.OR.IDWTUP.EQ.3).AND.
5736 & XSECUP(KFPR(ISUB,1)).LT.0D0) CALL
5737 & PYERRM(26,'(PYMAXI:) Negative XSECUP for user process')
5738 IF(IDWTUP.EQ.2.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
5739 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
5740 XSEC(ISUB,1)=1.00000001D-9*ABS(XSECUP(KFPR(ISUB,1)))
5741 ENDIF
5742 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
5743 & WTGAGA*XSEC(ISUB,1)
5744 NPOSI=NPOSI+1
5745 GOTO 450
5746 ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN
5747 CALL PYSIGH(NCHN,SIGS)
5748 XSEC(ISUB,1)=SIGS
5749 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
5750 & WTGAGA*XSEC(ISUB,1)
5751 IF(MSUB(ISUB).NE.1) GOTO 460
5752 NPOSI=NPOSI+1
5753 GOTO 450
5754 ELSEIF(ISUB.EQ.99.AND.MSUB(ISUB).EQ.1) THEN
5755 CALL PYSIGH(NCHN,SIGS)
5756 XSEC(ISUB,1)=SIGS
5757 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
5758 & WTGAGA*XSEC(ISUB,1)
5759 IF(XSEC(ISUB,1).EQ.0D0) THEN
5760 MSUB(ISUB)=0
5761 ELSE
5762 NPOSI=NPOSI+1
5763 ENDIF
5764 GOTO 450
5765 ELSEIF(ISUB.EQ.96) THEN
5766 IF(MINT(50).EQ.0) GOTO 460
5767 IF(MSUB(95).NE.1.AND.MSTP(81).LE.0.AND.MSTP(131).LE.0)
5768 & GOTO 460
5769 IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460
5770 ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
5771 & ISUB.EQ.53.OR.ISUB.EQ.68) THEN
5772 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
5773 ELSE
5774 IF(MSUB(ISUB).NE.1) GOTO 460
5775 ENDIF
5776 ISTSB=ISET(ISUB)
5777 IF(ISUB.EQ.96) ISTSB=2
5778 IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB
5779 MWTXS=0
5780 IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+
5781 & MSUB(94)+MSUB(95).EQ.0) MWTXS=1
5782
5783C...Find resonances (explicit or implicit in cross-section).
5784 MINT(72)=0
5785 KFR1=0
5786 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
5787 KFR1=KFPR(ISUB,1)
5788 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165
5789 & .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
5790 KFR1=23
5791 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172
5792 & .OR.ISUB.EQ.177) THEN
5793 KFR1=24
5794 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
5795 KFR1=25
5796 IF(MSTP(46).EQ.5) THEN
5797 KFR1=89
5798 PMAS(89,1)=PARP(45)
5799 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
5800 ENDIF
5801 ELSEIF(ISUB.EQ.194) THEN
5802 KFR1=KTECHN+113
5803 ELSEIF(ISUB.EQ.195) THEN
5804 KFR1=KTECHN+213
5805 ELSEIF(ISUB.GE.361.AND.ISUB.LE.368) THEN
5806 KFR1=KTECHN+113
5807 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
5808 KFR1=KTECHN+213
5809 ENDIF
5810 CKMX=CKIN(2)
5811 IF(CKMX.LE.0D0) CKMX=VINT(1)
5812 KCR1=PYCOMP(KFR1)
5813 IF(KFR1.NE.0) THEN
5814 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
5815 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
5816 ENDIF
5817 IF(KFR1.NE.0) THEN
5818 TAUR1=PMAS(KCR1,1)**2/VINT(2)
5819 IF(KFR1.EQ.KTECHN+113) THEN
5820 CALL PYTECM(S1,S2)
5821 TAUR1=S1/VINT(2)
5822 ENDIF
5823 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
5824 MINT(72)=1
5825 MINT(73)=KFR1
5826 VINT(73)=TAUR1
5827 VINT(74)=GAMR1
5828 ENDIF
5829 KFR2=0
5830 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.(ISUB.GE.364.AND.ISUB.LE.368))
5831 $ THEN
5832 KFR2=23
5833 IF(ISUB.EQ.194) THEN
5834 KFR2=KTECHN+223
5835 ELSEIF(ISUB.GE.364.AND.ISUB.LE.368) THEN
5836 KFR2=KTECHN+223
5837 ENDIF
5838 KCR2=PYCOMP(KFR2)
5839 TAUR2=PMAS(KCR2,1)**2/VINT(2)
5840 IF(KFR2.EQ.KTECHN+223) THEN
5841 CALL PYTECM(S1,S2)
5842 TAUR2=S2/VINT(2)
5843 ENDIF
5844 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
5845 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
5846 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
5847 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
5848 MINT(72)=2
5849 MINT(74)=KFR2
5850 VINT(75)=TAUR2
5851 VINT(76)=GAMR2
5852 ELSEIF(KFR2.NE.0) THEN
5853 KFR1=KFR2
5854 TAUR1=TAUR2
5855 GAMR1=GAMR2
5856 MINT(72)=1
5857 MINT(73)=KFR1
5858 VINT(73)=TAUR1
5859 VINT(74)=GAMR1
5860 KFR2=0
5861 ENDIF
5862 ENDIF
5863
5864C...Find product masses and minimum pT of process.
5865 SQM3=0D0
5866 SQM4=0D0
5867 MINT(71)=0
5868 VINT(71)=CKIN(3)
5869 VINT(80)=1D0
5870 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
5871 NBW=0
5872 DO 110 I=1,2
5873 PMMN(I)=0D0
5874 IF(KFPR(ISUB,I).EQ.0) THEN
5875 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
5876 & PARP(41)) THEN
5877 IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
5878 IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
5879 ELSE
5880 NBW=NBW+1
5881C...This prevents SUSY/t particles from becoming too light.
5882 KFLW=KFPR(ISUB,I)
5883 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
5884 KCW=PYCOMP(KFLW)
5885 PMMN(I)=PMAS(KCW,1)
5886 DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
5887 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
5888 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
5889 & PMAS(PYCOMP(KFDP(IDC,2)),1)
5890 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
5891 & PMAS(PYCOMP(KFDP(IDC,3)),1)
5892 PMMN(I)=MIN(PMMN(I),PMSUM)
5893 ENDIF
5894 100 CONTINUE
5895 ELSEIF(KFLW.EQ.6) THEN
5896 PMMN(I)=PMAS(24,1)+PMAS(5,1)
5897 ENDIF
5898 ENDIF
5899 110 CONTINUE
5900 IF(NBW.GE.1) THEN
5901 CKIN41=CKIN(41)
5902 CKIN43=CKIN(43)
5903 CKIN(41)=MAX(PMMN(1),CKIN(41))
5904 CKIN(43)=MAX(PMMN(2),CKIN(43))
5905 CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
5906 CKIN(41)=CKIN41
5907 CKIN(43)=CKIN43
5908 IF(MINT(51).EQ.1) THEN
5909 WRITE(MSTU(11),5100) ISUB
5910 MSUB(ISUB)=0
5911 GOTO 460
5912 ENDIF
5913 SQM3=PQM3**2
5914 SQM4=PQM4**2
5915 ENDIF
5916 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
5917 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
5918 IF(ISUB.EQ.96.AND.MSTP(82).LE.1) THEN
5919 VINT(71)=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
5920 ELSEIF(ISUB.EQ.96) THEN
5921 VINT(71)=0.08D0*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
5922 ENDIF
5923 ENDIF
5924 VINT(63)=SQM3
5925 VINT(64)=SQM4
5926
5927C...Prepare for additional variable choices in 2 -> 3.
5928 IF(ISTSB.EQ.5) THEN
5929 VINT(201)=0D0
5930 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
5931 VINT(206)=VINT(201)
5932 VINT(204)=PMAS(23,1)
5933 IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
5934 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
5935 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182
5936 & .OR.ISUB.EQ.186.OR.ISUB.EQ.187) VINT(204)=VINT(201)
5937 VINT(209)=VINT(204)
5938 ENDIF
5939
5940C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
5941 NPTS(1)=2+2*MINT(72)
5942 IF(MINT(47).EQ.1) THEN
5943 IF(ISTSB.EQ.1.OR.ISTSB.EQ.2) NPTS(1)=1
5944 ELSEIF(MINT(47).GE.5) THEN
5945 IF(ISTSB.LE.2.OR.ISTSB.GT.5) NPTS(1)=NPTS(1)+1
5946 ENDIF
5947 NPTS(2)=1
5948 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
5949 IF(MINT(47).GE.2) NPTS(2)=2
5950 IF(MINT(47).GE.5) NPTS(2)=3
5951 ENDIF
5952 NPTS(3)=1
5953 IF(MINT(47).EQ.4.OR.MINT(47).EQ.5) THEN
5954 NPTS(3)=3
5955 IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1
5956 IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1
5957 ENDIF
5958 NPTS(4)=1
5959 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
5960 NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
5961
5962C...Reset coefficients of cross-section weighting.
5963 DO 120 J=1,20
5964 COEF(ISUB,J)=0D0
5965 120 CONTINUE
5966 COEF(ISUB,1)=1D0
5967 COEF(ISUB,8)=0.5D0
5968 COEF(ISUB,9)=0.5D0
5969 COEF(ISUB,13)=1D0
5970 COEF(ISUB,18)=1D0
5971 MCTH=0
5972 MTAUP=0
5973 METAUP=0
5974 VINT(23)=0D0
5975 VINT(26)=0D0
5976 SIGSAM=0D0
5977
5978C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
5979C...in grid of phase space points.
5980 CALL PYKLIM(1)
5981 METAU=MINT(51)
5982 NACC=0
5983 DO 150 ITRY=1,NTRY
5984 MINT(51)=0
5985 IF(METAU.EQ.1) GOTO 150
5986 IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
5987 MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
5988 IF(MTAU.GT.2+2*MINT(72)) MTAU=7
5989 RTAU=0.5D0
5990C...Special case when both resonances have same mass,
5991C...as is often the case in process 194.
5992 IF(MINT(72).EQ.2) THEN
5993 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
5994 & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
5995 IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
5996 RTAU=0.4D0
5997 ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
5998 RTAU=0.6D0
5999 ENDIF
6000 ENDIF
6001 ENDIF
6002 CALL PYKMAP(1,MTAU,RTAU)
6003 IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4)
6004 METAUP=MINT(51)
6005 ENDIF
6006 IF(METAUP.EQ.1) GOTO 150
6007 IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4))
6008 & .EQ.0) THEN
6009 MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
6010 CALL PYKMAP(4,MTAUP,0.5D0)
6011 ENDIF
6012 IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN
6013 CALL PYKLIM(2)
6014 MEYST=MINT(51)
6015 ENDIF
6016 IF(MEYST.EQ.1) GOTO 150
6017 IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
6018 MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
6019 IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5
6020 CALL PYKMAP(2,MYST,0.5D0)
6021 CALL PYKLIM(3)
6022 MECTH=MINT(51)
6023 ENDIF
6024 IF(MECTH.EQ.1) GOTO 150
6025 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
6026 MCTH=1+MOD(ITRY-1,NPTS(4))
6027 CALL PYKMAP(3,MCTH,0.5D0)
6028 ENDIF
6029 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2)
6030
6031C...Store position and limits.
6032 MINT(51)=0
6033 CALL PYKLIM(0)
6034 IF(MINT(51).EQ.1) GOTO 150
6035 NACC=NACC+1
6036 MVARPT(NACC,1)=MTAU
6037 MVARPT(NACC,2)=MTAUP
6038 MVARPT(NACC,3)=MYST
6039 MVARPT(NACC,4)=MCTH
6040 DO 130 J=1,30
6041 VINTPT(NACC,J)=VINT(10+J)
6042 130 CONTINUE
6043
6044C...Normal case: calculate cross-section.
6045 IF(ISTSB.NE.5) THEN
6046 CALL PYSIGH(NCHN,SIGS)
6047 IF(MWTXS.EQ.1) THEN
6048 CALL PYEVWT(WTXS)
6049 SIGS=WTXS*SIGS
6050 ENDIF
6051
6052C..2 -> 3: find highest value out of a number of tries.
6053 ELSE
6054 SIGS=0D0
6055 DO 140 IKIN3=1,MSTP(129)
6056 CALL PYKMAP(5,0,0D0)
6057 IF(MINT(51).EQ.1) GOTO 140
6058 CALL PYSIGH(NCHN,SIGTMP)
6059 IF(MWTXS.EQ.1) THEN
6060 CALL PYEVWT(WTXS)
6061 SIGTMP=WTXS*SIGTMP
6062 ENDIF
6063 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
6064 140 CONTINUE
6065 ENDIF
6066
6067C...Store cross-section.
6068 SIGSPT(NACC)=SIGS
6069 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
6070 IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP,
6071 & VINT(21),VINT(22),VINT(23),VINT(26),SIGS
6072 150 CONTINUE
6073 IF(NACC.EQ.0) THEN
6074 WRITE(MSTU(11),5100) ISUB
6075 MSUB(ISUB)=0
6076 GOTO 460
6077 ELSEIF(SIGSAM.EQ.0D0) THEN
6078 WRITE(MSTU(11),5300) ISUB
6079 MSUB(ISUB)=0
6080 GOTO 460
6081 ENDIF
6082 IF(ISUB.NE.96) NPOSI=NPOSI+1
6083
6084C...Calculate integrals in tau over maximal phase space limits.
6085 TAUMIN=VINT(11)
6086 TAUMAX=VINT(31)
6087 ATAU1=LOG(TAUMAX/TAUMIN)
6088 IF(NPTS(1).GE.2) THEN
6089 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
6090 ENDIF
6091 IF(NPTS(1).GE.4) THEN
6092 ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
6093 ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
6094 & GAMR1
6095 ENDIF
6096 IF(NPTS(1).GE.6) THEN
6097 ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
6098 ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
6099 & GAMR2
6100 ENDIF
6101 IF(NPTS(1).GT.2+2*MINT(72)) THEN
6102 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
6103 ENDIF
6104
6105C...Reset. Sum up cross-sections in points calculated.
6106 DO 320 IVAR=1,4
6107 IF(NPTS(IVAR).EQ.1) GOTO 320
6108 IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320
6109 NBIN=NPTS(IVAR)
6110 DO 170 J1=1,NBIN
6111 NAREL(J1)=0
6112 WTREL(J1)=0D0
6113 COEFU(J1)=0D0
6114 DO 160 J2=1,NBIN
6115 WTMAT(J1,J2)=0D0
6116 160 CONTINUE
6117 170 CONTINUE
6118 DO 180 IACC=1,NACC
6119 IBIN=MVARPT(IACC,IVAR)
6120 IF(IVAR.EQ.1.AND.IBIN.EQ.7) IBIN=3+2*MINT(72)
6121 IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4
6122 NAREL(IBIN)=NAREL(IBIN)+1
6123 WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
6124
6125C...Sum up tau cross-section pieces in points used.
6126 IF(IVAR.EQ.1) THEN
6127 TAU=VINTPT(IACC,11)
6128 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
6129 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
6130 IF(NBIN.GE.4) THEN
6131 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
6132 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
6133 & ((TAU-TAUR1)**2+GAMR1**2)
6134 ENDIF
6135 IF(NBIN.GE.6) THEN
6136 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
6137 WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
6138 & ((TAU-TAUR2)**2+GAMR2**2)
6139 ENDIF
6140 IF(NBIN.GT.2+2*MINT(72)) THEN
6141 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(ATAU1/ATAU7)*
6142 & TAU/MAX(2D-10,1D0-TAU)
6143 ENDIF
6144
6145C...Sum up tau' cross-section pieces in points used.
6146 ELSEIF(IVAR.EQ.2) THEN
6147 TAU=VINTPT(IACC,11)
6148 TAUP=VINTPT(IACC,16)
6149 TAUPMN=VINTPT(IACC,6)
6150 TAUPMX=VINTPT(IACC,26)
6151 ATAUP1=LOG(TAUPMX/TAUPMN)
6152 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
6153 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
6154 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*
6155 & (1D0-TAU/TAUP)**3/TAUP
6156 IF(NBIN.GE.3) THEN
6157 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
6158 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)*
6159 & TAUP/MAX(2D-10,1D0-TAUP)
6160 ENDIF
6161
6162C...Sum up y* cross-section pieces in points used.
6163 ELSEIF(IVAR.EQ.3) THEN
6164 YST=VINTPT(IACC,12)
6165 YSTMIN=VINTPT(IACC,2)
6166 YSTMAX=VINTPT(IACC,22)
6167 AYST0=YSTMAX-YSTMIN
6168 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
6169 AYST2=AYST1
6170 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
6171 WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
6172 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST)
6173 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
6174 IF(MINT(45).EQ.3) THEN
6175 TAUE=VINTPT(IACC,11)
6176 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
6177 YST0=-0.5D0*LOG(TAUE)
6178 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
6179 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
6180 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/
6181 & MAX(1D-10,1D0-EXP(YST-YST0))
6182 ENDIF
6183 IF(MINT(46).EQ.3) THEN
6184 TAUE=VINTPT(IACC,11)
6185 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
6186 YST0=-0.5D0*LOG(TAUE)
6187 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
6188 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
6189 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/
6190 & MAX(1D-10,1D0-EXP(-YST-YST0))
6191 ENDIF
6192
6193C...Sum up cos(theta-hat) cross-section pieces in points used.
6194 ELSE
6195 RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2)
6196 RSQM=1D0+RM34
6197 CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2)))
6198 CTHMIN=-CTHMAX
6199 IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/
6200 & (TAUMAX*VINT(2)))
6201 ACTH1=CTHMAX-CTHMIN
6202 ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
6203 ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
6204 ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
6205 ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
6206 CTH=VINTPT(IACC,13)
6207 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
6208 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
6209 & MAX(RM34,RSQM-CTH)
6210 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
6211 & MAX(RM34,RSQM+CTH)
6212 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
6213 & MAX(RM34,RSQM-CTH)**2
6214 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
6215 & MAX(RM34,RSQM+CTH)**2
6216 ENDIF
6217 180 CONTINUE
6218
6219C...Check that equation system solvable.
6220 IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
6221 MSOLV=1
6222 WTRELS=0D0
6223 DO 190 IBIN=1,NBIN
6224 IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
6225 & IRED=1,NBIN),WTREL(IBIN)
6226 IF(NAREL(IBIN).EQ.0) MSOLV=0
6227 WTRELS=WTRELS+WTREL(IBIN)
6228 190 CONTINUE
6229 IF(ABS(WTRELS).LT.1D-20) MSOLV=0
6230
6231C...Solve to find relative importance of cross-section pieces.
6232 IF(MSOLV.EQ.1) THEN
6233 DO 200 IBIN=1,NBIN
6234 WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
6235 200 CONTINUE
6236 DO 230 IRED=1,NBIN-1
6237 DO 220 IBIN=IRED+1,NBIN
6238 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
6239 MSOLV=0
6240 GOTO 260
6241 ENDIF
6242 RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
6243 WTREL(IBIN)=WTREL(IBIN)-RQT*WTREL(IRED)
6244 DO 210 ICOE=IRED,NBIN
6245 WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-RQT*WTMAT(IRED,ICOE)
6246 210 CONTINUE
6247 220 CONTINUE
6248 230 CONTINUE
6249 DO 250 IRED=NBIN,1,-1
6250 DO 240 ICOE=IRED+1,NBIN
6251 WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
6252 240 CONTINUE
6253 COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
6254 250 CONTINUE
6255 ENDIF
6256
6257C...Share evenly if failure.
6258 260 IF(MSOLV.EQ.0) THEN
6259 DO 270 IBIN=1,NBIN
6260 COEFU(IBIN)=1D0
6261 WTRELN(IBIN)=0.1D0
6262 IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0,
6263 & WTREL(IBIN)/WTRELS)
6264 270 CONTINUE
6265 ENDIF
6266
6267C...Normalize coefficients, with piece shared democratically.
6268 COEFSU=0D0
6269 WTRELS=0D0
6270 DO 280 IBIN=1,NBIN
6271 COEFU(IBIN)=MAX(0D0,COEFU(IBIN))
6272 COEFSU=COEFSU+COEFU(IBIN)
6273 WTRELS=WTRELS+WTRELN(IBIN)
6274 280 CONTINUE
6275 IF(COEFSU.GT.0D0) THEN
6276 DO 290 IBIN=1,NBIN
6277 COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0*
6278 & (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS)
6279 290 CONTINUE
6280 ELSE
6281 DO 300 IBIN=1,NBIN
6282 COEFO(IBIN)=1D0/NBIN
6283 300 CONTINUE
6284 ENDIF
6285 IF(IVAR.EQ.1) IOFF=0
6286 IF(IVAR.EQ.2) IOFF=17
6287 IF(IVAR.EQ.3) IOFF=7
6288 IF(IVAR.EQ.4) IOFF=12
6289 DO 310 IBIN=1,NBIN
6290 ICOF=IOFF+IBIN
6291 IF(IVAR.EQ.1.AND.IBIN.GT.2+2*MINT(72)) ICOF=7
6292 IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
6293 COEF(ISUB,ICOF)=COEFO(IBIN)
6294 310 CONTINUE
6295 IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR),
6296 & (COEFO(IBIN),IBIN=1,NBIN)
6297 320 CONTINUE
6298
6299C...Find two most promising maxima among points previously determined.
6300 DO 330 J=1,4
6301 IACCMX(J)=0
6302 SIGSMX(J)=0D0
6303 330 CONTINUE
6304 NMAX=0
6305 DO 390 IACC=1,NACC
6306 DO 340 J=1,30
6307 VINT(10+J)=VINTPT(IACC,J)
6308 340 CONTINUE
6309 IF(ISTSB.NE.5) THEN
6310 CALL PYSIGH(NCHN,SIGS)
6311 IF(MWTXS.EQ.1) THEN
6312 CALL PYEVWT(WTXS)
6313 SIGS=WTXS*SIGS
6314 ENDIF
6315 ELSE
6316 SIGS=0D0
6317 DO 350 IKIN3=1,MSTP(129)
6318 CALL PYKMAP(5,0,0D0)
6319 IF(MINT(51).EQ.1) GOTO 350
6320 CALL PYSIGH(NCHN,SIGTMP)
6321 IF(MWTXS.EQ.1) THEN
6322 CALL PYEVWT(WTXS)
6323 SIGTMP=WTXS*SIGTMP
6324 ENDIF
6325 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
6326 350 CONTINUE
6327 ENDIF
6328 IEQ=0
6329 DO 360 IMV=1,NMAX
6330 IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
6331 360 CONTINUE
6332 IF(IEQ.EQ.0) THEN
6333 DO 370 IMV=NMAX,1,-1
6334 IIN=IMV+1
6335 IF(SIGS.LE.SIGSMX(IMV)) GOTO 380
6336 IACCMX(IMV+1)=IACCMX(IMV)
6337 SIGSMX(IMV+1)=SIGSMX(IMV)
6338 370 CONTINUE
6339 IIN=1
6340 380 IACCMX(IIN)=IACC
6341 SIGSMX(IIN)=SIGS
6342 IF(NMAX.LE.1) NMAX=NMAX+1
6343 ENDIF
6344 390 CONTINUE
6345
6346C...Read out starting position for search.
6347 IF(MSTP(122).GE.2) WRITE(MSTU(11),5700)
6348 SIGSAM=SIGSMX(1)
6349 DO 440 IMAX=1,NMAX
6350 IACC=IACCMX(IMAX)
6351 MTAU=MVARPT(IACC,1)
6352 MTAUP=MVARPT(IACC,2)
6353 MYST=MVARPT(IACC,3)
6354 MCTH=MVARPT(IACC,4)
6355 VTAU=0.5D0
6356 VYST=0.5D0
6357 VCTH=0.5D0
6358 VTAUP=0.5D0
6359
6360C...Starting point and step size in parameter space.
6361 DO 430 IRPT=1,2
6362 DO 420 IVAR=1,4
6363 IF(NPTS(IVAR).EQ.1) GOTO 420
6364 IF(IVAR.EQ.1) VVAR=VTAU
6365 IF(IVAR.EQ.2) VVAR=VTAUP
6366 IF(IVAR.EQ.3) VVAR=VYST
6367 IF(IVAR.EQ.4) VVAR=VCTH
6368 IF(IVAR.EQ.1) MVAR=MTAU
6369 IF(IVAR.EQ.2) MVAR=MTAUP
6370 IF(IVAR.EQ.3) MVAR=MYST
6371 IF(IVAR.EQ.4) MVAR=MCTH
6372 IF(IRPT.EQ.1) VDEL=0.1D0
6373 IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0,
6374 & 0.98D0-VVAR))
6375 IF(IRPT.EQ.1) VMAR=0.02D0
6376 IF(IRPT.EQ.2) VMAR=0.002D0
6377 IMOV0=1
6378 IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
6379 DO 410 IMOV=IMOV0,8
6380
6381C...Define new point in parameter space.
6382 IF(IMOV.EQ.0) THEN
6383 INEW=2
6384 VNEW=VVAR
6385 ELSEIF(IMOV.EQ.1) THEN
6386 INEW=3
6387 VNEW=VVAR+VDEL
6388 ELSEIF(IMOV.EQ.2) THEN
6389 INEW=1
6390 VNEW=VVAR-VDEL
6391 ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
6392 & VVAR+2D0*VDEL.LT.1D0-VMAR) THEN
6393 VVAR=VVAR+VDEL
6394 SIGSSM(1)=SIGSSM(2)
6395 SIGSSM(2)=SIGSSM(3)
6396 INEW=3
6397 VNEW=VVAR+VDEL
6398 ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
6399 & VVAR-2D0*VDEL.GT.VMAR) THEN
6400 VVAR=VVAR-VDEL
6401 SIGSSM(3)=SIGSSM(2)
6402 SIGSSM(2)=SIGSSM(1)
6403 INEW=1
6404 VNEW=VVAR-VDEL
6405 ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
6406 VDEL=0.5D0*VDEL
6407 VVAR=VVAR+VDEL
6408 SIGSSM(1)=SIGSSM(2)
6409 INEW=2
6410 VNEW=VVAR
6411 ELSE
6412 VDEL=0.5D0*VDEL
6413 VVAR=VVAR-VDEL
6414 SIGSSM(3)=SIGSSM(2)
6415 INEW=2
6416 VNEW=VVAR
6417 ENDIF
6418
6419C...Convert to relevant variables and find derived new limits.
6420 ILERR=0
6421 IF(IVAR.EQ.1) THEN
6422 VTAU=VNEW
6423 CALL PYKMAP(1,MTAU,VTAU)
6424 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
6425 CALL PYKLIM(4)
6426 IF(MINT(51).EQ.1) ILERR=1
6427 ENDIF
6428 ENDIF
6429 IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
6430 & ILERR.EQ.0) THEN
6431 IF(IVAR.EQ.2) VTAUP=VNEW
6432 CALL PYKMAP(4,MTAUP,VTAUP)
6433 ENDIF
6434 IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
6435 CALL PYKLIM(2)
6436 IF(MINT(51).EQ.1) ILERR=1
6437 ENDIF
6438 IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
6439 IF(IVAR.EQ.3) VYST=VNEW
6440 CALL PYKMAP(2,MYST,VYST)
6441 CALL PYKLIM(3)
6442 IF(MINT(51).EQ.1) ILERR=1
6443 ENDIF
6444 IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
6445 & ILERR.EQ.0) THEN
6446 IF(IVAR.EQ.4) VCTH=VNEW
6447 CALL PYKMAP(3,MCTH,VCTH)
6448 ENDIF
6449 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
6450
6451C...Evaluate cross-section. Save new maximum. Final maximum.
6452 IF(ILERR.NE.0) THEN
6453 SIGS=0.
6454 ELSEIF(ISTSB.NE.5) THEN
6455 CALL PYSIGH(NCHN,SIGS)
6456 IF(MWTXS.EQ.1) THEN
6457 CALL PYEVWT(WTXS)
6458 SIGS=WTXS*SIGS
6459 ENDIF
6460 ELSE
6461 SIGS=0D0
6462 DO 400 IKIN3=1,MSTP(129)
6463 CALL PYKMAP(5,0,0D0)
6464 IF(MINT(51).EQ.1) GOTO 400
6465 CALL PYSIGH(NCHN,SIGTMP)
6466 IF(MWTXS.EQ.1) THEN
6467 CALL PYEVWT(WTXS)
6468 SIGTMP=WTXS*SIGTMP
6469 ENDIF
6470 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
6471 400 CONTINUE
6472 ENDIF
6473 SIGSSM(INEW)=SIGS
6474 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
6475 IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
6476 & IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
6477 410 CONTINUE
6478 420 CONTINUE
6479 430 CONTINUE
6480 440 CONTINUE
6481 IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
6482 XSEC(ISUB,1)=1.05D0*SIGSAM
6483 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
6484 & WTGAGA*XSEC(ISUB,1)
6485 450 CONTINUE
6486 IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
6487 & PARP(174)*XSEC(ISUB,1)
6488 IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
6489 460 CONTINUE
6490 MINT(51)=0
6491
6492C...Print summary table.
6493 IF(MINT(121).EQ.1.AND.NPOSI.EQ.0) THEN
6494 IF(MSTP(127).NE.1) THEN
6495 WRITE(MSTU(11),5900)
6496 STOP
6497 ELSE
6498 WRITE(MSTU(11),6400)
6499 MSTI(53)=1
6500 ENDIF
6501 ENDIF
6502 IF(MSTP(122).GE.1) THEN
6503 WRITE(MSTU(11),6000)
6504 WRITE(MSTU(11),6100)
6505 DO 470 ISUB=1,500
6506 IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470
6507 IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470
6508 IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MSTP(81).LE.0) GOTO 470
6509 IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470
6510 IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13
6511 & .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470
6512 WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1)
6513 470 CONTINUE
6514 WRITE(MSTU(11),6300)
6515 ENDIF
6516
6517C...Format statements for maximization results.
6518 5000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
6519 &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X,
6520 &'cth',9X,'tau''',7X,'sigma')
6521 5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ',
6522 &'phase space.'/1X,'Process switched off!')
6523 5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4)
6524 5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ',
6525 &'cross-section.'/1X,'Process switched off!')
6526 5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
6527 5500 FORMAT(1X,1P,8D11.3)
6528 5600 FORMAT(1X,'Result for ',A4,':',7F9.4)
6529 5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
6530 &'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
6531 5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4)
6532 5900 FORMAT(1X,'Error: no requested process has non-vanishing ',
6533 &'cross-section.'/1X,'Execution stopped!')
6534 6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
6535 &'cross-section maximum search',1X,8('*'))
6536 6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ',
6537 &'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I',
6538 &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
6539 6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I')
6540 6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
6541 6400 FORMAT(1X,'Error: no requested process has non-vanishing ',
6542 &'cross-section.'/
6543 &1X,'Execution will stop if you try to generate events.')
6544
6545 RETURN
6546 END
6547
6548C*********************************************************************
6549
6550C...PYPILE
6551C...Initializes multiplicity distribution and selects mutliplicity
6552C...of pileup events, i.e. several events occuring at the same
6553C...beam crossing.
6554
6555 SUBROUTINE PYPILE(MPILE)
6556
6557C...Double precision and integer declarations.
6558 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6559 IMPLICIT INTEGER(I-N)
6560 INTEGER PYK,PYCHGE,PYCOMP
6561C...Commonblocks.
6562 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6563 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6564 COMMON/PYINT1/MINT(400),VINT(400)
6565 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
6566 SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
6567C...Local arrays and saved variables.
6568 DIMENSION WTI(0:200)
6569 SAVE IMIN,IMAX,WTI,WTS
6570
6571C...Sum of allowed cross-sections for pileup events.
6572 IF(MPILE.EQ.1) THEN
6573 VINT(131)=SIGT(0,0,5)
6574 IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
6575 IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
6576 IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
6577 IF(MSTP(133).LE.0) RETURN
6578
6579C...Initialize multiplicity distribution at maximum.
6580 XNAVE=VINT(131)*PARP(131)
6581 IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
6582 INAVE=MAX(1,MIN(200,NINT(XNAVE)))
6583 WTI(INAVE)=1D0
6584 WTS=WTI(INAVE)
6585 WTN=WTI(INAVE)*INAVE
6586
6587C...Find shape of multiplicity distribution below maximum.
6588 IMIN=INAVE
6589 DO 100 I=INAVE-1,1,-1
6590 IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
6591 IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
6592 IF(WTI(I).LT.1D-6) GOTO 110
6593 WTS=WTS+WTI(I)
6594 WTN=WTN+WTI(I)*I
6595 IMIN=I
6596 100 CONTINUE
6597
6598C...Find shape of multiplicity distribution above maximum.
6599 110 IMAX=INAVE
6600 DO 120 I=INAVE+1,200
6601 IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
6602 IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
6603 IF(WTI(I).LT.1D-6) GOTO 130
6604 WTS=WTS+WTI(I)
6605 WTN=WTN+WTI(I)*I
6606 IMAX=I
6607 120 CONTINUE
6608 130 VINT(132)=XNAVE
6609 VINT(133)=WTN/WTS
6610 IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
6611 & WTS/(WTS+WTI(1)/XNAVE)
6612 IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
6613 IF(MSTP(133).GE.2) VINT(134)=XNAVE
6614
6615C...Pick multiplicity of pileup events.
6616 ELSE
6617 IF(MSTP(133).LE.0) THEN
6618 MINT(81)=MAX(1,MSTP(134))
6619 ELSE
6620 WTR=WTS*PYR(0)
6621 DO 140 I=IMIN,IMAX
6622 MINT(81)=I
6623 WTR=WTR-WTI(I)
6624 IF(WTR.LE.0D0) GOTO 150
6625 140 CONTINUE
6626 150 CONTINUE
6627 ENDIF
6628 ENDIF
6629
6630C...Format statement for error message.
6631 5000 FORMAT(1X,'Warning: requested average number of events per bunch',
6632 &'crossing too large, ',1P,D12.4)
6633
6634 RETURN
6635 END
6636
6637C*********************************************************************
6638
6639C...PYSAVE
6640C...Saves and restores parameter and cross section values for the
6641C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alternatives.
6642C...Also makes random choice between alternatives.
6643
6644 SUBROUTINE PYSAVE(ISAVE,IGA)
6645
6646C...Double precision and integer declarations.
6647 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6648 IMPLICIT INTEGER(I-N)
6649 INTEGER PYK,PYCHGE,PYCOMP
6650C...Commonblocks.
6651 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
6652 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6653 COMMON/PYINT1/MINT(400),VINT(400)
6654 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
6655 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6656 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
6657 SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/,/PYINT7/
6658C...Local arrays and saved variables.
6659 DIMENSION NCP(15),NSUBCP(15,20),MSUBCP(15,20),COEFCP(15,20,20),
6660 &NGENCP(15,0:20,3),XSECCP(15,0:20,3),SIGTCP(15,0:6,0:6,0:5),
6661 &INTCP(15,20),RECP(15,20)
6662 SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,SIGTCP,INTCP,RECP
6663
6664C...Save list of subprocesses and cross-section information.
6665 IF(ISAVE.EQ.1) THEN
6666 ICP=0
6667 DO 120 I=1,500
6668 IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
6669 ICP=ICP+1
6670 NSUBCP(IGA,ICP)=I
6671 MSUBCP(IGA,ICP)=MSUB(I)
6672 DO 100 J=1,20
6673 COEFCP(IGA,ICP,J)=COEF(I,J)
6674 100 CONTINUE
6675 DO 110 J=1,3
6676 NGENCP(IGA,ICP,J)=NGEN(I,J)
6677 XSECCP(IGA,ICP,J)=XSEC(I,J)
6678 110 CONTINUE
6679 120 CONTINUE
6680 NCP(IGA)=ICP
6681 DO 130 J=1,3
6682 NGENCP(IGA,0,J)=NGEN(0,J)
6683 XSECCP(IGA,0,J)=XSEC(0,J)
6684 130 CONTINUE
6685 DO 160 I1=0,6
6686 DO 150 I2=0,6
6687 DO 140 J=0,5
6688 SIGTCP(IGA,I1,I2,J)=SIGT(I1,I2,J)
6689 140 CONTINUE
6690 150 CONTINUE
6691 160 CONTINUE
6692
6693C...Save various common process variables.
6694 DO 170 J=1,10
6695 INTCP(IGA,J)=MINT(40+J)
6696 170 CONTINUE
6697 INTCP(IGA,11)=MINT(101)
6698 INTCP(IGA,12)=MINT(102)
6699 INTCP(IGA,13)=MINT(107)
6700 INTCP(IGA,14)=MINT(108)
6701 INTCP(IGA,15)=MINT(123)
6702 RECP(IGA,1)=CKIN(3)
6703 RECP(IGA,2)=VINT(318)
6704
6705C...Save cross-section information only.
6706 ELSEIF(ISAVE.EQ.2) THEN
6707 DO 190 ICP=1,NCP(IGA)
6708 I=NSUBCP(IGA,ICP)
6709 DO 180 J=1,3
6710 NGENCP(IGA,ICP,J)=NGEN(I,J)
6711 XSECCP(IGA,ICP,J)=XSEC(I,J)
6712 180 CONTINUE
6713 190 CONTINUE
6714 DO 200 J=1,3
6715 NGENCP(IGA,0,J)=NGEN(0,J)
6716 XSECCP(IGA,0,J)=XSEC(0,J)
6717 200 CONTINUE
6718
6719C...Choose between allowed alternatives.
6720 ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
6721 IF(ISAVE.EQ.4) THEN
6722 XSUMCP=0D0
6723 DO 210 IG=1,MINT(121)
6724 XSUMCP=XSUMCP+XSECCP(IG,0,1)
6725 210 CONTINUE
6726 XSUMCP=XSUMCP*PYR(0)
6727 DO 220 IG=1,MINT(121)
6728 IGA=IG
6729 XSUMCP=XSUMCP-XSECCP(IG,0,1)
6730 IF(XSUMCP.LE.0D0) GOTO 230
6731 220 CONTINUE
6732 230 CONTINUE
6733 ENDIF
6734
6735C...Restore cross-section information.
6736 DO 240 I=1,500
6737 MSUB(I)=0
6738 240 CONTINUE
6739 DO 270 ICP=1,NCP(IGA)
6740 I=NSUBCP(IGA,ICP)
6741 MSUB(I)=MSUBCP(IGA,ICP)
6742 DO 250 J=1,20
6743 COEF(I,J)=COEFCP(IGA,ICP,J)
6744 250 CONTINUE
6745 DO 260 J=1,3
6746 NGEN(I,J)=NGENCP(IGA,ICP,J)
6747 XSEC(I,J)=XSECCP(IGA,ICP,J)
6748 260 CONTINUE
6749 270 CONTINUE
6750 DO 280 J=1,3
6751 NGEN(0,J)=NGENCP(IGA,0,J)
6752 XSEC(0,J)=XSECCP(IGA,0,J)
6753 280 CONTINUE
6754 DO 310 I1=0,6
6755 DO 300 I2=0,6
6756 DO 290 J=0,5
6757 SIGT(I1,I2,J)=SIGTCP(IGA,I1,I2,J)
6758 290 CONTINUE
6759 300 CONTINUE
6760 310 CONTINUE
6761
6762C...Restore various common process variables.
6763 DO 320 J=1,10
6764 MINT(40+J)=INTCP(IGA,J)
6765 320 CONTINUE
6766 MINT(101)=INTCP(IGA,11)
6767 MINT(102)=INTCP(IGA,12)
6768 MINT(107)=INTCP(IGA,13)
6769 MINT(108)=INTCP(IGA,14)
6770 MINT(123)=INTCP(IGA,15)
6771 CKIN(3)=RECP(IGA,1)
6772 CKIN(1)=2D0*CKIN(3)
6773 VINT(318)=RECP(IGA,2)
6774
6775C...Sum up cross-section info (for PYSTAT).
6776 ELSEIF(ISAVE.EQ.5) THEN
6777 DO 330 I=1,500
6778 MSUB(I)=0
6779 NGEN(I,1)=0
6780 NGEN(I,3)=0
6781 XSEC(I,3)=0D0
6782 330 CONTINUE
6783 NGEN(0,1)=0
6784 NGEN(0,2)=0
6785 NGEN(0,3)=0
6786 XSEC(0,3)=0
6787 DO 350 IG=1,MINT(121)
6788 DO 340 ICP=1,NCP(IG)
6789 I=NSUBCP(IG,ICP)
6790 IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1
6791 NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1)
6792 NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3)
6793 XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3)
6794 340 CONTINUE
6795 NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1)
6796 NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2)
6797 NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3)
6798 XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3)
6799 350 CONTINUE
6800 ENDIF
6801
6802 RETURN
6803 END
6804
6805C*********************************************************************
6806
6807C...PYGAGA
6808C...For lepton beams it gives photon-hadron or photon-photon systems
6809C...to be treated with the ordinary machinery and combines this with a
6810C...description of the lepton -> lepton + photon branching.
6811
6812 SUBROUTINE PYGAGA(IGAGA,WTGAGA)
6813
6814C...Double precision and integer declarations.
6815 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6816 IMPLICIT INTEGER(I-N)
6817 INTEGER PYK,PYCHGE,PYCOMP
6818C...Commonblocks.
6819 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
6820 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6821 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6822 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
6823 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6824 COMMON/PYINT1/MINT(400),VINT(400)
6825 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6826 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
6827 &/PYINT5/
6828C...Local variables and data statement.
6829 DIMENSION PMS(2),XMIN(2),XMAX(2),Q2MIN(2),Q2MAX(2),PMC(3),
6830 &X(2),Q2(2),Y(2),THETA(2),PHI(2),PT(2),BETA(3)
6831 SAVE PMS,XMIN,XMAX,Q2MIN,Q2MAX,PMC,X,Q2,THETA,PHI,PT,W2MIN
6832 DATA EPS/1D-4/
6833
6834C...Initialize generation of photons inside leptons.
6835 IF(IGAGA.EQ.1) THEN
6836
6837C...Save quantities on incoming lepton system.
6838 VINT(301)=VINT(1)
6839 VINT(302)=VINT(2)
6840 PMS(1)=VINT(303)**2
6841 IF(MINT(141).EQ.0) PMS(1)=SIGN(VINT(3)**2,VINT(3))
6842 PMS(2)=VINT(304)**2
6843 IF(MINT(142).EQ.0) PMS(2)=SIGN(VINT(4)**2,VINT(4))
6844 PMC(3)=VINT(302)-PMS(1)-PMS(2)
6845 W2MIN=MAX(CKIN(77),2D0*CKIN(3),2D0*CKIN(5))**2
6846
6847C...Calculate range of x and Q2 values allowed in generation.
6848 DO 100 I=1,2
6849 PMC(I)=VINT(302)+PMS(I)-PMS(3-I)
6850 IF(MINT(140+I).NE.0) THEN
6851 XMIN(I)=MAX(CKIN(59+2*I),EPS)
6852 XMAX(I)=MIN(CKIN(60+2*I),1D0-2D0*VINT(301)*SQRT(PMS(I))/
6853 & PMC(I),1D0-EPS)
6854 YMIN=MAX(CKIN(71+2*I),EPS)
6855 YMAX=MIN(CKIN(72+2*I),1D0-EPS)
6856 IF(CKIN(64+2*I).GT.0D0) XMIN(I)=MAX(XMIN(I),
6857 & (YMIN*PMC(3)-CKIN(64+2*I))/PMC(I))
6858 XMAX(I)=MIN(XMAX(I),(YMAX*PMC(3)-CKIN(63+2*I))/PMC(I))
6859 THEMIN=MAX(CKIN(67+2*I),0D0)
6860 THEMAX=MIN(CKIN(68+2*I),PARU(1))
6861 IF(CKIN(68+2*I).LT.0D0) THEMAX=PARU(1)
6862 Q2MIN(I)=MAX(CKIN(63+2*I),XMIN(I)**2*PMS(I)/(1D0-XMIN(I))+
6863 & ((1D0-XMAX(I))*(VINT(302)-2D0*PMS(3-I))-
6864 & 2D0*PMS(I)/(1D0-XMAX(I)))*SIN(THEMIN/2D0)**2,0D0)
6865 Q2MAX(I)=XMAX(I)**2*PMS(I)/(1D0-XMAX(I))+
6866 & ((1D0-XMIN(I))*(VINT(302)-2D0*PMS(3-I))-
6867 & 2D0*PMS(I)/(1D0-XMIN(I)))*SIN(THEMAX/2D0)**2
6868 IF(CKIN(64+2*I).GT.0D0) Q2MAX(I)=MIN(CKIN(64+2*I),Q2MAX(I))
6869C...W limits when lepton on one side only.
6870 IF(MINT(143-I).EQ.0) THEN
6871 XMIN(I)=MAX(XMIN(I),(W2MIN-PMS(3-I))/PMC(I))
6872 IF(CKIN(78).GT.0D0) XMAX(I)=MIN(XMAX(I),
6873 & (CKIN(78)**2-PMS(3-I))/PMC(I))
6874 ENDIF
6875 ENDIF
6876 100 CONTINUE
6877
6878C...W limits when lepton on both sides.
6879 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
6880 IF(CKIN(78).GT.0D0) XMAX(1)=MIN(XMAX(1),
6881 & (CKIN(78)**2+PMC(3)-PMC(2)*XMIN(2))/PMC(1))
6882 IF(CKIN(78).GT.0D0) XMAX(2)=MIN(XMAX(2),
6883 & (CKIN(78)**2+PMC(3)-PMC(1)*XMIN(1))/PMC(2))
6884 IF(IABS(MINT(141)).NE.IABS(MINT(142))) THEN
6885 XMIN(1)=MAX(XMIN(1),(PMS(1)-PMS(2)+VINT(302)*(W2MIN-
6886 & PMS(1)-PMS(2))/(PMC(2)*XMAX(2)+PMS(1)-PMS(2)))/PMC(1))
6887 XMIN(2)=MAX(XMIN(2),(PMS(2)-PMS(1)+VINT(302)*(W2MIN-
6888 & PMS(1)-PMS(2))/(PMC(1)*XMAX(1)+PMS(2)-PMS(1)))/PMC(2))
6889 ELSE
6890 XMIN(1)=MAX(XMIN(1),W2MIN/(VINT(302)*XMAX(2)))
6891 XMIN(2)=MAX(XMIN(2),W2MIN/(VINT(302)*XMAX(1)))
6892 ENDIF
6893 ENDIF
6894
6895C...Q2 and W values and photon flux weight factors for initialization.
6896 ELSEIF(IGAGA.EQ.2) THEN
6897 ISUB=MINT(1)
6898 MINT(15)=0
6899 MINT(16)=0
6900
6901C...W value for photon on one or both sides, and for processes
6902C...with gamma-gamma cross section peaked at small shat.
6903 IF(MINT(141).NE.0.AND.MINT(142).EQ.0) THEN
6904 VINT(2)=VINT(302)+PMS(1)-PMC(1)*(1D0-XMAX(1))
6905 ELSEIF(MINT(141).EQ.0.AND.MINT(142).NE.0) THEN
6906 VINT(2)=VINT(302)+PMS(2)-PMC(2)*(1D0-XMAX(2))
6907 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
6908 VINT(2)=MAX(CKIN(77)**2,12D0*MAX(CKIN(3),CKIN(5))**2)
6909 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
6910 ELSE
6911 VINT(2)=XMAX(1)*XMAX(2)*VINT(302)
6912 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
6913 ENDIF
6914 VINT(1)=SQRT(MAX(0D0,VINT(2)))
6915
6916C...Upper estimate of photon flux weight factor.
6917C...Initialization Q2 scale. Flag incoming unresolved photon.
6918 WTGAGA=1D0
6919 DO 110 I=1,2
6920 IF(MINT(140+I).NE.0) THEN
6921 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
6922 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
6923 IF(ISUB.EQ.99.AND.MINT(106+I).EQ.4.AND.MINT(109-I).EQ.3)
6924 & THEN
6925 Q2INIT=5D0+Q2MIN(3-I)
6926 ELSEIF(ISUB.EQ.99.AND.MINT(106+I).EQ.4) THEN
6927 Q2INIT=PMAS(PYCOMP(113),1)**2+Q2MIN(3-I)
6928 ELSEIF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
6929 Q2INIT=MAX(CKIN(1),2D0*CKIN(3),2D0*CKIN(5))**2/3D0
6930 ELSEIF((ISUB.EQ.138.AND.I.EQ.2).OR.
6931 & (ISUB.EQ.139.AND.I.EQ.1)) THEN
6932 Q2INIT=VINT(2)/3D0
6933 ELSEIF(ISUB.EQ.140) THEN
6934 Q2INIT=VINT(2)/2D0
6935 ELSE
6936 Q2INIT=Q2MIN(I)
6937 ENDIF
6938 VINT(2+I)=-SQRT(MAX(Q2MIN(I),MIN(Q2MAX(I),Q2INIT)))
6939 IF(MSTP(14).EQ.0.OR.(ISUB.GE.131.AND.ISUB.LE.140))
6940 & MINT(14+I)=22
6941 VINT(306+I)=VINT(2+I)**2
6942 ENDIF
6943 110 CONTINUE
6944 VINT(320)=WTGAGA
6945
6946C...Update pTmin and cross section information.
6947 IF(MSTP(82).LE.1) THEN
6948 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
6949 ELSE
6950 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
6951 ENDIF
6952 VINT(149)=4D0*PTMN**2/VINT(2)
6953 VINT(154)=PTMN
6954 CALL PYXTOT
6955 VINT(318)=VINT(317)
6956
6957C...Generate photons inside leptons and
6958C...calculate photon flux weight factors.
6959 ELSEIF(IGAGA.EQ.3) THEN
6960 ISUB=MINT(1)
6961 MINT(15)=0
6962 MINT(16)=0
6963
6964C...Generate phase space point and check against cuts.
6965 LOOP=0
6966 120 LOOP=LOOP+1
6967 DO 130 I=1,2
6968 IF(MINT(140+I).NE.0) THEN
6969C...Pick x and Q2
6970 X(I)=XMIN(I)*(XMAX(I)/XMIN(I))**PYR(0)
6971 Q2(I)=Q2MIN(I)*(Q2MAX(I)/Q2MIN(I))**PYR(0)
6972C...Cuts on internal consistency in x and Q2.
6973 IF(Q2(I).LT.X(I)**2*PMS(I)/(1D0-X(I))) GOTO 120
6974 IF(Q2(I).GT.(1D0-X(I))*(VINT(302)-2D0*PMS(3-I))-
6975 & (2D0-X(I)**2)*PMS(I)/(1D0-X(I))) GOTO 120
6976C...Cuts on y and theta.
6977 Y(I)=(PMC(I)*X(I)+Q2(I))/PMC(3)
6978 IF(Y(I).LT.CKIN(71+2*I).OR.Y(I).GT.CKIN(72+2*I)) GOTO 120
6979 RAT=((1D0-X(I))*Q2(I)-X(I)**2*PMS(I))/
6980 & ((1D0-X(I))**2*(VINT(302)-2D0*PMS(3-I)-2D0*PMS(I)))
6981 THETA(I)=2D0*ASIN(SQRT(MAX(0D0,MIN(1D0,RAT))))
6982 IF(THETA(I).LT.CKIN(67+2*I)) GOTO 120
6983 IF(CKIN(68+2*I).GT.0D0.AND.THETA(I).GT.CKIN(68+2*I))
6984 & GOTO 120
6985
6986C...Phi angle isotropic. Reconstruct pT.
6987 PHI(I)=PARU(2)*PYR(0)
6988 PT(I)=SQRT(((1D0-X(I))*PMC(I))**2/(4D0*VINT(302))-
6989 & PMS(I))*SIN(THETA(I))
6990
6991C...Store info on variables selected, for documentation purposes.
6992 VINT(2+I)=-SQRT(Q2(I))
6993 VINT(304+I)=X(I)
6994 VINT(306+I)=Q2(I)
6995 VINT(308+I)=Y(I)
6996 VINT(310+I)=THETA(I)
6997 VINT(312+I)=PHI(I)
6998 ELSE
6999 VINT(304+I)=1D0
7000 VINT(306+I)=0D0
7001 VINT(308+I)=1D0
7002 VINT(310+I)=0D0
7003 VINT(312+I)=0D0
7004 ENDIF
7005 130 CONTINUE
7006
7007C...Cut on W combines info from two sides.
7008 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
7009 W2=-Q2(1)-Q2(2)+0.5D0*X(1)*PMC(1)*X(2)*PMC(2)/VINT(302)-
7010 & 2D0*PT(1)*PT(2)*COS(PHI(1)-PHI(2))+2D0*
7011 & SQRT((0.5D0*X(1)*PMC(1)/VINT(301))**2+Q2(1)-PT(1)**2)*
7012 & SQRT((0.5D0*X(2)*PMC(2)/VINT(301))**2+Q2(2)-PT(2)**2)
7013 IF(W2.LT.W2MIN) GOTO 120
7014 IF(CKIN(78).GT.0D0.AND.W2.GT.CKIN(78)**2) GOTO 120
7015 PMS1=-Q2(1)
7016 PMS2=-Q2(2)
7017 ELSEIF(MINT(141).NE.0) THEN
7018 W2=(VINT(302)+PMS(1))*X(1)+PMS(2)*(1D0-X(1))
7019 PMS1=-Q2(1)
7020 PMS2=PMS(2)
7021 ELSEIF(MINT(142).NE.0) THEN
7022 W2=(VINT(302)+PMS(2))*X(2)+PMS(1)*(1D0-X(2))
7023 PMS1=PMS(1)
7024 PMS2=-Q2(2)
7025 ENDIF
7026
7027C...Store kinematics info for photon(s) in subsystem cm frame.
7028 VINT(2)=W2
7029 VINT(1)=SQRT(W2)
7030 VINT(291)=0D0
7031 VINT(292)=0D0
7032 VINT(293)=0.5D0*SQRT((W2-PMS1-PMS2)**2-4D0*PMS1*PMS2)/VINT(1)
7033 VINT(294)=0.5D0*(W2+PMS1-PMS2)/VINT(1)
7034 VINT(295)=SIGN(SQRT(ABS(PMS1)),PMS1)
7035 VINT(296)=0D0
7036 VINT(297)=0D0
7037 VINT(298)=-VINT(293)
7038 VINT(299)=0.5D0*(W2+PMS2-PMS1)/VINT(1)
7039 VINT(300)=SIGN(SQRT(ABS(PMS2)),PMS2)
7040
7041C...Assign weight for photon flux; different for transverse and
7042C...longitudinal photons. Flag incoming unresolved photon.
7043 WTGAGA=1D0
7044 DO 140 I=1,2
7045 IF(MINT(140+I).NE.0) THEN
7046 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
7047 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
7048 IF(MSTP(16).EQ.0) THEN
7049 XY=X(I)
7050 ELSE
7051 WTGAGA=WTGAGA*X(I)/Y(I)
7052 XY=Y(I)
7053 ENDIF
7054 IF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
7055 WTGAGA=WTGAGA*(1D0-XY)
7056 ELSEIF(I.EQ.1.AND.(ISUB.EQ.139.OR.ISUB.EQ.140)) THEN
7057 WTGAGA=WTGAGA*(1D0-XY)
7058 ELSEIF(I.EQ.2.AND.(ISUB.EQ.138.OR.ISUB.EQ.140)) THEN
7059 WTGAGA=WTGAGA*(1D0-XY)
7060 ELSE
7061 WTGAGA=WTGAGA*(0.5D0*(1D0+(1D0-XY)**2)-
7062 & PMS(I)*XY**2/Q2(I))
7063 ENDIF
7064 IF(MINT(106+I).EQ.0) MINT(14+I)=22
7065 ENDIF
7066 140 CONTINUE
7067 VINT(319)=WTGAGA
7068 MINT(143)=LOOP
7069
7070C...Update pTmin and cross section information.
7071 IF(MSTP(82).LE.1) THEN
7072 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
7073 ELSE
7074 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
7075 ENDIF
7076 VINT(149)=4D0*PTMN**2/VINT(2)
7077 VINT(154)=PTMN
7078 CALL PYXTOT
7079
7080C...Reconstruct kinematics of photons inside leptons.
7081 ELSEIF(IGAGA.EQ.4) THEN
7082
7083C...Make place for incoming particles and scattered leptons.
7084 MOVE=3
7085 IF(MINT(141).NE.0.AND.MINT(142).NE.0) MOVE=4
7086 MINT(4)=MINT(4)+MOVE
7087 DO 160 I=MINT(84)-MOVE,MINT(83)+1,-1
7088 IF(K(I,1).EQ.21) THEN
7089 DO 150 J=1,5
7090 K(I+MOVE,J)=K(I,J)
7091 P(I+MOVE,J)=P(I,J)
7092 V(I+MOVE,J)=V(I,J)
7093 150 CONTINUE
7094 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
7095 & K(I+MOVE,3)=K(I,3)+MOVE
7096 IF(K(I,4).GT.MINT(83).AND.K(I,4).LE.MINT(84))
7097 & K(I+MOVE,4)=K(I,4)+MOVE
7098 IF(K(I,5).GT.MINT(83).AND.K(I,5).LE.MINT(84))
7099 & K(I+MOVE,5)=K(I,5)+MOVE
7100 ENDIF
7101 160 CONTINUE
7102 DO 170 I=MINT(84)+1,N
7103 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
7104 & K(I,3)=K(I,3)+MOVE
7105 170 CONTINUE
7106
7107C...Fill in incoming particles.
7108 DO 190 I=MINT(83)+1,MINT(83)+MOVE
7109 DO 180 J=1,5
7110 K(I,J)=0
7111 P(I,J)=0D0
7112 V(I,J)=0D0
7113 180 CONTINUE
7114 190 CONTINUE
7115 DO 200 I=1,2
7116 K(MINT(83)+I,1)=21
7117 IF(MINT(140+I).NE.0) THEN
7118 K(MINT(83)+I,2)=MINT(140+I)
7119 P(MINT(83)+I,5)=VINT(302+I)
7120 ELSE
7121 K(MINT(83)+I,2)=MINT(10+I)
7122 P(MINT(83)+I,5)=VINT(2+I)
7123 ENDIF
7124 P(MINT(83)+I,3)=0.5D0*SQRT((PMC(3)**2-4D0*PMS(1)*PMS(2))/
7125 & VINT(302))*(-1D0)**(I+1)
7126 P(MINT(83)+I,4)=0.5D0*PMC(I)/VINT(301)
7127 200 CONTINUE
7128
7129C...New mother-daughter relations in documentation section.
7130 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
7131 K(MINT(83)+1,4)=MINT(83)+3
7132 K(MINT(83)+1,5)=MINT(83)+5
7133 K(MINT(83)+2,4)=MINT(83)+4
7134 K(MINT(83)+2,5)=MINT(83)+6
7135 K(MINT(83)+3,3)=MINT(83)+1
7136 K(MINT(83)+5,3)=MINT(83)+1
7137 K(MINT(83)+4,3)=MINT(83)+2
7138 K(MINT(83)+6,3)=MINT(83)+2
7139 ELSEIF(MINT(141).NE.0) THEN
7140 K(MINT(83)+1,4)=MINT(83)+3
7141 K(MINT(83)+1,5)=MINT(83)+4
7142 K(MINT(83)+2,4)=MINT(83)+5
7143 K(MINT(83)+3,3)=MINT(83)+1
7144 K(MINT(83)+4,3)=MINT(83)+1
7145 K(MINT(83)+5,3)=MINT(83)+2
7146 ELSEIF(MINT(142).NE.0) THEN
7147 K(MINT(83)+1,4)=MINT(83)+4
7148 K(MINT(83)+2,4)=MINT(83)+3
7149 K(MINT(83)+2,5)=MINT(83)+5
7150 K(MINT(83)+3,3)=MINT(83)+2
7151 K(MINT(83)+4,3)=MINT(83)+1
7152 K(MINT(83)+5,3)=MINT(83)+2
7153 ENDIF
7154
7155C...Fill scattered lepton(s).
7156 DO 210 I=1,2
7157 IF(MINT(140+I).NE.0) THEN
7158 LSC=MINT(83)+MIN(I+2,MOVE)
7159 K(LSC,1)=21
7160 K(LSC,2)=MINT(140+I)
7161 P(LSC,1)=PT(I)*COS(PHI(I))
7162 P(LSC,2)=PT(I)*SIN(PHI(I))
7163 P(LSC,4)=(1D0-X(I))*P(MINT(83)+I,4)
7164 P(LSC,3)=SQRT(P(LSC,4)**2-PMS(I))*COS(THETA(I))*
7165 & (-1D0)**(I-1)
7166 P(LSC,5)=VINT(302+I)
7167 ENDIF
7168 210 CONTINUE
7169
7170C...Find incoming four-vectors to subprocess.
7171 K(N+1,1)=21
7172 IF(MINT(141).NE.0) THEN
7173 DO 220 J=1,4
7174 P(N+1,J)=P(MINT(83)+1,J)-P(MINT(83)+3,J)
7175 220 CONTINUE
7176 ELSE
7177 DO 230 J=1,4
7178 P(N+1,J)=P(MINT(83)+1,J)
7179 230 CONTINUE
7180 ENDIF
7181 K(N+2,1)=21
7182 IF(MINT(142).NE.0) THEN
7183 DO 240 J=1,4
7184 P(N+2,J)=P(MINT(83)+2,J)-P(MINT(83)+MOVE,J)
7185 240 CONTINUE
7186 ELSE
7187 DO 250 J=1,4
7188 P(N+2,J)=P(MINT(83)+2,J)
7189 250 CONTINUE
7190 ENDIF
7191
7192C...Define boost and rotation between hadronic subsystem and
7193C...collision rest frame; boost hadronic subsystem to this frame.
7194 DO 260 J=1,3
7195 BETA(J)=(P(N+1,J)+P(N+2,J))/(P(N+1,4)+P(N+2,4))
7196 260 CONTINUE
7197 CALL PYROBO(N+1,N+2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
7198 BPHI=PYANGL(P(N+1,1),P(N+1,2))
7199 CALL PYROBO(N+1,N+2,0D0,-BPHI,0D0,0D0,0D0)
7200 BTHETA=PYANGL(P(N+1,3),P(N+1,1))
7201 CALL PYROBO(MINT(83)+MOVE+1,N,BTHETA,BPHI,BETA(1),BETA(2),
7202 & BETA(3))
7203
7204C...Add on scattered leptons to final state.
7205 DO 280 I=1,2
7206 IF(MINT(140+I).NE.0) THEN
7207 LSC=MINT(83)+MIN(I+2,MOVE)
7208 N=N+1
7209 DO 270 J=1,5
7210 K(N,J)=K(LSC,J)
7211 P(N,J)=P(LSC,J)
7212 V(N,J)=V(LSC,J)
7213 270 CONTINUE
7214 K(N,1)=1
7215 K(N,3)=LSC
7216 ENDIF
7217 280 CONTINUE
7218 ENDIF
7219
7220 RETURN
7221 END
7222
7223C*********************************************************************
7224
7225C...PYRAND
7226C...Generates quantities characterizing the high-pT scattering at the
7227C...parton level according to the matrix elements. Chooses incoming,
7228C...reacting partons, their momentum fractions and one of the possible
7229C...subprocesses.
7230
7231 SUBROUTINE PYRAND
7232
7233C...Double precision and integer declarations.
7234 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
7235 IMPLICIT INTEGER(I-N)
7236 INTEGER PYK,PYCHGE,PYCOMP
7237C...Parameter statement to help give large particle numbers.
7238 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
7239 &KEXCIT=4000000,KDIMEN=5000000)
7240
7241C...User process initialization and event commonblocks.
7242 INTEGER MAXPUP
7243 PARAMETER (MAXPUP=100)
7244 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
7245 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
7246 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
7247 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
7248 &LPRUP(MAXPUP)
7249 INTEGER MAXNUP
7250 PARAMETER (MAXNUP=500)
7251 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
7252 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
7253 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
7254 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
7255 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
7256 SAVE /HEPRUP/,/HEPEUP/
7257
7258C...Commonblocks.
7259 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7260 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
7261 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
7262 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
7263 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
7264 COMMON/PYINT1/MINT(400),VINT(400)
7265 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
7266 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
7267 COMMON/PYINT4/MWID(500),WIDS(500,5)
7268 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
7269 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
7270 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
7271 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
7272 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYMSSM/
7273C...Local arrays.
7274 DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2)
7275
7276C...Parameters and data used in elastic/diffractive treatment.
7277 DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/,
7278 &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
7279
7280C...Initial values, specifically for (first) semihard interaction.
7281 MINT(10)=0
7282 MINT(17)=0
7283 MINT(18)=0
7284 VINT(97)=1D0
7285 VINT(143)=1D0
7286 VINT(144)=1D0
7287 VINT(157)=0D0
7288 VINT(158)=0D0
7289 MFAIL=0
7290 IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1
7291 ISUB=0
7292 ISTSB=0
7293 LOOP=0
7294 100 LOOP=LOOP+1
7295 MINT(51)=0
7296 MINT(143)=1
7297
7298C...Start by assuming incoming photon is entering subprocess.
7299 IF(MINT(11).EQ.22) THEN
7300 MINT(15)=22
7301 VINT(307)=VINT(3)**2
7302 ENDIF
7303 IF(MINT(12).EQ.22) THEN
7304 MINT(16)=22
7305 VINT(308)=VINT(4)**2
7306 ENDIF
7307 MINT(103)=MINT(11)
7308 MINT(104)=MINT(12)
7309
7310C...Choice of process type - first event of pileup.
7311 INMULT=0
7312 IF(MINT(82).EQ.1.AND.ISUB.GE.91.AND.ISUB.LE.96) THEN
7313 ELSEIF(MINT(82).EQ.1) THEN
7314
7315C...For gamma-p or gamma-gamma first pick between alternatives.
7316 IGA=0
7317 IF(MINT(121).GT.1) CALL PYSAVE(4,IGA)
7318 MINT(122)=IGA
7319
7320C...For real gamma + gamma with different nature, flip at random.
7321 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
7322 & MSTP(14).LE.10.AND.PYR(0).GT.0.5D0) THEN
7323 MINTSV=MINT(41)
7324 MINT(41)=MINT(42)
7325 MINT(42)=MINTSV
7326 MINTSV=MINT(45)
7327 MINT(45)=MINT(46)
7328 MINT(46)=MINTSV
7329 MINTSV=MINT(107)
7330 MINT(107)=MINT(108)
7331 MINT(108)=MINTSV
7332 IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47)
7333 ENDIF
7334
7335C...Pick process type, possibly by user process machinery.
7336C...(If the latter, also event will be picked here.)
7337 IF(MINT(111).EQ.11.AND.IABS(IDWTUP).EQ.2.AND.LOOP.GE.2) THEN
7338 CALL UPEVNT
7339 ELSEIF(MINT(111).EQ.11.AND.IABS(IDWTUP).GE.3) THEN
7340 CALL UPEVNT
7341 ISUB=0
7342 110 ISUB=ISUB+1
7343 IF(KFPR(ISUB,2).NE.IDPRUP.AND.ISUB.LT.500) GOTO 110
7344 ELSE
7345 RSUB=XSEC(0,1)*PYR(0)
7346 DO 120 I=1,500
7347 IF(MSUB(I).NE.1) GOTO 120
7348 ISUB=I
7349 RSUB=RSUB-XSEC(I,1)
7350 IF(RSUB.LE.0D0) GOTO 130
7351 120 CONTINUE
7352 130 IF(ISUB.EQ.95) ISUB=96
7353 IF(ISUB.EQ.96) INMULT=1
7354 IF(ISET(ISUB).EQ.11) THEN
7355 IDPRUP=KFPR(ISUB,2)
7356 CALL UPEVNT
7357 ENDIF
7358 ENDIF
7359
7360C...Choice of inclusive process type - pileup events.
7361 ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
7362 RSUB=VINT(131)*PYR(0)
7363 ISUB=96
7364 IF(RSUB.GT.SIGT(0,0,5)) ISUB=94
7365 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93
7366 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92
7367 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2))
7368 & ISUB=91
7369 IF(ISUB.EQ.96) INMULT=1
7370 ENDIF
7371
7372C...Choice of photon energy and flux factor inside lepton.
7373 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
7374 CALL PYGAGA(3,WTGAGA)
7375 IF(ISUB.GE.131.AND.ISUB.LE.140) THEN
7376 CKIN(3)=MAX(VINT(285),VINT(154))
7377 CKIN(1)=2D0*CKIN(3)
7378 ENDIF
7379C...When necessary set direct/resolved photon by hand.
7380 ELSEIF(MINT(15).EQ.22.OR.MINT(16).EQ.22) THEN
7381 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
7382 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
7383 ENDIF
7384
7385C...Restrict direct*resolved processes to pTmin >= Q,
7386C...to avoid doublecounting with DIS.
7387 IF(MSTP(18).EQ.3.AND.ISUB.GE.131.AND.ISUB.LE.136) THEN
7388 IF(MINT(15).EQ.22) THEN
7389 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(3)))
7390 ELSE
7391 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(4)))
7392 ENDIF
7393 CKIN(1)=2D0*CKIN(3)
7394 ENDIF
7395
7396C...Set up for multiple interactions.
7397 IF(INMULT.EQ.1) CALL PYMULT(2)
7398
7399C...Loopback point for minimum bias in photon physics.
7400 LOOP2=0
7401 140 LOOP2=LOOP2+1
7402 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+MINT(143)
7403 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+MINT(143)
7404 IF(ISUB.EQ.96.AND.LOOP2.EQ.1.AND.MINT(82).EQ.1)
7405 &NGEN(97,1)=NGEN(97,1)+MINT(143)
7406 MINT(1)=ISUB
7407 ISTSB=ISET(ISUB)
7408
7409C...Random choice of flavour for some SUSY processes.
7410 IF(ISUB.GE.201.AND.ISUB.LE.301) THEN
7411C...~e_L ~nu_e or ~mu_L ~nu_mu.
7412 IF(ISUB.EQ.210) THEN
7413 KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0))
7414 KFPR(ISUB,2)=KFPR(ISUB,1)+1
7415C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
7416 ELSEIF(ISUB.EQ.213) THEN
7417 KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0))
7418 KFPR(ISUB,2)=KFPR(ISUB,1)
7419C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
7420 ELSEIF(ISUB.GE.246.AND.ISUB.LE.259) THEN
7421 IF(ISUB.GE.258) THEN
7422 RKF=4D0
7423 ELSE
7424 RKF=5D0
7425 ENDIF
7426 IF(MOD(ISUB,2).EQ.0) THEN
7427 KFPR(ISUB,1)=KSUSY1+1+INT(RKF*PYR(0))
7428 ELSE
7429 KFPR(ISUB,1)=KSUSY2+1+INT(RKF*PYR(0))
7430 ENDIF
7431C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
7432 ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN
7433 IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN
7434 KSU1=KSUSY1
7435 KSU2=KSUSY1
7436 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN
7437 KSU1=KSUSY2
7438 KSU2=KSUSY2
7439 ELSEIF(PYR(0).LT.0.5D0) THEN
7440 KSU1=KSUSY1
7441 KSU2=KSUSY2
7442 ELSE
7443 KSU1=KSUSY2
7444 KSU2=KSUSY1
7445 ENDIF
7446 KFPR(ISUB,1)=KSU1+1+INT(4D0*PYR(0))
7447 KFPR(ISUB,2)=KSU2+1+INT(4D0*PYR(0))
7448C...~q ~q(bar); ~q = ~d, ~u, ~s, or ~c.
7449 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN
7450 KFPR(ISUB,1)=KSUSY1+1+INT(4D0*PYR(0))
7451 KFPR(ISUB,2)=KFPR(ISUB,1)
7452 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN
7453 KFPR(ISUB,1)=KSUSY2+1+INT(4D0*PYR(0))
7454 KFPR(ISUB,2)=KFPR(ISUB,1)
7455C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
7456 ELSEIF(ISUB.GE.281.AND.ISUB.LE.286) THEN
7457 IF(ISUB.EQ.281.OR.ISUB.EQ.284) THEN
7458 KSU1=KSUSY1
7459 KSU2=KSUSY1
7460 ELSEIF(ISUB.EQ.282.OR.ISUB.EQ.285) THEN
7461 KSU1=KSUSY2
7462 KSU2=KSUSY2
7463 ELSEIF(PYR(0).LT.0.5D0) THEN
7464 KSU1=KSUSY1
7465 KSU2=KSUSY2
7466 ELSE
7467 KSU1=KSUSY2
7468 KSU2=KSUSY1
7469 ENDIF
7470 IF(ISUB.EQ.281.OR.ISUB.LE.283) THEN
7471 RKF=5D0
7472 ELSE
7473 RKF=4D0
7474 ENDIF
7475 KFPR(ISUB,2)=KSU2+1+INT(RKF*PYR(0))
7476 ENDIF
7477 ENDIF
7478
7479C...Find resonances (explicit or implicit in cross-section).
7480 MINT(72)=0
7481 KFR1=0
7482 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
7483 KFR1=KFPR(ISUB,1)
7484 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR.
7485 & ISUB.EQ.171.OR.ISUB.EQ.176) THEN
7486 KFR1=23
7487 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR.
7488 & ISUB.EQ.177) THEN
7489 KFR1=24
7490 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
7491 KFR1=25
7492 IF(MSTP(46).EQ.5) THEN
7493 KFR1=89
7494 PMAS(89,1)=PARP(45)
7495 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
7496 ENDIF
7497 ELSEIF(ISUB.EQ.194) THEN
7498 KFR1=KTECHN+113
7499 ELSEIF(ISUB.EQ.195) THEN
7500 KFR1=KTECHN+213
7501 ELSEIF(ISUB.GE.361.AND.ISUB.LE.368) THEN
7502 KFR1=KTECHN+113
7503 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
7504 KFR1=KTECHN+213
7505 ENDIF
7506 CKMX=CKIN(2)
7507 IF(CKMX.LE.0D0) CKMX=VINT(1)
7508 KCR1=PYCOMP(KFR1)
7509 IF(KFR1.NE.0) THEN
7510 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
7511 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
7512 ENDIF
7513 IF(KFR1.NE.0) THEN
7514 TAUR1=PMAS(KCR1,1)**2/VINT(2)
7515 IF(KFR1.EQ.KTECHN+113) THEN
7516 CALL PYTECM(S1,S2)
7517 TAUR1=S1/VINT(2)
7518 ENDIF
7519 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
7520 MINT(72)=1
7521 MINT(73)=KFR1
7522 VINT(73)=TAUR1
7523 VINT(74)=GAMR1
7524 ENDIF
7525 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.(ISUB.GE.364.AND.ISUB.LE.368))
7526 $THEN
7527 KFR2=23
7528 IF(ISUB.EQ.194) THEN
7529 KFR2=KTECHN+223
7530 ELSEIF(ISUB.GE.364.AND.ISUB.LE.368) THEN
7531 KFR2=KTECHN+223
7532 ENDIF
7533 KCR2=PYCOMP(KFR2)
7534 TAUR2=PMAS(KCR2,1)**2/VINT(2)
7535 IF(KFR2.EQ.KTECHN+223) THEN
7536 CALL PYTECM(S1,S2)
7537 TAUR2=S2/VINT(2)
7538 ENDIF
7539 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
7540 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
7541 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
7542 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
7543 MINT(72)=2
7544 MINT(74)=KFR2
7545 VINT(75)=TAUR2
7546 VINT(76)=GAMR2
7547 ELSEIF(KFR2.NE.0) THEN
7548 KFR1=KFR2
7549 TAUR1=TAUR2
7550 GAMR1=GAMR2
7551 MINT(72)=1
7552 MINT(73)=KFR1
7553 VINT(73)=TAUR1
7554 VINT(74)=GAMR1
7555 ENDIF
7556 ENDIF
7557
7558C...Find product masses and minimum pT of process,
7559C...optionally with broadening according to a truncated Breit-Wigner.
7560 VINT(63)=0D0
7561 VINT(64)=0D0
7562 MINT(71)=0
7563 VINT(71)=CKIN(3)
7564 IF(MINT(82).GE.2) VINT(71)=0D0
7565 VINT(80)=1D0
7566 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7567 NBW=0
7568 DO 160 I=1,2
7569 PMMN(I)=0D0
7570 IF(KFPR(ISUB,I).EQ.0) THEN
7571 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
7572 & PARP(41)) THEN
7573 VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7574 ELSE
7575 NBW=NBW+1
7576C...This prevents SUSY/t particles from becoming too light.
7577 KFLW=KFPR(ISUB,I)
7578 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
7579 KCW=PYCOMP(KFLW)
7580 PMMN(I)=PMAS(KCW,1)
7581 DO 150 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
7582 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
7583 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
7584 & PMAS(PYCOMP(KFDP(IDC,2)),1)
7585 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
7586 & PMAS(PYCOMP(KFDP(IDC,3)),1)
7587 PMMN(I)=MIN(PMMN(I),PMSUM)
7588 ENDIF
7589 150 CONTINUE
7590 ELSEIF(KFLW.EQ.6) THEN
7591 PMMN(I)=PMAS(24,1)+PMAS(5,1)
7592 ENDIF
7593 ENDIF
7594 160 CONTINUE
7595 IF(NBW.GE.1) THEN
7596 CKIN41=CKIN(41)
7597 CKIN43=CKIN(43)
7598 CKIN(41)=MAX(PMMN(1),CKIN(41))
7599 CKIN(43)=MAX(PMMN(2),CKIN(43))
7600 CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
7601 CKIN(41)=CKIN41
7602 CKIN(43)=CKIN43
7603 IF(MINT(51).EQ.1) THEN
7604 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7605 IF(MFAIL.EQ.1) THEN
7606 MSTI(61)=1
7607 RETURN
7608 ENDIF
7609 GOTO 100
7610 ENDIF
7611 VINT(63)=PQM3**2
7612 VINT(64)=PQM4**2
7613 ENDIF
7614 IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
7615 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
7616 ENDIF
7617
7618C...Prepare for additional variable choices in 2 -> 3.
7619 IF(ISTSB.EQ.5) THEN
7620 VINT(201)=0D0
7621 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
7622 VINT(206)=VINT(201)
7623 VINT(204)=PMAS(23,1)
7624 IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
7625 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
7626 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
7627 & ISUB.EQ.186.OR.ISUB.EQ.187) VINT(204)=VINT(201)
7628 VINT(209)=VINT(204)
7629 ENDIF
7630
7631C...Select incoming VDM particle (rho/omega/phi/J/psi).
7632 IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND.
7633 &(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7)) THEN
7634 VRN=PYR(0)*SIGT(0,0,5)
7635 IF(MINT(101).LE.1) THEN
7636 I1MN=0
7637 I1MX=0
7638 ELSE
7639 I1MN=1
7640 I1MX=MINT(101)
7641 ENDIF
7642 IF(MINT(102).LE.1) THEN
7643 I2MN=0
7644 I2MX=0
7645 ELSE
7646 I2MN=1
7647 I2MX=MINT(102)
7648 ENDIF
7649 DO 180 I1=I1MN,I1MX
7650 KFV1=110*I1+3
7651 DO 170 I2=I2MN,I2MX
7652 KFV2=110*I2+3
7653 VRN=VRN-SIGT(I1,I2,5)
7654 IF(VRN.LE.0D0) GOTO 190
7655 170 CONTINUE
7656 180 CONTINUE
7657 190 IF(MINT(101).GE.2) MINT(103)=KFV1
7658 IF(MINT(102).GE.2) MINT(104)=KFV2
7659 ENDIF
7660
7661 IF(ISTSB.EQ.0) THEN
7662C...Elastic scattering or single or double diffractive scattering.
7663
7664C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
7665 MINT(103)=MINT(11)
7666 MINT(104)=MINT(12)
7667 PMM(1)=VINT(3)
7668 PMM(2)=VINT(4)
7669 IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN
7670 JJ=ISUB-90
7671 VRN=PYR(0)*SIGT(0,0,JJ)
7672 IF(MINT(101).LE.1) THEN
7673 I1MN=0
7674 I1MX=0
7675 ELSE
7676 I1MN=1
7677 I1MX=MINT(101)
7678 ENDIF
7679 IF(MINT(102).LE.1) THEN
7680 I2MN=0
7681 I2MX=0
7682 ELSE
7683 I2MN=1
7684 I2MX=MINT(102)
7685 ENDIF
7686 DO 210 I1=I1MN,I1MX
7687 KFV1=110*I1+3
7688 DO 200 I2=I2MN,I2MX
7689 KFV2=110*I2+3
7690 VRN=VRN-SIGT(I1,I2,JJ)
7691 IF(VRN.LE.0D0) GOTO 220
7692 200 CONTINUE
7693 210 CONTINUE
7694 220 IF(MINT(101).GE.2) THEN
7695 MINT(103)=KFV1
7696 PMM(1)=PYMASS(KFV1)
7697 ENDIF
7698 IF(MINT(102).GE.2) THEN
7699 MINT(104)=KFV2
7700 PMM(2)=PYMASS(KFV2)
7701 ENDIF
7702 ENDIF
7703 VINT(67)=PMM(1)
7704 VINT(68)=PMM(2)
7705
7706C...Select mass for GVMD states (rejecting previous assignment).
7707 Q0S=4D0*PARP(15)**2
7708 Q1S=4D0*VINT(154)**2
7709 LOOP3=0
7710 230 LOOP3=LOOP3+1
7711 DO 240 JT=1,2
7712 IF(MINT(106+JT).EQ.3) THEN
7713 PS=VINT(2+JT)**2
7714 PMM(JT)=(Q0S+PS)*(Q1S+PS)/
7715 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
7716 IF(MINT(102+JT).GE.333) PMM(JT)=PMM(JT)-
7717 & PMAS(PYCOMP(113),1)+PMAS(PYCOMP(MINT(102+JT)),1)
7718 ENDIF
7719 240 CONTINUE
7720 IF(PMM(1)+PMM(2)+PARP(104).GE.VINT(1)) THEN
7721 IF(LOOP3.LT.100.AND.(MINT(107).EQ.3.OR.MINT(108).EQ.3))
7722 & GOTO 230
7723 GOTO 100
7724 ENDIF
7725
7726C...Side/sides of diffractive system.
7727 MINT(17)=0
7728 MINT(18)=0
7729 IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1
7730 IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1
7731
7732C...Find masses of particles and minimal masses of diffractive states.
7733 DO 250 JT=1,2
7734 PDIF(JT)=PMM(JT)
7735 VINT(68+JT)=PDIF(JT)
7736 IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102)
7737 250 CONTINUE
7738 SH=VINT(2)
7739 SQM1=PMM(1)**2
7740 SQM2=PMM(2)**2
7741 SQM3=PDIF(1)**2
7742 SQM4=PDIF(2)**2
7743 SMRES1=(PMM(1)+PMRC)**2
7744 SMRES2=(PMM(2)+PMRC)**2
7745
7746C...Find elastic slope and lower limit diffractive slope.
7747 IHA=MAX(2,IABS(MINT(103))/110)
7748 IF(IHA.GE.5) IHA=1
7749 IHB=MAX(2,IABS(MINT(104))/110)
7750 IF(IHB.GE.5) IHB=1
7751 IF(ISUB.EQ.91) THEN
7752 BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0
7753 ELSEIF(ISUB.EQ.92) THEN
7754 BMN=MAX(2D0,2D0*BHAD(IHB))
7755 ELSEIF(ISUB.EQ.93) THEN
7756 BMN=MAX(2D0,2D0*BHAD(IHA))
7757 ELSEIF(ISUB.EQ.94) THEN
7758 BMN=2D0*ALP*4D0
7759 ENDIF
7760
7761C...Determine maximum possible t range and coefficient of generation.
7762 SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2
7763 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
7764 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
7765 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
7766 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
7767 & (SQM1*SQM4-SQM2*SQM3)/SH
7768 THL=-0.5D0*(THA+THB)
7769 THU=THC/THL
7770 THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0
7771
7772C...Select diffractive mass/masses according to dm^2/m^2.
7773 LOOP3=0
7774 260 LOOP3=LOOP3+1
7775 DO 270 JT=1,2
7776 IF(MINT(16+JT).EQ.0) THEN
7777 PDIF(2+JT)=PDIF(JT)
7778 ELSE
7779 PMMIN=PDIF(JT)
7780 PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT))
7781 PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0)
7782 ENDIF
7783 270 CONTINUE
7784 SQM3=PDIF(3)**2
7785 SQM4=PDIF(4)**2
7786
7787C..Additional mass factors, including resonance enhancement.
7788 IF(PDIF(3)+PDIF(4).GE.VINT(1)) THEN
7789 IF(LOOP3.LT.100) GOTO 260
7790 GOTO 100
7791 ENDIF
7792 IF(ISUB.EQ.92) THEN
7793 FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3))
7794 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
7795 ELSEIF(ISUB.EQ.93) THEN
7796 FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4))
7797 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
7798 ELSEIF(ISUB.EQ.94) THEN
7799 FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/
7800 & (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))*
7801 & (1D0+CRES*SMRES2/(SMRES2+SQM4))
7802 IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 260
7803 ENDIF
7804
7805C...Select t according to exp(Bmn*t) and correct to right slope.
7806 TH=THU+LOG(1D0+THRND*PYR(0))/BMN
7807 IF(ISUB.GE.92) THEN
7808 IF(ISUB.EQ.92) THEN
7809 BADD=2D0*ALP*LOG(SH/SQM3)
7810 IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
7811 ELSEIF(ISUB.EQ.93) THEN
7812 BADD=2D0*ALP*LOG(SH/SQM4)
7813 IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
7814 ELSEIF(ISUB.EQ.94) THEN
7815 BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0)
7816 ENDIF
7817 IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 260
7818 ENDIF
7819
7820C...Check whether m^2 and t choices are consistent.
7821 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
7822 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
7823 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
7824 IF(THB.LE.1D-8) GOTO 260
7825 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
7826 & (SQM1*SQM4-SQM2*SQM3)/SH
7827 THLM=-0.5D0*(THA+THB)
7828 THUM=THC/THLM
7829 IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 260
7830
7831C...Information to output.
7832 VINT(21)=1D0
7833 VINT(22)=0D0
7834 VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB))
7835 VINT(45)=TH
7836 VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB
7837 VINT(63)=PDIF(3)**2
7838 VINT(64)=PDIF(4)**2
7839 VINT(283)=PMM(1)**2/4D0
7840 VINT(284)=PMM(2)**2/4D0
7841
7842C...Note: in the following, by In is meant the integral over the
7843C...quantity multiplying coefficient cn.
7844C...Choose tau according to h1(tau)/tau, where
7845C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
7846C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
7847C...I1/I5*c5*1/(tau+tau_R') +
7848C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
7849C...I1/I7*c7*tau/(1.-tau), and
7850C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
7851 ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN
7852 CALL PYKLIM(1)
7853 IF(MINT(51).NE.0) THEN
7854 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7855 IF(MFAIL.EQ.1) THEN
7856 MSTI(61)=1
7857 RETURN
7858 ENDIF
7859 GOTO 100
7860 ENDIF
7861 RTAU=PYR(0)
7862 MTAU=1
7863 IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
7864 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
7865 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
7866 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
7867 & MTAU=5
7868 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
7869 & COEF(ISUB,5)) MTAU=6
7870 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
7871 & COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7
7872 CALL PYKMAP(1,MTAU,PYR(0))
7873
7874C...2 -> 3, 4 processes:
7875C...Choose tau' according to h4(tau,tau')/tau', where
7876C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
7877C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
7878 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
7879 CALL PYKLIM(4)
7880 IF(MINT(51).NE.0) THEN
7881 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7882 IF(MFAIL.EQ.1) THEN
7883 MSTI(61)=1
7884 RETURN
7885 ENDIF
7886 GOTO 100
7887 ENDIF
7888 RTAUP=PYR(0)
7889 MTAUP=1
7890 IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2
7891 IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3
7892 CALL PYKMAP(4,MTAUP,PYR(0))
7893 ENDIF
7894
7895C...Choose y* according to h2(y*), where
7896C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
7897C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
7898C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
7899C...and c1 + c2 + c3 + c4 + c5 = 1.
7900 CALL PYKLIM(2)
7901 IF(MINT(51).NE.0) THEN
7902 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7903 IF(MFAIL.EQ.1) THEN
7904 MSTI(61)=1
7905 RETURN
7906 ENDIF
7907 GOTO 100
7908 ENDIF
7909 RYST=PYR(0)
7910 MYST=1
7911 IF(RYST.GT.COEF(ISUB,8)) MYST=2
7912 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
7913 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4
7914 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+
7915 & COEF(ISUB,11)) MYST=5
7916 CALL PYKMAP(2,MYST,PYR(0))
7917
7918C...2 -> 2 processes:
7919C...Choose cos(theta-hat) (cth) according to h3(cth), where
7920C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
7921C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
7922C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
7923C...and c0 + c1 + c2 + c3 + c4 = 1.
7924 CALL PYKLIM(3)
7925 IF(MINT(51).NE.0) THEN
7926 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7927 IF(MFAIL.EQ.1) THEN
7928 MSTI(61)=1
7929 RETURN
7930 ENDIF
7931 GOTO 100
7932 ENDIF
7933 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7934 RCTH=PYR(0)
7935 MCTH=1
7936 IF(RCTH.GT.COEF(ISUB,13)) MCTH=2
7937 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3
7938 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4
7939 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+
7940 & COEF(ISUB,16)) MCTH=5
7941 CALL PYKMAP(3,MCTH,PYR(0))
7942 ENDIF
7943
7944C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
7945 IF(ISTSB.EQ.5) THEN
7946 CALL PYKMAP(5,0,0D0)
7947 IF(MINT(51).NE.0) THEN
7948 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7949 IF(MFAIL.EQ.1) THEN
7950 MSTI(61)=1
7951 RETURN
7952 ENDIF
7953 GOTO 100
7954 ENDIF
7955 ENDIF
7956
7957C...DIS as f + gamma* -> f process: set dummy values.
7958 ELSEIF(ISTSB.EQ.8) THEN
7959 VINT(21)=0.9D0
7960 VINT(22)=0D0
7961 VINT(23)=0D0
7962 VINT(47)=0D0
7963 VINT(48)=0D0
7964
7965C...Low-pT or multiple interactions (first semihard interaction).
7966 ELSEIF(ISTSB.EQ.9) THEN
7967 CALL PYMULT(3)
7968 ISUB=MINT(1)
7969
7970C...Study user-defined process: kinematics plus weight.
7971 ELSEIF(ISTSB.EQ.11) THEN
7972 IF(IDWTUP.GT.0.AND.XWGTUP.LT.0D0) CALL
7973 & PYERRM(26,'(PYRAND:) Negative XWGTUP for user process')
7974 MSTI(51)=0
7975 IF(NUP.LE.0) THEN
7976 MINT(51)=2
7977 MSTI(51)=1
7978 IF(MINT(82).EQ.1) THEN
7979 NGEN(0,1)=NGEN(0,1)-1
7980 NGEN(ISUB,1)=NGEN(ISUB,1)-1
7981 ENDIF
7982 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7983 RETURN
7984 ENDIF
7985
7986C...Extract cross section event weight.
7987 IF(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.4) THEN
7988 SIGS=1D-9*XWGTUP
7989 ELSE
7990 SIGS=1D-9*XSECUP(KFPR(ISUB,1))
7991 ENDIF
7992 IF(IABS(IDWTUP).GE.1.AND.IABS(IDWTUP).LE.3) THEN
7993 VINT(97)=SIGN(1D0,XWGTUP)
7994 ELSE
7995 VINT(97)=1D-9*XWGTUP
7996 ENDIF
7997
7998C...Construct 'trivial' kinematical variables needed.
7999 KFL1=IDUP(1)
8000 KFL2=IDUP(2)
8001 VINT(41)=PUP(4,1)/EBMUP(1)
8002 VINT(42)=PUP(4,2)/EBMUP(2)
8003 VINT(21)=VINT(41)*VINT(42)
8004 VINT(22)=0.5D0*LOG(VINT(41)/VINT(42))
8005 VINT(44)=VINT(21)*VINT(2)
8006 VINT(43)=SQRT(MAX(0D0,VINT(44)))
8007 VINT(55)=SCALUP
8008 IF(SCALUP.LE.0D0) VINT(55)=VINT(43)
8009 VINT(56)=VINT(55)**2
8010 VINT(57)=AQEDUP
8011 VINT(58)=AQCDUP
8012
8013C...Construct other kinematical variables needed (approximately).
8014 VINT(23)=0D0
8015 VINT(26)=VINT(21)
8016 VINT(45)=-0.5D0*VINT(44)
8017 VINT(46)=-0.5D0*VINT(44)
8018 VINT(49)=VINT(43)
8019 VINT(50)=VINT(44)
8020 VINT(51)=VINT(55)
8021 VINT(52)=VINT(56)
8022 VINT(53)=VINT(55)
8023 VINT(54)=VINT(56)
8024 VINT(25)=0D0
8025 VINT(48)=0D0
8026 IF(ISTUP(1).NE.-1.OR.ISTUP(2).NE.-1) CALL PYERRM(26,
8027 & '(PYRAND:) unacceptable ISTUP code for incoming particles')
8028 DO 280 IUP=3,NUP
8029 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) CALL PYERRM(26,
8030 & '(PYRAND:) unacceptable ISTUP code for particles')
8031 IF(ISTUP(IUP).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(5,IUP)**2+
8032 & PUP(1,IUP)**2+PUP(2,IUP)**2)/VINT(2)
8033 IF(ISTUP(IUP).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(1,IUP)**2+
8034 & PUP(2,IUP)**2)
8035 280 CONTINUE
8036 VINT(47)=SQRT(VINT(48))
8037 ENDIF
8038
8039C...Choose azimuthal angle.
8040 VINT(24)=0D0
8041 IF(ISTSB.NE.11) VINT(24)=PARU(2)*PYR(0)
8042
8043C...Check against user cuts on kinematics at parton level.
8044 MINT(51)=0
8045 IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0)
8046 IF(MINT(51).NE.0) THEN
8047 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8048 IF(MFAIL.EQ.1) THEN
8049 MSTI(61)=1
8050 RETURN
8051 ENDIF
8052 GOTO 100
8053 ENDIF
8054 IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN
8055 MCUT=0
8056 IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
8057 & CALL PYKCUT(MCUT)
8058 IF(MCUT.NE.0) THEN
8059 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8060 IF(MFAIL.EQ.1) THEN
8061 MSTI(61)=1
8062 RETURN
8063 ENDIF
8064 GOTO 100
8065 ENDIF
8066 ENDIF
8067
8068C...Calculate differential cross-section for different subprocesses.
8069 IF(ISTSB.LE.10) CALL PYSIGH(NCHN,SIGS)
8070 SIGSOR=SIGS
8071 SIGLPT=SIGT(0,0,5)*VINT(315)*VINT(316)
8072
8073C...Multiply cross section by lepton -> photon flux factor.
8074 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
8075 SIGS=WTGAGA*SIGS
8076 DO 290 ICHN=1,NCHN
8077 SIGH(ICHN)=WTGAGA*SIGH(ICHN)
8078 290 CONTINUE
8079 SIGLPT=WTGAGA*SIGLPT
8080 ENDIF
8081
8082C...Multiply cross-section by user-defined weights.
8083 IF(MSTP(173).EQ.1) THEN
8084 SIGS=PARP(173)*SIGS
8085 DO 300 ICHN=1,NCHN
8086 SIGH(ICHN)=PARP(173)*SIGH(ICHN)
8087 300 CONTINUE
8088 SIGLPT=PARP(173)*SIGLPT
8089 ENDIF
8090 WTXS=1D0
8091 SIGSWT=SIGS
8092 VINT(99)=1D0
8093 VINT(100)=1D0
8094 IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN
8095 IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+
8096 & MSUB(95).EQ.0) CALL PYEVWT(WTXS)
8097 SIGSWT=WTXS*SIGS
8098 VINT(99)=WTXS
8099 IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS
8100 ENDIF
8101
8102C...Calculations for Monte Carlo estimate of all cross-sections.
8103 IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
8104 IF(MSTP(142).LE.1) THEN
8105 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
8106 ELSE
8107 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT
8108 ENDIF
8109 ELSEIF(MINT(82).EQ.1) THEN
8110 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
8111 ENDIF
8112 IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP2.EQ.1.AND.
8113 &MINT(82).EQ.1) XSEC(97,2)=XSEC(97,2)+SIGLPT
8114
8115C...Multiple interactions: store results of cross-section calculation.
8116 IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN
8117 VINT(153)=SIGSOR
8118 CALL PYMULT(4)
8119 ENDIF
8120
8121C...Ratio of actual to maximum cross section.
8122 IF(ISTSB.NE.11) THEN
8123 VIOL=SIGSWT/XSEC(ISUB,1)
8124 IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174)
8125 ELSEIF(IDWTUP.EQ.1.OR.IDWTUP.EQ.2) THEN
8126 VIOL=XWGTUP/XMAXUP(KFPR(ISUB,1))
8127 ELSEIF(IDWTUP.EQ.-1.OR.IDWTUP.EQ.-2) THEN
8128 VIOL=ABS(XWGTUP)/ABS(XMAXUP(KFPR(ISUB,1)))
8129 ELSE
8130 VIOL=1D0
8131 ENDIF
8132
8133C...Check that weight not negative.
8134 IF(MSTP(123).LE.0) THEN
8135 IF(VIOL.LT.-1D-3) THEN
8136 WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1
8137 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
8138 & VINT(22),VINT(23),VINT(26)
8139 STOP
8140 ENDIF
8141 ELSE
8142 IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN
8143 VINT(109)=VIOL
8144 WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1
8145 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
8146 & VINT(22),VINT(23),VINT(26)
8147 ENDIF
8148 ENDIF
8149
8150C...Weighting using estimate of maximum of differential cross-section.
8151 IF(MFAIL.EQ.0.AND.ISUB.NE.95.AND.ISUB.NE.96) THEN
8152 IF(VIOL.LT.PYR(0)) THEN
8153 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8154 IF(ISUB.GE.91.AND.ISUB.LE.94) ISUB=0
8155 GOTO 100
8156 ENDIF
8157 ELSEIF(MFAIL.EQ.0) THEN
8158 RATND=SIGLPT/XSEC(95,1)
8159 IF(LOOP2.EQ.1.AND.RATND.LT.PYR(0)) THEN
8160 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8161 ISUB=0
8162 GOTO 100
8163 ENDIF
8164 VIOL=VIOL/RATND
8165 IF(VIOL.LT.PYR(0)) THEN
8166 GOTO 140
8167 ENDIF
8168 ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN
8169 IF(VIOL.LT.PYR(0)) THEN
8170 MSTI(61)=1
8171 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8172 RETURN
8173 ENDIF
8174 ELSE
8175 RATND=SIGLPT/XSEC(95,1)
8176 IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN
8177 MSTI(61)=1
8178 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8179 RETURN
8180 ENDIF
8181 VIOL=VIOL/RATND
8182 IF(VIOL.LT.PYR(0)) THEN
8183 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8184 GOTO 100
8185 ENDIF
8186 ENDIF
8187
8188C...Check for possible violation of estimated maximum of differential
8189C...cross-section used in weighting.
8190 IF(MSTP(123).LE.0) THEN
8191 IF(VIOL.GT.1D0) THEN
8192 WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1
8193 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
8194 & VINT(22),VINT(23),VINT(26)
8195 STOP
8196 ENDIF
8197 ELSEIF(MSTP(123).EQ.1) THEN
8198 IF(VIOL.GT.VINT(108)) THEN
8199 VINT(108)=VIOL
8200 IF(VIOL.GT.1.0001D0) THEN
8201 MINT(10)=1
8202 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
8203 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
8204 & VINT(22),VINT(23),VINT(26)
8205 ENDIF
8206 ENDIF
8207 ELSEIF(VIOL.GT.VINT(108)) THEN
8208 VINT(108)=VIOL
8209 IF(VIOL.GT.1D0) THEN
8210 MINT(10)=1
8211 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
8212 IF(ISTSB.EQ.11.AND.(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.2))
8213 & THEN
8214 XMAXUP(KFPR(ISUB,1))=VIOL*XMAXUP(KFPR(ISUB,1))
8215 IF(KFPR(ISUB,1).LE.9) THEN
8216 WRITE(MSTU(11),5800) KFPR(ISUB,1),XMAXUP(KFPR(ISUB,1))
8217 ELSEIF(KFPR(ISUB,1).LE.99) THEN
8218 WRITE(MSTU(11),5900) KFPR(ISUB,1),XMAXUP(KFPR(ISUB,1))
8219 ELSE
8220 WRITE(MSTU(11),6000) KFPR(ISUB,1),XMAXUP(KFPR(ISUB,1))
8221 ENDIF
8222 ENDIF
8223 IF(ISTSB.NE.11.OR.IABS(IDWTUP).EQ.1) THEN
8224 XDIF=XSEC(ISUB,1)*(VIOL-1D0)
8225 XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
8226 IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
8227 & XSEC(0,1)=XSEC(0,1)+XDIF
8228 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
8229 & VINT(22),VINT(23),VINT(26)
8230 IF(ISUB.LE.9) THEN
8231 WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1)
8232 ELSEIF(ISUB.LE.99) THEN
8233 WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1)
8234 ELSE
8235 WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1)
8236 ENDIF
8237 ENDIF
8238 VINT(108)=1D0
8239 ENDIF
8240 ENDIF
8241
8242C...Multiple interactions: choose impact parameter.
8243 VINT(148)=1D0
8244 IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.
8245 &MSTP(82).GE.3) THEN
8246 CALL PYMULT(5)
8247 IF(VINT(150).LT.PYR(0)) THEN
8248 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8249 IF(MFAIL.EQ.1) THEN
8250 MSTI(61)=1
8251 RETURN
8252 ENDIF
8253 GOTO 100
8254 ENDIF
8255 ENDIF
8256 IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1
8257 IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
8258 IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+MINT(143)
8259 IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
8260 ENDIF
8261 IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
8262
8263C...Choose flavour of reacting partons (and subprocess).
8264 IF(ISTSB.GE.11) GOTO 320
8265 RSIGS=SIGS*PYR(0)
8266 QT2=VINT(48)
8267 RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82)*
8268 &(VINT(1)/PARP(89))**PARP(90))**2))**2)
8269 IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
8270 &PYR(0).GT.RQQBAR)) THEN
8271 DO 310 ICHN=1,NCHN
8272 KFL1=ISIG(ICHN,1)
8273 KFL2=ISIG(ICHN,2)
8274 MINT(2)=ISIG(ICHN,3)
8275 RSIGS=RSIGS-SIGH(ICHN)
8276 IF(RSIGS.LE.0D0) GOTO 320
8277 310 CONTINUE
8278
8279C...Multiple interactions: choose qqbar preferentially at small pT.
8280 ELSEIF(ISUB.EQ.96) THEN
8281 MINT(105)=MINT(103)
8282 MINT(109)=MINT(107)
8283 CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
8284 MINT(105)=MINT(104)
8285 MINT(109)=MINT(108)
8286 CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
8287 MINT(1)=11
8288 MINT(2)=1
8289 IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2
8290
8291C...Low-pT: choose string drawing configuration.
8292 ELSE
8293 KFL1=21
8294 KFL2=21
8295 RSIGS=6D0*PYR(0)
8296 MINT(2)=1
8297 IF(RSIGS.GT.1D0) MINT(2)=2
8298 IF(RSIGS.GT.2D0) MINT(2)=3
8299 ENDIF
8300
8301C...Reassign QCD process. Partons before initial state radiation.
8302 320 IF(MINT(2).GT.10) THEN
8303 MINT(1)=MINT(2)/10
8304 MINT(2)=MOD(MINT(2),10)
8305 ENDIF
8306 IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)=
8307 &NGEN(MINT(1),2)+1
8308 MINT(15)=KFL1
8309 MINT(16)=KFL2
8310 MINT(13)=MINT(15)
8311 MINT(14)=MINT(16)
8312 VINT(141)=VINT(41)
8313 VINT(142)=VINT(42)
8314 VINT(151)=0D0
8315 VINT(152)=0D0
8316
8317C...Calculate x value of photon for parton inside photon inside e.
8318 DO 350 JT=1,2
8319 MINT(18+JT)=0
8320 VINT(154+JT)=0D0
8321 MSPLI=0
8322 IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1
8323 IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1
8324 IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1
8325 IF(MSPLI.EQ.2) THEN
8326 KFLH=MINT(14+JT)
8327 XHRD=VINT(140+JT)
8328 Q2HRD=VINT(54)
8329 MINT(105)=MINT(102+JT)
8330 MINT(109)=MINT(106+JT)
8331 VINT(120)=VINT(2+JT)
8332 IF(MSTP(57).LE.1) THEN
8333 CALL PYPDFU(22,XHRD,Q2HRD,XPQ)
8334 ELSE
8335 CALL PYPDFL(22,XHRD,Q2HRD,XPQ)
8336 ENDIF
8337 WTMX=4D0*XPQ(KFLH)
8338 IF(MSTP(13).EQ.2) THEN
8339 Q2PMS=Q2HRD/PMAS(11,1)**2
8340 WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2))
8341 ENDIF
8342 330 XE=XHRD**PYR(0)
8343 XG=MIN(1D0-1D-10,XHRD/XE)
8344 IF(MSTP(57).LE.1) THEN
8345 CALL PYPDFU(22,XG,Q2HRD,XPQ)
8346 ELSE
8347 CALL PYPDFL(22,XG,Q2HRD,XPQ)
8348 ENDIF
8349 WT=(1D0+(1D0-XE)**2)*XPQ(KFLH)
8350 IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2))
8351 IF(WT.LT.PYR(0)*WTMX) GOTO 330
8352 MINT(18+JT)=1
8353 VINT(154+JT)=XE
8354 DO 340 KFLS=-25,25
8355 XSFX(JT,KFLS)=XPQ(KFLS)
8356 340 CONTINUE
8357 ENDIF
8358 350 CONTINUE
8359
8360C...Pick scale where photon is resolved.
8361 Q0S=PARP(15)**2
8362 Q1S=VINT(154)**2
8363 VINT(283)=0D0
8364 IF(MINT(107).EQ.3) THEN
8365 IF(MSTP(66).EQ.1) THEN
8366 VINT(283)=Q0S*(VINT(54)/Q0S)**PYR(0)
8367 ELSEIF(MSTP(66).EQ.2) THEN
8368 PS=VINT(3)**2
8369 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
8370 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
8371 Q2INT=SQRT(Q0S*Q2EFF)
8372 VINT(283)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
8373 ELSEIF(MSTP(66).EQ.3) THEN
8374 VINT(283)=Q0S*(Q1S/Q0S)**PYR(0)
8375 ELSEIF(MSTP(66).GE.4) THEN
8376 PS=0.25D0*VINT(3)**2
8377 VINT(283)=(Q0S+PS)*(Q1S+PS)/
8378 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
8379 ENDIF
8380 ENDIF
8381 VINT(284)=0D0
8382 IF(MINT(108).EQ.3) THEN
8383 IF(MSTP(66).EQ.1) THEN
8384 VINT(284)=Q0S*(VINT(54)/Q0S)**PYR(0)
8385 ELSEIF(MSTP(66).EQ.2) THEN
8386 PS=VINT(4)**2
8387 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
8388 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
8389 Q2INT=SQRT(Q0S*Q2EFF)
8390 VINT(284)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
8391 ELSEIF(MSTP(66).EQ.3) THEN
8392 VINT(284)=Q0S*(Q1S/Q0S)**PYR(0)
8393 ELSEIF(MSTP(66).GE.4) THEN
8394 PS=0.25D0*VINT(4)**2
8395 VINT(284)=(Q0S+PS)*(Q1S+PS)/
8396 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
8397 ENDIF
8398 ENDIF
8399 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8400
8401C...Format statements for differential cross-section maximum violations.
8402 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
8403 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
8404 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
8405 &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
8406 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
8407 &'in event',1X,I7)
8408 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
8409 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
8410 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
8411 &'in event',1X,I7)
8412 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
8413 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
8414 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
8415 5800 FORMAT(1X,'XMAXUP(',I1,') increased to',1P,D11.3)
8416 5900 FORMAT(1X,'XMAXUP(',I2,') increased to',1P,D11.3)
8417 6000 FORMAT(1X,'XMAXUP(',I3,') increased to',1P,D11.3)
8418
8419 RETURN
8420 END
8421
8422C*********************************************************************
8423
8424C...PYSCAT
8425C...Finds outgoing flavours and event type; sets up the kinematics
8426C...and colour flow of the hard scattering
8427
8428 SUBROUTINE PYSCAT
8429
8430C...Double precision and integer declarations
8431 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8432 IMPLICIT INTEGER(I-N)
8433 INTEGER PYK,PYCHGE,PYCOMP
8434C...Parameter statement to help give large particle numbers.
8435 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
8436 &KEXCIT=4000000,KDIMEN=5000000)
8437
8438C...User process event common block.
8439 INTEGER MAXNUP
8440 PARAMETER (MAXNUP=500)
8441 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
8442 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
8443 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
8444 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
8445 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
8446 SAVE /HEPEUP/
8447
8448C...Commonblocks
8449 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
8450 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8451 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
8452 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
8453 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8454 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8455 COMMON/PYINT1/MINT(400),VINT(400)
8456 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
8457 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
8458 COMMON/PYINT4/MWID(500),WIDS(500,5)
8459 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8460 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
8461 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
8462 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
8463 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYSSMT/
8464C...Local arrays and saved variables
8465 DIMENSION WDTP(0:300),WDTE(0:300,0:5),PMQ(2),Z(2),CTHE(2),
8466 &PHI(2),KUPPO(100),VINTSV(41:66),ILAB(100)
8467 SAVE VINTSV
8468
8469C...Read out process
8470 ISUB=MINT(1)
8471 ISUBSV=ISUB
8472
8473C...Restore information for low-pT processes
8474 IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN
8475 DO 100 J=41,66
8476 100 VINT(J)=VINTSV(J)
8477 ENDIF
8478
8479C...Convert H' or A process into equivalent H one
8480 IHIGG=1
8481 KFHIGG=25
8482 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
8483 &ISUB.LE.190)) THEN
8484 IHIGG=2
8485 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
8486 KFHIGG=33+IHIGG
8487 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
8488 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
8489 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
8490 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
8491 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
8492 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
8493 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
8494 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
8495 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
8496 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
8497 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
8498 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
8499 ENDIF
8500
8501C...Choice of subprocess, number of documentation lines
8502 IDOC=6+ISET(ISUB)
8503 IF(ISUB.EQ.95) IDOC=8
8504 IF(ISET(ISUB).EQ.5) IDOC=9
8505 IF(ISET(ISUB).EQ.11) IDOC=4+NUP
8506 MINT(3)=IDOC-6
8507 IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2
8508 MINT(4)=IDOC
8509 IPU1=MINT(84)+1
8510 IPU2=MINT(84)+2
8511 IPU3=MINT(84)+3
8512 IPU4=MINT(84)+4
8513 IPU5=MINT(84)+5
8514 IPU6=MINT(84)+6
8515
8516C...Reset K, P and V vectors. Store incoming particles
8517 DO 120 JT=1,MSTP(126)+100
8518 I=MINT(83)+JT
8519 IF(I.GT.MSTU(4)) GOTO 120
8520 DO 110 J=1,5
8521 K(I,J)=0
8522 P(I,J)=0D0
8523 V(I,J)=0D0
8524 110 CONTINUE
8525 120 CONTINUE
8526 DO 140 JT=1,2
8527 I=MINT(83)+JT
8528 K(I,1)=21
8529 K(I,2)=MINT(10+JT)
8530 DO 130 J=1,5
8531 P(I,J)=VINT(285+5*JT+J)
8532 130 CONTINUE
8533 140 CONTINUE
8534 MINT(6)=2
8535 KFRES=0
8536
8537C...Store incoming partons in their CM-frame
8538 SH=VINT(44)
8539 SHR=SQRT(SH)
8540 SHP=VINT(26)*VINT(2)
8541 SHPR=SQRT(SHP)
8542 SHUSER=SHR
8543 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR
8544 DO 150 JT=1,2
8545 I=MINT(84)+JT
8546 K(I,1)=14
8547 K(I,2)=MINT(14+JT)
8548 K(I,3)=MINT(83)+2+JT
8549 P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1)
8550 P(I,4)=0.5D0*SHUSER
8551 150 CONTINUE
8552
8553C...Copy incoming partons to documentation lines
8554 DO 170 JT=1,2
8555 I1=MINT(83)+4+JT
8556 I2=MINT(84)+JT
8557 K(I1,1)=21
8558 K(I1,2)=K(I2,2)
8559 K(I1,3)=I1-2
8560 DO 160 J=1,5
8561 P(I1,J)=P(I2,J)
8562 160 CONTINUE
8563 170 CONTINUE
8564
8565C...Choose new quark/lepton flavour for relevant annihilation graphs
8566 IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58.OR.
8567 &(ISUB.GE.135.AND.ISUB.LE.140)) THEN
8568 IGLGA=21
8569 IF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) IGLGA=22
8570 CALL PYWIDT(IGLGA,SH,WDTP,WDTE)
8571 180 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
8572 DO 190 I=1,MDCY(IGLGA,3)
8573 KFLF=KFDP(I+MDCY(IGLGA,2)-1,1)
8574 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
8575 IF(RKFL.LE.0D0) GOTO 200
8576 190 CONTINUE
8577 200 CONTINUE
8578 IF(ISUB.EQ.53.AND.MINT(2).LE.2) THEN
8579 IF(KFLF.GE.4) GOTO 180
8580 ELSEIF(ISUB.EQ.53.AND.MINT(2).LE.4) THEN
8581 KFLF=4
8582 MINT(2)=MINT(2)-2
8583 ELSEIF(ISUB.EQ.53) THEN
8584 KFLF=5
8585 MINT(2)=MINT(2)-4
8586 ELSEIF(ISUB.EQ.12.AND.MSTP(5).EQ.1.AND.IABS(MINT(15)).LE.2.AND.
8587 & IABS(KFLF).GE.3) THEN
8588 FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/
8589 & VINT(44)**2
8590 FACCIB=VINT(46)**2/PARU(155)**4
8591 IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180
8592 ELSEIF(ISUB.EQ.54.OR.ISUB.EQ.135.OR.ISUB.EQ.136) THEN
8593 IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180
8594 ELSEIF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) THEN
8595 IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180
8596 ENDIF
8597 ENDIF
8598
8599C...Final state flavours and colour flow: default values
8600 JS=1
8601 MINT(21)=MINT(15)
8602 MINT(22)=MINT(16)
8603 MINT(23)=0
8604 MINT(24)=0
8605 KCC=20
8606 KCS=ISIGN(1,MINT(15))
8607
8608 IF(ISET(ISUB).EQ.11) THEN
8609C...User-defined processes: find products
8610 MINT(3)=0
8611 DO 210 IUP=3,NUP
8612 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) THEN
8613 ELSEIF(NUP.EQ.5.AND.IUP.GE.4.AND.MOTHUP(1,4).EQ.3) THEN
8614 MINT(21+IUP)=IDUP(IUP)
8615 ELSEIF(ISTUP(IUP).EQ.1.AND.(ISTUP(MOTHUP(1,IUP)).EQ.2.OR.
8616 & ISTUP(MOTHUP(1,IUP)).EQ.3).AND.IDUP(MOTHUP(1,IUP)).NE.0) THEN
8617 ELSEIF(IDUP(IUP).EQ.0) THEN
8618 ELSE
8619 MINT(3)=MINT(3)+1
8620 IF(MINT(3).LE.6) MINT(20+MINT(3))=IDUP(IUP)
8621 ENDIF
8622 210 CONTINUE
8623
8624 ELSEIF(ISUB.LE.10) THEN
8625 IF(ISUB.EQ.1) THEN
8626C...f + fbar -> gamma*/Z0
8627 KFRES=23
8628
8629 ELSEIF(ISUB.EQ.2) THEN
8630C...f + fbar' -> W+/-
8631 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8632 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8633 KFRES=ISIGN(24,KCH1+KCH2)
8634
8635 ELSEIF(ISUB.EQ.3) THEN
8636C...f + fbar -> h0 (or H0, or A0)
8637 KFRES=KFHIGG
8638
8639 ELSEIF(ISUB.EQ.4) THEN
8640C...gamma + W+/- -> W+/-
8641
8642 ELSEIF(ISUB.EQ.5) THEN
8643C...Z0 + Z0 -> h0
8644 XH=SH/SHP
8645 MINT(21)=MINT(15)
8646 MINT(22)=MINT(16)
8647 PMQ(1)=PYMASS(MINT(21))
8648 PMQ(2)=PYMASS(MINT(22))
8649 220 JT=INT(1.5D0+PYR(0))
8650 ZMIN=2D0*PMQ(JT)/SHPR
8651 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
8652 & (SHPR*(SHPR-PMQ(3-JT)))
8653 ZMAX=MIN(1D0-XH,ZMAX)
8654 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
8655 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
8656 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220
8657 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
8658 IF(SQC1.LT.1D-8) GOTO 220
8659 C1=SQRT(SQC1)
8660 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
8661 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8662 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
8663 Z(3-JT)=1D0-XH/(1D0-Z(JT))
8664 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
8665 IF(SQC1.LT.1D-8) GOTO 220
8666 C1=SQRT(SQC1)
8667 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
8668 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8669 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
8670 PHIR=PARU(2)*PYR(0)
8671 CPHI=COS(PHIR)
8672 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
8673 & SQRT(1D0-CTHE(2)**2)*CPHI
8674 Z1=2D0-Z(JT)
8675 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
8676 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
8677 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
8678 & PMQ(3-JT)**2/SHP))
8679 ZMIN=2D0*PMQ(3-JT)/SHPR
8680 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
8681 ZMAX=MIN(1D0-XH,ZMAX)
8682 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220
8683 KCC=22
8684 KFRES=25
8685
8686 ELSEIF(ISUB.EQ.6) THEN
8687C...Z0 + W+/- -> W+/-
8688
8689 ELSEIF(ISUB.EQ.7) THEN
8690C...W+ + W- -> Z0
8691
8692 ELSEIF(ISUB.EQ.8) THEN
8693C...W+ + W- -> h0
8694 XH=SH/SHP
8695 230 DO 260 JT=1,2
8696 I=MINT(14+JT)
8697 IA=IABS(I)
8698 IF(IA.LE.10) THEN
8699 RVCKM=VINT(180+I)*PYR(0)
8700 DO 240 J=1,MSTP(1)
8701 IB=2*J-1+MOD(IA,2)
8702 IPM=(5-ISIGN(1,I))/2
8703 IDC=J+MDCY(IA,2)+2
8704 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240
8705 MINT(20+JT)=ISIGN(IB,I)
8706 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8707 IF(RVCKM.LE.0D0) GOTO 250
8708 240 CONTINUE
8709 ELSE
8710 IB=2*((IA+1)/2)-1+MOD(IA,2)
8711 MINT(20+JT)=ISIGN(IB,I)
8712 ENDIF
8713 250 PMQ(JT)=PYMASS(MINT(20+JT))
8714 260 CONTINUE
8715 JT=INT(1.5D0+PYR(0))
8716 ZMIN=2D0*PMQ(JT)/SHPR
8717 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
8718 & (SHPR*(SHPR-PMQ(3-JT)))
8719 ZMAX=MIN(1D0-XH,ZMAX)
8720 IF(ZMIN.GE.ZMAX) GOTO 230
8721 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
8722 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
8723 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230
8724 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
8725 IF(SQC1.LT.1D-8) GOTO 230
8726 C1=SQRT(SQC1)
8727 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
8728 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8729 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
8730 Z(3-JT)=1D0-XH/(1D0-Z(JT))
8731 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
8732 IF(SQC1.LT.1D-8) GOTO 230
8733 C1=SQRT(SQC1)
8734 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
8735 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8736 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
8737 PHIR=PARU(2)*PYR(0)
8738 CPHI=COS(PHIR)
8739 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
8740 & SQRT(1D0-CTHE(2)**2)*CPHI
8741 Z1=2D0-Z(JT)
8742 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
8743 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
8744 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
8745 & PMQ(3-JT)**2/SHP))
8746 ZMIN=2D0*PMQ(3-JT)/SHPR
8747 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
8748 ZMAX=MIN(1D0-XH,ZMAX)
8749 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230
8750 KCC=22
8751 KFRES=25
8752
8753 ELSEIF(ISUB.EQ.10) THEN
8754C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
8755 IF(MINT(2).EQ.1) THEN
8756 KCC=22
8757 ELSE
8758C...W exchange: need to mix flavours according to CKM matrix
8759 DO 280 JT=1,2
8760 I=MINT(14+JT)
8761 IA=IABS(I)
8762 IF(IA.LE.10) THEN
8763 RVCKM=VINT(180+I)*PYR(0)
8764 DO 270 J=1,MSTP(1)
8765 IB=2*J-1+MOD(IA,2)
8766 IPM=(5-ISIGN(1,I))/2
8767 IDC=J+MDCY(IA,2)+2
8768 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
8769 MINT(20+JT)=ISIGN(IB,I)
8770 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8771 IF(RVCKM.LE.0D0) GOTO 280
8772 270 CONTINUE
8773 ELSE
8774 IB=2*((IA+1)/2)-1+MOD(IA,2)
8775 MINT(20+JT)=ISIGN(IB,I)
8776 ENDIF
8777 280 CONTINUE
8778 KCC=22
8779 ENDIF
8780 ENDIF
8781
8782 ELSEIF(ISUB.LE.20) THEN
8783 IF(ISUB.EQ.11) THEN
8784C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
8785 KCC=MINT(2)
8786 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8787
8788 ELSEIF(ISUB.EQ.12) THEN
8789C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
8790 MINT(21)=ISIGN(KFLF,MINT(15))
8791 MINT(22)=-MINT(21)
8792 KCC=4
8793
8794 ELSEIF(ISUB.EQ.13) THEN
8795C...f + fbar -> g + g; th arbitrary
8796 MINT(21)=21
8797 MINT(22)=21
8798 KCC=MINT(2)+4
8799
8800 ELSEIF(ISUB.EQ.14) THEN
8801C...f + fbar -> g + gamma; th arbitrary
8802 IF(PYR(0).GT.0.5D0) JS=2
8803 MINT(20+JS)=21
8804 MINT(23-JS)=22
8805 KCC=17+JS
8806
8807 ELSEIF(ISUB.EQ.15) THEN
8808C...f + fbar -> g + Z0; th arbitrary
8809 IF(PYR(0).GT.0.5D0) JS=2
8810 MINT(20+JS)=21
8811 MINT(23-JS)=23
8812 KCC=17+JS
8813
8814 ELSEIF(ISUB.EQ.16) THEN
8815C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
8816 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8817 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8818 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
8819 MINT(20+JS)=21
8820 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
8821 KCC=17+JS
8822
8823 ELSEIF(ISUB.EQ.17) THEN
8824C...f + fbar -> g + h0; th arbitrary
8825 IF(PYR(0).GT.0.5D0) JS=2
8826 MINT(20+JS)=21
8827 MINT(23-JS)=25
8828 KCC=17+JS
8829
8830 ELSEIF(ISUB.EQ.18) THEN
8831C...f + fbar -> gamma + gamma; th arbitrary
8832 MINT(21)=22
8833 MINT(22)=22
8834
8835 ELSEIF(ISUB.EQ.19) THEN
8836C...f + fbar -> gamma + Z0; th arbitrary
8837 IF(PYR(0).GT.0.5D0) JS=2
8838 MINT(20+JS)=22
8839 MINT(23-JS)=23
8840
8841 ELSEIF(ISUB.EQ.20) THEN
8842C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
8843C...(p(fbar')-p(W+))**2
8844 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8845 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8846 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
8847 MINT(20+JS)=22
8848 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
8849 ENDIF
8850
8851 ELSEIF(ISUB.LE.30) THEN
8852 IF(ISUB.EQ.21) THEN
8853C...f + fbar -> gamma + h0; th arbitrary
8854 IF(PYR(0).GT.0.5D0) JS=2
8855 MINT(20+JS)=22
8856 MINT(23-JS)=25
8857
8858 ELSEIF(ISUB.EQ.22) THEN
8859C...f + fbar -> Z0 + Z0; th arbitrary
8860 MINT(21)=23
8861 MINT(22)=23
8862
8863 ELSEIF(ISUB.EQ.23) THEN
8864C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
8865 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8866 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8867 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
8868 MINT(20+JS)=23
8869 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
8870
8871 ELSEIF(ISUB.EQ.24) THEN
8872C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
8873 IF(PYR(0).GT.0.5D0) JS=2
8874 MINT(20+JS)=23
8875 MINT(23-JS)=KFHIGG
8876
8877 ELSEIF(ISUB.EQ.25) THEN
8878C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
8879 MINT(21)=-ISIGN(24,MINT(15))
8880 MINT(22)=-MINT(21)
8881
8882 ELSEIF(ISUB.EQ.26) THEN
8883C...f + fbar' -> W+/- + h0 (or H0, or A0);
8884C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
8885 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8886 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8887 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
8888 MINT(20+JS)=ISIGN(24,KCH1+KCH2)
8889 MINT(23-JS)=KFHIGG
8890
8891 ELSEIF(ISUB.EQ.27) THEN
8892C...f + fbar -> h0 + h0
8893
8894 ELSEIF(ISUB.EQ.28) THEN
8895C...f + g -> f + g; th = (p(f)-p(f))**2
8896 KCC=MINT(2)+6
8897 IF(MINT(15).EQ.21) KCC=KCC+2
8898 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
8899 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
8900
8901 ELSEIF(ISUB.EQ.29) THEN
8902C...f + g -> f + gamma; th = (p(f)-p(f))**2
8903 IF(MINT(15).EQ.21) JS=2
8904 MINT(23-JS)=22
8905 KCC=15+JS
8906 KCS=ISIGN(1,MINT(14+JS))
8907
8908 ELSEIF(ISUB.EQ.30) THEN
8909C...f + g -> f + Z0; th = (p(f)-p(f))**2
8910 IF(MINT(15).EQ.21) JS=2
8911 MINT(23-JS)=23
8912 KCC=15+JS
8913 KCS=ISIGN(1,MINT(14+JS))
8914 ENDIF
8915
8916 ELSEIF(ISUB.LE.40) THEN
8917 IF(ISUB.EQ.31) THEN
8918C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
8919 IF(MINT(15).EQ.21) JS=2
8920 I=MINT(14+JS)
8921 IA=IABS(I)
8922 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
8923 RVCKM=VINT(180+I)*PYR(0)
8924 DO 290 J=1,MSTP(1)
8925 IB=2*J-1+MOD(IA,2)
8926 IPM=(5-ISIGN(1,I))/2
8927 IDC=J+MDCY(IA,2)+2
8928 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290
8929 MINT(20+JS)=ISIGN(IB,I)
8930 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8931 IF(RVCKM.LE.0D0) GOTO 300
8932 290 CONTINUE
8933 300 KCC=15+JS
8934 KCS=ISIGN(1,MINT(14+JS))
8935
8936 ELSEIF(ISUB.EQ.32) THEN
8937C...f + g -> f + h0; th = (p(f)-p(f))**2
8938 IF(MINT(15).EQ.21) JS=2
8939 MINT(23-JS)=25
8940 KCC=15+JS
8941 KCS=ISIGN(1,MINT(14+JS))
8942
8943 ELSEIF(ISUB.EQ.33) THEN
8944C...f + gamma -> f + g; th=(p(f)-p(f))**2
8945 IF(MINT(15).EQ.22) JS=2
8946 MINT(23-JS)=21
8947 KCC=24+JS
8948 KCS=ISIGN(1,MINT(14+JS))
8949
8950 ELSEIF(ISUB.EQ.34) THEN
8951C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
8952 IF(MINT(15).EQ.22) JS=2
8953 KCC=22
8954 KCS=ISIGN(1,MINT(14+JS))
8955
8956 ELSEIF(ISUB.EQ.35) THEN
8957C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
8958 IF(MINT(15).EQ.22) JS=2
8959 MINT(23-JS)=23
8960 KCC=22
8961
8962 ELSEIF(ISUB.EQ.36) THEN
8963C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
8964 IF(MINT(15).EQ.22) JS=2
8965 I=MINT(14+JS)
8966 IA=IABS(I)
8967 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
8968 IF(IA.LE.10) THEN
8969 RVCKM=VINT(180+I)*PYR(0)
8970 DO 310 J=1,MSTP(1)
8971 IB=2*J-1+MOD(IA,2)
8972 IPM=(5-ISIGN(1,I))/2
8973 IDC=J+MDCY(IA,2)+2
8974 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310
8975 MINT(20+JS)=ISIGN(IB,I)
8976 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8977 IF(RVCKM.LE.0D0) GOTO 320
8978 310 CONTINUE
8979 ELSE
8980 IB=2*((IA+1)/2)-1+MOD(IA,2)
8981 MINT(20+JS)=ISIGN(IB,I)
8982 ENDIF
8983 320 KCC=22
8984
8985 ELSEIF(ISUB.EQ.37) THEN
8986C...f + gamma -> f + h0
8987
8988 ELSEIF(ISUB.EQ.38) THEN
8989C...f + Z0 -> f + g
8990
8991 ELSEIF(ISUB.EQ.39) THEN
8992C...f + Z0 -> f + gamma
8993
8994 ELSEIF(ISUB.EQ.40) THEN
8995C...f + Z0 -> f + Z0
8996 ENDIF
8997
8998 ELSEIF(ISUB.LE.50) THEN
8999 IF(ISUB.EQ.41) THEN
9000C...f + Z0 -> f' + W+/-
9001
9002 ELSEIF(ISUB.EQ.42) THEN
9003C...f + Z0 -> f + h0
9004
9005 ELSEIF(ISUB.EQ.43) THEN
9006C...f + W+/- -> f' + g
9007
9008 ELSEIF(ISUB.EQ.44) THEN
9009C...f + W+/- -> f' + gamma
9010
9011 ELSEIF(ISUB.EQ.45) THEN
9012C...f + W+/- -> f' + Z0
9013
9014 ELSEIF(ISUB.EQ.46) THEN
9015C...f + W+/- -> f' + W+/-
9016
9017 ELSEIF(ISUB.EQ.47) THEN
9018C...f + W+/- -> f' + h0
9019
9020 ELSEIF(ISUB.EQ.48) THEN
9021C...f + h0 -> f + g
9022
9023 ELSEIF(ISUB.EQ.49) THEN
9024C...f + h0 -> f + gamma
9025
9026 ELSEIF(ISUB.EQ.50) THEN
9027C...f + h0 -> f + Z0
9028 ENDIF
9029
9030 ELSEIF(ISUB.LE.60) THEN
9031 IF(ISUB.EQ.51) THEN
9032C...f + h0 -> f' + W+/-
9033
9034 ELSEIF(ISUB.EQ.52) THEN
9035C...f + h0 -> f + h0
9036
9037 ELSEIF(ISUB.EQ.53) THEN
9038C...g + g -> f + fbar; th arbitrary
9039 KCS=(-1)**INT(1.5D0+PYR(0))
9040 MINT(21)=ISIGN(KFLF,KCS)
9041 MINT(22)=-MINT(21)
9042 KCC=MINT(2)+10
9043
9044 ELSEIF(ISUB.EQ.54) THEN
9045C...g + gamma -> f + fbar; th arbitrary
9046 KCS=(-1)**INT(1.5D0+PYR(0))
9047 MINT(21)=ISIGN(KFLF,KCS)
9048 MINT(22)=-MINT(21)
9049 KCC=27
9050 IF(MINT(16).EQ.21) KCC=28
9051
9052 ELSEIF(ISUB.EQ.55) THEN
9053C...g + Z0 -> f + fbar
9054
9055 ELSEIF(ISUB.EQ.56) THEN
9056C...g + W+/- -> f + fbar'
9057
9058 ELSEIF(ISUB.EQ.57) THEN
9059C...g + h0 -> f + fbar
9060
9061 ELSEIF(ISUB.EQ.58) THEN
9062C...gamma + gamma -> f + fbar; th arbitrary
9063 KCS=(-1)**INT(1.5D0+PYR(0))
9064 MINT(21)=ISIGN(KFLF,KCS)
9065 MINT(22)=-MINT(21)
9066 KCC=21
9067
9068 ELSEIF(ISUB.EQ.59) THEN
9069C...gamma + Z0 -> f + fbar
9070
9071 ELSEIF(ISUB.EQ.60) THEN
9072C...gamma + W+/- -> f + fbar'
9073 ENDIF
9074
9075 ELSEIF(ISUB.LE.70) THEN
9076 IF(ISUB.EQ.61) THEN
9077C...gamma + h0 -> f + fbar
9078
9079 ELSEIF(ISUB.EQ.62) THEN
9080C...Z0 + Z0 -> f + fbar
9081
9082 ELSEIF(ISUB.EQ.63) THEN
9083C...Z0 + W+/- -> f + fbar'
9084
9085 ELSEIF(ISUB.EQ.64) THEN
9086C...Z0 + h0 -> f + fbar
9087
9088 ELSEIF(ISUB.EQ.65) THEN
9089C...W+ + W- -> f + fbar
9090
9091 ELSEIF(ISUB.EQ.66) THEN
9092C...W+/- + h0 -> f + fbar'
9093
9094 ELSEIF(ISUB.EQ.67) THEN
9095C...h0 + h0 -> f + fbar
9096
9097 ELSEIF(ISUB.EQ.68) THEN
9098C...g + g -> g + g; th arbitrary
9099 KCC=MINT(2)+12
9100 KCS=(-1)**INT(1.5D0+PYR(0))
9101
9102 ELSEIF(ISUB.EQ.69) THEN
9103C...gamma + gamma -> W+ + W-; th arbitrary
9104 MINT(21)=24
9105 MINT(22)=-24
9106 KCC=21
9107
9108 ELSEIF(ISUB.EQ.70) THEN
9109C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
9110 IF(MINT(15).EQ.22) MINT(21)=23
9111 IF(MINT(16).EQ.22) MINT(22)=23
9112 KCC=21
9113 ENDIF
9114
9115 ELSEIF(ISUB.LE.80) THEN
9116 IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
9117C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
9118 XH=SH/SHP
9119 MINT(21)=MINT(15)
9120 MINT(22)=MINT(16)
9121 PMQ(1)=PYMASS(MINT(21))
9122 PMQ(2)=PYMASS(MINT(22))
9123 330 JT=INT(1.5D0+PYR(0))
9124 ZMIN=2D0*PMQ(JT)/SHPR
9125 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
9126 & (SHPR*(SHPR-PMQ(3-JT)))
9127 ZMAX=MIN(1D0-XH,ZMAX)
9128 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
9129 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
9130 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330
9131 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
9132 IF(SQC1.LT.1D-8) GOTO 330
9133 C1=SQRT(SQC1)
9134 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
9135 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9136 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
9137 Z(3-JT)=1D0-XH/(1D0-Z(JT))
9138 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
9139 IF(SQC1.LT.1D-8) GOTO 330
9140 C1=SQRT(SQC1)
9141 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
9142 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9143 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
9144 PHIR=PARU(2)*PYR(0)
9145 CPHI=COS(PHIR)
9146 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
9147 & SQRT(1D0-CTHE(2)**2)*CPHI
9148 Z1=2D0-Z(JT)
9149 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
9150 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
9151 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
9152 & PMQ(3-JT)**2/SHP))
9153 ZMIN=2D0*PMQ(3-JT)/SHPR
9154 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
9155 ZMAX=MIN(1D0-XH,ZMAX)
9156 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330
9157 KCC=22
9158
9159 ELSEIF(ISUB.EQ.73) THEN
9160C...Z0 + W+/- -> Z0 + W+/-
9161 JS=MINT(2)
9162 XH=SH/SHP
9163 340 JT=3-MINT(2)
9164 I=MINT(14+JT)
9165 IA=IABS(I)
9166 IF(IA.LE.10) THEN
9167 RVCKM=VINT(180+I)*PYR(0)
9168 DO 350 J=1,MSTP(1)
9169 IB=2*J-1+MOD(IA,2)
9170 IPM=(5-ISIGN(1,I))/2
9171 IDC=J+MDCY(IA,2)+2
9172 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350
9173 MINT(20+JT)=ISIGN(IB,I)
9174 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
9175 IF(RVCKM.LE.0D0) GOTO 360
9176 350 CONTINUE
9177 ELSE
9178 IB=2*((IA+1)/2)-1+MOD(IA,2)
9179 MINT(20+JT)=ISIGN(IB,I)
9180 ENDIF
9181 360 PMQ(JT)=PYMASS(MINT(20+JT))
9182 MINT(23-JT)=MINT(17-JT)
9183 PMQ(3-JT)=PYMASS(MINT(23-JT))
9184 JT=INT(1.5D0+PYR(0))
9185 ZMIN=2D0*PMQ(JT)/SHPR
9186 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
9187 & (SHPR*(SHPR-PMQ(3-JT)))
9188 ZMAX=MIN(1D0-XH,ZMAX)
9189 IF(ZMIN.GE.ZMAX) GOTO 340
9190 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
9191 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
9192 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340
9193 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
9194 IF(SQC1.LT.1D-8) GOTO 340
9195 C1=SQRT(SQC1)
9196 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
9197 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9198 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
9199 Z(3-JT)=1D0-XH/(1D0-Z(JT))
9200 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
9201 IF(SQC1.LT.1D-8) GOTO 340
9202 C1=SQRT(SQC1)
9203 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
9204 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9205 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
9206 PHIR=PARU(2)*PYR(0)
9207 CPHI=COS(PHIR)
9208 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
9209 & SQRT(1D0-CTHE(2)**2)*CPHI
9210 Z1=2D0-Z(JT)
9211 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
9212 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
9213 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
9214 & PMQ(3-JT)**2/SHP))
9215 ZMIN=2D0*PMQ(3-JT)/SHPR
9216 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
9217 ZMAX=MIN(1D0-XH,ZMAX)
9218 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
9219 KCC=22
9220
9221 ELSEIF(ISUB.EQ.74) THEN
9222C...Z0 + h0 -> Z0 + h0
9223
9224 ELSEIF(ISUB.EQ.75) THEN
9225C...W+ + W- -> gamma + gamma
9226
9227 ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
9228C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
9229 XH=SH/SHP
9230 370 DO 400 JT=1,2
9231 I=MINT(14+JT)
9232 IA=IABS(I)
9233 IF(IA.LE.10) THEN
9234 RVCKM=VINT(180+I)*PYR(0)
9235 DO 380 J=1,MSTP(1)
9236 IB=2*J-1+MOD(IA,2)
9237 IPM=(5-ISIGN(1,I))/2
9238 IDC=J+MDCY(IA,2)+2
9239 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380
9240 MINT(20+JT)=ISIGN(IB,I)
9241 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
9242 IF(RVCKM.LE.0D0) GOTO 390
9243 380 CONTINUE
9244 ELSE
9245 IB=2*((IA+1)/2)-1+MOD(IA,2)
9246 MINT(20+JT)=ISIGN(IB,I)
9247 ENDIF
9248 390 PMQ(JT)=PYMASS(MINT(20+JT))
9249 400 CONTINUE
9250 JT=INT(1.5D0+PYR(0))
9251 ZMIN=2D0*PMQ(JT)/SHPR
9252 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
9253 & (SHPR*(SHPR-PMQ(3-JT)))
9254 ZMAX=MIN(1D0-XH,ZMAX)
9255 IF(ZMIN.GE.ZMAX) GOTO 370
9256 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
9257 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
9258 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370
9259 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
9260 IF(SQC1.LT.1D-8) GOTO 370
9261 C1=SQRT(SQC1)
9262 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
9263 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9264 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
9265 Z(3-JT)=1D0-XH/(1D0-Z(JT))
9266 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
9267 IF(SQC1.LT.1D-8) GOTO 370
9268 C1=SQRT(SQC1)
9269 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
9270 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9271 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
9272 PHIR=PARU(2)*PYR(0)
9273 CPHI=COS(PHIR)
9274 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
9275 & SQRT(1D0-CTHE(2)**2)*CPHI
9276 Z1=2D0-Z(JT)
9277 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
9278 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
9279 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
9280 & PMQ(3-JT)**2/SHP))
9281 ZMIN=2D0*PMQ(3-JT)/SHPR
9282 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
9283 ZMAX=MIN(1D0-XH,ZMAX)
9284 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370
9285 KCC=22
9286
9287 ELSEIF(ISUB.EQ.78) THEN
9288C...W+/- + h0 -> W+/- + h0
9289
9290 ELSEIF(ISUB.EQ.79) THEN
9291C...h0 + h0 -> h0 + h0
9292
9293 ELSEIF(ISUB.EQ.80) THEN
9294C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
9295 IF(MINT(15).EQ.22) JS=2
9296 I=MINT(14+JS)
9297 IA=IABS(I)
9298 MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I)
9299 IB=3-IA
9300 MINT(20+JS)=ISIGN(IB,I)
9301 KCC=22
9302 ENDIF
9303
9304 ELSEIF(ISUB.LE.90) THEN
9305 IF(ISUB.EQ.81) THEN
9306C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
9307 MINT(21)=ISIGN(MINT(55),MINT(15))
9308 MINT(22)=-MINT(21)
9309 KCC=4
9310
9311 ELSEIF(ISUB.EQ.82) THEN
9312C...g + g -> Q + Qbar; th arbitrary
9313 KCS=(-1)**INT(1.5D0+PYR(0))
9314 MINT(21)=ISIGN(MINT(55),KCS)
9315 MINT(22)=-MINT(21)
9316 KCC=MINT(2)+10
9317
9318 ELSEIF(ISUB.EQ.83) THEN
9319C...f + q -> f' + Q; th = (p(f) - p(f'))**2
9320 KFOLD=MINT(16)
9321 IF(MINT(2).EQ.2) KFOLD=MINT(15)
9322 KFAOLD=IABS(KFOLD)
9323 IF(KFAOLD.GT.10) THEN
9324 KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1
9325 ELSE
9326 RCKM=VINT(180+KFOLD)*PYR(0)
9327 IPM=(5-ISIGN(1,KFOLD))/2
9328 KFANEW=-MOD(KFAOLD+1,2)
9329 410 KFANEW=KFANEW+2
9330 IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2
9331 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN
9332 IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM-
9333 & VCKM(KFAOLD/2,(KFANEW+1)/2)
9334 IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM-
9335 & VCKM(KFANEW/2,(KFAOLD+1)/2)
9336 ENDIF
9337 IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410
9338 ENDIF
9339 IF(MINT(2).EQ.1) THEN
9340 MINT(21)=ISIGN(MINT(55),MINT(15))
9341 MINT(22)=ISIGN(KFANEW,MINT(16))
9342 ELSE
9343 MINT(21)=ISIGN(KFANEW,MINT(15))
9344 MINT(22)=ISIGN(MINT(55),MINT(16))
9345 JS=2
9346 ENDIF
9347 KCC=22
9348
9349 ELSEIF(ISUB.EQ.84) THEN
9350C...g + gamma -> Q + Qbar; th arbitary
9351 KCS=(-1)**INT(1.5D0+PYR(0))
9352 MINT(21)=ISIGN(MINT(55),KCS)
9353 MINT(22)=-MINT(21)
9354 KCC=27
9355 IF(MINT(16).EQ.21) KCC=28
9356
9357 ELSEIF(ISUB.EQ.85) THEN
9358C...gamma + gamma -> F + Fbar; th arbitary
9359 KCS=(-1)**INT(1.5D0+PYR(0))
9360 MINT(21)=ISIGN(MINT(56),KCS)
9361 MINT(22)=-MINT(21)
9362 KCC=21
9363
9364 ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN
9365C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
9366 MINT(21)=KFPR(ISUB,1)
9367 MINT(22)=KFPR(ISUB,2)
9368 KCC=24
9369 KCS=(-1)**INT(1.5D0+PYR(0))
9370 ENDIF
9371
9372 ELSEIF(ISUB.LE.100) THEN
9373 IF(ISUB.EQ.95) THEN
9374C...Low-pT ( = energyless g + g -> g + g)
9375 KCC=MINT(2)+12
9376 KCS=(-1)**INT(1.5D0+PYR(0))
9377
9378 ELSEIF(ISUB.EQ.96) THEN
9379C...Multiple interactions (should be reassigned to QCD process)
9380 ENDIF
9381
9382 ELSEIF(ISUB.LE.110) THEN
9383 IF(ISUB.EQ.101) THEN
9384C...g + g -> gamma*/Z0
9385 KCC=21
9386 KFRES=22
9387
9388 ELSEIF(ISUB.EQ.102) THEN
9389C...g + g -> h0 (or H0, or A0)
9390 KCC=21
9391 KFRES=KFHIGG
9392
9393 ELSEIF(ISUB.EQ.103) THEN
9394C...gamma + gamma -> h0 (or H0, or A0)
9395 KCC=21
9396 KFRES=KFHIGG
9397
9398 ELSEIF(ISUB.EQ.104.OR.ISUB.EQ.105) THEN
9399C...g + g -> chi_0c or chi_2c.
9400 KCC=21
9401 KFRES=KFPR(ISUB,1)
9402
9403 ELSEIF(ISUB.EQ.106) THEN
9404C...g + g -> J/Psi + gamma
9405 MINT(21)=KFPR(ISUB,1)
9406 MINT(22)=KFPR(ISUB,2)
9407 KCC=21
9408
9409 ELSEIF(ISUB.EQ.107) THEN
9410C...g + gamma -> J/Psi + g
9411 MINT(21)=KFPR(ISUB,1)
9412 MINT(22)=KFPR(ISUB,2)
9413 KCC=22
9414 IF(MINT(16).EQ.22) KCC=33
9415
9416 ELSEIF(ISUB.EQ.108) THEN
9417C...gamma + gamma -> J/Psi + gamma
9418 MINT(21)=KFPR(ISUB,1)
9419 MINT(22)=KFPR(ISUB,2)
9420
9421 ELSEIF(ISUB.EQ.110) THEN
9422C...f + fbar -> gamma + h0; th arbitrary
9423 IF(PYR(0).GT.0.5D0) JS=2
9424 MINT(20+JS)=22
9425 MINT(23-JS)=KFHIGG
9426 ENDIF
9427
9428 ELSEIF(ISUB.LE.120) THEN
9429 IF(ISUB.EQ.111) THEN
9430C...f + fbar -> g + h0; th arbitrary
9431 IF(PYR(0).GT.0.5D0) JS=2
9432 MINT(20+JS)=21
9433 MINT(23-JS)=KFHIGG
9434 KCC=17+JS
9435
9436 ELSEIF(ISUB.EQ.112) THEN
9437C...f + g -> f + h0; th = (p(f) - p(f))**2
9438 IF(MINT(15).EQ.21) JS=2
9439 MINT(23-JS)=KFHIGG
9440 KCC=15+JS
9441 KCS=ISIGN(1,MINT(14+JS))
9442
9443 ELSEIF(ISUB.EQ.113) THEN
9444C...g + g -> g + h0; th arbitrary
9445 IF(PYR(0).GT.0.5D0) JS=2
9446 MINT(23-JS)=KFHIGG
9447 KCC=22+JS
9448 KCS=(-1)**INT(1.5D0+PYR(0))
9449
9450 ELSEIF(ISUB.EQ.114) THEN
9451C...g + g -> gamma + gamma; th arbitrary
9452 IF(PYR(0).GT.0.5D0) JS=2
9453 MINT(21)=22
9454 MINT(22)=22
9455 KCC=21
9456
9457 ELSEIF(ISUB.EQ.115) THEN
9458C...g + g -> g + gamma; th arbitrary
9459 IF(PYR(0).GT.0.5D0) JS=2
9460 MINT(23-JS)=22
9461 KCC=22+JS
9462 KCS=(-1)**INT(1.5D0+PYR(0))
9463
9464 ELSEIF(ISUB.EQ.116) THEN
9465C...g + g -> gamma + Z0
9466
9467 ELSEIF(ISUB.EQ.117) THEN
9468C...g + g -> Z0 + Z0
9469
9470 ELSEIF(ISUB.EQ.118) THEN
9471C...g + g -> W+ + W-
9472 ENDIF
9473
9474 ELSEIF(ISUB.LE.140) THEN
9475 IF(ISUB.EQ.121) THEN
9476C...g + g -> Q + Qbar + h0
9477 KCS=(-1)**INT(1.5D0+PYR(0))
9478 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
9479 MINT(22)=-MINT(21)
9480 KCC=11+INT(0.5D0+PYR(0))
9481 KFRES=KFHIGG
9482
9483 ELSEIF(ISUB.EQ.122) THEN
9484C...q + qbar -> Q + Qbar + h0
9485 MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15))
9486 MINT(22)=-MINT(21)
9487 KCC=4
9488 KFRES=KFHIGG
9489
9490 ELSEIF(ISUB.EQ.123) THEN
9491C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
9492C...inner process)
9493 KCC=22
9494 KFRES=KFHIGG
9495
9496 ELSEIF(ISUB.EQ.124) THEN
9497C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
9498C...inner process)
9499 DO 430 JT=1,2
9500 I=MINT(14+JT)
9501 IA=IABS(I)
9502 IF(IA.LE.10) THEN
9503 RVCKM=VINT(180+I)*PYR(0)
9504 DO 420 J=1,MSTP(1)
9505 IB=2*J-1+MOD(IA,2)
9506 IPM=(5-ISIGN(1,I))/2
9507 IDC=J+MDCY(IA,2)+2
9508 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420
9509 MINT(20+JT)=ISIGN(IB,I)
9510 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
9511 IF(RVCKM.LE.0D0) GOTO 430
9512 420 CONTINUE
9513 ELSE
9514 IB=2*((IA+1)/2)-1+MOD(IA,2)
9515 MINT(20+JT)=ISIGN(IB,I)
9516 ENDIF
9517 430 CONTINUE
9518 KCC=22
9519 KFRES=KFHIGG
9520
9521 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
9522C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2
9523 IF(MINT(15).EQ.22) JS=2
9524 MINT(23-JS)=21
9525 KCC=24+JS
9526 KCS=ISIGN(1,MINT(14+JS))
9527
9528 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
9529C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2
9530 IF(MINT(15).EQ.22) JS=2
9531 KCC=22
9532 KCS=ISIGN(1,MINT(14+JS))
9533
9534 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
9535C...g + gamma*_(T,L) -> f + fbar; th arbitrary
9536 KCS=(-1)**INT(1.5D0+PYR(0))
9537 MINT(21)=ISIGN(KFLF,KCS)
9538 MINT(22)=-MINT(21)
9539 KCC=27
9540 IF(MINT(16).EQ.21) KCC=28
9541
9542 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
9543C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary
9544 KCS=(-1)**INT(1.5D0+PYR(0))
9545 MINT(21)=ISIGN(KFLF,KCS)
9546 MINT(22)=-MINT(21)
9547 KCC=21
9548
9549 ENDIF
9550
9551 ELSEIF(ISUB.LE.160) THEN
9552 IF(ISUB.EQ.141) THEN
9553C...f + fbar -> gamma*/Z0/Z'0
9554 KFRES=32
9555
9556 ELSEIF(ISUB.EQ.142) THEN
9557C...f + fbar' -> W'+/-
9558 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9559 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9560 KFRES=ISIGN(34,KCH1+KCH2)
9561
9562 ELSEIF(ISUB.EQ.143) THEN
9563C...f + fbar' -> H+/-
9564 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9565 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9566 KFRES=ISIGN(37,KCH1+KCH2)
9567
9568 ELSEIF(ISUB.EQ.144) THEN
9569C...f + fbar' -> R
9570 KFRES=ISIGN(41,MINT(15)+MINT(16))
9571
9572 ELSEIF(ISUB.EQ.145) THEN
9573C...q + l -> LQ (leptoquark)
9574 IF(IABS(MINT(16)).LE.8) JS=2
9575 KFRES=ISIGN(42,MINT(14+JS))
9576 KCC=28+JS
9577 KCS=ISIGN(1,MINT(14+JS))
9578
9579 ELSEIF(ISUB.EQ.146) THEN
9580C...e + gamma -> e* (excited lepton)
9581 IF(MINT(15).EQ.22) JS=2
9582 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
9583 KCC=22
9584
9585 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
9586C...q + g -> q* (excited quark)
9587 IF(MINT(15).EQ.21) JS=2
9588 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
9589 KCC=30+JS
9590 KCS=ISIGN(1,MINT(14+JS))
9591
9592 ELSEIF(ISUB.EQ.149) THEN
9593C...g + g -> eta_tc
9594 KFRES=KTECHN+331
9595 KCC=23
9596 KCS=(-1)**INT(1.5D0+PYR(0))
9597 ENDIF
9598
9599 ELSEIF(ISUB.LE.200) THEN
9600 IF(ISUB.EQ.161) THEN
9601C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
9602 IF(MINT(15).EQ.21) JS=2
9603 I=MINT(14+JS)
9604 IA=IABS(I)
9605 MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I)
9606 IB=IA+MOD(IA,2)-MOD(IA+1,2)
9607 MINT(20+JS)=ISIGN(IB,I)
9608 KCC=15+JS
9609 KCS=ISIGN(1,MINT(14+JS))
9610
9611 ELSEIF(ISUB.EQ.162) THEN
9612C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
9613 IF(MINT(15).EQ.21) JS=2
9614 MINT(20+JS)=ISIGN(42,MINT(14+JS))
9615 KFLQL=KFDP(MDCY(42,2),2)
9616 MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS))
9617 KCC=15+JS
9618 KCS=ISIGN(1,MINT(14+JS))
9619
9620 ELSEIF(ISUB.EQ.163) THEN
9621C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
9622 KCS=(-1)**INT(1.5D0+PYR(0))
9623 MINT(21)=ISIGN(42,KCS)
9624 MINT(22)=-MINT(21)
9625 KCC=MINT(2)+10
9626
9627 ELSEIF(ISUB.EQ.164) THEN
9628C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
9629 MINT(21)=ISIGN(42,MINT(15))
9630 MINT(22)=-MINT(21)
9631 KCC=4
9632
9633 ELSEIF(ISUB.EQ.165) THEN
9634C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
9635 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9636 MINT(22)=-MINT(21)
9637
9638 ELSEIF(ISUB.EQ.166) THEN
9639C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
9640 IF(MOD(MINT(15),2).EQ.0) THEN
9641 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
9642 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
9643 ELSE
9644 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9645 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
9646 ENDIF
9647
9648 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
9649C...q + q' -> q" + q* (excited quark)
9650 KFQSTR=KFPR(ISUB,2)
9651 KFQEXC=MOD(KFQSTR,KEXCIT)
9652 JS=MINT(2)
9653 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
9654 IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC)
9655 & MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
9656 KCC=22
9657 JS=3-JS
9658
9659 ELSEIF(ISUB.EQ.169) THEN
9660C...q + qbar -> e + e* (excited lepton)
9661 KFQSTR=KFPR(ISUB,2)
9662 KFQEXC=MOD(KFQSTR,KEXCIT)
9663 JS=MINT(2)
9664 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
9665 MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
9666 JS=3-JS
9667
9668 ELSEIF(ISUB.EQ.191) THEN
9669C...f + fbar -> rho_tc0.
9670 KFRES=KTECHN+113
9671
9672 ELSEIF(ISUB.EQ.192) THEN
9673C...f + fbar' -> rho_tc+/-
9674 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9675 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9676 KFRES=ISIGN(KTECHN+213,KCH1+KCH2)
9677
9678 ELSEIF(ISUB.EQ.193) THEN
9679C...f + fbar -> omega_tc0.
9680 KFRES=KTECHN+223
9681
9682 ELSEIF(ISUB.EQ.194) THEN
9683C...f + fbar -> f' + fbar' via mixture of s-channel
9684C...rho_tc and omega_tc; th=(p(f)-p(f'))**2
9685 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9686 MINT(22)=-MINT(21)
9687
9688 ELSEIF(ISUB.EQ.195) THEN
9689C...f + fbar' -> f'' + fbar''' via s-channel
9690C...rho_tc+ th=(p(f)-p(f'))**2
9691C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
9692 IF(MOD(MINT(15),2).EQ.0) THEN
9693 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
9694 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
9695 ELSE
9696 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9697 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
9698 ENDIF
9699 ENDIF
9700
9701CMRENNA++
9702 ELSEIF(ISUB.LE.215) THEN
9703 IF(ISUB.EQ.201) THEN
9704C...f + fbar -> ~e_L + ~e_Lbar
9705 MINT(21)=ISIGN(KSUSY1+11,KCS)
9706 MINT(22)=-MINT(21)
9707
9708 ELSEIF(ISUB.EQ.202) THEN
9709C...f + fbar -> ~e_R + ~e_Rbar
9710 MINT(21)=ISIGN(KSUSY2+11,KCS)
9711 MINT(22)=-MINT(21)
9712
9713 ELSEIF(ISUB.EQ.203) THEN
9714C...f + fbar -> ~e_L + ~e_Rbar
9715 KCS=1
9716 IF(MINT(2).EQ.2) KCS=-1
9717 KS2=KSUSY2+11
9718 KS1=KSUSY1+11
9719 IF(KCS.EQ.-1) THEN
9720 KS2=KSUSY1+11
9721 KS1=KSUSY2+11
9722 JS=2
9723 ENDIF
9724 MINT(21)=ISIGN(KS1,MINT(15))
9725 MINT(22)=ISIGN(KS2,MINT(16))
9726
9727c KCS=1
9728c IF(MINT(2).EQ.2) KCS=-1
9729C MINT(21)=ISIGN(KSUSY1+11,KCS)
9730C MINT(22)=-ISIGN(KSUSY2+11,KCS)
9731c IF(KCS.EQ.-1) THEN
9732C KS1=KSUSY1+11
9733C KS2=KSUSY2+11
9734C JS=2
9735c ENDIF
9736c MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9737c MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
9738
9739 ELSEIF(ISUB.EQ.204) THEN
9740C...f + fbar -> ~mu_L + ~mu_Lbar
9741 MINT(21)=ISIGN(KSUSY1+13,KCS)
9742 MINT(22)=-MINT(21)
9743
9744 ELSEIF(ISUB.EQ.205) THEN
9745C...f + fbar -> ~mu_R + ~mu_Rbar
9746 MINT(21)=ISIGN(KSUSY2+13,KCS)
9747 MINT(22)=-MINT(21)
9748
9749 ELSEIF(ISUB.EQ.206) THEN
9750C...f + fbar -> ~mu_L + ~mu_Rbar
9751 KCS=1
9752 IF(MINT(2).EQ.2) KCS=-1
9753 KS2=KSUSY2+13
9754 KS1=KSUSY1+13
9755 IF(KCS.EQ.-1) THEN
9756 KS2=KSUSY1+13
9757 KS1=KSUSY2+13
9758 JS=2
9759 ENDIF
9760 MINT(21)=ISIGN(KS1,MINT(15))
9761 MINT(22)=ISIGN(KS2,MINT(16))
9762c MINT(21)=ISIGN(KSUSY1+13,KCS)
9763c MINT(22)=-ISIGN(KSUSY2+13,KCS)
9764
9765 ELSEIF(ISUB.EQ.207) THEN
9766C...f + fbar -> ~tau_1 + ~tau_1bar
9767 MINT(21)=ISIGN(KSUSY1+15,KCS)
9768 MINT(22)=-MINT(21)
9769
9770 ELSEIF(ISUB.EQ.208) THEN
9771C...f + fbar -> ~tau_2 + ~tau_2bar
9772 MINT(21)=ISIGN(KSUSY2+15,KCS)
9773 MINT(22)=-MINT(21)
9774
9775 ELSEIF(ISUB.EQ.209) THEN
9776C...f + fbar -> ~tau_1 + ~tau_2bar
9777 KCS=1
9778 IF(MINT(2).EQ.2) KCS=-1
9779 KS2=KSUSY2+15
9780 KS1=KSUSY1+15
9781 IF(KCS.EQ.-1) THEN
9782 KS2=KSUSY1+15
9783 KS1=KSUSY2+15
9784 JS=2
9785 ENDIF
9786 MINT(21)=ISIGN(KS1,MINT(15))
9787 MINT(22)=ISIGN(KS2,MINT(16))
9788C KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9789C IF(MINT(2).EQ.1) THEN
9790C MINT(21)= ISIGN(KSUSY1+15,KCH1)
9791C MINT(22)= -ISIGN(KSUSY2+15,KCH1)
9792C ELSE
9793C MINT(21)= ISIGN(KSUSY2+15,KCH1)
9794C MINT(22)= -ISIGN(KSUSY1+15,KCH1)
9795C JS=2
9796C ENDIF
9797
9798 ELSEIF(ISUB.EQ.210) THEN
9799C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
9800 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9801 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9802 MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2)
9803 MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2)
9804
9805 ELSEIF(ISUB.EQ.211) THEN
9806C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
9807 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9808 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9809 MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2)
9810 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
9811
9812 ELSEIF(ISUB.EQ.212) THEN
9813C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
9814 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9815 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9816 MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2)
9817 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
9818
9819 ELSEIF(ISUB.EQ.213) THEN
9820C...f + fbar -> ~nul + ~nulbar
9821 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
9822 MINT(22)=-MINT(21)
9823
9824 ELSEIF(ISUB.EQ.214) THEN
9825C...f + fbar -> ~nutau + ~nutaubar
9826 MINT(21)=ISIGN(KSUSY1+16,KCS)
9827 MINT(22)=-MINT(21)
9828 ENDIF
9829
9830 ELSEIF(ISUB.LE.225) THEN
9831 IF(ISUB.EQ.216) THEN
9832C...f + fbar -> ~chi01 + ~chi01
9833 MINT(21)=KSUSY1+22
9834 MINT(22)=KSUSY1+22
9835
9836 ELSEIF(ISUB.EQ.217) THEN
9837C...f + fbar -> ~chi02 + ~chi02
9838 MINT(21)=KSUSY1+23
9839 MINT(22)=KSUSY1+23
9840
9841 ELSEIF(ISUB.EQ.218 ) THEN
9842C...f + fbar -> ~chi03 + ~chi03
9843 MINT(21)=KSUSY1+25
9844 MINT(22)=KSUSY1+25
9845
9846 ELSEIF(ISUB.EQ.219 ) THEN
9847C...f + fbar -> ~chi04 + ~chi04
9848 MINT(21)=KSUSY1+35
9849 MINT(22)=KSUSY1+35
9850
9851 ELSEIF(ISUB.EQ.220 ) THEN
9852C...f + fbar -> ~chi01 + ~chi02
9853 IF(MINT(15).LT.0) JS=2
9854C IF(PYR(0).GT.0.5D0) JS=2
9855 MINT(20+JS)=KSUSY1+22
9856 MINT(23-JS)=KSUSY1+23
9857
9858 ELSEIF(ISUB.EQ.221 ) THEN
9859C...f + fbar -> ~chi01 + ~chi03
9860 IF(MINT(15).LT.0) JS=2
9861C IF(PYR(0).GT.0.5D0) JS=2
9862 MINT(20+JS)=KSUSY1+22
9863 MINT(23-JS)=KSUSY1+25
9864
9865 ELSEIF(ISUB.EQ.222) THEN
9866C...f + fbar -> ~chi01 + ~chi04
9867 IF(MINT(15).LT.0) JS=2
9868C IF(PYR(0).GT.0.5D0) JS=2
9869 MINT(20+JS)=KSUSY1+22
9870 MINT(23-JS)=KSUSY1+35
9871
9872 ELSEIF(ISUB.EQ.223) THEN
9873C...f + fbar -> ~chi02 + ~chi03
9874 IF(MINT(15).LT.0) JS=2
9875C IF(PYR(0).GT.0.5D0) JS=2
9876 MINT(20+JS)=KSUSY1+23
9877 MINT(23-JS)=KSUSY1+25
9878
9879 ELSEIF(ISUB.EQ.224) THEN
9880C...f + fbar -> ~chi02 + ~chi04
9881 IF(MINT(15).LT.0) JS=2
9882C IF(PYR(0).GT.0.5D0) JS=2
9883 MINT(20+JS)=KSUSY1+23
9884 MINT(23-JS)=KSUSY1+35
9885
9886 ELSEIF(ISUB.EQ.225) THEN
9887C...f + fbar -> ~chi03 + ~chi04
9888 IF(MINT(15).LT.0) JS=2
9889C IF(PYR(0).GT.0.5D0) JS=2
9890 MINT(20+JS)=KSUSY1+25
9891 MINT(23-JS)=KSUSY1+35
9892 ENDIF
9893
9894 ELSEIF(ISUB.LE.236) THEN
9895 IF(ISUB.EQ.226) THEN
9896C...f + fbar -> ~chi+-1 + ~chi-+1
9897C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
9898 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9899 MINT(21)=ISIGN(KSUSY1+24,KCH1)
9900 MINT(22)=-MINT(21)
9901
9902 ELSEIF(ISUB.EQ.227) THEN
9903C...f + fbar -> ~chi+-2 + ~chi-+2
9904 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9905 MINT(21)=ISIGN(KSUSY1+37,KCH1)
9906 MINT(22)=-MINT(21)
9907
9908 ELSEIF(ISUB.EQ.228) THEN
9909C...f + fbar -> ~chi+-1 + ~chi-+2
9910C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
9911C...js=1 if pyr<.5, js=2 if pyr>.5
9912C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
9913C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
9914C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
9915C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
9916 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9917 KCH2=INT(1-KCH1)/2
9918 IF(MINT(2).EQ.1) THEN
9919 MINT(21)= ISIGN(KSUSY1+24,KCH1)
9920 MINT(22)= -ISIGN(KSUSY1+37,KCH1)
9921c IF(KCH2.EQ.0) JS=2
9922 ELSE
9923 MINT(21)= ISIGN(KSUSY1+37,KCH1)
9924 MINT(22)= -ISIGN(KSUSY1+24,KCH1)
9925 JS=2
9926c IF(KCH2.EQ.1) JS=2
9927 ENDIF
9928
9929 ELSEIF(ISUB.EQ.229) THEN
9930C...q + qbar' -> ~chi01 + ~chi+-1
9931C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
9932 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9933 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9934C...CHECK THIS
9935 IF(MOD(MINT(15),2).EQ.0) JS=2
9936 MINT(20+JS)=KSUSY1+22
9937 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
9938
9939 ELSEIF(ISUB.EQ.230) THEN
9940C...q + qbar' -> ~chi02 + ~chi+-1
9941 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9942 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9943 IF(MOD(MINT(15),2).EQ.0) JS=2
9944 MINT(20+JS)=KSUSY1+23
9945 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
9946
9947 ELSEIF(ISUB.EQ.231) THEN
9948C...q + qbar' -> ~chi03 + ~chi+-1
9949 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9950 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9951 IF(MOD(MINT(15),2).EQ.0) JS=2
9952 MINT(20+JS)=KSUSY1+25
9953 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
9954
9955 ELSEIF(ISUB.EQ.232) THEN
9956C...q + qbar' -> ~chi04 + ~chi+-1
9957 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9958 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9959 IF(MOD(MINT(15),2).EQ.0) JS=2
9960 MINT(20+JS)=KSUSY1+35
9961 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
9962
9963 ELSEIF(ISUB.EQ.233) THEN
9964C...q + qbar' -> ~chi01 + ~chi+-2
9965 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9966 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9967 IF(MOD(MINT(15),2).EQ.0) JS=2
9968 MINT(20+JS)=KSUSY1+22
9969 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
9970
9971 ELSEIF(ISUB.EQ.234) THEN
9972C...q + qbar' -> ~chi02 + ~chi+-2
9973 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9974 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9975 IF(MOD(MINT(15),2).EQ.0) JS=2
9976 MINT(20+JS)=KSUSY1+23
9977 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
9978
9979 ELSEIF(ISUB.EQ.235) THEN
9980C...q + qbar' -> ~chi03 + ~chi+-2
9981 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9982 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9983 IF(MOD(MINT(15),2).EQ.0) JS=2
9984 MINT(20+JS)=KSUSY1+25
9985 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
9986
9987 ELSEIF(ISUB.EQ.236) THEN
9988C...q + qbar' -> ~chi04 + ~chi+-2
9989 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9990 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9991 IF(MOD(MINT(15),2).EQ.0) JS=2
9992 MINT(20+JS)=KSUSY1+35
9993 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
9994 ENDIF
9995
9996 ELSEIF(ISUB.LE.245) THEN
9997 IF(ISUB.EQ.237) THEN
9998C...q + qbar -> ~chi01 + ~g
9999C...th arbitrary
10000 IF(PYR(0).GT.0.5D0) JS=2
10001 MINT(20+JS)=KSUSY1+21
10002 MINT(23-JS)=KSUSY1+22
10003 KCC=17+JS
10004
10005 ELSEIF(ISUB.EQ.238) THEN
10006C...q + qbar -> ~chi02 + ~g
10007C...th arbitrary
10008 IF(PYR(0).GT.0.5D0) JS=2
10009 MINT(20+JS)=KSUSY1+21
10010 MINT(23-JS)=KSUSY1+23
10011 KCC=17+JS
10012
10013 ELSEIF(ISUB.EQ.239) THEN
10014C...q + qbar -> ~chi03 + ~g
10015C...th arbitrary
10016 IF(PYR(0).GT.0.5D0) JS=2
10017 MINT(20+JS)=KSUSY1+21
10018 MINT(23-JS)=KSUSY1+25
10019 KCC=17+JS
10020
10021 ELSEIF(ISUB.EQ.240) THEN
10022C...q + qbar -> ~chi04 + ~g
10023C...th arbitrary
10024 IF(PYR(0).GT.0.5D0) JS=2
10025 MINT(20+JS)=KSUSY1+21
10026 MINT(23-JS)=KSUSY1+35
10027 KCC=17+JS
10028
10029 ELSEIF(ISUB.EQ.241) THEN
10030C...q + qbar' -> ~chi+-1 + ~g
10031C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
10032C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
10033C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
10034C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
10035C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
10036 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10037 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10038 JS=1
10039 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10040 MINT(20+JS)=KSUSY1+21
10041 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
10042 KCC=17+JS
10043
10044 ELSEIF(ISUB.EQ.242) THEN
10045C...q + qbar' -> ~chi+-2 + ~g
10046C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
10047C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
10048C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
10049C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
10050C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
10051 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10052 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10053 JS=1
10054 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10055 MINT(20+JS)=KSUSY1+21
10056 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
10057 KCC=17+JS
10058
10059 ELSEIF(ISUB.EQ.243) THEN
10060C...q + qbar -> ~g + ~g ; th arbitrary
10061 MINT(21)=KSUSY1+21
10062 MINT(22)=KSUSY1+21
10063 KCC=MINT(2)+4
10064
10065 ELSEIF(ISUB.EQ.244) THEN
10066C...g + g -> ~g + ~g ; th arbitrary
10067 KCC=MINT(2)+12
10068 KCS=(-1)**INT(1.5D0+PYR(0))
10069 MINT(21)=KSUSY1+21
10070 MINT(22)=KSUSY1+21
10071 ENDIF
10072
10073 ELSEIF(ISUB.LE.260) THEN
10074 IF(ISUB.EQ.246) THEN
10075C...qj + g -> ~qj_L + ~chi01
10076 IF(MINT(15).EQ.21) JS=2
10077 I=MINT(14+JS)
10078 IA=IABS(I)
10079 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10080 MINT(23-JS)=KSUSY1+22
10081 KCC=15+JS
10082 KCS=ISIGN(1,MINT(14+JS))
10083
10084 ELSEIF(ISUB.EQ.247) THEN
10085C...qj + g -> ~qj_R + ~chi01
10086 IF(MINT(15).EQ.21) JS=2
10087 I=MINT(14+JS)
10088 IA=IABS(I)
10089 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10090 MINT(23-JS)=KSUSY1+22
10091 KCC=15+JS
10092 KCS=ISIGN(1,MINT(14+JS))
10093
10094 ELSEIF(ISUB.EQ.248) THEN
10095C...qj + g -> ~qj_L + ~chi02
10096 IF(MINT(15).EQ.21) JS=2
10097 I=MINT(14+JS)
10098 IA=IABS(I)
10099 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10100 MINT(23-JS)=KSUSY1+23
10101 KCC=15+JS
10102 KCS=ISIGN(1,MINT(14+JS))
10103
10104 ELSEIF(ISUB.EQ.249) THEN
10105C...qj + g -> ~qj_R + ~chi02
10106 IF(MINT(15).EQ.21) JS=2
10107 I=MINT(14+JS)
10108 IA=IABS(I)
10109 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10110 MINT(23-JS)=KSUSY1+23
10111 KCC=15+JS
10112 KCS=ISIGN(1,MINT(14+JS))
10113
10114 ELSEIF(ISUB.EQ.250) THEN
10115C...qj + g -> ~qj_L + ~chi03
10116 IF(MINT(15).EQ.21) JS=2
10117 I=MINT(14+JS)
10118 IA=IABS(I)
10119 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10120 MINT(23-JS)=KSUSY1+25
10121 KCC=15+JS
10122 KCS=ISIGN(1,MINT(14+JS))
10123
10124 ELSEIF(ISUB.EQ.251) THEN
10125C...qj + g -> ~qj_R + ~chi03
10126 IF(MINT(15).EQ.21) JS=2
10127 I=MINT(14+JS)
10128 IA=IABS(I)
10129 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10130 MINT(23-JS)=KSUSY1+25
10131 KCC=15+JS
10132 KCS=ISIGN(1,MINT(14+JS))
10133
10134 ELSEIF(ISUB.EQ.252) THEN
10135C...qj + g -> ~qj_L + ~chi04
10136 IF(MINT(15).EQ.21) JS=2
10137 I=MINT(14+JS)
10138 IA=IABS(I)
10139 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10140 MINT(23-JS)=KSUSY1+35
10141 KCC=15+JS
10142 KCS=ISIGN(1,MINT(14+JS))
10143
10144 ELSEIF(ISUB.EQ.253) THEN
10145C...qj + g -> ~qj_R + ~chi04
10146 IF(MINT(15).EQ.21) JS=2
10147 I=MINT(14+JS)
10148 IA=IABS(I)
10149 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10150 MINT(23-JS)=KSUSY1+35
10151 KCC=15+JS
10152 KCS=ISIGN(1,MINT(14+JS))
10153
10154 ELSEIF(ISUB.EQ.254) THEN
10155C...qj + g -> ~qk_L + ~chi+-1
10156 IF(MINT(15).EQ.21) JS=2
10157 I=MINT(14+JS)
10158 IA=IABS(I)
10159 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
10160 IB=-IA+INT((IA+1)/2)*4-1
10161 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
10162 KCC=15+JS
10163 KCS=ISIGN(1,MINT(14+JS))
10164
10165 ELSEIF(ISUB.EQ.255) THEN
10166C...qj + g -> ~qk_L + ~chi+-1
10167 IF(MINT(15).EQ.21) JS=2
10168 I=MINT(14+JS)
10169 IA=IABS(I)
10170 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
10171 IB=-IA+INT((IA+1)/2)*4-1
10172 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
10173 KCC=15+JS
10174 KCS=ISIGN(1,MINT(14+JS))
10175
10176 ELSEIF(ISUB.EQ.256) THEN
10177C...qj + g -> ~qk_L + ~chi+-2
10178 IF(MINT(15).EQ.21) JS=2
10179 I=MINT(14+JS)
10180 IA=IABS(I)
10181 IB=-IA+INT((IA+1)/2)*4-1
10182 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
10183 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
10184 KCC=15+JS
10185 KCS=ISIGN(1,MINT(14+JS))
10186
10187 ELSEIF(ISUB.EQ.257) THEN
10188C...qj + g -> ~qk_R + ~chi+-2
10189 IF(MINT(15).EQ.21) JS=2
10190 I=MINT(14+JS)
10191 IA=IABS(I)
10192 IB=-IA+INT((IA+1)/2)*4-1
10193 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
10194 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
10195 KCC=15+JS
10196 KCS=ISIGN(1,MINT(14+JS))
10197
10198 ELSEIF(ISUB.EQ.258) THEN
10199C...qj + g -> ~qj_L + ~g
10200 IF(MINT(15).EQ.21) JS=2
10201 I=MINT(14+JS)
10202 IA=IABS(I)
10203 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10204 MINT(23-JS)=KSUSY1+21
10205 KCC=MINT(2)+6
10206 IF(JS.EQ.2) KCC=KCC+2
10207 KCS=ISIGN(1,I)
10208
10209 ELSEIF(ISUB.EQ.259) THEN
10210C...qj + g -> ~qj_R + ~g
10211 IF(MINT(15).EQ.21) JS=2
10212 I=MINT(14+JS)
10213 IA=IABS(I)
10214 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10215 MINT(23-JS)=KSUSY1+21
10216 KCC=MINT(2)+6
10217 IF(JS.EQ.2) KCC=KCC+2
10218 KCS=ISIGN(1,I)
10219 ENDIF
10220
10221 ELSEIF(ISUB.LE.270) THEN
10222 IF(ISUB.EQ.261) THEN
10223C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
10224 ISGN=1
10225 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
10226 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
10227 MINT(22)=-MINT(21)
10228C...Correct color combination
10229 IF(MINT(43).EQ.4) KCC=4
10230
10231 ELSEIF(ISUB.EQ.262) THEN
10232C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
10233 ISGN=1
10234 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
10235 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
10236 MINT(22)=-MINT(21)
10237C...Correct color combination
10238 IF(MINT(43).EQ.4) KCC=4
10239
10240 ELSEIF(ISUB.EQ.263) THEN
10241C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
10242 IF((KCS.GT.0.AND.MINT(2).EQ.1).OR.
10243 & (KCS.LT.0.AND.MINT(2).EQ.2)) THEN
10244 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10245 MINT(22)=-ISIGN(KFPR(ISUB,2),KCS)
10246 ELSE
10247 JS=2
10248 MINT(21)=ISIGN(KFPR(ISUB,2),KCS)
10249 MINT(22)=-ISIGN(KFPR(ISUB,1),KCS)
10250 ENDIF
10251C...Correct color combination
10252 IF(MINT(43).EQ.4) KCC=4
10253
10254 ELSEIF(ISUB.EQ.264) THEN
10255C...g + g -> ~t_1 + ~t_1bar; th arbitrary
10256 KCS=(-1)**INT(1.5D0+PYR(0))
10257 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10258 MINT(22)=-MINT(21)
10259 KCC=MINT(2)+10
10260
10261 ELSEIF(ISUB.EQ.265) THEN
10262C...g + g -> ~t_2 + ~t_2bar; th arbitrary
10263 KCS=(-1)**INT(1.5D0+PYR(0))
10264 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10265 MINT(22)=-MINT(21)
10266 KCC=MINT(2)+10
10267 ENDIF
10268
10269 ELSEIF(ISUB.LE.296) THEN
10270 IF(ISUB.EQ.271.OR.ISUB.EQ.281.OR.ISUB.EQ.291) THEN
10271C...qi + qj -> ~qi_L + ~qj_L
10272 KCC=MINT(2)
10273 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10274 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
10275 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
10276
10277 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.282.OR.ISUB.EQ.292) THEN
10278C...qi + qj -> ~qi_R + ~qj_R
10279 KCC=MINT(2)
10280 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10281 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
10282 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
10283
10284 ELSEIF(ISUB.EQ.273.OR.ISUB.EQ.283.OR.ISUB.EQ.293) THEN
10285C...qi + qj -> ~qi_L + ~qj_R
10286 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
10287 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
10288 KCC=MINT(2)
10289 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10290
10291 ELSEIF(ISUB.EQ.274.OR.ISUB.EQ.284) THEN
10292C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
10293 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
10294 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
10295 KCC=MINT(2)
10296 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10297
10298 ELSEIF(ISUB.EQ.275.OR.ISUB.EQ.285) THEN
10299C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
10300 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
10301 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
10302 KCC=MINT(2)
10303 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10304
10305 ELSEIF(ISUB.EQ.276.OR.ISUB.EQ.286.OR.ISUB.EQ.296) THEN
10306C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
10307 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
10308 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
10309 KCC=MINT(2)
10310 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10311
10312 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.287) THEN
10313C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
10314 ISGN=1
10315 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
10316 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
10317 MINT(22)=-MINT(21)
10318 IF(MINT(43).EQ.4) KCC=4
10319
10320 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.288) THEN
10321C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
10322 ISGN=1
10323 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
10324 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
10325 MINT(22)=-MINT(21)
10326 IF(MINT(43).EQ.4) KCC=4
10327
10328 ELSEIF(ISUB.EQ.279.OR.ISUB.EQ.289) THEN
10329C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
10330C...pure LL + RR
10331 KCS=(-1)**INT(1.5D0+PYR(0))
10332 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10333 MINT(22)=-MINT(21)
10334 KCC=MINT(2)+10
10335
10336 ELSEIF(ISUB.EQ.280.OR.ISUB.EQ.290) THEN
10337C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
10338 KCS=(-1)**INT(1.5D0+PYR(0))
10339 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10340 MINT(22)=-MINT(21)
10341 KCC=MINT(2)+10
10342
10343 ELSEIF(ISUB.EQ.294) THEN
10344C...qj + g -> ~qj_L + ~g
10345 IF(MINT(15).EQ.21) JS=2
10346 I=MINT(14+JS)
10347 IA=IABS(I)
10348 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10349 MINT(23-JS)=KSUSY1+21
10350 KCC=MINT(2)+6
10351 IF(JS.EQ.2) KCC=KCC+2
10352 KCS=ISIGN(1,I)
10353
10354 ELSEIF(ISUB.EQ.295) THEN
10355C...qj + g -> ~qj_R + ~g
10356 IF(MINT(15).EQ.21) JS=2
10357 I=MINT(14+JS)
10358 IA=IABS(I)
10359 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10360 MINT(23-JS)=KSUSY1+21
10361 KCC=MINT(2)+6
10362 IF(JS.EQ.2) KCC=KCC+2
10363 KCS=ISIGN(1,I)
10364 ENDIF
10365
10366 ELSEIF(ISUB.LE.340) THEN
10367
10368 IF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
10369C...q + qbar' -> H+ + H0
10370 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10371 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10372 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10373 MINT(20+JS)=ISIGN(37,KCH1+KCH2)
10374 MINT(23-JS)=KFPR(ISUB,2)
10375 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
10376C...f + fbar -> A0 + H0; th arbitrary
10377 IF(PYR(0).GT.0.5D0) JS=2
10378 MINT(20+JS)=KFPR(ISUB,1)
10379 MINT(23-JS)=KFPR(ISUB,2)
10380 ELSEIF(ISUB.EQ.301) THEN
10381C...f + fbar -> H+ H-
10382 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10383 MINT(22)=-MINT(21)
10384 ENDIF
10385CMRENNA--
10386
10387 ELSEIF(ISUB.LE.360) THEN
10388
10389 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
10390C...l + l -> H_L++/--, H_R++/--
10391 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10392 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10393 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
10394
10395 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
10396C...l + gamma -> l' + H++/--; th=(p(l)-p(H))**2
10397 IF(MINT(15).EQ.22) JS=2
10398 MINT(20+JS)=ISIGN(KFPR(ISUB,1),-MINT(14+JS))
10399 MINT(23-JS)=ISIGN(KFPR(ISUB,2),-MINT(14+JS))
10400 KCC=22
10401
10402 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
10403C...f + fbar -> H++ + H--; th = (p(f)-p(H--))**2
10404 MINT(21)=-ISIGN(KFPR(ISUB,1),MINT(15))
10405 MINT(22)=-MINT(21)
10406
10407 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
10408C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/--
10409C...as inner process).
10410 DO 450 JT=1,2
10411 I=MINT(14+JT)
10412 IA=IABS(I)
10413 IF(IA.LE.10) THEN
10414 RVCKM=VINT(180+I)*PYR(0)
10415 DO 440 J=1,MSTP(1)
10416 IB=2*J-1+MOD(IA,2)
10417 IPM=(5-ISIGN(1,I))/2
10418 IDC=J+MDCY(IA,2)+2
10419 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 440
10420 MINT(20+JT)=ISIGN(IB,I)
10421 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10422 IF(RVCKM.LE.0D0) GOTO 450
10423 440 CONTINUE
10424 ELSE
10425 IB=2*((IA+1)/2)-1+MOD(IA,2)
10426 MINT(20+JT)=ISIGN(IB,I)
10427 ENDIF
10428 450 CONTINUE
10429 KCC=22
10430 KFRES=ISIGN(KFPR(ISUB,1),MINT(15))
10431 IF(MOD(MINT(15),2).EQ.1) KFRES=-KFRES
10432
10433 ELSEIF(ISUB.EQ.353) THEN
10434C...f + fbar -> Z_R0
10435 KFRES=KFPR(ISUB,1)
10436
10437 ELSEIF(ISUB.EQ.354) THEN
10438C...f + fbar' -> W+/-
10439 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10440 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10441 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
10442
10443 ENDIF
10444
10445 ELSEIF(ISUB.LE.380) THEN
10446
10447 IF(ISUB.LE.363.OR.ISUB.EQ.368) THEN
10448C...f + fbar -> charged+ charged- technicolor
10449 KSW=(-1)**INT(1.5D0+PYR(0))
10450 MINT(21)=ISIGN(KFPR(ISUB,1),KSW)
10451 MINT(22)=-ISIGN(KFPR(ISUB,2),KSW)
10452
10453 ELSEIF(ISUB.LE.367) THEN
10454C...f + fbar -> neutral neutral technicolor
10455 MINT(21)=KFPR(ISUB,1)
10456 MINT(22)=KFPR(ISUB,2)
10457
10458 ELSEIF(ISUB.EQ.374.OR.ISUB.EQ.375) THEN
10459C...f + fbar' -> neutral charged technicolor
10460 IN=1
10461 IC=2
10462 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10463 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10464 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10465 MINT(23-JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
10466 MINT(20+JS)=KFPR(ISUB,IN)
10467
10468 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
10469C...f + fbar' -> charged neutral technicolor
10470 IN=2
10471 IC=1
10472 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10473 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10474 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10475 MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
10476 MINT(23-JS)=KFPR(ISUB,IN)
10477 ENDIF
10478
10479 ELSEIF(ISUB.LE.400) THEN
10480 IF(ISUB.EQ.391) THEN
10481C...f + fbar -> G*.
10482 KFRES=KFPR(ISUB,1)
10483
10484 ELSEIF(ISUB.EQ.392) THEN
10485C...g + g -> G*.
10486 KCC=21
10487 KFRES=KFPR(ISUB,1)
10488
10489 ELSEIF(ISUB.EQ.393) THEN
10490C...q + qbar -> g + G*; th arbitrary.
10491 IF(PYR(0).GT.0.5D0) JS=2
10492 MINT(20+JS)=KFPR(ISUB,1)
10493 MINT(23-JS)=KFPR(ISUB,2)
10494 KCC=17+JS
10495
10496 ELSEIF(ISUB.EQ.394) THEN
10497C...q + g -> q + G*; th = (p(f) - p(f))**2
10498 IF(MINT(15).EQ.21) JS=2
10499 MINT(23-JS)=KFPR(ISUB,2)
10500 KCC=15+JS
10501 KCS=ISIGN(1,MINT(14+JS))
10502
10503 ELSEIF(ISUB.EQ.395) THEN
10504C...g + g -> G* + g; th arbitrary.
10505 IF(PYR(0).GT.0.5D0) JS=2
10506 MINT(23-JS)=KFPR(ISUB,2)
10507 KCC=22+JS
10508 ENDIF
10509 ENDIF
10510
10511 IF(ISET(ISUB).EQ.11) THEN
10512C...Store documentation for user-defined processes
10513 BEZUP=(PUP(3,1)+PUP(3,2))/(PUP(4,1)+PUP(4,2))
10514 KUPPO(1)=MINT(83)+5
10515 KUPPO(2)=MINT(83)+6
10516 I=MINT(83)+6
10517 DO 470 IUP=3,NUP
10518 KUPPO(IUP)=0
10519 IF(MSTP(128).GE.2.AND.MOTHUP(1,IUP).GE.3) THEN
10520 IDOC=IDOC-1
10521 MINT(4)=MINT(4)-1
10522 GOTO 470
10523 ENDIF
10524 I=I+1
10525 KUPPO(IUP)=I
10526 K(I,1)=21
10527 K(I,2)=IDUP(IUP)
10528 IF(IDUP(IUP).EQ.0) K(I,2)=90
10529 K(I,3)=0
10530 IF(MOTHUP(1,IUP).GE.3) K(I,3)=KUPPO(MOTHUP(1,IUP))
10531 K(I,4)=0
10532 K(I,5)=0
10533 DO 460 J=1,5
10534 P(I,J)=PUP(J,IUP)
10535 460 CONTINUE
10536 V(I,5)=VTIMUP(IUP)
10537 470 CONTINUE
10538 CALL PYROBO(MINT(83)+7,MINT(83)+4+NUP,0D0,VINT(24),0D0,0D0,
10539 & -BEZUP)
10540
10541C...Store final state partons for user-defined processes
10542 N=IPU2
10543 DO 490 IUP=3,NUP
10544 N=N+1
10545 K(N,1)=1
10546 IF(ISTUP(IUP).EQ.2.OR.ISTUP(IUP).EQ.3) K(N,1)=11
10547 K(N,2)=IDUP(IUP)
10548 IF(IDUP(IUP).EQ.0) K(N,2)=90
10549 IF(MSTP(128).LE.0.OR.MOTHUP(1,IUP).EQ.0) THEN
10550 K(N,3)=KUPPO(IUP)
10551 ELSE
10552 K(N,3)=MINT(84)+MOTHUP(1,IUP)
10553 ENDIF
10554 K(N,4)=0
10555 K(N,5)=0
10556 DO 480 J=1,5
10557 P(N,J)=PUP(J,IUP)
10558 480 CONTINUE
10559 V(N,5)=VTIMUP(IUP)
10560 490 CONTINUE
10561 CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP)
10562
10563C...Arrange colour flow for user-defined processes
10564 NLBL=0
10565 DO 540 IUP1=1,NUP
10566 I1=MINT(84)+IUP1
10567 IF(KCHG(PYCOMP(K(I1,2)),2).EQ.0) GOTO 540
10568 IF(K(I1,1).EQ.1) K(I1,1)=3
10569 IF(K(I1,1).EQ.11) K(I1,1)=14
10570C...Find a not yet considered colour/anticolour line.
10571 DO 530 ISDE1=1,2
10572 IF(ICOLUP(ISDE1,IUP1).EQ.0) GOTO 530
10573 NMAT=0
10574 DO 500 ILBL=1,NLBL
10575 IF(ICOLUP(ISDE1,IUP1).EQ.ILAB(ILBL)) NMAT=1
10576 500 CONTINUE
10577 IF(NMAT.EQ.0) THEN
10578 NLBL=NLBL+1
10579 ILAB(NLBL)=ICOLUP(ISDE1,IUP1)
10580C...Find all others belonging to same line.
10581 I3=I1
10582 I4=0
10583 DO 520 IUP2=IUP1+1,NUP
10584 I2=MINT(84)+IUP2
10585 DO 510 ISDE2=1,2
10586 IF(ICOLUP(ISDE2,IUP2).EQ.ICOLUP(ISDE1,IUP1)) THEN
10587 IF(ISDE2.EQ.ISDE1) THEN
10588 K(I3,3+ISDE2)=K(I3,3+ISDE2)+I2
10589 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I3
10590 I3=I2
10591 ELSEIF(I4.NE.0) THEN
10592 K(I4,3+ISDE2)=K(I4,3+ISDE2)+I2
10593 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I4
10594 I4=I2
10595 ELSEIF(IUP2.LE.2) THEN
10596 K(I1,3+ISDE1)=K(I1,3+ISDE1)+I2
10597 K(I2,3+ISDE2)=K(I2,3+ISDE2)+I1
10598 I4=I2
10599 ELSE
10600 K(I1,3+ISDE1)=K(I1,3+ISDE1)+MSTU(5)*I2
10601 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I1
10602 I4=I2
10603 ENDIF
10604 ENDIF
10605 510 CONTINUE
10606 520 CONTINUE
10607 ENDIF
10608 530 CONTINUE
10609 540 CONTINUE
10610
10611 ELSEIF(IDOC.EQ.7) THEN
10612C...Resonance not decaying; store kinematics
10613 I=MINT(83)+7
10614 K(IPU3,1)=1
10615 K(IPU3,2)=KFRES
10616 K(IPU3,3)=I
10617 P(IPU3,4)=SHUSER
10618 P(IPU3,5)=SHUSER
10619 K(I,1)=21
10620 K(I,2)=KFRES
10621 P(I,4)=SHUSER
10622 P(I,5)=SHUSER
10623 N=IPU3
10624 MINT(21)=KFRES
10625 MINT(22)=0
10626
10627C...Special cases: colour flow in coloured resonances
10628 KCRES=PYCOMP(KFRES)
10629 IF(KCHG(KCRES,2).NE.0) THEN
10630 K(IPU3,1)=3
10631 DO 550 J=1,2
10632 JC=J
10633 IF(KCS.EQ.-1) JC=3-J
10634 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
10635 & MINT(84)+ICOL(KCC,1,JC)
10636 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
10637 & MINT(84)+ICOL(KCC,2,JC)
10638 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
10639 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
10640 550 CONTINUE
10641 ELSE
10642 K(IPU1,4)=IPU2
10643 K(IPU1,5)=IPU2
10644 K(IPU2,4)=IPU1
10645 K(IPU2,5)=IPU1
10646 ENDIF
10647
10648 ELSEIF(IDOC.EQ.8) THEN
10649C...2 -> 2 processes: store outgoing partons in their CM-frame
10650 DO 560 JT=1,2
10651 I=MINT(84)+2+JT
10652 KCA=PYCOMP(MINT(20+JT))
10653 K(I,1)=1
10654 IF(KCHG(KCA,2).NE.0) K(I,1)=3
10655 K(I,2)=MINT(20+JT)
10656 K(I,3)=MINT(83)+IDOC+JT-2
10657 KFAA=IABS(K(I,2))
10658 IF(KFPR(ISUBSV,1+MOD(JS+JT,2)).NE.0) THEN
10659 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
10660 ELSE
10661 P(I,5)=PYMASS(K(I,2))
10662 ENDIF
10663 IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND.
10664 & P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2))
10665 560 CONTINUE
10666 IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
10667 KFA1=IABS(MINT(21))
10668 KFA2=IABS(MINT(22))
10669 IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
10670 & THEN
10671 MINT(51)=1
10672 RETURN
10673 ENDIF
10674 P(IPU3,5)=0D0
10675 P(IPU4,5)=0D0
10676 ENDIF
10677 P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
10678 P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2))
10679 P(IPU4,4)=SHR-P(IPU3,4)
10680 P(IPU4,3)=-P(IPU3,3)
10681 N=IPU4
10682 MINT(7)=MINT(83)+7
10683 MINT(8)=MINT(83)+8
10684
10685C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
10686 CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
10687
10688 ELSEIF(IDOC.EQ.9) THEN
10689C...2 -> 3 processes: store outgoing partons in their CM frame
10690 DO 570 JT=1,2
10691 I=MINT(84)+2+JT
10692 KCA=PYCOMP(MINT(20+JT))
10693 K(I,1)=1
10694 IF(KCHG(KCA,2).NE.0) K(I,1)=3
10695 K(I,2)=MINT(20+JT)
10696 K(I,3)=MINT(83)+IDOC+JT-3
10697 IF(IABS(K(I,2)).LE.22) THEN
10698 P(I,5)=PYMASS(K(I,2))
10699 ELSE
10700 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
10701 ENDIF
10702 PT=SQRT(MAX(0D0,VINT(197+5*JT)-P(I,5)**2+VINT(196+5*JT)**2))
10703 P(I,1)=PT*COS(VINT(198+5*JT))
10704 P(I,2)=PT*SIN(VINT(198+5*JT))
10705 570 CONTINUE
10706 K(IPU5,1)=1
10707 K(IPU5,2)=KFRES
10708 K(IPU5,3)=MINT(83)+IDOC
10709 P(IPU5,5)=SHR
10710 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
10711 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
10712 PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
10713 PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2
10714 PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2
10715 PMT3=SQRT(PMS3)
10716 P(IPU5,3)=PMT3*SINH(VINT(211))
10717 P(IPU5,4)=PMT3*COSH(VINT(211))
10718 PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2
10719 SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2
10720 IF(SQL12.LE.0D0) THEN
10721 MINT(51)=1
10722 RETURN
10723 ENDIF
10724 P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+
10725 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
10726 P(IPU4,3)=-P(IPU3,3)-P(IPU5,3)
10727 P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2)
10728 P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2)
10729 MINT(23)=KFRES
10730 N=IPU5
10731 MINT(7)=MINT(83)+7
10732 MINT(8)=MINT(83)+8
10733
10734 ELSEIF(IDOC.EQ.11) THEN
10735C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
10736 PHI(1)=PARU(2)*PYR(0)
10737 PHI(2)=PHI(1)-PHIR
10738 DO 580 JT=1,2
10739 I=MINT(84)+2+JT
10740 K(I,1)=1
10741 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
10742 K(I,2)=MINT(20+JT)
10743 K(I,3)=MINT(83)+IDOC+JT-2
10744 P(I,5)=PYMASS(K(I,2))
10745 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN
10746 MINT(51)=1
10747 RETURN
10748 ENDIF
10749 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
10750 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
10751 P(I,1)=PTABS*COS(PHI(JT))
10752 P(I,2)=PTABS*SIN(PHI(JT))
10753 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
10754 P(I,4)=0.5D0*SHPR*Z(JT)
10755 IZW=MINT(83)+6+JT
10756 K(IZW,1)=21
10757 K(IZW,2)=23
10758 IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT)))
10759 K(IZW,3)=IZW-2
10760 P(IZW,1)=-P(I,1)
10761 P(IZW,2)=-P(I,2)
10762 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
10763 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
10764 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
10765 580 CONTINUE
10766 I=MINT(83)+9
10767 K(IPU5,1)=1
10768 K(IPU5,2)=KFRES
10769 K(IPU5,3)=I
10770 P(IPU5,5)=SHR
10771 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
10772 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
10773 P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
10774 P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
10775 K(I,1)=21
10776 K(I,2)=KFRES
10777 DO 590 J=1,5
10778 P(I,J)=P(IPU5,J)
10779 590 CONTINUE
10780 N=IPU5
10781 MINT(23)=KFRES
10782
10783 ELSEIF(IDOC.EQ.12) THEN
10784C...Z0 and W+/- scattering: store bosons and outgoing partons
10785 PHI(1)=PARU(2)*PYR(0)
10786 PHI(2)=PHI(1)-PHIR
10787 JTRAN=INT(1.5D0+PYR(0))
10788 DO 600 JT=1,2
10789 I=MINT(84)+2+JT
10790 K(I,1)=1
10791 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
10792 K(I,2)=MINT(20+JT)
10793 K(I,3)=MINT(83)+IDOC+JT-2
10794 P(I,5)=PYMASS(K(I,2))
10795 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0
10796 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
10797 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
10798 P(I,1)=PTABS*COS(PHI(JT))
10799 P(I,2)=PTABS*SIN(PHI(JT))
10800 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
10801 P(I,4)=0.5D0*SHPR*Z(JT)
10802 IZW=MINT(83)+6+JT
10803 K(IZW,1)=21
10804 IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
10805 K(IZW,2)=23
10806 ELSE
10807 K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT)))
10808 ENDIF
10809 K(IZW,3)=IZW-2
10810 P(IZW,1)=-P(I,1)
10811 P(IZW,2)=-P(I,2)
10812 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
10813 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
10814 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
10815 IPU=MINT(84)+4+JT
10816 K(IPU,1)=3
10817 K(IPU,2)=KFPR(ISUB,JT)
10818 IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2)
10819 IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2)
10820 K(IPU,3)=MINT(83)+8+JT
10821 IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
10822 P(IPU,5)=PYMASS(K(IPU,2))
10823 ELSE
10824 P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
10825 ENDIF
10826 MINT(22+JT)=K(IPU,2)
10827 600 CONTINUE
10828C...Find rotation and boost for hard scattering subsystem
10829 I1=MINT(83)+7
10830 I2=MINT(83)+8
10831 BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
10832 BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
10833 BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
10834 GAMCM=(P(I1,4)+P(I2,4))/SHR
10835 BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
10836 PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM
10837 PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM
10838 PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM
10839 THECM=PYANGL(PZ,SQRT(PX**2+PY**2))
10840 PHICM=PYANGL(PX,PY)
10841C...Store hard scattering subsystem. Rotate and boost it
10842 SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2*
10843 & P(IPU6,5)**2
10844 PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH)))
10845 CTHWZ=VINT(23)
10846 STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2))
10847 PHIWZ=VINT(24)-PHICM
10848 P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
10849 P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
10850 P(IPU5,3)=PABS*CTHWZ
10851 P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
10852 P(IPU6,1)=-P(IPU5,1)
10853 P(IPU6,2)=-P(IPU5,2)
10854 P(IPU6,3)=-P(IPU5,3)
10855 P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
10856 CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM)
10857 DO 620 JT=1,2
10858 I1=MINT(83)+8+JT
10859 I2=MINT(84)+4+JT
10860 K(I1,1)=21
10861 K(I1,2)=K(I2,2)
10862 DO 610 J=1,5
10863 P(I1,J)=P(I2,J)
10864 610 CONTINUE
10865 620 CONTINUE
10866 N=IPU6
10867 MINT(7)=MINT(83)+9
10868 MINT(8)=MINT(83)+10
10869 ENDIF
10870
10871 IF(ISET(ISUB).EQ.11) THEN
10872 ELSEIF(IDOC.GE.8) THEN
10873C...Store colour connection indices
10874 DO 630 J=1,2
10875 JC=J
10876 IF(KCS.EQ.-1) JC=3-J
10877 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
10878 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
10879 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
10880 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
10881 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
10882 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
10883 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
10884 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
10885 630 CONTINUE
10886
10887C...Copy outgoing partons to documentation lines
10888 IMAX=2
10889 IF(IDOC.EQ.9) IMAX=3
10890 DO 650 I=1,IMAX
10891 I1=MINT(83)+IDOC-IMAX+I
10892 I2=MINT(84)+2+I
10893 K(I1,1)=21
10894 K(I1,2)=K(I2,2)
10895 IF(IDOC.LE.9) K(I1,3)=0
10896 IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
10897 DO 640 J=1,5
10898 P(I1,J)=P(I2,J)
10899 640 CONTINUE
10900 650 CONTINUE
10901
10902 ELSEIF(IDOC.EQ.9) THEN
10903C...Store colour connection indices
10904 DO 660 J=1,2
10905 JC=J
10906 IF(KCS.EQ.-1) JC=3-J
10907 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
10908 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+
10909 & MAX(0,MIN(1,ICOL(KCC,1,JC)-2))
10910 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
10911 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+
10912 & MAX(0,MIN(1,ICOL(KCC,2,JC)-2))
10913 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
10914 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
10915 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)=
10916 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
10917 660 CONTINUE
10918
10919C...Copy outgoing partons to documentation lines
10920 DO 680 I=1,3
10921 I1=MINT(83)+IDOC-3+I
10922 I2=MINT(84)+2+I
10923 K(I1,1)=21
10924 K(I1,2)=K(I2,2)
10925 K(I1,3)=0
10926 DO 670 J=1,5
10927 P(I1,J)=P(I2,J)
10928 670 CONTINUE
10929 680 CONTINUE
10930 ENDIF
10931
10932C...Low-pT events: remove gluons used for string drawing purposes
10933 IF(ISUB.EQ.95) THEN
10934 K(IPU3,1)=K(IPU3,1)+10
10935 K(IPU4,1)=K(IPU4,1)+10
10936 DO 690 J=41,66
10937 VINTSV(J)=VINT(J)
10938 VINT(J)=0D0
10939 690 CONTINUE
10940 DO 710 I=MINT(83)+5,MINT(83)+8
10941 DO 700 J=1,5
10942 P(I,J)=0D0
10943 700 CONTINUE
10944 710 CONTINUE
10945 ENDIF
10946
10947 RETURN
10948 END
10949
10950C*********************************************************************
10951
10952C...PYSSPA
10953C...Generates spacelike parton showers.
10954
10955 SUBROUTINE PYSSPA(IPU1,IPU2)
10956
10957C...Double precision and integer declarations.
10958 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
10959 IMPLICIT INTEGER(I-N)
10960 INTEGER PYK,PYCHGE,PYCOMP
10961C...Commonblocks.
10962 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
10963 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10964 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
10965 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
10966 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
10967 COMMON/PYINT1/MINT(400),VINT(400)
10968 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
10969 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
10970 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
10971 &/PYINT2/,/PYINT3/
10972C...Local arrays and data.
10973 DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2),
10974 &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25),
10975 &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),
10976 &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2),
10977 &THEFIS(2,2),ISFI(2),DPHI(2),MCESV(2)
10978 DATA IS/2*0/
10979
10980C...Read out basic information; set global Q^2 scale.
10981 IPUS1=IPU1
10982 IPUS2=IPU2
10983 ISUB=MINT(1)
10984 Q2MX=VINT(56)
10985 IF(ISET(ISUB).EQ.2) Q2MX=MIN(VINT(2),PARP(67)*VINT(56))
10986 FCQ2MX=1D0
10987
10988C...Define which processes ME corrections have been implemented for.
10989 MECOR=0
10990 IF(MSTP(68).EQ.1) THEN
10991 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ.142.OR.
10992 & ISUB.EQ.144) MECOR=1
10993 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
10994 ENDIF
10995
10996C...Initialize QCD evolution and check phase space.
10997 Q2MNC=PARP(62)**2
10998 Q2MNCS(1)=Q2MNC
10999 Q2MNCS(2)=Q2MNC
11000 IF(MINT(107).EQ.2.AND.MSTP(66).EQ.2) THEN
11001 Q0S=PARP(15)**2
11002 PS=VINT(3)**2
11003 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
11004 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
11005 Q2INT=SQRT(Q0S*Q2EFF)
11006 Q2MNCS(1)=MAX(Q2MNC,Q2INT)
11007 ELSEIF(MINT(107).EQ.3.AND.MSTP(66).GE.1) THEN
11008 Q2MNCS(1)=MAX(Q2MNC,VINT(283))
11009 ENDIF
11010 IF(MINT(108).EQ.2.AND.MSTP(66).EQ.2) THEN
11011 Q0S=PARP(15)**2
11012 PS=VINT(4)**2
11013 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
11014 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
11015 Q2INT=SQRT(Q0S*Q2EFF)
11016 Q2MNCS(2)=MAX(Q2MNC,Q2INT)
11017 ELSEIF(MINT(108).EQ.3.AND.MSTP(66).GE.1) THEN
11018 Q2MNCS(2)=MAX(Q2MNC,VINT(284))
11019 ENDIF
11020 MCEV=0
11021 ALAMS=PARU(112)
11022 PARU(112)=PARP(61)
11023 FQ2C=1D0
11024 TCMX=0D0
11025 IF(MINT(47).GE.2.AND.(MINT(47).LT.5.OR.MSTP(12).GE.1)) THEN
11026 MCEV=1
11027 IF(MSTP(64).EQ.1) FQ2C=PARP(63)
11028 IF(MSTP(64).EQ.2) FQ2C=PARP(64)
11029 TCMX=LOG(FQ2C*Q2MX/PARP(61)**2)
11030 IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0)
11031 & MCEV=0
11032 ENDIF
11033
11034C...Initialize QED evolution and check phase space.
11035 MEEV=0
11036 XEE=1D-10
11037 SPME=PMAS(11,1)**2
11038 IF(IABS(MINT(11)).EQ.13.OR.IABS(MINT(12)).EQ.13)
11039 &SPME=PMAS(13,1)**2
11040 IF(IABS(MINT(11)).EQ.15.OR.IABS(MINT(12)).EQ.15)
11041 &SPME=PMAS(15,1)**2
11042 Q2MNE=MAX(PARP(68)**2,2D0*SPME)
11043 TEMX=0D0
11044 FWTE=10D0
11045 IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN
11046 MEEV=1
11047 TEMX=LOG(Q2MX/SPME)
11048 IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0
11049 ENDIF
11050 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0) THEN
11051 MEEV=2
11052 TEMX=TCMX
11053 FWTE=1D0
11054 ENDIF
11055 IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN
11056
11057C...Loopback point in case of failure to reconstruct kinematics.
11058 NS=N
11059 LOOP=0
11060 100 LOOP=LOOP+1
11061 IF(LOOP.GT.100) THEN
11062 MINT(51)=1
11063 RETURN
11064 ENDIF
11065 N=NS
11066
11067C...Initial values: flavours, momenta, virtualities.
11068 DO 120 JT=1,2
11069 MORE(JT)=1
11070 KFBEAM(JT)=MINT(10+JT)
11071 IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22
11072 KFLS(JT)=MINT(14+JT)
11073 KFLS(JT+2)=KFLS(JT)
11074 XS(JT)=VINT(40+JT)
11075 IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT)
11076 ZS(JT)=1D0
11077 Q2S(JT)=FCQ2MX*Q2MX
11078 DQ2(JT)=0D0
11079 TEVCSV(JT)=TCMX
11080 ALAM(JT)=PARP(61)
11081 THE2(JT)=1D0
11082 TEVESV(JT)=TEMX
11083 MCESV(JT)=0
11084C...Calculate initial parton distribution weights.
11085 MINT(105)=MINT(102+JT)
11086 MINT(109)=MINT(106+JT)
11087 VINT(120)=VINT(2+JT)
11088C.... ALICE
11089C.... Store side in MINT(124)
c80e5422 11090 MINT(124) = JT
b6778262 11091 IF(XS(JT).LT.1D0-XEE) THEN
11092 IF(MSTP(57).LE.1) THEN
11093 CALL PYPDFU(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
11094 ELSE
11095 CALL PYPDFL(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
11096 ENDIF
11097 ENDIF
11098 DO 110 KFL=-25,25
11099 XFS(JT,KFL)=XFB(KFL)
11100 110 CONTINUE
11101C...Special kinematics check for c/b quarks (that g -> c cbar or
11102C...b bbar kinematically possible).
11103 KFLCB=IABS(KFLS(JT))
11104 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
11105 IF(XS(JT).GT.0.9D0*Q2S(JT)/(PMAS(KFLCB,1)**2+Q2S(JT))) THEN
11106 MINT(51)=1
11107 RETURN
11108 ENDIF
11109 ENDIF
11110 120 CONTINUE
11111 DSH=VINT(44)
11112 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2)
11113
11114C...Find if interference with final state partons.
11115 MFIS=0
11116 IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67)
11117 IF(MFIS.NE.0) THEN
11118 DO 140 I=1,2
11119 KCFI(I)=0
11120 KCA=PYCOMP(IABS(KFLS(I)))
11121 IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I))
11122 NFIS(I)=0
11123 IF(KCFI(I).NE.0) THEN
11124 IF(I.EQ.1) IPFS=IPUS1
11125 IF(I.EQ.2) IPFS=IPUS2
11126 DO 130 J=1,2
11127 ICSI=MOD(K(IPFS,3+J),MSTU(5))
11128 IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND.
11129 & (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN
11130 NFIS(I)=NFIS(I)+1
11131 THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+
11132 & P(ICSI,2)**2))
11133 IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I))
11134 ENDIF
11135 130 CONTINUE
11136 ENDIF
11137 140 CONTINUE
11138 IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0
11139 ENDIF
11140
11141C...Pick up leg with highest virtuality.
11142 JTOLD=1
11143 150 N=N+1
11144 JT=1
11145 IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
11146 IF(N.EQ.NS+2.AND.JT.EQ.JTOLD) JT=3-JT
11147 IF(MORE(JT).EQ.0) JT=3-JT
11148 JTOLD=JT
11149 KFLB=KFLS(JT)
11150 XB=XS(JT)
11151 DO 160 KFL=-25,25
11152 XFB(KFL)=XFS(JT,KFL)
11153 160 CONTINUE
11154 DSHR=2D0*SQRT(DSH)
11155 DSHZ=DSH/ZS(JT)
11156
11157C...Check if allowed to branch.
11158 MCEV=0
11159 IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN
11160 MCEV=1
11161 XEC=MAX(PARP(65)*DSHR/VINT(2),XB*(1D0/(1D0-PARP(66))-1D0))
11162 IF(XB.GE.1D0-2D0*XEC) MCEV=0
11163 ENDIF
11164 MEEV=0
11165 IF(MINT(44+JT).EQ.3) THEN
11166 MEEV=1
11167 IF(XB.GE.1D0-2D0*XEE) MEEV=0
11168 IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC)
11169 & MEEV=0
11170C***Currently kill QED shower for resolved photoproduction.
11171 IF(MINT(18+JT).EQ.1) MEEV=0
11172C***Currently kill shower for W inside electron.
11173 IF(IABS(KFLB).EQ.24) THEN
11174 MCEV=0
11175 MEEV=0
11176 ENDIF
11177 ENDIF
11178 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0.AND.IABS(KFLB).LE.10)
11179 &MEEV=2
11180 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
11181 Q2B=0D0
11182 GOTO 260
11183 ENDIF
11184
11185C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
11186 Q2B=Q2S(JT)
11187 TEVCB=TEVCSV(JT)
11188 TEVEB=TEVESV(JT)
11189 IF(MSTP(62).LE.1) THEN
11190 IF(ZS(JT).GT.0.99999D0) THEN
11191 Q2B=Q2S(JT)
11192 ELSE
11193 Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)*
11194 & (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+
11195 & 8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT))))
11196 ENDIF
11197 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
11198 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
11199 ENDIF
11200 IF(MCEV.EQ.1) THEN
11201 ALSDUM=PYALPS(FQ2C*Q2B)
11202 TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117))
11203 ALAM(JT)=PARU(117)
11204 B0=(33D0-2D0*MSTU(118))/6D0
11205 ENDIF
11206 IF(MEEV.EQ.2) TEVEB=TEVCB
11207 TEVCBS=TEVCB
11208 TEVEBS=TEVEB
11209
11210C...Select side for interference with final state partons.
11211 IF(MFIS.GE.1.AND.N.LE.NS+2) THEN
11212 IFI=N-NS
11213 ISFI(IFI)=0
11214 IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN
11215 ISFI(IFI)=1
11216 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN
11217 IF(PYR(0).GT.0.5D0) ISFI(IFI)=1
11218 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN
11219 ISFI(IFI)=1
11220 IF(PYR(0).GT.0.5D0) ISFI(IFI)=2
11221 ENDIF
11222 ENDIF
11223
11224C...Calculate preweighting factor for ME-corrected processes.
11225 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
11226
11227C...Calculate Altarelli-Parisi weights.
11228 DO 170 KFL=-25,25
11229 WTAPC(KFL)=0D0
11230 WTAPE(KFL)=0D0
11231 WTSF(KFL)=0D0
11232 170 CONTINUE
11233C...q -> q (g or gamma emission), g -> q.
11234 IF(IABS(KFLB).LE.10) THEN
11235 WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC)))
11236 WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC))
11237 EQ2=1D0/9D0
11238 IF(MOD(IABS(KFLB),2).EQ.0) EQ2=4D0*EQ2
11239 IF(MEEV.EQ.2) WTAPE(KFLB)=2.*EQ2*LOG((1D0-XEC-XB)*(XB+XEC)/
11240 & (XEC*(1D0-XEC)))
11241 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11242 WTAPC(KFLB)=WTFF*WTAPC(KFLB)
11243 WTAPC(21)=WTGF*WTAPC(21)
11244 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
11245 ENDIF
11246C...f -> f, gamma -> f.
11247 ELSEIF(IABS(KFLB).LE.20) THEN
11248 WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE)))
11249 WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))
11250 WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2)
11251 IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE)
11252 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11253 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
11254 WTAPE(22)=WTGF*WTAPE(22)
11255 ENDIF
11256C...f -> g, g -> g.
11257 ELSEIF(KFLB.EQ.21) THEN
11258 WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB))
11259 DO 180 KFL=1,MSTP(58)
11260 WTAPC(KFL)=WTAPQ
11261 WTAPC(-KFL)=WTAPQ
11262 180 CONTINUE
11263 WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC)
11264 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11265 DO 190 KFL=1,MSTP(58)
11266 WTAPC(KFL)=WTFG*WTAPC(KFL)
11267 WTAPC(-KFL)=WTFG*WTAPC(-KFL)
11268 190 CONTINUE
11269 WTAPC(21)=WTGG*WTAPC(21)
11270 ENDIF
11271C...f -> gamma, W+, W-.
11272 ELSEIF(KFLB.EQ.22) THEN
11273 WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB
11274 WTAPE(11)=WTAPF
11275 WTAPE(-11)=WTAPF
11276 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11277 WTAPE(11)=WTFG*WTAPE(11)
11278 WTAPE(-11)=WTFG*WTAPE(-11)
11279 ENDIF
11280 ELSEIF(KFLB.EQ.24) THEN
11281 WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
11282 & (XEE*(XB+XEE)))/XB
11283 ELSEIF(KFLB.EQ.-24) THEN
11284 WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
11285 & (XEE*(XB+XEE)))/XB
11286 ENDIF
11287
11288C...Calculate parton distribution weights and sum.
11289 NTRY=0
11290 200 NTRY=NTRY+1
11291 IF(NTRY.GT.500) THEN
11292 MINT(51)=1
11293 RETURN
11294 ENDIF
11295 WTSUMC=0D0
11296 WTSUME=0D0
11297 XFBO=MAX(1D-10,XFB(KFLB))
11298 DO 210 KFL=-25,25
11299 WTSF(KFL)=XFB(KFL)/XFBO
11300 WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL)
11301 WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL)
11302 210 CONTINUE
11303 WTSUMC=MAX(0.0001D0,WTSUMC)
11304 WTSUME=MAX(0.0001D0/FWTE,WTSUME)
11305
11306C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
11307 NTRY2=0
11308 220 NTRY2=NTRY2+1
11309 IF(NTRY2.GT.500) THEN
11310 MINT(51)=1
11311 RETURN
11312 ENDIF
11313 IF(MCEV.EQ.1) THEN
11314 IF(MSTP(64).LE.0) THEN
11315 TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC)
11316 ELSEIF(MSTP(64).EQ.1) THEN
11317 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC))
11318 ELSE
11319 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC)))
11320 ENDIF
11321 ENDIF
11322 IF(MEEV.EQ.1) THEN
11323 TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
11324 & (PARU(101)*FWTE*WTSUME*TEMX)))
11325 ELSEIF(MEEV.EQ.2) THEN
11326 TEVEB=TEVEB+LOG(PYR(0))*PARU(2)/(PARU(101)*WTSUME)
11327 ENDIF
11328
11329C...Translate t into Q2 scale; choose between QCD and QED evolution.
11330 230 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C
11331 IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
11332 IF(MEEV.EQ.2) Q2EB=ALAM(JT)**2*EXP(MAX(-50D0,TEVEB))/FQ2C
11333C...Ensure that Q2 is above threshold for charm/bottom.
11334 KFLCB=IABS(KFLB)
11335 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
11336 &MCEV.EQ.1) THEN
11337 IF(Q2CB.LT.PMAS(KFLCB,1)**2) THEN
11338 Q2CB=1.1D0*PMAS(KFLCB,1)**2
11339 TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
11340 FCQ2MX=MIN(2D0,1.05D0*FCQ2MX)
11341 ENDIF
11342 ENDIF
11343 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
11344 &MEEV.EQ.2) THEN
11345 IF(Q2EB.LT.PMAS(KFLCB,1)**2) MEEV=0
11346 ENDIF
11347 MCE=0
11348 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
11349 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN
11350 IF(Q2CB.GT.Q2MNCS(JT)) MCE=1
11351 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN
11352 IF(Q2EB.GT.Q2MNE) MCE=2
11353 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.2) THEN
11354 IF(Q2EB.GT.Q2MNCS(JT)) MCE=2
11355 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.2) THEN
11356 IF(Q2CB.GT.Q2EB.AND.Q2CB.GT.Q2MNCS(JT)) MCE=1
11357 IF(Q2EB.GT.Q2CB.AND.Q2EB.GT.Q2MNCS(JT)) MCE=2
11358 ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN
11359 MCE=1
11360 IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2
11361 IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0
11362 ELSE
11363 MCE=2
11364 IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1
11365 IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0
11366 ENDIF
11367
11368C...Evolution possibly ended. Update t values.
11369 IF(MCE.EQ.0) THEN
11370 Q2B=0D0
11371 GOTO 260
11372 ELSEIF(MCE.EQ.1) THEN
11373 Q2B=Q2CB
11374 Q2REF=FQ2C*Q2B
11375 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
11376 IF(MEEV.EQ.2) TEVEB=LOG(FQ2C*Q2B/ALAM(JT)**2)
11377 ELSE
11378 Q2B=Q2EB
11379 Q2REF=Q2B
11380 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
11381 ENDIF
11382
11383C...Select flavour for branching parton.
11384 IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC
11385 IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME
11386 KFLA=-25
11387 240 KFLA=KFLA+1
11388 IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA)
11389 IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA)
11390 IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 240
11391 IF(KFLA.EQ.25) THEN
11392 Q2B=0D0
11393 GOTO 260
11394 ENDIF
11395
11396C...Choose z value and corrective weight.
11397 WTZ=0D0
11398C...q -> q + g or q -> q + gamma.
11399 IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN
11400 Z=1D0-((1D0-XB-XEC)/(1D0-XEC))*
11401 & (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0)
11402 WTZ=0.5D0*(1D0+Z**2)
11403C...q -> g + q.
11404 ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN
11405 Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2
11406 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
11407C...f -> f + gamma.
11408 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
11409 IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN
11410 Z=1D0-((1D0-XB-XEE)/(1D0-XEE))*
11411 & (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0)
11412 ELSE
11413 Z=XB+XB*(XEE/(1D0-XEE))*
11414 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
11415 ENDIF
11416 WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB)
11417C...f -> gamma + f.
11418 ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) THEN
11419 Z=XB+XB*(XEE/(1D0-XEE))*
11420 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
11421 WTZ=0.5D0*(1D0+(1D0-Z)**2)*XB*(Z-XB)/Z
11422C...f -> W+- + f.
11423 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) THEN
11424 Z=XB+XB*(XEE/(1D0-XEE))*
11425 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
11426 WTZ=0.5D0*(1D0+(1D0-Z)**2)*(XB*(Z-XB)/Z)*
11427 & (Q2B/(Q2B+PMAS(24,1)**2))
11428C...g -> q + qbar.
11429 ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN
11430 Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC))
11431 WTZ=1D0-2D0*Z*(1D0-Z)
11432C...g -> g + g.
11433 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
11434 Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0))
11435 WTZ=(1D0-Z*(1D0-Z))**2
11436C...gamma -> f + fbar.
11437 ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN
11438 Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE))
11439 WTZ=1D0-2D0*Z*(1D0-Z)
11440 ENDIF
11441 IF(MCE.EQ.2.AND.MEEV.EQ.1) WTZ=(WTZ/FWTE)*(TEVEB/TEMX)
11442
11443C...Option with resummation of soft gluon emission as effective z shift.
11444 IF(MCE.EQ.1) THEN
11445 IF(MSTP(65).GE.1) THEN
11446 RSOFT=6D0
11447 IF(KFLB.NE.21) RSOFT=8D0/3D0
11448 Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0))
11449 IF(Z.LE.XB) GOTO 220
11450 ENDIF
11451
11452C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
11453 IF(MSTP(64).GE.2) THEN
11454 IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 220
11455 ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z))
11456 IF(ALPRAT.LT.5D0*PYR(0)) GOTO 220
11457 IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0
11458 ENDIF
11459 ENDIF
11460
11461C...Remove kinematically impossible branchings.
11462 UHAT=Q2B-DSH*(1D0-Z)/Z
11463 IF(MSTP(68).GE.0.AND.UHAT.GT.0D0) GOTO 220
11464
11465C...Select phi angle of branching at random.
11466 PHIBR=PARU(2)*PYR(0)
11467
11468C...Matrix-element corrections for some processes.
11469 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11470 IF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
11471 CALL PYMEWT(MECOR,1,Q2B,Z,PHIBR,WTME)
11472 WTZ=WTZ*WTME/WTFF
11473 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.IABS(KFLB).LE.20) THEN
11474 CALL PYMEWT(MECOR,2,Q2B,Z,PHIBR,WTME)
11475 WTZ=WTZ*WTME/WTGF
11476 ELSEIF(IABS(KFLA).LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
11477 CALL PYMEWT(MECOR,3,Q2B,Z,PHIBR,WTME)
11478 WTZ=WTZ*WTME/WTFG
11479 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
11480 CALL PYMEWT(MECOR,4,Q2B,Z,PHIBR,WTME)
11481 WTZ=WTZ*WTME/WTGG
11482 ENDIF
11483 ENDIF
11484
11485C...Impose angular constraint in first branching from interference
11486C...with final state partons.
11487 IF(MCE.EQ.1) THEN
11488 IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN
11489 THE2D=(4D0*Q2B)/(DSH*(1D0-Z))
11490 IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN
11491 IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 220
11492 ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN
11493 IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 220
11494 ENDIF
11495 ENDIF
11496
11497C...Option with angular ordering requirement.
11498 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN
11499 THE2T=(4D0*Z**2*Q2B)/(4D0*Z**2*Q2B+(1D0-Z)*XB**2*VINT(2))
11500 IF(THE2T.GT.THE2(JT)) GOTO 220
11501 ENDIF
11502 ENDIF
11503
11504C...Weighting with new parton distributions.
11505 MINT(105)=MINT(102+JT)
11506 MINT(109)=MINT(106+JT)
11507 VINT(120)=VINT(2+JT)
11508C.... ALICE
11509C.... Store side in MINT(124)
11510 MINT(124)=JT
11511
11512 IF(MSTP(57).LE.1) THEN
11513 CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN)
11514 ELSE
11515 CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN)
11516 ENDIF
11517 XFBN=XFN(KFLB)
11518 IF(XFBN.LT.1D-20) THEN
11519 IF(KFLA.EQ.KFLB) THEN
11520 TEVCB=TEVCBS
11521 TEVEB=TEVEBS
11522 WTAPC(KFLB)=0D0
11523 WTAPE(KFLB)=0D0
11524 GOTO 200
11525 ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN
11526 TEVCB=0.5D0*(TEVCBS+TEVCB)
11527 GOTO 230
11528 ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN
11529 TEVEB=0.5D0*(TEVEBS+TEVEB)
11530 GOTO 230
11531 ELSE
11532 XFBN=1D-10
11533 XFN(KFLB)=XFBN
11534 ENDIF
11535 ENDIF
11536 DO 250 KFL=-25,25
11537 XFB(KFL)=XFN(KFL)
11538 250 CONTINUE
11539 XA=XB/Z
11540C.... ALICE
11541C.... Store side in MINT(124)
11542 MINT(124) = JT
11543C....
11544
11545 IF(MSTP(57).LE.1) THEN
11546 CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA)
11547 ELSE
11548 CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA)
11549 ENDIF
11550 XFAN=XFA(KFLA)
11551 IF(XFAN.LT.1D-20) GOTO 200
11552 WTSFA=WTSF(KFLA)
11553 IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 200
11554
11555C...Define two hard scatterers in their CM-frame.
11556 260 IF(N.EQ.NS+2) THEN
11557 DQ2(JT)=Q2B
11558 DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
11559 DO 280 JR=1,2
11560 I=NS+JR
11561 IF(JR.EQ.1) IPO=IPUS1
11562 IF(JR.EQ.2) IPO=IPUS2
11563 DO 270 J=1,5
11564 K(I,J)=0
11565 P(I,J)=0D0
11566 V(I,J)=0D0
11567 270 CONTINUE
11568 K(I,1)=14
11569 K(I,2)=KFLS(JR+2)
11570 K(I,4)=IPO
11571 K(I,5)=IPO
11572 P(I,3)=DPLCM*(-1)**(JR+1)
11573 P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
11574 P(I,5)=-SQRT(DQ2(JR))
11575 K(IPO,1)=14
11576 K(IPO,3)=I
11577 K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
11578 K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
11579 280 CONTINUE
11580
11581C...Find maximum allowed mass of timelike parton.
11582 ELSEIF(N.GT.NS+2) THEN
11583 JR=3-JT
11584 DQ2(3)=Q2B
11585 DPC(1)=P(IS(1),4)
11586 DPC(2)=P(IS(2),4)
11587 DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
11588 DPD(1)=DSH+DQ2(JR)+DQ2(JT)
11589 DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
11590 DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
11591 DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
11592 IKIN=0
11593 IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE.
11594 & 1D-10*DPD(1)) IKIN=1
11595 IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))*
11596 & (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
11597 IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/
11598 & (2D0*DQ2(JR))-DQ2(JT)-DQ2(3)
11599
11600C...Generate timelike parton shower (if required).
11601 IT=N
11602 DO 290 J=1,5
11603 K(IT,J)=0
11604 P(IT,J)=0D0
11605 V(IT,J)=0D0
11606 290 CONTINUE
11607C...f -> f + g (gamma).
11608 IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN
11609 K(IT,2)=21
11610 IF(MCESV(JT).EQ.2.OR.IABS(KFLB).GE.11) K(IT,2)=22
11611C...f -> g (gamma, W+-) + f.
11612 ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN
11613 K(IT,2)=KFLB
11614 IF(KFLS(JT+2).EQ.24) THEN
11615 K(IT,2)=-12
11616 ELSEIF(KFLS(JT+2).EQ.-24) THEN
11617 K(IT,2)=12
11618 ENDIF
11619C...g (gamma) -> f + fbar, g + g.
11620 ELSE
11621 K(IT,2)=-KFLS(JT+2)
11622 IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2)
11623 ENDIF
11624 K(IT,1)=3
11625 IF((IABS(K(IT,2)).GE.11.AND.IABS(K(IT,2)).LE.18).OR.
11626 & IABS(K(IT,2)).EQ.22) K(IT,1)=1
11627 P(IT,5)=PYMASS(K(IT,2))
11628 IF(DMSMA.LE.P(IT,5)**2) GOTO 100
11629 IF(MSTP(63).GE.1.AND.MCESV(JT).EQ.1) THEN
11630 MSTJ48=MSTJ(48)
11631 PARJ85=PARJ(85)
11632 P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
11633 P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
11634 IF(MSTP(63).EQ.1) THEN
11635 Q2TIM=DMSMA
11636 ELSEIF(MSTP(63).EQ.2) THEN
11637 Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT))
11638 ELSE
11639 Q2TIM=DMSMA
11640 MSTJ(48)=1
11641 IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
11642 IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)*
11643 & DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2)
11644 PARJ(85)=SQRT(MAX(0D0,DPT2))*
11645 & (1D0/P(IT,4)+1D0/P(IS(JT),4))
11646 ENDIF
11647 CALL PYSHOW(IT,0,SQRT(Q2TIM))
11648 MSTJ(48)=MSTJ48
11649 PARJ(85)=PARJ85
11650 IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
11651 ENDIF
11652
11653C...Reconstruct kinematics of branching: timelike parton shower.
11654 DMS=P(IT,5)**2
11655 IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
11656 IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+
11657 & 0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/
11658 & (4D0*DSH*DPC(3)**2)
11659 IF(DPT2.LT.0D0) GOTO 100
11660 DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
11661 & DSHR)/DPC(3)-DPC(3)
11662 P(IT,1)=SQRT(DPT2)
11663 P(IT,3)=DPB(1)*(-1)**(JT+1)
11664 P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS)
11665 IF(N.GE.IT+1) THEN
11666 DPB(1)=SQRT(DPB(1)**2+DPT2)
11667 DPB(2)=SQRT(DPB(1)**2+DMS)
11668 DPB(3)=P(IT+1,3)
11669 DPB(4)=SQRT(DPB(3)**2+DMS)
11670 DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
11671 & DPB(1))
11672 CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ)
11673 THE=PYANGL(P(IT,3),P(IT,1))
11674 CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0)
11675 ENDIF
11676
11677C...Reconstruct kinematics of branching: spacelike parton.
11678 DO 300 J=1,5
11679 K(N+1,J)=0
11680 P(N+1,J)=0D0
11681 V(N+1,J)=0D0
11682 300 CONTINUE
11683 K(N+1,1)=14
11684 K(N+1,2)=KFLB
11685 P(N+1,1)=P(IT,1)
11686 P(N+1,3)=P(IT,3)+P(IS(JT),3)
11687 P(N+1,4)=P(IT,4)+P(IS(JT),4)
11688 P(N+1,5)=-SQRT(DQ2(3))
11689
11690C...Define colour flow of branching.
11691 K(IS(JT),3)=N+1
11692 K(IT,3)=N+1
11693 IM1=N+1
11694 IM2=N+1
11695C...f -> f + gamma (Z, W).
11696 IF(IABS(K(IT,2)).GE.22) THEN
11697 K(IT,1)=1
11698 ID1=IS(JT)
11699 ID2=IS(JT)
11700C...f -> gamma (Z, W) + f.
11701 ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN
11702 ID1=IT
11703 ID2=IT
11704C...gamma -> q + qbar, g + g.
11705 ELSEIF(K(N+1,2).EQ.22) THEN
11706 ID1=IS(JT)
11707 ID2=IT
11708 IM1=ID2
11709 IM2=ID1
11710C...q -> q + g.
11711 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN
11712 ID1=IT
11713 ID2=IS(JT)
11714C...q -> g + q.
11715 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN
11716 ID1=IS(JT)
11717 ID2=IT
11718C...qbar -> qbar + g.
11719 ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN
11720 ID1=IS(JT)
11721 ID2=IT
11722C...qbar -> g + qbar.
11723 ELSEIF(K(N+1,2).LT.0) THEN
11724 ID1=IT
11725 ID2=IS(JT)
11726C...g -> g + g; g -> q + qbar.
11727 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
11728 ID1=IS(JT)
11729 ID2=IT
11730 ELSE
11731 ID1=IT
11732 ID2=IS(JT)
11733 ENDIF
11734 IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1
11735 IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2
11736 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
11737 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
11738 IF(ID1.NE.ID2) THEN
11739 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
11740 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
11741 ENDIF
11742 N=N+1
11743
11744C...Boost to new CM-frame.
11745 DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4))
11746 DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4))
11747 IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100
11748 CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ)
11749 IR=N+(JT-1)*(IS(1)-N)
11750 CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),DPHI(JT),
11751 & 0D0,0D0,0D0)
11752 ENDIF
11753
11754C...Update kinematics variables.
11755 IS(JT)=N
11756 DQ2(JT)=Q2B
11757 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THE2(JT)=THE2T
11758 DSH=DSHZ
11759
11760C...Save quantities; loop back.
11761 Q2S(JT)=Q2B
11762 DPHI(JT)=PHIBR
11763 MCESV(JT)=MCE
11764 IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR.
11765 &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN
11766 KFLS(JT+2)=KFLS(JT)
11767 KFLS(JT)=KFLA
11768 XS(JT)=XA
11769 ZS(JT)=Z
11770 DO 310 KFL=-25,25
11771 XFS(JT,KFL)=XFA(KFL)
11772 310 CONTINUE
11773 TEVCSV(JT)=TEVCB
11774 TEVESV(JT)=TEVEB
11775 ELSE
11776 MORE(JT)=0
11777 IF(JT.EQ.1) IPU1=N
11778 IF(JT.EQ.2) IPU2=N
11779 ENDIF
11780 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
11781 CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS')
11782 IF(MSTU(21).GE.1) N=NS
11783 IF(MSTU(21).GE.1) RETURN
11784 ENDIF
11785 IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150
11786
11787C...Boost hard scattering partons to frame of shower initiators.
11788 DO 320 J=1,3
11789 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
11790 320 CONTINUE
11791 K(N+2,1)=1
11792 DO 330 J=1,5
11793 P(N+2,J)=P(NS+1,J)
11794 330 CONTINUE
11795 CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5))
11796 ROBO(2)=PYANGL(P(N+2,1),P(N+2,2))
11797 ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
11798 CALL PYROBO(MINT(83)+5,NS,0D0,-ROBO(2),0D0,0D0,0D0)
11799 CALL PYROBO(MINT(83)+5,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),
11800 &ROBO(5))
11801
11802C...Store user information. Reset Lambda value.
11803 K(IPU1,3)=MINT(83)+3
11804 K(IPU2,3)=MINT(83)+4
11805 DO 340 JT=1,2
11806 MINT(12+JT)=KFLS(JT)
11807 VINT(140+JT)=XS(JT)
11808 IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT)
11809 340 CONTINUE
11810 PARU(112)=ALAMS
11811
11812 RETURN
11813 END
11814
11815C*********************************************************************
11816
11817C...PYMEMX
11818C...Generates maximum ME weight in some initial-state showers.
11819C...Inparameter MECOR: kind of hard scattering process
11820C...Outparameter WTFF: maximum weight for fermion -> fermion
11821C... WTGF: maximum weight for gluon/photon -> fermion
11822C... WTFG: maximum weight for fermion -> gluon/photon
11823C... WTGG: maximum weight for gluon -> gluon
11824
11825 SUBROUTINE PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
11826
11827C...Double precision and integer declarations.
11828 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
11829 IMPLICIT INTEGER(I-N)
11830 INTEGER PYK,PYCHGE,PYCOMP
11831C...Commonblocks.
11832 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
11833 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11834 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
11835 COMMON/PYINT1/MINT(400),VINT(400)
11836 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
11837 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
11838
11839C...Default maximum weight.
11840 WTFF=1D0
11841 WTGF=1D0
11842 WTFG=1D0
11843 WTGG=1D0
11844
11845C...Select maximum weight by process.
11846 IF(MECOR.EQ.1) THEN
11847 WTFF=1D0
11848 WTGF=3D0
11849 ELSEIF(MECOR.EQ.2) THEN
11850 WTFG=1D0
11851 WTGG=1D0
11852 ENDIF
11853
11854 RETURN
11855 END
11856
11857C*********************************************************************
11858
11859C...PYMEWT
11860C...Calculates actual ME weight in some initial-state showers.
11861C...Inparameter MECOR: kind of hard scattering process
11862C... IFLCB: flavour combination of branching,
11863C... 1 for fermion -> fermion,
11864C... 2 for gluon/photon -> fermion
11865C... 3 for fermion -> gluon/photon,
11866C... 4 for gluon -> gluon
11867C... Q2: Q2 value of shower branching
11868C... Z: Z value of branching
11869C...In+outparameter PHIBR: azimuthal angle of branching
11870C...Outparameter WTME: actual ME weight
11871
11872 SUBROUTINE PYMEWT(MECOR,IFLCB,Q2,Z,PHIBR,WTME)
11873
11874C...Double precision and integer declarations.
11875 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
11876 IMPLICIT INTEGER(I-N)
11877 INTEGER PYK,PYCHGE,PYCOMP
11878C...Commonblocks.
11879 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
11880 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11881 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
11882 COMMON/PYINT1/MINT(400),VINT(400)
11883 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
11884 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
11885
11886C...Default output.
11887 WTME=1D0
11888
11889C...Define kinematics of shower branching in Mandelstam variables.
11890 SQM=VINT(44)
11891 SH=SQM/Z
11892 TH=-Q2
11893 UH=Q2-SQM*(1D0-Z)/Z
11894
11895C...Matrix-element corrections for f + fbar -> s-channel vector boson.
11896 IF(MECOR.EQ.1) THEN
11897 IF(IFLCB.EQ.1) THEN
11898 WTME=(TH**2+UH**2+2D0*SQM*SH)/(SH**2+SQM**2)
11899 ELSEIF(IFLCB.EQ.2) THEN
11900 WTME=(SH**2+UH**2+2D0*SQM*TH)/((SH-SQM)**2+SQM**2)
11901 ENDIF
11902
11903C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0).
11904 ELSEIF(MECOR.EQ.2) THEN
11905 IF(IFLCB.EQ.3) THEN
11906 WTME=(SH**2+UH**2)/(SH**2+(SH-SQM)**2)
11907 ELSEIF(IFLCB.EQ.4) THEN
11908 WTME=0.5D0*(SH**4+UH**4+TH**4+SQM**4)/(SH**2-SQM*(SH-SQM))**2
11909 ENDIF
11910 ENDIF
11911
11912 RETURN
11913 END
11914
11915C*********************************************************************
11916
11917C...PYADSH
11918C...Administers the generation of successive final-state showers
11919C...in external processes.
11920
11921 SUBROUTINE PYADSH(NFIN)
11922
11923C...Double precision and integer declarations.
11924 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
11925 IMPLICIT INTEGER(I-N)
11926 INTEGER PYK,PYCHGE,PYCOMP
11927C...Commonblocks.
11928 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
11929 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11930 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
11931 COMMON/PYINT1/MINT(400),VINT(400)
11932 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
11933C...Local array.
11934 DIMENSION IBEG(100),KSAV(10,5),IORD(10),PSUM(4),BETA(3)
11935
11936C...Set primary vertex.
11937 DO 100 J=1,5
11938 V(MINT(83)+5,J)=0D0
11939 V(MINT(83)+6,J)=0D0
11940 V(MINT(84)+1,J)=0D0
11941 V(MINT(84)+2,J)=0D0
11942 100 CONTINUE
11943
11944C...Isolate systems of particles with the same mother.
11945 NSYS=0
11946 IMS=-1
11947 DO 140 I=MINT(84)+3,NFIN
11948 IM=K(I,3)
11949 IF(IM.GT.0.AND.IM.LE.MINT(84)) IM=K(IM,3)
11950 IF(IM.NE.IMS) THEN
11951 NSYS=NSYS+1
11952 IBEG(NSYS)=I
11953 IMS=IM
11954 ENDIF
11955
11956C...Set production vertices.
11957 IF(IM.LE.MINT(83)+6.OR.(IM.GT.MINT(84).AND.IM.LE.MINT(84)+2))
11958 & THEN
11959 DO 110 J=1,4
11960 V(I,J)=0D0
11961 110 CONTINUE
11962 ELSE
11963 DO 120 J=1,4
11964 V(I,J)=V(IM,J)+V(IM,5)*P(IM,J)/P(IM,5)
11965 120 CONTINUE
11966 ENDIF
11967 IF(MSTP(125).GE.1) THEN
11968 IDOC=I-MSTP(126)+4
11969 DO 130 J=1,5
11970 V(IDOC,J)=V(I,J)
11971 130 CONTINUE
11972 ENDIF
11973 140 CONTINUE
11974
11975C...End loop over systems. Return if no showers to be performed.
11976 IBEG(NSYS+1)=NFIN+1
11977 IF(MSTP(71).LE.0) RETURN
11978
11979C...Loop through systems of particles; check that sensible size.
11980 DO 260 ISYS=1,NSYS
11981 NSIZ=IBEG(ISYS+1)-IBEG(ISYS)
11982 IF(NSIZ.EQ.1.AND.ISYS.EQ.1) THEN
11983 ELSEIF(NSIZ.LE.1) THEN
11984 CALL PYERRM(2,'(PYADSH:) only one particle in system')
11985 ELSEIF(NSIZ.GT.7) THEN
11986 CALL PYERRM(2,'(PYADSH:) more than seven particles in system')
11987 ELSE
11988
11989C...Save status codes and daughters of showering pair; reset them.
11990 DO 150 J=1,4
11991 PSUM(J)=0D0
11992 150 CONTINUE
11993 DO 170 II=1,NSIZ
11994 I=IBEG(ISYS)-1+II
11995 KSAV(II,1)=K(I,1)
11996 IF(K(I,1).GT.10) THEN
11997 K(I,1)=1
11998 IF(KSAV(II,1).EQ.14) K(I,1)=3
11999 ENDIF
12000 IF(KSAV(II,1).LE.10) THEN
12001 ELSEIF(K(I,1).EQ.1) THEN
12002 KSAV(II,4)=K(I,4)
12003 KSAV(II,5)=K(I,5)
12004 K(I,4)=0
12005 K(I,5)=0
12006 ELSE
12007 KSAV(II,4)=MOD(K(I,4),MSTU(5))
12008 KSAV(II,5)=MOD(K(I,5),MSTU(5))
12009 K(I,4)=K(I,4)-KSAV(II,4)
12010 K(I,5)=K(I,5)-KSAV(II,5)
12011 ENDIF
12012 DO 160 J=1,4
12013 PSUM(J)=PSUM(J)+P(I,J)
12014 160 CONTINUE
12015 170 CONTINUE
12016
12017C...Perform shower.
12018 QMAX=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
12019 & PSUM(3)**2))
12020 IF(ISYS.EQ.1) QMAX=VINT(55)
12021 NSAV=N
12022 IF(NSIZ.EQ.2) THEN
12023 CALL PYSHOW(IBEG(ISYS),IBEG(ISYS)+1,QMAX)
12024 ELSE
12025 CALL PYSHOW(IBEG(ISYS),-NSIZ,QMAX)
12026 ENDIF
12027
12028C...Look up showered copies of original showering particles.
12029 DO 250 II=1,NSIZ
12030 I=IBEG(ISYS)-1+II
12031 IMV=I
12032 IF(N.EQ.NSAV.OR.K(I,1).LE.10) THEN
12033 ELSEIF(K(I,1).EQ.11) THEN
12034 180 IMV=MOD(K(IMV,4),MSTU(5))
12035 IF(K(IMV,1).EQ.11) GOTO 180
12036 ELSE
12037 KDA1=MOD(K(I,4),MSTU(5))
12038 KDA2=MOD(K(I,5),MSTU(5))
12039 DO 190 I3=I+1,N
12040 IF(K(I3,2).EQ.K(I,2).AND.(I3.EQ.KDA1.OR.I3.EQ.KDA2))
12041 & THEN
12042 IMV=I3
12043 KDA1=MOD(K(I3,4),MSTU(5))
12044 KDA2=MOD(K(I3,5),MSTU(5))
12045 ENDIF
12046 190 CONTINUE
12047 ENDIF
12048
12049C...Restore daughter info of original partons to showered copies.
12050 IF(KSAV(II,1).GT.10) K(IMV,1)=KSAV(II,1)
12051 IF(KSAV(II,1).LE.10) THEN
12052 ELSEIF(K(I,1).EQ.1) THEN
12053 K(IMV,4)=KSAV(II,4)
12054 K(IMV,5)=KSAV(II,5)
12055 ELSE
12056 K(IMV,4)=K(IMV,4)+KSAV(II,4)
12057 K(IMV,5)=K(IMV,5)+KSAV(II,5)
12058 ENDIF
12059
12060C...Reset mother info of existing daughters to showered copies.
12061 DO 200 I3=IBEG(ISYS+1),NFIN
12062 IF(K(I3,3).EQ.I) K(I3,3)=IMV
12063 IF(K(I3,1).EQ.3.OR.K(I3,1).EQ.14) THEN
12064 IF(K(I3,4)/MSTU(5).EQ.I) K(I3,4)=K(I3,4)+MSTU(5)*(IMV-I)
12065 IF(K(I3,5)/MSTU(5).EQ.I) K(I3,5)=K(I3,5)+MSTU(5)*(IMV-I)
12066 ENDIF
12067 200 CONTINUE
12068
12069C...Boost all original daughters to new frame of showered copy.
12070 IF(IMV.NE.I) THEN
12071 DO 210 J=1,3
12072 BETA(J)=(P(IMV,J)-P(I,J))/(P(IMV,4)+P(I,4))
12073 210 CONTINUE
12074 FAC=2D0/(1D0+BETA(1)**2+BETA(2)**2+BETA(3)**2)
12075 DO 220 J=1,3
12076 BETA(J)=FAC*BETA(J)
12077 220 CONTINUE
12078 DO 240 I3=IBEG(ISYS+1),NFIN
12079 IMO=I3
12080 230 IMO=K(IMO,3)
12081 IF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) GOTO 230
12082 IF(IMO.EQ.I.OR.(K(I,3).LE.MINT(84).AND.IMO.EQ.K(I,3)))
12083 & CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
12084 240 CONTINUE
12085 ENDIF
12086 250 CONTINUE
12087
12088C...End of loop over showering systems
12089 ENDIF
12090 260 CONTINUE
12091
12092 RETURN
12093 END
12094
12095C*********************************************************************
12096
12097C...PYRESD
12098C...Allows resonances to decay (including parton showers for hadronic
12099C...channels).
12100
12101 SUBROUTINE PYRESD(IRES)
12102
12103C...Double precision and integer declarations.
12104 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12105 IMPLICIT INTEGER(I-N)
12106 INTEGER PYK,PYCHGE,PYCOMP
12107C...Parameter statement to help give large particle numbers.
12108 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
12109 &KEXCIT=4000000,KDIMEN=5000000)
12110C...Commonblocks.
12111 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12112 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12113 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
12114 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
12115 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
12116 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12117 COMMON/PYINT1/MINT(400),VINT(400)
12118 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
12119 COMMON/PYINT4/MWID(500),WIDS(500,5)
12120 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
12121 &/PYINT1/,/PYINT2/,/PYINT4/
12122C...Local arrays and complex and character variables.
12123 DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
12124 &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(3),ILIN(6),
12125 &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3),
12126 &PHI(3),WDTP(0:300),WDTE(0:300,0:5),DPMO(5),XM(5),VDCY(4)
12127 COMPLEX FGK,HA(6,6),HC(6,6)
12128 REAL TIR,UIR
12129 CHARACTER CODE*9,MASS*9
12130
12131C...The F, Xi and Xj functions of Gunion and Kunszt
12132C...(Phys. Rev. D33, 665, plus errata from the authors).
12133 FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
12134 &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
12135 DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/
12136 &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34))
12137 DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU-
12138 &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+
12139 &2D0*(D34/D56+D56/D34))
12140
12141C...Some general constants.
12142 XW=PARU(102)
12143 XWV=XW
12144 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
12145 XW1=1D0-XW
12146 SQMZ=PMAS(23,1)**2
12147 GMMZ=PMAS(23,1)*PMAS(23,2)
12148 SQMW=PMAS(24,1)**2
12149 GMMW=PMAS(24,1)*PMAS(24,2)
12150 SH=VINT(44)
12151
12152C...Boost and rotate to rest frame of incoming partons,
12153C...to get proper amount of smearing of decay angles.
12154 IBST=0
12155 IF(IRES.EQ.0) THEN
12156 IBST=1
12157 ETOTIN=P(MINT(84)+1,4)+P(MINT(84)+2,4)
12158 BEXIN=(P(MINT(84)+1,1)+P(MINT(84)+2,1))/ETOTIN
12159 BEYIN=(P(MINT(84)+1,2)+P(MINT(84)+2,2))/ETOTIN
12160 BEZIN=(P(MINT(84)+1,3)+P(MINT(84)+2,3))/ETOTIN
12161 CALL PYROBO(MINT(83)+7,N,0D0,0D0,-BEXIN,-BEYIN,-BEZIN)
12162 PHIIN=PYANGL(P(MINT(84)+1,1),P(MINT(84)+1,2))
12163 CALL PYROBO(MINT(83)+7,N,0D0,-PHIIN,0D0,0D0,0D0)
12164 THEIN=PYANGL(P(MINT(84)+1,3),P(MINT(84)+1,1))
12165 CALL PYROBO(MINT(83)+7,N,-THEIN,0D0,0D0,0D0,0D0)
12166 ENDIF
12167
12168C...Reset original resonance configuration.
12169 DO 100 JT=1,8
12170 IREF(1,JT)=0
12171 100 CONTINUE
12172
12173C...Define initial one, two or three objects for subprocess.
12174 IHDEC=0
12175 IF(IRES.EQ.0) THEN
12176 ISUB=MINT(1)
12177 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
12178 IREF(1,1)=MINT(84)+2+ISET(ISUB)
12179 IREF(1,4)=MINT(83)+6+ISET(ISUB)
12180 JTMAX=1
12181 ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
12182 IREF(1,1)=MINT(84)+1+ISET(ISUB)
12183 IREF(1,2)=MINT(84)+2+ISET(ISUB)
12184 IREF(1,4)=MINT(83)+5+ISET(ISUB)
12185 IREF(1,5)=MINT(83)+6+ISET(ISUB)
12186 JTMAX=2
12187 ELSEIF(ISET(ISUB).EQ.5) THEN
12188 IREF(1,1)=MINT(84)+3
12189 IREF(1,2)=MINT(84)+4
12190 IREF(1,3)=MINT(84)+5
12191 IREF(1,4)=MINT(83)+7
12192 IREF(1,5)=MINT(83)+8
12193 IREF(1,6)=MINT(83)+9
12194 JTMAX=3
12195 ENDIF
12196
12197C...Define original resonance for odd cases.
12198 ELSE
12199 ISUB=0
12200 IF(K(IRES,2).EQ.25.OR.K(IRES,2).EQ.35.OR.K(IRES,2).EQ.36)
12201 & IHDEC=1
12202 IF(IHDEC.EQ.1) ISUB=3
12203 IREF(1,1)=IRES
12204 IREF(1,4)=K(IRES,3)
12205 JTMAX=1
12206 ENDIF
12207
12208C...Check if initial resonance has been moved (in resonance + jet).
12209 DO 120 JT=1,3
12210 IF(IREF(1,JT).GT.0) THEN
12211 IF(K(IREF(1,JT),1).GT.10) THEN
12212 KFA=IABS(K(IREF(1,JT),2))
12213 IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN
12214 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
12215 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
12216 DO 110 I=IREF(1,JT)+1,N
12217 IF(K(I,2).EQ.K(IREF(1,JT),2).AND.(I.EQ.KDA1.OR.
12218 & I.EQ.KDA2)) THEN
12219 IREF(1,JT)=I
12220 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
12221 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
12222 ENDIF
12223 110 CONTINUE
12224 ELSE
12225 KDA=MOD(K(IREF(1,JT),4),MSTU(5))
12226 IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA
12227 ENDIF
12228 ENDIF
12229 ENDIF
12230 120 CONTINUE
12231
12232C.....Set decay vertex for initial resonances
12233 DO 140 JT=1,JTMAX
12234 DO 130 I=1,4
12235 V(IREF(1,JT),I)=0D0
12236 130 CONTINUE
12237 140 CONTINUE
12238
12239C...Loop over decay history.
12240 NP=1
12241 IP=0
12242 150 IP=IP+1
12243 NINH=0
12244 JTMAX=2
12245 IF(IREF(IP,2).EQ.0) JTMAX=1
12246 IF(IREF(IP,3).NE.0) JTMAX=3
12247 IT4=0
12248 NSAV=N
12249
12250C...Start treatment of one, two or three resonances in parallel.
12251 160 N=NSAV
12252 DO 250 JT=1,JTMAX
12253 ID=IREF(IP,JT)
12254 KDCY(JT)=0
12255 KFL1(JT)=0
12256 KFL2(JT)=0
12257 KFL3(JT)=0
12258 KEQL(JT)=0
12259 NSD(JT)=ID
12260
12261C...Check whether particle can/is allowed to decay.
12262 IF(ID.EQ.0) GOTO 240
12263 KFA=IABS(K(ID,2))
12264 KCA=PYCOMP(KFA)
12265 IF(MWID(KCA).EQ.0) GOTO 240
12266 IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 240
12267 IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR.
12268 & KFA.EQ.18) IT4=IT4+1
12269 K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5))
12270 K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5))
12271
12272C...Choose lifetime and determine decay vertex.
12273 IF(K(ID,1).EQ.5) THEN
12274 V(ID,5)=0D0
12275 ELSEIF(K(ID,1).NE.4) THEN
12276 V(ID,5)=-PMAS(KCA,4)*LOG(PYR(0))
12277 ENDIF
12278 DO 170 J=1,4
12279 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
12280 170 CONTINUE
12281
12282C...Determine whether decay allowed or not.
12283 MOUT=0
12284 IF(MSTJ(22).EQ.2) THEN
12285 IF(PMAS(KCA,4).GT.PARJ(71)) MOUT=1
12286 ELSEIF(MSTJ(22).EQ.3) THEN
12287 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
12288 ELSEIF(MSTJ(22).EQ.4) THEN
12289 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
12290 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
12291 ENDIF
12292 IF(MOUT.EQ.1.AND.K(ID,1).NE.5) THEN
12293 K(ID,1)=4
12294 GOTO 240
12295 ENDIF
12296
12297C...Info for selection of decay channel: sign, pairings.
12298 IF(KCHG(KCA,3).EQ.0) THEN
12299 IPM=2
12300 ELSE
12301 IPM=(5-ISIGN(1,K(ID,2)))/2
12302 ENDIF
12303 KFB=0
12304 IF(JTMAX.EQ.2) THEN
12305 KFB=IABS(K(IREF(IP,3-JT),2))
12306 ELSEIF(JTMAX.EQ.3) THEN
12307 JT2=JT+1-3*(JT/3)
12308 KFB=IABS(K(IREF(IP,JT2),2))
12309 IF(KFB.NE.KFA) THEN
12310 JT2=JT+2-3*((JT+1)/3)
12311 KFB=IABS(K(IREF(IP,JT2),2))
12312 ENDIF
12313 ENDIF
12314
12315C...Select decay channel.
12316 IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.
12317 & ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1
12318 CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE)
12319 WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4)
12320 IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5)
12321 IF(WDTE0S.LE.0D0) GOTO 240
12322 RKFL=WDTE0S*PYR(0)
12323 IDL=0
12324 180 IDL=IDL+1
12325 IDC=IDL+MDCY(KCA,2)-1
12326 RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4))
12327 IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5)
12328 IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 180
12329
12330C...Read out flavours and colour charges of decay channel chosen.
12331 KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2))
12332 IF(KCQM(JT).EQ.-2) KCQM(JT)=2
12333 KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
12334 KFC1A=PYCOMP(IABS(KFL1(JT)))
12335 IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT))
12336 KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT))
12337 IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2
12338 KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
12339 KFC2A=PYCOMP(IABS(KFL2(JT)))
12340 IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT))
12341 KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT))
12342 IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2
12343 KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2))
12344 IF(KFL3(JT).NE.0) THEN
12345 KFC3A=PYCOMP(IABS(KFL3(JT)))
12346 IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT))
12347 KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT))
12348 IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2
12349 ENDIF
12350
12351C...Set/save further info on channel.
12352 KDCY(JT)=1
12353 IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1)
12354 NSD(JT)=N
12355 HGZ(JT,1)=VINT(111)
12356 HGZ(JT,2)=VINT(112)
12357 HGZ(JT,3)=VINT(114)
12358 JTZ=JT
12359
12360C...Select masses; to begin with assume resonances narrow.
12361 DO 200 I=1,3
12362 P(N+I,5)=0D0
12363 PMMN(I)=0D0
12364 IF(I.EQ.1) THEN
12365 KFLW=IABS(KFL1(JT))
12366 KCW=KFC1A
12367 ELSEIF(I.EQ.2) THEN
12368 KFLW=IABS(KFL2(JT))
12369 KCW=KFC2A
12370 ELSEIF(I.EQ.3) THEN
12371 IF(KFL3(JT).EQ.0) GOTO 200
12372 KFLW=IABS(KFL3(JT))
12373 KCW=KFC3A
12374 ENDIF
12375 P(N+I,5)=PMAS(KCW,1)
12376CMRENNA++
12377C...This prevents SUSY/t particles from becoming too light.
12378 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
12379 PMMN(I)=PMAS(KCW,1)
12380 DO 190 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
12381 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
12382 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
12383 & PMAS(PYCOMP(KFDP(IDC,2)),1)
12384 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
12385 & PMAS(PYCOMP(KFDP(IDC,3)),1)
12386 PMMN(I)=MIN(PMMN(I),PMSUM)
12387 ENDIF
12388 190 CONTINUE
12389CMRENNA--
12390 ELSEIF(KFLW.EQ.6) THEN
12391 PMMN(I)=PMAS(24,1)+PMAS(5,1)
12392 ENDIF
12393 200 CONTINUE
12394
12395C...Check which two out of three are widest.
12396 IWID1=1
12397 IWID2=2
12398 PWID1=PMAS(KFC1A,2)
12399 PWID2=PMAS(KFC2A,2)
12400 KFLW1=IABS(KFL1(JT))
12401 KFLW2=IABS(KFL2(JT))
12402 IF(KFL3(JT).NE.0) THEN
12403 PWID3=PMAS(KFC3A,2)
12404 IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN
12405 IWID1=3
12406 PWID1=PWID3
12407 KFLW1=IABS(KFL3(JT))
12408 ELSEIF(PWID3.GT.PWID2) THEN
12409 IWID2=3
12410 PWID2=PWID3
12411 KFLW2=IABS(KFL3(JT))
12412 ENDIF
12413 ENDIF
12414
12415C...If all narrow then only check that masses consistent.
12416 IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND.
12417 & PWID2.LT.PARP(41))) THEN
12418CMRENNA++
12419C....Handle near degeneracy cases.
12420 IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN
12421 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
12422 P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0
12423 IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0
12424 ENDIF
12425 ENDIF
12426CMRENNA--
12427 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
12428 CALL PYERRM(13,'(PYRESD:) daughter masses too large')
12429 MINT(51)=1
12430 GOTO 630
12431 ELSEIF(P(N+1,5)+P(N+2,5)+P(N+3,5)+PARJ(64).GT.P(ID,5)) THEN
12432 CALL PYERRM(3,'(PYRESD:) daughter masses too large')
12433 MINT(51)=1
12434 GOTO 630
12435 ENDIF
12436
12437C...For three wide resonances select narrower of three
12438C...according to BW decoupled from rest.
12439 ELSE
12440 PMTOT=P(ID,5)
12441 IF(KFL3(JT).NE.0) THEN
12442 IWID3=6-IWID1-IWID2
12443 KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))-
12444 & KFLW1-KFLW2
12445 LOOP=0
12446 210 LOOP=LOOP+1
12447 P(N+IWID3,5)=PYMASS(KFLW3)
12448 IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 210
12449 PMTOT=PMTOT-P(N+IWID3,5)
12450 ENDIF
12451C...Select other two correlated within remaining phase space.
12452 IF(IP.EQ.1) THEN
12453 CKIN45=CKIN(45)
12454 CKIN47=CKIN(47)
12455 CKIN(45)=MAX(PMMN(IWID1),CKIN(45))
12456 CKIN(47)=MAX(PMMN(IWID2),CKIN(47))
12457 CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
12458 & P(N+IWID2,5))
12459 CKIN(45)=CKIN45
12460 CKIN(47)=CKIN47
12461 ELSE
12462 CKIN(49)=PMMN(IWID1)
12463 CKIN(50)=PMMN(IWID2)
12464 CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
12465 & P(N+IWID2,5))
12466 CKIN(49)=0D0
12467 CKIN(50)=0D0
12468 ENDIF
12469 IF(MINT(51).EQ.1) GOTO 630
12470 ENDIF
12471
12472C...Begin fill decay products, with colour flow for coloured objects.
12473 MSTU10=MSTU(10)
12474 MSTU(10)=1
12475 MSTU(19)=1
12476
12477CMRENNA++
12478C...1) Three-body decays of SUSY particles (plus special case top).
12479 IF(KFL3(JT).NE.0) THEN
12480 DO 230 I=N+1,N+3
12481 DO 220 J=1,5
12482 K(I,J)=0
12483C V(I,J)=0D0
12484 220 CONTINUE
12485 230 CONTINUE
12486 K(N+1,1)=1
12487 K(N+1,2)=KFL1(JT)
12488 K(N+2,1)=1
12489 K(N+2,2)=KFL2(JT)
12490 K(N+3,1)=1
12491 K(N+3,2)=KFL3(JT)
12492
12493 IDIN=ID
12494 CALL PYTBDY(IDIN)
12495
12496C...Set colour flow for t -> W + b + Z.
12497 IF(KFA.EQ.6) THEN
12498 K(N+2,1)=3
12499 ISID=4
12500 IF(KCQM(JT).EQ.-1) ISID=5
12501 IDAU=N+2
12502 K(ID,ISID)=K(ID,ISID)+IDAU
12503 K(IDAU,ISID)=MSTU(5)*ID
12504
12505C...Set colour flow in three-body decays - programmed as special cases.
12506 ELSEIF(KFC2A.LE.6) THEN
12507 K(N+2,1)=3
12508 K(N+3,1)=3
12509 ISID=4
12510 IF(KFL2(JT).LT.0) ISID=5
12511 K(N+2,ISID)=MSTU(5)*(N+3)
12512 K(N+3,9-ISID)=MSTU(5)*(N+2)
12513 ENDIF
12514 IF(KFL1(JT).EQ.KSUSY1+21) THEN
12515 K(N+1,1)=3
12516 K(N+2,1)=3
12517 K(N+3,1)=3
12518 ISID=4
12519 IF(KFL2(JT).LT.0) ISID=5
12520 K(N+1,ISID)=MSTU(5)*(N+2)
12521 K(N+1,9-ISID)=MSTU(5)*(N+3)
12522 K(N+2,ISID)=MSTU(5)*(N+1)
12523 K(N+3,9-ISID)=MSTU(5)*(N+1)
12524 ENDIF
12525 IF(KFA.EQ.KSUSY1+21) THEN
12526 K(N+2,1)=3
12527 K(N+3,1)=3
12528 ISID=4
12529 IF(KFL2(JT).LT.0) ISID=5
12530 K(ID,ISID)=K(ID,ISID)+(N+2)
12531 K(ID,9-ISID)=K(ID,9-ISID)+(N+3)
12532 K(N+2,ISID)=MSTU(5)*ID
12533 K(N+3,9-ISID)=MSTU(5)*ID
12534 ENDIF
12535 IF(KFA.GE.KSUSY1+22.AND.KFA.LE.KSUSY1+37.AND.
12536 & IABS(KCQ2(JT)).EQ.1) THEN
12537 K(N+2,1)=3
12538 K(N+3,1)=3
12539 ISID=4
12540 IF(KFL2(JT).LT.0) ISID=5
12541 K(N+2,ISID)=MSTU(5)*(N+3)
12542 K(N+3,9-ISID)=MSTU(5)*(N+2)
12543 ENDIF
12544 N=N+3
12545CMRENNA--
12546
12547C...2) Everything else two-body decay.
12548 ELSE
12549 CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
12550C...First set colour flow as if mother colour singlet.
12551 IF(KCQ1(JT).NE.0) THEN
12552 K(N-1,1)=3
12553 IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N
12554 IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N
12555 ENDIF
12556 IF(KCQ2(JT).NE.0) THEN
12557 K(N,1)=3
12558 IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1)
12559 IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1)
12560 ENDIF
12561C...Then redirect colour flow if mother (anti)triplet.
12562 IF(KCQM(JT).EQ.0) THEN
12563 ELSEIF(KCQM(JT).NE.2) THEN
12564 ISID=4
12565 IF(KCQM(JT).EQ.-1) ISID=5
12566 IDAU=N-1
12567 IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N
12568 K(ID,ISID)=K(ID,ISID)+IDAU
12569 K(IDAU,ISID)=MSTU(5)*ID
12570C...Then redirect colour flow if mother octet.
12571 ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN
12572 IDAU=N-1
12573 IF(KCQ1(JT).EQ.0) IDAU=N
12574 K(ID,4)=K(ID,4)+IDAU
12575 K(ID,5)=K(ID,5)+IDAU
12576 K(IDAU,4)=MSTU(5)*ID
12577 K(IDAU,5)=MSTU(5)*ID
12578 ELSE
12579 ISID=4
12580 IF(KCQ1(JT).EQ.-1) ISID=5
12581 IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0))
12582 K(ID,ISID)=K(ID,ISID)+(N-1)
12583 K(ID,9-ISID)=K(ID,9-ISID)+N
12584 K(N-1,ISID)=MSTU(5)*ID
12585 K(N,9-ISID)=MSTU(5)*ID
12586 ENDIF
12587 ENDIF
12588
12589C...End loop over resonances for daughter flavour and mass selection.
12590 MSTU(10)=MSTU10
12591 240 IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0))
12592 & NINH=NINH+1
12593 IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.MDCY(KCA,1).NE.0.AND.
12594 & KFL1(JT).EQ.0) THEN
12595 WRITE(CODE,'(I9)') K(ID,2)
12596 WRITE(MASS,'(F9.3)') P(ID,5)
12597 CALL PYERRM(3,'(PYRESD:) Failed to decay particle'//
12598 & CODE//' with mass'//MASS)
12599 MINT(51)=1
12600 GOTO 630
12601 ENDIF
12602 250 CONTINUE
12603
12604C...Check for allowed combinations. Skip if no decays.
12605 IF(JTMAX.EQ.1) THEN
12606 IF(KDCY(1).EQ.0) GOTO 620
12607 ELSEIF(JTMAX.EQ.2) THEN
12608 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 620
12609 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 160
12610 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 160
12611 ELSEIF(JTMAX.EQ.3) THEN
12612 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 620
12613 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 160
12614 IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 160
12615 IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 160
12616 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 160
12617 IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 160
12618 IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 160
12619 ENDIF
12620
12621C...Special case: matrix element option for Z0 decay to quarks.
12622 IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND.
12623 &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN
12624
12625C...Check consistency of MSTJ options set.
12626 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
12627 CALL PYERRM(6,
12628 & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
12629 MSTJ(110)=1
12630 ENDIF
12631 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
12632 CALL PYERRM(6,
12633 & '(PYRESD:) MSTJ(109) value requires MSTJ(111) = 0')
12634 MSTJ(111)=0
12635 ENDIF
12636
12637C...Select alpha_strong behaviour.
12638 MST111=MSTU(111)
12639 PAR112=PARU(112)
12640 MSTU(111)=MSTJ(108)
12641 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
12642 & MSTU(111)=1
12643 PARU(112)=PARJ(121)
12644 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
12645
12646C...Find axial fraction in total cross section for scalar gluon model.
12647 PARJ(171)=0D0
12648 IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR.
12649 & (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN
12650 POLL=1D0-PARJ(131)*PARJ(132)
12651 SFF=1D0/(16D0*XW*XW1)
12652 SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+
12653 & (PARJ(123)*PARJ(124))**2)
12654 SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2)
12655 VE=4D0*XW-1D0
12656 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
12657 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*
12658 & (PARJ(132)-PARJ(131)))
12659 KFLC=IABS(KFL1(1))
12660 PMQ=PYMASS(KFLC)
12661 QF=KCHG(KFLC,1)/3D0
12662 VQ=1D0
12663 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,
12664 & 1D0-(2D0*PMQ/P(ID,5))**2))
12665 VF=SIGN(1D0,QF)-4D0*QF*XW
12666 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+
12667 & VF**2*HF1W)+VQ**3*HF1W
12668 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
12669 ENDIF
12670
12671C...Choice of jet configuration.
12672 CALL PYXJET(P(ID,5),NJET,CUT)
12673 KFLC=IABS(KFL1(1))
12674 KFLN=21
12675 IF(NJET.EQ.4) THEN
12676 CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14)
12677 ELSEIF(NJET.EQ.3) THEN
12678 CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3)
12679 ELSE
12680 MSTJ(120)=1
12681 ENDIF
12682
12683C...Fill jet configuration; return if incorrect kinematics.
12684 NC=N-2
12685 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN
12686 CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5))
12687 ELSEIF(NJET.EQ.2) THEN
12688 CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5))
12689 ELSEIF(NJET.EQ.3) THEN
12690 CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3)
12691 ELSEIF(KFLN.EQ.21) THEN
12692 CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
12693 & X12,X14)
12694 ELSE
12695 CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
12696 & X12,X14)
12697 ENDIF
12698 IF(MSTU(24).NE.0) THEN
12699 MINT(51)=1
12700 MSTU(111)=MST111
12701 PARU(112)=PAR112
12702 GOTO 630
12703 ENDIF
12704
12705C...Angular orientation according to matrix element.
12706 IF(MSTJ(106).EQ.1) THEN
12707 CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHIZ,THEZ,PHIZ)
12708 IF(MINT(11).LT.0) THEZ=PARU(1)-THEZ
12709 CTHE(1)=COS(THEZ)
12710 CALL PYROBO(NC+1,N,0D0,CHIZ,0D0,0D0,0D0)
12711 CALL PYROBO(NC+1,N,THEZ,PHIZ,0D0,0D0,0D0)
12712 ENDIF
12713
12714C...Boost partons to Z0 rest frame.
12715 CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4),
12716 & P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
12717
12718C...Mark decayed resonance and add documentation lines,
12719 K(ID,1)=K(ID,1)+10
12720 IDOC=MINT(83)+MINT(4)
12721 DO 270 I=NC+1,N
12722 I1=MINT(83)+MINT(4)+1
12723 K(I,3)=I1
12724 IF(MSTP(128).GE.1) K(I,3)=ID
12725 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
12726 MINT(4)=MINT(4)+1
12727 K(I1,1)=21
12728 K(I1,2)=K(I,2)
12729 K(I1,3)=IREF(IP,4)
12730 DO 260 J=1,5
12731 P(I1,J)=P(I,J)
12732 260 CONTINUE
12733 ENDIF
12734 270 CONTINUE
12735
12736C...Generate parton shower.
12737 IF(MSTJ(101).EQ.5) CALL PYSHOW(N-1,N,P(ID,5))
12738
12739C... End special case for Z0: skip ahead.
12740 MSTU(111)=MST111
12741 PARU(112)=PAR112
12742 GOTO 610
12743 ENDIF
12744
12745C...Order incoming partons and outgoing resonances.
12746 IF(JTMAX.EQ.2.AND.ISUB.NE.0.AND.MSTP(47).GE.1.AND.
12747 &NINH.EQ.0) THEN
12748 ILIN(1)=MINT(84)+1
12749 IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
12750 IF(K(ILIN(1),2).EQ.21.OR.K(ILIN(1),2).EQ.22)
12751 & ILIN(1)=2*MINT(84)+3-ILIN(1)
12752 ILIN(2)=2*MINT(84)+3-ILIN(1)
12753 IMIN=1
12754 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
12755 & .EQ.36) IMIN=3
12756 IMAX=2
12757 IORD=1
12758 IF(K(IREF(IP,1),2).EQ.23) IORD=2
12759 IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
12760 IAKIPD=IABS(K(IREF(IP,IORD),2))
12761 IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD
12762 IF(KDCY(IORD).EQ.0) IORD=3-IORD
12763
12764C...Order decay products of resonances.
12765 DO 280 JT=IORD,3-IORD,3-2*IORD
12766 IF(KDCY(JT).EQ.0) THEN
12767 ILIN(IMAX+1)=NSD(JT)
12768 IMAX=IMAX+1
12769 ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
12770 ILIN(IMAX+1)=N+2*JT-1
12771 ILIN(IMAX+2)=N+2*JT
12772 IMAX=IMAX+2
12773 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
12774 K(N+2*JT,2)=K(NSD(JT)+2,2)
12775 ELSE
12776 ILIN(IMAX+1)=N+2*JT
12777 ILIN(IMAX+2)=N+2*JT-1
12778 IMAX=IMAX+2
12779 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
12780 K(N+2*JT,2)=K(NSD(JT)+2,2)
12781 ENDIF
12782 280 CONTINUE
12783
12784C...Find charge, isospin, left- and righthanded couplings.
12785 DO 300 I=IMIN,IMAX
12786 DO 290 J=1,4
12787 COUP(I,J)=0D0
12788 290 CONTINUE
12789 KFA=IABS(K(ILIN(I),2))
12790 IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 300
12791 COUP(I,1)=KCHG(KFA,1)/3D0
12792 COUP(I,2)=(-1)**MOD(KFA,2)
12793 COUP(I,4)=-2D0*COUP(I,1)*XWV
12794 COUP(I,3)=COUP(I,2)+COUP(I,4)
12795 300 CONTINUE
12796
12797C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
12798 IF(ISUB.EQ.22) THEN
12799 DO 330 I=3,5,2
12800 I1=IORD
12801 IF(I.EQ.5) I1=3-IORD
12802 DO 320 J1=1,2
12803 DO 310 J2=1,2
12804 CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/
12805 & 16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)*
12806 & COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)*
12807 & COUP(I,J2+2)**2
12808 310 CONTINUE
12809 320 CONTINUE
12810 330 CONTINUE
12811 COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
12812 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2))
12813 COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))*
12814 & (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2))
12815 IF(COWT12.LT.PYR(0)*COMX12) GOTO 160
12816 ENDIF
12817 ENDIF
12818
12819C...Select angular orientation type - Z'/W' only.
12820 MZPWP=0
12821 IF(ISUB.EQ.141) THEN
12822 IF(PYR(0).LT.PARU(130)) MZPWP=1
12823 IF(IP.EQ.2) THEN
12824 IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2
12825 IAKIR=IABS(K(IREF(2,2),2))
12826 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
12827 IF(IAKIR.LE.20) MZPWP=2
12828 ENDIF
12829 IF(IP.GE.3) MZPWP=2
12830 ELSEIF(ISUB.EQ.142) THEN
12831 IF(PYR(0).LT.PARU(136)) MZPWP=1
12832 IF(IP.EQ.2) THEN
12833 IAKIR=IABS(K(IREF(2,2),2))
12834 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
12835 IF(IAKIR.LE.20) MZPWP=2
12836 ENDIF
12837 IF(IP.GE.3) MZPWP=2
12838 ENDIF
12839
12840C...Select random angles (begin of weighting procedure).
12841 340 DO 350 JT=1,JTMAX
12842 IF(KDCY(JT).EQ.0) GOTO 350
12843 IF(JTMAX.EQ.1.AND.ISUB.NE.0.AND.IHDEC.EQ.0) THEN
12844 CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0)
12845 IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
12846 PHI(JT)=VINT(24)
12847 ELSE
12848 CTHE(JT)=2D0*PYR(0)-1D0
12849 PHI(JT)=PARU(2)*PYR(0)
12850 ENDIF
12851 350 CONTINUE
12852
12853 IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
12854C...Construct massless four-vectors.
12855 DO 370 I=N+1,N+4
12856 K(I,1)=1
12857 DO 360 J=1,5
12858 P(I,J)=0D0
12859C V(I,J)=0D0
12860 360 CONTINUE
12861 370 CONTINUE
12862 DO 380 JT=1,JTMAX
12863 IF(KDCY(JT).EQ.0) GOTO 380
12864 ID=IREF(IP,JT)
12865 P(N+2*JT-1,3)=0.5D0*P(ID,5)
12866 P(N+2*JT-1,4)=0.5D0*P(ID,5)
12867 P(N+2*JT,3)=-0.5D0*P(ID,5)
12868 P(N+2*JT,4)=0.5D0*P(ID,5)
12869 CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
12870 & P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
12871 380 CONTINUE
12872
12873C...Store incoming and outgoing momenta, with random rotation to
12874C...avoid accidental zeroes in HA expressions.
12875 IF(ISUB.NE.0) THEN
12876 DO 400 I=1,IMAX
12877 K(N+4+I,1)=1
12878 P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+
12879 & P(ILIN(I),3)**2+P(ILIN(I),5)**2)
12880 P(N+4+I,5)=P(ILIN(I),5)
12881 DO 390 J=1,3
12882 P(N+4+I,J)=P(ILIN(I),J)
12883 390 CONTINUE
12884 400 CONTINUE
12885 410 THERR=ACOS(2D0*PYR(0)-1D0)
12886 PHIRR=PARU(2)*PYR(0)
12887 CALL PYROBO(N+5,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
12888 DO 430 I=1,IMAX
12889 IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*P(N+4+I,4)**2)
12890 & GOTO 410
12891 DO 420 J=1,4
12892 PK(I,J)=P(N+4+I,J)
12893 420 CONTINUE
12894 430 CONTINUE
12895 ENDIF
12896
12897C...Calculate internal products.
12898 IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR.
12899 & ISUB.EQ.142) THEN
12900 DO 450 I1=IMIN,IMAX-1
12901 DO 440 I2=I1+1,IMAX
12902 HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+
12903 & PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))*
12904 & CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))-
12905 & SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
12906 & (1D-20+PK(I2,1)**2+PK(I2,2)**2)))*
12907 & CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2)))
12908 HC(I1,I2)=CONJG(HA(I1,I2))
12909 IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
12910 IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
12911 HA(I2,I1)=-HA(I1,I2)
12912 HC(I2,I1)=-HC(I1,I2)
12913 440 CONTINUE
12914 450 CONTINUE
12915 ENDIF
12916
12917C...Calculate four-products.
12918 IF(ISUB.NE.0) THEN
12919 DO 470 I=1,2
12920 DO 460 J=1,4
12921 PK(I,J)=-PK(I,J)
12922 460 CONTINUE
12923 470 CONTINUE
12924 DO 490 I1=IMIN,IMAX-1
12925 DO 480 I2=I1+1,IMAX
12926 PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
12927 & PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
12928 PKK(I2,I1)=PKK(I1,I2)
12929 480 CONTINUE
12930 490 CONTINUE
12931 ENDIF
12932 ENDIF
12933
12934 KFAGM=IABS(IREF(IP,7))
12935 IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN
12936C...Isotropic decay selected by user.
12937 WT=1D0
12938 WTMAX=1D0
12939
12940 ELSEIF(JTMAX.EQ.3) THEN
12941C...Isotropic decay when three mother particles.
12942 WT=1D0
12943 WTMAX=1D0
12944
12945 ELSEIF(IT4.GE.1) THEN
12946C... Isotropic decay t -> b + W etc for 4th generation q and l.
12947 WT=1D0
12948 WTMAX=1D0
12949
12950 ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.
12951 & IREF(IP,7).EQ.36) THEN
12952C...Angular weight for h0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
12953 IF(IP.EQ.1) WTMAX=SH**2
12954 IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4
12955 KFA=IABS(K(IREF(IP,1),2))
12956 IF(KFA.EQ.23) THEN
12957 KFLF1A=IABS(KFL1(1))
12958 EF1=KCHG(KFLF1A,1)/3D0
12959 AF1=SIGN(1D0,EF1+0.1D0)
12960 VF1=AF1-4D0*EF1*XWV
12961 KFLF2A=IABS(KFL1(2))
12962 EF2=KCHG(KFLF2A,1)/3D0
12963 AF2=SIGN(1D0,EF2+0.1D0)
12964 VF2=AF2-4D0*EF2*XWV
12965 VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)*(VF2**2+AF2**2))
12966 WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+
12967 & 8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5)
12968 ELSEIF(KFA.EQ.24) THEN
12969 WT=16D0*PKK(3,5)*PKK(4,6)
12970 ELSE
12971 WT=WTMAX
12972 ENDIF
12973
12974 ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR.
12975 & KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24)
12976 & THEN
12977C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
12978 I1=IREF(IP,8)
12979 IF(MOD(KFAGM,2).EQ.0) THEN
12980 I2=N+1
12981 I3=N+2
12982 ELSE
12983 I2=N+2
12984 I3=N+1
12985 ENDIF
12986 I4=IREF(IP,2)
12987 WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
12988 & P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)-
12989 & P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3))
12990 WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0
12991
12992 ELSEIF(ISUB.EQ.1) THEN
12993C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
12994 EI=KCHG(IABS(MINT(15)),1)/3D0
12995 AI=SIGN(1D0,EI+0.1D0)
12996 VI=AI-4D0*EI*XWV
12997 EF=KCHG(IABS(KFL1(1)),1)/3D0
12998 AF=SIGN(1D0,EF+0.1D0)
12999 VF=AF-4D0*EF*XWV
13000 RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH)
13001 WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
13002 & (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2)
13003 WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
13004 & (VI**2+AI**2)*VINT(114)*VF**2)
13005 WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+
13006 & 4D0*VI*AI*VINT(114)*VF*AF)
13007 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
13008 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
13009 WTMAX=2D0*(WT1+ABS(WT3))
13010
13011 ELSEIF(ISUB.EQ.2) THEN
13012C...Angular weight for W+/- -> 2 quarks/leptons.
13013 RM3=PMAS(IABS(KFL1(1)),1)**2/SH
13014 RM4=PMAS(IABS(KFL2(1)),1)**2/SH
13015 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
13016 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
13017 WTMAX=4D0
13018
13019 ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
13020C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
13021C...-> gluon/gamma + 2 quarks/leptons.
13022 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13023 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
13024 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
13025 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13026 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
13027 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
13028 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13029 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
13030 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
13031 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13032 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
13033 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
13034 WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+
13035 & (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2)
13036 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
13037 & ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
13038
13039 ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
13040C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
13041C...-> gluon/gamma + 2 quarks/leptons.
13042 WT=PKK(1,3)**2+PKK(2,4)**2
13043 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
13044
13045 ELSEIF(ISUB.EQ.22) THEN
13046C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
13047 S34=P(IREF(IP,IORD),5)**2
13048 S56=P(IREF(IP,3-IORD),5)**2
13049 TI=PKK(1,3)+PKK(1,4)+S34
13050 UI=PKK(1,5)+PKK(1,6)+S56
13051 TIR=REAL(TI)
13052 UIR=REAL(UI)
13053 FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2
13054 FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2
13055 FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2
13056 FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2
13057 FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2
13058 FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2
13059 FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2
13060 FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2
13061 WT=
13062 & CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+
13063 & CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+
13064 & CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+
13065 & CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264
13066 WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
13067 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56*
13068 & ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+
13069 & 1D0/UI**2))
13070
13071 ELSEIF(ISUB.EQ.23) THEN
13072C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
13073 D34=P(IREF(IP,IORD),5)**2
13074 D56=P(IREF(IP,3-IORD),5)**2
13075 DT=PKK(1,3)+PKK(1,4)+D34
13076 DU=PKK(1,5)+PKK(1,6)+D56
13077 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
13078 CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
13079 CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
13080 FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+
13081 & REAL(CBWZ)*FGK(1,2,5,6,3,4))
13082 FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+
13083 & REAL(CBWZ)*FGK(1,2,6,5,3,4))
13084 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
13085 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
13086 & DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
13087
13088 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
13089C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
13090C...(or H0, or A0).
13091 WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
13092 & PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
13093 & COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
13094 WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
13095 & (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
13096
13097 ELSEIF(ISUB.EQ.25) THEN
13098C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
13099 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
13100 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
13101 D34=P(IREF(IP,IORD),5)**2
13102 D56=P(IREF(IP,3-IORD),5)**2
13103 DT=PKK(1,3)+PKK(1,4)+D34
13104 DU=PKK(1,5)+PKK(1,6)+D56
13105 FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2)
13106 CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH
13107 CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT
13108 CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU
13109 CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH
13110 FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)-
13111 & REAL(CBWW)*FGK(1,2,5,6,3,4))
13112 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
13113 IF(MSTP(50).LE.0) THEN
13114 WT=FGK135**2+(CCWW*FGK253)**2
13115 WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-
13116 & CAWW*CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-
13117 & DJGK(DT,DU)))
13118 ELSE
13119 WT=POLL*FGK135**2+POLR*(CCWW*FGK253)**2
13120 WTMAX=4D0*D34*D56*(POLL*(CAWW**2*DIGK(DT,DU)+
13121 & CBWW**2*DIGK(DU,DT)-CAWW*CBWW*DJGK(DT,DU))+
13122 & POLR*CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
13123 ENDIF
13124
13125 ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN
13126C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
13127C...(or H0, or A0).
13128 WT=PKK(1,3)*PKK(2,4)
13129 WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
13130
13131 ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN
13132C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
13133C...-> f + 2 quarks/leptons.
13134 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13135 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
13136 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
13137 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13138 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
13139 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
13140 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13141 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
13142 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
13143 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13144 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
13145 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
13146 IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+
13147 & PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2)
13148 IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+
13149 & PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2)
13150 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
13151 & ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
13152
13153 ELSEIF(ISUB.EQ.31.OR.ISUB.EQ.36) THEN
13154C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions.
13155 IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
13156 IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
13157 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
13158
13159 ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.
13160 & ISUB.EQ.77) THEN
13161C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
13162 WT=16D0*PKK(3,5)*PKK(4,6)
13163 WTMAX=SH**2
13164
13165 ELSEIF(ISUB.EQ.110) THEN
13166C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
13167 WT=1D0
13168 WTMAX=1D0
13169
13170 ELSEIF(ISUB.EQ.141) THEN
13171 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
13172C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
13173C...Couplings of incoming flavour.
13174 KFAI=IABS(MINT(15))
13175 EI=KCHG(KFAI,1)/3D0
13176 AI=SIGN(1D0,EI+0.1D0)
13177 VI=AI-4D0*EI*XWV
13178 KFAIC=1
13179 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
13180 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
13181 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
13182 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
13183 VPI=PARU(119+2*KFAIC)
13184 API=PARU(120+2*KFAIC)
13185 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
13186 VPI=PARJ(178+2*KFAIC)
13187 API=PARJ(179+2*KFAIC)
13188 ELSE
13189 VPI=PARJ(186+2*KFAIC)
13190 API=PARJ(187+2*KFAIC)
13191 ENDIF
13192C...Couplings of final flavour.
13193 KFAF=IABS(KFL1(1))
13194 EF=KCHG(KFAF,1)/3D0
13195 AF=SIGN(1D0,EF+0.1D0)
13196 VF=AF-4D0*EF*XWV
13197 KFAFC=1
13198 IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2
13199 IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3
13200 IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4
13201 IF(KFAF.LE.2.OR.KFAF.EQ.11.OR.KFAF.EQ.12) THEN
13202 VPF=PARU(119+2*KFAFC)
13203 APF=PARU(120+2*KFAFC)
13204 ELSEIF(KFAF.LE.4.OR.KFAF.EQ.13.OR.KFAF.EQ.14) THEN
13205 VPF=PARJ(178+2*KFAFC)
13206 APF=PARJ(179+2*KFAFC)
13207 ELSE
13208 VPF=PARJ(186+2*KFAFC)
13209 APF=PARJ(187+2*KFAFC)
13210 ENDIF
13211C...Asymmetry and weight.
13212 ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+
13213 & 4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)*
13214 & (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/
13215 & (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
13216 & EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
13217 & (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+
13218 & (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2))
13219 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
13220 WTMAX=2D0+ABS(ASYM)
13221 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN
13222C...Angular weight for f + fbar -> Z' -> W+ + W-.
13223 RM1=P(NSD(1)+1,5)**2/SH
13224 RM2=P(NSD(1)+2,5)**2/SH
13225 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
13226 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
13227 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
13228 & (RM2-RM1)**2)
13229 WT=CFLAT+CCOS2*CTHE(1)**2
13230 WTMAX=CFLAT+MAX(0D0,CCOS2)
13231 ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR.
13232 & IABS(KFL1(1)).EQ.37)) THEN
13233C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
13234 WT=1D0-CTHE(1)**2
13235 WTMAX=1D0
13236 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
13237C...Angular weight for f + fbar -> Z' -> Z0 + h0.
13238 RM1=P(NSD(1)+1,5)**2/SH
13239 RM2=P(NSD(1)+2,5)**2/SH
13240 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
13241 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
13242 WTMAX=1D0+FLAM2/(8D0*RM1)
13243 ELSEIF(MZPWP.EQ.0) THEN
13244C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
13245C...(W:s like if intermediate Z).
13246 D34=P(IREF(IP,IORD),5)**2
13247 D56=P(IREF(IP,3-IORD),5)**2
13248 DT=PKK(1,3)+PKK(1,4)+D34
13249 DU=PKK(1,5)+PKK(1,6)+D56
13250 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
13251 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
13252 WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2
13253 WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)*
13254 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
13255 ELSEIF(MZPWP.EQ.1) THEN
13256C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
13257C...(W:s approximately longitudinal, like if intermediate H).
13258 WT=16D0*PKK(3,5)*PKK(4,6)
13259 WTMAX=SH**2
13260 ELSE
13261C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
13262C...H0 + A0 -> 4 quarks/leptons, t + tbar -> b + W+ + bbar + W- .
13263 WT=1D0
13264 WTMAX=1D0
13265 ENDIF
13266
13267 ELSEIF(ISUB.EQ.142) THEN
13268 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
13269C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
13270 KFAI=IABS(MINT(15))
13271 KFAIC=1
13272 IF(KFAI.GT.10) KFAIC=2
13273 VI=PARU(129+2*KFAIC)
13274 AI=PARU(130+2*KFAIC)
13275 KFAF=IABS(KFL1(1))
13276 KFAFC=1
13277 IF(KFAF.GT.10) KFAFC=2
13278 VF=PARU(129+2*KFAFC)
13279 AF=PARU(130+2*KFAFC)
13280 ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2))
13281 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
13282 WTMAX=2D0+ABS(ASYM)
13283 ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN
13284C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
13285 RM1=P(NSD(1)+1,5)**2/SH
13286 RM2=P(NSD(1)+2,5)**2/SH
13287 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
13288 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
13289 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
13290 & (RM2-RM1)**2)
13291 WT=CFLAT+CCOS2*CTHE(1)**2
13292 WTMAX=CFLAT+MAX(0D0,CCOS2)
13293 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
13294C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
13295 RM1=P(NSD(1)+1,5)**2/SH
13296 RM2=P(NSD(1)+2,5)**2/SH
13297 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
13298 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
13299 WTMAX=1D0+FLAM2/(8D0*RM1)
13300 ELSEIF(MZPWP.EQ.0) THEN
13301C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
13302C...(W/Z like if intermediate W).
13303 D34=P(IREF(IP,IORD),5)**2
13304 D56=P(IREF(IP,3-IORD),5)**2
13305 DT=PKK(1,3)+PKK(1,4)+D34
13306 DU=PKK(1,5)+PKK(1,6)+D56
13307 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
13308 FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4))
13309 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
13310 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*
13311 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
13312 ELSEIF(MZPWP.EQ.1) THEN
13313C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
13314C...(W/Z approximately longitudinal, like if intermediate H).
13315 WT=16D0*PKK(3,5)*PKK(4,6)
13316 WTMAX=SH**2
13317 ELSE
13318C...Angular weight for f + fbar -> W' -> W + h0 -> whatever,
13319C...t + bbar -> t + W + bbar.
13320 WT=1D0
13321 WTMAX=1D0
13322 ENDIF
13323
13324 ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164)
13325 & THEN
13326C...Isotropic decay of leptoquarks (assumed spin 0).
13327 WT=1D0
13328 WTMAX=1D0
13329
13330 ELSEIF(ISUB.GE.146.AND.ISUB.LE.148) THEN
13331C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-).
13332 SIDE=1D0
13333 IF(MINT(16).EQ.21.OR.MINT(16).EQ.22) SIDE=-1D0
13334 IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN
13335 WT=1D0+SIDE*CTHE(1)
13336 WTMAX=2D0
13337 ELSEIF(IP.EQ.1) THEN
13338 RM1=P(NSD(1)+1,5)**2/SH
13339 WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
13340 WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
13341 ELSE
13342C...W/Z decay assumed isotropic, since not known.
13343 WT=1D0
13344 WTMAX=1D0
13345 ENDIF
13346
13347 ELSEIF(ISUB.EQ.149) THEN
13348C...Isotropic decay of techni-eta.
13349 WT=1D0
13350 WTMAX=1D0
13351
13352 ELSEIF(ISUB.EQ.191) THEN
13353 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
13354C...Angular weight for f + fbar -> rho_tc0 -> W+ W-,
13355C...W+ pi_tc-, pi_tc+ W- or pi_tc+ pi_tc-.
13356 WT=1D0-CTHE(1)**2
13357 WTMAX=1D0
13358 ELSEIF(IP.EQ.1) THEN
13359C...Angular weight for f + fbar -> rho_tc0 -> f fbar.
13360 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
13361 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
13362 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
13363 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
13364 KFAI=IABS(MINT(15))
13365 EI=KCHG(KFAI,1)/3D0
13366 AI=SIGN(1D0,EI+0.1D0)
13367 VI=AI-4D0*EI*XWV
13368 VALI=0.5D0*(VI+AI)
13369 VARI=0.5D0*(VI-AI)
13370 ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2
13371 ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2
13372 KFAF=IABS(KFL1(1))
13373 EF=KCHG(KFAF,1)/3D0
13374 AF=SIGN(1D0,EF+0.1D0)
13375 VF=AF-4D0*EF*XWV
13376 VALF=0.5D0*(VF+AF)
13377 VARF=0.5D0*(VF-AF)
13378 ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2
13379 ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2
13380 ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF
13381 AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF
13382 WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2
13383 WTMAX=4D0*MAX(ASAME,AFLIP)
13384 ELSE
13385C...Isotropic decay of W/pi_tc produced in rho_tc decay.
13386 WT=1D0
13387 WTMAX=1D0
13388 ENDIF
13389
13390 ELSEIF(ISUB.EQ.192) THEN
13391 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
13392C...Angular weight for f + fbar' -> rho_tc+ -> W+ Z0,
13393C...W+ pi_tc0, pi_tc+ Z0 or pi_tc+ pi_tc0.
13394 WT=1D0-CTHE(1)**2
13395 WTMAX=1D0
13396 ELSEIF(IP.EQ.1) THEN
13397C...Angular weight for f + fbar' -> rho_tc+ -> f fbar'.
13398 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
13399 WT=(1D0+CTHESG)**2
13400 WTMAX=4D0
13401 ELSE
13402C...Isotropic decay of W/Z/pi_tc produced in rho_tc+ decay.
13403 WT=1D0
13404 WTMAX=1D0
13405 ENDIF
13406
13407 ELSEIF(ISUB.EQ.193) THEN
13408 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
13409C...Angular weight for f + fbar -> omega_tc0 ->
13410C...gamma pi_tc0 or Z0 pi_tc0.
13411 WT=1D0+CTHE(1)**2
13412 WTMAX=2D0
13413 ELSEIF(IP.EQ.1) THEN
13414C...Angular weight for f + fbar -> omega_tc0 -> f fbar.
13415 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
13416 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
13417 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
13418 KFAI=IABS(MINT(15))
13419 EI=KCHG(KFAI,1)/3D0
13420 AI=SIGN(1D0,EI+0.1D0)
13421 VI=AI-4D0*EI*XWV
13422 VALI=0.5D0*(VI+AI)
13423 VARI=0.5D0*(VI-AI)
13424 BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2
13425 BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2
13426 KFAF=IABS(KFL1(1))
13427 EF=KCHG(KFAF,1)/3D0
13428 AF=SIGN(1D0,EF+0.1D0)
13429 VF=AF-4D0*EF*XWV
13430 VALF=0.5D0*(VF+AF)
13431 VARF=0.5D0*(VF-AF)
13432 BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2
13433 BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2
13434 BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF
13435 BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF
13436 WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2
13437 WTMAX=4D0*MAX(BSAME,BFLIP)
13438 ELSE
13439C...Isotropic decay of Z/pi_tc produced in omega_tc decay.
13440 WT=1D0
13441 WTMAX=1D0
13442 ENDIF
13443
13444 ELSEIF(ISUB.EQ.353) THEN
13445C...Angular weight for Z_R0 -> 2 quarks/leptons.
13446 EI=KCHG(IABS(MINT(15)),1)/3D0
13447 AI=SIGN(1D0,EI+0.1D0)
13448 VI=AI-4D0*EI*XWV
13449 EF=KCHG(PYCOMP(KFL1(1)),1)/3D0
13450 AF=SIGN(1D0,EF+0.1D0)
13451 VF=AF-4D0*EF*XWV
13452 RMF=MIN(1D0,4D0*PMAS(PYCOMP(KFL1(1)),1)**2/SH)
13453 WT1=(VI**2+AI**2)*(VF**2+(1D0-RMF)*AF**2)
13454 WT2=RMF*(VI**2+AI**2)*VF**2
13455 WT3=SQRT(1D0-RMF)*4D0*VI*AI*VF*AF
13456 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
13457 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
13458 WTMAX=2D0*(WT1+ABS(WT3))
13459
13460 ELSEIF(ISUB.EQ.354) THEN
13461C...Angular weight for W_R+/- -> 2 quarks/leptons.
13462 RM3=PMAS(PYCOMP(KFL1(1)),1)**2/SH
13463 RM4=PMAS(PYCOMP(KFL2(1)),1)**2/SH
13464 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
13465 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
13466 WTMAX=4D0
13467
13468 ELSEIF(ISUB.EQ.391) THEN
13469C...Angular weight for f + fbar -> G* -> f + fbar
13470 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
13471 WT=1D0-3D0*CTHE(1)**2+4D0*CTHE(1)**4
13472 WTMAX=2D0
13473C...Other G* decays not yet implemented angular distributions.
13474 ELSE
13475 WT=1D0
13476 WTMAX=1D0
13477 ENDIF
13478
13479 ELSEIF(ISUB.EQ.392) THEN
13480C...Angular weight for g + g -> G* -> f + fbar
13481 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
13482 WT=1D0-CTHE(1)**4
13483 WTMAX=1D0
13484C...Other G* decays not yet implemented angular distributions.
13485 ELSE
13486 WT=1D0
13487 WTMAX=1D0
13488 ENDIF
13489
13490C...Obtain correct angular distribution by rejection techniques.
13491 ELSE
13492 WT=1D0
13493 WTMAX=1D0
13494 ENDIF
13495 IF(WT.LT.PYR(0)*WTMAX) GOTO 340
13496
13497C...Construct massive four-vectors using angles chosen.
13498 500 DO 600 JT=1,JTMAX
13499 IF(KDCY(JT).EQ.0) GOTO 600
13500 ID=IREF(IP,JT)
13501 DO 510 J=1,5
13502 DPMO(J)=P(ID,J)
13503 510 CONTINUE
13504 DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2)
13505CMRENNA++
13506 IF(KFL3(JT).EQ.0) THEN
13507 CALL PYROBO(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT),
13508 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
13509 N0=NSD(JT)+2
13510 ELSE
13511 CALL PYROBO(NSD(JT)+1,NSD(JT)+3,ACOS(CTHE(JT)),PHI(JT),
13512 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
13513 N0=NSD(JT)+3
13514 ENDIF
13515
13516 DO 520 J=1,4
13517 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
13518 520 CONTINUE
13519C...Fill in position of decay vertex.
13520 DO 540 I=NSD(JT)+1,N0
13521 DO 530 J=1,4
13522 V(I,J)=VDCY(J)
13523 530 CONTINUE
13524 V(I,5)=0D0
13525 540 CONTINUE
13526CMRENNA--
13527
13528C...Mark decayed resonances; trace history.
13529 K(ID,1)=K(ID,1)+10
13530 KFA=IABS(K(ID,2))
13531 KCA=PYCOMP(KFA)
13532 IF(KCQM(JT).NE.0) THEN
13533C...Do not kill colour flow through coloured resonance!
13534 ELSE
13535 K(ID,4)=NSD(JT)+1
13536 K(ID,5)=NSD(JT)+2
13537 IF(KFL3(JT).NE.0) K(ID,5)=NSD(JT)+3
13538 ENDIF
13539
13540C...Add documentation lines.
13541 IF(IRES.EQ.0) THEN
13542 IDOC=MINT(83)+MINT(4)
13543CMRENNA+++
13544 IHI=NSD(JT)+2
13545 IF(KFL3(JT).NE.0) IHI=IHI+1
13546 DO 560 I=NSD(JT)+1,IHI
13547CMRENNA---
13548 I1=MINT(83)+MINT(4)+1
13549 K(I,3)=I1
13550 IF(MSTP(128).GE.1) K(I,3)=ID
13551 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
13552 MINT(4)=MINT(4)+1
13553 K(I1,1)=21
13554 K(I1,2)=K(I,2)
13555 K(I1,3)=IREF(IP,JT+3)
13556 DO 550 J=1,5
13557 P(I1,J)=P(I,J)
13558 550 CONTINUE
13559 ENDIF
13560 560 CONTINUE
13561 ELSE
13562 K(NSD(JT)+1,3)=ID
13563 K(NSD(JT)+2,3)=ID
13564 IF(KFL3(JT).NE.0) K(NSD(JT)+3,3)=ID
13565 ENDIF
13566
13567C...Do showering of two or three objects.
13568 NSHBEF=N
13569 IF(MSTP(71).GE.1) THEN
13570 IF(KFL3(JT).EQ.0) THEN
13571 CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
13572 ELSE
13573 CALL PYSHOW(NSD(JT)+1,-3,P(ID,5))
13574 ENDIF
13575 ENDIF
13576 NSHAFT=N
13577 IF(JT.EQ.1) NAFT1=N
13578
13579C...Check if decay products moved by shower.
13580 NSD1=NSD(JT)+1
13581 NSD2=NSD(JT)+2
13582 NSD3=NSD(JT)+3
13583 IF(NSHAFT.GT.NSHBEF) THEN
13584 IF(K(NSD1,1).GT.10) THEN
13585 DO 570 I=NSHBEF+1,NSHAFT
13586 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
13587 570 CONTINUE
13588 ENDIF
13589 IF(K(NSD2,1).GT.10) THEN
13590 DO 580 I=NSHBEF+1,NSHAFT
13591 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
13592 & I.NE.NSD1) NSD2=I
13593 580 CONTINUE
13594 ENDIF
13595 IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
13596 DO 590 I=NSHBEF+1,NSHAFT
13597 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND.
13598 & I.NE.NSD1.AND.I.NE.NSD2) NSD3=I
13599 590 CONTINUE
13600 ENDIF
13601 ENDIF
13602
13603C...Store decay products for further treatment.
13604 NP=NP+1
13605 IREF(NP,1)=NSD1
13606 IREF(NP,2)=NSD2
13607 IREF(NP,3)=0
13608 IF(KFL3(JT).NE.0) IREF(NP,3)=NSD3
13609 IREF(NP,4)=IDOC+1
13610 IREF(NP,5)=IDOC+2
13611 IREF(NP,6)=0
13612 IF(KFL3(JT).NE.0) IREF(NP,6)=IDOC+3
13613 IREF(NP,7)=K(IREF(IP,JT),2)
13614 IREF(NP,8)=IREF(IP,JT)
13615 600 CONTINUE
13616
13617C...Fill information for 2 -> 1 -> 2.
13618 610 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN
13619 MINT(7)=MINT(83)+6+2*ISET(ISUB)
13620 MINT(8)=MINT(83)+7+2*ISET(ISUB)
13621 MINT(25)=KFL1(1)
13622 MINT(26)=KFL2(1)
13623 VINT(23)=CTHE(1)
13624 RM3=P(N-1,5)**2/SH
13625 RM4=P(N,5)**2/SH
13626 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
13627 VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1))
13628 VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1))
13629 VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2)
13630 VINT(47)=SQRT(VINT(48))
13631 ENDIF
13632
13633C...Possibility of colour rearrangement in W+W- events.
13634 IF((ISUB.EQ.25.OR.ISUB.EQ.22).AND.MSTP(115).GE.1) THEN
13635 IAKF1=IABS(KFL1(1))
13636 IAKF2=IABS(KFL1(2))
13637 IAKF3=IABS(KFL2(1))
13638 IAKF4=IABS(KFL2(2))
13639 IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
13640 & MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
13641 & PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
13642 ENDIF
13643
13644C...Loop back if needed.
13645 620 IF(IP.LT.NP) GOTO 150
13646
13647C...Boost back to standard frame.
13648 630 IF(IBST.EQ.1) CALL PYROBO(MINT(83)+7,N,THEIN,PHIIN,BEXIN,BEYIN,
13649 &BEZIN)
13650
13651 RETURN
13652 END
13653
13654C*********************************************************************
13655
13656C...PYMULT
13657C...Initializes treatment of multiple interactions, selects kinematics
13658C...of hardest interaction if low-pT physics included in run, and
13659C...generates all non-hardest interactions.
13660
13661 SUBROUTINE PYMULT(MMUL)
13662
13663C...Double precision and integer declarations.
13664 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
13665 IMPLICIT INTEGER(I-N)
13666 INTEGER PYK,PYCHGE,PYCOMP
13667C...Commonblocks.
13668 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
13669 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13670 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
13671 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
13672 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13673 COMMON/PYINT1/MINT(400),VINT(400)
13674 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
13675 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
13676 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
13677 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
13678 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
13679 &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
13680C...Local arrays and saved variables.
13681 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
13682 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM
13683
13684C...Initialization of multiple interaction treatment.
13685 IF(MMUL.EQ.1) THEN
13686 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
13687 ISUB=96
13688 MINT(1)=96
13689 VINT(63)=0D0
13690 VINT(64)=0D0
13691 VINT(143)=1D0
13692 VINT(144)=1D0
13693
13694C...Loop over phase space points: xT2 choice in 20 bins.
13695 100 SIGSUM=0D0
13696 DO 120 IXT2=1,20
13697 NMUL(IXT2)=MSTP(83)
13698 SIGM(IXT2)=0D0
13699 DO 110 ITRY=1,MSTP(83)
13700 RSCA=0.05D0*((21-IXT2)-PYR(0))
13701 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
13702 XT2=MAX(0.01D0*VINT(149),XT2)
13703 VINT(25)=XT2
13704
13705C...Choose tau and y*. Calculate cos(theta-hat).
13706 IF(PYR(0).LE.COEF(ISUB,1)) THEN
13707 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
13708 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
13709 ELSE
13710 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
13711 ENDIF
13712 VINT(21)=TAU
13713 CALL PYKLIM(2)
13714 RYST=PYR(0)
13715 MYST=1
13716 IF(RYST.GT.COEF(ISUB,8)) MYST=2
13717 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
13718 CALL PYKMAP(2,MYST,PYR(0))
13719 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
13720
13721C...Calculate differential cross-section.
13722 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
13723 CALL PYSIGH(NCHN,SIGS)
13724 SIGM(IXT2)=SIGM(IXT2)+SIGS
13725 110 CONTINUE
13726 SIGSUM=SIGSUM+SIGM(IXT2)
13727 120 CONTINUE
13728 SIGSUM=SIGSUM/(20D0*MSTP(83))
13729
13730C...Reject result if sigma(parton-parton) is smaller than hadronic one.
13731 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
13732 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
13733 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
13734 PARP(82)=0.9D0*PARP(82)
13735 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
13736 & VINT(2)
13737 GOTO 100
13738 ENDIF
13739 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
13740 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
13741
13742C...Start iteration to find k factor.
13743 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
13744 SO=0.5D0
13745 XI=0D0
13746 YI=0D0
13747 XF=0D0
13748 YF=0D0
13749 XK=0.5D0
13750 IIT=0
13751 130 IF(IIT.EQ.0) THEN
13752 XK=2D0*XK
13753 ELSEIF(IIT.EQ.1) THEN
13754 XK=0.5D0*XK
13755 ELSE
13756 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
13757 ENDIF
13758
13759C...Evaluate overlap integrals.
13760 IF(MSTP(82).EQ.2) THEN
13761 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
13762 SOP=SP/PARU(1)
13763 ELSE
13764 IF(MSTP(82).EQ.3) DELTAB=0.02D0
13765 IF(MSTP(82).EQ.4) DELTAB=MIN(0.01D0,0.05D0*PARP(84))
13766 SP=0D0
13767 SOP=0D0
13768 B=-0.5D0*DELTAB
13769 140 B=B+DELTAB
13770 IF(MSTP(82).EQ.3) THEN
13771 OV=EXP(-B**2)/PARU(2)
13772 ELSE
13773 CQ2=PARP(84)**2
13774 OV=((1D0-PARP(83))**2*EXP(-MIN(50D0,B**2))+
13775 & 2D0*PARP(83)*(1D0-PARP(83))*2D0/(1D0+CQ2)*
13776 & EXP(-MIN(50D0,B**2*2D0/(1D0+CQ2)))+
13777 & PARP(83)**2/CQ2*EXP(-MIN(50D0,B**2/CQ2)))/PARU(2)
13778 ENDIF
13779 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
13780 SP=SP+PARU(2)*B*DELTAB*PACC
13781 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
13782 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
13783 ENDIF
13784 YK=PARU(1)*XK*SO/SP
13785
13786C...Continue iteration until convergence.
13787 IF(YK.LT.YKE) THEN
13788 XI=XK
13789 YI=YK
13790 IF(IIT.EQ.1) IIT=2
13791 ELSE
13792 XF=XK
13793 YF=YK
13794 IF(IIT.EQ.0) IIT=1
13795 ENDIF
13796 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
13797
13798C...Store some results for subsequent use.
13799 VINT(145)=SIGSUM
13800 VINT(146)=SOP/SO
13801 VINT(147)=SOP/SP
13802
13803C...Initialize iteration in xT2 for hardest interaction.
13804 ELSEIF(MMUL.EQ.2) THEN
13805 IF(MSTP(82).LE.0) THEN
13806 ELSEIF(MSTP(82).EQ.1) THEN
13807 XT2=1D0
13808 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
13809 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
13810 & VINT(317)/(VINT(318)*VINT(320))
13811 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
13812 ELSEIF(MSTP(82).EQ.2) THEN
13813 XT2=1D0
13814 XT2FAC=VINT(146)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
13815 & VINT(149)*(1D0+VINT(149))
13816 ELSE
13817 XC2=4D0*CKIN(3)**2/VINT(2)
13818 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
13819 ENDIF
13820
13821 ELSEIF(MMUL.EQ.3) THEN
13822C...Low-pT or multiple interactions (first semihard interaction):
13823C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
13824C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
13825 ISUB=MINT(1)
13826 IF(MSTP(82).LE.0) THEN
13827 XT2=0D0
13828 ELSEIF(MSTP(82).EQ.1) THEN
13829 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
13830 ELSEIF(MSTP(82).EQ.2) THEN
13831 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
13832 & VINT(149)))).GT.PYR(0)) XT2=1D0
13833 IF(XT2.GE.1D0) THEN
13834 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
13835 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
13836 & VINT(149)
13837 ELSE
13838 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
13839 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
13840 & VINT(149)
13841 ENDIF
13842 XT2=MAX(0.01D0*VINT(149),XT2)
13843 ELSE
13844 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
13845 & PYR(0)*(1D0-XC2))-VINT(149)
13846 XT2=MAX(0.01D0*VINT(149),XT2)
13847 ENDIF
13848 VINT(25)=XT2
13849
13850C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
13851 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
13852 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-1
13853 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-1
13854 ISUB=95
13855 MINT(1)=ISUB
13856 VINT(21)=0.01D0*VINT(149)
13857 VINT(22)=0D0
13858 VINT(23)=0D0
13859 VINT(25)=0.01D0*VINT(149)
13860
13861 ELSE
13862C...Multiple interactions (first semihard interaction).
13863C...Choose tau and y*. Calculate cos(theta-hat).
13864 IF(PYR(0).LE.COEF(ISUB,1)) THEN
13865 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
13866 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
13867 ELSE
13868 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
13869 ENDIF
13870 VINT(21)=TAU
13871 CALL PYKLIM(2)
13872 RYST=PYR(0)
13873 MYST=1
13874 IF(RYST.GT.COEF(ISUB,8)) MYST=2
13875 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
13876 CALL PYKMAP(2,MYST,PYR(0))
13877 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
13878 ENDIF
13879 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
13880
13881C...Store results of cross-section calculation.
13882 ELSEIF(MMUL.EQ.4) THEN
13883 ISUB=MINT(1)
13884 XTS=VINT(25)
13885 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
13886 IF(ISET(ISUB).EQ.2)
13887 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
13888 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
13889 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
13890 & (XTS+VINT(149))))
13891 IRBIN=INT(1D0+20D0*RBIN)
13892 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
13893 NMUL(IRBIN)=NMUL(IRBIN)+1
13894 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
13895 ENDIF
13896
13897C...Choose impact parameter.
13898 ELSEIF(MMUL.EQ.5) THEN
13899 ISUB=MINT(1)
13900 150 IF(MSTP(82).EQ.3) THEN
13901 VINT(148)=PYR(0)/(PARU(2)*VINT(147))
13902 ELSE
13903 RTYPE=PYR(0)
13904 CQ2=PARP(84)**2
13905 IF(RTYPE.LT.(1D0-PARP(83))**2) THEN
13906 B2=-LOG(PYR(0))
13907 ELSEIF(RTYPE.LT.1D0-PARP(83)**2) THEN
13908 B2=-0.5D0*(1D0+CQ2)*LOG(PYR(0))
13909 ELSE
13910 B2=-CQ2*LOG(PYR(0))
13911 ENDIF
13912 VINT(148)=((1D0-PARP(83))**2*EXP(-MIN(50D0,B2))+2D0*PARP(83)*
13913 & (1D0-PARP(83))*2D0/(1D0+CQ2)*EXP(-MIN(50D0,B2*2D0/(1D0+CQ2)))+
13914 & PARP(83)**2/CQ2*EXP(-MIN(50D0,B2/CQ2)))/(PARU(2)*VINT(147))
13915 ENDIF
13916
13917C...Multiple interactions (variable impact parameter) : reject with
13918C...probability exp(-overlap*cross-section above pT/normalization).
13919 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
13920 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
13921 DO 160 IBIN=IRBIN+1,20
13922 RNCOR=RNCOR+NMUL(IBIN)
13923 SIGCOR=SIGCOR+SIGM(IBIN)
13924 160 CONTINUE
13925 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
13926 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
13927 VINT(150)=EXP(-MIN(50D0,VINT(146)*VINT(148)*
13928 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
13929 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
13930 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
13931 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
13932 IF(VINT(150).LT.PYR(0)) GOTO 150
13933 VINT(150)=1D0
13934 ENDIF
13935
13936C...Generate additional multiple semihard interactions.
13937 ELSEIF(MMUL.EQ.6) THEN
13938 ISUBSV=MINT(1)
13939 DO 170 J=11,80
13940 VINTSV(J)=VINT(J)
13941 170 CONTINUE
13942 ISUB=96
13943 MINT(1)=96
13944 VINT(151)=0D0
13945 VINT(152)=0D0
13946
13947C...Reconstruct strings in hard scattering.
13948 NMAX=MINT(84)+4
13949 IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2
13950 IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3)
13951 NSTR=0
13952 DO 190 I=MINT(84)+1,NMAX
13953 KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
13954 IF(KCS.EQ.0) GOTO 190
13955 DO 180 J=1,4
13956 IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 180
13957 IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 180
13958 IF(J.LE.2) THEN
13959 IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
13960 ELSE
13961 IST=MOD(K(I,J+1),MSTU(5))
13962 ENDIF
13963 IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 180
13964 IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 180
13965 NSTR=NSTR+1
13966 IF(J.EQ.1.OR.J.EQ.4) THEN
13967 KSTR(NSTR,1)=I
13968 KSTR(NSTR,2)=IST
13969 ELSE
13970 KSTR(NSTR,1)=IST
13971 KSTR(NSTR,2)=I
13972 ENDIF
13973 180 CONTINUE
13974 190 CONTINUE
13975
13976C...Set up starting values for iteration in xT2.
13977 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
13978 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
13979 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
13980 & ISUBSV.NE.96)) THEN
13981 XT2=(1D0-VINT(141))*(1D0-VINT(142))
13982 ELSE
13983 XT2=VINT(25)
13984 IF(ISET(ISUBSV).EQ.1) XT2=VINT(21)
13985 IF(ISET(ISUBSV).EQ.2)
13986 & XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
13987 IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26)
13988 ENDIF
13989 IF(MSTP(82).LE.1) THEN
13990 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
13991 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
13992 & VINT(317)/(VINT(318)*VINT(320))
13993 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
13994 ELSE
13995 XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/
13996 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
13997 ENDIF
13998 VINT(63)=0D0
13999 VINT(64)=0D0
14000 VINT(143)=1D0-VINT(141)
14001 VINT(144)=1D0-VINT(142)
14002
14003C...Iterate downwards in xT2.
14004 200 IF(MSTP(82).LE.1) THEN
14005 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
14006 IF(XT2.LT.VINT(149)) GOTO 250
14007 ELSE
14008 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 250
14009 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
14010 & LOG(PYR(0)))-VINT(149)
14011 IF(XT2.LE.0D0) GOTO 250
14012 XT2=MAX(0.01D0*VINT(149),XT2)
14013 ENDIF
14014 VINT(25)=XT2
14015
14016C...Choose tau and y*. Calculate cos(theta-hat).
14017 IF(PYR(0).LE.COEF(ISUB,1)) THEN
14018 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
14019 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
14020 ELSE
14021 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
14022 ENDIF
14023 VINT(21)=TAU
14024 CALL PYKLIM(2)
14025 RYST=PYR(0)
14026 MYST=1
14027 IF(RYST.GT.COEF(ISUB,8)) MYST=2
14028 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
14029 CALL PYKMAP(2,MYST,PYR(0))
14030 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
14031
14032C...Check that x not used up. Accept or reject kinematical variables.
14033 X1M=SQRT(TAU)*EXP(VINT(22))
14034 X2M=SQRT(TAU)*EXP(-VINT(22))
14035 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 200
14036 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
14037 CALL PYSIGH(NCHN,SIGS)
14038 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
14039 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 200
14040
14041C...Reset K, P and V vectors. Select some variables.
14042 DO 220 I=N+1,N+2
14043 DO 210 J=1,5
14044 K(I,J)=0
14045 P(I,J)=0D0
14046 V(I,J)=0D0
14047 210 CONTINUE
14048 220 CONTINUE
14049 RFLAV=PYR(0)
14050 PT=0.5D0*VINT(1)*SQRT(XT2)
14051 PHI=PARU(2)*PYR(0)
14052 CTH=VINT(23)
14053
14054C...Add first parton to event record.
14055 K(N+1,1)=3
14056 K(N+1,2)=21
14057 IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
14058 & 1+INT((2D0+PARJ(2))*PYR(0))
14059 P(N+1,1)=PT*COS(PHI)
14060 P(N+1,2)=PT*SIN(PHI)
14061 P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH))
14062 P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH))
14063 P(N+1,5)=0D0
14064
14065C...Add second parton to event record.
14066 K(N+2,1)=3
14067 K(N+2,2)=21
14068 IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
14069 P(N+2,1)=-P(N+1,1)
14070 P(N+2,2)=-P(N+1,2)
14071 P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH))
14072 P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH))
14073 P(N+2,5)=0D0
14074
14075 IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
14076C....Choose relevant string pieces to place gluons on.
14077 DO 240 I=N+1,N+2
14078 DMIN=1D8
14079 DO 230 ISTR=1,NSTR
14080 I1=KSTR(ISTR,1)
14081 I2=KSTR(ISTR,2)
14082 DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
14083 & P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
14084 & P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
14085 & P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
14086 IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
14087 DMIN=DIST
14088 IST1=I1
14089 IST2=I2
14090 ISTM=ISTR
14091 ENDIF
14092 230 CONTINUE
14093
14094C....Colour flow adjustments, new string pieces.
14095 IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
14096 & MOD(K(IST1,4),MSTU(5))
14097 IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
14098 & MSTU(5)*(K(IST1,5)/MSTU(5))+I
14099 K(I,5)=MSTU(5)*IST1
14100 K(I,4)=MSTU(5)*IST2
14101 IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
14102 & MOD(K(IST2,5),MSTU(5))
14103 IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
14104 & MSTU(5)*(K(IST2,4)/MSTU(5))+I
14105 KSTR(ISTM,2)=I
14106 KSTR(NSTR+1,1)=I
14107 KSTR(NSTR+1,2)=IST2
14108 NSTR=NSTR+1
14109 240 CONTINUE
14110
14111C...String drawing and colour flow for gluon loop.
14112 ELSEIF(K(N+1,2).EQ.21) THEN
14113 K(N+1,4)=MSTU(5)*(N+2)
14114 K(N+1,5)=MSTU(5)*(N+2)
14115 K(N+2,4)=MSTU(5)*(N+1)
14116 K(N+2,5)=MSTU(5)*(N+1)
14117 KSTR(NSTR+1,1)=N+1
14118 KSTR(NSTR+1,2)=N+2
14119 KSTR(NSTR+2,1)=N+2
14120 KSTR(NSTR+2,2)=N+1
14121 NSTR=NSTR+2
14122
14123C...String drawing and colour flow for qqbar pair.
14124 ELSE
14125 K(N+1,4)=MSTU(5)*(N+2)
14126 K(N+2,5)=MSTU(5)*(N+1)
14127 KSTR(NSTR+1,1)=N+1
14128 KSTR(NSTR+1,2)=N+2
14129 NSTR=NSTR+1
14130 ENDIF
14131
14132C...Update remaining energy; iterate.
14133 N=N+2
14134 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
14135 CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
14136 IF(MSTU(21).GE.1) RETURN
14137 ENDIF
14138 MINT(31)=MINT(31)+1
14139 VINT(151)=VINT(151)+VINT(41)
14140 VINT(152)=VINT(152)+VINT(42)
14141 VINT(143)=VINT(143)-VINT(41)
14142 VINT(144)=VINT(144)-VINT(42)
14143 IF(MINT(31).LT.240) GOTO 200
14144 250 CONTINUE
14145 MINT(1)=ISUBSV
14146 DO 260 J=11,80
14147 VINT(J)=VINTSV(J)
14148 260 CONTINUE
14149 ENDIF
14150
14151C...Format statements for printout.
14152 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
14153 &'actions for MSTP(82) =',I2,' ******')
14154 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
14155 &D9.2,' mb: rejected')
14156 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
14157 &D9.2,' mb: accepted')
14158
14159 RETURN
14160 END
14161
14162C*********************************************************************
14163
14164C...PYREMN
14165C...Adds on target remnants (one or two from each side) and
14166C...includes primordial kT for hadron beams.
14167
14168 SUBROUTINE PYREMN(IPU1,IPU2)
14169
14170C...Double precision and integer declarations.
14171 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14172 IMPLICIT INTEGER(I-N)
14173 INTEGER PYK,PYCHGE,PYCOMP
14174C...Commonblocks.
14175 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14176 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14177 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14178 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14179 COMMON/PYINT1/MINT(400),VINT(400)
14180 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
14181C...Local arrays.
14182 DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
14183 &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
14184
14185C...Find event type and remaining energy.
14186 ISUB=MINT(1)
14187 NS=N
14188 IF(MINT(50).EQ.0.OR.MSTP(81).LE.0) THEN
14189 VINT(143)=1D0-VINT(141)
14190 VINT(144)=1D0-VINT(142)
14191 ENDIF
14192
14193C...Define initial partons.
14194 NTRY=0
14195 100 NTRY=NTRY+1
14196 DO 130 JT=1,2
14197 I=MINT(83)+JT+2
14198 IF(JT.EQ.1) IPU=IPU1
14199 IF(JT.EQ.2) IPU=IPU2
14200 K(I,1)=21
14201 K(I,2)=K(IPU,2)
14202 K(I,3)=I-2
14203 PMS(JT)=0D0
14204 VINT(156+JT)=0D0
14205 VINT(158+JT)=0D0
14206 IF(MINT(47).EQ.1) THEN
14207 DO 110 J=1,5
14208 P(I,J)=P(I-2,J)
14209 110 CONTINUE
14210 ELSEIF(ISUB.EQ.95) THEN
14211 K(I,2)=21
14212 ELSE
14213 P(I,5)=P(IPU,5)
14214
14215C...No primordial kT, or chosen according to truncated Gaussian or
14216C...exponential, or (for photon) predetermined or power law.
14217 120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
14218 IF(MSTP(91).LE.0) THEN
14219 PT=0D0
14220 ELSEIF(MSTP(91).EQ.1) THEN
14221 PT=PARP(91)*SQRT(-LOG(PYR(0)))
14222 ELSE
14223 RPT1=PYR(0)
14224 RPT2=PYR(0)
14225 PT=-PARP(92)*LOG(RPT1*RPT2)
14226 ENDIF
14227 IF(PT.GT.PARP(93)) GOTO 120
14228 ELSEIF(MINT(106+JT).EQ.3) THEN
14229 PTA=SQRT(VINT(282+JT))
14230 PTB=0D0
14231 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
14232 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
14233 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
14234 RPT1=PYR(0)
14235 RPT2=PYR(0)
14236 PTB=-PARP(99)*LOG(RPT1*RPT2)
14237 ENDIF
14238 IF(PTB.GT.PARP(100)) GOTO 120
14239 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
14240 PT=PT*0.8D0**MINT(57)
14241 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
14242 ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN
14243 IF(MSTP(93).LE.0) THEN
14244 PT=0D0
14245 ELSEIF(MSTP(93).EQ.1) THEN
14246 PT=PARP(99)*SQRT(-LOG(PYR(0)))
14247 ELSEIF(MSTP(93).EQ.2) THEN
14248 RPT1=PYR(0)
14249 RPT2=PYR(0)
14250 PT=-PARP(99)*LOG(RPT1*RPT2)
14251 ELSEIF(MSTP(93).EQ.3) THEN
14252 HA=PARP(99)**2
14253 HB=PARP(100)**2
14254 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
14255 ELSE
14256 HA=PARP(99)**2
14257 HB=PARP(100)**2
14258 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
14259 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
14260 ENDIF
14261 IF(PT.GT.PARP(100)) GOTO 120
14262 ELSE
14263 PT=0D0
14264 ENDIF
14265 VINT(156+JT)=PT
14266 PHI=PARU(2)*PYR(0)
14267 P(I,1)=PT*COS(PHI)
14268 P(I,2)=PT*SIN(PHI)
14269 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
14270 ENDIF
14271 130 CONTINUE
14272 IF(MINT(47).EQ.1) RETURN
14273
14274C...Kinematics construction for initial partons.
14275 I1=MINT(83)+3
14276 I2=MINT(83)+4
14277 IF(ISUB.EQ.95) THEN
14278 SHS=0D0
14279 SHR=0D0
14280 ELSE
14281 SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+
14282 & (P(I1,2)+P(I2,2))**2
14283 SHR=SQRT(MAX(0D0,SHS))
14284 IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100
14285 P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR)
14286 P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1)))
14287 P(I2,4)=SHR-P(I1,4)
14288 P(I2,3)=-P(I1,3)
14289
14290C...Transform partons to overall CM-frame.
14291 ROBO(3)=(P(I1,1)+P(I2,1))/SHR
14292 ROBO(4)=(P(I1,2)+P(I2,2))/SHR
14293 CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0)
14294 ROBO(2)=PYANGL(P(I1,1),P(I1,2))
14295 CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0)
14296 ROBO(1)=PYANGL(P(I1,3),P(I1,1))
14297 CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0)
14298 CALL PYROBO(I2+1,MINT(52),0D0,-ROBO(2),0D0,0D0,0D0)
14299 CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0)
14300 ROBO(5)=(VINT(141)-VINT(142))/(VINT(141)+VINT(142))
14301 CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5))
14302 ENDIF
14303
14304C...Optionally fix up x and Q2 definitions for leptoproduction.
14305 IDISXQ=0
14306 IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND.
14307 &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1
14308 IF(IDISXQ.EQ.1) THEN
14309
14310C...Find where incoming and outgoing leptons/partons are sitting.
14311 LESD=1
14312 IF(MINT(42).EQ.1) LESD=2
14313 LPIN=MINT(83)+3-LESD
14314 LEIN=MINT(84)+LESD
14315 LQIN=MINT(84)+3-LESD
14316 LEOUT=MINT(84)+2+LESD
14317 LQOUT=MINT(84)+5-LESD
14318 IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3)
14319 IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3)
14320 LSCMS=0
14321 DO 140 I=MINT(84)+5,N
14322 IF(K(I,2).EQ.94) THEN
14323 LSCMS=I
14324 LEOUT=I+LESD
14325 LQOUT=I+3-LESD
14326 ENDIF
14327 140 CONTINUE
14328 LQBG=IPU1
14329 IF(LESD.EQ.1) LQBG=IPU2
14330
14331C...Calculate actual and wanted momentum transfer.
14332 XNOM=VINT(43-LESD)
14333 Q2NOM=-VINT(45)
14334 HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)-
14335 & P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))*
14336 & (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4))
14337 HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK)))
14338 FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2))
14339 P(N+1,1)=FAC*P(LEOUT,1)
14340 P(N+1,2)=FAC*P(LEOUT,2)
14341 P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)-
14342 & Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1)
14343 P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+
14344 & P(N+1,3)**2)
14345 DO 150 J=1,4
14346 QOLD(J)=P(LEIN,J)-P(LEOUT,J)
14347 QNEW(J)=P(LEIN,J)-P(N+1,J)
14348 150 CONTINUE
14349
14350C...Boost outgoing electron and daughters.
14351 IF(LSCMS.EQ.0) THEN
14352 DO 160 J=1,4
14353 P(LEOUT,J)=P(N+1,J)
14354 160 CONTINUE
14355 ELSE
14356 DO 170 J=1,3
14357 P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4))
14358 170 CONTINUE
14359 PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2)
14360 DO 180 J=1,3
14361 DBE(J)=PINV*P(N+2,J)
14362 180 CONTINUE
14363 DO 200 I=LSCMS+1,N
14364 IORIG=I
14365 190 IORIG=K(IORIG,3)
14366 IF(IORIG.GT.LEOUT) GOTO 190
14367 IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT)
14368 & CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3))
14369 200 CONTINUE
14370 ENDIF
14371
14372C...Copy shower initiator and all outgoing partons.
14373 NCOP=N+1
14374 K(NCOP,3)=LQBG
14375 DO 210 J=1,5
14376 P(NCOP,J)=P(LQBG,J)
14377 210 CONTINUE
14378 DO 240 I=MINT(84)+1,N
14379 ICOP=0
14380 IF(K(I,1).GT.10) GOTO 240
14381 IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN
14382 ICOP=I
14383 ELSE
14384 IORIG=I
14385 220 IORIG=K(IORIG,3)
14386 IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN
14387 ICOP=IORIG
14388 ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN
14389 GOTO 220
14390 ENDIF
14391 ENDIF
14392 IF(ICOP.NE.0) THEN
14393 NCOP=NCOP+1
14394 K(NCOP,3)=I
14395 DO 230 J=1,5
14396 P(NCOP,J)=P(I,J)
14397 230 CONTINUE
14398 ENDIF
14399 240 CONTINUE
14400
14401C...Calculate relative rescaling factors.
14402 SLC=3-2*LESD
14403 PLCSUM=0D0
14404 DO 250 I=N+2,NCOP
14405 PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3))
14406 250 CONTINUE
14407 DO 260 I=N+2,NCOP
14408 V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM
14409 260 CONTINUE
14410
14411C...Transfer extra three-momentum of current.
14412 DO 280 I=N+2,NCOP
14413 DO 270 J=1,3
14414 P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J))
14415 270 CONTINUE
14416 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
14417 280 CONTINUE
14418
14419C...Iterate change of initiator momentum to get energy right.
14420 ITER=0
14421 290 ITER=ITER+1
14422 PEEX=-P(N+1,4)-QNEW(4)
14423 PEMV=-P(N+1,3)/P(N+1,4)
14424 DO 300 I=N+2,NCOP
14425 PEEX=PEEX+P(I,4)
14426 PEMV=PEMV+V(I,1)*P(I,3)/P(I,4)
14427 300 CONTINUE
14428 IF(ABS(PEMV).LT.1D-10) THEN
14429 MINT(51)=1
14430 MINT(57)=MINT(57)+1
14431 RETURN
14432 ENDIF
14433 PZCH=-PEEX/PEMV
14434 P(N+1,3)=P(N+1,3)+PZCH
14435 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)
14436 DO 310 I=N+2,NCOP
14437 P(I,3)=P(I,3)+V(I,1)*PZCH
14438 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
14439 310 CONTINUE
14440 IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290
14441
14442C...Modify momenta in event record.
14443 HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/
14444 & ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2)
14445 IF(ABS(HBE).GE.1D0) THEN
14446 MINT(51)=1
14447 MINT(57)=MINT(57)+1
14448 RETURN
14449 ENDIF
14450 I=MINT(83)+5-LESD
14451 CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE)
14452 DO 330 I=N+1,NCOP
14453 ICOP=K(I,3)
14454 DO 320 J=1,4
14455 P(ICOP,J)=P(I,J)
14456 320 CONTINUE
14457 330 CONTINUE
14458 ENDIF
14459
14460C...Check minimum invariant mass of remnant system(s).
14461 PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152))
14462 PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152))
14463 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
14464 PMIN(0)=SQRT(PMS(0))
14465 DO 340 JT=1,2
14466 PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT)
14467 PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1)
14468 PMIN(JT)=0D0
14469 IF(MINT(44+JT).EQ.1) GOTO 340
14470 MINT(105)=MINT(102+JT)
14471 MINT(109)=MINT(106+JT)
14472 CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
14473 IF(MINT(51).NE.0) THEN
14474 MINT(57)=MINT(57)+1
14475 RETURN
14476 ENDIF
14477 IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT))
14478 IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT))
14479 IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111)
14480 PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+
14481 & P(MINT(83)+JT+2,2)**2)
14482 340 CONTINUE
14483 IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND.
14484 &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT.
14485 &PSYS(2,4))) THEN
14486 MINT(51)=1
14487 MINT(57)=MINT(57)+1
14488 RETURN
14489 ENDIF
14490
14491C...Loop over two remnants; skip if none there.
14492 I=NS
14493 DO 410 JT=1,2
14494 ISN(JT)=0
14495 IF(MINT(44+JT).EQ.1) GOTO 410
14496 IF(JT.EQ.1) IPU=IPU1
14497 IF(JT.EQ.2) IPU=IPU2
14498
14499C...Store first remnant parton.
14500 I=I+1
14501 IS(JT)=I
14502 ISN(JT)=1
14503 DO 350 J=1,5
14504 K(I,J)=0
14505 P(I,J)=0D0
14506 V(I,J)=0D0
14507 350 CONTINUE
14508 K(I,1)=1
14509 K(I,2)=KFLSP(JT)
14510 K(I,3)=MINT(83)+JT
14511 P(I,5)=PYMASS(K(I,2))
14512
14513C...First parton colour connections and kinematics.
14514 KCOL=KCHG(PYCOMP(KFLSP(JT)),2)
14515 IF(KCOL.EQ.2) THEN
14516 K(I,1)=3
14517 K(I,4)=MSTU(5)*IPU+IPU
14518 K(I,5)=MSTU(5)*IPU+IPU
14519 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
14520 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
14521 ELSEIF(KCOL.NE.0) THEN
14522 K(I,1)=3
14523 KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2
14524 K(I,KFLS+3)=IPU
14525 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
14526 ENDIF
14527 IF(KFLCH(JT).EQ.0) THEN
14528 P(I,1)=-P(MINT(83)+JT+2,1)
14529 P(I,2)=-P(MINT(83)+JT+2,2)
14530 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
14531 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
14532 P(I,3)=PSYS(JT,3)
14533 P(I,4)=PSYS(JT,4)
14534
14535C...When extra remnant parton or hadron: store extra remnant.
14536 ELSE
14537 I=I+1
14538 ISN(JT)=2
14539 DO 360 J=1,5
14540 K(I,J)=0
14541 P(I,J)=0D0
14542 V(I,J)=0D0
14543 360 CONTINUE
14544 K(I,1)=1
14545 K(I,2)=KFLCH(JT)
14546 K(I,3)=MINT(83)+JT
14547 P(I,5)=PYMASS(K(I,2))
14548
14549C...Find parton colour connections of extra remnant.
14550 KCOL=KCHG(PYCOMP(KFLCH(JT)),2)
14551 IF(KCOL.EQ.2) THEN
14552 K(I,1)=3
14553 K(I,4)=MSTU(5)*IPU+IPU
14554 K(I,5)=MSTU(5)*IPU+IPU
14555 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
14556 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
14557 ELSEIF(KCOL.NE.0) THEN
14558 K(I,1)=3
14559 KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2
14560 K(I,KFLS+3)=IPU
14561 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
14562 ENDIF
14563
14564C...Relative transverse momentum when two remnants.
14565 LOOP=0
14566 370 LOOP=LOOP+1
14567 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
14568 IF(IABS(MINT(10+JT)).LT.20) THEN
14569 P(I-1,1)=0D0
14570 P(I-1,2)=0D0
14571 ELSE
14572 P(I-1,1)=P(I-1,1)-0.5D0*P(MINT(83)+JT+2,1)
14573 P(I-1,2)=P(I-1,2)-0.5D0*P(MINT(83)+JT+2,2)
14574 ENDIF
14575 PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
14576 P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
14577 P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
14578 PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
14579
14580C...Meson or baryon; photon as meson. For splitup below.
14581 IMB=1
14582 IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
14583
14584C***Relative distribution for electron into two electrons. Temporary!
14585 IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT))
14586 & THEN
14587 CHI(JT)=PYR(0)
14588
14589C...Relative distribution of electron energy into electron plus parton.
14590 ELSEIF(IABS(MINT(10+JT)).LT.20) THEN
14591 XHRD=VINT(140+JT)
14592 XE=VINT(154+JT)
14593 CHI(JT)=(XE-XHRD)/(1D0-XHRD)
14594
14595C...Relative distribution of energy for particle into two jets.
14596 ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
14597 CHIK=PARP(92+2*IMB)
14598 IF(MSTP(92).LE.1) THEN
14599 IF(IMB.EQ.1) CHI(JT)=PYR(0)
14600 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
14601 ELSEIF(MSTP(92).EQ.2) THEN
14602 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK))
14603 ELSEIF(MSTP(92).EQ.3) THEN
14604 CUT=2D0*0.3D0/VINT(1)
14605 380 CHI(JT)=PYR(0)**2
14606 IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0*
14607 & (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380
14608 ELSEIF(MSTP(92).EQ.4) THEN
14609 CUT=2D0*0.3D0/VINT(1)
14610 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
14611 390 CHIR=CUT*CUTR**PYR(0)
14612 CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR)
14613 IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390
14614 ELSE
14615 CUT=2D0*0.3D0/VINT(1)
14616 CUTA=CUT**(1D0-PARP(98))
14617 CUTB=(1D0+CUT)**(1D0-PARP(98))
14618 400 CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
14619 IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))**
14620 & (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400
14621 ENDIF
14622
14623C...Relative distribution of energy for particle into jet plus particle.
14624 ELSE
14625 IF(MSTP(94).LE.1) THEN
14626 IF(IMB.EQ.1) CHI(JT)=PYR(0)
14627 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
14628 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
14629 ELSEIF(MSTP(94).EQ.2) THEN
14630 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
14631 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
14632 ELSEIF(MSTP(94).EQ.3) THEN
14633 CALL PYZDIS(1,0,PMS(JT+4),ZZ)
14634 CHI(JT)=ZZ
14635 ELSE
14636 CALL PYZDIS(1000,0,PMS(JT+4),ZZ)
14637 CHI(JT)=ZZ
14638 ENDIF
14639 ENDIF
14640
14641C...Construct total transverse mass; reject if too large.
14642 CHI(JT)=MAX(1D-8,MIN(1D0-1D-8,CHI(JT)))
14643 PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT))
14644 IF(PMS(JT).GT.PSYS(JT,4)**2) THEN
14645 IF(LOOP.LT.100) THEN
14646 GOTO 370
14647 ELSE
14648 MINT(51)=1
14649 MINT(57)=MINT(57)+1
14650 RETURN
14651 ENDIF
14652 ENDIF
14653 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
14654 VINT(158+JT)=CHI(JT)
14655
14656C...Subdivide longitudinal momentum according to value selected above.
14657 PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3)))
14658 P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1)
14659 P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
14660 P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4)
14661 P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3)
14662 ENDIF
14663 410 CONTINUE
14664 N=I
14665
14666C...Check if longitudinal boosts needed - if so pick two systems.
14667 PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+
14668 &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3))
14669 IF(PDEV.LE.1D-6*VINT(1)) RETURN
14670 IF(ISN(1).EQ.0) THEN
14671 IR=0
14672 IL=2
14673 ELSEIF(ISN(2).EQ.0) THEN
14674 IR=1
14675 IL=0
14676 ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN
14677 IR=1
14678 IL=2
14679 ELSEIF(VINT(143).GT.0.2D0) THEN
14680 IR=1
14681 IL=0
14682 ELSEIF(VINT(144).GT.0.2D0) THEN
14683 IR=0
14684 IL=2
14685 ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN
14686 IR=1
14687 IL=0
14688 ELSE
14689 IR=0
14690 IL=2
14691 ENDIF
14692 IG=3-IR-IL
14693
14694C...E+-pL wanted for system to be modified.
14695 IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN
14696 PPB=VINT(1)
14697 PNB=VINT(1)
14698 ELSE
14699 PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3))
14700 PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3))
14701 ENDIF
14702
14703C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
14704 IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN
14705 PPB=PPB-(PSYS(0,4)+PSYS(0,3))
14706 PNB=PNB-(PSYS(0,4)-PSYS(0,3))
14707 DO 420 J=1,4
14708 PSYS(0,J)=0D0
14709 420 CONTINUE
14710 DO 450 I=MINT(84)+1,NS
14711 IF(K(I,1).GT.10) GOTO 450
14712 INCL=0
14713 IORIG=I
14714 430 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
14715 IORIG=K(IORIG,3)
14716 IF(IORIG.GT.LPIN) GOTO 430
14717 IF(INCL.EQ.0) GOTO 450
14718 DO 440 J=1,4
14719 PSYS(0,J)=PSYS(0,J)+P(I,J)
14720 440 CONTINUE
14721 450 CONTINUE
14722 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
14723 PPB=PPB+(PSYS(0,4)+PSYS(0,3))
14724 PNB=PNB+(PSYS(0,4)-PSYS(0,3))
14725 ENDIF
14726
14727C...Construct longitudinal boosts.
14728 DPMTB=PPB*PNB
14729 DPMTR=PMS(IR)
14730 DPMTL=PMS(IL)
14731 DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL))
14732 IF(DSQLAM.LE.1D-6*DPMTB) THEN
14733 MINT(51)=1
14734 MINT(57)=MINT(57)+1
14735 RETURN
14736 ENDIF
14737 DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
14738 DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/
14739 &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB)
14740 DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/
14741 &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB)
14742 DBER=(DRKR**2-1D0)/(DRKR**2+1D0)
14743 DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0)
14744
14745C...Perform longitudinal boosts.
14746 IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN
14747 P(IS(1),3)=0D0
14748 P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2)
14749 ELSEIF(IR.EQ.1) THEN
14750 CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER)
14751 ELSEIF(IDISXQ.EQ.1) THEN
14752 DO 470 I=I1,NS
14753 INCL=0
14754 IORIG=I
14755 460 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
14756 IORIG=K(IORIG,3)
14757 IF(IORIG.GT.LPIN) GOTO 460
14758 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER)
14759 470 CONTINUE
14760 ELSE
14761 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER)
14762 ENDIF
14763 IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN
14764 P(IS(2),3)=0D0
14765 P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2)
14766 ELSEIF(IL.EQ.2) THEN
14767 CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL)
14768 ELSEIF(IDISXQ.EQ.1) THEN
14769 DO 490 I=I1,NS
14770 INCL=0
14771 IORIG=I
14772 480 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
14773 IORIG=K(IORIG,3)
14774 IF(IORIG.GT.LPIN) GOTO 480
14775 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL)
14776 490 CONTINUE
14777 ELSE
14778 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL)
14779 ENDIF
14780
14781C...Final check that energy-momentum conservation worked.
14782 PESUM=0D0
14783 PZSUM=0D0
14784 DO 500 I=MINT(84)+1,N
14785 IF(K(I,1).GT.10) GOTO 500
14786 PESUM=PESUM+P(I,4)
14787 PZSUM=PZSUM+P(I,3)
14788 500 CONTINUE
14789 PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM)
14790 IF(PDEV.GT.1D-4*VINT(1)) THEN
14791 MINT(51)=1
14792 MINT(57)=MINT(57)+1
14793 RETURN
14794 ENDIF
14795
14796C...Calculate rotation and boost from overall CM frame to
14797C...hadronic CM frame in leptoproduction.
14798 MINT(91)=0
14799 IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
14800 MINT(91)=1
14801 LESD=1
14802 IF(MINT(42).EQ.1) LESD=2
14803 LPIN=MINT(83)+3-LESD
14804
14805C...Sum upp momenta of everything not lepton or photon to define boost.
14806 DO 510 J=1,4
14807 PSUM(J)=0D0
14808 510 CONTINUE
14809 DO 530 I=1,N
14810 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
14811 IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
14812 IF(K(I,2).EQ.22) GOTO 530
14813 DO 520 J=1,4
14814 PSUM(J)=PSUM(J)+P(I,J)
14815 520 CONTINUE
14816 530 CONTINUE
14817 VINT(223)=-PSUM(1)/PSUM(4)
14818 VINT(224)=-PSUM(2)/PSUM(4)
14819 VINT(225)=-PSUM(3)/PSUM(4)
14820
14821C...Boost incoming hadron to hadronic CM frame to determine rotations.
14822 K(N+1,1)=1
14823 DO 540 J=1,5
14824 P(N+1,J)=P(LPIN,J)
14825 V(N+1,J)=V(LPIN,J)
14826 540 CONTINUE
14827 CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
14828 VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
14829 CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
14830 IF(LESD.EQ.2) THEN
14831 VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
14832 ELSE
14833 VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
14834 ENDIF
14835 ENDIF
14836
14837 RETURN
14838 END
14839
14840C*********************************************************************
14841
14842C...PYDIFF
14843C...Handles diffractive and elastic scattering.
14844
14845 SUBROUTINE PYDIFF
14846
14847C...Double precision and integer declarations.
14848 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14849 IMPLICIT INTEGER(I-N)
14850 INTEGER PYK,PYCHGE,PYCOMP
14851C...Commonblocks.
14852 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14853 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14854 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14855 COMMON/PYINT1/MINT(400),VINT(400)
14856 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
14857
14858C...Reset K, P and V vectors. Store incoming particles.
14859 DO 110 JT=1,MSTP(126)+10
14860 I=MINT(83)+JT
14861 DO 100 J=1,5
14862 K(I,J)=0
14863 P(I,J)=0D0
14864 V(I,J)=0D0
14865 100 CONTINUE
14866 110 CONTINUE
14867 N=MINT(84)
14868 MINT(3)=0
14869 MINT(21)=0
14870 MINT(22)=0
14871 MINT(23)=0
14872 MINT(24)=0
14873 MINT(4)=4
14874 DO 130 JT=1,2
14875 I=MINT(83)+JT
14876 K(I,1)=21
14877 K(I,2)=MINT(10+JT)
14878 DO 120 J=1,5
14879 P(I,J)=VINT(285+5*JT+J)
14880 120 CONTINUE
14881 130 CONTINUE
14882 MINT(6)=2
14883
14884C...Subprocess; kinematics.
14885 SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64)
14886 PZ=SQRT(SQLAM)/(2D0*VINT(1))
14887 DO 200 JT=1,2
14888 I=MINT(83)+JT
14889 PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1))
14890 KFH=MINT(102+JT)
14891
14892C...Elastically scattered particle. (Except elastic GVMD states.)
14893 IF(MINT(16+JT).LE.0.AND.(MINT(10+JT).NE.22.OR.
14894 & MINT(106+JT).NE.3)) THEN
14895 N=N+1
14896 K(N,1)=1
14897 K(N,2)=KFH
14898 K(N,3)=I+2
14899 P(N,3)=PZ*(-1)**(JT+1)
14900 P(N,4)=PE
14901 P(N,5)=SQRT(VINT(62+JT))
14902
14903C...Decay rho from elastic scattering of gamma with sin**2(theta)
14904C...distribution of decay products (in rho rest frame).
14905 IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN
14906 NSAV=N
14907 DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2)
14908 P(N,3)=0D0
14909 P(N,4)=P(N,5)
14910 CALL PYDECY(NSAV)
14911 IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN
14912 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
14913 CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0)
14914 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
14915 CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0)
14916 140 CTHE=2D0*PYR(0)-1D0
14917 IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140
14918 CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0)
14919 ENDIF
14920 CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ)
14921 ENDIF
14922
14923C...Diffracted particle: low-mass system to two particles.
14924 ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN
14925 N=N+2
14926 K(N-1,1)=1
14927 K(N,1)=1
14928 K(N-1,3)=I+2
14929 K(N,3)=I+2
14930 PMMAS=SQRT(VINT(62+JT))
14931 NTRY=0
14932 150 NTRY=NTRY+1
14933 IF(NTRY.LT.20) THEN
14934 MINT(105)=MINT(102+JT)
14935 MINT(109)=MINT(106+JT)
14936 CALL PYSPLI(KFH,21,KFL1,KFL2)
14937 CALL PYKFDI(KFL1,0,KFL3,KF1)
14938 IF(KF1.EQ.0) GOTO 150
14939 CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2)
14940 IF(KF2.EQ.0) GOTO 150
14941 ELSE
14942 KF1=KFH
14943 KF2=111
14944 ENDIF
14945 PM1=PYMASS(KF1)
14946 PM2=PYMASS(KF2)
14947 IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150
14948 K(N-1,2)=KF1
14949 K(N,2)=KF2
14950 P(N-1,5)=PM1
14951 P(N,5)=PM2
14952 PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2-
14953 & 4D0*PM1**2*PM2**2))/(2D0*PMMAS)
14954 P(N-1,3)=PZP
14955 P(N,3)=-PZP
14956 P(N-1,4)=SQRT(PM1**2+PZP**2)
14957 P(N,4)=SQRT(PM2**2+PZP**2)
14958 CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0),
14959 & 0D0,0D0,0D0)
14960 DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2)
14961 CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ)
14962
14963C...Diffracted particle: valence quark kicked out.
14964 ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT.
14965 & PARP(101))) THEN
14966 N=N+2
14967 K(N-1,1)=2
14968 K(N,1)=1
14969 K(N-1,3)=I+2
14970 K(N,3)=I+2
14971 MINT(105)=MINT(102+JT)
14972 MINT(109)=MINT(106+JT)
14973 CALL PYSPLI(KFH,21,K(N,2),K(N-1,2))
14974 P(N-1,5)=PYMASS(K(N-1,2))
14975 P(N,5)=PYMASS(K(N,2))
14976 SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
14977 & 4D0*P(N-1,5)**2*P(N,5)**2
14978 P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
14979 & P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1)
14980 P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
14981 P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
14982 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
14983
14984C...Diffracted particle: gluon kicked out.
14985 ELSE
14986 N=N+3
14987 K(N-2,1)=2
14988 K(N-1,1)=2
14989 K(N,1)=1
14990 K(N-2,3)=I+2
14991 K(N-1,3)=I+2
14992 K(N,3)=I+2
14993 MINT(105)=MINT(102+JT)
14994 MINT(109)=MINT(106+JT)
14995 CALL PYSPLI(KFH,21,K(N,2),K(N-2,2))
14996 K(N-1,2)=21
14997 P(N-2,5)=PYMASS(K(N-2,2))
14998 P(N-1,5)=0D0
14999 P(N,5)=PYMASS(K(N,2))
15000C...Energy distribution for particle into two jets.
15001 160 IMB=1
15002 IF(MOD(KFH/1000,10).NE.0) IMB=2
15003 CHIK=PARP(92+2*IMB)
15004 IF(MSTP(92).LE.1) THEN
15005 IF(IMB.EQ.1) CHI=PYR(0)
15006 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
15007 ELSEIF(MSTP(92).EQ.2) THEN
15008 CHI=1D0-PYR(0)**(1D0/(1D0+CHIK))
15009 ELSEIF(MSTP(92).EQ.3) THEN
15010 CUT=2D0*0.3D0/VINT(1)
15011 170 CHI=PYR(0)**2
15012 IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT.
15013 & PYR(0)) GOTO 170
15014 ELSEIF(MSTP(92).EQ.4) THEN
15015 CUT=2D0*0.3D0/VINT(1)
15016 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
15017 180 CHIR=CUT*CUTR**PYR(0)
15018 CHI=(CHIR**2-CUT**2)/(2D0*CHIR)
15019 IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180
15020 ELSE
15021 CUT=2D0*0.3D0/VINT(1)
15022 CUTA=CUT**(1D0-PARP(98))
15023 CUTB=(1D0+CUT)**(1D0-PARP(98))
15024 190 CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
15025 IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))**
15026 & (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
15027 ENDIF
15028 IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/
15029 & VINT(62+JT)) GOTO 160
15030 SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI
15031 PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
15032 & (2D0*VINT(62+JT))
15033 PEI=SQRT(PZI**2+SQM)
15034 PQQP=(1D0-CHI)*(PEI+PZI)
15035 P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
15036 P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
15037 P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
15038 P(N-1,3)=P(N-1,4)*(-1)**JT
15039 P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
15040 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
15041 ENDIF
15042
15043C...Documentation lines.
15044 K(I+2,1)=21
15045 IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
15046 IF(MINT(16+JT).NE.0.OR.(MINT(10+JT).EQ.22.AND.
15047 & MINT(106+JT).EQ.3)) K(I+2,2)=ISIGN(9900000,KFH)+10*(KFH/10)
15048 K(I+2,3)=I
15049 P(I+2,3)=PZ*(-1)**(JT+1)
15050 P(I+2,4)=PE
15051 P(I+2,5)=SQRT(VINT(62+JT))
15052 200 CONTINUE
15053
15054C...Rotate outgoing partons/particles using cos(theta).
15055 IF(VINT(23).LT.0.9D0) THEN
15056 CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
15057 ELSE
15058 CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
15059 ENDIF
15060
15061 RETURN
15062 END
15063
15064C*********************************************************************
15065
15066C...PYDISG
15067C...Set up a DIS process as gamma* + f -> f, with beam remnant
15068C...and showering added consecutively. Photon flux by the PYGAGA
15069C...routine (if at all).
15070
15071 SUBROUTINE PYDISG
15072
15073C...Double precision and integer declarations.
15074 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15075 IMPLICIT INTEGER(I-N)
15076 INTEGER PYK,PYCHGE,PYCOMP
15077C...Parameter statement to help give large particle numbers.
15078 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
15079 &KEXCIT=4000000,KDIMEN=5000000)
15080C...Commonblocks.
15081 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15082 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15083 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15084 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
15085 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15086 COMMON/PYINT1/MINT(400),VINT(400)
15087 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
15088C...Local arrays.
15089 DIMENSION PMS(4)
15090
15091C...Choice of subprocess, number of documentation lines
15092 IDOC=7
15093 MINT(3)=IDOC-6
15094 MINT(4)=IDOC
15095 IPU1=MINT(84)+1
15096 IPU2=MINT(84)+2
15097 IPU3=MINT(84)+3
15098 ISIDE=1
15099 IF(MINT(107).EQ.4) ISIDE=2
15100
15101C...Reset K, P and V vectors. Store incoming particles
15102 DO 110 JT=1,MSTP(126)+20
15103 I=MINT(83)+JT
15104 DO 100 J=1,5
15105 K(I,J)=0
15106 P(I,J)=0D0
15107 V(I,J)=0D0
15108 100 CONTINUE
15109 110 CONTINUE
15110 DO 130 JT=1,2
15111 I=MINT(83)+JT
15112 K(I,1)=21
15113 K(I,2)=MINT(10+JT)
15114 DO 120 J=1,5
15115 P(I,J)=VINT(285+5*JT+J)
15116 120 CONTINUE
15117 130 CONTINUE
15118 MINT(6)=2
15119
15120C...Store incoming partons in hadronic CM-frame
15121 DO 140 JT=1,2
15122 I=MINT(84)+JT
15123 K(I,1)=14
15124 K(I,2)=MINT(14+JT)
15125 K(I,3)=MINT(83)+2+JT
15126 140 CONTINUE
15127 IF(MINT(15).EQ.22) THEN
15128 P(MINT(84)+1,3)=0.5D0*(VINT(1)+VINT(307)/VINT(1))
15129 P(MINT(84)+1,4)=0.5D0*(VINT(1)-VINT(307)/VINT(1))
15130 P(MINT(84)+1,5)=-SQRT(VINT(307))
15131 P(MINT(84)+2,3)=-0.5D0*VINT(307)/VINT(1)
15132 P(MINT(84)+2,4)=0.5D0*VINT(307)/VINT(1)
15133 KFRES=MINT(16)
15134 ISIDE=2
15135 ELSE
15136 P(MINT(84)+1,3)=0.5D0*VINT(308)/VINT(1)
15137 P(MINT(84)+1,4)=0.5D0*VINT(308)/VINT(1)
15138 P(MINT(84)+2,3)=-0.5D0*(VINT(1)+VINT(308)/VINT(1))
15139 P(MINT(84)+2,4)=0.5D0*(VINT(1)-VINT(308)/VINT(1))
15140 P(MINT(84)+1,5)=-SQRT(VINT(308))
15141 KFRES=MINT(15)
15142 ISIDE=1
15143 ENDIF
15144 SIDESG=(-1D0)**(ISIDE-1)
15145
15146C...Copy incoming partons to documentation lines.
15147 DO 170 JT=1,2
15148 I1=MINT(83)+4+JT
15149 I2=MINT(84)+JT
15150 K(I1,1)=21
15151 K(I1,2)=K(I2,2)
15152 K(I1,3)=I1-2
15153 DO 150 J=1,5
15154 P(I1,J)=P(I2,J)
15155 150 CONTINUE
15156
15157C...Second copy for partons before ISR shower, since no such.
15158 I1=MINT(83)+2+JT
15159 K(I1,1)=21
15160 K(I1,2)=K(I2,2)
15161 K(I1,3)=I1-2
15162 DO 160 J=1,5
15163 P(I1,J)=P(I2,J)
15164 160 CONTINUE
15165 170 CONTINUE
15166
15167C...Define initial partons.
15168 NTRY=0
15169 180 NTRY=NTRY+1
15170 IF(NTRY.GT.100) THEN
15171 MINT(51)=1
15172 RETURN
15173 ENDIF
15174
15175C...Scattered quark in hadronic CM frame.
15176 I=MINT(83)+7
15177 K(IPU3,1)=3
15178 K(IPU3,2)=KFRES
15179 K(IPU3,3)=I
15180 P(IPU3,5)=PYMASS(KFRES)
15181 P(IPU3,3)=P(IPU1,3)+P(IPU2,3)
15182 P(IPU3,4)=P(IPU1,4)+P(IPU2,4)
15183 P(IPU3,5)=0D0
15184 K(I,1)=21
15185 K(I,2)=KFRES
15186 K(I,3)=MINT(83)+4+ISIDE
15187 P(I,3)=P(IPU3,3)
15188 P(I,4)=P(IPU3,4)
15189 P(I,5)=P(IPU3,5)
15190 N=IPU3
15191 MINT(21)=KFRES
15192 MINT(22)=0
15193
15194C...No primordial kT, or chosen according to truncated Gaussian or
15195C...exponential, or (for photon) predetermined or power law.
15196 190 IF(MINT(40+ISIDE).EQ.2.AND.MINT(10+ISIDE).NE.22) THEN
15197 IF(MSTP(91).LE.0) THEN
15198 PT=0D0
15199 ELSEIF(MSTP(91).EQ.1) THEN
15200 PT=PARP(91)*SQRT(-LOG(PYR(0)))
15201 ELSE
15202 RPT1=PYR(0)
15203 RPT2=PYR(0)
15204 PT=-PARP(92)*LOG(RPT1*RPT2)
15205 ENDIF
15206 IF(PT.GT.PARP(93)) GOTO 190
15207 ELSEIF(MINT(106+ISIDE).EQ.3) THEN
15208 PTA=SQRT(VINT(282+ISIDE))
15209 PTB=0D0
15210 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
15211 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
15212 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
15213 RPT1=PYR(0)
15214 RPT2=PYR(0)
15215 PTB=-PARP(99)*LOG(RPT1*RPT2)
15216 ENDIF
15217 IF(PTB.GT.PARP(100)) GOTO 190
15218 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
15219 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
15220 ELSEIF(IABS(MINT(14+ISIDE)).LE.8.OR.MINT(14+ISIDE).EQ.21) THEN
15221 IF(MSTP(93).LE.0) THEN
15222 PT=0D0
15223 ELSEIF(MSTP(93).EQ.1) THEN
15224 PT=PARP(99)*SQRT(-LOG(PYR(0)))
15225 ELSEIF(MSTP(93).EQ.2) THEN
15226 RPT1=PYR(0)
15227 RPT2=PYR(0)
15228 PT=-PARP(99)*LOG(RPT1*RPT2)
15229 ELSEIF(MSTP(93).EQ.3) THEN
15230 HA=PARP(99)**2
15231 HB=PARP(100)**2
15232 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
15233 ELSE
15234 HA=PARP(99)**2
15235 HB=PARP(100)**2
15236 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
15237 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
15238 ENDIF
15239 IF(PT.GT.PARP(100)) GOTO 190
15240 ELSE
15241 PT=0D0
15242 ENDIF
15243 VINT(156+ISIDE)=PT
15244 PHI=PARU(2)*PYR(0)
15245 P(IPU3,1)=PT*COS(PHI)
15246 P(IPU3,2)=PT*SIN(PHI)
15247 P(IPU3,4)=SQRT(P(IPU3,5)**2+PT**2+P(IPU3,3)**2)
15248 PMS(3-ISIDE)=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
15249 PCP=P(IPU3,4)+ABS(P(IPU3,3))
15250
15251C...Find one or two beam remnants.
15252 MINT(105)=MINT(102+ISIDE)
15253 MINT(109)=MINT(106+ISIDE)
15254 CALL PYSPLI(MINT(10+ISIDE),MINT(12+ISIDE),KFLCH,KFLSP)
15255 IF(MINT(51).NE.0) THEN
15256 MINT(51)=0
15257 GOTO 180
15258 ENDIF
15259
15260C...Store first remnant parton, with colour info and kinematics.
15261 I=N+1
15262 K(I,1)=1
15263 K(I,2)=KFLSP
15264 K(I,3)=MINT(83)+ISIDE
15265 P(I,5)=PYMASS(K(I,2))
15266 KCOL=KCHG(PYCOMP(KFLSP),2)
15267 IF(KCOL.NE.0) THEN
15268 K(I,1)=3
15269 KFLS=(3-KCOL*ISIGN(1,KFLSP))/2
15270 K(I,KFLS+3)=MSTU(5)*IPU3
15271 K(IPU3,6-KFLS)=MSTU(5)*I
15272 ICOLR=I
15273 ENDIF
15274 IF(KFLCH.EQ.0) THEN
15275 P(I,1)=-P(IPU3,1)
15276 P(I,2)=-P(IPU3,2)
15277 PMS(ISIDE)=P(I,5)**2+P(I,1)**2+P(I,2)**2
15278 P(I,3)=-P(IPU3,3)
15279 P(I,4)=SQRT(PMS(ISIDE)+P(I,3)**2)
15280 PRP=P(I,4)+ABS(P(I,3))
15281
15282C...When extra remnant parton or hadron: store extra remnant.
15283 ELSE
15284 I=I+1
15285 K(I,1)=1
15286 K(I,2)=KFLCH
15287 K(I,3)=MINT(83)+ISIDE
15288 P(I,5)=PYMASS(K(I,2))
15289 KCOL=KCHG(PYCOMP(KFLCH),2)
15290 IF(KCOL.NE.0) THEN
15291 K(I,1)=3
15292 KFLS=(3-KCOL*ISIGN(1,KFLCH))/2
15293 K(I,KFLS+3)=MSTU(5)*IPU3
15294 K(IPU3,6-KFLS)=MSTU(5)*I
15295 ICOLR=I
15296 ENDIF
15297
15298C...Relative transverse momentum when two remnants.
15299 LOOP=0
15300 200 LOOP=LOOP+1
15301 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
15302 P(I-1,1)=P(I-1,1)-0.5D0*P(IPU3,1)
15303 P(I-1,2)=P(I-1,2)-0.5D0*P(IPU3,2)
15304 PMS(3)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
15305 P(I,1)=-P(IPU3,1)-P(I-1,1)
15306 P(I,2)=-P(IPU3,2)-P(I-1,2)
15307 PMS(4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
15308
15309C...Relative distribution of energy for particle into jet plus particle.
15310 IMB=1
15311 IF(MOD(MINT(10+ISIDE)/1000,10).NE.0) IMB=2
15312 IF(MSTP(94).LE.1) THEN
15313 IF(IMB.EQ.1) CHI=PYR(0)
15314 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
15315 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
15316 ELSEIF(MSTP(94).EQ.2) THEN
15317 CHI=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
15318 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
15319 ELSEIF(MSTP(94).EQ.3) THEN
15320 CALL PYZDIS(1,0,PMS(4),ZZ)
15321 CHI=ZZ
15322 ELSE
15323 CALL PYZDIS(1000,0,PMS(4),ZZ)
15324 CHI=ZZ
15325 ENDIF
15326
15327C...Construct total transverse mass; reject if too large.
15328 CHI=MAX(1D-8,MIN(1D0-1D-8,CHI))
15329 PMS(ISIDE)=PMS(4)/CHI+PMS(3)/(1D0-CHI)
15330 IF(PMS(ISIDE).GT.P(IPU3,4)**2) THEN
15331 IF(LOOP.LT.10) GOTO 200
15332 GOTO 180
15333 ENDIF
15334 VINT(158+ISIDE)=CHI
15335
15336C...Subdivide longitudinal momentum according to value selected above.
15337 PRP=SQRT(PMS(ISIDE)+P(IPU3,3)**2)+ABS(P(IPU3,3))
15338 PW1=(1D0-CHI)*PRP
15339 P(I-1,4)=0.5D0*(PW1+PMS(3)/PW1)
15340 P(I-1,3)=0.5D0*(PW1-PMS(3)/PW1)*SIDESG
15341 PW2=CHI*PRP
15342 P(I,4)=0.5D0*(PW2+PMS(4)/PW2)
15343 P(I,3)=0.5D0*(PW2-PMS(4)/PW2)*SIDESG
15344 ENDIF
15345 N=I
15346
15347C...Boost current and remnant systems to correct frame.
15348 IF(SQRT(PMS(1))+SQRT(PMS(2)).GT.0.99D0*VINT(1)) GOTO 180
15349 DSQLAM=SQRT(MAX(0D0,(VINT(2)-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2)))
15350 DRKC=(VINT(2)+PMS(3-ISIDE)-PMS(ISIDE)+DSQLAM)/
15351 &(2D0*VINT(1)*PCP)
15352 DRKR=(VINT(2)+PMS(ISIDE)-PMS(3-ISIDE)+DSQLAM)/
15353 &(2D0*VINT(1)*PRP)
15354 DBEC=-SIDESG*(DRKC**2-1D0)/(DRKC**2+1D0)
15355 DBER=SIDESG*(DRKR**2-1D0)/(DRKR**2+1D0)
15356 CALL PYROBO(IPU3,IPU3,0D0,0D0,0D0,0D0,DBEC)
15357 CALL PYROBO(IPU3+1,N,0D0,0D0,0D0,0D0,DBER)
15358
15359C...Let current quark shower; recoil but no showering by colour partner.
15360 QMAX=2D0*SQRT(VINT(309-ISIDE))
15361 MSTJ48=MSTJ(48)
15362 MSTJ(48)=1
15363 PARJ86=PARJ(86)
15364 PARJ(86)=0D0
15365 IF(MSTP(71).EQ.1) CALL PYSHOW(IPU3,ICOLR,QMAX)
15366 MSTJ(48)=MSTJ48
15367 PARJ(86)=PARJ86
15368
15369 RETURN
15370 END
15371
15372C*********************************************************************
15373
15374C...PYDOCU
15375C...Handles the documentation of the process in MSTI and PARI,
15376C...and also computes cross-sections based on accumulated statistics.
15377
15378 SUBROUTINE PYDOCU
15379
15380C...Double precision and integer declarations.
15381 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15382 IMPLICIT INTEGER(I-N)
15383 INTEGER PYK,PYCHGE,PYCOMP
15384C...Commonblocks.
15385 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15386 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15387 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15388 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
15389 COMMON/PYINT1/MINT(400),VINT(400)
15390 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15391 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
15392 SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
15393 &/PYINT5/
15394
15395C...Calculate Monte Carlo estimates of cross-sections.
15396 ISUB=MINT(1)
15397 IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
15398 NGEN(0,3)=NGEN(0,3)+1
15399 XSEC(0,3)=0D0
15400 DO 100 I=1,500
15401 IF(I.EQ.96.OR.I.EQ.97) THEN
15402 XSEC(I,3)=0D0
15403 ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
15404 & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
15405 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
15406 & DBLE(NGEN(96,2)))
15407 ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
15408 XSEC(I,3)=0D0
15409 ELSEIF(NGEN(I,2).EQ.0) THEN
15410 XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))*
15411 & DBLE(NGEN(0,2)))
15412 ELSE
15413 XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))*
15414 & DBLE(NGEN(I,2)))
15415 ENDIF
15416 XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
15417 100 CONTINUE
15418
15419C...Rescale to known low-pT cross-section for standard QCD processes.
15420 IF(MSUB(95).EQ.1) THEN
15421 XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
15422 & XSEC(68,3)+XSEC(95,3)
15423 XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
15424 IF(XSECH.GT.1D-20.AND.XSECW.GT.1D-20) THEN
15425 FAC=XSECW/XSECH
15426 XSEC(11,3)=FAC*XSEC(11,3)
15427 XSEC(12,3)=FAC*XSEC(12,3)
15428 XSEC(13,3)=FAC*XSEC(13,3)
15429 XSEC(28,3)=FAC*XSEC(28,3)
15430 XSEC(53,3)=FAC*XSEC(53,3)
15431 XSEC(68,3)=FAC*XSEC(68,3)
15432 XSEC(95,3)=FAC*XSEC(95,3)
15433 XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
15434 ENDIF
15435 ENDIF
15436
15437C...Save information for gamma-p and gamma-gamma.
15438 IF(MINT(121).GT.1) THEN
15439 IGA=MINT(122)
15440 CALL PYSAVE(2,IGA)
15441 CALL PYSAVE(5,0)
15442 ENDIF
15443
15444C...Reset information on hard interaction.
15445 DO 110 J=1,200
15446 MSTI(J)=0
15447 PARI(J)=0D0
15448 110 CONTINUE
15449
15450C...Copy integer valued information from MINT into MSTI.
15451 DO 120 J=1,32
15452 MSTI(J)=MINT(J)
15453 120 CONTINUE
15454 IF(MINT(121).GT.1) MSTI(9)=MINT(122)
15455
15456C...Store cross-section variables in PARI.
15457 PARI(1)=XSEC(0,3)
15458 PARI(2)=XSEC(0,3)/MINT(5)
15459 PARI(7)=VINT(97)
15460 PARI(9)=VINT(99)
15461 PARI(10)=VINT(100)
15462 VINT(98)=VINT(98)+VINT(100)
15463 IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
15464
15465C...Store kinematics variables in PARI.
15466 PARI(11)=VINT(1)
15467 PARI(12)=VINT(2)
15468 IF(ISUB.NE.95) THEN
15469 DO 130 J=13,26
15470 PARI(J)=VINT(30+J)
15471 130 CONTINUE
15472 PARI(31)=VINT(141)
15473 PARI(32)=VINT(142)
15474 PARI(33)=VINT(41)
15475 PARI(34)=VINT(42)
15476 PARI(35)=PARI(33)-PARI(34)
15477 PARI(36)=VINT(21)
15478 PARI(37)=VINT(22)
15479 PARI(38)=VINT(26)
15480 PARI(39)=VINT(157)
15481 PARI(40)=VINT(158)
15482 PARI(41)=VINT(23)
15483 PARI(42)=2D0*VINT(47)/VINT(1)
15484 ENDIF
15485
15486C...Store information on scattered partons in PARI.
15487 IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
15488 DO 140 IS=7,8
15489 I=MINT(IS)
15490 PARI(36+IS)=P(I,3)/VINT(1)
15491 PARI(38+IS)=P(I,4)/VINT(1)
15492 PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
15493 PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
15494 & SQRT(PR),1D20)),P(I,3))
15495 PR=MAX(1D-20,P(I,1)**2+P(I,2)**2)
15496 PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
15497 & SQRT(PR),1D20)),P(I,3))
15498 PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2)
15499 PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
15500 PARI(48+IS)=PYANGL(P(I,1),P(I,2))
15501 140 CONTINUE
15502 ENDIF
15503
15504C...Store sum up transverse and longitudinal momenta.
15505 PARI(65)=2D0*PARI(17)
15506 IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
15507 DO 150 I=MSTP(126)+1,N
15508 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
15509 PT=SQRT(P(I,1)**2+P(I,2)**2)
15510 PARI(69)=PARI(69)+PT
15511 IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
15512 IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
15513 150 CONTINUE
15514 PARI(67)=PARI(68)
15515 PARI(71)=VINT(151)
15516 PARI(72)=VINT(152)
15517 PARI(73)=VINT(151)
15518 PARI(74)=VINT(152)
15519 ELSE
15520 PARI(66)=PARI(65)
15521 PARI(69)=PARI(65)
15522 ENDIF
15523
15524C...Store various other pieces of information into PARI.
15525 PARI(61)=VINT(148)
15526 PARI(75)=VINT(155)
15527 PARI(76)=VINT(156)
15528 PARI(77)=VINT(159)
15529 PARI(78)=VINT(160)
15530 PARI(81)=VINT(138)
15531
15532C...Store information on lepton -> lepton + gamma in PYGAGA.
15533 MSTI(71)=MINT(141)
15534 MSTI(72)=MINT(142)
15535 PARI(101)=VINT(301)
15536 PARI(102)=VINT(302)
15537 DO 160 I=103,114
15538 PARI(I)=VINT(I+202)
15539 160 CONTINUE
15540
15541C...Set information for PYTABU.
15542 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
15543 MSTU(161)=MINT(21)
15544 MSTU(162)=0
15545 ELSEIF(ISET(ISUB).EQ.5) THEN
15546 MSTU(161)=MINT(23)
15547 MSTU(162)=0
15548 ELSE
15549 MSTU(161)=MINT(21)
15550 MSTU(162)=MINT(22)
15551 ENDIF
15552
15553 RETURN
15554 END
15555
15556C*********************************************************************
15557
15558C...PYFRAM
15559C...Performs transformations between different coordinate frames.
15560
15561 SUBROUTINE PYFRAM(IFRAME)
15562
15563C...Double precision and integer declarations.
15564 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15565 IMPLICIT INTEGER(I-N)
15566 INTEGER PYK,PYCHGE,PYCOMP
15567C...Commonblocks.
15568 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15569 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15570 COMMON/PYINT1/MINT(400),VINT(400)
15571 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
15572
15573C...Check that transformation can and should be done.
15574 IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
15575 &MINT(91).EQ.1)) THEN
15576 IF(IFRAME.EQ.MINT(6)) RETURN
15577 ELSE
15578 WRITE(MSTU(11),5000) IFRAME,MINT(6)
15579 RETURN
15580 ENDIF
15581
15582 IF(MINT(6).EQ.1) THEN
15583C...Transform from fixed target or user specified frame to
15584C...overall CM frame.
15585 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
15586 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
15587 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
15588 ELSEIF(MINT(6).EQ.3) THEN
15589C...Transform from hadronic CM frame in DIS to overall CM frame.
15590 CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
15591 & -VINT(225))
15592 ENDIF
15593
15594 IF(IFRAME.EQ.1) THEN
15595C...Transform from overall CM frame to fixed target or user specified
15596C...frame.
15597 CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
15598 ELSEIF(IFRAME.EQ.3) THEN
15599C...Transform from overall CM frame to hadronic CM frame in DIS.
15600 CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
15601 CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
15602 CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
15603 ENDIF
15604
15605C...Set information about new frame.
15606 MINT(6)=IFRAME
15607 MSTI(6)=IFRAME
15608
15609 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
15610 &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
15611 &1X,I5)
15612
15613 RETURN
15614 END
15615
15616C*********************************************************************
15617
15618C...PYWIDT
15619C...Calculates full and partial widths of resonances.
15620
15621 SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
15622
15623C...Double precision and integer declarations.
15624 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15625 IMPLICIT INTEGER(I-N)
15626 INTEGER PYK,PYCHGE,PYCOMP
15627C...Parameter statement to help give large particle numbers.
15628 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
15629 &KEXCIT=4000000,KDIMEN=5000000)
15630C...Commonblocks.
15631 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15632 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15633 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15634 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
15635 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15636 COMMON/PYINT1/MINT(400),VINT(400)
15637 COMMON/PYINT4/MWID(500),WIDS(500,5)
15638 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
15639 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
15640 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
15641 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
15642 &/PYINT4/,/PYMSSM/,/PYSSMT/
15643C...Local arrays and saved variables.
15644 COMPLEX*16 ZMIXC(4,4),AL,BL,AR,BR,FL,FR
15645 DIMENSION WDTP(0:300),WDTE(0:300,0:5),MOFSV(3,2),WIDWSV(3,2),
15646 &WID2SV(3,2),WDTPP(0:300),WDTEP(0:300,0:5)
15647 SAVE MOFSV,WIDWSV,WID2SV
15648 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
15649
15650C...Compressed code and sign; mass.
15651 KFLA=IABS(KFLR)
15652 KFLS=ISIGN(1,KFLR)
15653 KC=PYCOMP(KFLA)
15654 SHR=SQRT(SH)
15655 PMR=PMAS(KC,1)
15656
15657C...Reset width information.
15658 DO 110 I=0,200
15659 WDTP(I)=0D0
15660 DO 100 J=0,5
15661 WDTE(I,J)=0D0
15662 100 CONTINUE
15663 110 CONTINUE
15664
15665C...Allow for fudge factor to rescale resonance width.
15666 FUDGE=1D0
15667 IF(MSTP(110).NE.0.AND.(MWID(KC).EQ.1.OR.MWID(KC).EQ.2.OR.
15668 &(MWID(KC).EQ.3.AND.MINT(63).EQ.1))) THEN
15669 IF(MSTP(110).EQ.KFLA) THEN
15670 FUDGE=PARP(110)
15671 ELSEIF(MSTP(110).EQ.-1) THEN
15672 IF(KFLA.NE.6.AND.KFLA.NE.23.AND.KFLA.NE.24) FUDGE=PARP(110)
15673 ELSEIF(MSTP(110).EQ.-2) THEN
15674 FUDGE=PARP(110)
15675 ENDIF
15676 ENDIF
15677
15678C...Not to be treated as a resonance: return.
15679 IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND.
15680 &KFLA.NE.22) THEN
15681 WDTP(0)=1D0
15682 WDTE(0,0)=1D0
15683 MINT(61)=0
15684 MINT(62)=0
15685 MINT(63)=0
15686 RETURN
15687
15688C...Treatment as a resonance based on tabulated branching ratios.
15689 ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN
15690C...Loop over possible decay channels; skip irrelevant ones.
15691 DO 120 I=1,MDCY(KC,3)
15692 IDC=I+MDCY(KC,2)-1
15693 IF(MDME(IDC,1).LT.0) GOTO 120
15694
15695C...Read out decay products and nominal masses.
15696 KFD1=KFDP(IDC,1)
15697 KFC1=PYCOMP(KFD1)
15698 IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1
15699 PM1=PMAS(KFC1,1)
15700 KFD2=KFDP(IDC,2)
15701 KFC2=PYCOMP(KFD2)
15702 IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2
15703 PM2=PMAS(KFC2,1)
15704 KFD3=KFDP(IDC,3)
15705 PM3=0D0
15706 IF(KFD3.NE.0) THEN
15707 KFC3=PYCOMP(KFD3)
15708 IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3
15709 PM3=PMAS(KFC3,1)
15710 ENDIF
15711
15712C...Naive partial width and alternative threshold factors.
15713 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)
15714 IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND.
15715 & PM1+PM2+PM3.GE.SHR) THEN
15716 WDTP(I)=0D0
15717 ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN
15718 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2-
15719 & 4D0*PM1**2*PM2**2))/SH
15720 ELSEIF(MDME(IDC,2).EQ.52) THEN
15721 PMA=MAX(PM1,PM2,PM3)
15722 PMC=MIN(PM1,PM2,PM3)
15723 PMB=PM1+PM2+PM3-PMA-PMC
15724 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC)
15725 PMAN=PMA**2/SH
15726 PMBN=PMB**2/SH
15727 PMCN=PMC**2/SH
15728 PMBCN=PMBC**2/SH
15729 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,
15730 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
15731 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
15732 & ((SHR-PMA)**2-(PMB+PMC)**2)*
15733 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
15734 & ((1D0-PMBCN)*PMBCN*SH)
15735 ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
15736 WDTP(I)=WDTP(I)*SQRT(
15737 & MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/
15738 & MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2))
15739 ELSEIF(MDME(IDC,2).EQ.53) THEN
15740 PMA=MAX(PM1,PM2,PM3)
15741 PMC=MIN(PM1,PM2,PM3)
15742 PMB=PM1+PM2+PM3-PMA-PMC
15743 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC)
15744 PMAN=PMA**2/SH
15745 PMBN=PMB**2/SH
15746 PMCN=PMC**2/SH
15747 PMBCN=PMBC**2/SH
15748 FACACT=SQRT(MAX(0D0,
15749 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
15750 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
15751 & ((SHR-PMA)**2-(PMB+PMC)**2)*
15752 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
15753 & ((1D0-PMBCN)*PMBCN*SH)
15754 PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
15755 PMAN=PMA**2/PMR**2
15756 PMBN=PMB**2/PMR**2
15757 PMCN=PMC**2/PMR**2
15758 PMBCN=PMBC**2/PMR**2
15759 FACNOM=SQRT(MAX(0D0,
15760 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
15761 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
15762 & ((PMR-PMA)**2-(PMB+PMC)**2)*
15763 & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
15764 & ((1D0-PMBCN)*PMBCN*PMR**2)
15765 WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM)
15766 ENDIF
15767 WDTP(I)=FUDGE*WDTP(I)
15768 WDTP(0)=WDTP(0)+WDTP(I)
15769
15770C...Calculate secondary width (at most two identical/opposite).
15771 WID2=1D0
15772 IF(MDME(IDC,1).GT.0) THEN
15773 IF(KFD2.EQ.KFD1) THEN
15774 IF(KCHG(KFC1,3).EQ.0) THEN
15775 WID2=WIDS(KFC1,1)
15776 ELSEIF(KFD1.GT.0) THEN
15777 WID2=WIDS(KFC1,4)
15778 ELSE
15779 WID2=WIDS(KFC1,5)
15780 ENDIF
15781 IF(KFD3.GT.0) THEN
15782 WID2=WID2*WIDS(KFC3,2)
15783 ELSEIF(KFD3.LT.0) THEN
15784 WID2=WID2*WIDS(KFC3,3)
15785 ENDIF
15786 ELSEIF(KFD2.EQ.-KFD1) THEN
15787 WID2=WIDS(KFC1,1)
15788 IF(KFD3.GT.0) THEN
15789 WID2=WID2*WIDS(KFC3,2)
15790 ELSEIF(KFD3.LT.0) THEN
15791 WID2=WID2*WIDS(KFC3,3)
15792 ENDIF
15793 ELSEIF(KFD3.EQ.KFD1) THEN
15794 IF(KCHG(KFC1,3).EQ.0) THEN
15795 WID2=WIDS(KFC1,1)
15796 ELSEIF(KFD1.GT.0) THEN
15797 WID2=WIDS(KFC1,4)
15798 ELSE
15799 WID2=WIDS(KFC1,5)
15800 ENDIF
15801 IF(KFD2.GT.0) THEN
15802 WID2=WID2*WIDS(KFC2,2)
15803 ELSEIF(KFD2.LT.0) THEN
15804 WID2=WID2*WIDS(KFC2,3)
15805 ENDIF
15806 ELSEIF(KFD3.EQ.-KFD1) THEN
15807 WID2=WIDS(KFC1,1)
15808 IF(KFD2.GT.0) THEN
15809 WID2=WID2*WIDS(KFC2,2)
15810 ELSEIF(KFD2.LT.0) THEN
15811 WID2=WID2*WIDS(KFC2,3)
15812 ENDIF
15813 ELSEIF(KFD3.EQ.KFD2) THEN
15814 IF(KCHG(KFC2,3).EQ.0) THEN
15815 WID2=WIDS(KFC2,1)
15816 ELSEIF(KFD2.GT.0) THEN
15817 WID2=WIDS(KFC2,4)
15818 ELSE
15819 WID2=WIDS(KFC2,5)
15820 ENDIF
15821 IF(KFD1.GT.0) THEN
15822 WID2=WID2*WIDS(KFC1,2)
15823 ELSEIF(KFD1.LT.0) THEN
15824 WID2=WID2*WIDS(KFC1,3)
15825 ENDIF
15826 ELSEIF(KFD3.EQ.-KFD2) THEN
15827 WID2=WIDS(KFC2,1)
15828 IF(KFD1.GT.0) THEN
15829 WID2=WID2*WIDS(KFC1,2)
15830 ELSEIF(KFD1.LT.0) THEN
15831 WID2=WID2*WIDS(KFC1,3)
15832 ENDIF
15833 ELSE
15834 IF(KFD1.GT.0) THEN
15835 WID2=WIDS(KFC1,2)
15836 ELSE
15837 WID2=WIDS(KFC1,3)
15838 ENDIF
15839 IF(KFD2.GT.0) THEN
15840 WID2=WID2*WIDS(KFC2,2)
15841 ELSE
15842 WID2=WID2*WIDS(KFC2,3)
15843 ENDIF
15844 IF(KFD3.GT.0) THEN
15845 WID2=WID2*WIDS(KFC3,2)
15846 ELSEIF(KFD3.LT.0) THEN
15847 WID2=WID2*WIDS(KFC3,3)
15848 ENDIF
15849 ENDIF
15850
15851C...Store effective widths according to case.
15852 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
15853 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
15854 WDTE(I,0)=WDTE(I,MDME(IDC,1))
15855 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
15856 ENDIF
15857 120 CONTINUE
15858C...Return.
15859 MINT(61)=0
15860 MINT(62)=0
15861 MINT(63)=0
15862 RETURN
15863 ENDIF
15864
15865C...Here begins detailed dynamical calculation of resonance widths.
15866C...Shared treatment of Higgs states.
15867 KFHIGG=25
15868 IHIGG=1
15869 IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN
15870 KFHIGG=KFLA
15871 IHIGG=KFLA-33
15872 ENDIF
15873
15874C...Common electroweak and strong constants.
15875 XW=PARU(102)
15876 XWV=XW
15877 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
15878 XW1=1D0-XW
15879 AEM=PYALEM(SH)
15880 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
15881 AS=PYALPS(SH)
15882 RADC=1D0+AS/PARU(1)
15883
15884 IF(KFLA.EQ.6) THEN
15885C...t quark.
15886 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
15887 RADCT=1D0-2.5D0*AS/PARU(1)
15888 DO 140 I=1,MDCY(KC,3)
15889 IDC=I+MDCY(KC,2)-1
15890 IF(MDME(IDC,1).LT.0) GOTO 140
15891 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
15892 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
15893 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
15894 WID2=1D0
15895 IF(I.GE.4.AND.I.LE.7) THEN
15896C...t -> W + q; including approximate QCD correction factor.
15897 WDTP(I)=FAC*VCKM(3,I-3)*RADCT*
15898 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
15899 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
15900 IF(KFLR.GT.0) THEN
15901 WID2=WIDS(24,2)
15902 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
15903 ELSE
15904 WID2=WIDS(24,3)
15905 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
15906 ENDIF
15907 ELSEIF(I.EQ.9) THEN
15908C...t -> H + b.
15909 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
15910 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
15911 WID2=WIDS(37,2)
15912 IF(KFLR.LT.0) WID2=WIDS(37,3)
15913CMRENNA++
15914 ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN
15915C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
15916 BETA=ATAN(RMSS(5))
15917 SINB=SIN(BETA)
15918 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
15919 ET=KCHG(6,1)/3D0
15920 T3L=SIGN(0.5D0,ET)
15921 KFC1=PYCOMP(KFDP(IDC,1))
15922 KFC2=PYCOMP(KFDP(IDC,2))
15923 PMNCHI=PMAS(KFC1,1)
15924 PMSTOP=PMAS(KFC2,1)
15925 IF(SHR.GT.PMNCHI+PMSTOP) THEN
15926 IZ=I-9
15927 DO 130 IK=1,4
15928 ZMIXC(IZ,IK)=DCMPLX(ZMIX(IZ,IK),ZMIXI(IZ,IK))
15929 130 CONTINUE
15930 AL=SHR*DCONJG(ZMIXC(IZ,4))/(2.0D0*PMAS(24,1)*SINB)
15931 AR=-ET*ZMIXC(IZ,1)*TANW
15932 BL=T3L*(ZMIXC(IZ,2)-ZMIXC(IZ,1)*TANW)-AR
15933 BR=AL
15934 FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR
15935 FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR
15936 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
15937 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
15938 WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM*
15939 & ((ABS(FL)**2+ABS(FR)**2)*(SH+PMNCHI**2-PMSTOP**2)+
15940 & SMZ(IZ)*4D0*SHR*DBLE(FL*DCONJG(FR)))/SH
15941 IF(KFLR.GT.0) THEN
15942 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
15943 ELSE
15944 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
15945 ENDIF
15946 ENDIF
15947 ELSEIF(I.EQ.14.AND.IMSS(1).NE.0) THEN
15948C...t -> ~g + ~t
15949 KFC1=PYCOMP(KFDP(IDC,1))
15950 KFC2=PYCOMP(KFDP(IDC,2))
15951 PMNCHI=PMAS(KFC1,1)
15952 PMSTOP=PMAS(KFC2,1)
15953 IF(SHR.GT.PMNCHI+PMSTOP) THEN
15954 RL=SFMIX(6,1)
15955 RR=-SFMIX(6,2)
15956 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
15957 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
15958 WDTP(I)=4D0/3D0*0.5D0*PYALPS(SH)*PCM*((RL**2+RR**2)*
15959 & (SH+PMNCHI**2-PMSTOP**2)+PMNCHI*4D0*SHR*RL*RR)/SH
15960 IF(KFLR.GT.0) THEN
15961 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
15962 ELSE
15963 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
15964 ENDIF
15965 ENDIF
15966 ELSEIF(I.EQ.15.AND.IMSS(1).NE.0) THEN
15967C...t -> ~gravitino + ~t
15968 XMP2=RMSS(29)**2
15969 KFC1=PYCOMP(KFDP(IDC,1))
15970 XMGR2=PMAS(KFC1,1)**2
15971 WDTP(I)=SH**2*SHR/(96D0*PARU(1)*XMP2*XMGR2)*(1D0-RM2)**4
15972 KFC2=PYCOMP(KFDP(IDC,2))
15973 WID2=WIDS(KFC2,2)
15974 IF(KFLR.LT.0) WID2=WIDS(KFC2,3)
15975CMRENNA--
15976 ENDIF
15977 WDTP(I)=FUDGE*WDTP(I)
15978 WDTP(0)=WDTP(0)+WDTP(I)
15979 IF(MDME(IDC,1).GT.0) THEN
15980 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
15981 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
15982 WDTE(I,0)=WDTE(I,MDME(IDC,1))
15983 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
15984 ENDIF
15985 140 CONTINUE
15986
15987 ELSEIF(KFLA.EQ.7) THEN
15988C...b' quark.
15989 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
15990 DO 150 I=1,MDCY(KC,3)
15991 IDC=I+MDCY(KC,2)-1
15992 IF(MDME(IDC,1).LT.0) GOTO 150
15993 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
15994 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
15995 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150
15996 WID2=1D0
15997 IF(I.GE.4.AND.I.LE.7) THEN
15998C...b' -> W + q.
15999 WDTP(I)=FAC*VCKM(I-3,4)*
16000 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16001 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
16002 IF(KFLR.GT.0) THEN
16003 WID2=WIDS(24,3)
16004 IF(I.EQ.6) WID2=WID2*WIDS(6,2)
16005 IF(I.EQ.7) WID2=WID2*WIDS(8,2)
16006 ELSE
16007 WID2=WIDS(24,2)
16008 IF(I.EQ.6) WID2=WID2*WIDS(6,3)
16009 IF(I.EQ.7) WID2=WID2*WIDS(8,3)
16010 ENDIF
16011 WID2=WIDS(24,3)
16012 IF(KFLR.LT.0) WID2=WIDS(24,2)
16013 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
16014C...b' -> H + q.
16015 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16016 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
16017 IF(KFLR.GT.0) THEN
16018 WID2=WIDS(37,3)
16019 IF(I.EQ.10) WID2=WID2*WIDS(6,2)
16020 ELSE
16021 WID2=WIDS(37,2)
16022 IF(I.EQ.10) WID2=WID2*WIDS(6,3)
16023 ENDIF
16024 ENDIF
16025 WDTP(I)=FUDGE*WDTP(I)
16026 WDTP(0)=WDTP(0)+WDTP(I)
16027 IF(MDME(IDC,1).GT.0) THEN
16028 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16029 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16030 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16031 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16032 ENDIF
16033 150 CONTINUE
16034
16035 ELSEIF(KFLA.EQ.8) THEN
16036C...t' quark.
16037 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
16038 DO 160 I=1,MDCY(KC,3)
16039 IDC=I+MDCY(KC,2)-1
16040 IF(MDME(IDC,1).LT.0) GOTO 160
16041 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16042 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16043 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160
16044 WID2=1D0
16045 IF(I.GE.4.AND.I.LE.7) THEN
16046C...t' -> W + q.
16047 WDTP(I)=FAC*VCKM(4,I-3)*
16048 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16049 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
16050 IF(KFLR.GT.0) THEN
16051 WID2=WIDS(24,2)
16052 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
16053 ELSE
16054 WID2=WIDS(24,3)
16055 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
16056 ENDIF
16057 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
16058C...t' -> H + q.
16059 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16060 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
16061 IF(KFLR.GT.0) THEN
16062 WID2=WIDS(37,2)
16063 IF(I.EQ.10) WID2=WID2*WIDS(7,2)
16064 ELSE
16065 WID2=WIDS(37,3)
16066 IF(I.EQ.10) WID2=WID2*WIDS(7,3)
16067 ENDIF
16068 ENDIF
16069 WDTP(I)=FUDGE*WDTP(I)
16070 WDTP(0)=WDTP(0)+WDTP(I)
16071 IF(MDME(IDC,1).GT.0) THEN
16072 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16073 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16074 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16075 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16076 ENDIF
16077 160 CONTINUE
16078
16079 ELSEIF(KFLA.EQ.17) THEN
16080C...tau' lepton.
16081 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
16082 DO 170 I=1,MDCY(KC,3)
16083 IDC=I+MDCY(KC,2)-1
16084 IF(MDME(IDC,1).LT.0) GOTO 170
16085 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16086 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16087 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170
16088 WID2=1D0
16089 IF(I.EQ.3) THEN
16090C...tau' -> W + nu'_tau.
16091 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16092 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
16093 IF(KFLR.GT.0) THEN
16094 WID2=WIDS(24,3)
16095 WID2=WID2*WIDS(18,2)
16096 ELSE
16097 WID2=WIDS(24,2)
16098 WID2=WID2*WIDS(18,3)
16099 ENDIF
16100 ELSEIF(I.EQ.5) THEN
16101C...tau' -> H + nu'_tau.
16102 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16103 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
16104 IF(KFLR.GT.0) THEN
16105 WID2=WIDS(37,3)
16106 WID2=WID2*WIDS(18,2)
16107 ELSE
16108 WID2=WIDS(37,2)
16109 WID2=WID2*WIDS(18,3)
16110 ENDIF
16111 ENDIF
16112 WDTP(I)=FUDGE*WDTP(I)
16113 WDTP(0)=WDTP(0)+WDTP(I)
16114 IF(MDME(IDC,1).GT.0) THEN
16115 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16116 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16117 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16118 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16119 ENDIF
16120 170 CONTINUE
16121
16122 ELSEIF(KFLA.EQ.18) THEN
16123C...nu'_tau neutrino.
16124 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
16125 DO 180 I=1,MDCY(KC,3)
16126 IDC=I+MDCY(KC,2)-1
16127 IF(MDME(IDC,1).LT.0) GOTO 180
16128 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16129 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16130 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180
16131 WID2=1D0
16132 IF(I.EQ.2) THEN
16133C...nu'_tau -> W + tau'.
16134 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16135 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
16136 IF(KFLR.GT.0) THEN
16137 WID2=WIDS(24,2)
16138 WID2=WID2*WIDS(17,2)
16139 ELSE
16140 WID2=WIDS(24,3)
16141 WID2=WID2*WIDS(17,3)
16142 ENDIF
16143 ELSEIF(I.EQ.3) THEN
16144C...nu'_tau -> H + tau'.
16145 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16146 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
16147 IF(KFLR.GT.0) THEN
16148 WID2=WIDS(37,2)
16149 WID2=WID2*WIDS(17,2)
16150 ELSE
16151 WID2=WIDS(37,3)
16152 WID2=WID2*WIDS(17,3)
16153 ENDIF
16154 ENDIF
16155 WDTP(I)=FUDGE*WDTP(I)
16156 WDTP(0)=WDTP(0)+WDTP(I)
16157 IF(MDME(IDC,1).GT.0) THEN
16158 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16159 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16160 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16161 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16162 ENDIF
16163 180 CONTINUE
16164
16165 ELSEIF(KFLA.EQ.21) THEN
16166C...QCD:
16167C***Note that widths are not given in dimensional quantities here.
16168 DO 190 I=1,MDCY(KC,3)
16169 IDC=I+MDCY(KC,2)-1
16170 IF(MDME(IDC,1).LT.0) GOTO 190
16171 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16172 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16173 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190
16174 WID2=1D0
16175 IF(I.LE.8) THEN
16176C...QCD -> q + qbar
16177 WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
16178 IF(I.EQ.6) WID2=WIDS(6,1)
16179 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
16180 ENDIF
16181 WDTP(I)=FUDGE*WDTP(I)
16182 WDTP(0)=WDTP(0)+WDTP(I)
16183 IF(MDME(IDC,1).GT.0) THEN
16184 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16185 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16186 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16187 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16188 ENDIF
16189 190 CONTINUE
16190
16191 ELSEIF(KFLA.EQ.22) THEN
16192C...QED photon.
16193C***Note that widths are not given in dimensional quantities here.
16194 DO 200 I=1,MDCY(KC,3)
16195 IDC=I+MDCY(KC,2)-1
16196 IF(MDME(IDC,1).LT.0) GOTO 200
16197 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16198 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16199 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 200
16200 WID2=1D0
16201 IF(I.LE.8) THEN
16202C...QED -> q + qbar.
16203 EF=KCHG(I,1)/3D0
16204 FCOF=3D0*RADC
16205 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
16206 WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
16207 IF(I.EQ.6) WID2=WIDS(6,1)
16208 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
16209 ELSEIF(I.LE.12) THEN
16210C...QED -> l+ + l-.
16211 EF=KCHG(9+2*(I-8),1)/3D0
16212 WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
16213 IF(I.EQ.12) WID2=WIDS(17,1)
16214 ENDIF
16215 WDTP(I)=FUDGE*WDTP(I)
16216 WDTP(0)=WDTP(0)+WDTP(I)
16217 IF(MDME(IDC,1).GT.0) THEN
16218 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16219 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16220 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16221 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16222 ENDIF
16223 200 CONTINUE
16224
16225 ELSEIF(KFLA.EQ.23) THEN
16226C...Z0:
16227 ICASE=1
16228 XWC=1D0/(16D0*XW*XW1)
16229 FAC=(AEM*XWC/3D0)*SHR
16230 210 CONTINUE
16231 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
16232 VINT(111)=0D0
16233 VINT(112)=0D0
16234 VINT(114)=0D0
16235 ENDIF
16236 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
16237 KFI=IABS(MINT(15))
16238 IF(KFI.GT.20) KFI=IABS(MINT(16))
16239 EI=KCHG(KFI,1)/3D0
16240 AI=SIGN(1D0,EI)
16241 VI=AI-4D0*EI*XWV
16242 SQMZ=PMAS(23,1)**2
16243 HZ=SHR*WDTP(0)
16244 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0
16245 IF(MSTP(43).EQ.3) VINT(112)=
16246 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
16247 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
16248 & XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
16249 ENDIF
16250 DO 220 I=1,MDCY(KC,3)
16251 IDC=I+MDCY(KC,2)-1
16252 IF(MDME(IDC,1).LT.0) GOTO 220
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 220
16256 WID2=1D0
16257 IF(I.LE.8) THEN
16258C...Z0 -> q + qbar
16259 EF=KCHG(I,1)/3D0
16260 AF=SIGN(1D0,EF+0.1D0)
16261 VF=AF-4D0*EF*XWV
16262 FCOF=3D0*RADC
16263 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
16264 IF(I.EQ.6) WID2=WIDS(6,1)
16265 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
16266 ELSEIF(I.LE.16) THEN
16267C...Z0 -> l+ + l-, nu + nubar
16268 EF=KCHG(I+2,1)/3D0
16269 AF=SIGN(1D0,EF+0.1D0)
16270 VF=AF-4D0*EF*XWV
16271 FCOF=1D0
16272 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
16273 ENDIF
16274 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
16275 IF(ICASE.EQ.1) THEN
16276 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
16277 & BE34
16278 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
16279 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
16280 & EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+
16281 & (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34
16282 ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
16283 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
16284 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
16285 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
16286 ENDIF
16287 IF(ICASE.EQ.1) WDTP(I)=FUDGE*WDTP(I)
16288 IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I)
16289 IF(MDME(IDC,1).GT.0) THEN
16290 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
16291 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
16292 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16293 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
16294 & WDTE(I,MDME(IDC,1))
16295 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16296 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16297 ENDIF
16298 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
16299 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=
16300 & VINT(111)+FGGF*WID2
16301 IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2
16302 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
16303 & VINT(114)+FZZF*WID2
16304 ENDIF
16305 ENDIF
16306 220 CONTINUE
16307 IF(MINT(61).GE.1) ICASE=3-ICASE
16308 IF(ICASE.EQ.2) GOTO 210
16309
16310 ELSEIF(KFLA.EQ.24) THEN
16311C...W+/-:
16312 FAC=(AEM/(24D0*XW))*SHR
16313 DO 230 I=1,MDCY(KC,3)
16314 IDC=I+MDCY(KC,2)-1
16315 IF(MDME(IDC,1).LT.0) GOTO 230
16316 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16317 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16318 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 230
16319 WID2=1D0
16320 IF(I.LE.16) THEN
16321C...W+/- -> q + qbar'
16322 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
16323 IF(KFLR.GT.0) THEN
16324 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
16325 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
16326 IF(I.GE.13) WID2=WID2*WIDS(7,3)
16327 ELSE
16328 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
16329 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
16330 IF(I.GE.13) WID2=WID2*WIDS(7,2)
16331 ENDIF
16332 ELSEIF(I.LE.20) THEN
16333C...W+/- -> l+/- + nu
16334 FCOF=1D0
16335 IF(KFLR.GT.0) THEN
16336 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
16337 ELSE
16338 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
16339 ENDIF
16340 ENDIF
16341 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
16342 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
16343 WDTP(I)=FUDGE*WDTP(I)
16344 WDTP(0)=WDTP(0)+WDTP(I)
16345 IF(MDME(IDC,1).GT.0) THEN
16346 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16347 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16348 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16349 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16350 ENDIF
16351 230 CONTINUE
16352
16353 ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN
16354C...h0 (or H0, or A0):
16355 IF(MSTP(49).EQ.0) THEN
16356 SHFS=SH
16357 ELSE
16358 SHFS=PMAS(KFHIGG,1)**2
16359 ENDIF
16360 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
16361 DO 270 I=1,MDCY(KFHIGG,3)
16362 IDC=I+MDCY(KFHIGG,2)-1
16363 IF(MDME(IDC,1).LT.0) GOTO 270
16364 KFC1=PYCOMP(KFDP(IDC,1))
16365 KFC2=PYCOMP(KFDP(IDC,2))
16366 RM1=PMAS(KFC1,1)**2/SH
16367 RM2=PMAS(KFC2,1)**2/SH
16368 IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0)
16369 & GOTO 270
16370 WID2=1D0
16371
16372 IF(I.LE.8) THEN
16373C...h0 -> q + qbar
16374 WDTP(I)=FAC*3D0*(PYMRUN(KFDP(IDC,1),SH)**2/SHFS)*
16375 & SQRT(MAX(0D0,1D0-4D0*RM1))*RADC
16376C...A0 behaves like beta, ho and H0 like beta**3.
16377 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
16378 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
16379 IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2
16380 IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2
16381 IF(IMSS(1).NE.0.AND.KFC1.EQ.5) THEN
16382 WDTP(I)=WDTP(I)/(1D0+RMSS(41))**2
16383 IF(IHIGG.NE.3) THEN
16384 WDTP(I)=WDTP(I)*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
16385 & PARU(151+10*IHIGG))**2
16386 ENDIF
16387 ENDIF
16388 ENDIF
16389 IF(I.EQ.6) WID2=WIDS(6,1)
16390 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
16391 ELSEIF(I.LE.12) THEN
16392C...h0 -> l+ + l-
16393 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))*(SH/SHFS)
16394C...A0 behaves like beta, ho and H0 like beta**3.
16395 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
16396 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
16397 & PARU(153+10*IHIGG)**2
16398 IF(I.EQ.12) WID2=WIDS(17,1)
16399
16400 ELSEIF(I.EQ.13) THEN
16401C...h0 -> g + g; quark loop contribution only
16402 ETARE=0D0
16403 ETAIM=0D0
16404 DO 240 J=1,2*MSTP(1)
16405 EPS=(2D0*PMAS(J,1))**2/SH
16406C...Loop integral; function of eps=4m^2/shat; different for A0.
16407 IF(EPS.LE.1D0) THEN
16408 IF(EPS.GT.1D-4) THEN
16409 ROOT=SQRT(1D0-EPS)
16410 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
16411 ELSE
16412 RLN=LOG(4D0/EPS-2D0)
16413 ENDIF
16414 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
16415 PHIIM=0.5D0*PARU(1)*RLN
16416 ELSE
16417 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
16418 PHIIM=0D0
16419 ENDIF
16420 IF(IHIGG.LE.2) THEN
16421 ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
16422 ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM
16423 ELSE
16424 ETAREJ=-0.5D0*EPS*PHIRE
16425 ETAIMJ=-0.5D0*EPS*PHIIM
16426 ENDIF
16427C...Couplings (=1 for standard model Higgs).
16428 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
16429 IF(MOD(J,2).EQ.1) THEN
16430 ETAREJ=ETAREJ*PARU(151+10*IHIGG)
16431 ETAIMJ=ETAIMJ*PARU(151+10*IHIGG)
16432 ELSE
16433 ETAREJ=ETAREJ*PARU(152+10*IHIGG)
16434 ETAIMJ=ETAIMJ*PARU(152+10*IHIGG)
16435 ENDIF
16436 ENDIF
16437 ETARE=ETARE+ETAREJ
16438 ETAIM=ETAIM+ETAIMJ
16439 240 CONTINUE
16440 ETA2=ETARE**2+ETAIM**2
16441 WDTP(I)=FAC*(AS/PARU(1))**2*ETA2
16442
16443 ELSEIF(I.EQ.14) THEN
16444C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
16445 ETARE=0D0
16446 ETAIM=0D0
16447 JMAX=3*MSTP(1)+1
16448 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
16449 DO 250 J=1,JMAX
16450 IF(J.LE.2*MSTP(1)) THEN
16451 EJ=KCHG(J,1)/3D0
16452 EPS=(2D0*PMAS(J,1))**2/SH
16453 ELSEIF(J.LE.3*MSTP(1)) THEN
16454 JL=2*(J-2*MSTP(1))-1
16455 EJ=KCHG(10+JL,1)/3D0
16456 EPS=(2D0*PMAS(10+JL,1))**2/SH
16457 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
16458 EPS=(2D0*PMAS(24,1))**2/SH
16459 ELSE
16460 EPS=(2D0*PMAS(37,1))**2/SH
16461 ENDIF
16462C...Loop integral; function of eps=4m^2/shat.
16463 IF(EPS.LE.1D0) THEN
16464 IF(EPS.GT.1D-4) THEN
16465 ROOT=SQRT(1D0-EPS)
16466 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
16467 ELSE
16468 RLN=LOG(4D0/EPS-2D0)
16469 ENDIF
16470 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
16471 PHIIM=0.5D0*PARU(1)*RLN
16472 ELSE
16473 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
16474 PHIIM=0D0
16475 ENDIF
16476 IF(J.LE.3*MSTP(1)) THEN
16477C...Fermion loops: loop integral different for A0; charges.
16478 IF(IHIGG.LE.2) THEN
16479 PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
16480 PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM
16481 ELSE
16482 PHIPRE=-0.5D0*EPS*PHIRE
16483 PHIPIM=-0.5D0*EPS*PHIIM
16484 ENDIF
16485 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
16486 EJC=3D0*EJ**2
16487 EJH=PARU(151+10*IHIGG)
16488 ELSEIF(J.LE.2*MSTP(1)) THEN
16489 EJC=3D0*EJ**2
16490 EJH=PARU(152+10*IHIGG)
16491 ELSE
16492 EJC=EJ**2
16493 EJH=PARU(153+10*IHIGG)
16494 ENDIF
16495 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
16496 ETAREJ=EJC*EJH*PHIPRE
16497 ETAIMJ=EJC*EJH*PHIPIM
16498 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
16499C...W loops: loop integral and charges.
16500 ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE)
16501 ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM
16502 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
16503 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
16504 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
16505 ENDIF
16506 ELSE
16507C...Charged H loops: loop integral and charges.
16508 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*
16509 & PARU(158+10*IHIGG+2*(IHIGG/3))
16510 ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH
16511 ETAIMJ=-EPS**2*PHIIM*FACHHH
16512 ENDIF
16513 ETARE=ETARE+ETAREJ
16514 ETAIM=ETAIM+ETAIMJ
16515 250 CONTINUE
16516 ETA2=ETARE**2+ETAIM**2
16517 WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2
16518
16519 ELSEIF(I.EQ.15) THEN
16520C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
16521 ETARE=0D0
16522 ETAIM=0D0
16523 JMAX=3*MSTP(1)+1
16524 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
16525 DO 260 J=1,JMAX
16526 IF(J.LE.2*MSTP(1)) THEN
16527 EJ=KCHG(J,1)/3D0
16528 AJ=SIGN(1D0,EJ+0.1D0)
16529 VJ=AJ-4D0*EJ*XWV
16530 EPS=(2D0*PMAS(J,1))**2/SH
16531 EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2
16532 ELSEIF(J.LE.3*MSTP(1)) THEN
16533 JL=2*(J-2*MSTP(1))-1
16534 EJ=KCHG(10+JL,1)/3D0
16535 AJ=SIGN(1D0,EJ+0.1D0)
16536 VJ=AJ-4D0*EJ*XWV
16537 EPS=(2D0*PMAS(10+JL,1))**2/SH
16538 EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2
16539 ELSE
16540 EPS=(2D0*PMAS(24,1))**2/SH
16541 EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2
16542 ENDIF
16543C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
16544 IF(EPS.LE.1D0) THEN
16545 ROOT=SQRT(1D0-EPS)
16546 IF(EPS.GT.1D-4) THEN
16547 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
16548 ELSE
16549 RLN=LOG(4D0/EPS-2D0)
16550 ENDIF
16551 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
16552 PHIIM=0.5D0*PARU(1)*RLN
16553 PSIRE=0.5D0*ROOT*RLN
16554 PSIIM=-0.5D0*ROOT*PARU(1)
16555 ELSE
16556 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
16557 PHIIM=0D0
16558 PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS))
16559 PSIIM=0D0
16560 ENDIF
16561 IF(EPSP.LE.1D0) THEN
16562 ROOT=SQRT(1D0-EPSP)
16563 IF(EPSP.GT.1D-4) THEN
16564 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
16565 ELSE
16566 RLN=LOG(4D0/EPSP-2D0)
16567 ENDIF
16568 PHIREP=-0.25D0*(RLN**2-PARU(1)**2)
16569 PHIIMP=0.5D0*PARU(1)*RLN
16570 PSIREP=0.5D0*ROOT*RLN
16571 PSIIMP=-0.5D0*ROOT*PARU(1)
16572 ELSE
16573 PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
16574 PHIIMP=0D0
16575 PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
16576 PSIIMP=0D0
16577 ENDIF
16578 FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)*
16579 & (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
16580 FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)*
16581 & (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP))
16582 F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP)
16583 F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP)
16584 IF(J.LE.3*MSTP(1)) THEN
16585C...Fermion loops: loop integral different for A0; charges.
16586 IF(IHIGG.EQ.3) FXYRE=0D0
16587 IF(IHIGG.EQ.3) FXYIM=0D0
16588 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
16589 EJC=-3D0*EJ*VJ
16590 EJH=PARU(151+10*IHIGG)
16591 ELSEIF(J.LE.2*MSTP(1)) THEN
16592 EJC=-3D0*EJ*VJ
16593 EJH=PARU(152+10*IHIGG)
16594 ELSE
16595 EJC=-EJ*VJ
16596 EJH=PARU(153+10*IHIGG)
16597 ENDIF
16598 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
16599 ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE)
16600 ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM)
16601 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
16602C...W loops: loop integral and charges.
16603 HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS)
16604 ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE)
16605 ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM)
16606 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
16607 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
16608 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
16609 ENDIF
16610 ELSE
16611C...Charged H loops: loop integral and charges.
16612 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)*
16613 & PARU(158+10*IHIGG+2*(IHIGG/3))
16614 ETAREJ=FACHHH*FXYRE
16615 ETAIMJ=FACHHH*FXYIM
16616 ENDIF
16617 ETARE=ETARE+ETAREJ
16618 ETAIM=ETAIM+ETAIMJ
16619 260 CONTINUE
16620 ETA2=(ETARE**2+ETAIM**2)/(XW*XW1)
16621 WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2
16622 WID2=WIDS(23,2)
16623
16624 ELSEIF(I.LE.17) THEN
16625C...h0 -> Z0 + Z0, W+ + W-
16626 PM1=PMAS(IABS(KFDP(IDC,1)),1)
16627 PG1=PMAS(IABS(KFDP(IDC,1)),2)
16628 IF(MINT(62).GE.1) THEN
16629 IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND.
16630 & CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND.
16631 & MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN
16632 MOFSV(IHIGG,I-15)=0
16633 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
16634 & 1D0-4D0*RM1))
16635 WID2=1D0
16636 ELSE
16637 MOFSV(IHIGG,I-15)=1
16638 RMAS=SQRT(MAX(0D0,SH))
16639 CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW,
16640 & WID2)
16641 WIDWSV(IHIGG,I-15)=WIDW
16642 WID2SV(IHIGG,I-15)=WID2
16643 ENDIF
16644 ELSE
16645 IF(MOFSV(IHIGG,I-15).EQ.0) THEN
16646 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
16647 & 1D0-4D0*RM1))
16648 WID2=1D0
16649 ELSE
16650 WIDW=WIDWSV(IHIGG,I-15)
16651 WID2=WID2SV(IHIGG,I-15)
16652 ENDIF
16653 ENDIF
16654 WDTP(I)=FAC*WIDW/(2D0*(18-I))
16655 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
16656 & PARU(138+I+10*IHIGG)**2
16657 WID2=WID2*WIDS(7+I,1)
16658
16659 ELSEIF(I.EQ.18.AND.IHIGG.GE.2) THEN
16660C...H0 -> Z0 + h0, A0-> Z0 + h0
16661 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
16662 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
16663 IF(IHIGG.EQ.2) THEN
16664 WDTP(I)=WDTP(I)*PARU(179)**2
16665 ELSEIF(IHIGG.EQ.3) THEN
16666 WDTP(I)=WDTP(I)*PARU(186)**2
16667 ENDIF
16668 WID2=WIDS(23,2)*WIDS(25,2)
16669
16670 ELSEIF(I.EQ.19.AND.IHIGG.GE.2) THEN
16671C...H0 -> h0 + h0, A0-> h0 + h0
16672 WDTP(I)=FAC*0.25D0*
16673 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
16674 IF(IHIGG.EQ.2) THEN
16675 WDTP(I)=WDTP(I)*PARU(176)**2
16676 ELSEIF(IHIGG.EQ.3) THEN
16677 WDTP(I)=WDTP(I)*PARU(169)**2
16678 ENDIF
16679 WID2=WIDS(25,1)
16680 ELSEIF((I.EQ.20.OR.I.EQ.21).AND.IHIGG.GE.2) THEN
16681C...H0 -> W+/- + H-/+, A0 -> W+/- + H-/+
16682 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
16683 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
16684 & *PARU(195+IHIGG)**2
16685 IF(I.EQ.20) THEN
16686 WID2=WIDS(24,2)*WIDS(37,3)
16687 ELSEIF(I.EQ.21) THEN
16688 WID2=WIDS(24,3)*WIDS(37,2)
16689 ENDIF
16690
16691 ELSEIF(I.EQ.22.AND.IHIGG.EQ.2) THEN
16692C...H0 -> Z0 + A0.
16693 WDTP(I)=FAC*0.5D0*PARU(187)**2*SQRT(MAX(0D0,
16694 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*0.0D0
16695 WID2=WIDS(36,2)*WIDS(23,2)
16696
16697 ELSEIF(I.EQ.23.AND.IHIGG.EQ.2) THEN
16698C...H0 -> h0 + A0.
16699 WDTP(I)=FAC*0.5D0*PARU(180)**2*
16700 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
16701 WID2=WIDS(25,2)*WIDS(36,2)
16702
16703 ELSEIF(I.EQ.24.AND.IHIGG.EQ.2) THEN
16704C...H0 -> A0 + A0
16705 WDTP(I)=FAC*0.25D0*PARU(177)**2*
16706 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
16707 WID2=WIDS(36,1)
16708
16709CMRENNA++
16710 ELSE
16711C...Add in SUSY decays (two-body) by rescaling by phase space factor.
16712 RM10=RM1*SH/PMR**2
16713 RM20=RM2*SH/PMR**2
16714 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
16715 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
16716 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
16717 WFAC=0D0
16718 ELSE
16719 WFAC=WFAC/WFAC0
16720 ENDIF
16721 WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
16722CMRENNA--
16723 IF(KFC2.EQ.KFC1) THEN
16724 WID2=WIDS(KFC1,1)
16725 ELSE
16726 KSGN1=2
16727 IF(KFDP(IDC,1).LT.0) KSGN1=3
16728 KSGN2=2
16729 IF(KFDP(IDC,2).LT.0) KSGN2=3
16730 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
16731 ENDIF
16732 ENDIF
16733 WDTP(I)=FUDGE*WDTP(I)
16734 WDTP(0)=WDTP(0)+WDTP(I)
16735 IF(MDME(IDC,1).GT.0) THEN
16736 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16737 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16738 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16739 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16740 ENDIF
16741 270 CONTINUE
16742
16743 ELSEIF(KFLA.EQ.32) THEN
16744C...Z'0:
16745 ICASE=1
16746 XWC=1D0/(16D0*XW*XW1)
16747 FAC=(AEM*XWC/3D0)*SHR
16748 VINT(117)=0D0
16749 280 CONTINUE
16750 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
16751 VINT(111)=0D0
16752 VINT(112)=0D0
16753 VINT(113)=0D0
16754 VINT(114)=0D0
16755 VINT(115)=0D0
16756 VINT(116)=0D0
16757 ENDIF
16758 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
16759 KFAI=IABS(MINT(15))
16760 EI=KCHG(KFAI,1)/3D0
16761 AI=SIGN(1D0,EI+0.1D0)
16762 VI=AI-4D0*EI*XWV
16763 KFAIC=1
16764 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
16765 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
16766 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
16767 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
16768 VPI=PARU(119+2*KFAIC)
16769 API=PARU(120+2*KFAIC)
16770 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
16771 VPI=PARJ(178+2*KFAIC)
16772 API=PARJ(179+2*KFAIC)
16773 ELSE
16774 VPI=PARJ(186+2*KFAIC)
16775 API=PARJ(187+2*KFAIC)
16776 ENDIF
16777 SQMZ=PMAS(23,1)**2
16778 HZ=SHR*VINT(117)
16779 SQMZP=PMAS(32,1)**2
16780 HZP=SHR*WDTP(0)
16781 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
16782 & MSTP(44).EQ.7) VINT(111)=1D0
16783 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=
16784 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
16785 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
16786 & 2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2)
16787 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
16788 & MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
16789 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
16790 & 2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/
16791 & (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2))
16792 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
16793 & MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2)
16794 ENDIF
16795 DO 290 I=1,MDCY(KC,3)
16796 IDC=I+MDCY(KC,2)-1
16797 IF(MDME(IDC,1).LT.0) GOTO 290
16798 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16799 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16800 IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 290
16801 WID2=1D0
16802 IF(I.LE.16) THEN
16803 IF(I.LE.8) THEN
16804C...Z'0 -> q + qbar
16805 EF=KCHG(I,1)/3D0
16806 AF=SIGN(1D0,EF+0.1D0)
16807 VF=AF-4D0*EF*XWV
16808 IF(I.LE.2) THEN
16809 VPF=PARU(123-2*MOD(I,2))
16810 APF=PARU(124-2*MOD(I,2))
16811 ELSEIF(I.LE.4) THEN
16812 VPF=PARJ(182-2*MOD(I,2))
16813 APF=PARJ(183-2*MOD(I,2))
16814 ELSE
16815 VPF=PARJ(190-2*MOD(I,2))
16816 APF=PARJ(191-2*MOD(I,2))
16817 ENDIF
16818 FCOF=3D0*RADC
16819 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
16820 & PYHFTH(SH,SH*RM1,1D0)
16821 IF(I.EQ.6) WID2=WIDS(6,1)
16822 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
16823 ELSEIF(I.LE.16) THEN
16824C...Z'0 -> l+ + l-, nu + nubar
16825 EF=KCHG(I+2,1)/3D0
16826 AF=SIGN(1D0,EF+0.1D0)
16827 VF=AF-4D0*EF*XWV
16828 IF(I.LE.10) THEN
16829 VPF=PARU(127-2*MOD(I,2))
16830 APF=PARU(128-2*MOD(I,2))
16831 ELSEIF(I.LE.12) THEN
16832 VPF=PARJ(186-2*MOD(I,2))
16833 APF=PARJ(187-2*MOD(I,2))
16834 ELSE
16835 VPF=PARJ(194-2*MOD(I,2))
16836 APF=PARJ(195-2*MOD(I,2))
16837 ENDIF
16838 FCOF=1D0
16839 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
16840 ENDIF
16841 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
16842 IF(ICASE.EQ.1) THEN
16843 WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
16844 WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+
16845 & APF**2*(1D0-4D0*RM1))*BE34
16846 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
16847 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
16848 & EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
16849 & VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)*
16850 & VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)*
16851 & AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)*
16852 & VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34
16853 ELSEIF(MINT(61).EQ.2) THEN
16854 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
16855 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
16856 FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34
16857 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
16858 FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))*
16859 & BE34
16860 FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))*
16861 & BE34
16862 ENDIF
16863 ELSEIF(I.EQ.17) THEN
16864C...Z'0 -> W+ + W-
16865 WDTPZP=PARU(129)**2*XW1**2*
16866 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
16867 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
16868 IF(ICASE.EQ.1) THEN
16869 WDTPZ=0D0
16870 WDTP(I)=FAC*WDTPZP
16871 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
16872 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
16873 ELSEIF(MINT(61).EQ.2) THEN
16874 FGGF=0D0
16875 FGZF=0D0
16876 FGZPF=0D0
16877 FZZF=0D0
16878 FZZPF=0D0
16879 FZPZPF=WDTPZP
16880 ENDIF
16881 WID2=WIDS(24,1)
16882 ELSEIF(I.EQ.18) THEN
16883C...Z'0 -> H+ + H-
16884 CZC=2D0*(1D0-2D0*XW)
16885 BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
16886 IF(ICASE.EQ.1) THEN
16887 WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C
16888 WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C
16889 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
16890 WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI*
16891 & VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2*
16892 & (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)*
16893 & (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2*
16894 & (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C
16895 ELSEIF(MINT(61).EQ.2) THEN
16896 FGGF=0.25D0*BE34C
16897 FGZF=0.25D0*PARU(142)*CZC*BE34C
16898 FGZPF=0.25D0*PARU(143)*CZC*BE34C
16899 FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C
16900 FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C
16901 FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C
16902 ENDIF
16903 WID2=WIDS(37,1)
16904 ELSEIF(I.EQ.19) THEN
16905C...Z'0 -> Z0 + gamma.
16906 ELSEIF(I.EQ.20) THEN
16907C...Z'0 -> Z0 + h0
16908 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
16909 WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)*
16910 & (3D0*RM1+0.25D0*FLAM**2)*FLAM
16911 IF(ICASE.EQ.1) THEN
16912 WDTPZ=0D0
16913 WDTP(I)=FAC*WDTPZP
16914 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
16915 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
16916 ELSEIF(MINT(61).EQ.2) THEN
16917 FGGF=0D0
16918 FGZF=0D0
16919 FGZPF=0D0
16920 FZZF=0D0
16921 FZZPF=0D0
16922 FZPZPF=WDTPZP
16923 ENDIF
16924 WID2=WIDS(23,2)*WIDS(25,2)
16925 ELSEIF(I.EQ.21.OR.I.EQ.22) THEN
16926C...Z' -> h0 + A0 or H0 + A0.
16927 BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
16928 IF(I.EQ.21) THEN
16929 CZAH=PARU(186)
16930 CZPAH=PARU(188)
16931 ELSE
16932 CZAH=PARU(187)
16933 CZPAH=PARU(189)
16934 ENDIF
16935 IF(ICASE.EQ.1) THEN
16936 WDTPZ=CZAH**2*BE34C
16937 WDTP(I)=FAC*CZPAH**2*BE34C
16938 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
16939 WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH*
16940 & (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)*
16941 & VINT(116))*BE34C
16942 ELSEIF(MINT(61).EQ.2) THEN
16943 FGGF=0D0
16944 FGZF=0D0
16945 FGZPF=0D0
16946 FZZF=CZAH**2*BE34C
16947 FZZPF=CZAH*CZPAH*BE34C
16948 FZPZPF=CZPAH**2*BE34C
16949 ENDIF
16950 IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2)
16951 IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2)
16952 ENDIF
16953 IF(ICASE.EQ.1) THEN
16954 VINT(117)=VINT(117)+FAC*WDTPZ
16955 WDTP(I)=FUDGE*WDTP(I)
16956 WDTP(0)=WDTP(0)+WDTP(I)
16957 ENDIF
16958 IF(MDME(IDC,1).GT.0) THEN
16959 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
16960 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
16961 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16962 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
16963 & WDTE(I,MDME(IDC,1))
16964 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16965 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16966 ENDIF
16967 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
16968 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
16969 & MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2
16970 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+
16971 & FGZF*WID2
16972 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+
16973 & FGZPF*WID2
16974 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
16975 & MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2
16976 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+
16977 & FZZPF*WID2
16978 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
16979 & MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2
16980 ENDIF
16981 ENDIF
16982 290 CONTINUE
16983 IF(MINT(61).GE.1) ICASE=3-ICASE
16984 IF(ICASE.EQ.2) GOTO 280
16985
16986 ELSEIF(KFLA.EQ.34) THEN
16987C...W'+/-:
16988 FAC=(AEM/(24D0*XW))*SHR
16989 DO 300 I=1,MDCY(KC,3)
16990 IDC=I+MDCY(KC,2)-1
16991 IF(MDME(IDC,1).LT.0) GOTO 300
16992 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16993 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16994 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300
16995 WID2=1D0
16996 IF(I.LE.20) THEN
16997 IF(I.LE.16) THEN
16998C...W'+/- -> q + qbar'
16999 FCOF=3D0*RADC*(PARU(131)**2+PARU(132)**2)*
17000 & VCKM((I-1)/4+1,MOD(I-1,4)+1)
17001 IF(KFLR.GT.0) THEN
17002 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
17003 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
17004 IF(I.GE.13) WID2=WID2*WIDS(7,3)
17005 ELSE
17006 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
17007 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
17008 IF(I.GE.13) WID2=WID2*WIDS(7,2)
17009 ENDIF
17010 ELSEIF(I.LE.20) THEN
17011C...W'+/- -> l+/- + nu
17012 FCOF=PARU(133)**2+PARU(134)**2
17013 IF(KFLR.GT.0) THEN
17014 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
17015 ELSE
17016 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
17017 ENDIF
17018 ENDIF
17019 WDTP(I)=FAC*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)*
17020 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17021 ELSEIF(I.EQ.21) THEN
17022C...W'+/- -> W+/- + Z0
17023 WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)*
17024 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17025 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
17026 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2)
17027 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2)
17028 ELSEIF(I.EQ.23) THEN
17029C...W'+/- -> W+/- + h0
17030 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17031 WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM
17032 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
17033 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
17034 ENDIF
17035 WDTP(I)=FUDGE*WDTP(I)
17036 WDTP(0)=WDTP(0)+WDTP(I)
17037 IF(MDME(IDC,1).GT.0) THEN
17038 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17039 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17040 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17041 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17042 ENDIF
17043 300 CONTINUE
17044
17045 ELSEIF(KFLA.EQ.37) THEN
17046C...H+/-:
17047 IF(MSTP(49).EQ.0) THEN
17048 SHFS=SH
17049 ELSE
17050 SHFS=PMAS(37,1)**2
17051 ENDIF
17052 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
17053 DO 310 I=1,MDCY(KC,3)
17054 IDC=I+MDCY(KC,2)-1
17055 IF(MDME(IDC,1).LT.0) GOTO 310
17056 KFC1=PYCOMP(KFDP(IDC,1))
17057 KFC2=PYCOMP(KFDP(IDC,2))
17058 RM1=PMAS(KFC1,1)**2/SH
17059 RM2=PMAS(KFC2,1)**2/SH
17060 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310
17061 WID2=1D0
17062 IF(I.LE.4) THEN
17063C...H+/- -> q + qbar'
17064 RM1R=PYMRUN(KFDP(IDC,1),SH)**2/SH
17065 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
17066 WDTP(I)=FAC*3D0*RADC*MAX(0D0,(RM1R*PARU(141)**2+
17067 & RM2R/PARU(141)**2)*(1D0-RM1R-RM2R)-4D0*RM1R*RM2R)*
17068 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
17069 IF(KFLR.GT.0) THEN
17070 IF(I.EQ.3) WID2=WIDS(6,2)
17071 IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2)
17072 ELSE
17073 IF(I.EQ.3) WID2=WIDS(6,3)
17074 IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3)
17075 ENDIF
17076 ELSEIF(I.LE.8) THEN
17077C...H+/- -> l+/- + nu
17078 WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)*
17079 & (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0,
17080 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
17081 IF(KFLR.GT.0) THEN
17082 IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2)
17083 ELSE
17084 IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3)
17085 ENDIF
17086 ELSEIF(I.EQ.9) THEN
17087C...H+/- -> W+/- + h0.
17088 WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0,
17089 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17090 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
17091 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
17092
17093CMRENNA++
17094 ELSE
17095C...Add in SUSY decays (two-body) by rescaling by phase space factor.
17096 RM10=RM1*SH/PMR**2
17097 RM20=RM2*SH/PMR**2
17098 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
17099 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
17100 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
17101 WFAC=0D0
17102 ELSE
17103 WFAC=WFAC/WFAC0
17104 ENDIF
17105 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
17106CMRENNA--
17107 KSGN1=2
17108 IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3
17109 KSGN2=2
17110 IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3
17111 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
17112 ENDIF
17113 WDTP(I)=FUDGE*WDTP(I)
17114 WDTP(0)=WDTP(0)+WDTP(I)
17115 IF(MDME(IDC,1).GT.0) THEN
17116 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17117 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17118 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17119 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17120 ENDIF
17121 310 CONTINUE
17122
17123 ELSEIF(KFLA.EQ.41) THEN
17124C...R:
17125 FAC=(AEM/(12D0*XW))*SHR
17126 DO 320 I=1,MDCY(KC,3)
17127 IDC=I+MDCY(KC,2)-1
17128 IF(MDME(IDC,1).LT.0) GOTO 320
17129 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17130 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17131 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320
17132 WID2=1D0
17133 IF(I.LE.6) THEN
17134C...R -> q + qbar'
17135 FCOF=3D0*RADC
17136 ELSEIF(I.LE.9) THEN
17137C...R -> l+ + l'-
17138 FCOF=1D0
17139 ENDIF
17140 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
17141 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17142 IF(KFLR.GT.0) THEN
17143 IF(I.EQ.4) WID2=WIDS(6,3)
17144 IF(I.EQ.5) WID2=WIDS(7,3)
17145 IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3)
17146 IF(I.EQ.9) WID2=WIDS(17,3)
17147 ELSE
17148 IF(I.EQ.4) WID2=WIDS(6,2)
17149 IF(I.EQ.5) WID2=WIDS(7,2)
17150 IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2)
17151 IF(I.EQ.9) WID2=WIDS(17,2)
17152 ENDIF
17153 WDTP(I)=FUDGE*WDTP(I)
17154 WDTP(0)=WDTP(0)+WDTP(I)
17155 IF(MDME(IDC,1).GT.0) THEN
17156 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17157 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17158 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17159 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17160 ENDIF
17161 320 CONTINUE
17162
17163 ELSEIF(KFLA.EQ.42) THEN
17164C...LQ (leptoquark).
17165 FAC=(AEM/4D0)*PARU(151)*SHR
17166 DO 330 I=1,MDCY(KC,3)
17167 IDC=I+MDCY(KC,2)-1
17168 IF(MDME(IDC,1).LT.0) GOTO 330
17169 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17170 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17171 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330
17172 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17173 WID2=1D0
17174 ILQQ=KFDP(IDC,1)*ISIGN(1,KFLR)
17175 IF(ILQQ.GE.6) WID2=WIDS(ILQQ,2)
17176 IF(ILQQ.LE.-6) WID2=WIDS(-ILQQ,3)
17177 ILQL=KFDP(IDC,2)*ISIGN(1,KFLR)
17178 IF(ILQL.GE.17) WID2=WID2*WIDS(ILQL,2)
17179 IF(ILQL.LE.-17) WID2=WID2*WIDS(-ILQL,3)
17180 WDTP(I)=FUDGE*WDTP(I)
17181 WDTP(0)=WDTP(0)+WDTP(I)
17182 IF(MDME(IDC,1).GT.0) THEN
17183 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17184 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17185 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17186 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17187 ENDIF
17188 330 CONTINUE
17189
17190 ELSEIF(KFLA.EQ.KTECHN+111.OR.KFLA.EQ.KTECHN+221) THEN
17191C...Techni-pi0 and techni-pi0':
17192 FAC=(1D0/(32D0*PARU(1)*PARP(142)**2))*SHR
17193 DO 340 I=1,MDCY(KC,3)
17194 IDC=I+MDCY(KC,2)-1
17195 IF(MDME(IDC,1).LT.0) GOTO 340
17196 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
17197 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
17198 RM1=PM1**2/SH
17199 RM2=PM2**2/SH
17200 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340
17201 WID2=1D0
17202C...pi_tc -> g + g
17203 IF(I.EQ.8) THEN
17204 FACP=(AS/(4D0*PARU(1))*PARP(144)/PARP(142))**2
17205 & /(8D0*PARU(1))*SH*SHR
17206 IF(KFLA.EQ.KTECHN+111) THEN
17207 FACP=FACP*PARP(149)
17208 ELSE
17209 FACP=FACP*PARP(150)
17210 ENDIF
17211 WDTP(I)=FACP
17212 ELSE
17213C...pi_tc -> f + fbar.
17214 FCOF=1D0
17215 IKA=IABS(KFDP(IDC,1))
17216 IF(IKA.LT.10) FCOF=3D0*RADC
17217 HM1=PM1
17218 HM2=PM2
17219 IF(IKA.GE.4.AND.IKA.LE.6) THEN
17220 FCOF=FCOF*PARP(141+IKA)**2
17221 HM1=PYMRUN(KFDP(IDC,1),SH)
17222 HM2=PYMRUN(KFDP(IDC,2),SH)
17223 ELSEIF(IKA.EQ.15) THEN
17224 FCOF=FCOF*PARP(148)**2
17225 ENDIF
17226 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
17227 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17228 ENDIF
17229 WDTP(I)=FUDGE*WDTP(I)
17230 WDTP(0)=WDTP(0)+WDTP(I)
17231 IF(MDME(IDC,1).GT.0) THEN
17232 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17233 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17234 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17235 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17236 ENDIF
17237 340 CONTINUE
17238
17239 ELSEIF(KFLA.EQ.KTECHN+211) THEN
17240C...pi+_tc
17241 FAC=(1D0/(32D0*PARU(1)*PARP(142)**2))*SHR
17242 DO 350 I=1,MDCY(KC,3)
17243 IDC=I+MDCY(KC,2)-1
17244 IF(MDME(IDC,1).LT.0) GOTO 350
17245 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
17246 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
17247 PM3=0D0
17248 IF(I.EQ.5) PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
17249 RM1=PM1**2/SH
17250 RM2=PM2**2/SH
17251 RM3=PM3**2/SH
17252 IF(SQRT(RM1)+SQRT(RM2)+SQRT(RM3).GT.1D0) GOTO 350
17253 WID2=1D0
17254C...pi_tc -> f + f'.
17255 FCOF=1D0
17256 IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
17257C...pi_tc+ -> W b b~
17258 IF(I.EQ.5.AND.SHR.LT.PMAS(6,1)+PMAS(5,1)) THEN
17259 FCOF=3D0*RADC
17260 XMT2=PMAS(6,1)**2/SH
17261 FACP=FAC/(4D0*PARU(1))*FCOF*XMT2*PARP(147)**2
17262 KFC3=PYCOMP(KFDP(IDC,3))
17263 CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3)
17264 CHECK = SQRT(RM1)
17265 T0 = (1D0-CHECK**2)*
17266 & (XMT2*(6D0*XMT2**2+3D0*XMT2*RM1-4D0*RM1**2)-
17267 & (5D0*XMT2**2+2D0*XMT2*RM1-8D0*RM1**2))/(4D0*XMT2**2)
17268 T1 = (1D0-XMT2)*(RM1-XMT2)*((XMT2**2+XMT2*RM1+4D0*RM1**2)
17269 & -3D0*XMT2**2*(XMT2+RM1))/(2D0*XMT2**3)
17270 T3 = RM1**2/XMT2**3*(3D0*XMT2-4D0*RM1+4D0*XMT2*RM1)
17271 WDTP(I)=FACP*(T0 + T1*LOG((XMT2-CHECK**2)/(XMT2-1D0))
17272 & +T3*LOG(CHECK))
17273 IF(KFLR.GT.0) THEN
17274 WID2=WIDS(24,2)
17275 ELSE
17276 WID2=WIDS(24,3)
17277 ENDIF
17278 ELSE
17279 FCOF=1D0
17280 IKA=IABS(KFDP(IDC,1))
17281 IF(IKA.LT.10) FCOF=3D0*RADC
17282 HM1=PM1
17283 HM2=PM2
17284 IF(I.GE.1.AND.I.LE.5) THEN
17285 IF(I.LE.2) THEN
17286 FCOF=FCOF*PARP(145)**2
17287 ELSEIF(I.LE.4) THEN
17288 FCOF=FCOF*PARP(146)**2
17289 ELSEIF(I.EQ.5) THEN
17290 FCOF=FCOF*PARP(147)**2
17291 ENDIF
17292 HM1=PYMRUN(KFDP(IDC,1),SH)
17293 HM2=PYMRUN(KFDP(IDC,2),SH)
17294 ELSEIF(I.EQ.8) THEN
17295 FCOF=FCOF*PARP(148)**2
17296 ENDIF
17297 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
17298 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17299 ENDIF
17300 WDTP(I)=FUDGE*WDTP(I)
17301 WDTP(0)=WDTP(0)+WDTP(I)
17302 IF(MDME(IDC,1).GT.0) THEN
17303 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17304 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17305 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17306 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17307 ENDIF
17308 350 CONTINUE
17309
17310 ELSEIF(KFLA.EQ.KTECHN+331) THEN
17311C...Techni-eta.
17312 FAC=(SH/PARP(46)**2)*SHR
17313 DO 360 I=1,MDCY(KC,3)
17314 IDC=I+MDCY(KC,2)-1
17315 IF(MDME(IDC,1).LT.0) GOTO 360
17316 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17317 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17318 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360
17319 WID2=1D0
17320 IF(I.LE.2) THEN
17321 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1))
17322 IF(I.EQ.2) WID2=WIDS(6,1)
17323 ELSE
17324 WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3)
17325 ENDIF
17326 WDTP(I)=FUDGE*WDTP(I)
17327 WDTP(0)=WDTP(0)+WDTP(I)
17328 IF(MDME(IDC,1).GT.0) THEN
17329 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17330 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17331 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17332 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17333 ENDIF
17334 360 CONTINUE
17335
17336 ELSEIF(KFLA.EQ.KTECHN+113) THEN
17337C...Techni-rho0:
17338 ALPRHT=2.91D0*(3D0/PARP(144))
17339 FAC=(ALPRHT/12D0)*SHR
17340 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
17341 SQMZ=PMAS(23,1)**2
17342 SQMW=PMAS(24,1)**2
17343 SHP=SH
17344 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
17345 GMMZ=SHR*WDTPP(0)
17346 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
17347 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
17348 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
17349 DO 370 I=1,MDCY(KC,3)
17350 IDC=I+MDCY(KC,2)-1
17351 IF(MDME(IDC,1).LT.0) GOTO 370
17352 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17353 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17354 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370
17355 WID2=1D0
17356 IF(I.EQ.1) THEN
17357C...rho_tc0 -> W+ + W-.
17358 WDTP(I)=FAC*PARP(141)**4*
17359 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17360 WID2=WIDS(24,1)
17361 ELSEIF(I.EQ.2) THEN
17362C...rho_tc0 -> W+ + pi_tc-.
17363 WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
17364 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
17365 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
17366 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
17367 & (1D0-PARP(141)**2)/4D0/XW/24D0/PARP(138)**2*SHR**3
17368 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
17369 ELSEIF(I.EQ.3) THEN
17370C...rho_tc0 -> pi_tc+ + W-.
17371 WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
17372 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
17373 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
17374 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
17375 & (1D0-PARP(141)**2)/4D0/XW/24D0/PARP(138)**2*SHR**3
17376 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(24,3)
17377 ELSEIF(I.EQ.4) THEN
17378C...rho_tc0 -> pi_tc+ + pi_tc-.
17379 WDTP(I)=FAC*(1D0-PARP(141)**2)**2*
17380 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17381 WID2=WIDS(PYCOMP(KTECHN+211),1)
17382 ELSEIF(I.EQ.5) THEN
17383C...rho_tc0 -> gamma + pi_tc0
17384 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17385 & (2D0*PARP(143)-1D0)**2*(1D0-PARP(141)**2)/24D0/PARP(137)**2*
17386 & SHR**3
17387 WID2=WIDS(PYCOMP(KTECHN+111),2)
17388 ELSEIF(I.EQ.6) THEN
17389C...rho_tc0 -> gamma + pi_tc0'
17390 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17391 & (1D0-PARP(139)**2)/24D0/PARP(137)**2*SHR**3
17392 WID2=WIDS(PYCOMP(KTECHN+221),2)
17393 ELSEIF(I.EQ.7) THEN
17394C...rho_tc0 -> Z0 + pi_tc0
17395 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17396 & (2D0*PARP(143)-1D0)**2*(1D0-PARP(141)**2)/24D0/PARP(137)**2*
17397 & XW/XW1*SHR**3
17398 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
17399 ELSEIF(I.EQ.8) THEN
17400C...rho_tc0 -> Z0 + pi_tc0'
17401 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17402 & (1D0-PARP(139)**2)/24D0/PARP(137)**2*(1D0-2D0*XW)**2/4D0/
17403 & XW/XW1*SHR**3
17404 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
17405 ELSE
17406C...rho_tc0 -> f + fbar.
17407 WID2=1D0
17408 IF(I.LE.16) THEN
17409 IA=I-8
17410 FCOF=3D0*RADC
17411 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
17412 ELSE
17413 IA=I-6
17414 FCOF=1D0
17415 IF(IA.GE.17) WID2=WIDS(IA,1)
17416 ENDIF
17417 EI=KCHG(IA,1)/3D0
17418 AI=SIGN(1D0,EI+0.1D0)
17419 VI=AI-4D0*EI*XWV
17420 VALI=0.5D0*(VI+AI)
17421 VARI=0.5D0*(VI-AI)
17422 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
17423 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
17424 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
17425 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
17426 ENDIF
17427 WDTP(I)=FUDGE*WDTP(I)
17428 WDTP(0)=WDTP(0)+WDTP(I)
17429 IF(MDME(IDC,1).GT.0) THEN
17430 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17431 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17432 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17433 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17434 ENDIF
17435 370 CONTINUE
17436
17437 ELSEIF(KFLA.EQ.KTECHN+213) THEN
17438C...Techni-rho+/-:
17439 ALPRHT=2.91D0*(3D0/PARP(144))
17440 FAC=(ALPRHT/12D0)*SHR
17441 SQMZ=PMAS(23,1)**2
17442 SQMW=PMAS(24,1)**2
17443 SHP=SH
17444 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
17445 GMMW=SHR*WDTPP(0)
17446 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
17447 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
17448 DO 380 I=1,MDCY(KC,3)
17449 IDC=I+MDCY(KC,2)-1
17450 IF(MDME(IDC,1).LT.0) GOTO 380
17451 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17452 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17453 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380
17454 WID2=1D0
17455 IF(I.EQ.1) THEN
17456C...rho_tc+ -> W+ + Z0.
17457 WDTP(I)=FAC*PARP(141)**4*
17458 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17459 IF(KFLR.GT.0) THEN
17460 WID2=WIDS(24,2)*WIDS(23,2)
17461 ELSE
17462 WID2=WIDS(24,3)*WIDS(23,2)
17463 ENDIF
17464 ELSEIF(I.EQ.2) THEN
17465C...rho_tc+ -> W+ + pi_tc0.
17466 WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
17467 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
17468 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
17469 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
17470 & (1D0-PARP(141)**2)/4D0/XW/24D0/PARP(138)**2*SHR**3
17471 IF(KFLR.GT.0) THEN
17472 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+111),2)
17473 ELSE
17474 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+111),2)
17475 ENDIF
17476 ELSEIF(I.EQ.3) THEN
17477C...rho_tc+ -> pi_tc+ + Z0.
17478 WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
17479 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
17480 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
17481 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMZ/SH)*
17482 & (1D0-PARP(141)**2)/4D0/XW/XW1/24D0/PARP(138)**2*SHR**3+
17483 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17484 & (2D0*PARP(143)-1D0)**2*(1D0-PARP(141)**2)/24D0/PARP(137)**2*
17485 & SHR**3*XW/XW1
17486 IF(KFLR.GT.0) THEN
17487 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(23,2)
17488 ELSE
17489 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(23,2)
17490 ENDIF
17491 ELSEIF(I.EQ.4) THEN
17492C...rho_tc+ -> pi_tc+ + pi_tc0.
17493 WDTP(I)=FAC*(1D0-PARP(141)**2)**2*
17494 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17495 IF(KFLR.GT.0) THEN
17496 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(PYCOMP(KTECHN+111),2)
17497 ELSE
17498 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(PYCOMP(KTECHN+111),2)
17499 ENDIF
17500 ELSEIF(I.EQ.5) THEN
17501C...rho_tc+ -> pi_tc+ + gamma
17502 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17503 & (2D0*PARP(143)-1D0)**2*(1D0-PARP(141)**2)/24D0/PARP(137)**2*
17504 & SHR**3
17505 IF(KFLR.GT.0) THEN
17506 WID2=WIDS(PYCOMP(KTECHN+211),2)
17507 ELSE
17508 WID2=WIDS(PYCOMP(KTECHN+211),3)
17509 ENDIF
17510 ELSEIF(I.EQ.6) THEN
17511C...rho_tc+ -> W+ + pi_tc0'
17512 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17513 & (1D0-PARP(139)**2)/4D0/XW/24D0/PARP(137)**2*SHR**3
17514 IF(KFLR.GT.0) THEN
17515 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+221),2)
17516 ELSE
17517 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+221),2)
17518 ENDIF
17519 ELSE
17520C...rho_tc+ -> f + fbar'.
17521 IA=I-6
17522 WID2=1D0
17523 IF(IA.LE.16) THEN
17524 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
17525 IF(KFLR.GT.0) THEN
17526 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
17527 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
17528 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
17529 ELSE
17530 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
17531 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
17532 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
17533 ENDIF
17534 ELSE
17535 FCOF=1D0
17536 IF(KFLR.GT.0) THEN
17537 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
17538 ELSE
17539 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
17540 ENDIF
17541 ENDIF
17542 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
17543 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17544 ENDIF
17545 WDTP(I)=FUDGE*WDTP(I)
17546 WDTP(0)=WDTP(0)+WDTP(I)
17547 IF(MDME(IDC,1).GT.0) THEN
17548 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17549 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17550 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17551 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17552 ENDIF
17553 380 CONTINUE
17554
17555 ELSEIF(KFLA.EQ.KTECHN+223) THEN
17556C...Techni-omega:
17557 ALPRHT=2.91D0*(3D0/PARP(144))
17558 FAC=(ALPRHT/12D0)*SHR
17559 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR*(2D0*PARP(143)-1D0)**2
17560 SQMZ=PMAS(23,1)**2
17561 SHP=SH
17562 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
17563 GMMZ=SHR*WDTPP(0)
17564 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
17565 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
17566 DO 390 I=1,MDCY(KC,3)
17567 IDC=I+MDCY(KC,2)-1
17568 IF(MDME(IDC,1).LT.0) GOTO 390
17569 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17570 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17571 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390
17572 WID2=1D0
17573 IF(I.EQ.1) THEN
17574C...omega_tc0 -> gamma + pi_tc0.
17575 WDTP(I)=AEM/24D0/PARP(137)**2*(1D0-PARP(141)**2)*
17576 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*SHR**3
17577 WID2=WIDS(PYCOMP(KTECHN+111),2)
17578 ELSEIF(I.EQ.2) THEN
17579C...omega_tc0 -> Z0 + pi_tc0
17580 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17581 & (1D0-PARP(141)**2)/24D0/PARP(137)**2*(1D0-2D0*XW)**2/4D0/
17582 & XW/XW1*SHR**3
17583 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
17584 ELSEIF(I.EQ.3) THEN
17585C...omega_tc0 -> gamma + pi_tc0'
17586 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17587 & (2D0*PARP(143)-1D0)**2*(1D0-PARP(139)**2)/24D0/PARP(137)**2*
17588 & SHR**3
17589 WID2=WIDS(PYCOMP(KTECHN+221),2)
17590 ELSEIF(I.EQ.4) THEN
17591C...omega_tc0 -> Z0 + pi_tc0'
17592 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17593 & (2D0*PARP(143)-1D0)**2*(1D0-PARP(139)**2)/24D0/PARP(137)**2*
17594 & XW/XW1*SHR**3
17595 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
17596 ELSEIF(I.EQ.5) THEN
17597C...omega_tc0 -> W+ + pi_tc-
17598 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17599 & (1D0-PARP(141)**2)/4D0/XW/24D0/PARP(137)**2*SHR**3+
17600 & FAC*PARP(141)**2*(1D0-PARP(141)**2)*PARP(140)**2*
17601 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17602 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
17603 ELSEIF(I.EQ.6) THEN
17604C...omega_tc0 -> pi_tc+ + W-
17605 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17606 & (1D0-PARP(141)**2)/4D0/XW/24D0/PARP(137)**2*SHR**3+
17607 & FAC*PARP(141)**2*(1D0-PARP(141)**2)*PARP(140)**2*
17608 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17609 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
17610 ELSEIF(I.EQ.7) THEN
17611C...omega_tc0 -> W+ + W-.
17612 WDTP(I)=FAC*PARP(141)**4*PARP(140)**2*
17613 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17614 WID2=WIDS(24,1)
17615 ELSEIF(I.EQ.8) THEN
17616C...omega_tc0 -> pi_tc+ + pi_tc-.
17617 WDTP(I)=FAC*(1D0-PARP(141)**2)**2*PARP(140)**2*
17618 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17619 WID2=WIDS(PYCOMP(KTECHN+211),1)
17620 ELSE
17621C...omega_tc0 -> f + fbar.
17622 WID2=1D0
17623 IF(I.LE.14) THEN
17624 IA=I-8
17625 FCOF=3D0*RADC
17626 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
17627 ELSE
17628 IA=I-6
17629 FCOF=1D0
17630 IF(IA.GE.17) WID2=WIDS(IA,1)
17631 ENDIF
17632 EI=KCHG(IA,1)/3D0
17633 AI=SIGN(1D0,EI+0.1D0)
17634 VI=AI-4D0*EI*XWV
17635 VALI=0.5D0*(VI+AI)
17636 VARI=0.5D0*(VI-AI)
17637 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
17638 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
17639 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
17640 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
17641 ENDIF
17642 WDTP(I)=FUDGE*WDTP(I)
17643 WDTP(0)=WDTP(0)+WDTP(I)
17644 IF(MDME(IDC,1).GT.0) THEN
17645 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17646 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17647 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17648 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17649 ENDIF
17650 390 CONTINUE
17651
17652C.....V8 -> quark anti-quark
17653 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
17654 FAC=AS/6D0*SHR
17655 TANT3=ABS(PARP(155))
17656 IF(PARP(155).GT.0) THEN
17657 IMDL=1
17658 ELSE
17659 IMDL=2
17660 ENDIF
17661 DO 400 I=1,MDCY(KC,3)
17662 IDC=I+MDCY(KC,2)-1
17663 IF(MDME(IDC,1).LT.0) GOTO 400
17664 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
17665 RM1=PM1**2/SH
17666 IF(RM1.GT.0.25D0) GOTO 400
17667 WID2=1D0
17668 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
17669 FMIX=1D0/TANT3**2
17670 ELSE
17671 FMIX=TANT3**2
17672 ENDIF
17673 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
17674 IF(I.EQ.6) WID2=WIDS(6,1)
17675 WDTP(I)=FUDGE*WDTP(I)
17676 WDTP(0)=WDTP(0)+WDTP(I)
17677 IF(MDME(IDC,1).GT.0) THEN
17678 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17679 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17680 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17681 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17682 ENDIF
17683 400 CONTINUE
17684
17685 ELSEIF(KFLA.EQ.KTECHN+100111.OR.KFLA.EQ.KTECHN+200111) THEN
17686 FAC=(1D0/(4D0*PARU(1)*PARP(142)**2))*SHR
17687 CLEBF=0D0
17688 DO 410 I=1,MDCY(KC,3)
17689 IDC=I+MDCY(KC,2)-1
17690 IF(MDME(IDC,1).LT.0) GOTO 410
17691 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17692 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17693 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410
17694 WID2=1D0
17695C...pi_tc -> g + g
17696 IF(I.EQ.7) THEN
17697 IF(KFLA.EQ.KTECHN+100111) THEN
17698 CLEBG=4D0/3D0
17699 ELSE
17700 CLEBG=5D0/3D0
17701 ENDIF
17702 FACP=(AS/(8D0*PARU(1))*PARP(144)/PARP(142))**2
17703 & /(2D0*PARU(1))*SH*SHR*CLEBG
17704 WDTP(I)=FACP
17705 ELSE
17706C...pi_tc -> f + fbar.
17707 IF(I.EQ.6) WID2=WIDS(6,1)
17708 FCOF=1D0
17709 IKA=IABS(KFDP(IDC,1))
17710 IF(IKA.LT.10) FCOF=3D0*RADC
17711 HM1=PYMRUN(KFDP(IDC,1),SH)
17712 WDTP(I)=FAC*FCOF*HM1**2*CLEBF*
17713 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17714 ENDIF
17715 WDTP(I)=FUDGE*WDTP(I)
17716 WDTP(0)=WDTP(0)+WDTP(I)
17717 IF(MDME(IDC,1).GT.0) THEN
17718 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17719 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17720 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17721 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17722 ENDIF
17723 410 CONTINUE
17724
17725 ELSEIF(KFLA.GE.KTECHN+100113.AND.KFLA.LE.KTECHN+400113) THEN
17726 FAC=AS/6D0*SHR
17727 ALPRHT=2.91D0*(3D0/PARP(144))
17728 TANT3=ABS(PARP(155))
17729 SIN2T=2D0*TANT3/(TANT3**2+1D0)
17730 SINT3=TANT3/SQRT(TANT3**2+1D0)
17731 CSXPP=1D0/SQRT(2D0)
17732 RM82=PARP(156)**2
17733 X12=(1D0/SQRT(2D0)*1D0/SQRT(2D0)+
17734 & 1D0/SQRT(2D0)*1D0/SQRT(2D0))/SQRT(2D0)
17735 X21=1D-6
17736 X11=(.25D0*((1D0/SQRT(2D0))**2+(1D0/SQRT(2D0))**2+2D0)-
17737 & SINT3**2)*2D0
17738 X22=(.25D0*((1D0/SQRT(2D0))**2+(1D0/SQRT(2D0))**2)-
17739 & SINT3**2)*2D0
17740 IF(PARP(155).GT.0) THEN
17741 IMDL=1
17742 ELSE
17743 IMDL=2
17744 ENDIF
17745 DO 420 I=1,MDCY(KC,3)
17746 IF(I.EQ.7.AND.(KFLA.EQ.KTECHN+200113.OR.
17747 & KFLA.EQ.KTECHN+300113)) GOTO 420
17748 IDC=I+MDCY(KC,2)-1
17749 IF(MDME(IDC,1).LT.0) GOTO 420
17750 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17751 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17752 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 420
17753 WID2=1D0
17754 IF(I.LE.6) THEN
17755 IF(I.EQ.6) WID2=WIDS(6,1)
17756 XIG=1D0
17757 IF(KFLA.EQ.KTECHN+200113) THEN
17758 XIG=0D0
17759 XIJ=X12
17760 ELSEIF(KFLA.EQ.KTECHN+300113) THEN
17761 XIG=0D0
17762 XIJ=X21
17763 ELSEIF(KFLA.EQ.KTECHN+100113) THEN
17764 XIJ=X11
17765 ELSE
17766 XIJ=X22
17767 ENDIF
17768 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
17769 FMIX=1D0/TANT3/SIN2T
17770 ELSE
17771 FMIX=-TANT3/SIN2T
17772 ENDIF
17773 XFAC=(XIG+FMIX*XIJ)**2
17774 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*AS/ALPRHT*XFAC
17775 ELSEIF(I.EQ.7) THEN
17776 WDTP(I)=SHR*AS**2/(2D0*ALPRHT)
17777 ELSEIF(KFLA.EQ.KTECHN+400113.AND.I.LE.9) THEN
17778 PSH=SHR*(1D0-RM1)/2D0
17779 WDTP(I)=AS/9D0*PSH**3/RM82
17780 IF(I.EQ.8) THEN
17781 WDTP(I)=2D0*WDTP(I)*CSXPP**2
17782 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
17783 ELSE
17784 WDTP(I)=5D0*WDTP(I)
17785 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
17786 ENDIF
17787 ENDIF
17788 WDTP(I)=FUDGE*WDTP(I)
17789 WDTP(0)=WDTP(0)+WDTP(I)
17790 IF(MDME(IDC,1).GT.0) THEN
17791 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17792 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17793 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17794 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17795 ENDIF
17796 420 CONTINUE
17797
17798 ELSEIF(KFLA.EQ.KEXCIT+1) THEN
17799C...d* excited quark.
17800 FAC=(SH/PARU(155)**2)*SHR
17801 DO 430 I=1,MDCY(KC,3)
17802 IDC=I+MDCY(KC,2)-1
17803 IF(MDME(IDC,1).LT.0) GOTO 430
17804 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17805 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17806 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 430
17807 WID2=1D0
17808 IF(I.EQ.1) THEN
17809C...d* -> g + d.
17810 WDTP(I)=FAC*AS*PARU(159)**2/3D0
17811 WID2=1D0
17812 ELSEIF(I.EQ.2) THEN
17813C...d* -> gamma + d.
17814 QF=-PARU(157)/2D0+PARU(158)/6D0
17815 WDTP(I)=FAC*AEM*QF**2/4D0
17816 WID2=1D0
17817 ELSEIF(I.EQ.3) THEN
17818C...d* -> Z0 + d.
17819 QF=-PARU(157)*XW1/2D0-PARU(158)*XW/6D0
17820 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
17821 & (1D0-RM1)**2*(2D0+RM1)
17822 WID2=WIDS(23,2)
17823 ELSEIF(I.EQ.4) THEN
17824C...d* -> W- + u.
17825 WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
17826 & (1D0-RM1)**2*(2D0+RM1)
17827 IF(KFLR.GT.0) WID2=WIDS(24,3)
17828 IF(KFLR.LT.0) WID2=WIDS(24,2)
17829 ENDIF
17830 WDTP(I)=FUDGE*WDTP(I)
17831 WDTP(0)=WDTP(0)+WDTP(I)
17832 IF(MDME(IDC,1).GT.0) THEN
17833 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17834 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17835 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17836 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17837 ENDIF
17838 430 CONTINUE
17839
17840 ELSEIF(KFLA.EQ.KEXCIT+2) THEN
17841C...u* excited quark.
17842 FAC=(SH/PARU(155)**2)*SHR
17843 DO 440 I=1,MDCY(KC,3)
17844 IDC=I+MDCY(KC,2)-1
17845 IF(MDME(IDC,1).LT.0) GOTO 440
17846 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17847 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17848 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 440
17849 WID2=1D0
17850 IF(I.EQ.1) THEN
17851C...u* -> g + u.
17852 WDTP(I)=FAC*AS*PARU(159)**2/3D0
17853 WID2=1D0
17854 ELSEIF(I.EQ.2) THEN
17855C...u* -> gamma + u.
17856 QF=PARU(157)/2D0+PARU(158)/6D0
17857 WDTP(I)=FAC*AEM*QF**2/4D0
17858 WID2=1D0
17859 ELSEIF(I.EQ.3) THEN
17860C...u* -> Z0 + u.
17861 QF=PARU(157)*XW1/2D0-PARU(158)*XW/6D0
17862 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
17863 & (1D0-RM1)**2*(2D0+RM1)
17864 WID2=WIDS(23,2)
17865 ELSEIF(I.EQ.4) THEN
17866C...u* -> W+ + d.
17867 WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
17868 & (1D0-RM1)**2*(2D0+RM1)
17869 IF(KFLR.GT.0) WID2=WIDS(24,2)
17870 IF(KFLR.LT.0) WID2=WIDS(24,3)
17871 ENDIF
17872 WDTP(I)=FUDGE*WDTP(I)
17873 WDTP(0)=WDTP(0)+WDTP(I)
17874 IF(MDME(IDC,1).GT.0) THEN
17875 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17876 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17877 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17878 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17879 ENDIF
17880 440 CONTINUE
17881
17882 ELSEIF(KFLA.EQ.KEXCIT+11) THEN
17883C...e* excited lepton.
17884 FAC=(SH/PARU(155)**2)*SHR
17885 DO 450 I=1,MDCY(KC,3)
17886 IDC=I+MDCY(KC,2)-1
17887 IF(MDME(IDC,1).LT.0) GOTO 450
17888 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17889 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17890 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 450
17891 WID2=1D0
17892 IF(I.EQ.1) THEN
17893C...e* -> gamma + e.
17894 QF=-PARU(157)/2D0-PARU(158)/2D0
17895 WDTP(I)=FAC*AEM*QF**2/4D0
17896 WID2=1D0
17897 ELSEIF(I.EQ.2) THEN
17898C...e* -> Z0 + e.
17899 QF=-PARU(157)*XW1/2D0+PARU(158)*XW/2D0
17900 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
17901 & (1D0-RM1)**2*(2D0+RM1)
17902 WID2=WIDS(23,2)
17903 ELSEIF(I.EQ.3) THEN
17904C...e* -> W- + nu.
17905 WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
17906 & (1D0-RM1)**2*(2D0+RM1)
17907 IF(KFLR.GT.0) WID2=WIDS(24,3)
17908 IF(KFLR.LT.0) WID2=WIDS(24,2)
17909 ENDIF
17910 WDTP(I)=FUDGE*WDTP(I)
17911 WDTP(0)=WDTP(0)+WDTP(I)
17912 IF(MDME(IDC,1).GT.0) THEN
17913 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17914 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17915 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17916 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17917 ENDIF
17918 450 CONTINUE
17919
17920 ELSEIF(KFLA.EQ.KEXCIT+12) THEN
17921C...nu*_e excited neutrino.
17922 FAC=(SH/PARU(155)**2)*SHR
17923 DO 460 I=1,MDCY(KC,3)
17924 IDC=I+MDCY(KC,2)-1
17925 IF(MDME(IDC,1).LT.0) GOTO 460
17926 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17927 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17928 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 460
17929 WID2=1D0
17930 IF(I.EQ.1) THEN
17931C...nu*_e -> Z0 + nu*_e.
17932 QF=PARU(157)*XW1/2D0+PARU(158)*XW/2D0
17933 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
17934 & (1D0-RM1)**2*(2D0+RM1)
17935 WID2=WIDS(23,2)
17936 ELSEIF(I.EQ.2) THEN
17937C...nu*_e -> W+ + e.
17938 WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
17939 & (1D0-RM1)**2*(2D0+RM1)
17940 IF(KFLR.GT.0) WID2=WIDS(24,2)
17941 IF(KFLR.LT.0) WID2=WIDS(24,3)
17942 ENDIF
17943 WDTP(I)=FUDGE*WDTP(I)
17944 WDTP(0)=WDTP(0)+WDTP(I)
17945 IF(MDME(IDC,1).GT.0) THEN
17946 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17947 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17948 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17949 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17950 ENDIF
17951 460 CONTINUE
17952
17953 ELSEIF(KFLA.EQ.KDIMEN+39) THEN
17954C...G* (graviton resonance):
17955 FAC=(PARP(50)**2/PARU(1))*SHR
17956 DO 470 I=1,MDCY(KC,3)
17957 IDC=I+MDCY(KC,2)-1
17958 IF(MDME(IDC,1).LT.0) GOTO 470
17959 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17960 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17961 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 470
17962 WID2=1D0
17963 IF(I.LE.8) THEN
17964C...G* -> q + qbar
17965 FCOF=3D0*RADC
17966 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
17967 & PYHFTH(SH,SH*RM1,1D0)
17968 WDTP(I)=FAC*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
17969 & (1D0+8D0*RM1/3D0)/320D0
17970 IF(I.EQ.6) WID2=WIDS(6,1)
17971 IF(I.EQ.7.OR.I.EQ.8) WID2=WIDS(I,1)
17972 ELSEIF(I.LE.16) THEN
17973C...G* -> l+ + l-, nu + nubar
17974 FCOF=1D0
17975 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
17976 & (1D0+8D0*RM1/3D0)/320D0
17977 IF(I.EQ.15.OR.I.EQ.16) WID2=WIDS(2+I,1)
17978 ELSEIF(I.EQ.17) THEN
17979C...G* -> g + g.
17980 WDTP(I)=FAC/20D0
17981 ELSEIF(I.EQ.18) THEN
17982C...G* -> gamma + gamma.
17983 WDTP(I)=FAC/160D0
17984 ELSEIF(I.EQ.19) THEN
17985C...G* -> Z0 + Z0.
17986 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
17987 & 14D0*RM1/3D0+4D0*RM1**2)/160D0
17988 WID2=WIDS(23,1)
17989 ELSEIF(I.EQ.20) THEN
17990C...G* -> W+ + W-.
17991 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
17992 & 14D0*RM1/3D0+4D0*RM1**2)/80D0
17993 WID2=WIDS(24,1)
17994 ENDIF
17995 WDTP(I)=FUDGE*WDTP(I)
17996 WDTP(0)=WDTP(0)+WDTP(I)
17997 IF(MDME(IDC,1).GT.0) THEN
17998 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17999 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18000 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18001 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18002 ENDIF
18003 470 CONTINUE
18004
18005 ELSEIF(KFLA.EQ.9900012.OR.KFLA.EQ.9900014.OR.KFLA.EQ.9900016) THEN
18006C...nu_eR, nu_muR, nu_tauR: righthanded Majorana neutrinos.
18007 PMWR=MAX(1.001D0*SHR,PMAS(PYCOMP(9900024),1))
18008 FAC=(AEM**2/(768D0*PARU(1)*XW**2))*SHR**5/PMWR**4
18009 DO 480 I=1,MDCY(KC,3)
18010 IDC=I+MDCY(KC,2)-1
18011 IF(MDME(IDC,1).LT.0) GOTO 480
18012 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
18013 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
18014 PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
18015 IF(PM1+PM2+PM3.GE.SHR) GOTO 480
18016 WID2=1D0
18017 IF(I.LE.9) THEN
18018C...nu_lR -> l- qbar q'
18019 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
18020 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
18021 ELSEIF(I.LE.18) THEN
18022C...nu_lR -> l+ q qbar'
18023 FCOF=3D0*RADC*VCKM((I-10)/3+1,MOD(I-10,3)+1)
18024 IF(MOD(I-9,3).EQ.0) WID2=WIDS(6,3)
18025 ELSE
18026C...nu_lR -> l- l'+ nu_lR' + charge conjugate.
18027 FCOF=1D0
18028 WID2=WIDS(PYCOMP(KFDP(IDC,3)),2)
18029 ENDIF
18030 X=(PM1+PM2+PM3)/SHR
18031 FX=1D0-8D0*X**2+8D0*X**6-X**8-24D0*X**4*LOG(X)
18032 Y=(SHR/PMWR)**2
18033 FY=(12D0*(1D0-Y)*LOG(1D0-Y)+12D0*Y-6D0*Y**2-2D0*Y**3)/Y**4
18034 WDTP(I)=FAC*FCOF*FX*FY
18035 WDTP(I)=FUDGE*WDTP(I)
18036 WDTP(0)=WDTP(0)+WDTP(I)
18037 IF(MDME(IDC,1).GT.0) THEN
18038 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18039 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18040 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18041 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18042 ENDIF
18043 480 CONTINUE
18044
18045 ELSEIF(KFLA.EQ.9900023) THEN
18046C...Z_R0:
18047 FAC=(AEM/(48D0*XW*XW1*(1D0-2D0*XW)))*SHR
18048 DO 490 I=1,MDCY(KC,3)
18049 IDC=I+MDCY(KC,2)-1
18050 IF(MDME(IDC,1).LT.0) GOTO 490
18051 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18052 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18053 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 490
18054 WID2=1D0
18055 SYMMET=1D0
18056 IF(I.LE.6) THEN
18057C...Z_R0 -> q + qbar
18058 EF=KCHG(I,1)/3D0
18059 AF=SIGN(1D0,EF+0.1D0)*(1D0-2D0*XW)
18060 VF=SIGN(1D0,EF+0.1D0)-4D0*EF*XW
18061 FCOF=3D0*RADC
18062 IF(I.EQ.6) WID2=WIDS(6,1)
18063 ELSEIF(I.EQ.7.OR.I.EQ.10.OR.I.EQ.13) THEN
18064C...Z_R0 -> l+ + l-
18065 AF=-(1D0-2D0*XW)
18066 VF=-1D0+4D0*XW
18067 FCOF=1D0
18068 ELSEIF(I.EQ.8.OR.I.EQ.11.OR.I.EQ.14) THEN
18069C...Z0 -> nu_L + nu_Lbar, assumed Majorana.
18070 AF=-2D0*XW
18071 VF=0D0
18072 FCOF=1D0
18073 SYMMET=0.5D0
18074 ELSEIF(I.LE.15) THEN
18075C...Z0 -> nu_R + nu_R, assumed Majorana.
18076 AF=2D0*XW1
18077 VF=0D0
18078 FCOF=1D0
18079 WID2=WIDS(PYCOMP(KFDP(IDC,1)),1)
18080 SYMMET=0.5D0
18081 ENDIF
18082 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
18083 & SQRT(MAX(0D0,1D0-4D0*RM1))*SYMMET
18084 WDTP(I)=FUDGE*WDTP(I)
18085 WDTP(0)=WDTP(0)+WDTP(I)
18086 IF(MDME(IDC,1).GT.0) THEN
18087 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18088 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18089 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18090 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18091 ENDIF
18092 490 CONTINUE
18093
18094 ELSEIF(KFLA.EQ.9900024) THEN
18095C...W_R+/-:
18096 FAC=(AEM/(24D0*XW))*SHR
18097 DO 500 I=1,MDCY(KC,3)
18098 IDC=I+MDCY(KC,2)-1
18099 IF(MDME(IDC,1).LT.0) GOTO 500
18100 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18101 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18102 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 500
18103 WID2=1D0
18104 IF(I.LE.9) THEN
18105C...W_R+/- -> q + qbar'
18106 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
18107 IF(KFLR.GT.0) THEN
18108 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
18109 ELSE
18110 IF(MOD(I,3).EQ.0) WID2=WIDS(6,3)
18111 ENDIF
18112 ELSEIF(I.LE.12) THEN
18113C...W_R+/- -> l+/- + nu_R
18114 FCOF=1D0
18115 ENDIF
18116 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
18117 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18118 WDTP(I)=FUDGE*WDTP(I)
18119 WDTP(0)=WDTP(0)+WDTP(I)
18120 IF(MDME(IDC,1).GT.0) THEN
18121 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18122 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18123 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18124 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18125 ENDIF
18126 500 CONTINUE
18127
18128 ELSEIF(KFLA.EQ.9900041) THEN
18129C...H_L++/--:
18130 FAC=(1D0/(8D0*PARU(1)))*SHR
18131 DO 510 I=1,MDCY(KC,3)
18132 IDC=I+MDCY(KC,2)-1
18133 IF(MDME(IDC,1).LT.0) GOTO 510
18134 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18135 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18136 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 510
18137 WID2=1D0
18138 IF(I.LE.6) THEN
18139C...H_L++/-- -> l+/- + l'+/-
18140 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
18141 & (IABS(KFDP(IDC,2))-9)/2)**2
18142 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
18143 ELSEIF(I.EQ.7) THEN
18144C...H_L++/-- -> W_L+/- + W_L+/-
18145 FCOF=0.5D0*PARP(190)**4*PARP(192)**2/PMAS(24,1)**2*
18146 & (3D0*RM1+0.25D0/RM1-1D0)
18147 WID2=WIDS(24,4+(1-KFLS)/2)
18148 ENDIF
18149 WDTP(I)=FAC*FCOF*
18150 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18151 WDTP(I)=FUDGE*WDTP(I)
18152 WDTP(0)=WDTP(0)+WDTP(I)
18153 IF(MDME(IDC,1).GT.0) THEN
18154 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18155 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18156 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18157 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18158 ENDIF
18159 510 CONTINUE
18160
18161 ELSEIF(KFLA.EQ.9900042) THEN
18162C...H_R++/--:
18163 FAC=(1D0/(8D0*PARU(1)))*SHR
18164 DO 520 I=1,MDCY(KC,3)
18165 IDC=I+MDCY(KC,2)-1
18166 IF(MDME(IDC,1).LT.0) GOTO 520
18167 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18168 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18169 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 520
18170 WID2=1D0
18171 IF(I.LE.6) THEN
18172C...H_R++/-- -> l+/- + l'+/-
18173 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
18174 & (IABS(KFDP(IDC,2))-9)/2)**2
18175 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
18176 ELSEIF(I.EQ.7) THEN
18177C...H_R++/-- -> W_R+/- + W_R+/-
18178 FCOF=PARP(191)**2*(3D0*RM1+0.25D0/RM1-1D0)
18179 WID2=WIDS(PYCOMP(9900024),4+(1-KFLS)/2)
18180 ENDIF
18181 WDTP(I)=FAC*FCOF*
18182 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18183 WDTP(I)=FUDGE*WDTP(I)
18184 WDTP(0)=WDTP(0)+WDTP(I)
18185 IF(MDME(IDC,1).GT.0) THEN
18186 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18187 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18188 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18189 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18190 ENDIF
18191 520 CONTINUE
18192
18193 ENDIF
18194 MINT(61)=0
18195 MINT(62)=0
18196 MINT(63)=0
18197 RETURN
18198 END
18199
18200C***********************************************************************
18201
18202C...PYOFSH
18203C...Calculates partial width and differential cross-section maxima
18204C...of channels/processes not allowed on mass-shell, and selects
18205C...masses in such channels/processes.
18206
18207 SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
18208
18209C...Double precision and integer declarations.
18210 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
18211 IMPLICIT INTEGER(I-N)
18212 INTEGER PYK,PYCHGE,PYCOMP
18213C...Commonblocks.
18214 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
18215 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
18216 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
18217 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
18218 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
18219 COMMON/PYINT1/MINT(400),VINT(400)
18220 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
18221 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
18222 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
18223 &/PYINT2/,/PYINT5/
18224C...Local arrays.
18225 DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2),
18226 &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100),
18227 &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:300),
18228 &WDTE(0:300,0:5)
18229
18230C...Find if particles equal, maximum mass, matrix elements, etc.
18231 MINT(51)=0
18232 ISUB=MINT(1)
18233 KFD(1)=IABS(KFD1)
18234 KFD(2)=IABS(KFD2)
18235 MEQL=0
18236 IF(KFD(1).EQ.KFD(2)) MEQL=1
18237 MLM=0
18238 IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0))
18239 IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN
18240 NOFF=44
18241 PMMX=PMMO
18242 ELSE
18243 NOFF=40
18244 PMMX=VINT(1)
18245 IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1))
18246 ENDIF
18247 MMED=0
18248 IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
18249 &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
18250 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR.
18251 &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2
18252 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR.
18253 &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3
18254 LOOP=1
18255
18256C...Find where Breit-Wigners are required, else select discrete masses.
18257 100 DO 110 I=1,2
18258 KFCA=PYCOMP(KFD(I))
18259 IF(KFCA.GT.0) THEN
18260 PMD(I)=PMAS(KFCA,1)
18261 PGD(I)=PMAS(KFCA,2)
18262 ELSE
18263 PMD(I)=0D0
18264 PGD(I)=0D0
18265 ENDIF
18266 IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN
18267 MBW(I)=0
18268 PMG(I)=PMD(I)
18269 RMG(I)=(PMG(I)/PMMX)**2
18270 ELSE
18271 MBW(I)=1
18272 ENDIF
18273 110 CONTINUE
18274
18275C...Find allowed mass range and Breit-Wigner parameters.
18276 DO 120 I=1,2
18277 IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN
18278 PML(I)=PARP(42)
18279 PMU(I)=PMMX-PARP(42)
18280 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
18281 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
18282 ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN
18283 ILM=I
18284 IF(MLM.EQ.2) ILM=3-I
18285 PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42))
18286 IF(MBW(3-I).EQ.0) THEN
18287 PMU(I)=PMMX-PMD(3-I)
18288 ELSE
18289 PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42))
18290 ENDIF
18291 IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=
18292 & MIN(PMU(I),CKIN(NOFF+2*ILM))
18293 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
18294 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
18295 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
18296 IF(MBW(I).EQ.1) THEN
18297 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
18298 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
18299 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
18300 & PGD(I)))
18301 ENDIF
18302 ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN
18303 ILM=I
18304 IF(MLM.EQ.2) ILM=3-I
18305 PML(I)=MAX(CKIN(48+I),PARP(42))
18306 PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42))
18307 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
18308 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
18309 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
18310 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
18311 IF(MBW(I).EQ.1) THEN
18312 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
18313 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
18314 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
18315 & PGD(I)))
18316 ENDIF
18317 ENDIF
18318 120 CONTINUE
18319 IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0))
18320 &THEN
18321 CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses')
18322 MINT(51)=1
18323 RETURN
18324 ENDIF
18325
18326C...Calculation of partial width of resonance.
18327 IF(MOFSH.EQ.1) THEN
18328
18329C..If only one integration, pick that to be the inner.
18330 IF(MBW(1).EQ.0) THEN
18331 PM2=PMD(1)
18332 PMD(1)=PMD(2)
18333 PGD(1)=PGD(2)
18334 PML(1)=PML(2)
18335 PMU(1)=PMU(2)
18336 ELSEIF(MBW(2).EQ.0) THEN
18337 PM2=PMD(2)
18338 ENDIF
18339
18340C...Start outer loop of integration.
18341 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
18342 ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
18343 ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
18344 NPT2=1
18345 XPT2(1)=1D0
18346 INX2(1)=0
18347 FMAX2=0D0
18348 ENDIF
18349 130 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
18350 PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2))
18351 PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S))))
18352 ENDIF
18353 RM2=(PM2/PMMX)**2
18354
18355C...Start inner loop of integration.
18356 PML1=PML(1)
18357 PMU1=MIN(PMU(1),PMMX-PM2)
18358 IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2)
18359 ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
18360 ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
18361 IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN
18362 FUNC2=0D0
18363 GOTO 180
18364 ENDIF
18365 NPT1=1
18366 XPT1(1)=1D0
18367 INX1(1)=0
18368 FMAX1=0D0
18369 140 PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1))
18370 PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S))))
18371 RM1=(PM1/PMMX)**2
18372
18373C...Evaluate function value - inner loop.
18374 FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18375 IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2)
18376 IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+
18377 & RM2**2+10D0*RM1*RM2)
18378 IF(FUNC1.GT.FMAX1) FMAX1=FUNC1
18379 FPT1(NPT1)=FUNC1
18380
18381C...Go to next position in inner loop.
18382 IF(NPT1.EQ.1) THEN
18383 NPT1=NPT1+1
18384 XPT1(NPT1)=0D0
18385 INX1(NPT1)=1
18386 GOTO 140
18387 ELSEIF(NPT1.LE.8) THEN
18388 NPT1=NPT1+1
18389 IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1
18390 ISH1=ISH1+1
18391 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
18392 INX1(NPT1)=INX1(ISH1)
18393 INX1(ISH1)=NPT1
18394 GOTO 140
18395 ELSEIF(NPT1.LT.100) THEN
18396 ISN1=ISH1
18397 150 ISH1=ISH1+1
18398 IF(ISH1.GT.NPT1) ISH1=2
18399 IF(ISH1.EQ.ISN1) GOTO 160
18400 DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1)))
18401 IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150
18402 NPT1=NPT1+1
18403 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
18404 INX1(NPT1)=INX1(ISH1)
18405 INX1(ISH1)=NPT1
18406 GOTO 140
18407 ENDIF
18408
18409C...Calculate integral over inner loop.
18410 160 FSUM1=0D0
18411 DO 170 IPT1=2,NPT1
18412 FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))*
18413 & (XPT1(INX1(IPT1))-XPT1(IPT1))
18414 170 CONTINUE
18415 FUNC2=FSUM1*(ATU1-ATL1)/PARU(1)
18416 180 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
18417 IF(FUNC2.GT.FMAX2) FMAX2=FUNC2
18418 FPT2(NPT2)=FUNC2
18419
18420C...Go to next position in outer loop.
18421 IF(NPT2.EQ.1) THEN
18422 NPT2=NPT2+1
18423 XPT2(NPT2)=0D0
18424 INX2(NPT2)=1
18425 GOTO 130
18426 ELSEIF(NPT2.LE.8) THEN
18427 NPT2=NPT2+1
18428 IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1
18429 ISH2=ISH2+1
18430 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
18431 INX2(NPT2)=INX2(ISH2)
18432 INX2(ISH2)=NPT2
18433 GOTO 130
18434 ELSEIF(NPT2.LT.100) THEN
18435 ISN2=ISH2
18436 190 ISH2=ISH2+1
18437 IF(ISH2.GT.NPT2) ISH2=2
18438 IF(ISH2.EQ.ISN2) GOTO 200
18439 DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2)))
18440 IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190
18441 NPT2=NPT2+1
18442 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
18443 INX2(NPT2)=INX2(ISH2)
18444 INX2(ISH2)=NPT2
18445 GOTO 130
18446 ENDIF
18447
18448C...Calculate integral over outer loop.
18449 200 FSUM2=0D0
18450 DO 210 IPT2=2,NPT2
18451 FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))*
18452 & (XPT2(INX2(IPT2))-XPT2(IPT2))
18453 210 CONTINUE
18454 FSUM2=FSUM2*(ATU2-ATL2)/PARU(1)
18455 IF(MEQL.EQ.1) FSUM2=2D0*FSUM2
18456 ELSE
18457 FSUM2=FUNC2
18458 ENDIF
18459
18460C...Save result; second integration for user-selected mass range.
18461 IF(LOOP.EQ.1) WIDW=FSUM2
18462 WID2=FSUM2
18463 IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47)
18464 & .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN
18465 LOOP=2
18466 GOTO 100
18467 ENDIF
18468 RET1=WIDW
18469 RET2=WID2/WIDW
18470
18471C...Select two decay product masses of a resonance.
18472 ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN
18473 220 DO 230 I=1,2
18474 IF(MBW(I).EQ.0) GOTO 230
18475 PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*
18476 & (ATU(I)-ATL(I)))
18477 PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW))))
18478 RMG(I)=(PMG(I)/PMMX)**2
18479 230 CONTINUE
18480 IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
18481 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220
18482
18483C...Weight with matrix element (if none known, use beta factor).
18484 FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2)))
18485 IF(MMED.EQ.1) THEN
18486 WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2))
18487 ELSEIF(MMED.EQ.2) THEN
18488 WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+
18489 & RMG(2)**2+10D0*RMG(1)*RMG(2))
18490 ELSEIF(MMED.EQ.3) THEN
18491 WTBE=FLAM*(RMG(1)+FLAM**2/12D0)
18492 ELSE
18493 WTBE=FLAM
18494 ENDIF
18495 IF(WTBE.LT.PYR(0)) GOTO 220
18496 RET1=PMG(1)
18497 RET2=PMG(2)
18498
18499C...Find suitable set of masses for initialization of 2 -> 2 processes.
18500 ELSEIF(MOFSH.EQ.3) THEN
18501 IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN
18502 PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1)))
18503 PMG(2)=PMD(2)
18504 ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN
18505 PMG(1)=PMD(1)
18506 PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2)))
18507 ELSE
18508 IDIV=-1
18509 240 IDIV=IDIV+1
18510 PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1)))
18511 PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2)))
18512 IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240
18513 ENDIF
18514 RET1=PMG(1)
18515 RET2=PMG(2)
18516
18517C...Evaluate importance of excluded tails of Breit-Wigners.
18518 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
18519 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
18520 IF(MEQL.LE.1) THEN
18521 VINT(80)=1D0
18522 DO 250 I=1,2
18523 IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/
18524 & PARU(1)
18525 250 CONTINUE
18526 ELSE
18527 VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))*
18528 & (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2)))
18529 ENDIF
18530 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND.
18531 & MSTP(43).NE.2) VINT(80)=2D0*VINT(80)
18532 IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80)
18533 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
18534
18535C...Pick one particle to be the lighter (if improves efficiency).
18536 ELSEIF(MOFSH.EQ.4) THEN
18537 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
18538 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
18539 260 IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0))
18540
18541C...Select two masses according to Breit-Wigner + flat in s + 1/s.
18542 DO 270 I=1,2
18543 IF(MBW(I).EQ.0) GOTO 270
18544 PMV=PMU(I)
18545 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
18546 ATV=ATU(I)
18547 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
18548 RBR=PYR(0)
18549 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
18550 & ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR
18551 IF(RBR.LT.0.8D0) THEN
18552 PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I)))
18553 PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR))))
18554 ELSEIF(RBR.LT.0.9D0) THEN
18555 PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2)))
18556 ELSEIF(RBR.LT.1.5D0) THEN
18557 PMG(I)=PML(I)*(PMV/PML(I))**PYR(0)
18558 ELSE
18559 PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)*
18560 & (PMV**2-PML(I)**2))))
18561 ENDIF
18562 270 CONTINUE
18563 IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
18564 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN
18565 IF(MINT(48).EQ.1) THEN
18566 NGEN(0,1)=NGEN(0,1)+1
18567 NGEN(MINT(1),1)=NGEN(MINT(1),1)+1
18568 GOTO 260
18569 ELSE
18570 MINT(51)=1
18571 RETURN
18572 ENDIF
18573 ENDIF
18574 RET1=PMG(1)
18575 RET2=PMG(2)
18576
18577C...Give weight for selected mass distribution.
18578 VINT(80)=1D0
18579 DO 280 I=1,2
18580 IF(MBW(I).EQ.0) GOTO 280
18581 PMV=PMU(I)
18582 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
18583 ATV=ATU(I)
18584 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
18585 F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+
18586 & (PMD(I)*PGD(I))**2)/PARU(1)
18587 F1=1D0
18588 F2=1D0/PMG(I)**2
18589 F3=1D0/PMG(I)**4
18590 FI0=(ATV-ATL(I))/PARU(1)
18591 FI1=PMV**2-PML(I)**2
18592 FI2=2D0*LOG(PMV/PML(I))
18593 FI3=1D0/PML(I)**2-1D0/PMV**2
18594 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
18595 & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
18596 VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+
18597 & 5D0*F3/FI3))
18598 ELSE
18599 VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2))
18600 ENDIF
18601 VINT(80)=VINT(80)*FI0
18602 280 CONTINUE
18603 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
18604 ENDIF
18605
18606 RETURN
18607 END
18608
18609C***********************************************************************
18610
18611C...PYRECO
18612C...Handles the possibility of colour reconnection in W+W- events,
18613C...Based on the main scenarios of the Sjostrand and Khoze study:
18614C...I, II, II', intermediate and instantaneous; plus one model
18615C...along the lines of the Gustafson and Hakkinen: GH.
18616C...Note: also handles Z0 Z0 and W-W+ events, but notation below
18617C...is as if first resonance is W+ and second W-.
18618
18619 SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
18620
18621C...Double precision and integer declarations.
18622 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
18623 IMPLICIT INTEGER(I-N)
18624 INTEGER PYK,PYCHGE,PYCOMP
18625C...Parameter value; number of points in MC integration.
18626 PARAMETER (NPT=100)
18627C...Commonblocks.
18628 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
18629 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
18630 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
18631 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
18632 COMMON/PYINT1/MINT(400),VINT(400)
18633 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
18634C...Local arrays.
18635 DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
18636 &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
18637 &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
18638 &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
18639 &TMC(20),IJOIN(100)
18640
18641C...Functions to give four-product and to do determinants.
18642 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)
18643 DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+
18644 &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+
18645 &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3)
18646
18647C...Only allow fraction of recoupling for GH, intermediate and
18648C...instantaneous.
18649 IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
18650 IF(PYR(0).GT.PARP(120)) RETURN
18651 ENDIF
18652 ISUB=MINT(1)
18653
18654C...Common part for scenarios I, II, II', and GH.
18655 IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
18656 &MSTP(115).EQ.5) THEN
18657
18658C...Read out frequently-used parameters.
18659 PI=PARU(1)
18660 HBAR=PARU(3)
18661 PMW=PMAS(24,1)
18662 IF(ISUB.EQ.22) PMW=PMAS(23,1)
18663 PGW=PMAS(24,2)
18664 IF(ISUB.EQ.22) PGW=PMAS(23,2)
18665 TFRAG=PARP(115)
18666 RHAD=PARP(116)
18667 FACT=PARP(117)
18668 BLOWR=PARP(118)
18669 BLOWT=PARP(119)
18670
18671C...Find range of decay products of the W's.
18672C...Background: the W's are stored in IW1 and IW2.
18673C...Their direct decay products in NSD1+1 through NSD1+4.
18674C...Products after shower (if any) in NSD1+5 through NAFT1
18675C...for first W and in NAFT1+1 through N for the second.
18676 IF(NAFT1.GT.NSD1+4) THEN
18677 NBEG(1)=NSD1+5
18678 NEND(1)=NAFT1
18679 ELSE
18680 NBEG(1)=NSD1+1
18681 NEND(1)=NSD1+2
18682 ENDIF
18683 IF(N.GT.NAFT1) THEN
18684 NBEG(2)=NAFT1+1
18685 NEND(2)=N
18686 ELSE
18687 NBEG(2)=NSD1+3
18688 NEND(2)=NSD1+4
18689 ENDIF
18690
18691C...Rearrange parton shower products along strings.
18692 NOLD=N
18693 CALL PYPREP(NSD1+1)
18694
18695C...Find partons pointing back to W+ and W-; store them with quark
18696C...end of string first.
18697 NNP=0
18698 NNM=0
18699 ISGP=0
18700 ISGM=0
18701 DO 120 I=NOLD+1,N
18702 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
18703 IF(IABS(K(I,2)).GE.22) GOTO 120
18704 IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
18705 IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
18706 NNP=NNP+1
18707 IF(ISGP.EQ.1) THEN
18708 INP(NNP)=I
18709 ELSE
18710 DO 100 I1=NNP,2,-1
18711 INP(I1)=INP(I1-1)
18712 100 CONTINUE
18713 INP(1)=I
18714 ENDIF
18715 IF(K(I,1).EQ.1) ISGP=0
18716 ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
18717 IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
18718 NNM=NNM+1
18719 IF(ISGM.EQ.1) THEN
18720 INM(NNM)=I
18721 ELSE
18722 DO 110 I1=NNM,2,-1
18723 INM(I1)=INM(I1-1)
18724 110 CONTINUE
18725 INM(1)=I
18726 ENDIF
18727 IF(K(I,1).EQ.1) ISGM=0
18728 ENDIF
18729 120 CONTINUE
18730
18731C...Boost to W+W- rest frame (not strictly needed).
18732 DO 130 J=1,3
18733 BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
18734 130 CONTINUE
18735 CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
18736 CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
18737 CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
18738
18739C...Select decay vertices of W+ and W-.
18740 TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/
18741 & SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2)
18742 TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/
18743 & SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2)
18744 GTMAX=MAX(TP,TM)
18745 DO 140 J=1,3
18746 XP(J)=TP*P(IW1,J)/P(IW1,4)
18747 XM(J)=TM*P(IW2,J)/P(IW2,4)
18748 140 CONTINUE
18749
18750C...Begin scenario I specifics.
18751 IF(MSTP(115).EQ.1) THEN
18752
18753C...Reconstruct velocity and direction of W+ string pieces.
18754 DO 170 IIP=1,NNP-1
18755 IF(K(INP(IIP),2).LT.0) GOTO 170
18756 I1=INP(IIP)
18757 I2=INP(IIP+1)
18758 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
18759 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
18760 DO 150 J=1,3
18761 V1(J)=P(I1,J)/P1A
18762 V2(J)=P(I2,J)/P2A
18763 BETP(IIP,J)=0.5D0*(V1(J)+V2(J))
18764 DIRP(IIP,J)=V1(J)-V2(J)
18765 150 CONTINUE
18766 BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2-
18767 & BETP(IIP,3)**2)
18768 DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2)
18769 DO 160 J=1,3
18770 DIRP(IIP,J)=DIRP(IIP,J)/DIRL
18771 160 CONTINUE
18772 170 CONTINUE
18773
18774C...Reconstruct velocity and direction of W- string pieces.
18775 DO 200 IIM=1,NNM-1
18776 IF(K(INM(IIM),2).LT.0) GOTO 200
18777 I1=INM(IIM)
18778 I2=INM(IIM+1)
18779 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
18780 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
18781 DO 180 J=1,3
18782 V1(J)=P(I1,J)/P1A
18783 V2(J)=P(I2,J)/P2A
18784 BETM(IIM,J)=0.5D0*(V1(J)+V2(J))
18785 DIRM(IIM,J)=V1(J)-V2(J)
18786 180 CONTINUE
18787 BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2-
18788 & BETM(IIM,3)**2)
18789 DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2)
18790 DO 190 J=1,3
18791 DIRM(IIM,J)=DIRM(IIM,J)/DIRL
18792 190 CONTINUE
18793 200 CONTINUE
18794
18795C...Loop over number of space-time points.
18796 NACC=0
18797 SUM=0D0
18798 DO 250 IPT=1,NPT
18799
18800C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
18801 R=SQRT(-LOG(PYR(0)))
18802 PHI=2D0*PI*PYR(0)
18803 X=BLOWR*RHAD*R*COS(PHI)
18804 Y=BLOWR*RHAD*R*SIN(PHI)
18805 R=SQRT(-LOG(PYR(0)))
18806 PHI=2D0*PI*PYR(0)
18807 Z=BLOWR*RHAD*R*COS(PHI)
18808 T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI))
18809
18810C...Reject impossible points. Weight for sample distribution.
18811 IF(T**2-X**2-Y**2-Z**2.LT.0D0) GOTO 250
18812 WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)*
18813 & EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2)
18814
18815C...Loop over W+ string pieces and find one with largest weight.
18816 IMAXP=0
18817 WTMAXP=1D-10
18818 XD(1)=X-XP(1)
18819 XD(2)=Y-XP(2)
18820 XD(3)=Z-XP(3)
18821 XD(4)=T-TP
18822 DO 220 IIP=1,NNP-1
18823 IF(K(INP(IIP),2).LT.0) GOTO 220
18824 BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3)
18825 BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4))
18826 DO 210 J=1,3
18827 XB(J)=XD(J)+BEDG*BETP(IIP,J)
18828 210 CONTINUE
18829 XB(4)=BETP(IIP,4)*(XD(4)-BED)
18830 SR2=XB(1)**2+XB(2)**2+XB(3)**2
18831 SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+
18832 & DIRP(IIP,3)*XB(3))**2
18833 WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
18834 & TFRAG**2)
18835 IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0
18836 IF(WTP.GT.WTMAXP) THEN
18837 IMAXP=IIP
18838 WTMAXP=WTP
18839 ENDIF
18840 220 CONTINUE
18841
18842C...Loop over W- string pieces and find one with largest weight.
18843 IMAXM=0
18844 WTMAXM=1D-10
18845 XD(1)=X-XM(1)
18846 XD(2)=Y-XM(2)
18847 XD(3)=Z-XM(3)
18848 XD(4)=T-TM
18849 DO 240 IIM=1,NNM-1
18850 IF(K(INM(IIM),2).LT.0) GOTO 240
18851 BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3)
18852 BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4))
18853 DO 230 J=1,3
18854 XB(J)=XD(J)+BEDG*BETM(IIM,J)
18855 230 CONTINUE
18856 XB(4)=BETM(IIM,4)*(XD(4)-BED)
18857 SR2=XB(1)**2+XB(2)**2+XB(3)**2
18858 SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+
18859 & DIRM(IIM,3)*XB(3))**2
18860 WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
18861 & TFRAG**2)
18862 IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0
18863 IF(WTM.GT.WTMAXM) THEN
18864 IMAXM=IIM
18865 WTMAXM=WTM
18866 ENDIF
18867 240 CONTINUE
18868
18869C...Result of integration.
18870 WT=0D0
18871 IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN
18872 WT=WTMAXP*WTMAXM/WTSMP
18873 SUM=SUM+WT
18874 NACC=NACC+1
18875 IAP(NACC)=IMAXP
18876 IAM(NACC)=IMAXM
18877 WTA(NACC)=WT
18878 ENDIF
18879 250 CONTINUE
18880 RES=BLOWR**3*BLOWT*SUM/NPT
18881
18882C...Decide whether to reconnect and, if so, where.
18883 IACC=0
18884 PREC=1D0-EXP(-FACT*RES)
18885 IF(PREC.GT.PYR(0)) THEN
18886 RSUM=PYR(0)*SUM
18887 DO 260 IA=1,NACC
18888 IACC=IA
18889 RSUM=RSUM-WTA(IA)
18890 IF(RSUM.LE.0D0) GOTO 270
18891 260 CONTINUE
18892 270 IIP=IAP(IACC)
18893 IIM=IAM(IACC)
18894 ENDIF
18895
18896C...Begin scenario II and II' specifics.
18897 ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN
18898
18899C...Loop through all string pieces, one from W+ and one from W-.
18900 NCROSS=0
18901 TC(0)=0D0
18902 DO 340 IIP=1,NNP-1
18903 IF(K(INP(IIP),2).LT.0) GOTO 340
18904 I1P=INP(IIP)
18905 I2P=INP(IIP+1)
18906 DO 330 IIM=1,NNM-1
18907 IF(K(INM(IIM),2).LT.0) GOTO 330
18908 I1M=INM(IIM)
18909 I2M=INM(IIM+1)
18910
18911C...Find endpoint velocity vectors.
18912 DO 280 J=1,3
18913 V1P(J)=P(I1P,J)/P(I1P,4)
18914 V2P(J)=P(I2P,J)/P(I2P,4)
18915 V1M(J)=P(I1M,J)/P(I1M,4)
18916 V2M(J)=P(I2M,J)/P(I2M,4)
18917 280 CONTINUE
18918
18919C...Define q matrix and find t.
18920 DO 290 J=1,3
18921 Q(1,J)=V2P(J)-V1P(J)
18922 Q(2,J)=-(V2M(J)-V1M(J))
18923 Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J)
18924 Q(4,J)=V1P(J)-V1M(J)
18925 290 CONTINUE
18926 T=-DETER(1,2,3)/DETER(1,2,4)
18927
18928C...Find alpha and beta; i.e. coordinates of crossing point.
18929 S11=Q(1,1)*(T-TP)
18930 S12=Q(2,1)*(T-TM)
18931 S13=Q(3,1)+Q(4,1)*T
18932 S21=Q(1,2)*(T-TP)
18933 S22=Q(2,2)*(T-TM)
18934 S23=Q(3,2)+Q(4,2)*T
18935 DEN=S11*S22-S12*S21
18936 ALP=(S12*S23-S22*S13)/DEN
18937 BET=(S21*S13-S11*S23)/DEN
18938
18939C...Check if solution acceptable.
18940 IANSW=1
18941 IF(T.LT.GTMAX) IANSW=0
18942 IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
18943 IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
18944
18945C...Find point of crossing and check that not inconsistent.
18946 DO 300 J=1,3
18947 XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP)
18948 XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM)
18949 300 CONTINUE
18950 D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+
18951 & (XPP(3)-XMM(3))**2
18952 D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2
18953 D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2
18954 IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
18955
18956C...Find string eigentimes at crossing.
18957 IF(IANSW.EQ.1) THEN
18958 TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2-
18959 & (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2))
18960 TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2-
18961 & (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2))
18962 ELSE
18963 TAUP=0D0
18964 TAUM=0D0
18965 ENDIF
18966
18967C...Order crossings by time. End loop over crossings.
18968 IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
18969 NCROSS=NCROSS+1
18970 DO 310 I1=NCROSS,1,-1
18971 IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
18972 IPC(I1)=IIP
18973 IMC(I1)=IIM
18974 TC(I1)=T
18975 TPC(I1)=TAUP
18976 TMC(I1)=TAUM
18977 GOTO 320
18978 ELSE
18979 IPC(I1)=IPC(I1-1)
18980 IMC(I1)=IMC(I1-1)
18981 TC(I1)=TC(I1-1)
18982 TPC(I1)=TPC(I1-1)
18983 TMC(I1)=TMC(I1-1)
18984 ENDIF
18985 310 CONTINUE
18986 320 CONTINUE
18987 ENDIF
18988 330 CONTINUE
18989 340 CONTINUE
18990
18991C...Loop over crossings; find first (if any) acceptable one.
18992 IACC=0
18993 IF(NCROSS.GE.1) THEN
18994 DO 350 IC=1,NCROSS
18995 PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2)
18996 IF(PNFRAG.GT.PYR(0)) THEN
18997C...Scenario II: only compare with fragmentation time.
18998 IF(MSTP(115).EQ.2) THEN
18999 IACC=IC
19000 IIP=IPC(IACC)
19001 IIM=IMC(IACC)
19002 GOTO 360
19003C...Scenario II': also require that string length decreases.
19004 ELSE
19005 IIP=IPC(IC)
19006 IIM=IMC(IC)
19007 I1P=INP(IIP)
19008 I2P=INP(IIP+1)
19009 I1M=INM(IIM)
19010 I2M=INM(IIM+1)
19011 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
19012 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
19013 IF(ELNEW.LT.ELOLD) THEN
19014 IACC=IC
19015 IIP=IPC(IACC)
19016 IIM=IMC(IACC)
19017 GOTO 360
19018 ENDIF
19019 ENDIF
19020 ENDIF
19021 350 CONTINUE
19022 360 CONTINUE
19023 ENDIF
19024
19025C...Begin scenario GH specifics.
19026 ELSEIF(MSTP(115).EQ.5) THEN
19027
19028C...Loop through all string pieces, one from W+ and one from W-.
19029 IACC=0
19030 ELMIN=1D0
19031 DO 380 IIP=1,NNP-1
19032 IF(K(INP(IIP),2).LT.0) GOTO 380
19033 I1P=INP(IIP)
19034 I2P=INP(IIP+1)
19035 DO 370 IIM=1,NNM-1
19036 IF(K(INM(IIM),2).LT.0) GOTO 370
19037 I1M=INM(IIM)
19038 I2M=INM(IIM+1)
19039
19040C...Look for largest decrease of (exponent of) Lambda measure.
19041 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
19042 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
19043 ELDIF=ELNEW/MAX(1D-10,ELOLD)
19044 IF(ELDIF.LT.ELMIN) THEN
19045 IACC=IIP+IIM
19046 ELMIN=ELDIF
19047 IPC(1)=IIP
19048 IMC(1)=IIM
19049 ENDIF
19050 370 CONTINUE
19051 380 CONTINUE
19052 IIP=IPC(1)
19053 IIM=IMC(1)
19054 ENDIF
19055
19056C...Common for scenarios I, II, II' and GH: reconnect strings.
19057 IF(IACC.NE.0) THEN
19058 MINT(32)=1
19059 NJOIN=0
19060 DO 390 IS=1,NNP+NNM
19061 NJOIN=NJOIN+1
19062 IF(IS.LE.IIP) THEN
19063 I=INP(IS)
19064 ELSEIF(IS.LE.IIP+NNM-IIM) THEN
19065 I=INM(IS-IIP+IIM)
19066 ELSEIF(IS.LE.IIP+NNM) THEN
19067 I=INM(IS-IIP-NNM+IIM)
19068 ELSE
19069 I=INP(IS-NNM)
19070 ENDIF
19071 IJOIN(NJOIN)=I
19072 IF(K(I,2).LT.0) THEN
19073 CALL PYJOIN(NJOIN,IJOIN)
19074 NJOIN=0
19075 ENDIF
19076 390 CONTINUE
19077
19078C...Restore original event record if no reconnection.
19079 ELSE
19080 DO 400 I=NSD1+1,NOLD
19081 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
19082 K(I,4)=MOD(K(I,4),MSTU(5)**2)
19083 K(I,5)=MOD(K(I,5),MSTU(5)**2)
19084 ENDIF
19085 400 CONTINUE
19086 DO 410 I=NOLD+1,N
19087 K(K(I,3),1)=3
19088 410 CONTINUE
19089 N=NOLD
19090 ENDIF
19091
19092C...Boost back system.
19093 CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
19094 CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
19095 IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
19096 & BEWW(1),BEWW(2),BEWW(3))
19097
19098C...Common part for intermediate and instantaneous scenarios.
19099 ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
19100 MINT(32)=1
19101
19102C...Remove old shower products and reset showering ones.
19103 N=NSD1+4
19104 DO 420 I=NSD1+1,NSD1+4
19105 K(I,1)=3
19106 K(I,4)=MOD(K(I,4),MSTU(5)**2)
19107 K(I,5)=MOD(K(I,5),MSTU(5)**2)
19108 420 CONTINUE
19109
19110C...Identify quark-antiquark pairs.
19111 IQ1=NSD1+1
19112 IQ2=NSD1+2
19113 IQ3=NSD1+3
19114 IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
19115 IQ4=2*NSD1+7-IQ3
19116
19117C...Reconnect strings.
19118 IJOIN(1)=IQ1
19119 IJOIN(2)=IQ4
19120 CALL PYJOIN(2,IJOIN)
19121 IJOIN(1)=IQ3
19122 IJOIN(2)=IQ2
19123 CALL PYJOIN(2,IJOIN)
19124
19125C...Do new parton showers in intermediate scenario.
19126 IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
19127 MSTJ50=MSTJ(50)
19128 MSTJ(50)=0
19129 CALL PYSHOW(IQ1,IQ2,P(IW1,5))
19130 CALL PYSHOW(IQ3,IQ4,P(IW2,5))
19131 MSTJ(50)=MSTJ50
19132
19133C...Do new parton showers in instantaneous scenario.
19134 ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
19135 PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2-
19136 & (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2
19137 PPM=SQRT(MAX(0D0,PPM2))
19138 CALL PYSHOW(IQ1,IQ4,PPM)
19139 PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2-
19140 & (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2
19141 PPM=SQRT(MAX(0D0,PPM2))
19142 CALL PYSHOW(IQ3,IQ2,PPM)
19143 ENDIF
19144 ENDIF
19145
19146 RETURN
19147 END
19148
19149C***********************************************************************
19150
19151C...PYKLIM
19152C...Checks generated variables against pre-set kinematical limits;
19153C...also calculates limits on variables used in generation.
19154
19155 SUBROUTINE PYKLIM(ILIM)
19156
19157C...Double precision and integer declarations.
19158 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19159 IMPLICIT INTEGER(I-N)
19160 INTEGER PYK,PYCHGE,PYCOMP
19161C...Commonblocks.
19162 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19163 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19164 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19165 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
19166 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
19167 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19168 COMMON/PYINT1/MINT(400),VINT(400)
19169 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
19170 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
19171 &/PYINT1/,/PYINT2/
19172
19173C...Common kinematical expressions.
19174 MINT(51)=0
19175 ISUB=MINT(1)
19176 ISTSB=ISET(ISUB)
19177 IF(ISUB.EQ.96) GOTO 100
19178 SQM3=VINT(63)
19179 SQM4=VINT(64)
19180 IF(ILIM.NE.0) THEN
19181 IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
19182 CKIN09=MAX(CKIN(9),CKIN(13))
19183 CKIN10=MIN(CKIN(10),CKIN(14))
19184 CKIN11=MAX(CKIN(11),CKIN(15))
19185 CKIN12=MIN(CKIN(12),CKIN(16))
19186 ELSE
19187 CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
19188 CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
19189 CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
19190 CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
19191 ENDIF
19192 ENDIF
19193 IF(ILIM.NE.1) THEN
19194 TAU=VINT(21)
19195 RM3=SQM3/(TAU*VINT(2))
19196 RM4=SQM4/(TAU*VINT(2))
19197 BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
19198 ENDIF
19199 PTHMIN=CKIN(3)
19200 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3)
19201 &PTHMIN=MAX(CKIN(3),CKIN(5))
19202
19203 IF(ILIM.EQ.0) THEN
19204C...Check generated values of tau, y*, cos(theta-hat), and tau' against
19205C...pre-set kinematical limits.
19206 YST=VINT(22)
19207 CTH=VINT(23)
19208 TAUP=VINT(26)
19209 TAUE=TAU
19210 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
19211 X1=SQRT(TAUE)*EXP(YST)
19212 X2=SQRT(TAUE)*EXP(-YST)
19213 XF=X1-X2
19214 IF(MINT(47).NE.1) THEN
19215 IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
19216 IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
19217 IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
19218 IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
19219 ENDIF
19220 IF(MINT(45).NE.1) THEN
19221 IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
19222 ENDIF
19223 IF(MINT(46).NE.1) THEN
19224 IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
19225 ENDIF
19226 IF(MINT(45).EQ.2) THEN
19227 IF(X1.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
19228 ENDIF
19229 IF(MINT(46).EQ.2) THEN
19230 IF(X2.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
19231 ENDIF
19232 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
19233 PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2))
19234 EXPY3=MAX(1D-20,(1D0+RM3-RM4+BE34*CTH)/
19235 & MAX(1D-20,(1D0+RM3-RM4-BE34*CTH)))
19236 EXPY4=MAX(1D-20,(1D0-RM3+RM4-BE34*CTH)/
19237 & MAX(1D-20,(1D0-RM3+RM4+BE34*CTH)))
19238 Y3=YST+0.5D0*LOG(EXPY3)
19239 Y4=YST+0.5D0*LOG(EXPY4)
19240 YLARGE=MAX(Y3,Y4)
19241 YSMALL=MIN(Y3,Y4)
19242 ETALAR=20D0
19243 ETASMA=-20D0
19244 STH=SQRT(MAX(0D0,1D0-CTH**2))
19245 EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*
19246 & CTH)**2-4D0*RM3))
19247 EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*
19248 & CTH)**2-4D0*RM4))
19249 IF(STH.GE.1D-10) THEN
19250 EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/
19251 & (BE34*STH)
19252 EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/
19253 & (BE34*STH)
19254 ETA3=LOG(MIN(1D10,MAX(1D-10,EXPET3)))
19255 ETA4=LOG(MIN(1D10,MAX(1D-10,EXPET4)))
19256 ETALAR=MAX(ETA3,ETA4)
19257 ETASMA=MIN(ETA3,ETA4)
19258 ENDIF
19259 CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3
19260 CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4
19261 CTSLAR=MIN(1D0,MAX(-1D0,CTS3,CTS4))
19262 CTSSMA=MAX(-1D0,MIN(1D0,CTS3,CTS4))
19263 SH=TAU*VINT(2)
19264 RPTS=4D0*VINT(71)**2/SH
19265 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
19266 RM34=MAX(1D-20,2D0*RM3*RM4)
19267 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
19268 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
19269 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
19270 THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
19271 UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
19272 IF(PTH.LT.PTHMIN) MINT(51)=1
19273 IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1
19274 IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
19275 IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
19276 IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
19277 IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
19278 IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
19279 IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
19280 IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
19281 IF(THA.LT.CKIN(35)) MINT(51)=1
19282 IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1
19283 IF(UHA.LT.CKIN(37)) MINT(51)=1
19284 IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1
19285 ENDIF
19286 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
19287 IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
19288 IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
19289 ENDIF
19290
19291C...Additional cuts on W2 (approximately) in DIS.
19292 IF(ISUB.EQ.10.AND.MINT(43).GE.2) THEN
19293 XBJ=X2
19294 IF(IABS(MINT(12)).LT.20) XBJ=X1
19295 Q2BJ=THA
19296 W2BJ=Q2BJ*(1D0-XBJ)/XBJ
19297 IF(W2BJ.LT.CKIN(39)) MINT(51)=1
19298 IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1
19299 ENDIF
19300
19301 ELSEIF(ILIM.EQ.1) THEN
19302C...Calculate limits on tau
19303C...0) due to definition
19304 TAUMN0=0D0
19305 TAUMX0=1D0
19306C...1) due to limits on subsystem mass
19307 TAUMN1=CKIN(1)**2/VINT(2)
19308 TAUMX1=1D0
19309 IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2)
19310C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
19311 TM3=SQRT(SQM3+PTHMIN**2)
19312 TM4=SQRT(SQM4+PTHMIN**2)
19313 YDCOSH=1D0
19314 IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12)
19315 TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
19316 TAUMX2=1D0
19317C...3) due to limits on pT-hat and cos(theta-hat)
19318 CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
19319 CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
19320 TAUMN3=0D0
19321 IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3=
19322 & (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+
19323 & SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2)
19324 TAUMX3=1D0
19325 IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3=
19326 & (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+
19327 & SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2)
19328C...4) due to limits on x1 and x2
19329 TAUMN4=CKIN(21)*CKIN(23)
19330 TAUMX4=CKIN(22)*CKIN(24)
19331C...5) due to limits on xF
19332 TAUMN5=0D0
19333 TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26))
19334C...6) due to limits on that and uhat
19335 TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2)
19336 TAUMX6=1D0
19337 IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6=
19338 & (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2)
19339
19340C...Net effect of all separate limits.
19341 VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6)
19342 VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6)
19343 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
19344 VINT(11)=1D0-1D-9
19345 VINT(31)=1D0+1D-9
19346 ELSEIF(MINT(47).EQ.5) THEN
19347 VINT(31)=MIN(VINT(31),1D0-2D-10)
19348 ELSEIF(MINT(47).GE.6) THEN
19349 VINT(31)=MIN(VINT(31),1D0-1D-10)
19350 ENDIF
19351 IF(VINT(31).LE.VINT(11)) MINT(51)=1
19352
19353 ELSEIF(ILIM.EQ.2) THEN
19354C...Calculate limits on y*
19355 TAUE=TAU
19356 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
19357 TAURT=SQRT(TAUE)
19358C...0) due to kinematics
19359 YSTMN0=LOG(TAURT)
19360 YSTMX0=-YSTMN0
19361C...1) due to explicit limits
19362 YSTMN1=CKIN(7)
19363 YSTMX1=CKIN(8)
19364C...2) due to limits on x1
19365 YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT)
19366 YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT)
19367C...3) due to limits on x2
19368 YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT)
19369 YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT)
19370C...4) due to limits on xF
19371 YEPMN4=0.5D0*ABS(CKIN(25))/TAURT
19372 YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25))
19373 YEPMX4=0.5D0*ABS(CKIN(26))/TAURT
19374 YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26))
19375C...5) due to simultaneous limits on y-large and y-small
19376 YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11)
19377 YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12)
19378 YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN)))
19379 YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX)))
19380 YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN)
19381 YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX)
19382C...6) due to simultaneous limits on cos(theta-hat) and y-large or
19383C... y-small
19384 CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2))))
19385 RZMN=BE34*MAX(CKIN(27),-CTHLIM)
19386 RZMX=BE34*MIN(CKIN(28),CTHLIM)
19387 YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX)
19388 YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN)
19389 YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN)
19390 YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX)
19391 YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX))
19392 YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN))
19393
19394C...Net effect of all separate limits.
19395 VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
19396 VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
19397 IF(MINT(47).EQ.1) THEN
19398 VINT(12)=-1D-9
19399 VINT(32)=1D-9
19400 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
19401 VINT(12)=(1D0-1D-9)*YSTMX0
19402 VINT(32)=(1D0+1D-9)*YSTMX0
19403 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
19404 VINT(12)=-(1D0+1D-9)*YSTMX0
19405 VINT(32)=-(1D0-1D-9)*YSTMX0
19406 ELSEIF(MINT(47).EQ.5) THEN
19407 YSTEE=LOG((1D0-1D-10)/TAURT)
19408 VINT(12)=MAX(VINT(12),-YSTEE)
19409 VINT(32)=MIN(VINT(32),YSTEE)
19410 ENDIF
19411 IF(VINT(32).LE.VINT(12)) MINT(51)=1
19412
19413 ELSEIF(ILIM.EQ.3) THEN
19414C...Calculate limits on cos(theta-hat)
19415 YST=VINT(22)
19416C...0) due to definition
19417 CTNMN0=-1D0
19418 CTNMX0=0D0
19419 CTPMN0=0D0
19420 CTPMX0=1D0
19421C...1) due to explicit limits
19422 CTNMN1=MIN(0D0,CKIN(27))
19423 CTNMX1=MIN(0D0,CKIN(28))
19424 CTPMN1=MAX(0D0,CKIN(27))
19425 CTPMX1=MAX(0D0,CKIN(28))
19426C...2) due to limits on pT-hat
19427 CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2))))
19428 CTPMX2=-CTNMN2
19429 CTNMX2=0D0
19430 CTPMN2=0D0
19431 IF(CKIN(4).GE.0D0) THEN
19432 CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/
19433 & (BE34**2*TAU*VINT(2))))
19434 CTPMN2=-CTNMX2
19435 ENDIF
19436C...3) due to limits on y-large and y-small
19437 CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST),
19438 & -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST)))
19439 CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST),
19440 & -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST))
19441 CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST),
19442 & -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST))
19443 CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST),
19444 & -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST)))
19445C...4) due to limits on that
19446 CTNMN4=-1D0
19447 CTNMX4=0D0
19448 CTPMN4=0D0
19449 CTPMX4=1D0
19450 SH=TAU*VINT(2)
19451 IF(CKIN(35).GT.0D0) THEN
19452 CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34
19453 IF(CTLIM.GT.0D0) THEN
19454 CTPMX4=CTLIM
19455 ELSE
19456 CTPMX4=0D0
19457 CTNMX4=CTLIM
19458 ENDIF
19459 ENDIF
19460 IF(CKIN(36).GT.0D0) THEN
19461 CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34
19462 IF(CTLIM.LT.0D0) THEN
19463 CTNMN4=CTLIM
19464 ELSE
19465 CTNMN4=0D0
19466 CTPMN4=CTLIM
19467 ENDIF
19468 ENDIF
19469C...5) due to limits on uhat
19470 CTNMN5=-1D0
19471 CTNMX5=0D0
19472 CTPMN5=0D0
19473 CTPMX5=1D0
19474 IF(CKIN(37).GT.0D0) THEN
19475 CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34
19476 IF(CTLIM.LT.0D0) THEN
19477 CTNMN5=CTLIM
19478 ELSE
19479 CTNMN5=0D0
19480 CTPMN5=CTLIM
19481 ENDIF
19482 ENDIF
19483 IF(CKIN(38).GT.0D0) THEN
19484 CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34
19485 IF(CTLIM.GT.0D0) THEN
19486 CTPMX5=CTLIM
19487 ELSE
19488 CTPMX5=0D0
19489 CTNMX5=CTLIM
19490 ENDIF
19491 ENDIF
19492
19493C...Net effect of all separate limits.
19494 VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5)
19495 VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5)
19496 VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5)
19497 VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5)
19498 IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
19499
19500 ELSEIF(ILIM.EQ.4) THEN
19501C...Calculate limits on tau'
19502C...0) due to kinematics
19503 TAPMN0=TAU
19504 IF(ISTSB.EQ.5.AND.KFPR(ISUB,2).GT.0) THEN
19505 PQRAT=2D0*PMAS(PYCOMP(KFPR(ISUB,2)),1)/VINT(1)
19506 TAPMN0=(SQRT(TAU)+PQRAT)**2
19507 ENDIF
19508 TAPMX0=1D0
19509C...1) due to explicit limits
19510 TAPMN1=CKIN(31)**2/VINT(2)
19511 TAPMX1=1D0
19512 IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2)
19513
19514C...Net effect of all separate limits.
19515 VINT(16)=MAX(TAPMN0,TAPMN1)
19516 VINT(36)=MIN(TAPMX0,TAPMX1)
19517 IF(MINT(47).EQ.1) THEN
19518 VINT(16)=1D0-1D-9
19519 VINT(36)=1D0+1D-9
19520 ELSEIF(MINT(47).EQ.5) THEN
19521 VINT(36)=MIN(VINT(36),1D0-2D-10)
19522 ELSEIF(MINT(47).EQ.6.OR.MINT(47).EQ.7) THEN
19523 VINT(36)=MIN(VINT(36),1D0-1D-10)
19524 ENDIF
19525 IF(VINT(36).LE.VINT(16)) MINT(51)=1
19526
19527 ENDIF
19528 RETURN
19529
19530C...Special case for low-pT and multiple interactions:
19531C...effective kinematical limits for tau, y*, cos(theta-hat).
19532 100 IF(ILIM.EQ.0) THEN
19533 ELSEIF(ILIM.EQ.1) THEN
19534 IF(MSTP(82).LE.1) THEN
19535 VINT(11)=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
19536 & VINT(2)
19537 ELSE
19538 VINT(11)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/VINT(2)
19539 ENDIF
19540 VINT(31)=1D0
19541 ELSEIF(ILIM.EQ.2) THEN
19542 VINT(12)=0.5D0*LOG(VINT(21))
19543 VINT(32)=-VINT(12)
19544 ELSEIF(ILIM.EQ.3) THEN
19545 IF(MSTP(82).LE.1) THEN
19546 ST2EFF=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
19547 & (VINT(21)*VINT(2))
19548 ELSE
19549 ST2EFF=0.01D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
19550 & (VINT(21)*VINT(2))
19551 ENDIF
19552 VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF))
19553 VINT(33)=0D0
19554 VINT(14)=0D0
19555 VINT(34)=-VINT(13)
19556 ENDIF
19557
19558 RETURN
19559 END
19560
19561C*********************************************************************
19562
19563C...PYKMAP
19564C...Maps a uniform distribution into a distribution of a kinematical
19565C...variable according to one of the possibilities allowed. It is
19566C...assumed that kinematical limits have been set by a PYKLIM call.
19567
19568 SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
19569
19570C...Double precision and integer declarations.
19571 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19572 IMPLICIT INTEGER(I-N)
19573 INTEGER PYK,PYCHGE,PYCOMP
19574C...Commonblocks.
19575 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19576 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19577 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
19578 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19579 COMMON/PYINT1/MINT(400),VINT(400)
19580 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
19581 SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
19582
19583C...Convert VVAR to tau variable.
19584 ISUB=MINT(1)
19585 ISTSB=ISET(ISUB)
19586 IF(IVAR.EQ.1) THEN
19587 TAUMIN=VINT(11)
19588 TAUMAX=VINT(31)
19589 IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
19590 TAURE=VINT(73)
19591 GAMRE=VINT(74)
19592 ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
19593 TAURE=VINT(75)
19594 GAMRE=VINT(76)
19595 ENDIF
19596 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
19597 TAU=1D0
19598 ELSEIF(MVAR.EQ.1) THEN
19599 TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
19600 ELSEIF(MVAR.EQ.2) THEN
19601 TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
19602 ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5) THEN
19603 RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
19604 TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
19605 ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6) THEN
19606 AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
19607 ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
19608 TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
19609 ELSEIF(MINT(47).EQ.5) THEN
19610 AUPP=LOG(MAX(2D-10,1D0-TAUMAX))
19611 ALOW=LOG(MAX(2D-10,1D0-TAUMIN))
19612 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
19613 ELSE
19614 AUPP=LOG(MAX(1D-10,1D0-TAUMAX))
19615 ALOW=LOG(MAX(1D-10,1D0-TAUMIN))
19616 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
19617 ENDIF
19618 VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
19619
19620C...Convert VVAR to y* variable.
19621 ELSEIF(IVAR.EQ.2) THEN
19622 YSTMIN=VINT(12)
19623 YSTMAX=VINT(32)
19624 TAUE=VINT(21)
19625 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
19626 IF(MINT(47).EQ.1) THEN
19627 YST=0D0
19628 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
19629 YST=-0.5D0*LOG(TAUE)
19630 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
19631 YST=0.5D0*LOG(TAUE)
19632 ELSEIF(MVAR.EQ.1) THEN
19633 YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
19634 ELSEIF(MVAR.EQ.2) THEN
19635 YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR)
19636 ELSEIF(MVAR.EQ.3) THEN
19637 AUPP=ATAN(EXP(YSTMAX))
19638 ALOW=ATAN(EXP(YSTMIN))
19639 YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
19640 ELSEIF(MVAR.EQ.4) THEN
19641 YST0=-0.5D0*LOG(TAUE)
19642 AUPP=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0))
19643 ALOW=LOG(MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
19644 YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW)))
19645 ELSE
19646 YST0=-0.5D0*LOG(TAUE)
19647 AUPP=LOG(MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
19648 ALOW=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0))
19649 YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0
19650 ENDIF
19651 VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
19652
19653C...Convert VVAR to cos(theta-hat) variable.
19654 ELSEIF(IVAR.EQ.3) THEN
19655 RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2)
19656 RSQM=1D0+RM34
19657 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
19658 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
19659 CTNMIN=VINT(13)
19660 CTNMAX=VINT(33)
19661 CTPMIN=VINT(14)
19662 CTPMAX=VINT(34)
19663 IF(MVAR.EQ.1) THEN
19664 ANEG=CTNMAX-CTNMIN
19665 APOS=CTPMAX-CTPMIN
19666 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
19667 VCTN=VVAR*(ANEG+APOS)/ANEG
19668 CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
19669 ELSE
19670 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
19671 CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
19672 ENDIF
19673 ELSEIF(MVAR.EQ.2) THEN
19674 RMNMIN=MAX(RM34,RSQM-CTNMIN)
19675 RMNMAX=MAX(RM34,RSQM-CTNMAX)
19676 RMPMIN=MAX(RM34,RSQM-CTPMIN)
19677 RMPMAX=MAX(RM34,RSQM-CTPMAX)
19678 ANEG=LOG(RMNMIN/RMNMAX)
19679 APOS=LOG(RMPMIN/RMPMAX)
19680 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
19681 VCTN=VVAR*(ANEG+APOS)/ANEG
19682 CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
19683 ELSE
19684 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
19685 CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
19686 ENDIF
19687 ELSEIF(MVAR.EQ.3) THEN
19688 RMNMIN=MAX(RM34,RSQM+CTNMIN)
19689 RMNMAX=MAX(RM34,RSQM+CTNMAX)
19690 RMPMIN=MAX(RM34,RSQM+CTPMIN)
19691 RMPMAX=MAX(RM34,RSQM+CTPMAX)
19692 ANEG=LOG(RMNMAX/RMNMIN)
19693 APOS=LOG(RMPMAX/RMPMIN)
19694 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
19695 VCTN=VVAR*(ANEG+APOS)/ANEG
19696 CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
19697 ELSE
19698 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
19699 CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
19700 ENDIF
19701 ELSEIF(MVAR.EQ.4) THEN
19702 RMNMIN=MAX(RM34,RSQM-CTNMIN)
19703 RMNMAX=MAX(RM34,RSQM-CTNMAX)
19704 RMPMIN=MAX(RM34,RSQM-CTPMIN)
19705 RMPMAX=MAX(RM34,RSQM-CTPMAX)
19706 ANEG=1D0/RMNMAX-1D0/RMNMIN
19707 APOS=1D0/RMPMAX-1D0/RMPMIN
19708 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
19709 VCTN=VVAR*(ANEG+APOS)/ANEG
19710 CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN)
19711 ELSE
19712 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
19713 CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP)
19714 ENDIF
19715 ELSEIF(MVAR.EQ.5) THEN
19716 RMNMIN=MAX(RM34,RSQM+CTNMIN)
19717 RMNMAX=MAX(RM34,RSQM+CTNMAX)
19718 RMPMIN=MAX(RM34,RSQM+CTPMIN)
19719 RMPMAX=MAX(RM34,RSQM+CTPMAX)
19720 ANEG=1D0/RMNMIN-1D0/RMNMAX
19721 APOS=1D0/RMPMIN-1D0/RMPMAX
19722 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
19723 VCTN=VVAR*(ANEG+APOS)/ANEG
19724 CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM
19725 ELSE
19726 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
19727 CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM
19728 ENDIF
19729 ENDIF
19730 IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
19731 IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
19732 VINT(23)=CTH
19733
19734C...Convert VVAR to tau' variable.
19735 ELSEIF(IVAR.EQ.4) THEN
19736 TAU=VINT(21)
19737 TAUPMN=VINT(16)
19738 TAUPMX=VINT(36)
19739 IF(MINT(47).EQ.1) THEN
19740 TAUP=1D0
19741 ELSEIF(MVAR.EQ.1) THEN
19742 TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
19743 ELSEIF(MVAR.EQ.2) THEN
19744 AUPP=(1D0-TAU/TAUPMX)**4
19745 ALOW=(1D0-TAU/TAUPMN)**4
19746 TAUP=TAU/MAX(1D-10,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0)
19747 ELSEIF(MINT(47).EQ.5) THEN
19748 AUPP=LOG(MAX(2D-10,1D0-TAUPMX))
19749 ALOW=LOG(MAX(2D-10,1D0-TAUPMN))
19750 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
19751 ELSE
19752 AUPP=LOG(MAX(1D-10,1D0-TAUPMX))
19753 ALOW=LOG(MAX(1D-10,1D0-TAUPMN))
19754 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
19755 ENDIF
19756 VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
19757
19758C...Selection of extra variables needed in 2 -> 3 process:
19759C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
19760C...Since no options are available, the functions of PYKLIM
19761C...and PYKMAP are joint for these choices.
19762 ELSEIF(IVAR.EQ.5) THEN
19763
19764C...Read out total energy and particle masses.
19765 MINT(51)=0
19766 MPTPK=1
19767 IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174
19768 & .OR.ISUB.EQ.178.OR.ISUB.EQ.179.OR.ISUB.EQ.351.OR.ISUB.EQ.352)
19769 & MPTPK=2
19770 SHP=VINT(26)*VINT(2)
19771 SHPR=SQRT(SHP)
19772 PM1=VINT(201)
19773 PM2=VINT(206)
19774 PM3=SQRT(VINT(21))*VINT(1)
19775 IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN
19776 MINT(51)=1
19777 RETURN
19778 ENDIF
19779 PMRS1=VINT(204)**2
19780 PMRS2=VINT(209)**2
19781
19782C...Specify coefficients of pT choice; upper and lower limits.
19783 IF(MPTPK.EQ.1) THEN
19784 HWT1=0.4D0
19785 HWT2=0.4D0
19786 ELSE
19787 HWT1=0.05D0
19788 HWT2=0.05D0
19789 ENDIF
19790 HWT3=1D0-HWT1-HWT2
19791 PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/
19792 & (4D0*SHP)
19793 IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
19794 PTSMN1=CKIN(51)**2
19795 PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/
19796 & (4D0*SHP)
19797 IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2)
19798 PTSMN2=CKIN(53)**2
19799
19800C...Select transverse momenta according to
19801C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
19802 HMX=PMRS1+PTSMX1
19803 HMN=PMRS1+PTSMN1
19804 IF(HMX.LT.1.0001D0*HMN) THEN
19805 MINT(51)=1
19806 RETURN
19807 ENDIF
19808 HDE=PTSMX1-PTSMN1
19809 RPT=PYR(0)
19810 IF(RPT.LT.HWT1) THEN
19811 PTS1=PTSMN1+PYR(0)*HDE
19812 ELSEIF(RPT.LT.HWT1+HWT2) THEN
19813 PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1)
19814 ELSE
19815 PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1)
19816 ENDIF
19817 WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+
19818 & HWT3*HMN*HMX/(PMRS1+PTS1)**2)
19819 HMX=PMRS2+PTSMX2
19820 HMN=PMRS2+PTSMN2
19821 IF(HMX.LT.1.0001D0*HMN) THEN
19822 MINT(51)=1
19823 RETURN
19824 ENDIF
19825 HDE=PTSMX2-PTSMN2
19826 RPT=PYR(0)
19827 IF(RPT.LT.HWT1) THEN
19828 PTS2=PTSMN2+PYR(0)*HDE
19829 ELSEIF(RPT.LT.HWT1+HWT2) THEN
19830 PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2)
19831 ELSE
19832 PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2)
19833 ENDIF
19834 WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+
19835 & HWT3*HMN*HMX/(PMRS2+PTS2)**2)
19836
19837C...Select azimuthal angles and check pT choice.
19838 PHI1=PARU(2)*PYR(0)
19839 PHI2=PARU(2)*PYR(0)
19840 PHIR=PHI2-PHI1
19841 PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR))
19842 IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT.
19843 & CKIN(56)**2)) THEN
19844 MINT(51)=1
19845 RETURN
19846 ENDIF
19847
19848C...Calculate transverse masses and check phase space not closed.
19849 PMS1=PM1**2+PTS1
19850 PMS2=PM2**2+PTS2
19851 PMS3=PM3**2+PTS3
19852 PMT1=SQRT(PMS1)
19853 PMT2=SQRT(PMS2)
19854 PMT3=SQRT(PMS3)
19855 PM12=(PMT1+PMT2)**2
19856 IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN
19857 MINT(51)=1
19858 RETURN
19859 ENDIF
19860
19861C...Select rapidity for particle 3 and check phase space not closed.
19862 Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2-
19863 & 4D0*PMS3*PM12)))/(2D0*SHPR*PMT3))
19864 IF(Y3MAX.LT.1D-6) THEN
19865 MINT(51)=1
19866 RETURN
19867 ENDIF
19868 Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX
19869 PZ3=PMT3*SINH(Y3)
19870 PE3=PMT3*COSH(Y3)
19871
19872C...Find momentum transfers in two mirror solutions (in 1-2 frame).
19873 PZ12=-PZ3
19874 PE12=SHPR-PE3
19875 PMS12=PE12**2-PZ12**2
19876 SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2))
19877 IF(SQL12.LT.1D-6*SHP) THEN
19878 MINT(51)=1
19879 RETURN
19880 ENDIF
19881 PMM1=PMS12+PMS1-PMS2
19882 PMM2=PMS12+PMS2-PMS1
19883 TFAC=-SHPR/(2D0*PMS12)
19884 T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12)
19885 T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12)
19886 T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12)
19887 T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12)
19888
19889C...Construct relative mirror weights and make choice.
19890 IF(MPTPK.EQ.1.OR.ISUB.EQ.351.OR.ISUB.EQ.352) THEN
19891 WTPU=1D0
19892 WTNU=1D0
19893 ELSE
19894 WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2
19895 WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2
19896 ENDIF
19897 WTP=WTPU/(WTPU+WTNU)
19898 WTN=WTNU/(WTPU+WTNU)
19899 EPS=1D0
19900 IF(WTN.GT.PYR(0)) EPS=-1D0
19901
19902C...Store result of variable choice and associated weights.
19903 VINT(202)=PTS1
19904 VINT(207)=PTS2
19905 VINT(203)=PHI1
19906 VINT(208)=PHI2
19907 VINT(205)=WTPTS1
19908 VINT(210)=WTPTS2
19909 VINT(211)=Y3
19910 VINT(212)=Y3MAX
19911 VINT(213)=EPS
19912 IF(EPS.GT.0D0) THEN
19913 VINT(214)=1D0/WTP
19914 VINT(215)=T1P
19915 VINT(216)=T2P
19916 ELSE
19917 VINT(214)=1D0/WTN
19918 VINT(215)=T1N
19919 VINT(216)=T2N
19920 ENDIF
19921 VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12)
19922 VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12)
19923 VINT(219)=0.5D0*(PMS12-PTS3)
19924 VINT(220)=SQL12
19925 ENDIF
19926
19927 RETURN
19928 END
19929
19930C***********************************************************************
19931
19932C...PYSIGH
19933C...Differential matrix elements for all included subprocesses
19934C...Note that what is coded is (disregarding the COMFAC factor)
19935C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
19936C...when d(sigma-hat) is given in the zero-width limit, the delta
19937C...function in tau is replaced by a (modified) Breit-Wigner:
19938C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
19939C...where H_res = s-hat/m_res*Gamma_res(s-hat);
19940C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
19941C...i.e., dimensionless quantities
19942C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
19943C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
19944C...(2pi)^4 delta^4(P - sum p_i)
19945C...COMFAC contains the factor pi/s (or equivalent) and
19946C...the conversion factor from GeV^-2 to mb
19947
19948 SUBROUTINE PYSIGH(NCHN,SIGS)
19949
19950C...Double precision and integer declarations
19951 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19952 IMPLICIT INTEGER(I-N)
19953 INTEGER PYK,PYCHGE,PYCOMP
19954C...Parameter statement to help give large particle numbers.
19955 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
19956 &KEXCIT=4000000,KDIMEN=5000000)
19957C...Commonblocks
19958 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19959 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19960 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19961 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
19962 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
19963 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19964 COMMON/PYINT1/MINT(400),VINT(400)
19965 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
19966 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
19967 COMMON/PYINT4/MWID(500),WIDS(500,5)
19968 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
19969 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
19970 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
19971 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
19972 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
19973 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
19974 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
19975 &/PYMSSM/,/PYSSMT/
19976C...Local arrays and complex variables
19977 DIMENSION X(2),XPQ(-25:25),KFAC(2,-40:40),WDTP(0:300),
19978 &WDTE(0:300,0:5),HGZ(6,3),HL3(3),HR3(3),HL4(3),HR4(3)
19979 COMPLEX*16 A004,A204,A114,A00U,A20U,A11U
19980 COMPLEX*16 CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF,
19981 &COULCK,COULCP,COULCD,COULCR,COULCS
19982 REAL*8 A00L,A11L,A20L,COULXX
19983 COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME
19984 COMPLEX*16 DAA,DZZ,DAZ
19985 COMPLEX*16 ZTC(6,6),YTC(6,6),DGGS,DGGT,DGGU
19986 COMPLEX*16 DQQS,DQQT,DQQU,DQTS
19987 COMPLEX*16 DVVS,DVVT,DVVU
19988 COMPLEX*16 OLPP,ORPP,OLP,ORP,OL,OR,QLL,QLR
19989 COMPLEX*16 QRR,QRL,GLIJ,GRIJ,PROPW,PROPZ
19990 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
19991 INTEGER INDX(6)
19992
19993C...Reset number of channels and cross-section
19994 NCHN=0
19995 SIGS=0D0
19996
19997C...Convert H or A process into equivalent h one
19998 ISUB=MINT(1)
19999 ISUBSV=ISUB
20000 IHIGG=1
20001 KFHIGG=25
20002 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
20003 &ISUB.LE.190)) THEN
20004 IHIGG=2
20005 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
20006 KFHIGG=33+IHIGG
20007 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
20008 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
20009 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
20010 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
20011 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
20012 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
20013 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
20014 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
20015 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
20016 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
20017 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
20018 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
20019 ENDIF
20020
20021CMRENNA++
20022C...Convert almost equivalent SUSY processes into each other
20023C...Extract differences in flavours and couplings
20024 IF(ISUB.GE.200.AND.ISUB.LE.301) THEN
20025
20026C...Sleptons and sneutrinos
20027 IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN
20028 KFID=MOD(KFPR(ISUB,1),KSUSY1)
20029 ISUB=201
20030 ILR=0
20031 ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN
20032 KFID=MOD(KFPR(ISUB,1),KSUSY1)
20033 ISUB=201
20034 ILR=1
20035 ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN
20036 KFID=MOD(KFPR(ISUB,1),KSUSY1)
20037 ISUB=203
20038 ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN
20039 IF(ISUB.EQ.210) THEN
20040 RKF=2.0D0
20041 ELSEIF(ISUB.EQ.211) THEN
20042 RKF=SFMIX(15,1)**2
20043 ELSEIF(ISUB.EQ.212) THEN
20044 RKF=SFMIX(15,2)**2
20045 ENDIF
20046 ISUB=210
20047 ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN
20048 IF(ISUB.EQ.213) THEN
20049 KFID=MOD(KFPR(ISUB,1),KSUSY1)
20050 RKF=2.0D0
20051 ELSEIF(ISUB.EQ.214) THEN
20052 KFID=16
20053 RKF=1.0D0
20054 ENDIF
20055 ISUB=213
20056
20057C...Neutralinos
20058 ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN
20059 IF(ISUB.EQ.216) THEN
20060 IZID1=1
20061 IZID2=1
20062 ELSEIF(ISUB.EQ.217) THEN
20063 IZID1=2
20064 IZID2=2
20065 ELSEIF(ISUB.EQ.218) THEN
20066 IZID1=3
20067 IZID2=3
20068 ELSEIF(ISUB.EQ.219) THEN
20069 IZID1=4
20070 IZID2=4
20071 ELSEIF(ISUB.EQ.220) THEN
20072 IZID1=1
20073 IZID2=2
20074 ELSEIF(ISUB.EQ.221) THEN
20075 IZID1=1
20076 IZID2=3
20077 ELSEIF(ISUB.EQ.222) THEN
20078 IZID1=1
20079 IZID2=4
20080 ELSEIF(ISUB.EQ.223) THEN
20081 IZID1=2
20082 IZID2=3
20083 ELSEIF(ISUB.EQ.224) THEN
20084 IZID1=2
20085 IZID2=4
20086 ELSEIF(ISUB.EQ.225) THEN
20087 IZID1=3
20088 IZID2=4
20089 ENDIF
20090 ISUB=216
20091
20092C...Charginos
20093 ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN
20094 IF(ISUB.EQ.226) THEN
20095 IZID1=1
20096 IZID2=1
20097 ELSEIF(ISUB.EQ.227) THEN
20098 IZID1=2
20099 IZID2=2
20100 ELSEIF(ISUB.EQ.228) THEN
20101 IZID1=1
20102 IZID2=2
20103 ENDIF
20104 ISUB=226
20105
20106C...Neutralino + chargino
20107 ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN
20108 IF(ISUB.EQ.229) THEN
20109 IZID1=1
20110 IZID2=1
20111 ELSEIF(ISUB.EQ.230) THEN
20112 IZID1=1
20113 IZID2=2
20114 ELSEIF(ISUB.EQ.231) THEN
20115 IZID1=1
20116 IZID2=3
20117 ELSEIF(ISUB.EQ.232) THEN
20118 IZID1=1
20119 IZID2=4
20120 ELSEIF(ISUB.EQ.233) THEN
20121 IZID1=2
20122 IZID2=1
20123 ELSEIF(ISUB.EQ.234) THEN
20124 IZID1=2
20125 IZID2=2
20126 ELSEIF(ISUB.EQ.235) THEN
20127 IZID1=2
20128 IZID2=3
20129 ELSEIF(ISUB.EQ.236) THEN
20130 IZID1=2
20131 IZID2=4
20132 ENDIF
20133 ISUB=229
20134
20135C...Gluino + neutralino
20136 ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN
20137 IF(ISUB.EQ.237) THEN
20138 IZID=1
20139 ELSEIF(ISUB.EQ.238) THEN
20140 IZID=2
20141 ELSEIF(ISUB.EQ.239) THEN
20142 IZID=3
20143 ELSEIF(ISUB.EQ.240) THEN
20144 IZID=4
20145 ENDIF
20146 ISUB=237
20147
20148C...Gluino + chargino
20149 ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN
20150 IF(ISUB.EQ.241) THEN
20151 IZID=1
20152 ELSEIF(ISUB.EQ.242) THEN
20153 IZID=2
20154 ENDIF
20155 ISUB=241
20156
20157C...Squark + neutralino
20158 ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN
20159 ILR=0
20160 IF(MOD(ISUB,2).NE.0) ILR=1
20161 IF(ISUB.LE.247) THEN
20162 IZID=1
20163 ELSEIF(ISUB.LE.249) THEN
20164 IZID=2
20165 ELSEIF(ISUB.LE.251) THEN
20166 IZID=3
20167 ELSEIF(ISUB.LE.253) THEN
20168 IZID=4
20169 ENDIF
20170 ISUB=246
20171 RKF=5D0
20172
20173C...Squark + chargino
20174 ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN
20175 IF(ISUB.LE.255) THEN
20176 IZID=1
20177 ELSEIF(ISUB.LE.257) THEN
20178 IZID=2
20179 ENDIF
20180 IF(MOD(ISUB,2).EQ.0) THEN
20181 ILR=0
20182 ELSE
20183 ILR=1
20184 ENDIF
20185 ISUB=254
20186 RKF=5D0
20187
20188C...Squark + gluino
20189 ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN
20190 ISUB=258
20191 RKF=4D0
20192
20193C...Stops
20194 ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN
20195 ILR=0
20196 IF(ISUB.EQ.262) ILR=1
20197 ISUB=261
20198 ELSEIF(ISUB.EQ.265) THEN
20199 ISUB=264
20200
20201C...Squarks
20202 ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN
20203 ILR=0
20204 IF(ISUB.LE.273) THEN
20205 IF(ISUB.EQ.273) ILR=1
20206 ISUB=271
20207 RKF=16D0
20208 ELSEIF(ISUB.LE.276) THEN
20209 IF(ISUB.EQ.276) ILR=1
20210 ISUB=274
20211 RKF=16D0
20212 ELSEIF(ISUB.LE.278) THEN
20213 IF(ISUB.EQ.278) ILR=1
20214 ISUB=277
20215 RKF=4D0
20216 ELSE
20217 IF(ISUB.EQ.280) ILR=1
20218 ISUB=279
20219 RKF=4D0
20220 ENDIF
20221C...Sbottoms
20222 ELSEIF(ISUB.GE.281.AND.ISUB.LE.296) THEN
20223 ILR=0
20224 IF(ISUB.LE.283) THEN
20225 IF(ISUB.EQ.283) ILR=1
20226 ISUB=271
20227 RKF=4D0
20228 ELSEIF(ISUB.LE.286) THEN
20229 IF(ISUB.EQ.286) ILR=1
20230 ISUB=274
20231 RKF=4D0
20232 ELSEIF(ISUB.LE.288) THEN
20233 IF(ISUB.EQ.288) ILR=1
20234 ISUB=277
20235 RKF=1D0
20236 ELSEIF(ISUB.LE.290) THEN
20237 IF(ISUB.EQ.290) ILR=1
20238 ISUB=279
20239 RKF=1D0
20240 ELSEIF(ISUB.LE.293) THEN
20241 IF(ISUB.EQ.293) ILR=1
20242 ISUB=271
20243 RKF=1D0
20244 ELSEIF(ISUB.EQ.296) THEN
20245 ILR=1
20246 ISUB=274
20247 RKF=1D0
20248C...Squark + gluino
20249 ELSEIF(ISUB.EQ.294.OR.ISUB.EQ.295) THEN
20250 ISUB=258
20251 RKF=1D0
20252 ENDIF
20253C...H+/- + H0
20254 ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
20255 IF(ISUB.EQ.297) THEN
20256 RKF=.5D0*PARU(195)**2
20257 ELSEIF(ISUB.EQ.298) THEN
20258 RKF=.5D0*(1D0-PARU(195)**2)
20259 ENDIF
20260 ISUB=210
20261C...A0 + H0
20262 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
20263 IF(ISUB.EQ.299) THEN
20264 RKF=PARU(186)**2
20265 KFID=25
20266 ELSEIF(ISUB.EQ.300) THEN
20267 RKF=PARU(187)**2
20268 KFID=35
20269 ENDIF
20270 ISUB=213
20271C...H+ + H-
20272 ELSEIF(ISUB.EQ.301) THEN
20273 KFID=37
20274 RKF=1D0
20275 ISUB=201
20276 ENDIF
20277
20278C...Convert almost equivalent technicolor processes into
20279C...a few basic processes, and set distinguishing parameters.
20280 ELSEIF(ISUB.GE.361.AND.ISUB.LE.379) THEN
20281 SQTV=PARP(137)**2
20282 SQTA=PARP(138)**2
20283 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
20284 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
20285 CSXI=COS(ASIN(PARP(141)))
20286 CSXIP=COS(ASIN(PARP(139)))
20287 QUPD=2D0*PARP(143)-1D0
20288C... rho_tc0 -> W_L W_L
20289 IF(ISUB.EQ.361) THEN
20290 KFA=24
20291 KFB=24
20292 CAB2=PARP(141)**4
20293C... rho_tc0 -> W_L pi_tc-
20294 ELSEIF(ISUB.EQ.362) THEN
20295 KFA=24
20296 KFB=KTECHN+211
20297 ISUB=361
20298 CAB2=PARP(141)**2*(1D0-PARP(141)**2)
20299C... pi_tc pi_tc
20300 ELSEIF(ISUB.EQ.363) THEN
20301 KFA=KTECHN+211
20302 KFB=KTECHN+211
20303 ISUB=361
20304 CAB2=(1D0-PARP(141)**2)**2
20305C... rho_tc0/omega_tc -> gamma pi_tc
20306 ELSEIF(ISUB.EQ.364) THEN
20307 KFA=22
20308 KFB=KTECHN+111
20309 VOGP=CSXI
20310 VRGP=VOGP*QUPD
20311 AOGP=0D0
20312 ARGP=0D0
20313C... gamma pi_tc'
20314 ELSEIF(ISUB.EQ.365) THEN
20315 KFA=22
20316 KFB=KTECHN+221
20317 ISUB=364
20318 VRGP=CSXIP
20319 VOGP=VRGP*QUPD
20320 AOGP=0D0
20321 ARGP=0D0
20322C... Z pi_tc
20323 ELSEIF(ISUB.EQ.366) THEN
20324 KFA=23
20325 KFB=KTECHN+111
20326 ISUB=364
20327 VOGP=CSXI*CT2W
20328 VRGP=-QUPD*CSXI*TANW
20329 AOGP=0D0
20330 ARGP=0D0
20331C... Z pi_tc'
20332 ELSEIF(ISUB.EQ.367) THEN
20333 KFA=23
20334 KFB=KTECHN+221
20335 ISUB=364
20336 VRGP=CSXIP*CT2W
20337 VOGP=-QUPD*CSXIP*TANW
20338 AOGP=0D0
20339 ARGP=0D0
20340C... W_T pi_tc
20341 ELSEIF(ISUB.EQ.368) THEN
20342 KFA=24
20343 KFB=KTECHN+211
20344 ISUB=364
20345 VOGP=CSXI/(2D0*SQRT(PARU(102)))
20346 VRGP=0D0
20347 AOGP=0D0
20348 ARGP=-VOGP
20349C... rho_tc+ -> W_L Z_L
20350 ELSEIF(ISUB.EQ.370) THEN
20351 KFA=24
20352 KFB=23
20353 CAB2=PARP(141)**4
20354C... W_L pi_tc0
20355 ELSEIF(ISUB.EQ.371) THEN
20356 KFA=24
20357 KFB=KTECHN+111
20358 ISUB=370
20359 CAB2=PARP(141)**2*(1D0-PARP(141)**2)
20360C... Z_L pi_tc+
20361 ELSEIF(ISUB.EQ.372) THEN
20362 KFA=KTECHN+211
20363 KFB=23
20364 ISUB=370
20365 CAB2=PARP(141)**2*(1D0-PARP(141)**2)
20366C... pi_tc+ pi_tc0
20367 ELSEIF(ISUB.EQ.373) THEN
20368 KFA=KTECHN+211
20369 KFB=KTECHN+111
20370 ISUB=370
20371 CAB2=(1D0-PARP(141)**2)**2
20372C... gamma pi_tc+
20373 ELSEIF(ISUB.EQ.374) THEN
20374 KFA=KTECHN+211
20375 KFB=22
20376 VRGP=QUPD*CSXI
20377 ARGP=0D0
20378C... Z_T pi_tc+
20379 ELSEIF(ISUB.EQ.375) THEN
20380 KFA=KTECHN+211
20381 KFB=23
20382 ISUB=374
20383 VRGP=-QUPD*CSXI*TANW
20384 ARGP=CSXI/(2D0*SQRT(PARU(102)*(1D0-PARU(102))))
20385C... W_T pi_tc0
20386 ELSEIF(ISUB.EQ.376) THEN
20387 KFA=24
20388 KFB=KTECHN+111
20389 ISUB=374
20390 VRGP=0D0
20391 ARGP=-CSXI/(2D0*SQRT(PARU(102)))
20392C... W_T pi_tc0'
20393 ELSEIF(ISUB.EQ.377) THEN
20394 KFA=24
20395 KFB=KTECHN+221
20396 ISUB=374
20397 ARGP=0D0
20398 VRGP=CSXIP/(2D0*SQRT(PARU(102)))
20399 ENDIF
20400 ENDIF
20401CMRENNA--
20402
20403C...Read kinematical variables and limits
20404 ISTSB=ISET(ISUBSV)
20405 TAUMIN=VINT(11)
20406 YSTMIN=VINT(12)
20407 CTNMIN=VINT(13)
20408 CTPMIN=VINT(14)
20409 TAUPMN=VINT(16)
20410 TAU=VINT(21)
20411 YST=VINT(22)
20412 CTH=VINT(23)
20413 XT2=VINT(25)
20414 TAUP=VINT(26)
20415 TAUMAX=VINT(31)
20416 YSTMAX=VINT(32)
20417 CTNMAX=VINT(33)
20418 CTPMAX=VINT(34)
20419 TAUPMX=VINT(36)
20420
20421C...Derive kinematical quantities
20422 TAUE=TAU
20423 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
20424 X(1)=SQRT(TAUE)*EXP(YST)
20425 X(2)=SQRT(TAUE)*EXP(-YST)
20426 IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN
20427 IF(X(1).GT.1D0-1D-7) RETURN
20428 ELSEIF(MINT(45).EQ.3) THEN
20429 X(1)=MIN(1D0-1.1D-10,X(1))
20430 ENDIF
20431 IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
20432 IF(X(2).GT.1D0-1D-7) RETURN
20433 ELSEIF(MINT(46).EQ.3) THEN
20434 X(2)=MIN(1D0-1.1D-10,X(2))
20435 ENDIF
20436 SH=MAX(1D0,TAU*VINT(2))
20437 SQM3=VINT(63)
20438 SQM4=VINT(64)
20439 RM3=SQM3/SH
20440 RM4=SQM4/SH
20441 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
20442 RPTS=4D0*VINT(71)**2/SH
20443 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
20444 RM34=MAX(1D-20,2D0*RM3*RM4)
20445 RSQM=1D0+RM34
20446 IF(2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)).LT.0.0001D0)
20447 &RM34=MAX(RM34,2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)))
20448 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
20449 IF(ISTSB.EQ.0) THEN
20450 TH=VINT(45)
20451 UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
20452 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
20453 ELSE
20454C...Kinematics with incoming masses tricky: now depends on how
20455C...subprocess has been set up w.r.t. order of incoming partons.
20456 RM1=0D0
20457 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) RM1=-VINT(3)**2/SH
20458 RM2=0D0
20459 IF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) RM2=-VINT(4)**2/SH
20460 IF(ISUB.EQ.35) THEN
20461 RM2=MIN(RM1,RM2)
20462 RM1=0D0
20463 ENDIF
20464 BE12=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
20465 TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4)
20466 TH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM4-2D0*RM2*RM3-
20467 & BE12*BE34*CTH)
20468 UH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM3-2D0*RM2*RM4+
20469 & BE12*BE34*CTH)
20470 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
20471 ENDIF
20472 SHR=SQRT(SH)
20473 SH2=SH**2
20474 TH2=TH**2
20475 UH2=UH**2
20476
20477C...Choice of Q2 scale: hard, parton distributions, parton showers
20478 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
20479 Q2=SH
20480 ELSEIF(ISTSB.EQ.8) THEN
20481 IF(MINT(107).EQ.4) Q2=VINT(307)
20482 IF(MINT(108).EQ.4) Q2=VINT(308)
20483 ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
20484 Q2IN1=0D0
20485 IF(MINT(11).EQ.22.AND.VINT(3).LT.0D0) Q2IN1=VINT(3)**2
20486 Q2IN2=0D0
20487 IF(MINT(12).EQ.22.AND.VINT(4).LT.0D0) Q2IN2=VINT(4)**2
20488 IF(MSTP(32).EQ.1) THEN
20489 Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
20490 ELSEIF(MSTP(32).EQ.2) THEN
20491 Q2=SQPTH+0.5D0*(SQM3+SQM4)
20492 ELSEIF(MSTP(32).EQ.3) THEN
20493 Q2=MIN(-TH,-UH)
20494 ELSEIF(MSTP(32).EQ.4) THEN
20495 Q2=SH
20496 ELSEIF(MSTP(32).EQ.5) THEN
20497 Q2=-TH
20498 ELSEIF(MSTP(32).EQ.6) THEN
20499 XSF1=X(1)
20500 IF(ISTSB.EQ.9) XSF1=X(1)/VINT(143)
20501 XSF2=X(2)
20502 IF(ISTSB.EQ.9) XSF2=X(2)/VINT(144)
20503 Q2=(1D0+XSF1*Q2IN1/SH+XSF2*Q2IN2/SH)*
20504 & (SQPTH+0.5D0*(SQM3+SQM4))
20505 ELSEIF(MSTP(32).EQ.7) THEN
20506 Q2=(1D0+Q2IN1/SH+Q2IN2/SH)*(SQPTH+0.5D0*(SQM3+SQM4))
20507 ELSEIF(MSTP(32).EQ.8) THEN
20508 Q2=SQPTH+0.5D0*(Q2IN1+Q2IN2+SQM3+SQM4)
20509 ELSEIF(MSTP(32).EQ.9) THEN
20510 Q2=SQPTH+Q2IN1+Q2IN2+SQM3+SQM4
20511 ELSEIF(MSTP(32).EQ.10) THEN
20512 Q2=VINT(2)
20513 ENDIF
20514 IF(ISTSB.EQ.9) Q2=SQPTH
20515 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2=Q2+
20516 & (PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
20517 ENDIF
20518 Q2SF=Q2
20519 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
20520 Q2SF=PMAS(23,1)**2
20521 IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124.OR.
20522 & ISUB.EQ.351) Q2SF=PMAS(24,1)**2
20523 IF(ISUB.EQ.352) Q2SF=PMAS(PYCOMP(9900024),1)**2
20524 IF(ISUB.EQ.121.OR.ISUB.EQ.122) THEN
20525 Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
20526 IF(MSTP(39).EQ.2) Q2SF=Q2SF+MAX(VINT(202),VINT(207))
20527 IF(MSTP(39).EQ.3) Q2SF=SH
20528 IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2)
20529 IF(MSTP(39).EQ.5) Q2SF=PMAS(KFHIGG,1)**2
20530 ENDIF
20531 ENDIF
20532 Q2PS=Q2SF
20533 Q2SF=Q2SF*PARP(34)
20534 IF(MSTP(69).GE.1.AND.MINT(47).EQ.5) Q2SF=VINT(2)
20535 IF(MSTP(69).GE.2) Q2SF=VINT(2)
20536 IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND.
20537 &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
20538 XBJ=X(2)
20539 IF(MINT(43).EQ.3) XBJ=X(1)
20540 IF(MSTP(22).EQ.1) THEN
20541 Q2PS=-TH
20542 ELSEIF(MSTP(22).EQ.2) THEN
20543 Q2PS=((1D0-XBJ)/XBJ)*(-TH)
20544 ELSEIF(MSTP(22).EQ.3) THEN
20545 Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH)
20546 ELSE
20547 Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH)
20548 ENDIF
20549 ENDIF
20550 IF(MSTP(68).EQ.1.AND.(ISUBSV.EQ.1.OR.ISUBSV.EQ.2.OR.
20551 &ISUBSV.EQ.102.OR.ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR.
20552 &ISUBSV.EQ.144.OR.ISUBSV.EQ.152.OR.ISUBSV.EQ.157)) THEN
20553 Q2PS=VINT(2)
20554 ELSEIF(MSTP(68).GE.2.AND.(ISUBSV.NE.11.AND.ISUBSV.NE.12.AND.
20555 &ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.ISUBSV.NE.53.AND.
20556 &ISUBSV.NE.68)) THEN
20557 Q2PS=VINT(2)
20558 ENDIF
20559
20560C...Store derived kinematical quantities
20561 VINT(41)=X(1)
20562 VINT(42)=X(2)
20563 VINT(44)=SH
20564 VINT(43)=SQRT(SH)
20565 VINT(45)=TH
20566 VINT(46)=UH
20567 IF(ISTSB.NE.8) VINT(48)=SQPTH
20568 IF(ISTSB.NE.8) VINT(47)=SQRT(SQPTH)
20569 VINT(50)=TAUP*VINT(2)
20570 VINT(49)=SQRT(MAX(0D0,VINT(50)))
20571 VINT(52)=Q2
20572 VINT(51)=SQRT(Q2)
20573 VINT(54)=Q2SF
20574 VINT(53)=SQRT(Q2SF)
20575 VINT(56)=Q2PS
20576 VINT(55)=SQRT(Q2PS)
20577
20578C...Calculate parton distributions
20579 IF(ISTSB.LE.0) GOTO 160
20580 IF(MINT(47).GE.2) THEN
20581 DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
20582 XSF=X(I)
20583 IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
20584 IF(ISUB.EQ.99) THEN
20585 XSF=VINT(309-I)/(VINT(2)+VINT(307)+VINT(308))
20586 Q2SF=VINT(309-I)
20587 ENDIF
20588 MINT(105)=MINT(102+I)
20589 MINT(109)=MINT(106+I)
20590 VINT(120)=VINT(2+I)
20591C.... ALICE
20592C.... Store side in MINT(124)
20593 MINT(124)=I
20594C....
20595 IF(MSTP(57).LE.1) THEN
20596 CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ)
20597 ELSE
20598 CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ)
20599 ENDIF
20600 DO 100 KFL=-25,25
20601 XSFX(I,KFL)=XPQ(KFL)
20602 100 CONTINUE
20603 110 CONTINUE
20604 ENDIF
20605
20606C...Calculate alpha_em, alpha_strong and K-factor
20607 XW=PARU(102)
20608 XWV=XW
20609 IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW=
20610 &1D0-(PMAS(24,1)/PMAS(23,1))**2
20611 XW1=1D0-XW
20612 XWC=1D0/(16D0*XW*XW1)
20613 AEM=PYALEM(Q2)
20614 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
20615 IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2)
20616 FACK=1D0
20617 FACA=1D0
20618 IF(MSTP(33).EQ.1) THEN
20619 FACK=PARP(31)
20620 ELSEIF(MSTP(33).EQ.2) THEN
20621 FACK=PARP(31)
20622 FACA=PARP(32)/PARP(31)
20623 ELSEIF(MSTP(33).EQ.3) THEN
20624 Q2AS=PARP(33)*Q2
20625 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+
20626 & PARU(112)*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
20627 AS=PYALPS(Q2AS)
20628 ENDIF
20629 VINT(138)=1D0
20630 VINT(57)=AEM
20631 VINT(58)=AS
20632
20633C...Set flags for allowed reacting partons/leptons
20634 DO 140 I=1,2
20635 DO 120 J=-25,25
20636 KFAC(I,J)=0
20637 120 CONTINUE
20638 IF(MINT(44+I).EQ.1) THEN
20639 KFAC(I,MINT(10+I))=1
20640 ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN
20641 KFAC(I,MINT(10+I))=1
20642 KFAC(I,22)=1
20643 KFAC(I,24)=1
20644 KFAC(I,-24)=1
20645 ELSE
20646 DO 130 J=-25,25
20647 KFAC(I,J)=KFIN(I,J)
20648 IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0
20649 IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0
20650 130 CONTINUE
20651 ENDIF
20652 140 CONTINUE
20653
20654C...Lower and upper limit for fermion flavour loops
20655 MMIN1=0
20656 MMAX1=0
20657 MMIN2=0
20658 MMAX2=0
20659 DO 150 J=-20,20
20660 IF(KFAC(1,-J).EQ.1) MMIN1=-J
20661 IF(KFAC(1,J).EQ.1) MMAX1=J
20662 IF(KFAC(2,-J).EQ.1) MMIN2=-J
20663 IF(KFAC(2,J).EQ.1) MMAX2=J
20664 150 CONTINUE
20665 MMINA=MIN(MMIN1,MMIN2)
20666 MMAXA=MAX(MMAX1,MMAX2)
20667
20668C...Common resonance mass and width combinations
20669 SQMZ=PMAS(23,1)**2
20670 SQMW=PMAS(24,1)**2
20671 SQMH=PMAS(KFHIGG,1)**2
20672 GMMZ=PMAS(23,1)*PMAS(23,2)
20673 GMMW=PMAS(24,1)*PMAS(24,2)
20674 GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2)
20675C...MRENNA+++
20676 ZWID=PMAS(23,2)
20677 WWID=PMAS(24,2)
20678 TANW=SQRT(XW/XW1)
20679 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
20680C...MRENNA---
20681C...Polarization factors...implemented so far for W+W-(25)
20682 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
20683 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
20684 POLRR=(1D0+PARJ(132))*(1D0+PARJ(131))
20685 POLLL=(1D0-PARJ(132))*(1D0-PARJ(131))
20686
20687C...Phase space integral in tau
20688 COMFAC=PARU(1)*PARU(5)/VINT(2)
20689 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK
20690 IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND.
20691 &ISTSB.NE.8.AND.ISTSB.NE.9) THEN
20692 ATAU1=LOG(TAUMAX/TAUMIN)
20693 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
20694 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
20695 IF(MINT(72).GE.1) THEN
20696 TAUR1=VINT(73)
20697 GAMR1=VINT(74)
20698 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
20699 ATAU3=ATAUD/TAUR1
20700 IF(ATAUD.GT.1D-10) H1=H1+
20701 & (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
20702 ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
20703 ATAU4=ATAUD/GAMR1
20704 IF(ATAUD.GT.1D-10) H1=H1+
20705 & (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
20706 ENDIF
20707 IF(MINT(72).EQ.2) THEN
20708 TAUR2=VINT(75)
20709 GAMR2=VINT(76)
20710 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
20711 ATAU5=ATAUD/TAUR2
20712 IF(ATAUD.GT.1D-10) H1=H1+
20713 & (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
20714 ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
20715 ATAU6=ATAUD/GAMR2
20716 IF(ATAUD.GT.1D-10) H1=H1+
20717 & (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
20718 ENDIF
20719 IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
20720 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
20721 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
20722 & MAX(2D-10,1D0-TAU)
20723 ELSEIF(MINT(47).GE.6.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
20724 ATAU7=LOG(MAX(1D-10,1D0-TAUMIN)/MAX(1D-10,1D0-TAUMAX))
20725 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
20726 & MAX(1D-10,1D0-TAU)
20727 ENDIF
20728 COMFAC=COMFAC*ATAU1/(TAU*H1)
20729 ENDIF
20730
20731C...Phase space integral in y*
20732 IF((MINT(47).EQ.4.OR.MINT(47).EQ.5).AND.ISTSB.NE.8.AND.ISTSB.NE.9)
20733 &THEN
20734 AYST0=YSTMAX-YSTMIN
20735 IF(AYST0.LT.1D-10) THEN
20736 COMFAC=0D0
20737 ELSE
20738 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
20739 AYST2=AYST1
20740 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
20741 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
20742 & (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
20743 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
20744 IF(MINT(45).EQ.3) THEN
20745 YST0=-0.5D0*LOG(TAUE)
20746 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
20747 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
20748 IF(AYST4.GT.1D-10) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
20749 & MAX(1D-10,1D0-EXP(YST-YST0))
20750 ENDIF
20751 IF(MINT(46).EQ.3) THEN
20752 YST0=-0.5D0*LOG(TAUE)
20753 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
20754 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
20755 IF(AYST5.GT.1D-10) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
20756 & MAX(1D-10,1D0-EXP(-YST-YST0))
20757 ENDIF
20758 COMFAC=COMFAC*AYST0/H2
20759 ENDIF
20760 ENDIF
20761
20762C...2 -> 1 processes: reduction in angular part of phase space integral
20763C...for case of decaying resonance
20764 ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
20765 IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
20766 IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
20767 IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
20768 & KFPR(ISUB,1).EQ.39) THEN
20769 COMFAC=COMFAC*0.5D0*ACTH0
20770 ELSE
20771 COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
20772 & CTPMAX**3-CTPMIN**3)
20773 ENDIF
20774 ENDIF
20775
20776C...2 -> 2 processes: angular part of phase space integral
20777 ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
20778 ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
20779 & (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
20780 ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
20781 & (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
20782 ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
20783 & 1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
20784 ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
20785 & 1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
20786 H3=COEF(ISUBSV,13)+
20787 & (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
20788 & (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
20789 & (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
20790 & (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
20791 COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3
20792
20793C...2 -> 2 processes: take into account final state Breit-Wigners
20794 COMFAC=COMFAC*VINT(80)
20795 ENDIF
20796
20797C...2 -> 3, 4 processes: phace space integral in tau'
20798 IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
20799 ATAUP1=LOG(TAUPMX/TAUPMN)
20800 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
20801 H4=COEF(ISUBSV,18)+
20802 & (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
20803 IF(MINT(47).EQ.5) THEN
20804 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
20805 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-10,1D0-TAUP)
20806 ELSEIF(MINT(47).GE.6) THEN
20807 ATAUP3=LOG(MAX(1D-10,1D0-TAUPMN)/MAX(1D-10,1D0-TAUPMX))
20808 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(1D-10,1D0-TAUP)
20809 ENDIF
20810 COMFAC=COMFAC*ATAUP1/H4
20811 ENDIF
20812
20813C...2 -> 3, 4 processes: effective W/Z parton distributions
20814 IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
20815 IF(1D0-TAU/TAUP.GT.1D-4) THEN
20816 FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
20817 ELSE
20818 FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
20819 ENDIF
20820 COMFAC=COMFAC*FZW
20821 ENDIF
20822
20823C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
20824 IF(ISTSB.EQ.5) THEN
20825 COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
20826 & (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
20827 ENDIF
20828
20829C...Phase space integral for low-pT and multiple interactions
20830 IF(ISTSB.EQ.9) THEN
20831 COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
20832 ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
20833 ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
20834 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
20835 COMFAC=COMFAC*ATAU1/H1
20836 AYST0=YSTMAX-YSTMIN
20837 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
20838 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
20839 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
20840 & (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
20841 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
20842 COMFAC=COMFAC*AYST0/H2
20843 IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
20844C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
20845C...introduced to make cross-section finite for xT2 -> 0
20846 IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
20847 & (1D0+VINT(149)))
20848 ENDIF
20849
20850C...Real gamma + gamma: include factor 2 when different nature
20851 160 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
20852 &MSTP(14).LE.10) COMFAC=2D0*COMFAC
20853
20854C...Extra factors to include the effects of
20855C...longitudinal resolved photons (but not direct or DIS ones).
20856 DO 170 ISDE=1,2
20857 IF(MINT(10+ISDE).EQ.22.AND.MINT(106+ISDE).GE.1.AND.
20858 & MINT(106+ISDE).LE.3) THEN
20859 VINT(314+ISDE)=1D0
20860 XY=PARP(166+ISDE)
20861 IF(MSTP(16).EQ.0) THEN
20862 IF(VINT(304+ISDE).GT.0D0.AND.VINT(304+ISDE).LT.1D0)
20863 & XY=VINT(304+ISDE)
20864 ELSE
20865 IF(VINT(308+ISDE).GT.0D0.AND.VINT(308+ISDE).LT.1D0)
20866 & XY=VINT(308+ISDE)
20867 ENDIF
20868 Q2GA=VINT(306+ISDE)
20869 IF(MSTP(17).GT.0.AND.XY.GT.0D0.AND.XY.LT.1D0.AND.
20870 & Q2GA.GT.0D0) THEN
20871 REDUCE=0D0
20872 IF(MSTP(17).EQ.1) THEN
20873 REDUCE=4D0*Q2*Q2GA/(Q2+Q2GA)**2
20874 ELSEIF(MSTP(17).EQ.2) THEN
20875 REDUCE=4D0*Q2GA/(Q2+Q2GA)
20876 ELSEIF(MSTP(17).EQ.3) THEN
20877 PMVIRT=PMAS(PYCOMP(113),1)
20878 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
20879 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.1) THEN
20880 PMVIRT=PMAS(PYCOMP(113),1)
20881 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
20882 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.2) THEN
20883 PMVIRT=PMAS(PYCOMP(113),1)
20884 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
20885 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.3) THEN
20886 PMVSMN=4D0*PARP(15)**2
20887 PMVSMX=4D0*VINT(154)**2
20888 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
20889 REDLON=(3D0*PMVSMN+Q2GA)/(PMVSMN+Q2GA)**3-
20890 & (3D0*PMVSMX+Q2GA)/(PMVSMX+Q2GA)**3
20891 REDUCE=4D0*(Q2GA/6D0)*REDLON/REDTRA
20892 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.1) THEN
20893 PMVIRT=PMAS(PYCOMP(113),1)
20894 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
20895 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.2) THEN
20896 PMVIRT=PMAS(PYCOMP(113),1)
20897 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
20898 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.3) THEN
20899 PMVSMN=4D0*PARP(15)**2
20900 PMVSMX=4D0*VINT(154)**2
20901 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
20902 REDLON=1D0/(PMVSMN+Q2GA)**2-1D0/(PMVSMX+Q2GA)**2
20903 REDUCE=4D0*(Q2GA/2D0)*REDLON/REDTRA
20904 ENDIF
20905 BEAMAS=PYMASS(11)
20906 IF(VINT(302+ISDE).GT.0D0) BEAMAS=VINT(302+ISDE)
20907 FRACLT=1D0/(1D0+XY**2/2D0/(1D0-XY)*
20908 & (1D0-2D0*BEAMAS**2/Q2GA))
20909 VINT(314+ISDE)=1D0+PARP(165)*REDUCE*FRACLT
20910 ENDIF
20911 ELSE
20912 VINT(314+ISDE)=1D0
20913 ENDIF
20914 COMFAC=COMFAC*VINT(314+ISDE)
20915 170 CONTINUE
20916
20917C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
20918 IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ.
20919 &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN
20920C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
20921 IF(MSTP(46).LE.4) THEN
20922 HDTLH=LOG(PMAS(25,1)/PARP(44))
20923 HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0
20924 HDTNR=-1D0/18D0+HDTLH/6D0
20925 ELSE
20926 HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2)
20927 HDTLQ=LOG(PARP(45)/PARP(44))
20928 HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0
20929 HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0
20930 ENDIF
20931
20932C...Calculate lowest and next-to-lowest order partial wave amplitudes
20933 HDTV=1D0/(16D0*PARU(1)*PARP(47)**2)
20934 A00L=DBLE(HDTV*SH)
20935 A20L=-0.5D0*A00L
20936 A11L=A00L/6D0
20937 HDTLS=LOG(SH/PARP(44)**2)
20938 A004=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
20939 & CMPLX(DBLE((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0-
20940 & (50D0/9D0)*HDTLS),DBLE(4D0*PARU(1)))
20941 A204=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
20942 & CMPLX(DBLE(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0-
20943 & (20D0/9D0)*HDTLS),DBLE(PARU(1)))
20944 A114=DBLE((HDTV*SH)**2/(6D0*PARU(1)))*
20945 & CMPLX(DBLE(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),DBLE(PARU(1)/6D0))
20946
20947C...Unitarize partial wave amplitudes with Pade or K-matrix method
20948 IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN
20949 A00U=A00L/(1D0-A004/A00L)
20950 A20U=A20L/(1D0-A204/A20L)
20951 A11U=A11L/(1D0-A114/A11L)
20952 ELSE
20953 A00U=(A00L+DBLE(A004))/(1D0-DCMPLX(0.D0,A00L+DBLE(A004)))
20954 A20U=(A20L+DBLE(A204))/(1D0-DCMPLX(0.D0,A20L+DBLE(A204)))
20955 A11U=(A11L+DBLE(A114))/(1D0-DCMPLX(0.D0,A11L+DBLE(A114)))
20956 ENDIF
20957 ENDIF
20958
20959C...Supersymmetric processes - all of type 2 -> 2 :
20960C...correct final-state Breit-Wigners from fixed to running width.
20961 IF(ISUB.GE.200.AND.ISUB.LE.301.AND.MSTP(42).GT.0) THEN
20962 DO 180 I=1,2
20963 KFLW=KFPR(ISUBSV,I)
20964 KCW=PYCOMP(KFLW)
20965 IF(PMAS(KCW,2).LT.PARP(41)) GOTO 180
20966 IF(I.EQ.1) SQMI=SQM3
20967 IF(I.EQ.2) SQMI=SQM4
20968 SQMS=PMAS(KCW,1)**2
20969 GMMS=PMAS(KCW,1)*PMAS(KCW,2)
20970 HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2)
20971 CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
20972 GMMI=SQRT(SQMI)*WDTP(0)
20973 HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2)
20974 COMFAC=COMFAC*(HBWI/HBWS)
20975 180 CONTINUE
20976 ENDIF
20977
20978C...QCD 2 -> 2 processes: corrections from virtual technicolor exchange.
20979 IF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.
20980 $ISUB.EQ.68.OR.ISUB.EQ.81.OR.ISUB.EQ.82) THEN
20981 IF(MSTP(5).LE.4) THEN
20982 SQDQQS=1D0/SH2
20983 SQDQQT=1D0/TH2
20984 SQDQQU=1D0/UH2
20985 SQDGGS=SQDQQS
20986 SQDGGT=SQDQQT
20987 SQDGGU=SQDQQU
20988 REDGGS=1D0/SH
20989 REDGGT=1D0/TH
20990 REDGGU=1D0/UH
20991 REDGTU=1D0/UH/TH
20992 REDGSU=1D0/SH/UH
20993 REDGST=1D0/SH/TH
20994 REDQST=1D0/SH/TH
20995 REDQTU=1D0/UH/TH
20996 SQDLGS=0D0
20997 SQDLGT=0D0
20998 SQDQTS=SQDQQS
20999 ELSEIF(MSTP(5).EQ.5) THEN
21000 TANT3=ABS(PARP(155))
21001 IF(PARP(155).GT.0) THEN
21002 IMDL=1
21003 ELSE
21004 IMDL=2
21005 ENDIF
21006 ALPRHT=2.91D0*(3D0/PARP(144))
21007 SIN2T=2D0*TANT3/(TANT3**2+1D0)
21008 SINT3=TANT3/SQRT(TANT3**2+1D0)
21009 XIG=SQRT(PYALPS(SH)/ALPRHT)
21010 X12=(1D0/SQRT(2D0)*1D0/SQRT(2D0)+
21011 & 1D0/SQRT(2D0)*1D0/SQRT(2D0))/SQRT(2D0)/SIN2T
21012 X21=1D-3
21013 X11=(.25D0*((1D0/SQRT(2D0))**2+(1D0/SQRT(2D0))**2+2D0)-
21014 & SINT3**2)*2D0/SIN2T
21015 X22=(.25D0*((1D0/SQRT(2D0))**2+(1D0/SQRT(2D0))**2)-
21016 & SINT3**2)*2D0/SIN2T
21017 IF(PARP(156).GT.0.5D0) THEN
21018 SM1122=1D-6
21019 SM1112=1D-6
21020 SM1121=1D-6
21021 SM2212=1D-6
21022 SM2221=1D-6
21023 SM1221=1D-6
21024 X12=1D-6
21025 X21=1D-6
21026 X11=(1D0-SINT3**2)*2D0/SIN2T
21027 X22=-SINT3**2*2D0/SIN2T
21028 ELSE
21029 SM1122=100D0**2
21030 SM1112=150D0**2
21031 SM1121=150D0**2
21032 SM2212=150D0**2
21033 SM2221=75D0**2
21034 SM1221=50D0**2
21035 ENDIF
21036
21037C.........SH LOOP
21038 ZTC(1,1)=DCMPLX(SH,0D0)
21039 CALL PYWIDT(3100021,SH,WDTP,WDTE)
21040 ZTC(2,2)=DCMPLX(SH-PMAS(PYCOMP(3100021),1)**2,-SHR*WDTP(0))
21041 CALL PYWIDT(3100113,SH,WDTP,WDTE)
21042 ZTC(3,3)=DCMPLX(SH-PMAS(PYCOMP(3100113),1)**2,-SHR*WDTP(0))
21043 CALL PYWIDT(3400113,SH,WDTP,WDTE)
21044 ZTC(4,4)=DCMPLX(SH-PMAS(PYCOMP(3400113),1)**2,-SHR*WDTP(0))
21045 CALL PYWIDT(3200113,SH,WDTP,WDTE)
21046 ZTC(5,5)=DCMPLX(SH-PMAS(PYCOMP(3200113),1)**2,-SHR*WDTP(0))
21047 CALL PYWIDT(3300113,SH,WDTP,WDTE)
21048 ZTC(6,6)=DCMPLX(SH-PMAS(PYCOMP(3300113),1)**2,-SHR*WDTP(0))
21049 ZTC(1,2)=(0D0,0D0)
21050 ZTC(1,3)=DCMPLX(SH*XIG,0D0)
21051 ZTC(1,4)=ZTC(1,3)
21052 ZTC(1,5)=ZTC(1,2)
21053 ZTC(1,6)=ZTC(1,2)
21054 ZTC(2,3)=DCMPLX(SH*XIG*X11,0D0)
21055 ZTC(2,4)=DCMPLX(SH*XIG*X22,0D0)
21056 ZTC(2,5)=DCMPLX(SH*XIG*X12,0D0)
21057 ZTC(2,6)=DCMPLX(SH*XIG*X21,0D0)
21058 ZTC(3,4)=-SM1122
21059 ZTC(3,5)=-SM1112
21060 ZTC(3,6)=-SM1121
21061 ZTC(4,5)=-SM2212
21062 ZTC(4,6)=-SM2221
21063 ZTC(5,6)=-SM1221
21064
21065
21066 DO 200 I=1,5
21067 DO 190 J=I+1,6
21068 ZTC(J,I)=ZTC(I,J)
21069 190 CONTINUE
21070 200 CONTINUE
21071 CALL PYLDCM(ZTC,6,6,INDX,D)
21072 DO 220 I=1,6
21073 DO 210 J=1,6
21074 YTC(I,J)=(0D0,0D0)
21075 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
21076 210 CONTINUE
21077 220 CONTINUE
21078
21079 DO 230 I=1,6
21080 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
21081 230 CONTINUE
21082 DGGS=YTC(1,1)
21083 DVVS=YTC(2,2)
21084
21085 XIG=SQRT(PYALPS(-TH)/ALPRHT)
21086C.........TH LOOP
21087 ZTC(1,1)=DCMPLX(TH)
21088 ZTC(2,2)=DCMPLX(TH-PMAS(PYCOMP(3100021),1)**2)
21089 ZTC(3,3)=DCMPLX(TH-PMAS(PYCOMP(3100113),1)**2)
21090 ZTC(4,4)=DCMPLX(TH-PMAS(PYCOMP(3400113),1)**2)
21091 ZTC(5,5)=DCMPLX(TH-PMAS(PYCOMP(3200113),1)**2)
21092 ZTC(6,6)=DCMPLX(TH-PMAS(PYCOMP(3300113),1)**2)
21093 ZTC(1,2)=(0D0,0D0)
21094 ZTC(1,3)=DCMPLX(TH*XIG,0D0)
21095 ZTC(1,4)=ZTC(1,3)
21096 ZTC(1,5)=ZTC(1,2)
21097 ZTC(1,6)=ZTC(1,2)
21098 ZTC(2,3)=DCMPLX(TH*XIG*X11,0D0)
21099 ZTC(2,4)=DCMPLX(TH*XIG*X22,0D0)
21100 ZTC(2,5)=DCMPLX(TH*XIG*X12,0D0)
21101 ZTC(2,6)=DCMPLX(TH*XIG*X21,0D0)
21102 ZTC(3,4)=-SM1122
21103 ZTC(3,5)=-SM1112
21104 ZTC(3,6)=-SM1121
21105 ZTC(4,5)=-SM2212
21106 ZTC(4,6)=-SM2221
21107 ZTC(5,6)=-SM1221
21108 DO 250 I=1,5
21109 DO 240 J=I+1,6
21110 ZTC(J,I)=ZTC(I,J)
21111 240 CONTINUE
21112 250 CONTINUE
21113 CALL PYLDCM(ZTC,6,6,INDX,D)
21114 DO 270 I=1,6
21115 DO 260 J=1,6
21116 YTC(I,J)=(0D0,0D0)
21117 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
21118 260 CONTINUE
21119 270 CONTINUE
21120 DO 280 I=1,6
21121 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
21122 280 CONTINUE
21123 DGGT=YTC(1,1)
21124 DVVT=YTC(2,2)
21125
21126 XIG=SQRT(PYALPS(-UH)/ALPRHT)
21127C.........UH LOOP
21128 ZTC(1,1)=DCMPLX(UH,0D0)
21129 ZTC(2,2)=DCMPLX(UH-PMAS(PYCOMP(3100021),1)**2)
21130 ZTC(3,3)=DCMPLX(UH-PMAS(PYCOMP(3100113),1)**2)
21131 ZTC(4,4)=DCMPLX(UH-PMAS(PYCOMP(3400113),1)**2)
21132 ZTC(5,5)=DCMPLX(UH-PMAS(PYCOMP(3200113),1)**2)
21133 ZTC(6,6)=DCMPLX(UH-PMAS(PYCOMP(3300113),1)**2)
21134 ZTC(1,2)=(0D0,0D0)
21135 ZTC(1,3)=DCMPLX(UH*XIG,0D0)
21136 ZTC(1,4)=ZTC(1,3)
21137 ZTC(1,5)=ZTC(1,2)
21138 ZTC(1,6)=ZTC(1,2)
21139 ZTC(2,3)=DCMPLX(UH*XIG*X11,0D0)
21140 ZTC(2,4)=DCMPLX(UH*XIG*X22,0D0)
21141 ZTC(2,5)=DCMPLX(UH*XIG*X12,0D0)
21142 ZTC(2,6)=DCMPLX(UH*XIG*X21,0D0)
21143 ZTC(3,4)=-SM1122
21144 ZTC(3,5)=-SM1112
21145 ZTC(3,6)=-SM1121
21146 ZTC(4,5)=-SM2212
21147 ZTC(4,6)=-SM2221
21148 ZTC(5,6)=-SM1221
21149 DO 300 I=1,5
21150 DO 290 J=I+1,6
21151 ZTC(J,I)=ZTC(I,J)
21152 290 CONTINUE
21153 300 CONTINUE
21154 CALL PYLDCM(ZTC,6,6,INDX,D)
21155 DO 320 I=1,6
21156 DO 310 J=1,6
21157 YTC(I,J)=(0D0,0D0)
21158 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
21159 310 CONTINUE
21160 320 CONTINUE
21161 DO 330 I=1,6
21162 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
21163 330 CONTINUE
21164 DGGU=YTC(1,1)
21165 DVVU=YTC(2,2)
21166
21167 IF(IMDL.EQ.1) THEN
21168 DQQS=DGGS+DVVS*DCMPLX(TANT3**2)
21169 DQQT=DGGT+DVVT*DCMPLX(TANT3**2)
21170 DQQU=DGGU+DVVU*DCMPLX(TANT3**2)
21171 DQTS=DGGS-DVVS
21172 ELSE
21173 DQQS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)
21174 DQQT=DGGT+DVVT*DCMPLX(1D0/TANT3**2)
21175 DQQU=DGGU+DVVU*DCMPLX(1D0/TANT3**2)
21176 DQTS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)
21177 ENDIF
21178
21179 SQDQTS=ABS(DQTS)**2
21180 SQDQQS=ABS(DQQS)**2
21181 SQDQQT=ABS(DQQT)**2
21182 SQDQQU=ABS(DQQU)**2
21183 SQDLGS=ABS(DCMPLX(SH)*DGGS-DCMPLX(1D0))**2
21184 SQDLGT=ABS(DCMPLX(TH)*DGGT-DCMPLX(1D0))**2
21185
21186 SQDGGS=ABS(DGGS)**2
21187 SQDGGT=ABS(DGGT)**2
21188 SQDGGU=ABS(DGGU)**2
21189 REDGGS=DBLE(DGGS)
21190 REDGGT=DBLE(DGGT)
21191 REDGGU=DBLE(DGGU)
21192 REDGTU=DBLE(DGGU*DCONJG(DGGT))
21193 REDGSU=DBLE(DGGU*DCONJG(DGGS))
21194 REDGST=DBLE(DGGS*DCONJG(DGGT))
21195 REDQST=DBLE(DQQS*DCONJG(DQQT))
21196 REDQTU=DBLE(DQQT*DCONJG(DQQU))
21197 ENDIF
21198 ENDIF
21199
21200C...A: 2 -> 1, tree diagrams
21201
21202 IF(ISUB.LE.10) THEN
21203 IF(ISUB.EQ.1) THEN
21204C...f + fbar -> gamma*/Z0
21205 MINT(61)=2
21206 CALL PYWIDT(23,SH,WDTP,WDTE)
21207 HS=SHR*WDTP(0)
21208 FACZ=4D0*COMFAC*3D0
21209 HP0=AEM/3D0*SH
21210 HP1=AEM/3D0*XWC*SH
21211 DO 340 I=MMINA,MMAXA
21212 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 340
21213 EI=KCHG(IABS(I),1)/3D0
21214 AI=SIGN(1D0,EI)
21215 VI=AI-4D0*EI*XWV
21216 HI0=HP0
21217 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
21218 HI1=HP1
21219 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
21220 NCHN=NCHN+1
21221 ISIG(NCHN,1)=I
21222 ISIG(NCHN,2)=-I
21223 ISIG(NCHN,3)=1
21224 SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+
21225 & EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*
21226 & (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/
21227 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114))
21228 340 CONTINUE
21229
21230 ELSEIF(ISUB.EQ.2) THEN
21231C...f + fbar' -> W+/-
21232 CALL PYWIDT(24,SH,WDTP,WDTE)
21233 HS=SHR*WDTP(0)
21234 FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0
21235 HP=AEM/(24D0*XW)*SH
21236 DO 360 I=MMIN1,MMAX1
21237 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 360
21238 IA=IABS(I)
21239 DO 350 J=MMIN2,MMAX2
21240 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 350
21241 JA=IABS(J)
21242 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 350
21243 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
21244 & GOTO 350
21245 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
21246 HI=HP*2D0
21247 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
21248 NCHN=NCHN+1
21249 ISIG(NCHN,1)=I
21250 ISIG(NCHN,2)=J
21251 ISIG(NCHN,3)=1
21252 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
21253 SIGH(NCHN)=HI*FACBW*HF
21254 350 CONTINUE
21255 360 CONTINUE
21256
21257 ELSEIF(ISUB.EQ.3) THEN
21258C...f + fbar -> h0 (or H0, or A0)
21259 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
21260 HS=SHR*WDTP(0)
21261 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
21262 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
21263 & FACBW=0D0
21264 HP=AEM/(8D0*XW)*SH/SQMW*SH
21265 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
21266 DO 370 I=MMINA,MMAXA
21267 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 370
21268 IA=IABS(I)
21269 RMQ=PYMRUN(IA,SH)**2/SH
21270 HI=HP*RMQ
21271 IF(IA.LE.10) HI=HP*RMQ*FACA/3D0
21272 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
21273 IKFI=1
21274 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
21275 IF(IA.GT.10) IKFI=3
21276 HI=HI*PARU(150+10*IHIGG+IKFI)**2
21277 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
21278 HI=HI/(1D0+RMSS(41))**2
21279 IF(IHIGG.NE.3) THEN
21280 HI=HI*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
21281 & PARU(151+10*IHIGG))**2
21282 ENDIF
21283 ENDIF
21284 ENDIF
21285 NCHN=NCHN+1
21286 ISIG(NCHN,1)=I
21287 ISIG(NCHN,2)=-I
21288 ISIG(NCHN,3)=1
21289 SIGH(NCHN)=HI*FACBW*HF
21290 370 CONTINUE
21291
21292 ELSEIF(ISUB.EQ.4) THEN
21293C...gamma + W+/- -> W+/-
21294
21295 ELSEIF(ISUB.EQ.5) THEN
21296C...Z0 + Z0 -> h0
21297 CALL PYWIDT(25,SH,WDTP,WDTE)
21298 HS=SHR*WDTP(0)
21299 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
21300 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
21301 HP=AEM/(8D0*XW)*SH/SQMW*SH
21302 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
21303 HI=HP/4D0
21304 FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2
21305 DO 390 I=MMIN1,MMAX1
21306 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 390
21307 DO 380 J=MMIN2,MMAX2
21308 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 380
21309 EI=KCHG(IABS(I),1)/3D0
21310 AI=SIGN(1D0,EI)
21311 VI=AI-4D0*EI*XWV
21312 EJ=KCHG(IABS(J),1)/3D0
21313 AJ=SIGN(1D0,EJ)
21314 VJ=AJ-4D0*EJ*XWV
21315 NCHN=NCHN+1
21316 ISIG(NCHN,1)=I
21317 ISIG(NCHN,2)=J
21318 ISIG(NCHN,3)=1
21319 SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF
21320 380 CONTINUE
21321 390 CONTINUE
21322
21323 ELSEIF(ISUB.EQ.6) THEN
21324C...Z0 + W+/- -> W+/-
21325
21326 ELSEIF(ISUB.EQ.7) THEN
21327C...W+ + W- -> Z0
21328
21329 ELSEIF(ISUB.EQ.8) THEN
21330C...W+ + W- -> h0
21331 CALL PYWIDT(25,SH,WDTP,WDTE)
21332 HS=SHR*WDTP(0)
21333 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
21334 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
21335 HP=AEM/(8D0*XW)*SH/SQMW*SH
21336 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
21337 HI=HP/2D0
21338 FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2
21339 DO 410 I=MMIN1,MMAX1
21340 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410
21341 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
21342 DO 400 J=MMIN2,MMAX2
21343 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 400
21344 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
21345 IF(EI*EJ.GT.0D0) GOTO 400
21346 NCHN=NCHN+1
21347 ISIG(NCHN,1)=I
21348 ISIG(NCHN,2)=J
21349 ISIG(NCHN,3)=1
21350 SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF
21351 400 CONTINUE
21352 410 CONTINUE
21353
21354C...B: 2 -> 2, tree diagrams
21355
21356 ELSEIF(ISUB.EQ.10) THEN
21357C...f + f' -> f + f' (gamma/Z/W exchange)
21358 FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2
21359 FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ))
21360 FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2
21361 FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2
21362 DO 430 I=MMIN1,MMAX1
21363 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 430
21364 IA=IABS(I)
21365 DO 420 J=MMIN2,MMAX2
21366 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 420
21367 JA=IABS(J)
21368C...Electroweak couplings
21369 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
21370 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
21371 VI=AI-4D0*EI*XWV
21372 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
21373 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
21374 VJ=AJ-4D0*EJ*XWV
21375 EPSIJ=ISIGN(1,I*J)
21376C...gamma/Z exchange, only gamma exchange, or only Z exchange
21377 IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN
21378 IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN
21379 FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ*
21380 & (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+
21381 & FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+
21382 & 4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
21383 ELSEIF(MSTP(21).EQ.2) THEN
21384 FACNCF=FACGGF*EI**2*EJ**2
21385 ELSE
21386 FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*
21387 & (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
21388 ENDIF
21389C...Extrafactor 2 for only one incoming neutrino spin state.
21390 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACNCF=2D0*FACNCF
21391 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACNCF=2D0*FACNCF
21392 NCHN=NCHN+1
21393 ISIG(NCHN,1)=I
21394 ISIG(NCHN,2)=J
21395 ISIG(NCHN,3)=1
21396 SIGH(NCHN)=FACNCF
21397 ENDIF
21398C...W exchange
21399 IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN
21400 FACCCF=FACWWF*VINT(180+I)*VINT(180+J)
21401 IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2
21402 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF
21403 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF
21404 NCHN=NCHN+1
21405 ISIG(NCHN,1)=I
21406 ISIG(NCHN,2)=J
21407 ISIG(NCHN,3)=2
21408 SIGH(NCHN)=FACCCF
21409 ENDIF
21410 420 CONTINUE
21411 430 CONTINUE
21412 ENDIF
21413
21414 ELSEIF(ISUB.LE.20) THEN
21415 IF(ISUB.EQ.11) THEN
21416C...f + f' -> f + f' (g exchange)
21417 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)*SQDQQT
21418 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)*SQDQQT*FACA-
21419 & MSTP(34)*2D0/3D0*UH2*REDQST)
21420 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)*SQDQQU
21421 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
21422 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
21423 IF(MSTP(5).GE.1.AND.MSTP(5).LE.4) THEN
21424C...Modifications from contact interactions (compositeness)
21425 FACCI1=FACQQ1+COMFAC*(SH2/PARU(155)**4)
21426 FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*PARU(156)/PARU(155)**2)*
21427 & (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/PARU(155)**4)
21428 FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*PARU(156)/PARU(155)**2)*
21429 & (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/PARU(155)**4)
21430 FACCI3=FACQQ1+COMFAC*(UH2/PARU(155)**4)
21431 RATCII=(FACCI1*FACCI2+FACQQI)/(FACCI1+FACCI2)
21432 ELSEIF(MSTP(5).EQ.5) THEN
21433 FACCI1=FACQQ1
21434 FACCIB=FACQQB
21435 FACCI2=FACQQ2
21436 FACCI3=FACQQ1
21437 RATCII=1D0
21438 ENDIF
21439 DO 450 I=MMIN1,MMAX1
21440 IA=IABS(I)
21441 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 450
21442 DO 440 J=MMIN2,MMAX2
21443 JA=IABS(J)
21444 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 440
21445 NCHN=NCHN+1
21446 ISIG(NCHN,1)=I
21447 ISIG(NCHN,2)=J
21448 ISIG(NCHN,3)=1
21449 IF(MSTP(5).LE.0.OR.(MSTP(5).EQ.1.AND.(IA.GE.3.OR.
21450 & JA.GE.3))) THEN
21451 SIGH(NCHN)=FACQQ1
21452 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
21453 ELSE
21454 SIGH(NCHN)=FACCI1
21455 IF(I*J.LT.0) SIGH(NCHN)=FACCI3
21456 IF(I.EQ.-J) SIGH(NCHN)=FACCIB
21457 ENDIF
21458 IF(I.EQ.J) THEN
21459 NCHN=NCHN+1
21460 ISIG(NCHN,1)=I
21461 ISIG(NCHN,2)=J
21462 ISIG(NCHN,3)=2
21463 IF(MSTP(5).LE.0.OR.(MSTP(5).EQ.1.AND.IA.GE.3)) THEN
21464 SIGH(NCHN-1)=0.5D0*FACQQ1*RATQQI
21465 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
21466 ELSE
21467 SIGH(NCHN-1)=0.5D0*FACCI1*RATCII
21468 SIGH(NCHN)=0.5D0*FACCI2*RATCII
21469 ENDIF
21470 ENDIF
21471 440 CONTINUE
21472 450 CONTINUE
21473
21474 ELSEIF(ISUB.EQ.12) THEN
21475C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
21476 CALL PYWIDT(21,SH,WDTP,WDTE)
21477C.........Do not use for b bbar in Standard TC2
21478 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)*SQDQQS*
21479 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
21480 IF(MSTP(5).EQ.1) THEN
21481C...Modifications from contact interactions (compositeness)
21482 FACCIB=FACQQB
21483 DO 460 I=1,2
21484 FACCIB=FACCIB+COMFAC*(UH2/PARU(155)**4)*(WDTE(I,1)+
21485 & WDTE(I,2)+WDTE(I,4))
21486 460 CONTINUE
21487 ELSEIF(MSTP(5).GE.2.AND.MSTP(5).LE.4) THEN
21488 FACCIB=FACQQB+COMFAC*(UH2/PARU(155)**4)*
21489 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
21490 ENDIF
21491 DO 470 I=MMINA,MMAXA
21492 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
21493 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 470
21494 NCHN=NCHN+1
21495 ISIG(NCHN,1)=I
21496 ISIG(NCHN,2)=-I
21497 ISIG(NCHN,3)=1
21498 IF(MSTP(5).LE.0.OR.(MSTP(5).EQ.1.AND.IABS(I).GE.3)) THEN
21499 SIGH(NCHN)=FACQQB
21500 ELSE
21501 SIGH(NCHN)=FACCIB
21502 ENDIF
21503 470 CONTINUE
21504
21505 ELSEIF(ISUB.EQ.13) THEN
21506C...f + fbar -> g + g (q + qbar -> g + g only)
21507 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
21508 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
21509 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
21510 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
21511 DO 480 I=MMINA,MMAXA
21512 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
21513 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 480
21514 NCHN=NCHN+1
21515 ISIG(NCHN,1)=I
21516 ISIG(NCHN,2)=-I
21517 ISIG(NCHN,3)=1
21518 SIGH(NCHN)=0.5D0*FACGG1
21519 NCHN=NCHN+1
21520 ISIG(NCHN,1)=I
21521 ISIG(NCHN,2)=-I
21522 ISIG(NCHN,3)=2
21523 SIGH(NCHN)=0.5D0*FACGG2
21524 480 CONTINUE
21525
21526 ELSEIF(ISUB.EQ.14) THEN
21527C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
21528 FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH)
21529 DO 490 I=MMINA,MMAXA
21530 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
21531 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 490
21532 EI=KCHG(IABS(I),1)/3D0
21533 NCHN=NCHN+1
21534 ISIG(NCHN,1)=I
21535 ISIG(NCHN,2)=-I
21536 ISIG(NCHN,3)=1
21537 SIGH(NCHN)=FACGG*EI**2
21538 490 CONTINUE
21539
21540 ELSEIF(ISUB.EQ.15) THEN
21541C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
21542 FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
21543C...gamma, gamma/Z interference and Z couplings to final fermion pairs
21544 HFGG=0D0
21545 HFGZ=0D0
21546 HFZZ=0D0
21547 RADC4=1D0+PYALPS(SQM4)/PARU(1)
21548 DO 500 I=1,MIN(16,MDCY(23,3))
21549 IDC=I+MDCY(23,2)-1
21550 IF(MDME(IDC,1).LT.0) GOTO 500
21551 IMDM=0
21552 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
21553 & IMDM=1
21554 IF(I.LE.8) THEN
21555 EF=KCHG(I,1)/3D0
21556 AF=SIGN(1D0,EF+0.1D0)
21557 VF=AF-4D0*EF*XWV
21558 ELSEIF(I.LE.16) THEN
21559 EF=KCHG(I+2,1)/3D0
21560 AF=SIGN(1D0,EF+0.1D0)
21561 VF=AF-4D0*EF*XWV
21562 ENDIF
21563 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
21564 IF(4D0*RM1.LT.1D0) THEN
21565 FCOF=1D0
21566 IF(I.LE.8) FCOF=3D0*RADC4
21567 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
21568 IF(IMDM.EQ.1) THEN
21569 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
21570 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
21571 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
21572 & AF**2*(1D0-4D0*RM1))*BE34
21573 ENDIF
21574 ENDIF
21575 500 CONTINUE
21576C...Propagators: as simulated in PYOFSH and as desired
21577 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
21578 MINT15=MINT(15)
21579 MINT(15)=1
21580 MINT(61)=1
21581 CALL PYWIDT(23,SQM4,WDTP,WDTE)
21582 MINT(15)=MINT15
21583 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
21584 HFGG=HFGG*HFAEM*VINT(111)/SQM4
21585 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
21586 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
21587C...Loop over flavours; consider full gamma/Z structure
21588 DO 510 I=MMINA,MMAXA
21589 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
21590 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 510
21591 EI=KCHG(IABS(I),1)/3D0
21592 AI=SIGN(1D0,EI)
21593 VI=AI-4D0*EI*XWV
21594 NCHN=NCHN+1
21595 ISIG(NCHN,1)=I
21596 ISIG(NCHN,2)=-I
21597 ISIG(NCHN,3)=1
21598 SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+
21599 & (VI**2+AI**2)*HFZZ)/HBW4
21600 510 CONTINUE
21601
21602 ELSEIF(ISUB.EQ.16) THEN
21603C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
21604 FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
21605C...Propagators: as simulated in PYOFSH and as desired
21606 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
21607 CALL PYWIDT(24,SQM4,WDTP,WDTE)
21608 GMMWC=SQRT(SQM4)*WDTP(0)
21609 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
21610 FACWG=FACWG*HBW4C/HBW4
21611 DO 530 I=MMIN1,MMAX1
21612 IA=IABS(I)
21613 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 530
21614 DO 520 J=MMIN2,MMAX2
21615 JA=IABS(J)
21616 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 520
21617 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 520
21618 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
21619 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
21620 FCKM=VCKM((IA+1)/2,(JA+1)/2)
21621 NCHN=NCHN+1
21622 ISIG(NCHN,1)=I
21623 ISIG(NCHN,2)=J
21624 ISIG(NCHN,3)=1
21625 SIGH(NCHN)=FACWG*FCKM*WIDSC
21626 520 CONTINUE
21627 530 CONTINUE
21628
21629 ELSEIF(ISUB.EQ.17) THEN
21630C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
21631
21632 ELSEIF(ISUB.EQ.18) THEN
21633C...f + fbar -> gamma + gamma
21634 FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH)
21635 DO 540 I=MMINA,MMAXA
21636 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 540
21637 EI=KCHG(IABS(I),1)/3D0
21638 FCOI=1D0
21639 IF(IABS(I).LE.10) FCOI=FACA/3D0
21640 NCHN=NCHN+1
21641 ISIG(NCHN,1)=I
21642 ISIG(NCHN,2)=-I
21643 ISIG(NCHN,3)=1
21644 SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4
21645 540 CONTINUE
21646
21647 ELSEIF(ISUB.EQ.19) THEN
21648C...f + fbar -> gamma + (gamma*/Z0)
21649 FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
21650C...gamma, gamma/Z interference and Z couplings to final fermion pairs
21651 HFGG=0D0
21652 HFGZ=0D0
21653 HFZZ=0D0
21654 RADC4=1D0+PYALPS(SQM4)/PARU(1)
21655 DO 550 I=1,MIN(16,MDCY(23,3))
21656 IDC=I+MDCY(23,2)-1
21657 IF(MDME(IDC,1).LT.0) GOTO 550
21658 IMDM=0
21659 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
21660 & IMDM=1
21661 IF(I.LE.8) THEN
21662 EF=KCHG(I,1)/3D0
21663 AF=SIGN(1D0,EF+0.1D0)
21664 VF=AF-4D0*EF*XWV
21665 ELSEIF(I.LE.16) THEN
21666 EF=KCHG(I+2,1)/3D0
21667 AF=SIGN(1D0,EF+0.1D0)
21668 VF=AF-4D0*EF*XWV
21669 ENDIF
21670 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
21671 IF(4D0*RM1.LT.1D0) THEN
21672 FCOF=1D0
21673 IF(I.LE.8) FCOF=3D0*RADC4
21674 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
21675 IF(IMDM.EQ.1) THEN
21676 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
21677 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
21678 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
21679 & AF**2*(1D0-4D0*RM1))*BE34
21680 ENDIF
21681 ENDIF
21682 550 CONTINUE
21683C...Propagators: as simulated in PYOFSH and as desired
21684 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
21685 MINT15=MINT(15)
21686 MINT(15)=1
21687 MINT(61)=1
21688 CALL PYWIDT(23,SQM4,WDTP,WDTE)
21689 MINT(15)=MINT15
21690 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
21691 HFGG=HFGG*HFAEM*VINT(111)/SQM4
21692 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
21693 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
21694C...Loop over flavours; consider full gamma/Z structure
21695 DO 560 I=MMINA,MMAXA
21696 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 560
21697 EI=KCHG(IABS(I),1)/3D0
21698 AI=SIGN(1D0,EI)
21699 VI=AI-4D0*EI*XWV
21700 FCOI=1D0
21701 IF(IABS(I).LE.10) FCOI=FACA/3D0
21702 NCHN=NCHN+1
21703 ISIG(NCHN,1)=I
21704 ISIG(NCHN,2)=-I
21705 ISIG(NCHN,3)=1
21706 SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+
21707 & (VI**2+AI**2)*HFZZ)/HBW4
21708 560 CONTINUE
21709
21710 ELSEIF(ISUB.EQ.20) THEN
21711C...f + fbar' -> gamma + W+/-
21712 FACGW=COMFAC*0.5D0*AEM**2/XW
21713C...Propagators: as simulated in PYOFSH and as desired
21714 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
21715 CALL PYWIDT(24,SQM4,WDTP,WDTE)
21716 GMMWC=SQRT(SQM4)*WDTP(0)
21717 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
21718 FACGW=FACGW*HBW4C/HBW4
21719C...Anomalous couplings
21720 TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
21721 TERM2=0D0
21722 TERM3=0D0
21723 IF(MSTP(5).GE.1.AND.MSTP(5).LE.4) THEN
21724 TERM2=PARU(153)*(TH-UH)/(TH+UH)
21725 TERM3=0.5D0*PARU(153)**2*(TH*UH+(TH2+UH2)*SH/
21726 & (4D0*SQMW))/(TH+UH)**2
21727 ENDIF
21728 DO 580 I=MMIN1,MMAX1
21729 IA=IABS(I)
21730 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 580
21731 DO 570 J=MMIN2,MMAX2
21732 JA=IABS(J)
21733 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 570
21734 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 570
21735 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
21736 & GOTO 570
21737 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
21738 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
21739 IF(IA.LE.10) THEN
21740 FACWR=UH/(TH+UH)-1D0/3D0
21741 FCKM=VCKM((IA+1)/2,(JA+1)/2)
21742 FCOI=FACA/3D0
21743 ELSE
21744 FACWR=-TH/(TH+UH)
21745 FCKM=1D0
21746 FCOI=1D0
21747 ENDIF
21748 FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3
21749 NCHN=NCHN+1
21750 ISIG(NCHN,1)=I
21751 ISIG(NCHN,2)=J
21752 ISIG(NCHN,3)=1
21753 SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC
21754 570 CONTINUE
21755 580 CONTINUE
21756 ENDIF
21757
21758 ELSEIF(ISUB.LE.30) THEN
21759 IF(ISUB.EQ.21) THEN
21760C...f + fbar -> gamma + h0
21761
21762 ELSEIF(ISUB.EQ.22) THEN
21763C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
21764C...Kinematics dependence
21765 FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)-
21766 & SQM3*SQM4*(1D0/TH2+1D0/UH2))
21767C...gamma, gamma/Z interference and Z couplings to final fermion pairs
21768 DO 600 I=1,6
21769 DO 590 J=1,3
21770 HGZ(I,J)=0D0
21771 590 CONTINUE
21772 600 CONTINUE
21773 RADC3=1D0+PYALPS(SQM3)/PARU(1)
21774 RADC4=1D0+PYALPS(SQM4)/PARU(1)
21775 DO 610 I=1,MIN(16,MDCY(23,3))
21776 IDC=I+MDCY(23,2)-1
21777 IF(MDME(IDC,1).LT.0) GOTO 610
21778 IMDM=0
21779 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1
21780 IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2
21781 IF(I.LE.8) THEN
21782 EF=KCHG(I,1)/3D0
21783 AF=SIGN(1D0,EF+0.1D0)
21784 VF=AF-4D0*EF*XWV
21785 ELSEIF(I.LE.16) THEN
21786 EF=KCHG(I+2,1)/3D0
21787 AF=SIGN(1D0,EF+0.1D0)
21788 VF=AF-4D0*EF*XWV
21789 ENDIF
21790 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3
21791 IF(4D0*RM1.LT.1D0) THEN
21792 FCOF=1D0
21793 IF(I.LE.8) FCOF=3D0*RADC3
21794 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
21795 IF(IMDM.GE.1) THEN
21796 HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
21797 HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
21798 HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
21799 & AF**2*(1D0-4D0*RM1))*BE34
21800 ENDIF
21801 ENDIF
21802 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
21803 IF(4D0*RM1.LT.1D0) THEN
21804 FCOF=1D0
21805 IF(I.LE.8) FCOF=3D0*RADC4
21806 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
21807 IF(IMDM.GE.1) THEN
21808 HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
21809 HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
21810 HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
21811 & AF**2*(1D0-4D0*RM1))*BE34
21812 ENDIF
21813 ENDIF
21814 610 CONTINUE
21815C...Propagators: as simulated in PYOFSH and as desired
21816 HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
21817 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
21818 MINT15=MINT(15)
21819 MINT(15)=1
21820 MINT(61)=1
21821 CALL PYWIDT(23,SQM3,WDTP,WDTE)
21822 MINT(15)=MINT15
21823 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
21824 DO 620 J=1,3
21825 HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3
21826 HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3
21827 HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3
21828 620 CONTINUE
21829 MINT15=MINT(15)
21830 MINT(15)=1
21831 MINT(61)=1
21832 CALL PYWIDT(23,SQM4,WDTP,WDTE)
21833 MINT(15)=MINT15
21834 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
21835 DO 630 J=1,3
21836 HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4
21837 HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4
21838 HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4
21839 630 CONTINUE
21840C...Loop over flavours; separate left- and right-handed couplings
21841 DO 650 I=MMINA,MMAXA
21842 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 650
21843 EI=KCHG(IABS(I),1)/3D0
21844 AI=SIGN(1D0,EI)
21845 VI=AI-4D0*EI*XWV
21846 VALI=VI-AI
21847 VARI=VI+AI
21848 FCOI=1D0
21849 IF(IABS(I).LE.10) FCOI=FACA/3D0
21850 DO 640 J=1,3
21851 HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J)
21852 HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J)
21853 HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J)
21854 HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J)
21855 640 CONTINUE
21856 FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+
21857 & HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+
21858 & HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+
21859 & HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3)
21860 NCHN=NCHN+1
21861 ISIG(NCHN,1)=I
21862 ISIG(NCHN,2)=-I
21863 ISIG(NCHN,3)=1
21864 SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4)
21865 650 CONTINUE
21866
21867 ELSEIF(ISUB.EQ.23) THEN
21868C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.)
21869 FACZW=COMFAC*0.5D0*(AEM/XW)**2
21870 FACZW=FACZW*WIDS(23,2)
21871 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
21872 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
21873 DO 670 I=MMIN1,MMAX1
21874 IA=IABS(I)
21875 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 670
21876 DO 660 J=MMIN2,MMAX2
21877 JA=IABS(J)
21878 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 660
21879 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 660
21880 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
21881 & GOTO 660
21882 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
21883 EI=KCHG(IA,1)/3D0
21884 AI=SIGN(1D0,EI+0.1D0)
21885 VI=AI-4D0*EI*XWV
21886 EJ=KCHG(JA,1)/3D0
21887 AJ=SIGN(1D0,EJ+0.1D0)
21888 VJ=AJ-4D0*EJ*XWV
21889 IF(VI+AI.GT.0) THEN
21890 VISAV=VI
21891 AISAV=AI
21892 VI=VJ
21893 AI=AJ
21894 VJ=VISAV
21895 AJ=AISAV
21896 ENDIF
21897 FCKM=1D0
21898 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
21899 FCOI=1D0
21900 IF(IA.LE.10) FCOI=FACA/3D0
21901 NCHN=NCHN+1
21902 ISIG(NCHN,1)=I
21903 ISIG(NCHN,2)=J
21904 ISIG(NCHN,3)=1
21905 SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+
21906 & (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))*
21907 & (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
21908 & THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
21909 & SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))*
21910 & WIDS(24,(5-KCHW)/2)
21911C***Protect against slightly negative cross sections. (Reason yet to be
21912C***sorted out. One possibility: addition of width to the W propagator.)
21913 SIGH(NCHN)=MAX(0D0,SIGH(NCHN))
21914 660 CONTINUE
21915 670 CONTINUE
21916
21917 ELSEIF(ISUB.EQ.24) THEN
21918C...f + fbar -> Z0 + h0 (or H0, or A0)
21919 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
21920 FACHZ=COMFAC*8D0*(AEM*XWC)**2*
21921 & (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2)
21922 FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2)
21923 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
21924 & PARU(154+10*IHIGG)**2
21925 DO 680 I=MMINA,MMAXA
21926 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 680
21927 EI=KCHG(IABS(I),1)/3D0
21928 AI=SIGN(1D0,EI)
21929 VI=AI-4D0*EI*XWV
21930 FCOI=1D0
21931 IF(IABS(I).LE.10) FCOI=FACA/3D0
21932 NCHN=NCHN+1
21933 ISIG(NCHN,1)=I
21934 ISIG(NCHN,2)=-I
21935 ISIG(NCHN,3)=1
21936 SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2)
21937 680 CONTINUE
21938
21939 ELSEIF(ISUB.EQ.25) THEN
21940C...f + fbar -> W+ + W-
21941C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
21942 GMMZC=GMMZ
21943 HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2)
21944 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
21945 CALL PYWIDT(24,SQM3,WDTP,WDTE)
21946 GMMW3=SQRT(SQM3)*WDTP(0)
21947 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
21948 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
21949 CALL PYWIDT(24,SQM4,WDTP,WDTE)
21950 GMMW4=SQRT(SQM4)*WDTP(0)
21951 HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2)
21952C...Kinematical functions
21953 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
21954 THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4)
21955 GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2
21956 GT=THUH34+4D0*THUH/TH2
21957 GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH
21958 GU=THUH34+4D0*THUH/UH2
21959 GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH
21960C...Common factors and couplings
21961 FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)
21962 FACWW=FACWW*WIDS(24,1)
21963 CGG=AEM**2/2D0
21964 CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH)
21965 CZZ=AEM**2/(32D0*XW**2)*HBWZC
21966 CNG=AEM**2/(4D0*XW)
21967 CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH)
21968 CNN=AEM**2/(16D0*XW**2)
21969C...Coulomb factor for W+W- pair
21970 IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
21971 COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1))
21972 COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH))
21973 IF(COULE.LT.100D0*PMAS(24,2)) THEN
21974 COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
21975 & PMAS(24,2)**2)-COULE))
21976 ELSE
21977 COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE))
21978 ENDIF
21979 IF(COULE.GT.-100D0*PMAS(24,2)) THEN
21980 COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
21981 & PMAS(24,2)**2)+COULE))
21982 ELSE
21983 COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/
21984 & ABS(COULE)))
21985 ENDIF
21986 IF(MSTP(40).EQ.1) THEN
21987 COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/
21988 & MAX(1D-10,2D0*COULP*COULP1))
21989 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
21990 ELSEIF(MSTP(40).EQ.2) THEN
21991 COULCK=DCMPLX(DBLE(COULP1),DBLE(COULP2))
21992 COULCP=DCMPLX(0D0,DBLE(COULP))
21993 COULCD=(COULCK+COULCP)/(COULCK-COULCP)
21994 COULCR=1D0+DBLE(PARU(101)*SQRT(SH))/
21995 & (4D0*COULCP)*LOG(COULCD)
21996 COULCS=DCMPLX(0D0,0D0)
21997 NSTP=100
21998 DO 690 ISTP=1,NSTP
21999 COULXX=(ISTP-0.5)/NSTP
22000 COULCS=COULCS+(1D0/COULXX)*LOG((1D0+COULXX*COULCD)/
22001 & (1D0+COULXX/COULCD))
22002 690 CONTINUE
22003 COULCR=COULCR+DBLE(PARU(101)**2*SH)/(16D0*COULCP*COULCK)*
22004 & (COULCS/NSTP)
22005 FACCOU=ABS(COULCR)**2
22006 ELSEIF(MSTP(40).EQ.3) THEN
22007 COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+
22008 & COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1))
22009 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
22010 ENDIF
22011 ELSEIF(MSTP(40).EQ.4) THEN
22012 FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34)
22013 ELSE
22014 FACCOU=1D0
22015 ENDIF
22016 VINT(95)=FACCOU
22017 FACWW=FACWW*FACCOU
22018C...Loop over allowed flavours
22019 DO 700 I=MMINA,MMAXA
22020 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 700
22021 EI=KCHG(IABS(I),1)/3D0
22022 AI=SIGN(1D0,EI+0.1D0)
22023 VI=AI-4D0*EI*XWV
22024 FCOI=1D0
22025 IF(IABS(I).LE.10) FCOI=FACA/3D0
22026 IF(MSTP(50).LE.0.OR.IABS(I).LE.10) THEN
22027 IF(AI.LT.0D0) THEN
22028 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+
22029 & (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT
22030 ELSE
22031 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS-
22032 & (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU
22033 ENDIF
22034 ELSE
22035 XMW02=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
22036 BET=SQRT(1D0-4D0*XMW02/SH)
22037 GAT=1D0/SQRT(1D0-BET**2)
22038 STHE2=1D0-CTH**2
22039 AMPZG=BET**3*(16D0+(4D0*BET**2*GAT**2+3D0/GAT**2)*STHE2)
22040 AMPNU=BET*(2D0+BET**2*GAT**2*STHE2/2D0+
22041 & 2D0*BET**2*(1D0-BET**2)*STHE2/(1D0-2D0*BET*CTH+BET**2)**2)
22042 AMPNG=BET*((1D0+BET**2)*(4D0+BET**2*GAT**2*STHE2)+
22043 & 2D0*(1D0-BET**2)*(BET**2*STHE2-2D0*(1D0-BET**2))/
22044 & (1D0-2D0*BET*CTH+BET**2))
22045 PROPI1=(0.25D0*SQMZ/XMW02)*HBWZC*(1D0-SQMZ/SH)
22046 PROPI2=(0.25D0*SQMZ/XMW02)**2*HBWZC
22047 A0=(2D0*(XMW02/SQMZ)-(1D0-BET**2)*XW)*POLL
22048 A1=(2D0*(XMW02/SQMZ)**2-2*XMW02/SQMZ*(1D0-BET**2)*XW)*POLL
22049 A2=(1D0-BET**2)**2*XW**2*(POLR+POLL)/2D0
22050 ATOT=AMPNU*POLL+(A1+A2)*PROPI2*AMPZG-A0*PROPI1*AMPNG
22051 ATOT=ATOT*CNN/SQMW*SH/BET*2D0
22052 DSIGWW=ATOT
22053 ENDIF
22054 NCHN=NCHN+1
22055 ISIG(NCHN,1)=I
22056 ISIG(NCHN,2)=-I
22057 ISIG(NCHN,3)=1
22058 SIGH(NCHN)=FACWW*FCOI*DSIGWW
22059 700 CONTINUE
22060
22061 ELSEIF(ISUB.EQ.26) THEN
22062C...f + fbar' -> W+/- + h0 (or H0, or A0)
22063 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
22064 FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/
22065 & ((SH-SQMW)**2+GMMW**2)
22066 FACHW=FACHW*WIDS(KFHIGG,2)
22067 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
22068 & PARU(155+10*IHIGG)**2
22069 DO 720 I=MMIN1,MMAX1
22070 IA=IABS(I)
22071 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 720
22072 DO 710 J=MMIN2,MMAX2
22073 JA=IABS(J)
22074 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 710
22075 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 710
22076 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
22077 & GOTO 710
22078 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
22079 FCKM=1D0
22080 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
22081 FCOI=1D0
22082 IF(IA.LE.10) FCOI=FACA/3D0
22083 NCHN=NCHN+1
22084 ISIG(NCHN,1)=I
22085 ISIG(NCHN,2)=J
22086 ISIG(NCHN,3)=1
22087 SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2)
22088 710 CONTINUE
22089 720 CONTINUE
22090
22091 ELSEIF(ISUB.EQ.27) THEN
22092C...f + fbar -> h0 + h0
22093
22094 ELSEIF(ISUB.EQ.28) THEN
22095C...f + g -> f + g (q + g -> q + g only)
22096 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
22097 & UH/SH-9D0/4D0*SH*UH/TH2*SQDLGT)*FACA
22098 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
22099 & SH/UH-9D0/4D0*SH*UH/TH2*SQDLGT)
22100 DO 740 I=MMINA,MMAXA
22101 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 740
22102 DO 730 ISDE=1,2
22103 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 730
22104 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 730
22105 NCHN=NCHN+1
22106 ISIG(NCHN,ISDE)=I
22107 ISIG(NCHN,3-ISDE)=21
22108 ISIG(NCHN,3)=1
22109 SIGH(NCHN)=FACQG1
22110 NCHN=NCHN+1
22111 ISIG(NCHN,ISDE)=I
22112 ISIG(NCHN,3-ISDE)=21
22113 ISIG(NCHN,3)=2
22114 SIGH(NCHN)=FACQG2
22115 730 CONTINUE
22116 740 CONTINUE
22117
22118 ELSEIF(ISUB.EQ.29) THEN
22119C...f + g -> f + gamma (q + g -> q + gamma only)
22120 FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH)
22121 DO 760 I=MMINA,MMAXA
22122 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 760
22123 EI=KCHG(IABS(I),1)/3D0
22124 FACGQ=FGQ*EI**2
22125 DO 750 ISDE=1,2
22126 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 750
22127 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 750
22128 NCHN=NCHN+1
22129 ISIG(NCHN,ISDE)=I
22130 ISIG(NCHN,3-ISDE)=21
22131 ISIG(NCHN,3)=1
22132 SIGH(NCHN)=FACGQ
22133 750 CONTINUE
22134 760 CONTINUE
22135
22136 ELSEIF(ISUB.EQ.30) THEN
22137C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
22138 FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/
22139 & (-SH*UH)
22140C...gamma, gamma/Z interference and Z couplings to final fermion pairs
22141 HFGG=0D0
22142 HFGZ=0D0
22143 HFZZ=0D0
22144 RADC4=1D0+PYALPS(SQM4)/PARU(1)
22145 DO 770 I=1,MIN(16,MDCY(23,3))
22146 IDC=I+MDCY(23,2)-1
22147 IF(MDME(IDC,1).LT.0) GOTO 770
22148 IMDM=0
22149 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
22150 & IMDM=1
22151 IF(I.LE.8) THEN
22152 EF=KCHG(I,1)/3D0
22153 AF=SIGN(1D0,EF+0.1D0)
22154 VF=AF-4D0*EF*XWV
22155 ELSEIF(I.LE.16) THEN
22156 EF=KCHG(I+2,1)/3D0
22157 AF=SIGN(1D0,EF+0.1D0)
22158 VF=AF-4D0*EF*XWV
22159 ENDIF
22160 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
22161 IF(4D0*RM1.LT.1D0) THEN
22162 FCOF=1D0
22163 IF(I.LE.8) FCOF=3D0*RADC4
22164 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
22165 IF(IMDM.EQ.1) THEN
22166 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
22167 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
22168 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
22169 & AF**2*(1D0-4D0*RM1))*BE34
22170 ENDIF
22171 ENDIF
22172 770 CONTINUE
22173C...Propagators: as simulated in PYOFSH and as desired
22174 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
22175 MINT15=MINT(15)
22176 MINT(15)=1
22177 MINT(61)=1
22178 CALL PYWIDT(23,SQM4,WDTP,WDTE)
22179 MINT(15)=MINT15
22180 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
22181 HFGG=HFGG*HFAEM*VINT(111)/SQM4
22182 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
22183 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
22184C...Loop over flavours; consider full gamma/Z structure
22185 DO 790 I=MMINA,MMAXA
22186 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 790
22187 EI=KCHG(IABS(I),1)/3D0
22188 AI=SIGN(1D0,EI)
22189 VI=AI-4D0*EI*XWV
22190 FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+
22191 & (VI**2+AI**2)*HFZZ)/HBW4
22192 DO 780 ISDE=1,2
22193 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 780
22194 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 780
22195 NCHN=NCHN+1
22196 ISIG(NCHN,ISDE)=I
22197 ISIG(NCHN,3-ISDE)=21
22198 ISIG(NCHN,3)=1
22199 SIGH(NCHN)=FACZQ
22200 780 CONTINUE
22201 790 CONTINUE
22202 ENDIF
22203
22204 ELSEIF(ISUB.LE.40) THEN
22205 IF(ISUB.EQ.31) THEN
22206C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
22207 FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0*
22208 & (SH2+UH2+2D0*SQM4*TH)/(-SH*UH)
22209C...Propagators: as simulated in PYOFSH and as desired
22210 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
22211 CALL PYWIDT(24,SQM4,WDTP,WDTE)
22212 GMMWC=SQRT(SQM4)*WDTP(0)
22213 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
22214 FACWQ=FACWQ*HBW4C/HBW4
22215 DO 810 I=MMINA,MMAXA
22216 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 810
22217 IA=IABS(I)
22218 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
22219 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
22220 DO 800 ISDE=1,2
22221 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 800
22222 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 800
22223 NCHN=NCHN+1
22224 ISIG(NCHN,ISDE)=I
22225 ISIG(NCHN,3-ISDE)=21
22226 ISIG(NCHN,3)=1
22227 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
22228 800 CONTINUE
22229 810 CONTINUE
22230
22231 ELSEIF(ISUB.EQ.32) THEN
22232C...f + g -> f + h0 (q + g -> q + h0 only)
22233 SQMHC=PMAS(25,1)**2
22234 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24D0
22235 DO 830 I=MMINA,MMAXA
22236 IA=IABS(I)
22237 IF(IA.NE.5) GOTO 830
22238 SQML=PMAS(IA,1)**2
22239 IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) SQML=SQML*
22240 & (LOG(MAX(4D0,PARP(37)**2*SQML/PARU(117)**2))/
22241 & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
22242 IUA=IA+MOD(IA,2)
22243 SQMQ=SQML
22244 FACHCQ=FHCQ*SQML/SQMW*
22245 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH+
22246 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
22247 & (SQMHC-SQMQ-SH)/SH)
22248 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
22249 DO 820 ISDE=1,2
22250 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 820
22251 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,1).EQ.0) GOTO 820
22252 NCHN=NCHN+1
22253 ISIG(NCHN,ISDE)=I
22254 ISIG(NCHN,3-ISDE)=21
22255 ISIG(NCHN,3)=1
22256 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
22257 820 CONTINUE
22258 830 CONTINUE
22259
22260 ELSEIF(ISUB.EQ.33) THEN
22261C...f + gamma -> f + g (q + gamma -> q + g only)
22262 FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH)
22263 DO 850 I=MMINA,MMAXA
22264 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 850
22265 EI=KCHG(IABS(I),1)/3D0
22266 FACGQ=FGQ*EI**2
22267 DO 840 ISDE=1,2
22268 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 840
22269 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 840
22270 NCHN=NCHN+1
22271 ISIG(NCHN,ISDE)=I
22272 ISIG(NCHN,3-ISDE)=22
22273 ISIG(NCHN,3)=1
22274 SIGH(NCHN)=FACGQ
22275 840 CONTINUE
22276 850 CONTINUE
22277
22278 ELSEIF(ISUB.EQ.34) THEN
22279C...f + gamma -> f + gamma
22280 FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH)
22281 DO 870 I=MMINA,MMAXA
22282 IF(I.EQ.0) GOTO 870
22283 EI=KCHG(IABS(I),1)/3D0
22284 FACGQ=FGQ*EI**4
22285 DO 860 ISDE=1,2
22286 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 860
22287 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 860
22288 NCHN=NCHN+1
22289 ISIG(NCHN,ISDE)=I
22290 ISIG(NCHN,3-ISDE)=22
22291 ISIG(NCHN,3)=1
22292 SIGH(NCHN)=FACGQ
22293 860 CONTINUE
22294 870 CONTINUE
22295
22296 ELSEIF(ISUB.EQ.35) THEN
22297C...f + gamma -> f + (gamma*/Z0)
22298 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) THEN
22299 FZQN=SH2+UH2+2D0*(SQM4-VINT(3)**2)*TH
22300 FZQDTM=VINT(3)**2*SQM4-SH*(UH-VINT(4)**2)
22301 ELSEIF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) THEN
22302 FZQN=SH2+UH2+2D0*(SQM4-VINT(4)**2)*TH
22303 FZQDTM=VINT(4)**2*SQM4-SH*(UH-VINT(3)**2)
22304 ELSE
22305 FZQN=SH2+UH2+2D0*SQM4*TH
22306 FZQDTM=-SH*UH
22307 ENDIF
22308 FZQN=COMFAC*2D0*AEM**2*MAX(0D0,FZQN)
22309C...gamma, gamma/Z interference and Z couplings to final fermion pairs
22310 HFGG=0D0
22311 HFGZ=0D0
22312 HFZZ=0D0
22313 RADC4=1D0+PYALPS(SQM4)/PARU(1)
22314 DO 880 I=1,MIN(16,MDCY(23,3))
22315 IDC=I+MDCY(23,2)-1
22316 IF(MDME(IDC,1).LT.0) GOTO 880
22317 IMDM=0
22318 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
22319 & IMDM=1
22320 IF(I.LE.8) THEN
22321 EF=KCHG(I,1)/3D0
22322 AF=SIGN(1D0,EF+0.1D0)
22323 VF=AF-4D0*EF*XWV
22324 ELSEIF(I.LE.16) THEN
22325 EF=KCHG(I+2,1)/3D0
22326 AF=SIGN(1D0,EF+0.1D0)
22327 VF=AF-4D0*EF*XWV
22328 ENDIF
22329 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
22330 IF(4D0*RM1.LT.1D0) THEN
22331 FCOF=1D0
22332 IF(I.LE.8) FCOF=3D0*RADC4
22333 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
22334 IF(IMDM.EQ.1) THEN
22335 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
22336 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
22337 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
22338 & AF**2*(1D0-4D0*RM1))*BE34
22339 ENDIF
22340 ENDIF
22341 880 CONTINUE
22342C...Propagators: as simulated in PYOFSH and as desired
22343 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
22344 MINT15=MINT(15)
22345 MINT(15)=1
22346 MINT(61)=1
22347 CALL PYWIDT(23,SQM4,WDTP,WDTE)
22348 MINT(15)=MINT15
22349 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
22350 HFGG=HFGG*HFAEM*VINT(111)/SQM4
22351 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
22352 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
22353C...Loop over flavours; consider full gamma/Z structure
22354 DO 900 I=MMINA,MMAXA
22355 IF(I.EQ.0) GOTO 900
22356 EI=KCHG(IABS(I),1)/3D0
22357 AI=SIGN(1D0,EI)
22358 VI=AI-4D0*EI*XWV
22359 FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+
22360 & (VI**2+AI**2)*HFZZ)/HBW4
22361 FZQD=MAX(PMAS(IABS(I),1)**2*SQM4,FZQDTM)
22362 DO 890 ISDE=1,2
22363 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 890
22364 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 890
22365 NCHN=NCHN+1
22366 ISIG(NCHN,ISDE)=I
22367 ISIG(NCHN,3-ISDE)=22
22368 ISIG(NCHN,3)=1
22369 SIGH(NCHN)=FACZQ*FZQN/FZQD
22370 890 CONTINUE
22371 900 CONTINUE
22372
22373 ELSEIF(ISUB.EQ.36) THEN
22374C...f + gamma -> f' + W+/-
22375 FWQ=COMFAC*AEM**2/(2D0*XW)*
22376 & (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH)
22377C...Propagators: as simulated in PYOFSH and as desired
22378 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
22379 CALL PYWIDT(24,SQM4,WDTP,WDTE)
22380 GMMWC=SQRT(SQM4)*WDTP(0)
22381 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
22382 FWQ=FWQ*HBW4C/HBW4
22383 DO 920 I=MMINA,MMAXA
22384 IF(I.EQ.0) GOTO 920
22385 IA=IABS(I)
22386 EIA=ABS(KCHG(IABS(I),1)/3D0)
22387 FACWQ=FWQ*(EIA-SH/(SH+UH))**2
22388 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
22389 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
22390 DO 910 ISDE=1,2
22391 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 910
22392 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 910
22393 NCHN=NCHN+1
22394 ISIG(NCHN,ISDE)=I
22395 ISIG(NCHN,3-ISDE)=22
22396 ISIG(NCHN,3)=1
22397 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
22398 910 CONTINUE
22399 920 CONTINUE
22400
22401 ELSEIF(ISUB.EQ.37) THEN
22402C...f + gamma -> f + h0
22403
22404 ELSEIF(ISUB.EQ.38) THEN
22405C...f + Z0 -> f + g (q + Z0 -> q + g only)
22406
22407 ELSEIF(ISUB.EQ.39) THEN
22408C...f + Z0 -> f + gamma
22409
22410 ELSEIF(ISUB.EQ.40) THEN
22411C...f + Z0 -> f + Z0
22412 ENDIF
22413
22414 ELSEIF(ISUB.LE.50) THEN
22415 IF(ISUB.EQ.41) THEN
22416C...f + Z0 -> f' + W+/-
22417
22418 ELSEIF(ISUB.EQ.42) THEN
22419C...f + Z0 -> f + h0
22420
22421 ELSEIF(ISUB.EQ.43) THEN
22422C...f + W+/- -> f' + g (q + W+/- -> q' + g only)
22423
22424 ELSEIF(ISUB.EQ.44) THEN
22425C...f + W+/- -> f' + gamma
22426
22427 ELSEIF(ISUB.EQ.45) THEN
22428C...f + W+/- -> f' + Z0
22429
22430 ELSEIF(ISUB.EQ.46) THEN
22431C...f + W+/- -> f' + W+/-
22432
22433 ELSEIF(ISUB.EQ.47) THEN
22434C...f + W+/- -> f' + h0
22435
22436 ELSEIF(ISUB.EQ.48) THEN
22437C...f + h0 -> f + g (q + h0 -> q + g only)
22438
22439 ELSEIF(ISUB.EQ.49) THEN
22440C...f + h0 -> f + gamma
22441
22442 ELSEIF(ISUB.EQ.50) THEN
22443C...f + h0 -> f + Z0
22444 ENDIF
22445
22446 ELSEIF(ISUB.LE.60) THEN
22447 IF(ISUB.EQ.51) THEN
22448C...f + h0 -> f' + W+/-
22449
22450 ELSEIF(ISUB.EQ.52) THEN
22451C...f + h0 -> f + h0
22452
22453 ELSEIF(ISUB.EQ.53) THEN
22454C...g + g -> f + fbar (g + g -> q + qbar only)
22455 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 940
22456 IDC0=MDCY(21,2)-1
22457C...Begin by d, u, s flavours.
22458 FLAVWT=0D0
22459 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
22460 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
22461 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
22462 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
22463 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
22464 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
22465 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
22466 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
22467 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
22468 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
22469 NCHN=NCHN+1
22470 ISIG(NCHN,1)=21
22471 ISIG(NCHN,2)=21
22472 ISIG(NCHN,3)=1
22473 SIGH(NCHN)=FACQQ1
22474 NCHN=NCHN+1
22475 ISIG(NCHN,1)=21
22476 ISIG(NCHN,2)=21
22477 ISIG(NCHN,3)=2
22478 SIGH(NCHN)=FACQQ2
22479C...Next c and b flavours: modified that and uhat for fixed
22480C...cos(theta-hat).
22481 DO 930 IFL=4,5
22482 SQMAVG=PMAS(IFL,1)**2
22483 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
22484 BE34=SQRT(1D0-4D0*SQMAVG/SH)
22485 THQ=-0.5D0*SH*(1D0-BE34*CTH)
22486 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
22487 THUHQ=THQ*UHQ-SQMAVG*SH
22488 IF(MSTP(34).EQ.0) THEN
22489 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
22490 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
22491 ELSE
22492 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
22493 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
22494 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
22495 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
22496 ENDIF
22497 IF(MSTP(5).GE.5) THEN
22498 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDGGS+
22499 & 2.25D0*THQ*UHQ/SH2*SQDLGS
22500 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDGGS+
22501 & 2.25D0*THQ*UHQ/SH2*SQDLGS
22502 ENDIF
22503 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
22504 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
22505 NCHN=NCHN+1
22506 ISIG(NCHN,1)=21
22507 ISIG(NCHN,2)=21
22508 ISIG(NCHN,3)=1+2*(IFL-3)
22509 SIGH(NCHN)=FACQQ1
22510 NCHN=NCHN+1
22511 ISIG(NCHN,1)=21
22512 ISIG(NCHN,2)=21
22513 ISIG(NCHN,3)=2+2*(IFL-3)
22514 SIGH(NCHN)=FACQQ2
22515 ENDIF
22516 930 CONTINUE
22517 940 CONTINUE
22518
22519 ELSEIF(ISUB.EQ.54) THEN
22520C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
22521 CALL PYWIDT(21,SH,WDTP,WDTE)
22522 WDTESU=0D0
22523 DO 950 I=1,MIN(8,MDCY(21,3))
22524 EF=KCHG(I,1)/3D0
22525 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
22526 & WDTE(I,4))
22527 950 CONTINUE
22528 FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH)
22529 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
22530 NCHN=NCHN+1
22531 ISIG(NCHN,1)=21
22532 ISIG(NCHN,2)=22
22533 ISIG(NCHN,3)=1
22534 SIGH(NCHN)=FACQQ
22535 ENDIF
22536 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
22537 NCHN=NCHN+1
22538 ISIG(NCHN,1)=22
22539 ISIG(NCHN,2)=21
22540 ISIG(NCHN,3)=1
22541 SIGH(NCHN)=FACQQ
22542 ENDIF
22543
22544 ELSEIF(ISUB.EQ.55) THEN
22545C...g + Z -> f + fbar (g + Z -> q + qbar only)
22546
22547 ELSEIF(ISUB.EQ.56) THEN
22548C...g + W -> f + f'bar (g + W -> q + q'bar only)
22549
22550 ELSEIF(ISUB.EQ.57) THEN
22551C...g + h0 -> f + fbar (g + h0 -> q + qbar only)
22552
22553 ELSEIF(ISUB.EQ.58) THEN
22554C...gamma + gamma -> f + fbar
22555 CALL PYWIDT(22,SH,WDTP,WDTE)
22556 WDTESU=0D0
22557 DO 960 I=1,MIN(12,MDCY(22,3))
22558 IF(I.LE.8) EF= KCHG(I,1)/3D0
22559 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
22560 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
22561 & WDTE(I,4))
22562 960 CONTINUE
22563 FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH)
22564 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
22565 NCHN=NCHN+1
22566 ISIG(NCHN,1)=22
22567 ISIG(NCHN,2)=22
22568 ISIG(NCHN,3)=1
22569 SIGH(NCHN)=FACFF
22570 ENDIF
22571
22572 ELSEIF(ISUB.EQ.59) THEN
22573C...gamma + Z0 -> f + fbar
22574
22575 ELSEIF(ISUB.EQ.60) THEN
22576C...gamma + W+/- -> f + fbar'
22577 ENDIF
22578
22579 ELSEIF(ISUB.LE.70) THEN
22580 IF(ISUB.EQ.61) THEN
22581C...gamma + h0 -> f + fbar
22582
22583 ELSEIF(ISUB.EQ.62) THEN
22584C...Z0 + Z0 -> f + fbar
22585
22586 ELSEIF(ISUB.EQ.63) THEN
22587C...Z0 + W+/- -> f + fbar'
22588
22589 ELSEIF(ISUB.EQ.64) THEN
22590C...Z0 + h0 -> f + fbar
22591
22592 ELSEIF(ISUB.EQ.65) THEN
22593C...W+ + W- -> f + fbar
22594
22595 ELSEIF(ISUB.EQ.66) THEN
22596C...W+/- + h0 -> f + fbar'
22597
22598 ELSEIF(ISUB.EQ.67) THEN
22599C...h0 + h0 -> f + fbar
22600
22601 ELSEIF(ISUB.EQ.68) THEN
22602C...g + g -> g + g
22603 IF(MSTP(5).LE.4) THEN
22604 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
22605 & 2D0*TH/SH+TH2/SH2)*FACA
22606 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
22607 & 2D0*SH/UH+SH2/UH2)*FACA
22608 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+
22609 & 2D0*UH/TH+UH2/TH2)
22610 ELSE
22611 GST= (12D0 + 40D0*TH/SH + 56D0*TH2/SH2 + 32D0*TH**3/SH**3 +
22612 & 16D0*TH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*TH + 16D0*TH2)+
22613 & 4D0*REDGST*(SH + 2D0*TH)*
22614 & (2D0*SH**3 - 3D0*SH2*TH - 2D0*SH*TH2 + 2D0*TH**3)/SH2 +
22615 & 2D0*REDGGS*(2D0*SH - 12D0*TH2/SH - 8D0*TH**3/SH2) +
22616 & 2D0*REDGGT*(4D0*SH - 22D0*TH - 68D0*TH2/SH - 60D0*TH**3/SH2-
22617 & 32D0*TH**4/SH**3 - 16D0*TH**5/SH**4) +
22618 & SQDGGT*(16D0*SH2 + 16D0*SH*TH + 68D0*TH2 + 144D0*TH**3/SH +
22619 & 96D0*TH**4/SH2 + 32D0*TH**5/SH**3 + 16D0*TH**6/SH**4))/16D0
22620 GSU= (12D0 + 40D0*UH/SH + 56D0*UH2/SH2 + 32D0*UH**3/SH**3 +
22621 & 16D0*UH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*UH + 16D0*UH2)+
22622 & 4D0*REDGSU*(SH + 2D0*UH)*
22623 & (2D0*SH**3 - 3D0*SH2*UH - 2D0*SH*UH2 + 2D0*UH**3)/SH2 +
22624 & 2D0*REDGGS*(2D0*SH - 12D0*UH2/SH - 8D0*UH**3/SH2) +
22625 & 2D0*REDGGU*(4D0*SH - 22D0*UH - 68D0*UH2/SH - 60D0*UH**3/SH2-
22626 & 32D0*UH**4/SH**3 - 16D0*UH**5/SH**4) +
22627 & SQDGGU*(16D0*SH2 + 16D0*SH*UH + 68D0*UH2 + 144D0*UH**3/SH +
22628 & 96D0*UH**4/SH2 + 32D0*UH**5/SH**3 + 16D0*UH**6/SH**4))/16D0
22629 GUT= (12D0 - 16D0*TH*(TH - UH)**2*UH/SH**4 +
22630 & 4D0*REDGGU*(2D0*TH**5 - 15D0*TH**4*UH - 48D0*TH**3*UH2 -
22631 & 58D0*TH2*UH**3 - 10D0*TH*UH**4 + UH**5)/SH**4 +
22632 & 4D0*REDGGT*(TH**5 - 10D0*TH**4*UH - 58D0*TH**3*UH2 -
22633 & 48D0*TH2*UH**3 - 15D0*TH*UH**4 + 2D0*UH**5)/SH**4 +
22634 & 4D0*SQDGGU*(4D0*TH**6 + 20D0*TH**5*UH + 57D0*TH**4*UH2 +
22635 & 72D0*TH**3*UH**3+ 38D0*TH2*UH**4+4D0*TH*UH**5 +UH**6)/SH**4+
22636 & 4D0*SQDGGT*(4D0*UH**6 + 4D0*TH**5*UH + 38D0*TH**4*UH2 +
22637 & 72D0*TH**3*UH**3 +57D0*TH2*UH**4+20D0*TH*UH**5+TH**6)/SH**4+
22638 & 2D0*REDGTU*((TH - UH)**2* (TH**4 + 20D0*TH**3*UH +
22639 & 30D0*TH2*UH2 + 20D0*TH*UH**3 + UH**4) +
22640 & SH2*(7D0*TH**4 + 52D0*TH**3*UH + 274D0*TH2*UH2 +
22641 & 52D0*TH*UH**3 + 7D0*UH**4))/(2D0*SH**4))/16D0
22642 FACGG1=COMFAC*AS**2*9D0/4D0*GST*FACA
22643 FACGG2=COMFAC*AS**2*9D0/4D0*GSU*FACA
22644 FACGG3=COMFAC*AS**2*9D0/4D0*GUT
22645 ENDIF
22646 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 970
22647 NCHN=NCHN+1
22648 ISIG(NCHN,1)=21
22649 ISIG(NCHN,2)=21
22650 ISIG(NCHN,3)=1
22651 SIGH(NCHN)=0.5D0*FACGG1
22652 NCHN=NCHN+1
22653 ISIG(NCHN,1)=21
22654 ISIG(NCHN,2)=21
22655 ISIG(NCHN,3)=2
22656 SIGH(NCHN)=0.5D0*FACGG2
22657 NCHN=NCHN+1
22658 ISIG(NCHN,1)=21
22659 ISIG(NCHN,2)=21
22660 ISIG(NCHN,3)=3
22661 SIGH(NCHN)=0.5D0*FACGG3
22662 970 CONTINUE
22663
22664 ELSEIF(ISUB.EQ.69) THEN
22665C...gamma + gamma -> W+ + W-
22666 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
22667 FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
22668 FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+
22669 & FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1)
22670 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 980
22671 NCHN=NCHN+1
22672 ISIG(NCHN,1)=22
22673 ISIG(NCHN,2)=22
22674 ISIG(NCHN,3)=1
22675 SIGH(NCHN)=FACWW
22676 980 CONTINUE
22677
22678 ELSEIF(ISUB.EQ.70) THEN
22679C...gamma + W+/- -> Z0 + W+/-
22680 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
22681 FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH))
22682 FACZW=COMFAC*6D0*AEM**2*(XW1/XW)*
22683 & (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+
22684 & FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2)
22685 DO 1000 KCHW=1,-1,-2
22686 DO 990 ISDE=1,2
22687 IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 990
22688 NCHN=NCHN+1
22689 ISIG(NCHN,ISDE)=22
22690 ISIG(NCHN,3-ISDE)=24*KCHW
22691 ISIG(NCHN,3)=1
22692 SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2)
22693 990 CONTINUE
22694 1000 CONTINUE
22695 ENDIF
22696
22697 ELSEIF(ISUB.LE.80) THEN
22698 IF(ISUB.EQ.71) THEN
22699C...Z0 + Z0 -> Z0 + Z0
22700 IF(SH.LE.4.01D0*SQMZ) GOTO 1030
22701
22702 IF(MSTP(46).LE.2) THEN
22703C...Exact scattering ME:s for on-mass-shell gauge bosons
22704 BE2=1D0-4D0*SQMZ/SH
22705 TH=-0.5D0*SH*BE2*(1D0-CTH)
22706 UH=-0.5D0*SH*BE2*(1D0+CTH)
22707 IF(MAX(TH,UH).GT.-1D0) GOTO 1030
22708 SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2
22709 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
22710 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
22711 THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2
22712 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
22713 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
22714 UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2
22715 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
22716 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
22717 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
22718 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
22719 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
22720 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+
22721 & (ASHIM+ATHIM+AUHIM)**2)
22722 IF(MSTP(46).EQ.2) FACZZ=0D0
22723
22724 ELSE
22725C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
22726 FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
22727 & ABS(A00U+2D0*A20U)**2
22728 ENDIF
22729 FACZZ=FACZZ*WIDS(23,1)
22730
22731 DO 1020 I=MMIN1,MMAX1
22732 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1020
22733 EI=KCHG(IABS(I),1)/3D0
22734 AI=SIGN(1D0,EI)
22735 VI=AI-4D0*EI*XWV
22736 AVI=AI**2+VI**2
22737 DO 1010 J=MMIN2,MMAX2
22738 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1010
22739 EJ=KCHG(IABS(J),1)/3D0
22740 AJ=SIGN(1D0,EJ)
22741 VJ=AJ-4D0*EJ*XWV
22742 AVJ=AJ**2+VJ**2
22743 NCHN=NCHN+1
22744 ISIG(NCHN,1)=I
22745 ISIG(NCHN,2)=J
22746 ISIG(NCHN,3)=1
22747 SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ
22748 1010 CONTINUE
22749 1020 CONTINUE
22750 1030 CONTINUE
22751
22752 ELSEIF(ISUB.EQ.72) THEN
22753C...Z0 + Z0 -> W+ + W-
22754 IF(SH.LE.4.01D0*SQMZ) GOTO 1060
22755
22756 IF(MSTP(46).LE.2) THEN
22757C...Exact scattering ME:s for on-mass-shell gauge bosons
22758 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
22759 CTH2=CTH**2
22760 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
22761 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
22762 IF(MAX(TH,UH).GT.-1D0) GOTO 1060
22763 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
22764 & (1D0-2D0*SQMZ/SH)
22765 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
22766 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
22767 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
22768 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
22769 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
22770 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
22771 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
22772 ATWIM=0D0
22773 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
22774 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
22775 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
22776 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
22777 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
22778 AUWIM=0D0
22779 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
22780 A4IM=0D0
22781 FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
22782 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
22783 IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2)
22784 IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+
22785 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
22786 IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+
22787 & (ATWIM+AUWIM+A4IM)**2)
22788
22789 ELSE
22790C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
22791 FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
22792 & ABS(A00U-A20U)**2
22793 ENDIF
22794 FACWW=FACWW*WIDS(24,1)
22795
22796 DO 1050 I=MMIN1,MMAX1
22797 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1050
22798 EI=KCHG(IABS(I),1)/3D0
22799 AI=SIGN(1D0,EI)
22800 VI=AI-4D0*EI*XWV
22801 AVI=AI**2+VI**2
22802 DO 1040 J=MMIN2,MMAX2
22803 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1040
22804 EJ=KCHG(IABS(J),1)/3D0
22805 AJ=SIGN(1D0,EJ)
22806 VJ=AJ-4D0*EJ*XWV
22807 AVJ=AJ**2+VJ**2
22808 NCHN=NCHN+1
22809 ISIG(NCHN,1)=I
22810 ISIG(NCHN,2)=J
22811 ISIG(NCHN,3)=1
22812 SIGH(NCHN)=FACWW*AVI*AVJ
22813 1040 CONTINUE
22814 1050 CONTINUE
22815 1060 CONTINUE
22816
22817 ELSEIF(ISUB.EQ.73) THEN
22818C...Z0 + W+/- -> Z0 + W+/-
22819 IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 1090
22820
22821 IF(MSTP(46).LE.2) THEN
22822C...Exact scattering ME:s for on-mass-shell gauge bosons
22823 BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
22824 EP1=1D0-(SQMZ-SQMW)/SH
22825 EP2=1D0+(SQMZ-SQMW)/SH
22826 TH=-0.5D0*SH*BE2*(1D0-CTH)
22827 UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH)
22828 IF(MAX(TH,UH).GT.-1D0) GOTO 1090
22829 THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH)
22830 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
22831 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
22832 ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
22833 & 1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+
22834 & 2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
22835 & 1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
22836 ASWIM=0D0
22837 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
22838 & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
22839 & (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)-
22840 & BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0*
22841 & (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+
22842 & 1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
22843 & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
22844 & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
22845 & (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*
22846 & (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2*
22847 & ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW*
22848 & (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
22849 AUWIM=0D0
22850 A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)-
22851 & 2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2)
22852 A4IM=0D0
22853 FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4*
22854 & (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2
22855 IF(MSTP(46).LE.0) FACZW=0D0
22856 IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+
22857 & (ATHIM+ASWIM+AUWIM+A4IM)**2)
22858 IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+
22859 & (ASWIM+AUWIM+A4IM)**2)
22860
22861 ELSE
22862C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
22863 FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0*
22864 & ABS(A20U+3D0*A11U*DBLE(CTH))**2
22865 ENDIF
22866 FACZW=FACZW*WIDS(23,2)
22867
22868 DO 1080 I=MMIN1,MMAX1
22869 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1080
22870 EI=KCHG(IABS(I),1)/3D0
22871 AI=SIGN(1D0,EI)
22872 VI=AI-4D0*EI*XWV
22873 AVI=AI**2+VI**2
22874 KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I))
22875 DO 1070 J=MMIN2,MMAX2
22876 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1070
22877 EJ=KCHG(IABS(J),1)/3D0
22878 AJ=SIGN(1D0,EJ)
22879 VJ=AI-4D0*EJ*XWV
22880 AVJ=AJ**2+VJ**2
22881 KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J))
22882 NCHN=NCHN+1
22883 ISIG(NCHN,1)=I
22884 ISIG(NCHN,2)=J
22885 ISIG(NCHN,3)=1
22886 SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2)
22887 NCHN=NCHN+1
22888 ISIG(NCHN,1)=I
22889 ISIG(NCHN,2)=J
22890 ISIG(NCHN,3)=2
22891 SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ
22892 1070 CONTINUE
22893 1080 CONTINUE
22894 1090 CONTINUE
22895
22896 ELSEIF(ISUB.EQ.75) THEN
22897C...W+ + W- -> gamma + gamma
22898
22899 ELSEIF(ISUB.EQ.76) THEN
22900C...W+ + W- -> Z0 + Z0
22901 IF(SH.LE.4.01D0*SQMZ) GOTO 1120
22902
22903 IF(MSTP(46).LE.2) THEN
22904C...Exact scattering ME:s for on-mass-shell gauge bosons
22905 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
22906 CTH2=CTH**2
22907 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
22908 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
22909 IF(MAX(TH,UH).GT.-1D0) GOTO 1120
22910 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
22911 & (1D0-2D0*SQMZ/SH)
22912 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
22913 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
22914 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
22915 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
22916 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
22917 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
22918 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
22919 ATWIM=0D0
22920 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
22921 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
22922 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
22923 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
22924 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
22925 AUWIM=0D0
22926 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
22927 A4IM=0D0
22928 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
22929 & (SH/SQMW)**2*SH2
22930 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
22931 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+
22932 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
22933 IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+
22934 & (ATWIM+AUWIM+A4IM)**2)
22935
22936 ELSE
22937C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
22938 FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
22939 & ABS(A00U-A20U)**2
22940 ENDIF
22941 FACZZ=FACZZ*WIDS(23,1)
22942
22943 DO 1110 I=MMIN1,MMAX1
22944 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1110
22945 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
22946 DO 1100 J=MMIN2,MMAX2
22947 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1100
22948 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
22949 IF(EI*EJ.GT.0D0) GOTO 1100
22950 NCHN=NCHN+1
22951 ISIG(NCHN,1)=I
22952 ISIG(NCHN,2)=J
22953 ISIG(NCHN,3)=1
22954 SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J)
22955 1100 CONTINUE
22956 1110 CONTINUE
22957 1120 CONTINUE
22958
22959 ELSEIF(ISUB.EQ.77) THEN
22960C...W+/- + W+/- -> W+/- + W+/-
22961 IF(SH.LE.4.01D0*SQMW) GOTO 1150
22962
22963 IF(MSTP(46).LE.2) THEN
22964C...Exact scattering ME:s for on-mass-shell gauge bosons
22965 BE2=1D0-4D0*SQMW/SH
22966 BE4=BE2**2
22967 CTH2=CTH**2
22968 CTH3=CTH**3
22969 TH=-0.5D0*SH*BE2*(1D0-CTH)
22970 UH=-0.5D0*SH*BE2*(1D0+CTH)
22971 IF(MAX(TH,UH).GT.-1D0) GOTO 1150
22972 SHANG=(1D0+BE2)**2
22973 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
22974 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
22975 THANG=(BE2-CTH)**2
22976 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
22977 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
22978 UHANG=(BE2+CTH)**2
22979 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
22980 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
22981 SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH
22982 ASGRE=XW*SGZANG
22983 ASGIM=0D0
22984 ASZRE=XW1*SH/(SH-SQMZ)*SGZANG
22985 ASZIM=0D0
22986 TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+
22987 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3)
22988 ATGRE=0.5D0*XW*SH/TH*TGZANG
22989 ATGIM=0D0
22990 ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG
22991 ATZIM=0D0
22992 UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+
22993 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3)
22994 AUGRE=0.5D0*XW*SH/UH*UGZANG
22995 AUGIM=0D0
22996 AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG
22997 AUZIM=0D0
22998 A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2)
22999 A4AIM=0D0
23000 A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2)
23001 A4SIM=0D0
23002 FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
23003 & (SH/SQMW)**2*SH2
23004 IF(MSTP(46).LE.0) THEN
23005 AWWARE=ASHRE
23006 AWWAIM=ASHIM
23007 AWWSRE=0D0
23008 AWWSIM=0D0
23009 ELSEIF(MSTP(46).EQ.1) THEN
23010 AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
23011 AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
23012 AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
23013 AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
23014 ELSE
23015 AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
23016 AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
23017 AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
23018 AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
23019 ENDIF
23020 AWWA2=AWWARE**2+AWWAIM**2
23021 AWWS2=AWWSRE**2+AWWSIM**2
23022
23023 ELSE
23024C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
23025 FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
23026 & ABS(A00U+0.5D0*A20U+4.5D0*A11U*DBLE(CTH))**2
23027 FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2
23028 ENDIF
23029
23030 DO 1140 I=MMIN1,MMAX1
23031 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1140
23032 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
23033 DO 1130 J=MMIN2,MMAX2
23034 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1130
23035 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
23036 IF(EI*EJ.LT.0D0) THEN
23037C...W+W-
23038 IF(MSTP(45).EQ.1) GOTO 1130
23039 IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1)
23040 IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1)
23041 ELSE
23042C...W+W+/W-W-
23043 IF(MSTP(45).EQ.2) GOTO 1130
23044 IF(MSTP(46).LE.2) FACWW=FWW*AWWS2
23045 IF(MSTP(46).GE.3) FACWW=FWWS
23046 IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4)
23047 IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5)
23048 ENDIF
23049 NCHN=NCHN+1
23050 ISIG(NCHN,1)=I
23051 ISIG(NCHN,2)=J
23052 ISIG(NCHN,3)=1
23053 SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J)
23054 IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN)
23055 1130 CONTINUE
23056 1140 CONTINUE
23057 1150 CONTINUE
23058
23059 ELSEIF(ISUB.EQ.78) THEN
23060C...W+/- + h0 -> W+/- + h0
23061
23062 ELSEIF(ISUB.EQ.79) THEN
23063C...h0 + h0 -> h0 + h0
23064
23065 ELSEIF(ISUB.EQ.80) THEN
23066C...q + gamma -> q' + pi+/-
23067 FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2)
23068 ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
23069 Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
23070 DELSH=UH*SQRT(ASSH*Q2FPSH)
23071 ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
23072 Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
23073 DELUH=SH*SQRT(ASUH*Q2FPUH)
23074 DO 1170 I=MAX(-2,MMINA),MIN(2,MMAXA)
23075 IF(I.EQ.0) GOTO 1170
23076 EI=KCHG(IABS(I),1)/3D0
23077 EJ=SIGN(1D0-ABS(EI),EI)
23078 DO 1160 ISDE=1,2
23079 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 1160
23080 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 1160
23081 NCHN=NCHN+1
23082 ISIG(NCHN,ISDE)=I
23083 ISIG(NCHN,3-ISDE)=22
23084 ISIG(NCHN,3)=1
23085 SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2
23086 1160 CONTINUE
23087 1170 CONTINUE
23088
23089 ENDIF
23090
23091C...C: 2 -> 2, tree diagrams with masses
23092
23093 ELSEIF(ISUB.LE.90) THEN
23094 IF(ISUB.EQ.81) THEN
23095C...q + qbar -> Q + Qbar
23096 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
23097 THQ=-0.5D0*SH*(1D0-BE34*CTH)
23098 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
23099 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
23100 & 2D0*SQMAVG/SH)
23101 IF(MSTP(5).GE.5) FACQQB=FACQQB*SH2*SQDQTS
23102 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
23103 WID2=1D0
23104 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
23105 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
23106 FACQQB=FACQQB*WID2
23107 DO 1180 I=MMINA,MMAXA
23108 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
23109 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1180
23110 NCHN=NCHN+1
23111 ISIG(NCHN,1)=I
23112 ISIG(NCHN,2)=-I
23113 ISIG(NCHN,3)=1
23114 SIGH(NCHN)=FACQQB
23115 1180 CONTINUE
23116
23117 ELSEIF(ISUB.EQ.82) THEN
23118C...g + g -> Q + Qbar
23119 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
23120 THQ=-0.5D0*SH*(1D0-BE34*CTH)
23121 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
23122 THUHQ=THQ*UHQ-SQMAVG*SH
23123 IF(MSTP(34).EQ.0) THEN
23124 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
23125 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
23126 ELSE
23127 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
23128 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
23129 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
23130 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
23131 ENDIF
23132 IF(MSTP(5).GE.5) THEN
23133 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDGGS+
23134 & 2.25D0*THQ*UHQ/SH2*SQDLGS
23135 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDGGS+
23136 & 2.25D0*THQ*UHQ/SH2*SQDLGS
23137 ENDIF
23138 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
23139 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
23140 IF(MSTP(35).GE.1) THEN
23141 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
23142 FACQQ1=FACQQ1*FATRE
23143 FACQQ2=FACQQ2*FATRE
23144 ENDIF
23145 WID2=1D0
23146 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
23147 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
23148 FACQQ1=FACQQ1*WID2
23149 FACQQ2=FACQQ2*WID2
23150 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1190
23151 NCHN=NCHN+1
23152 ISIG(NCHN,1)=21
23153 ISIG(NCHN,2)=21
23154 ISIG(NCHN,3)=1
23155 SIGH(NCHN)=FACQQ1
23156 NCHN=NCHN+1
23157 ISIG(NCHN,1)=21
23158 ISIG(NCHN,2)=21
23159 ISIG(NCHN,3)=2
23160 SIGH(NCHN)=FACQQ2
23161 1190 CONTINUE
23162
23163 ELSEIF(ISUB.EQ.83) THEN
23164C...f + q -> f' + Q
23165 FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2
23166 FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2
23167 DO 1210 I=MMIN1,MMAX1
23168 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1210
23169 DO 1200 J=MMIN2,MMAX2
23170 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1200
23171 IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 1200
23172 IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 1200
23173 IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1)
23174 & THEN
23175 NCHN=NCHN+1
23176 ISIG(NCHN,1)=I
23177 ISIG(NCHN,2)=J
23178 ISIG(NCHN,3)=1
23179 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
23180 & (IABS(I)+1)/2)*VINT(180+J)
23181 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2,
23182 & (MINT(55)+1)/2)*VINT(180+J)
23183 WID2=1D0
23184 IF(I.GT.0) THEN
23185 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
23186 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
23187 & WIDS(MINT(55),2)
23188 ELSE
23189 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
23190 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
23191 & WIDS(MINT(55),3)
23192 ENDIF
23193 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
23194 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
23195 ENDIF
23196 IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1)
23197 & THEN
23198 NCHN=NCHN+1
23199 ISIG(NCHN,1)=I
23200 ISIG(NCHN,2)=J
23201 ISIG(NCHN,3)=2
23202 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
23203 & (IABS(J)+1)/2)*VINT(180+I)
23204 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2,
23205 & (MINT(55)+1)/2)*VINT(180+I)
23206 IF(J.GT.0) THEN
23207 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
23208 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
23209 & WIDS(MINT(55),2)
23210 ELSE
23211 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
23212 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
23213 & WIDS(MINT(55),3)
23214 ENDIF
23215 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
23216 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
23217 ENDIF
23218 1200 CONTINUE
23219 1210 CONTINUE
23220
23221 ELSEIF(ISUB.EQ.84) THEN
23222C...g + gamma -> Q + Qbar
23223 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
23224 THQ=-0.5D0*SH*(1D0-BE34*CTH)
23225 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
23226 FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
23227 & (THQ**2+UHQ**2+4D0*SQMAVG*SH*(1D0-SQMAVG*SH/(THQ*UHQ)))/
23228 & (THQ*UHQ)
23229 IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQMAVG,0D0)
23230 WID2=1D0
23231 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
23232 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
23233 FACQQ=FACQQ*WID2
23234 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
23235 NCHN=NCHN+1
23236 ISIG(NCHN,1)=21
23237 ISIG(NCHN,2)=22
23238 ISIG(NCHN,3)=1
23239 SIGH(NCHN)=FACQQ
23240 ENDIF
23241 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
23242 NCHN=NCHN+1
23243 ISIG(NCHN,1)=22
23244 ISIG(NCHN,2)=21
23245 ISIG(NCHN,3)=1
23246 SIGH(NCHN)=FACQQ
23247 ENDIF
23248
23249 ELSEIF(ISUB.EQ.85) THEN
23250C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
23251 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
23252 THQ=-0.5D0*SH*(1D0-BE34*CTH)
23253 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
23254 FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
23255 & ((1D0-PARJ(131)*PARJ(132))*(THQ*UHQ-SQMAVG*SH)*
23256 & (UHQ**2+THQ**2+2D0*SQMAVG*SH)+(1D0+PARJ(131)*PARJ(132))*
23257 & SQMAVG*SH**2*(SH-2D0*SQMAVG))/(THQ*UHQ)**2
23258 IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF
23259 IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1)
23260 & FACFF=FACFF*PYHFTH(SH,SQMAVG,1D0)
23261 WID2=1D0
23262 IF(MINT(56).EQ.6) WID2=WIDS(6,1)
23263 IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1)
23264 IF(MINT(56).EQ.17) WID2=WIDS(17,1)
23265 FACFF=FACFF*WID2
23266 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
23267 NCHN=NCHN+1
23268 ISIG(NCHN,1)=22
23269 ISIG(NCHN,2)=22
23270 ISIG(NCHN,3)=1
23271 SIGH(NCHN)=FACFF
23272 ENDIF
23273
23274 ELSEIF(ISUB.EQ.86) THEN
23275C...g + g -> J/Psi + g
23276 FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)*
23277 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
23278 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
23279 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
23280 NCHN=NCHN+1
23281 ISIG(NCHN,1)=21
23282 ISIG(NCHN,2)=21
23283 ISIG(NCHN,3)=1
23284 SIGH(NCHN)=FACQQG
23285 ENDIF
23286
23287 ELSEIF(ISUB.EQ.87) THEN
23288C...g + g -> chi_0c + g
23289 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
23290 QGTW=(SH*TH*UH)/SH**3
23291 RGTW=SQM3/SH
23292 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
23293 & (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
23294 & 6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)-
23295 & PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+
23296 & 2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/
23297 & (QGTW*(QGTW-RGTW*PGTW)**4)
23298 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
23299 NCHN=NCHN+1
23300 ISIG(NCHN,1)=21
23301 ISIG(NCHN,2)=21
23302 ISIG(NCHN,3)=1
23303 SIGH(NCHN)=FACQQG
23304 ENDIF
23305
23306 ELSEIF(ISUB.EQ.88) THEN
23307C...g + g -> chi_1c + g
23308 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
23309 QGTW=(SH*TH*UH)/SH**3
23310 RGTW=SQM3/SH
23311 FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
23312 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+
23313 & 5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/
23314 & (QGTW-RGTW*PGTW)**4
23315 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
23316 NCHN=NCHN+1
23317 ISIG(NCHN,1)=21
23318 ISIG(NCHN,2)=21
23319 ISIG(NCHN,3)=1
23320 SIGH(NCHN)=FACQQG
23321 ENDIF
23322
23323 ELSEIF(ISUB.EQ.89) THEN
23324C...g + g -> chi_2c + g
23325 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
23326 QGTW=(SH*TH*UH)/SH**3
23327 RGTW=SQM3/SH
23328 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
23329 & (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
23330 & 3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+
23331 & 2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+
23332 & RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2*
23333 & QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
23334 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
23335 NCHN=NCHN+1
23336 ISIG(NCHN,1)=21
23337 ISIG(NCHN,2)=21
23338 ISIG(NCHN,3)=1
23339 SIGH(NCHN)=FACQQG
23340 ENDIF
23341 ENDIF
23342
23343C...D: Mimimum bias processes
23344
23345 ELSEIF(ISUB.LE.100) THEN
23346 IF(ISUB.EQ.91) THEN
23347C...Elastic scattering
23348 SIGS=VINT(315)*VINT(316)*SIGT(0,0,1)
23349
23350 ELSEIF(ISUB.EQ.92) THEN
23351C...Single diffractive scattering (first side, i.e. XB)
23352 SIGS=VINT(315)*VINT(316)*SIGT(0,0,2)
23353
23354 ELSEIF(ISUB.EQ.93) THEN
23355C...Single diffractive scattering (second side, i.e. AX)
23356 SIGS=VINT(315)*VINT(316)*SIGT(0,0,3)
23357
23358 ELSEIF(ISUB.EQ.94) THEN
23359C...Double diffractive scattering
23360 SIGS=VINT(315)*VINT(316)*SIGT(0,0,4)
23361
23362 ELSEIF(ISUB.EQ.95) THEN
23363C...Low-pT scattering
23364 SIGS=VINT(315)*VINT(316)*SIGT(0,0,5)
23365
23366 ELSEIF(ISUB.EQ.96) THEN
23367C...Multiple interactions: sum of QCD processes
23368 CALL PYWIDT(21,SH,WDTP,WDTE)
23369
23370C...q + q' -> q + q'
23371 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
23372 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
23373 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
23374 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)/UH2
23375 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
23376 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
23377 DO 1230 I=-5,5
23378 IF(I.EQ.0) GOTO 1230
23379 DO 1220 J=-5,5
23380 IF(J.EQ.0) GOTO 1220
23381 NCHN=NCHN+1
23382 ISIG(NCHN,1)=I
23383 ISIG(NCHN,2)=J
23384 ISIG(NCHN,3)=111
23385 SIGH(NCHN)=FACQQ1
23386 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
23387 IF(I.EQ.J) THEN
23388 SIGH(NCHN)=0.5D0*FACQQ1*RATQQI
23389 NCHN=NCHN+1
23390 ISIG(NCHN,1)=I
23391 ISIG(NCHN,2)=J
23392 ISIG(NCHN,3)=112
23393 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
23394 ENDIF
23395 1220 CONTINUE
23396 1230 CONTINUE
23397
23398C...q + qbar -> q' + qbar' or g + g
23399 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
23400 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
23401 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
23402 & UH2/SH2)
23403 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
23404 & TH2/SH2)
23405 DO 1240 I=-5,5
23406 IF(I.EQ.0) GOTO 1240
23407 NCHN=NCHN+1
23408 ISIG(NCHN,1)=I
23409 ISIG(NCHN,2)=-I
23410 ISIG(NCHN,3)=121
23411 SIGH(NCHN)=FACQQB
23412 NCHN=NCHN+1
23413 ISIG(NCHN,1)=I
23414 ISIG(NCHN,2)=-I
23415 ISIG(NCHN,3)=131
23416 SIGH(NCHN)=0.5D0*FACGG1
23417 NCHN=NCHN+1
23418 ISIG(NCHN,1)=I
23419 ISIG(NCHN,2)=-I
23420 ISIG(NCHN,3)=132
23421 SIGH(NCHN)=0.5D0*FACGG2
23422 1240 CONTINUE
23423
23424C...q + g -> q + g
23425 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
23426 & UH/SH)*FACA
23427 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
23428 & SH/UH)
23429 DO 1260 I=-5,5
23430 IF(I.EQ.0) GOTO 1260
23431 DO 1250 ISDE=1,2
23432 NCHN=NCHN+1
23433 ISIG(NCHN,ISDE)=I
23434 ISIG(NCHN,3-ISDE)=21
23435 ISIG(NCHN,3)=281
23436 SIGH(NCHN)=FACQG1
23437 NCHN=NCHN+1
23438 ISIG(NCHN,ISDE)=I
23439 ISIG(NCHN,3-ISDE)=21
23440 ISIG(NCHN,3)=282
23441 SIGH(NCHN)=FACQG2
23442 1250 CONTINUE
23443 1260 CONTINUE
23444
23445C...g + g -> q + qbar (only d, u, s)
23446 IDC0=MDCY(21,2)-1
23447 FLAVWT=0D0
23448 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
23449 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
23450 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
23451 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
23452 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
23453 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
23454 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
23455 & UH2/SH2)*FLAVWT*FACA
23456 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
23457 & TH2/SH2)*FLAVWT*FACA
23458 NCHN=NCHN+1
23459 ISIG(NCHN,1)=21
23460 ISIG(NCHN,2)=21
23461 ISIG(NCHN,3)=531
23462 SIGH(NCHN)=FACQQ1
23463 NCHN=NCHN+1
23464 ISIG(NCHN,1)=21
23465 ISIG(NCHN,2)=21
23466 ISIG(NCHN,3)=532
23467 SIGH(NCHN)=FACQQ2
23468
23469C...g + g -> c + cbar, b + bbar: modified that/uhat for fixed
23470C...cos(theta-hat)
23471 DO 1270 IFL=4,5
23472 SQMAVG=PMAS(IFL,1)**2
23473 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
23474 BE34=SQRT(1D0-4D0*SQMAVG/SH)
23475 THQ=-0.5D0*SH*(1D0-BE34*CTH)
23476 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
23477 THUHQ=THQ*UHQ-SQMAVG*SH
23478 IF(MSTP(34).EQ.0) THEN
23479 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
23480 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
23481 ELSE
23482 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
23483 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
23484 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
23485 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
23486 ENDIF
23487 IF(MSTP(5).GE.5) THEN
23488 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDGGS+
23489 & 2.25D0*THQ*UHQ/SH2*SQDLGS
23490 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDGGS+
23491 & 2.25D0*THQ*UHQ/SH2*SQDLGS
23492 ENDIF
23493 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
23494 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
23495 NCHN=NCHN+1
23496 ISIG(NCHN,1)=21
23497 ISIG(NCHN,2)=21
23498 ISIG(NCHN,3)=531+2*(IFL-3)
23499 SIGH(NCHN)=FACQQ1
23500 NCHN=NCHN+1
23501 ISIG(NCHN,1)=21
23502 ISIG(NCHN,2)=21
23503 ISIG(NCHN,3)=532+2*(IFL-3)
23504 SIGH(NCHN)=FACQQ2
23505 ENDIF
23506 1270 CONTINUE
23507
23508C...g + g -> g + g
23509 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
23510 & 2D0*TH/SH+TH2/SH2)*FACA
23511 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
23512 & 2D0*SH/UH+SH2/UH2)*FACA
23513 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+
23514 & 2D0*UH/TH+UH2/TH2)
23515 NCHN=NCHN+1
23516 ISIG(NCHN,1)=21
23517 ISIG(NCHN,2)=21
23518 ISIG(NCHN,3)=681
23519 SIGH(NCHN)=0.5D0*FACGG1
23520 NCHN=NCHN+1
23521 ISIG(NCHN,1)=21
23522 ISIG(NCHN,2)=21
23523 ISIG(NCHN,3)=682
23524 SIGH(NCHN)=0.5D0*FACGG2
23525 NCHN=NCHN+1
23526 ISIG(NCHN,1)=21
23527 ISIG(NCHN,2)=21
23528 ISIG(NCHN,3)=683
23529 SIGH(NCHN)=0.5D0*FACGG3
23530
23531 ELSEIF(ISUB.EQ.99) THEN
23532C...f + gamma* -> f.
23533 IF(MINT(107).EQ.4) THEN
23534 Q2GA=VINT(307)
23535 P2GA=VINT(308)
23536 ISDE=2
23537 ELSE
23538 Q2GA=VINT(308)
23539 P2GA=VINT(307)
23540 ISDE=1
23541 ENDIF
23542 COMFAC=PARU(5)*4D0*PARU(1)**2*PARU(101)*VINT(315)*VINT(316)
23543 PM2RHO=PMAS(PYCOMP(113),1)**2
23544 IF(MSTP(19).EQ.0) THEN
23545 COMFAC=COMFAC/Q2GA
23546 ELSEIF(MSTP(19).EQ.1) THEN
23547 COMFAC=COMFAC/(Q2GA+PM2RHO)
23548 ELSEIF(MSTP(19).EQ.2) THEN
23549 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
23550 ELSE
23551 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
23552 W2GA=VINT(2)
23553 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
23554 RDRDS=4.1D-3*W2GA**2.167D0/((Q2GA+0.15D0*W2GA)**2*
23555 & Q2GA**0.75D0)*(1D0+0.11D0*Q2GA*P2GA/(1D0+0.02D0*P2GA**2))
23556 XGA=Q2GA/(W2GA+VINT(307)+VINT(308))
23557 ELSE
23558 RDRDS=1.5D-4*W2GA**2.167D0/((Q2GA+0.041D0*W2GA)**2*
23559 & Q2GA**0.57D0)
23560 XGA=Q2GA/(W2GA+Q2GA-PMAS(PYCOMP(MINT(10+ISDE)),1)**2)
23561 ENDIF
23562 COMFAC=COMFAC*EXP(-MAX(1D-10,RDRDS))
23563 IF(MSTP(19).EQ.4) COMFAC=COMFAC/MAX(1D-2,1D0-XGA)
23564 ENDIF
23565 DO 1280 I=MMINA,MMAXA
23566 IF(I.EQ.0.OR.KFAC(ISDE,I).EQ.0) GOTO 1280
23567 IF(IABS(I).LT.10.AND.IABS(I).GT.MSTP(58)) GOTO 1280
23568 EI=KCHG(IABS(I),1)/3D0
23569 NCHN=NCHN+1
23570 ISIG(NCHN,ISDE)=I
23571 ISIG(NCHN,3-ISDE)=22
23572 ISIG(NCHN,3)=1
23573 SIGH(NCHN)=COMFAC*EI**2
23574 1280 CONTINUE
23575 ENDIF
23576
23577C...E: 2 -> 1, loop diagrams
23578
23579 ELSEIF(ISUB.LE.110) THEN
23580 IF(ISUB.EQ.101) THEN
23581C...g + g -> gamma*/Z0
23582
23583 ELSEIF(ISUB.EQ.102) THEN
23584C...g + g -> h0 (or H0, or A0)
23585 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
23586 HS=SHR*WDTP(0)
23587 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
23588 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
23589 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
23590 & FACBW=0D0
23591 HI=SHR*WDTP(13)/32D0
23592 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1290
23593 NCHN=NCHN+1
23594 ISIG(NCHN,1)=21
23595 ISIG(NCHN,2)=21
23596 ISIG(NCHN,3)=1
23597 SIGH(NCHN)=HI*FACBW*HF
23598 1290 CONTINUE
23599
23600 ELSEIF(ISUB.EQ.103) THEN
23601C...gamma + gamma -> h0 (or H0, or A0)
23602 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
23603 HS=SHR*WDTP(0)
23604 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
23605 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
23606 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
23607 & FACBW=0D0
23608 HI=SHR*WDTP(14)*2D0
23609 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 1300
23610 NCHN=NCHN+1
23611 ISIG(NCHN,1)=22
23612 ISIG(NCHN,2)=22
23613 ISIG(NCHN,3)=1
23614 SIGH(NCHN)=HI*FACBW*HF
23615 1300 CONTINUE
23616
23617 ELSEIF(ISUB.EQ.104) THEN
23618C...g + g -> chi_c0.
23619 KC=PYCOMP(10441)
23620 FACBW=COMFAC*12D0*AS**2*PARP(39)*PMAS(KC,2)/
23621 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
23622 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
23623 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
23624 NCHN=NCHN+1
23625 ISIG(NCHN,1)=21
23626 ISIG(NCHN,2)=21
23627 ISIG(NCHN,3)=1
23628 SIGH(NCHN)=FACBW
23629 ENDIF
23630
23631 ELSEIF(ISUB.EQ.105) THEN
23632C...g + g -> chi_c2.
23633 KC=PYCOMP(445)
23634 FACBW=COMFAC*16D0*AS**2*PARP(39)*PMAS(KC,2)/
23635 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
23636 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
23637 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
23638 NCHN=NCHN+1
23639 ISIG(NCHN,1)=21
23640 ISIG(NCHN,2)=21
23641 ISIG(NCHN,3)=1
23642 SIGH(NCHN)=FACBW
23643 ENDIF
23644
23645C...Continuation C: 2 -> 2, tree diagrams with masses.
23646
23647 ELSEIF(ISUB.EQ.106) THEN
23648C...g + g -> J/Psi + gamma.
23649 EQ=2D0/3D0
23650 FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)*
23651 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
23652 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
23653 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
23654 NCHN=NCHN+1
23655 ISIG(NCHN,1)=21
23656 ISIG(NCHN,2)=21
23657 ISIG(NCHN,3)=1
23658 SIGH(NCHN)=FACQQG
23659 ENDIF
23660
23661 ELSEIF(ISUB.EQ.107) THEN
23662C...g + gamma -> J/Psi + g.
23663 EQ=2D0/3D0
23664 FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)*
23665 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
23666 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
23667 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
23668 NCHN=NCHN+1
23669 ISIG(NCHN,1)=21
23670 ISIG(NCHN,2)=22
23671 ISIG(NCHN,3)=1
23672 SIGH(NCHN)=FACQQG
23673 ENDIF
23674 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
23675 NCHN=NCHN+1
23676 ISIG(NCHN,1)=22
23677 ISIG(NCHN,2)=21
23678 ISIG(NCHN,3)=1
23679 SIGH(NCHN)=FACQQG
23680 ENDIF
23681
23682 ELSEIF(ISUB.EQ.108) THEN
23683C...gamma + gamma -> J/Psi + gamma.
23684 EQ=2D0/3D0
23685 FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)*
23686 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
23687 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
23688 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
23689 NCHN=NCHN+1
23690 ISIG(NCHN,1)=22
23691 ISIG(NCHN,2)=22
23692 ISIG(NCHN,3)=1
23693 SIGH(NCHN)=FACQQG
23694 ENDIF
23695
23696C...F: 2 -> 2, box diagrams
23697
23698 ELSEIF(ISUB.EQ.110) THEN
23699C...f + fbar -> gamma + h0
23700 THUH=MAX(TH*UH,SH*CKIN(3)**2)
23701 FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH
23702 FACHG=FACHG*WIDS(KFHIGG,2)
23703C...Calculate loop contributions for intermediate gamma* and Z0
23704 CIGTOT=DCMPLX(0D0,0D0)
23705 CIZTOT=DCMPLX(0D0,0D0)
23706 JMAX=3*MSTP(1)+1
23707 DO 1310 J=1,JMAX
23708 IF(J.LE.2*MSTP(1)) THEN
23709 FNC=1D0
23710 EJ=KCHG(J,1)/3D0
23711 AJ=SIGN(1D0,EJ+0.1D0)
23712 VJ=AJ-4D0*EJ*XWV
23713 BALP=SQM4/(2D0*PMAS(J,1))**2
23714 BBET=SH/(2D0*PMAS(J,1))**2
23715 ELSEIF(J.LE.3*MSTP(1)) THEN
23716 FNC=3D0
23717 JL=2*(J-2*MSTP(1))-1
23718 EJ=KCHG(10+JL,1)/3D0
23719 AJ=SIGN(1D0,EJ+0.1D0)
23720 VJ=AJ-4D0*EJ*XWV
23721 BALP=SQM4/(2D0*PMAS(10+JL,1))**2
23722 BBET=SH/(2D0*PMAS(10+JL,1))**2
23723 ELSE
23724 BALP=SQM4/(2D0*PMAS(24,1))**2
23725 BBET=SH/(2D0*PMAS(24,1))**2
23726 ENDIF
23727 BABI=1D0/(BALP-BBET)
23728 IF(BALP.LT.1D0) THEN
23729 F0ALP=DCMPLX(DBLE(ASIN(SQRT(BALP))),0D0)
23730 F1ALP=F0ALP**2
23731 ELSE
23732 F0ALP=DCMPLX(DBLE(LOG(SQRT(BALP)+SQRT(BALP-1D0))),
23733 & -DBLE(0.5D0*PARU(1)))
23734 F1ALP=-F0ALP**2
23735 ENDIF
23736 F2ALP=DBLE(SQRT(ABS(BALP-1D0)/BALP))*F0ALP
23737 IF(BBET.LT.1D0) THEN
23738 F0BET=DCMPLX(DBLE(ASIN(SQRT(BBET))),0D0)
23739 F1BET=F0BET**2
23740 ELSE
23741 F0BET=DCMPLX(DBLE(LOG(SQRT(BBET)+SQRT(BBET-1D0))),
23742 & -DBLE(0.5D0*PARU(1)))
23743 F1BET=-F0BET**2
23744 ENDIF
23745 F2BET=DBLE(SQRT(ABS(BBET-1D0)/BBET))*F0BET
23746 IF(J.LE.3*MSTP(1)) THEN
23747 FIF=DBLE(0.5D0*BABI)+DBLE(BABI**2)*(DBLE(0.5D0*(1D0-BALP+
23748 & BBET))*(F1BET-F1ALP)+DBLE(BBET)*(F2BET-F2ALP))
23749 CIGTOT=CIGTOT+DBLE(FNC*EJ**2)*FIF
23750 CIZTOT=CIZTOT+DBLE(FNC*EJ*VJ)*FIF
23751 ELSE
23752 TXW=XW/XW1
23753 CIGTOT=CIGTOT-0.5*(DBLE(BABI*(1.5D0+BALP))+DBLE(BABI**2)*
23754 & (DBLE(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+
23755 & DBLE(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP)))
23756 CIZTOT=CIZTOT-DBLE(0.5D0*BABI*XW1)*(DBLE(5D0-TXW+2D0*BALP*
23757 & (1D0-TXW))*(1D0+DBLE(2D0*BABI*BBET)*(F2BET-F2ALP))+
23758 & DBLE(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))*
23759 & (F1BET-F1ALP))
23760 ENDIF
23761 1310 CONTINUE
23762 CIGTOT=CIGTOT/DBLE(SH)
23763 CIZTOT=CIZTOT*DBLE(XWC)/DCMPLX(DBLE(SH-SQMZ),DBLE(GMMZ))
23764C...Loop over initial flavours
23765 DO 1320 I=MMINA,MMAXA
23766 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1320
23767 EI=KCHG(IABS(I),1)/3D0
23768 AI=SIGN(1D0,EI)
23769 VI=AI-4D0*EI*XWV
23770 FCOI=1D0
23771 IF(IABS(I).LE.10) FCOI=FACA/3D0
23772 NCHN=NCHN+1
23773 ISIG(NCHN,1)=I
23774 ISIG(NCHN,2)=-I
23775 ISIG(NCHN,3)=1
23776 SIGH(NCHN)=FACHG*FCOI*(ABS(DBLE(EI)*CIGTOT+DBLE(VI)*
23777 & CIZTOT)**2+AI**2*ABS(CIZTOT)**2)
23778 1320 CONTINUE
23779
23780 ENDIF
23781
23782 ELSEIF(ISUB.LE.120) THEN
23783 IF(ISUB.EQ.111) THEN
23784C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
23785 IF(MSTP(38).NE.0) THEN
23786C...Simple case: only do gg <-> h exactly.
23787 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
23788 FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP(13)/SQRT(SQM4))*
23789 & (TH**2+UH**2)/(SH*SQM4)
23790C...Propagators: as simulated in PYOFSH and as desired
23791 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
23792 GMMHC=SQRT(SQM4)*WDTP(0)
23793 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
23794 & ((SQM4-SQMH)**2+GMMHC**2)
23795 FACGH=FACGH*HBW4C/HBW4
23796 ELSE
23797C...Messy case: do full loop integrals
23798 A5STUR=0D0
23799 A5STUI=0D0
23800 DO 1330 I=1,2*MSTP(1)
23801 SQMQ=PMAS(I,1)**2
23802 EPSS=4D0*SQMQ/SH
23803 EPSH=4D0*SQMQ/SQMH
23804 CALL PYWAUX(1,EPSS,W1SR,W1SI)
23805 CALL PYWAUX(1,EPSH,W1HR,W1HI)
23806 CALL PYWAUX(2,EPSS,W2SR,W2SI)
23807 CALL PYWAUX(2,EPSH,W2HR,W2HI)
23808 A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+
23809 & (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR))
23810 A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+
23811 & (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI))
23812 1330 CONTINUE
23813 FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
23814 & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
23815 FACGH=FACGH*WIDS(25,2)
23816 ENDIF
23817 DO 1340 I=MMINA,MMAXA
23818 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
23819 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1340
23820 NCHN=NCHN+1
23821 ISIG(NCHN,1)=I
23822 ISIG(NCHN,2)=-I
23823 ISIG(NCHN,3)=1
23824 SIGH(NCHN)=FACGH
23825 1340 CONTINUE
23826
23827 ELSEIF(ISUB.EQ.112) THEN
23828C...f + g -> f + h0 (q + g -> q + h0 only)
23829 IF(MSTP(38).NE.0) THEN
23830C...Simple case: only do gg <-> h exactly.
23831 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
23832 FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP(13)/SQRT(SQM4))*
23833 & (SH**2+UH**2)/(-TH*SQM4)
23834C...Propagators: as simulated in PYOFSH and as desired
23835 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
23836 GMMHC=SQRT(SQM4)*WDTP(0)
23837 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
23838 & ((SQM4-SQMH)**2+GMMHC**2)
23839 FACQH=FACQH*HBW4C/HBW4
23840 ELSE
23841C...Messy case: do full loop integrals
23842 A5TSUR=0D0
23843 A5TSUI=0D0
23844 DO 1350 I=1,2*MSTP(1)
23845 SQMQ=PMAS(I,1)**2
23846 EPST=4D0*SQMQ/TH
23847 EPSH=4D0*SQMQ/SQMH
23848 CALL PYWAUX(1,EPST,W1TR,W1TI)
23849 CALL PYWAUX(1,EPSH,W1HR,W1HI)
23850 CALL PYWAUX(2,EPST,W2TR,W2TI)
23851 CALL PYWAUX(2,EPSH,W2HR,W2HI)
23852 A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+
23853 & (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR))
23854 A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+
23855 & (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI))
23856 1350 CONTINUE
23857 FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
23858 & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
23859 FACQH=FACQH*WIDS(25,2)
23860 ENDIF
23861 DO 1370 I=MMINA,MMAXA
23862 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1370
23863 DO 1360 ISDE=1,2
23864 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1360
23865 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1360
23866 NCHN=NCHN+1
23867 ISIG(NCHN,ISDE)=I
23868 ISIG(NCHN,3-ISDE)=21
23869 ISIG(NCHN,3)=1
23870 SIGH(NCHN)=FACQH
23871 1360 CONTINUE
23872 1370 CONTINUE
23873
23874 ELSEIF(ISUB.EQ.113) THEN
23875C...g + g -> g + h0
23876 IF(MSTP(38).NE.0) THEN
23877C...Simple case: only do gg <-> h exactly.
23878 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
23879 FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP(13)/SQRT(SQM4))*
23880 & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
23881C...Propagators: as simulated in PYOFSH and as desired
23882 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
23883 GMMHC=SQRT(SQM4)*WDTP(0)
23884 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
23885 & ((SQM4-SQMH)**2+GMMHC**2)
23886 FACGH=FACGH*HBW4C/HBW4
23887 ELSE
23888C...Messy case: do full loop integrals
23889 A2STUR=0D0
23890 A2STUI=0D0
23891 A2USTR=0D0
23892 A2USTI=0D0
23893 A2TUSR=0D0
23894 A2TUSI=0D0
23895 A4STUR=0D0
23896 A4STUI=0D0
23897 DO 1380 I=1,2*MSTP(1)
23898 SQMQ=PMAS(I,1)**2
23899 EPSS=4D0*SQMQ/SH
23900 EPST=4D0*SQMQ/TH
23901 EPSU=4D0*SQMQ/UH
23902 EPSH=4D0*SQMQ/SQMH
23903 IF(EPSH.LT.1D-6) GOTO 1380
23904 CALL PYWAUX(1,EPSS,W1SR,W1SI)
23905 CALL PYWAUX(1,EPST,W1TR,W1TI)
23906 CALL PYWAUX(1,EPSU,W1UR,W1UI)
23907 CALL PYWAUX(1,EPSH,W1HR,W1HI)
23908 CALL PYWAUX(2,EPSS,W2SR,W2SI)
23909 CALL PYWAUX(2,EPST,W2TR,W2TI)
23910 CALL PYWAUX(2,EPSU,W2UR,W2UI)
23911 CALL PYWAUX(2,EPSH,W2HR,W2HI)
23912 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
23913 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
23914 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
23915 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
23916 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
23917 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
23918 CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI)
23919 CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI)
23920 CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI)
23921 CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI)
23922 CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI)
23923 CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI)
23924 W3STUR=YHSTUR-Y3STUR-Y3UTSR
23925 W3STUI=YHSTUI-Y3STUI-Y3UTSI
23926 W3SUTR=YHSUTR-Y3SUTR-Y3TUSR
23927 W3SUTI=YHSUTI-Y3SUTI-Y3TUSI
23928 W3TSUR=YHTSUR-Y3TSUR-Y3USTR
23929 W3TSUI=YHTSUI-Y3TSUI-Y3USTI
23930 W3TUSR=YHTUSR-Y3TUSR-Y3SUTR
23931 W3TUSI=YHTUSI-Y3TUSI-Y3SUTI
23932 W3USTR=YHUSTR-Y3USTR-Y3TSUR
23933 W3USTI=YHUSTI-Y3USTI-Y3TSUI
23934 W3UTSR=YHUTSR-Y3UTSR-Y3STUR
23935 W3UTSI=YHUTSI-Y3UTSI-Y3STUI
23936 B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH*
23937 & (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)*
23938 & (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/
23939 & (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH*
23940 & (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR)
23941 B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2*
23942 & (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+
23943 & W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))*
23944 & (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0*
23945 & (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI)
23946 B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH*
23947 & (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)*
23948 & (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/
23949 & (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH*
23950 & (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR)
23951 B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2*
23952 & (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+
23953 & W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))*
23954 & (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0*
23955 & (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI)
23956 B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH*
23957 & (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)*
23958 & (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/
23959 & (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH*
23960 & (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR)
23961 B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2*
23962 & (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+
23963 & W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))*
23964 & (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0*
23965 & (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI)
23966 B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH*
23967 & (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)*
23968 & (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/
23969 & (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH*
23970 & (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR)
23971 B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2*
23972 & (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+
23973 & W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))*
23974 & (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0*
23975 & (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI)
23976 B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH*
23977 & (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)*
23978 & (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/
23979 & (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH*
23980 & (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR)
23981 B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2*
23982 & (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+
23983 & W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))*
23984 & (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0*
23985 & (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI)
23986 B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH*
23987 & (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)*
23988 & (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/
23989 & (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH*
23990 & (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR)
23991 B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2*
23992 & (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+
23993 & W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))*
23994 & (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0*
23995 & (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI)
23996 B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
23997 & (W2SR-W2HR+W3STUR))
23998 B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI)
23999 B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
24000 & (W2TR-W2HR+W3TUSR))
24001 B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI)
24002 B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
24003 & (W2UR-W2HR+W3USTR))
24004 B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI)
24005 A2STUR=A2STUR+B2STUR+B2SUTR
24006 A2STUI=A2STUI+B2STUI+B2SUTI
24007 A2USTR=A2USTR+B2USTR+B2UTSR
24008 A2USTI=A2USTI+B2USTI+B2UTSI
24009 A2TUSR=A2TUSR+B2TUSR+B2TSUR
24010 A2TUSI=A2TUSI+B2TUSI+B2TSUI
24011 A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
24012 A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
24013 1380 CONTINUE
24014 FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3*
24015 & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
24016 & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
24017 FACGH=FACGH*WIDS(25,2)
24018 ENDIF
24019 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1390
24020 NCHN=NCHN+1
24021 ISIG(NCHN,1)=21
24022 ISIG(NCHN,2)=21
24023 ISIG(NCHN,3)=1
24024 SIGH(NCHN)=FACGH
24025 1390 CONTINUE
24026
24027 ELSEIF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN
24028C...g + g -> gamma + gamma or g + g -> g + gamma
24029 A0STUR=0D0
24030 A0STUI=0D0
24031 A0TSUR=0D0
24032 A0TSUI=0D0
24033 A0UTSR=0D0
24034 A0UTSI=0D0
24035 A1STUR=0D0
24036 A1STUI=0D0
24037 A2STUR=0D0
24038 A2STUI=0D0
24039 ALST=LOG(-SH/TH)
24040 ALSU=LOG(-SH/UH)
24041 ALTU=LOG(TH/UH)
24042 IMAX=2*MSTP(1)
24043 IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38)
24044 DO 1400 I=1,IMAX
24045 EI=KCHG(IABS(I),1)/3D0
24046 EIWT=EI**2
24047 IF(ISUB.EQ.115) EIWT=EI
24048 SQMQ=PMAS(I,1)**2
24049 EPSS=4D0*SQMQ/SH
24050 EPST=4D0*SQMQ/TH
24051 EPSU=4D0*SQMQ/UH
24052 IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1D-4) THEN
24053 B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+
24054 & PARU(1)**2)
24055 B0STUI=0D0
24056 B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2
24057 B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU)
24058 B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2
24059 B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST)
24060 B1STUR=-1D0
24061 B1STUI=0D0
24062 B2STUR=-1D0
24063 B2STUI=0D0
24064 ELSE
24065 CALL PYWAUX(1,EPSS,W1SR,W1SI)
24066 CALL PYWAUX(1,EPST,W1TR,W1TI)
24067 CALL PYWAUX(1,EPSU,W1UR,W1UI)
24068 CALL PYWAUX(2,EPSS,W2SR,W2SI)
24069 CALL PYWAUX(2,EPST,W2TR,W2TI)
24070 CALL PYWAUX(2,EPSU,W2UR,W2UI)
24071 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
24072 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
24073 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
24074 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
24075 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
24076 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
24077 B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+
24078 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)-
24079 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)-
24080 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+
24081 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
24082 & 0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
24083 B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+
24084 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)-
24085 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)-
24086 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+
24087 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
24088 & 0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
24089 B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+
24090 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)-
24091 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)-
24092 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+
24093 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
24094 & 0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)
24095 B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+
24096 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)-
24097 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)-
24098 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+
24099 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
24100 & 0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)
24101 B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+
24102 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)-
24103 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)-
24104 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+
24105 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
24106 & 0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR)
24107 B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+
24108 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)-
24109 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)-
24110 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+
24111 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
24112 & 0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI)
24113 B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+
24114 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+
24115 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+
24116 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
24117 B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+
24118 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+
24119 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+
24120 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
24121 B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+
24122 & 0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+
24123 & 0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR)
24124 B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+
24125 & 0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+
24126 & 0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI)
24127 ENDIF
24128 A0STUR=A0STUR+EIWT*B0STUR
24129 A0STUI=A0STUI+EIWT*B0STUI
24130 A0TSUR=A0TSUR+EIWT*B0TSUR
24131 A0TSUI=A0TSUI+EIWT*B0TSUI
24132 A0UTSR=A0UTSR+EIWT*B0UTSR
24133 A0UTSI=A0UTSI+EIWT*B0UTSI
24134 A1STUR=A1STUR+EIWT*B1STUR
24135 A1STUI=A1STUI+EIWT*B1STUI
24136 A2STUR=A2STUR+EIWT*B2STUR
24137 A2STUI=A2STUI+EIWT*B2STUI
24138 1400 CONTINUE
24139 ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+
24140 & A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2
24141 FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM
24142 FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM
24143 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1410
24144 NCHN=NCHN+1
24145 ISIG(NCHN,1)=21
24146 ISIG(NCHN,2)=21
24147 ISIG(NCHN,3)=1
24148 IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG
24149 IF(ISUB.EQ.115) SIGH(NCHN)=FACGP
24150 1410 CONTINUE
24151
24152 ELSEIF(ISUB.EQ.116) THEN
24153C...g + g -> gamma + Z0
24154
24155 ELSEIF(ISUB.EQ.117) THEN
24156C...g + g -> Z0 + Z0
24157
24158 ELSEIF(ISUB.EQ.118) THEN
24159C...g + g -> W+ + W-
24160
24161 ENDIF
24162
24163C...G: 2 -> 3, tree diagrams
24164
24165 ELSEIF(ISUB.LE.140) THEN
24166 IF(ISUB.EQ.121) THEN
24167C...g + g -> Q + Qbar + h0
24168 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1420
24169 IA=KFPR(ISUBSV,2)
24170 PMF=PYMRUN(IA,SH)
24171 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
24172 & (0.5D0*PMF/PMAS(24,1))**2
24173 WID2=1D0
24174 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
24175 FACQQH=FACQQH*WID2
24176 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24177 IKFI=1
24178 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
24179 IF(IA.GT.10) IKFI=3
24180 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
24181 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
24182 FACQQH=FACQQH/(1D0+RMSS(41))**2
24183 IF(IHIGG.NE.3) THEN
24184 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
24185 & PARU(151+10*IHIGG))**2
24186 ENDIF
24187 ENDIF
24188 ENDIF
24189 CALL PYQQBH(WTQQBH)
24190 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
24191 HS=SHR*WDTP(0)
24192 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24193 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
24194 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
24195 & FACBW=0D0
24196 NCHN=NCHN+1
24197 ISIG(NCHN,1)=21
24198 ISIG(NCHN,2)=21
24199 ISIG(NCHN,3)=1
24200 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
24201 1420 CONTINUE
24202
24203 ELSEIF(ISUB.EQ.122) THEN
24204C...q + qbar -> Q + Qbar + h0
24205 IA=KFPR(ISUBSV,2)
24206 PMF=PYMRUN(IA,SH)
24207 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
24208 & (0.5D0*PMF/PMAS(24,1))**2
24209 WID2=1D0
24210 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
24211 FACQQH=FACQQH*WID2
24212 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24213 IKFI=1
24214 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
24215 IF(IA.GT.10) IKFI=3
24216 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
24217 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
24218 FACQQH=FACQQH/(1D0+RMSS(41))**2
24219 IF(IHIGG.NE.3) THEN
24220 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
24221 & PARU(151+10*IHIGG))**2
24222 ENDIF
24223 ENDIF
24224 ENDIF
24225 CALL PYQQBH(WTQQBH)
24226 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
24227 HS=SHR*WDTP(0)
24228 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24229 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
24230 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
24231 & FACBW=0D0
24232 DO 1430 I=MMINA,MMAXA
24233 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
24234 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1430
24235 NCHN=NCHN+1
24236 ISIG(NCHN,1)=I
24237 ISIG(NCHN,2)=-I
24238 ISIG(NCHN,3)=1
24239 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
24240 1430 CONTINUE
24241
24242 ELSEIF(ISUB.EQ.123) THEN
24243C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
24244C...inner process)
24245 FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0
24246 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
24247 & PARU(154+10*IHIGG)**2
24248 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
24249 & (VINT(216)-VINT(209)**2))**2
24250 FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
24251 FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218)
24252 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
24253 HS=SHR*WDTP(0)
24254 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24255 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
24256 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
24257 & FACBW=0D0
24258 DO 1450 I=MMIN1,MMAX1
24259 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1450
24260 IA=IABS(I)
24261 DO 1440 J=MMIN2,MMAX2
24262 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1440
24263 JA=IABS(J)
24264 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
24265 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
24266 VI=AI-4D0*EI*XWV
24267 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
24268 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
24269 VJ=AJ-4D0*EJ*XWV
24270 FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ
24271 FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ
24272 NCHN=NCHN+1
24273 ISIG(NCHN,1)=I
24274 ISIG(NCHN,2)=J
24275 ISIG(NCHN,3)=1
24276 SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW
24277 1440 CONTINUE
24278 1450 CONTINUE
24279
24280 ELSEIF(ISUB.EQ.124) THEN
24281C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
24282C...inner process)
24283 FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW
24284 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
24285 & PARU(155+10*IHIGG)**2
24286 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
24287 & (VINT(216)-VINT(209)**2))**2
24288 FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
24289 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
24290 HS=SHR*WDTP(0)
24291 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24292 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
24293 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
24294 & FACBW=0D0
24295 DO 1470 I=MMIN1,MMAX1
24296 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1470
24297 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
24298 DO 1460 J=MMIN2,MMAX2
24299 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1460
24300 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
24301 IF(EI*EJ.GT.0D0) GOTO 1460
24302 FACLR=VINT(180+I)*VINT(180+J)
24303 NCHN=NCHN+1
24304 ISIG(NCHN,1)=I
24305 ISIG(NCHN,2)=J
24306 ISIG(NCHN,3)=1
24307 SIGH(NCHN)=FACLR*FACWW*FACBW
24308 1460 CONTINUE
24309 1470 CONTINUE
24310
24311 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
24312C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only)
24313 PH=0D0
24314 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
24315 & PH=VINT(3)**2
24316 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
24317 & PH=VINT(4)**2
24318 IF(ISUB.EQ.131) THEN
24319 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**2*
24320 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
24321 ELSE
24322 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
24323 ENDIF
24324 DO 1490 I=MMINA,MMAXA
24325 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1490
24326 EI=KCHG(IABS(I),1)/3D0
24327 FACGQ=FGQ*EI**2
24328 DO 1480 ISDE=1,2
24329 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 1480
24330 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 1480
24331 NCHN=NCHN+1
24332 ISIG(NCHN,ISDE)=I
24333 ISIG(NCHN,3-ISDE)=22
24334 ISIG(NCHN,3)=1
24335 SIGH(NCHN)=FACGQ
24336 1480 CONTINUE
24337 1490 CONTINUE
24338
24339 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
24340C...f + gamma*_(T,L) -> f + gamma
24341 PH=0D0
24342 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
24343 & PH=VINT(3)**2
24344 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
24345 & PH=VINT(4)**2
24346 IF(ISUB.EQ.133) THEN
24347 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**2*
24348 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
24349 ELSE
24350 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
24351 ENDIF
24352 DO 1510 I=MMINA,MMAXA
24353 IF(I.EQ.0) GOTO 1510
24354 EI=KCHG(IABS(I),1)/3D0
24355 FACGQ=FGQ*EI**4
24356 DO 1500 ISDE=1,2
24357 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 1500
24358 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 1500
24359 NCHN=NCHN+1
24360 ISIG(NCHN,ISDE)=I
24361 ISIG(NCHN,3-ISDE)=22
24362 ISIG(NCHN,3)=1
24363 SIGH(NCHN)=FACGQ
24364 1500 CONTINUE
24365 1510 CONTINUE
24366
24367 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
24368C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only)
24369 PH=0D0
24370 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
24371 & PH=VINT(3)**2
24372 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
24373 & PH=VINT(4)**2
24374 CALL PYWIDT(21,SH,WDTP,WDTE)
24375 WDTESU=0D0
24376 DO 1520 I=1,MIN(8,MDCY(21,3))
24377 EF=KCHG(I,1)/3D0
24378 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
24379 & WDTE(I,4))
24380 1520 CONTINUE
24381 IF(ISUB.EQ.135) THEN
24382 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**2*
24383 & ((TH2+UH2-2D0*PH*SH)/(TH*UH)+4D0*PH*SH/(SH+PH)**2)
24384 ELSE
24385 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**4*8D0*PH*SH
24386 ENDIF
24387 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
24388 NCHN=NCHN+1
24389 ISIG(NCHN,1)=21
24390 ISIG(NCHN,2)=22
24391 ISIG(NCHN,3)=1
24392 SIGH(NCHN)=FACQQ
24393 ENDIF
24394 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
24395 NCHN=NCHN+1
24396 ISIG(NCHN,1)=22
24397 ISIG(NCHN,2)=21
24398 ISIG(NCHN,3)=1
24399 SIGH(NCHN)=FACQQ
24400 ENDIF
24401
24402 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
24403C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar
24404 PH1=0D0
24405 IF(VINT(3).LT.0D0) PH1=VINT(3)**2
24406 PH2=0D0
24407 IF(VINT(4).LT.0D0) PH2=VINT(4)**2
24408 CALL PYWIDT(22,SH,WDTP,WDTE)
24409 WDTESU=0D0
24410 DO 1530 I=1,MIN(12,MDCY(22,3))
24411 IF(I.LE.8) EF= KCHG(I,1)/3D0
24412 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
24413 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
24414 & WDTE(I,4))
24415 1530 CONTINUE
24416 DLAMB2=(TH+UH)**2-4D0*PH1*PH2
24417 IF(ISUB.EQ.137) THEN
24418 FPARAM=-SH*(TH+UH)/DLAMB2
24419 FACFF=COMFAC*AEM**2*WDTESU*2D0*SH2/(DLAMB2*TH2*UH2)*
24420 & (TH*UH-PH1*PH2)*((TH2+UH2)*(1D0-2D0*FPARAM*(1D0-FPARAM))-
24421 & 2D0*PH1*PH2*FPARAM**2)
24422 ELSEIF(ISUB.EQ.138) THEN
24423 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
24424 & PH2*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH1*SH*(TH-UH)**2/DLAMB2)+
24425 & 2D0*PH1**2*(TH-UH)**2)
24426 ELSEIF(ISUB.EQ.139) THEN
24427 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
24428 & PH1*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH2*SH*(TH-UH)**2/DLAMB2)+
24429 & 2D0*PH2**2*(TH-UH)**2)
24430 ELSE
24431 FACFF=COMFAC*AEM**2*WDTESU*32D0*SH2**2/(DLAMB2**3*TH2*UH2)*
24432 & PH1*PH2*(TH*UH-PH1*PH2)*(TH-UH)**2
24433 ENDIF
24434 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
24435 NCHN=NCHN+1
24436 ISIG(NCHN,1)=22
24437 ISIG(NCHN,2)=22
24438 ISIG(NCHN,3)=1
24439 SIGH(NCHN)=FACFF
24440 ENDIF
24441
24442 ENDIF
24443
24444C...H: 2 -> 1, tree diagrams, non-standard model processes
24445
24446 ELSEIF(ISUB.LE.160) THEN
24447 IF(ISUB.EQ.141) THEN
24448C...f + fbar -> gamma*/Z0/Z'0
24449 SQMZP=PMAS(32,1)**2
24450 MINT(61)=2
24451 CALL PYWIDT(32,SH,WDTP,WDTE)
24452 HP0=AEM/3D0*SH
24453 HP1=AEM/3D0*XWC*SH
24454 HP2=HP1
24455 HS=SHR*VINT(117)
24456 HSP=SHR*WDTP(0)
24457 FACZP=4D0*COMFAC*3D0
24458 DO 1540 I=MMINA,MMAXA
24459 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1540
24460 EI=KCHG(IABS(I),1)/3D0
24461 AI=SIGN(1D0,EI)
24462 VI=AI-4D0*EI*XWV
24463 IA=IABS(I)
24464 IF(IA.LT.10) THEN
24465 IF(IA.LE.2) THEN
24466 VPI=PARU(123-2*MOD(IABS(I),2))
24467 API=PARU(124-2*MOD(IABS(I),2))
24468 ELSEIF(IA.LE.4) THEN
24469 VPI=PARJ(182-2*MOD(IABS(I),2))
24470 API=PARJ(183-2*MOD(IABS(I),2))
24471 ELSE
24472 VPI=PARJ(190-2*MOD(IABS(I),2))
24473 API=PARJ(191-2*MOD(IABS(I),2))
24474 ENDIF
24475 ELSE
24476 IF(IA.LE.12) THEN
24477 VPI=PARU(127-2*MOD(IABS(I),2))
24478 API=PARU(128-2*MOD(IABS(I),2))
24479 ELSEIF(IA.LE.14) THEN
24480 VPI=PARJ(186-2*MOD(IABS(I),2))
24481 API=PARJ(187-2*MOD(IABS(I),2))
24482 ELSE
24483 VPI=PARJ(194-2*MOD(IABS(I),2))
24484 API=PARJ(195-2*MOD(IABS(I),2))
24485 ENDIF
24486 ENDIF
24487 HI0=HP0
24488 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
24489 HI1=HP1
24490 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
24491 HI2=HP2
24492 IF(IABS(I).LE.10) HI2=HI2*FACA/3D0
24493 NCHN=NCHN+1
24494 ISIG(NCHN,1)=I
24495 ISIG(NCHN,2)=-I
24496 ISIG(NCHN,3)=1
24497 SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI*
24498 & (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)*
24499 & VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)*
24500 & (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/
24501 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)*
24502 & ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)*
24503 & ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+
24504 & (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116))
24505 1540 CONTINUE
24506
24507 ELSEIF(ISUB.EQ.142) THEN
24508C...f + fbar' -> W'+/-
24509 SQMWP=PMAS(34,1)**2
24510 CALL PYWIDT(34,SH,WDTP,WDTE)
24511 HS=SHR*WDTP(0)
24512 FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0
24513 HP=AEM/(24D0*XW)*SH
24514 DO 1560 I=MMIN1,MMAX1
24515 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1560
24516 IA=IABS(I)
24517 DO 1550 J=MMIN2,MMAX2
24518 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1550
24519 JA=IABS(J)
24520 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1550
24521 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
24522 & GOTO 1550
24523 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
24524 HI=HP*(PARU(133)**2+PARU(134)**2)
24525 IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)*
24526 & VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
24527 NCHN=NCHN+1
24528 ISIG(NCHN,1)=I
24529 ISIG(NCHN,2)=J
24530 ISIG(NCHN,3)=1
24531 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
24532 SIGH(NCHN)=HI*FACBW*HF
24533 1550 CONTINUE
24534 1560 CONTINUE
24535
24536 ELSEIF(ISUB.EQ.143) THEN
24537C...f + fbar' -> H+/-
24538 SQMHC=PMAS(37,1)**2
24539 CALL PYWIDT(37,SH,WDTP,WDTE)
24540 HS=SHR*WDTP(0)
24541 FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2)
24542 HP=AEM/(8D0*XW)*SH/SQMW*SH
24543 DO 1580 I=MMIN1,MMAX1
24544 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1580
24545 IA=IABS(I)
24546 IM=(MOD(IA,10)+1)/2
24547 DO 1570 J=MMIN2,MMAX2
24548 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1570
24549 JA=IABS(J)
24550 JM=(MOD(JA,10)+1)/2
24551 IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 1570
24552 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
24553 & GOTO 1570
24554 IF(MOD(IA,2).EQ.0) THEN
24555 IU=IA
24556 IL=JA
24557 ELSE
24558 IU=JA
24559 IL=IA
24560 ENDIF
24561 RML=PYMRUN(IL,SH)**2/SH
24562 RMU=PYMRUN(IU,SH)**2/SH
24563 HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2)
24564 IF(IA.LE.10) HI=HI*FACA/3D0
24565 KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
24566 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
24567 NCHN=NCHN+1
24568 ISIG(NCHN,1)=I
24569 ISIG(NCHN,2)=J
24570 ISIG(NCHN,3)=1
24571 SIGH(NCHN)=HI*FACBW*HF
24572 1570 CONTINUE
24573 1580 CONTINUE
24574
24575 ELSEIF(ISUB.EQ.144) THEN
24576C...f + fbar' -> R
24577 SQMR=PMAS(41,1)**2
24578 CALL PYWIDT(41,SH,WDTP,WDTE)
24579 HS=SHR*WDTP(0)
24580 FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0
24581 HP=AEM/(12D0*XW)*SH
24582 DO 1600 I=MMIN1,MMAX1
24583 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1600
24584 IA=IABS(I)
24585 DO 1590 J=MMIN2,MMAX2
24586 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1590
24587 JA=IABS(J)
24588 IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 1590
24589 HI=HP
24590 IF(IA.LE.10) HI=HI*FACA/3D0
24591 HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
24592 NCHN=NCHN+1
24593 ISIG(NCHN,1)=I
24594 ISIG(NCHN,2)=J
24595 ISIG(NCHN,3)=1
24596 SIGH(NCHN)=HI*FACBW*HF
24597 1590 CONTINUE
24598 1600 CONTINUE
24599
24600 ELSEIF(ISUB.EQ.145) THEN
24601C...q + l -> LQ (leptoquark)
24602 SQMLQ=PMAS(42,1)**2
24603 CALL PYWIDT(42,SH,WDTP,WDTE)
24604 HS=SHR*WDTP(0)
24605 FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2)
24606 IF(ABS(SHR-PMAS(42,1)).GT.PARP(48)*PMAS(42,2)) FACBW=0D0
24607 HP=AEM/4D0*SH
24608 KFLQQ=KFDP(MDCY(42,2),1)
24609 KFLQL=KFDP(MDCY(42,2),2)
24610 DO 1620 I=MMIN1,MMAX1
24611 IF(KFAC(1,I).EQ.0) GOTO 1620
24612 IA=IABS(I)
24613 IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 1620
24614 DO 1610 J=MMIN2,MMAX2
24615 IF(KFAC(2,J).EQ.0) GOTO 1610
24616 JA=IABS(J)
24617 IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 1610
24618 IF(I*J.NE.KFLQQ*KFLQL) GOTO 1610
24619 IF(JA.EQ.IA) GOTO 1610
24620 IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I)
24621 IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J)
24622 HI=HP*PARU(151)
24623 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4))
24624 NCHN=NCHN+1
24625 ISIG(NCHN,1)=I
24626 ISIG(NCHN,2)=J
24627 ISIG(NCHN,3)=1
24628 SIGH(NCHN)=HI*FACBW*HF
24629 1610 CONTINUE
24630 1620 CONTINUE
24631
24632 ELSEIF(ISUB.EQ.146) THEN
24633C...e + gamma* -> e* (excited lepton)
24634 KFQSTR=KFPR(ISUB,1)
24635 KCQSTR=PYCOMP(KFQSTR)
24636 KFQEXC=MOD(KFQSTR,KEXCIT)
24637 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
24638 HS=SHR*WDTP(0)
24639 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
24640 QF=-PARU(157)/2D0-PARU(158)/2D0
24641 FACBW=FACBW*AEM*QF**2*SH/PARU(155)**2
24642 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
24643 & FACBW=0D0
24644 HP=SH
24645 DO 1640 I=-KFQEXC,KFQEXC,2*KFQEXC
24646 DO 1630 ISDE=1,2
24647 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 1630
24648 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 1630
24649 HI=HP
24650 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24651 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
24652 NCHN=NCHN+1
24653 ISIG(NCHN,ISDE)=I
24654 ISIG(NCHN,3-ISDE)=22
24655 ISIG(NCHN,3)=1
24656 SIGH(NCHN)=HI*FACBW*HF
24657 1630 CONTINUE
24658 1640 CONTINUE
24659
24660 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
24661C...d + g -> d* and u + g -> u* (excited quarks)
24662 KFQSTR=KFPR(ISUB,1)
24663 KCQSTR=PYCOMP(KFQSTR)
24664 KFQEXC=MOD(KFQSTR,KEXCIT)
24665 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
24666 HS=SHR*WDTP(0)
24667 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
24668 FACBW=FACBW*AS*PARU(159)**2*SH/(3D0*PARU(155)**2)
24669 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
24670 & FACBW=0D0
24671 HP=SH
24672 DO 1660 I=-KFQEXC,KFQEXC,2*KFQEXC
24673 DO 1650 ISDE=1,2
24674 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1650
24675 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1650
24676 HI=HP
24677 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24678 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
24679 NCHN=NCHN+1
24680 ISIG(NCHN,ISDE)=I
24681 ISIG(NCHN,3-ISDE)=21
24682 ISIG(NCHN,3)=1
24683 SIGH(NCHN)=HI*FACBW*HF
24684 1650 CONTINUE
24685 1660 CONTINUE
24686
24687 ELSEIF(ISUB.EQ.149) THEN
24688C...g + g -> eta_tc
24689 KCTC=PYCOMP(KTECHN+331)
24690 CALL PYWIDT(KTECHN+331,SH,WDTP,WDTE)
24691 HS=SHR*WDTP(0)
24692 FACBW=COMFAC*0.5D0/((SH-PMAS(KCTC,1)**2)**2+HS**2)
24693 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
24694 HP=SH
24695 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1670
24696 HI=HP*WDTP(3)
24697 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24698 NCHN=NCHN+1
24699 ISIG(NCHN,1)=21
24700 ISIG(NCHN,2)=21
24701 ISIG(NCHN,3)=1
24702 SIGH(NCHN)=HI*FACBW*HF
24703 1670 CONTINUE
24704
24705 ENDIF
24706
24707C...I: 2 -> 2, tree diagrams, non-standard model processes
24708
24709 ELSEIF(ISUB.LE.200) THEN
24710 IF(ISUB.EQ.161) THEN
24711C...f + g -> f' + H+/- (b + g -> t + H+/- only)
24712C...(choice of only b and t to avoid kinematics problems)
24713 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24
24714C...H propagator: as simulated in PYOFSH and as desired
24715 SQMHC=PMAS(37,1)**2
24716 GMMHC=PMAS(37,1)*PMAS(37,2)
24717 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
24718 CALL PYWIDT(37,SQM4,WDTP,WDTE)
24719 GMMHCC=SQRT(SQM4)*WDTP(0)
24720 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
24721 FHCQ=FHCQ*HBW4C/HBW4
24722 DO 1690 I=MMINA,MMAXA
24723 IA=IABS(I)
24724 IF(IA.NE.5) GOTO 1690
24725 SQML=PYMRUN(IA,SH)**2
24726 IUA=IA+MOD(IA,2)
24727 SQMQ=PYMRUN(IUA,SH)**2
24728 FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW*
24729 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH+
24730 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
24731 & (SQMHC-SQMQ-SH)/SH)
24732 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
24733 DO 1680 ISDE=1,2
24734 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1680
24735 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,1).EQ.0) GOTO 1680
24736 NCHN=NCHN+1
24737 ISIG(NCHN,ISDE)=I
24738 ISIG(NCHN,3-ISDE)=21
24739 ISIG(NCHN,3)=1
24740 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
24741 1680 CONTINUE
24742 1690 CONTINUE
24743
24744 ELSEIF(ISUB.EQ.162) THEN
24745C...q + g -> LQ + lbar; LQ=leptoquark
24746 SQMLQ=PMAS(42,1)**2
24747 FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)*
24748 & (UH2+SQMLQ**2)/(UH-SQMLQ)**2
24749 KFLQQ=KFDP(MDCY(42,2),1)
24750 DO 1710 I=MMINA,MMAXA
24751 IF(IABS(I).NE.KFLQQ) GOTO 1710
24752 KCHLQ=ISIGN(1,I)
24753 DO 1700 ISDE=1,2
24754 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1700
24755 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1700
24756 NCHN=NCHN+1
24757 ISIG(NCHN,ISDE)=I
24758 ISIG(NCHN,3-ISDE)=21
24759 ISIG(NCHN,3)=1
24760 SIGH(NCHN)=FACLQ*WIDS(42,(5-KCHLQ)/2)
24761 1700 CONTINUE
24762 1710 CONTINUE
24763
24764 ELSEIF(ISUB.EQ.163) THEN
24765C...g + g -> LQ + LQbar; LQ=leptoquark
24766 SQMLQ=PMAS(42,1)**2
24767 FACLQ=COMFAC*FACA*WIDS(42,1)*(AS**2/2D0)*
24768 & (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/
24769 & (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/
24770 & ((TH-SQMLQ)*(UH-SQMLQ)))
24771 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1720
24772 NCHN=NCHN+1
24773 ISIG(NCHN,1)=21
24774 ISIG(NCHN,2)=21
24775C...Since don't know proper colour flow, randomize between alternatives
24776 ISIG(NCHN,3)=INT(1.5D0+PYR(0))
24777 SIGH(NCHN)=FACLQ
24778 1720 CONTINUE
24779
24780 ELSEIF(ISUB.EQ.164) THEN
24781C...q + qbar -> LQ + LQbar; LQ=leptoquark
24782 DELTA=0.25D0*(SQM3-SQM4)**2/SH
24783 SQMLQ=0.5D0*(SQM3+SQM4)-DELTA
24784 TH=TH-DELTA
24785 UH=UH-DELTA
24786C SQMLQ=PMAS(42,1)**2
24787 FACLQA=COMFAC*WIDS(42,1)*(AS**2/9D0)*
24788 & (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2
24789 FACLQS=COMFAC*WIDS(42,1)*((PARU(151)**2*AEM**2/8D0)*
24790 & (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)*
24791 & ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH))
24792 KFLQQ=KFDP(MDCY(42,2),1)
24793 DO 1730 I=MMINA,MMAXA
24794 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
24795 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1730
24796 NCHN=NCHN+1
24797 ISIG(NCHN,1)=I
24798 ISIG(NCHN,2)=-I
24799 ISIG(NCHN,3)=1
24800 SIGH(NCHN)=FACLQA
24801 IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS
24802 1730 CONTINUE
24803
24804 ELSEIF(ISUB.EQ.165) THEN
24805C...q + qbar -> l+ + l- (including contact term for compositeness)
24806 ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
24807 ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
24808 KFF=IABS(KFPR(ISUB,1))
24809 EF=KCHG(KFF,1)/3D0
24810 AF=SIGN(1D0,EF+0.1D0)
24811 VF=AF-4D0*EF*XWV
24812 VALF=VF+AF
24813 VARF=VF-AF
24814 FCOF=1D0
24815 IF(KFF.LE.10) FCOF=3D0
24816 WID2=1D0
24817 IF(KFF.EQ.6) WID2=WIDS(6,1)
24818 IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1)
24819 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
24820 DO 1740 I=MMINA,MMAXA
24821 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1740
24822 EI=KCHG(IABS(I),1)/3D0
24823 AI=SIGN(1D0,EI+0.1D0)
24824 VI=AI-4D0*EI*XWV
24825 VALI=VI+AI
24826 VARI=VI-AI
24827 FCOI=1D0
24828 IF(IABS(I).LE.10) FCOI=FACA/3D0
24829 IF((MSTP(5).EQ.1.AND.IABS(I).LE.2).OR.MSTP(5).EQ.2) THEN
24830 FGZA=(EI*EF+VALI*VALF*ZRATR+PARU(156)*SH/
24831 & (AEM*PARU(155)**2))**2+(VALI*VALF*ZRATI)**2+
24832 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
24833 ELSE
24834 FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+
24835 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
24836 ENDIF
24837 FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+
24838 & (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2
24839 FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2)
24840 IF((MSTP(5).EQ.3.AND.IABS(I).EQ.2).OR.(MSTP(5).EQ.4.AND.
24841 & MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*PARU(155)**4)
24842 NCHN=NCHN+1
24843 ISIG(NCHN,1)=I
24844 ISIG(NCHN,2)=-I
24845 ISIG(NCHN,3)=1
24846 SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2
24847 1740 CONTINUE
24848
24849 ELSEIF(ISUB.EQ.166) THEN
24850C...q + q'bar -> l + nu_l (including contact term for compositeness)
24851 WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2)
24852 WCIFAC=WFAC+SH2/(4D0*PARU(155)**4)
24853 KFF=IABS(KFPR(ISUB,1))
24854 FCOF=1D0
24855 IF(KFF.LE.10) FCOF=3D0
24856 DO 1760 I=MMIN1,MMAX1
24857 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1760
24858 IA=IABS(I)
24859 DO 1750 J=MMIN2,MMAX2
24860 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1750
24861 JA=IABS(J)
24862 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1750
24863 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
24864 & GOTO 1750
24865 FCOI=1D0
24866 IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
24867 WID2=1D0
24868 IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND.
24869 & MOD(J,2).EQ.0)) THEN
24870 IF(KFF.EQ.5) WID2=WIDS(6,2)
24871 IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3)
24872 IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3)
24873 ELSE
24874 IF(KFF.EQ.5) WID2=WIDS(6,3)
24875 IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2)
24876 IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2)
24877 ENDIF
24878 NCHN=NCHN+1
24879 ISIG(NCHN,1)=I
24880 ISIG(NCHN,2)=J
24881 ISIG(NCHN,3)=1
24882 SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2
24883 IF((MSTP(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.MSTP(5).EQ.4)
24884 & SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2
24885 1750 CONTINUE
24886 1760 CONTINUE
24887
24888 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
24889C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks)
24890 KFQSTR=KFPR(ISUB,2)
24891 KCQSTR=PYCOMP(KFQSTR)
24892 KFQEXC=MOD(KFQSTR,KEXCIT)
24893 FACQSA=COMFAC*(SH/PARU(155)**2)**2*(1D0-SQM4/SH)
24894 FACQSB=COMFAC*0.25D0*(SH/PARU(155)**2)**2*(1D0-SQM4/SH)*
24895 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
24896C...Propagators: as simulated in PYOFSH and as desired
24897 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
24898 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
24899 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
24900 GMMQC=SQRT(SQM4)*WDTP(0)
24901 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
24902 FACQSA=FACQSA*HBW4C/HBW4
24903 FACQSB=FACQSB*HBW4C/HBW4
24904C...Branching ratios.
24905 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
24906 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
24907 DO 1780 I=MMIN1,MMAX1
24908 IA=IABS(I)
24909 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 1780
24910 DO 1770 J=MMIN2,MMAX2
24911 JA=IABS(J)
24912 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 1770
24913 IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN
24914 NCHN=NCHN+1
24915 ISIG(NCHN,1)=I
24916 ISIG(NCHN,2)=J
24917 ISIG(NCHN,3)=1
24918 IF(I.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
24919 IF(I.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
24920 NCHN=NCHN+1
24921 ISIG(NCHN,1)=I
24922 ISIG(NCHN,2)=J
24923 ISIG(NCHN,3)=2
24924 IF(J.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
24925 IF(J.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
24926 ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN
24927 NCHN=NCHN+1
24928 ISIG(NCHN,1)=I
24929 ISIG(NCHN,2)=J
24930 ISIG(NCHN,3)=1
24931 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
24932 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSA*BRPOS
24933 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSA*BRNEG
24934 ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN
24935 NCHN=NCHN+1
24936 ISIG(NCHN,1)=I
24937 ISIG(NCHN,2)=J
24938 ISIG(NCHN,3)=1
24939 IF(I.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
24940 IF(I.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
24941 NCHN=NCHN+1
24942 ISIG(NCHN,1)=I
24943 ISIG(NCHN,2)=J
24944 ISIG(NCHN,3)=2
24945 IF(J.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
24946 IF(J.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
24947 ELSEIF(I.EQ.-J) THEN
24948 NCHN=NCHN+1
24949 ISIG(NCHN,1)=I
24950 ISIG(NCHN,2)=J
24951 ISIG(NCHN,3)=1
24952 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
24953 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
24954 NCHN=NCHN+1
24955 ISIG(NCHN,1)=I
24956 ISIG(NCHN,2)=J
24957 ISIG(NCHN,3)=2
24958 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
24959 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
24960 ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN
24961 NCHN=NCHN+1
24962 ISIG(NCHN,1)=I
24963 ISIG(NCHN,2)=J
24964 ISIG(NCHN,3)=1
24965 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
24966 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSB*BRPOS
24967 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSB*BRNEG
24968 ENDIF
24969 1770 CONTINUE
24970 1780 CONTINUE
24971
24972 ELSEIF(ISUB.EQ.169) THEN
24973C...q + qbar -> e + e* (excited lepton)
24974 KFQSTR=KFPR(ISUB,2)
24975 KCQSTR=PYCOMP(KFQSTR)
24976 KFQEXC=MOD(KFQSTR,KEXCIT)
24977 FACQSB=(COMFAC/6D0)*(SH/PARU(155)**2)**2*(1D0-SQM4/SH)*
24978 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
24979C...Propagators: as simulated in PYOFSH and as desired
24980 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
24981 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
24982 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
24983 GMMQC=SQRT(SQM4)*WDTP(0)
24984 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
24985 FACQSB=FACQSB*HBW4C/HBW4
24986C...Branching ratios.
24987 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
24988 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
24989 DO 1790 I=MMIN1,MMAX1
24990 IA=IABS(I)
24991 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 1790
24992 J=-I
24993 JA=IABS(J)
24994 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 1790
24995 NCHN=NCHN+1
24996 ISIG(NCHN,1)=I
24997 ISIG(NCHN,2)=J
24998 ISIG(NCHN,3)=1
24999 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
25000 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
25001 NCHN=NCHN+1
25002 ISIG(NCHN,1)=I
25003 ISIG(NCHN,2)=J
25004 ISIG(NCHN,3)=2
25005 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
25006 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
25007 1790 CONTINUE
25008
25009 ELSEIF(ISUB.EQ.191) THEN
25010C...q + qbar -> rho_tc0.
25011 KCTC=PYCOMP(KTECHN+113)
25012 SQMRHT=PMAS(KCTC,1)**2
25013 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
25014 HS=SHR*WDTP(0)
25015 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
25016 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
25017 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
25018 ALPRHT=2.91D0*(3D0/PARP(144))
25019 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)
25020 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
25021 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
25022 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
25023 DO 1800 I=MMINA,MMAXA
25024 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1800
25025 IA=IABS(I)
25026 EI=KCHG(IABS(I),1)/3D0
25027 AI=SIGN(1D0,EI+0.1D0)
25028 VI=AI-4D0*EI*XWV
25029 VALI=0.5D0*(VI+AI)
25030 VARI=0.5D0*(VI-AI)
25031 HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
25032 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
25033 IF(IA.LE.10) HI=HI*FACA/3D0
25034 NCHN=NCHN+1
25035 ISIG(NCHN,1)=I
25036 ISIG(NCHN,2)=-I
25037 ISIG(NCHN,3)=1
25038 SIGH(NCHN)=HI*FACBW*HF
25039 1800 CONTINUE
25040
25041 ELSEIF(ISUB.EQ.192) THEN
25042C...q + qbar' -> rho_tc+/-.
25043 KCTC=PYCOMP(KTECHN+213)
25044 SQMRHT=PMAS(KCTC,1)**2
25045 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
25046 HS=SHR*WDTP(0)
25047 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
25048 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
25049 ALPRHT=2.91D0*(3D0/PARP(144))
25050 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)*
25051 & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
25052 DO 1820 I=MMIN1,MMAX1
25053 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1820
25054 IA=IABS(I)
25055 DO 1810 J=MMIN2,MMAX2
25056 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1810
25057 JA=IABS(J)
25058 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1810
25059 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
25060 & GOTO 1810
25061 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
25062 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4))
25063 HI=HP
25064 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
25065 NCHN=NCHN+1
25066 ISIG(NCHN,1)=I
25067 ISIG(NCHN,2)=J
25068 ISIG(NCHN,3)=1
25069 SIGH(NCHN)=HI*FACBW*HF
25070 1810 CONTINUE
25071 1820 CONTINUE
25072
25073 ELSEIF(ISUB.EQ.193) THEN
25074C...q + qbar -> omega_tc0.
25075 KCTC=PYCOMP(KTECHN+223)
25076 SQMOMT=PMAS(KCTC,1)**2
25077 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
25078 HS=SHR*WDTP(0)
25079 FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2)
25080 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
25081 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
25082 ALPRHT=2.91D0*(3D0/PARP(144))
25083 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)*
25084 & (2D0*PARP(143)-1D0)**2
25085 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
25086 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
25087 DO 1830 I=MMINA,MMAXA
25088 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1830
25089 IA=IABS(I)
25090 EI=KCHG(IABS(I),1)/3D0
25091 AI=SIGN(1D0,EI+0.1D0)
25092 VI=AI-4D0*EI*XWV
25093 VALI=0.5D0*(VI+AI)
25094 VARI=0.5D0*(VI-AI)
25095 HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
25096 & (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
25097 IF(IA.LE.10) HI=HI*FACA/3D0
25098 NCHN=NCHN+1
25099 ISIG(NCHN,1)=I
25100 ISIG(NCHN,2)=-I
25101 ISIG(NCHN,3)=1
25102 SIGH(NCHN)=HI*FACBW*HF
25103 1830 CONTINUE
25104
25105 ELSEIF(ISUB.EQ.194) THEN
25106C...f + fbar -> f' + fbar' via s-channel rho_tc and omega_tc.
25107 KFA=KFPR(ISUBSV,1)
25108 ALPRHT=2.91D0*(3D0/PARP(144))
25109 HP=AEM**2*COMFAC
25110 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
25111 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
25112
25113 QUPD=2D0*PARP(143)-1D0
25114 FAR=SQRT(AEM/ALPRHT)
25115 FAO=FAR*QUPD
25116 FZR=FAR*CT2W
25117 FZO=-FAO*TANW
25118 SFAR=FAR**2
25119 SFAO=FAO**2
25120 SFZR=FZR**2
25121 SFZO=FZO**2
25122 CALL PYWIDT(23,SH,WDTP,WDTE)
25123 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
25124 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
25125 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
25126 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
25127 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
25128 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
25129 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
25130 DAA=(-Sfzr*SSMO - Sfzo*SSMR + SSMO*SSMR*SSMZ)/DETD/SH
25131 DZZ=(-Sfar*SSMO - Sfao*SSMR + SSMO*SSMR)/DETD/SH
25132 DAZ=(far*fzr*SSMO + fao*fzo*SSMR)/DETD/SH
25133
25134 XWRHT=1D0/(4D0*XW*(1D0-XW))
25135 KFF=IABS(KFPR(ISUB,1))
25136 EF=KCHG(KFF,1)/3D0
25137 AF=SIGN(1D0,EF+0.1D0)
25138 VF=AF-4D0*EF*XWV
25139 VALF=0.5D0*(VF+AF)
25140 VARF=0.5D0*(VF-AF)
25141 FCOF=1D0
25142 IF(KFF.LE.10) FCOF=3D0
25143
25144 WID2=1D0
25145 IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1)
25146 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
25147 DZZ=DZZ*DCMPLX(XWRHT,0D0)
25148 DAZ=DAZ*DCMPLX(SQRT(XWRHT),0D0)
25149
25150 DO 1840 I=MMINA,MMAXA
25151 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1840
25152 EI=KCHG(IABS(I),1)/3D0
25153 AI=SIGN(1D0,EI+0.1D0)
25154 VI=AI-4D0*EI*XWV
25155 VALI=0.5D0*(VI+AI)
25156 VARI=0.5D0*(VI-AI)
25157 FCOI=FCOF
25158 IF(IABS(I).LE.10) FCOI=FCOI/3D0
25159 DIFLL=ABS(EI*EF*DAA+VALI*VALF*DZZ+DAZ*(EI*VALF+EF*VALI))**2
25160 DIFRR=ABS(EI*EF*DAA+VARI*VARF*DZZ+DAZ*(EI*VARF+EF*VARI))**2
25161 DIFLR=ABS(EI*EF*DAA+VALI*VARF*DZZ+DAZ*(EI*VARF+EF*VALI))**2
25162 DIFRL=ABS(EI*EF*DAA+VARI*VALF*DZZ+DAZ*(EI*VALF+EF*VARI))**2
25163 FACSIG=(DIFLL+DIFRR)*((UH-SQM4)**2+SH*SQM4)+
25164 & (DIFLR+DIFRL)*((TH-SQM3)**2+SH*SQM3)
25165 NCHN=NCHN+1
25166 ISIG(NCHN,1)=I
25167 ISIG(NCHN,2)=-I
25168 ISIG(NCHN,3)=1
25169 SIGH(NCHN)=HP*FCOI*FACSIG*WID2
25170 1840 CONTINUE
25171
25172 ELSEIF(ISUB.EQ.195) THEN
25173C...f + fbar' -> f'' + fbar''' via s-channel rho_tc+
25174 KFA=KFPR(ISUBSV,1)
25175 KFB=KFA+1
25176 ALPRHT=2.91D0*(3D0/PARP(144))
25177 FACTC=COMFAC*(AEM**2/12D0/XW**2)*(UH-SQM3)*(UH-SQM4)*3D0
25178
25179 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
25180 CALL PYWIDT(24,SH,WDTP,WDTE)
25181 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
25182 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
25183 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
25184
25185 FCOF=1D0
25186 IF(KFA.LE.8) FCOF=3D0
25187 DETD=SSMZ*SSMR-DCMPLX(FWR**2,0D0)
25188 HP=FACTC*ABS(SSMR/DETD)**2/SH**2*FCOF
25189
25190 DO 1860 I=MMIN1,MMAX1
25191 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1860
25192 IA=IABS(I)
25193 DO 1850 J=MMIN2,MMAX2
25194 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1850
25195 JA=IABS(J)
25196 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1850
25197 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
25198 & GOTO 1850
25199 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
25200 HI=HP
25201 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
25202 NCHN=NCHN+1
25203 ISIG(NCHN,1)=I
25204 ISIG(NCHN,2)=J
25205 ISIG(NCHN,3)=1
25206 SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,(5+KCHR)/2)
25207 1850 CONTINUE
25208 1860 CONTINUE
25209
25210 ENDIF
25211
25212CMRENNA++
25213C...J: 2 -> 2, tree diagrams, SUSY processes
25214
25215 ELSEIF(ISUB.LE.210) THEN
25216 IF(ISUB.EQ.201) THEN
25217C...f + fbar -> e_L + e_Lbar
25218 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25219 DO 1890 I=MMIN1,MMAX1
25220 IA=IABS(I)
25221 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1890
25222 EI=KCHG(IA,1)/3D0
25223 TT3I=SIGN(1D0,EI+1D-6)/2D0
25224 EJ=-1D0
25225 TT3J=-1D0/2D0
25226 FCOL=1D0
25227C...Color factor for e+ e-
25228 IF(IA.GE.11) FCOL=3D0
25229 IF(ISUBSV.EQ.301) THEN
25230 A1=1D0
25231 A2=0D0
25232 ELSEIF(ILR.EQ.1) THEN
25233 A1=SFMIX(KFID,3)**2
25234 A2=SFMIX(KFID,4)**2
25235 ELSEIF(ILR.EQ.0) THEN
25236 A1=SFMIX(KFID,1)**2
25237 A2=SFMIX(KFID,2)**2
25238 ENDIF
25239 XLQ=(TT3J-EJ*XW)*A1
25240 XRQ=(-EJ*XW)*A2
25241 XLF=(TT3I-EI*XW)
25242 XRF=(-EI*XW)
25243 TAA=(EI*EJ)**2*(POLL+POLR)
25244 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ+XRQ)**2/XW**2/XW1**2
25245 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
25246 TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF*POLL+XRF*POLR)/XW/XW1
25247 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
25248 TNN=0.0D0
25249 TAN=0.0D0
25250 TZN=0.0D0
25251 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
25252 FAC2=SQRT(2D0)
25253 TNN1=0D0
25254 TNN2=0D0
25255 TNN3=0D0
25256 DO 1880 II=1,4
25257 DK=1D0/(TH-SMZ(II)**2)
25258 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
25259 & ZMIX(II,1))
25260 FREK=FAC2*TANW*EI*ZMIX(II,1)
25261 TNN1=TNN1+FLEK**2*DK
25262 TNN2=TNN2+FREK**2*DK
25263 DO 1870 JJ=1,4
25264 DL=1D0/(TH-SMZ(JJ)**2)
25265 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
25266 & ZMIX(JJ,1))
25267 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
25268 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
25269 1870 CONTINUE
25270 1880 CONTINUE
25271 TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2*POLL+
25272 & A2**2*TNN2**2*POLR)
25273 TNN=(TNN+SH*A1*A2*TNN3*((1D0-PARJ(131))*(1D0-PARJ(132))+
25274 & (1D0+PARJ(131))*(1D0+PARJ(132))))/4D0/XW**2
25275 TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
25276 & (TNN1*XLF*A1*POLL+TNN2*XRF*A2*POLR)
25277 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
25278 & (1D0-SQMZ/SH)/SH
25279 TZN=TZN/XW**2/XW1
25280 TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1*POLL+
25281 & A2*TNN2*POLR)/XW
25282 ENDIF
25283 FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0
25284 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2
25285 FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0
25286 NCHN=NCHN+1
25287 ISIG(NCHN,1)=I
25288 ISIG(NCHN,2)=-I
25289 ISIG(NCHN,3)=1
25290 SIGH(NCHN)=FACQQ1+FACQQ2
25291 1890 CONTINUE
25292
25293 ELSEIF(ISUB.EQ.203) THEN
25294C...f + fbar -> e_L + e_Rbar
25295 DO 1920 I=MMIN1,MMAX1
25296 IA=IABS(I)
25297 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1920
25298 EI=KCHG(IABS(I),1)/3D0
25299 TT3I=SIGN(1D0,EI)/2D0
25300 EJ=-1
25301 TT3J=-1D0/2D0
25302 FCOL=1D0
25303C...Color factor for e+ e-
25304 IF(IA.GE.11) FCOL=3D0
25305 A1=SFMIX(KFID,1)**2
25306 A2=SFMIX(KFID,2)**2
25307 XLQ=(TT3J-EJ*XW)
25308 XRQ=(-EJ*XW)
25309 XLF=(TT3I-EI*XW)
25310 XRF=(-EI*XW)
25311 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ-XRQ)**2
25312 & /XW**2/XW1**2*A1*A2
25313 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
25314 TNN=0.0D0
25315 TZN=0.0D0
25316 TNNA=0D0
25317 TNNB=0D0
25318 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
25319 FAC2=SQRT(2D0)
25320 TNN1=0D0
25321 TNN2=0D0
25322 TNN3=0D0
25323 DO 1910 II=1,4
25324 DK=1D0/(TH-SMZ(II)**2)
25325 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
25326 & ZMIX(II,1))
25327 FREK=FAC2*TANW*EI*ZMIX(II,1)
25328 TNN1=TNN1+FLEK**2*DK
25329 TNN2=TNN2+FREK**2*DK
25330 DO 1900 JJ=1,4
25331 DL=1D0/(TH-SMZ(JJ)**2)
25332 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
25333 & ZMIX(JJ,1))
25334 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
25335 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
25336 1900 CONTINUE
25337 1910 CONTINUE
25338 TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2*POLR+TNN1**2*POLL)
25339 TNNA=(TNN+SH*(A1**2*POLLL+A2**2*POLRR)*TNN3)/4D0
25340 TNNB=(TNN+SH*(A1**2*POLRR+A2**2*POLLL)*TNN3)/4D0
25341 TZN=(UH*TH-SQM3*SQM4)*A1*A2
25342 TZN=TZN*(XLQ-XRQ)*(XLF*TNN1*POLL-XRF*TNN2*POLR)/XW1
25343 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
25344 & (1D0-SQMZ/SH)/SH
25345 ENDIF
25346 FACQQ0=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
25347 FACQQ2=COMFAC*AEM**2/XW**2*(TNNA+TZN)*FCOL/3D0
25348 FACQQ1=COMFAC*AEM**2/XW**2*(TNNB+TZN)*FCOL/3D0
25349C%%%%%%%%%%%
25350 NCHN=NCHN+1
25351 ISIG(NCHN,1)=I
25352 ISIG(NCHN,2)=-I
25353 ISIG(NCHN,3)=1
25354 SIGH(NCHN)=(FACQQ0+FACQQ1)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25355 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
25356 NCHN=NCHN+1
25357 ISIG(NCHN,1)=I
25358 ISIG(NCHN,2)=-I
25359 ISIG(NCHN,3)=2
25360 SIGH(NCHN)=(FACQQ0+FACQQ2)*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
25361 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25362 1920 CONTINUE
25363
25364 ELSEIF(ISUB.EQ.210) THEN
25365C...q + qbar' -> W*- > ~l_L + ~nu_L
25366 FAC0=RKF*COMFAC*AEM**2/XW**2/12D0
25367 FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW)
25368 DO 1940 I=MMIN1,MMAX1
25369 IA=IABS(I)
25370 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 1940
25371 DO 1930 J=MMIN2,MMAX2
25372 JA=IABS(J)
25373 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 1930
25374 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1930
25375 FCKM=3D0
25376 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
25377 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
25378 KCHW=2
25379 IF(KCHSUM.LT.0) KCHW=3
25380 NCHN=NCHN+1
25381 ISIG(NCHN,1)=I
25382 ISIG(NCHN,2)=J
25383 ISIG(NCHN,3)=1
25384 IF(ISUBSV.EQ.297.OR.ISUBSV.EQ.298) THEN
25385 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
25386 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25387 ELSE
25388 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
25389 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
25390 ENDIF
25391 SIGH(NCHN)=FAC0*FAC1*FCKM*FACR
25392 1930 CONTINUE
25393 1940 CONTINUE
25394 ENDIF
25395
25396 ELSEIF(ISUB.LE.220) THEN
25397 IF(ISUB.EQ.213) THEN
25398C...f + fbar -> ~nu_L + ~nu_Lbar
25399 IF(ISUBSV.EQ.299.OR.ISUBSV.EQ.300) THEN
25400 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25401 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25402 ELSE
25403 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25404 ENDIF
25405 COMFAC=COMFAC*FACR
25406 PROPZ2=(SH-SQMZ)**2+ZWID**2*SQMZ
25407 XLL=0.5D0
25408 XLR=0.0D0
25409 DO 1950 I=MMIN1,MMAX1
25410 IA=IABS(I)
25411 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1950
25412 EI=KCHG(IA,1)/3D0
25413 FCOL=1D0
25414C...Color factor for e+ e-
25415 IF(IA.GE.11) FCOL=3D0
25416 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
25417 XRQ=-EI*XW
25418 TZC=0.0D0
25419 TCC=0.0D0
25420 IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN
25421 TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/
25422 & (TH-SMW(2)**2)
25423 TCC=TZC**2
25424 TZC=TZC/XW1*(SH-SQMZ)/PROPZ2*XLQ*XLL
25425 ENDIF
25426 FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ2
25427 FACQQ2=TZC+TCC/4D0
25428 NCHN=NCHN+1
25429 ISIG(NCHN,1)=I
25430 ISIG(NCHN,2)=-I
25431 ISIG(NCHN,3)=1
25432 SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC
25433 & *AEM**2*FCOL/3D0/XW**2
25434 1950 CONTINUE
25435
25436 ELSEIF(ISUB.EQ.216) THEN
25437C...q + qbar -> ~chi0_1 + ~chi0_1
25438 IF(IZID1.EQ.IZID2) THEN
25439 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25440 ELSE
25441 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25442 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25443 ENDIF
25444 FACXX=COMFAC*AEM**2/3D0/XW**2
25445 IF(IZID1.EQ.IZID2) FACXX=FACXX/2D0
25446 ZM12=SQM3
25447 ZM22=SQM4
25448 WU2 = (UH-ZM12)*(UH-ZM22)
25449 WT2 = (TH-ZM12)*(TH-ZM22)
25450 WS2 = SMZ(IZID1)*SMZ(IZID2)*SH
25451 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
25452 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
25453 DO 1960 I=1,4
25454 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
25455 IF(IZID2.NE.IZID1) THEN
25456 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
25457 ENDIF
25458 1960 CONTINUE
25459 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
25460 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
25461 ORPP=DCONJG(OLPP)
25462 DO 1970 I=MMINA,MMAXA
25463 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1970
25464 EI=KCHG(IABS(I),1)/3D0
25465 T3I=SIGN(1D0,EI+1D-6)/2D0
25466 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2
25467 XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2
25468 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
25469 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
25470 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
25471 QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
25472 QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
25473 & /DCMPLX(TH-XML2)
25474 QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
25475 QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
25476 & -DCONJG(GRIJ)/DCMPLX(UH-XMR2)
25477 FCOL=1D0
25478 IF(IABS(I).GE.11) FCOL=3D0
25479 FACGG1=(ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
25480 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
25481 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
25482 & QRL*DCONJG(QRR)*POLR)*WS2
25483 NCHN=NCHN+1
25484 ISIG(NCHN,1)=I
25485 ISIG(NCHN,2)=-I
25486 ISIG(NCHN,3)=1
25487 SIGH(NCHN)=FACXX*FACGG1*FCOL
25488 1970 CONTINUE
25489 ENDIF
25490
25491 ELSEIF(ISUB.LE.230) THEN
25492 IF(ISUB.EQ.226) THEN
25493C...f + fbar -> ~chi+_1 + ~chi-_1
25494 FACXX=COMFAC*AEM**2/3D0
25495 ZM12=SQM3
25496 ZM22=SQM4
25497 WU2 = (UH-ZM12)*(UH-ZM22)
25498 WT2 = (TH-ZM12)*(TH-ZM22)
25499 WS2 = SMW(IZID1)*SMW(IZID2)*SH
25500 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
25501 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
25502 DIFF=0D0
25503 IF(IZID1.EQ.IZID2) DIFF=1D0
25504 DO 1980 I=1,2
25505 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
25506 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
25507 IF(IZID2.NE.IZID1) THEN
25508 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
25509 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
25510 ENDIF
25511 1980 CONTINUE
25512 OLP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
25513 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0+DCMPLX(XW*DIFF)
25514 ORP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
25515 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0+DCMPLX(XW*DIFF)
25516 DO 1990 I=MMINA,MMAXA
25517 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1990
25518 EI=KCHG(IABS(I),1)/3D0
25519 T3I=SIGN(1D0,EI+1D-6)/2D0
25520 QRL=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*ORP
25521 QLL=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*PROPZ*ORP
25522 QRR=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*OLP
25523 IF(MOD(I,2).EQ.0) THEN
25524 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
25525 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
25526 & PROPZ*OLP-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*
25527 & DCMPLX(T3I/XW/(TH-XML2))
25528 ELSE
25529 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2
25530 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
25531 & PROPZ*OLP-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*
25532 & DCMPLX(T3I/XW/(TH-XML2))
25533 ENDIF
25534 FCOL=1D0
25535 IF(IABS(I).GE.11) FCOL=3D0
25536 FACSUM=((ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
25537 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
25538 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
25539 & QRL*DCONJG(QRR)*POLR)*WS2)*FACXX*FCOL
25540 NCHN=NCHN+1
25541 ISIG(NCHN,1)=I
25542 ISIG(NCHN,2)=-I
25543 ISIG(NCHN,3)=1
25544 IF(IZID1.EQ.IZID2) THEN
25545 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25546 ELSE
25547 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
25548 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25549 NCHN=NCHN+1
25550 ISIG(NCHN,1)=I
25551 ISIG(NCHN,2)=-I
25552 ISIG(NCHN,3)=2
25553 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25554 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
25555 ENDIF
25556 1990 CONTINUE
25557
25558 ELSEIF(ISUB.EQ.229) THEN
25559C...q + qbar' -> ~chi0_1 + ~chi+-_1
25560 FACXX=COMFAC*AEM**2/6D0/XW**2
25561 ZM12=SQM3
25562 ZM22=SQM4
25563 WU2 = (UH-ZM12)*(UH-ZM22)
25564 WT2 = (TH-ZM12)*(TH-ZM22)
25565 WS2 = SMW(IZID1)*SMZ(IZID2)*SH
25566 RT2I = 1D0/SQRT(2D0)
25567 PROPW = DCMPLX(SH-SQMW,-WWID*PMAS(24,1))/
25568 & DCMPLX((SH-SQMW)**2+WWID**2*SQMW,0D0)
25569 DO 2000 I=1,2
25570 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
25571 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
25572 2000 CONTINUE
25573 DO 2010 I=1,4
25574 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
25575 2010 CONTINUE
25576 OL=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
25577 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)*PROPW
25578 OR=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
25579 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)*PROPW
25580
25581 DO 2030 I=MMIN1,MMAX1
25582 IA=IABS(I)
25583 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 2030
25584 EI=KCHG(IA,1)/3D0
25585 T3I=SIGN(1D0,EI+1D-6)/2D0
25586 DO 2020 J=MMIN2,MMAX2
25587 JA=IABS(J)
25588 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 2020
25589 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 2020
25590 EJ=KCHG(JA,1)/3D0
25591 T3J=SIGN(1D0,EJ+1D-6)/2D0
25592 FCKM=3D0
25593 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
25594 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
25595 KCHW=2
25596 IF(KCHSUM.LT.0) KCHW=3
25597 IF(MOD(IA,2).EQ.0) THEN
25598 ZMI2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
25599 ZMJ2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
25600 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
25601 & TANW+ZMIXC(IZID2,2)*T3I)/DCMPLX(UH-ZMI2)
25602 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
25603 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
25604 & /DCMPLX(TH-ZMJ2)
25605 ELSE
25606 ZMI2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
25607 ZMJ2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
25608 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
25609 & TANW+ZMIXC(IZID2,2)*T3J)/DCMPLX(UH-ZMJ2)
25610 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
25611 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
25612 & /DCMPLX(TH-ZMI2)
25613 ENDIF
25614 ZINTR=DBLE(QLR*DCONJG(QLL))
25615 FACGG1=FACXX*(ABS(QLL)**2*WU2+ABS(QLR)**2*WT2+
25616 & 2D0*ZINTR*WS2)
25617 NCHN=NCHN+1
25618 ISIG(NCHN,1)=I
25619 ISIG(NCHN,2)=J
25620 ISIG(NCHN,3)=1
25621 SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25622 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
25623 2020 CONTINUE
25624 2030 CONTINUE
25625 ENDIF
25626
25627 ELSEIF(ISUB.LE.240) THEN
25628 IF(ISUB.EQ.237) THEN
25629C...q + qbar -> gluino + ~chi0_1
25630 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25631 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25632 FAC0=COMFAC*AS*AEM*4D0/9D0/XW
25633 GM2=SQM3
25634 ZM2=SQM4
25635 DO 2040 I=MMINA,MMAXA
25636 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2040
25637 EI=KCHG(IABS(I),1)/3D0
25638 IA=IABS(I)
25639 XLQC = -TANW*EI*ZMIX(IZID,1)
25640 XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
25641 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
25642 XLQ2=XLQC**2
25643 XRQ2=XRQC**2
25644 XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2
25645 XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2
25646 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2
25647 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2
25648 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2)
25649 SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN)
25650 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2
25651 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2
25652 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2)
25653 SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN)
25654 NCHN=NCHN+1
25655 ISIG(NCHN,1)=I
25656 ISIG(NCHN,2)=-I
25657 ISIG(NCHN,3)=1
25658 SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR)
25659 2040 CONTINUE
25660 ENDIF
25661
25662 ELSEIF(ISUB.LE.250) THEN
25663 IF(ISUB.EQ.241) THEN
25664C...q + qbar' -> ~chi+-_1 + gluino
25665 FACWG=COMFAC*AS*AEM/XW*2D0/9D0
25666 GM2=SQM3
25667 ZM2=SQM4
25668 FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1)
25669 FAC0=UMIX(IZID,1)**2
25670 FAC1=VMIX(IZID,1)**2
25671 DO 2060 I=MMIN1,MMAX1
25672 IA=IABS(I)
25673 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 2060
25674 DO 2050 J=MMIN2,MMAX2
25675 JA=IABS(J)
25676 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 2050
25677 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 2050
25678 FCKM=1D0
25679 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
25680 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
25681 KCHW=2
25682 IF(KCHSUM.LT.0) KCHW=3
25683 XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2
25684 XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2
25685 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2
25686 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2
25687 ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2)
25688 XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2
25689 XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2
25690 ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0
25691 AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0
25692 ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)*
25693 & SH/(TH-XMU2)/(UH-XMD2))/2D0
25694 NCHN=NCHN+1
25695 ISIG(NCHN,1)=I
25696 ISIG(NCHN,2)=J
25697 ISIG(NCHN,3)=1
25698 SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN-
25699 & FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25700 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
25701 2050 CONTINUE
25702 2060 CONTINUE
25703
25704 ELSEIF(ISUB.EQ.243) THEN
25705C...q + qbar -> gluino + gluino
25706 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25707 XMT=SQM3-TH
25708 XMU=SQM3-UH
25709 DO 2070 I=MMINA,MMAXA
25710 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
25711 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2070
25712 NCHN=NCHN+1
25713 XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH
25714 XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH
25715 FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
25716 & 2D0*SQM3*SH)/SH2 +4D0/9D0*(XMT**2/XST**2+
25717 & XMU**2/XSU**2) - (XMT**2+SH*SQM3)/SH/XST +
25718 & SQM3*SH/XST/XSU/9D0- (XMU**2+SH*SQM3)/SH/XSU )
25719 XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
25720 XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
25721 FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
25722 & 2D0*SQM3*SH)/SH2 +4D0/9D0*(XMT**2/XST**2+
25723 & XMU**2/XSU**2) - (XMT**2+SH*SQM3)/SH/XST +
25724 & SQM3*SH/XST/XSU/9D0- (XMU**2+SH*SQM3)/SH/XSU )
25725 ISIG(NCHN,1)=I
25726 ISIG(NCHN,2)=-I
25727 ISIG(NCHN,3)=1
25728C...1/2 for identical particles
25729 SIGH(NCHN)=0.25D0*(FACGG1+FACGG2)
25730 2070 CONTINUE
25731
25732 ELSEIF(ISUB.EQ.244) THEN
25733C...g + g -> gluino + gluino
25734 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25735 XMT=SQM3-TH
25736 XMU=SQM3-UH
25737 FACQQ1=COMFAC*AS**2*9D0/4D0*(
25738 & (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 -
25739 & (XMT*XMU+SQM3*(UH-TH))/SH/XMT )
25740 FACQQ2=COMFAC*AS**2*9D0/4D0*(
25741 & (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 -
25742 & (XMU*XMT+SQM3*(TH-UH))/SH/XMU )
25743 FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 +
25744 & SQM3*(SH-4D0*SQM3)/XMT/XMU)
25745 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 2080
25746 NCHN=NCHN+1
25747 ISIG(NCHN,1)=21
25748 ISIG(NCHN,2)=21
25749 ISIG(NCHN,3)=1
25750 SIGH(NCHN)=FACQQ1/2D0
25751 NCHN=NCHN+1
25752 ISIG(NCHN,1)=21
25753 ISIG(NCHN,2)=21
25754 ISIG(NCHN,3)=2
25755 SIGH(NCHN)=FACQQ2/2D0
25756 NCHN=NCHN+1
25757 ISIG(NCHN,1)=21
25758 ISIG(NCHN,2)=21
25759 ISIG(NCHN,3)=3
25760 SIGH(NCHN)=FACQQ3/2D0
25761 2080 CONTINUE
25762
25763 ELSEIF(ISUB.EQ.246) THEN
25764C...g + q_j -> ~chi0_1 + ~q_j
25765 FAC0=COMFAC*AS*AEM/6D0/XW
25766 ZM2=SQM4
25767 QM2=SQM3
25768 FACZQ0=FAC0*( (ZM2-TH)/SH +
25769 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
25770 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
25771 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
25772 DO 2100 I=-KFNSQ,KFNSQ,2*KFNSQ
25773 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 2100
25774 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2100
25775 EI=KCHG(IABS(I),1)/3D0
25776 IA=IABS(I)
25777 XRQZ = -TANW*EI*ZMIX(IZID,1)
25778 XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
25779 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
25780 IF(ILR.EQ.0) THEN
25781 BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2
25782 ELSE
25783 BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2
25784 ENDIF
25785 FACZQ=FACZQ0*BS
25786 KCHQ=2
25787 IF(I.LT.0) KCHQ=3
25788 DO 2090 ISDE=1,2
25789 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2090
25790 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2090
25791 NCHN=NCHN+1
25792 ISIG(NCHN,ISDE)=I
25793 ISIG(NCHN,3-ISDE)=21
25794 ISIG(NCHN,3)=1
25795 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25796 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25797 2090 CONTINUE
25798 2100 CONTINUE
25799 ENDIF
25800
25801 ELSEIF(ISUB.LE.260) THEN
25802 IF(ISUB.EQ.254) THEN
25803C...g + q_j -> ~chi1_1 + ~q_i
25804 FAC0=COMFAC*AS*AEM/12D0/XW
25805 ZM2=SQM4
25806 QM2=SQM3
25807 AU=UMIX(IZID,1)**2
25808 AD=VMIX(IZID,1)**2
25809 FACZQ0=FAC0*( (ZM2-TH)/SH +
25810 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
25811 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
25812 KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1)
25813 IF(MOD(KFNSQ1,2).EQ.0) THEN
25814 KFNSQ=KFNSQ1-1
25815 KCHW=2
25816 ELSE
25817 KFNSQ=KFNSQ1+1
25818 KCHW=3
25819 ENDIF
25820 DO 2120 I=-KFNSQ,KFNSQ,2*KFNSQ
25821 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 2120
25822 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2120
25823 IA=IABS(I)
25824 IF(MOD(IA,2).EQ.0) THEN
25825 FACZQ=FACZQ0*AU
25826 ELSE
25827 FACZQ=FACZQ0*AD
25828 ENDIF
25829 FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2
25830 KCHQ=2
25831 IF(I.LT.0) KCHQ=3
25832 KCHWQ=KCHW
25833 IF(I.LT.0) KCHWQ=5-KCHW
25834 DO 2110 ISDE=1,2
25835 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2110
25836 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2110
25837 NCHN=NCHN+1
25838 ISIG(NCHN,ISDE)=I
25839 ISIG(NCHN,3-ISDE)=21
25840 ISIG(NCHN,3)=1
25841 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25842 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ)
25843 2110 CONTINUE
25844 2120 CONTINUE
25845
25846 ELSEIF(ISUB.EQ.258) THEN
25847C...g + q_j -> gluino + ~q_i
25848 XG2=SQM4
25849 XQ2=SQM3
25850 XMT=XG2-TH
25851 XMU=XG2-UH
25852 XST=XQ2-TH
25853 XSU=XQ2-UH
25854 FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 -
25855 & ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) +
25856 & 0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) +
25857 & (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU
25858 FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0*
25859 & (SH*(UH+XG2)
25860 & +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH +
25861 & 0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+
25862 & (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU
25863 FACQG1=COMFAC*AS**2*FACQG1/2D0
25864 FACQG2=COMFAC*AS**2*FACQG2/2D0
25865 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
25866 DO 2140 I=-KFNSQ,KFNSQ,2*KFNSQ
25867 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 2140
25868 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 2140
25869 KCHQ=2
25870 IF(I.LT.0) KCHQ=3
25871 FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25872 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25873 DO 2130 ISDE=1,2
25874 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2130
25875 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2130
25876 NCHN=NCHN+1
25877 ISIG(NCHN,ISDE)=I
25878 ISIG(NCHN,3-ISDE)=21
25879 ISIG(NCHN,3)=1
25880 SIGH(NCHN)=FACQG1*FACSEL
25881 NCHN=NCHN+1
25882 ISIG(NCHN,ISDE)=I
25883 ISIG(NCHN,3-ISDE)=21
25884 ISIG(NCHN,3)=2
25885 SIGH(NCHN)=FACQG2*FACSEL
25886 2130 CONTINUE
25887 2140 CONTINUE
25888 ENDIF
25889
25890 ELSEIF(ISUB.LE.270) THEN
25891 IF(ISUB.EQ.261) THEN
25892C...q_i + q_ibar -> ~t_1 + ~t_1bar
25893 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )*
25894 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25895 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
25896 FAC0=AS**2*4D0/9D0
25897 DO 2150 I=MMIN1,MMAX1
25898 IA=IABS(I)
25899 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2150
25900 IF(IA.GE.11.AND.IA.LE.18) THEN
25901 EI=KCHG(IA,1)/3D0
25902 EJ=KCHG(KFNSQ,1)/3D0
25903 T3I=SIGN(1D0,EI)/2D0
25904 T3J=SIGN(1D0,EJ)/2D0
25905 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2
25906 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2
25907 XLF=2D0*(T3I-EI*XW)
25908 XRF=2D0*(-EI*XW)
25909 TAA=0.5D0*(EI*EJ)**2
25910 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
25911 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
25912 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
25913 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
25914 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
25915 ENDIF
25916 NCHN=NCHN+1
25917 ISIG(NCHN,1)=I
25918 ISIG(NCHN,2)=-I
25919 ISIG(NCHN,3)=1
25920 SIGH(NCHN)=FACQQ1*FAC0
25921 2150 CONTINUE
25922
25923 ELSEIF(ISUB.EQ.263) THEN
25924C...f + fbar -> ~t1 + ~t2bar
25925 DO 2160 I=MMIN1,MMAX1
25926 IA=IABS(I)
25927 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2160
25928 EI=KCHG(IABS(I),1)/3D0
25929 TT3I=SIGN(1D0,EI)/2D0
25930 EJ=2D0/3D0
25931 TT3J=1D0/2D0
25932 FCOL=1D0
25933C...Color factor for e+ e-
25934 IF(IA.GE.11) FCOL=3D0
25935 XLQ=2D0*(TT3J-EJ*XW)
25936 XRQ=2D0*(-EJ*XW)
25937 XLF=2D0*(TT3I-EI*XW)
25938 XRF=2D0*(-EI*XW)
25939 TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2
25940 TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2
25941 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
25942C...Factor of 2 for t1 t2bar + t2 t1bar
25943 FACQQ1=2D0*COMFAC*AEM**2*TZZ*FCOL*4D0
25944 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2
25945 NCHN=NCHN+1
25946 ISIG(NCHN,1)=I
25947 ISIG(NCHN,2)=-I
25948 ISIG(NCHN,3)=1
25949 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25950 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
25951 NCHN=NCHN+1
25952 ISIG(NCHN,1)=I
25953 ISIG(NCHN,2)=-I
25954 ISIG(NCHN,3)=2
25955 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
25956 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25957 2160 CONTINUE
25958
25959 ELSEIF(ISUB.EQ.264) THEN
25960C...g + g -> ~t_1 + ~t_1bar
25961 XSU=SQM3-UH
25962 XST=SQM3-TH
25963 FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0*
25964 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25965 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
25966 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
25967 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 2170
25968 NCHN=NCHN+1
25969 ISIG(NCHN,1)=21
25970 ISIG(NCHN,2)=21
25971 ISIG(NCHN,3)=1
25972 SIGH(NCHN)=FACQQ1
25973 NCHN=NCHN+1
25974 ISIG(NCHN,1)=21
25975 ISIG(NCHN,2)=21
25976 ISIG(NCHN,3)=2
25977 SIGH(NCHN)=FACQQ2
25978 2170 CONTINUE
25979 ENDIF
25980
25981 ELSEIF(ISUB.LE.280) THEN
25982 IF(ISUB.EQ.271) THEN
25983C...q + q' -> ~q + ~q' (~g exchange)
25984 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
25985 XMT=XMG2-TH
25986 XMU=XMG2-UH
25987 XSU1=SQM3-UH
25988 XSU2=SQM4-UH
25989 XST1=SQM3-TH
25990 XST2=SQM4-TH
25991 IF(ILR.EQ.1) THEN
25992 FACQQ1=COMFAC*AS**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 )
25993 FACQQ2=COMFAC*AS**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 )
25994 FACQQB=0.0D0
25995 ELSE
25996 FACQQ1=0.5D0*COMFAC*AS**2*4D0/9D0*( SH*XMG2/XMT**2 )
25997 FACQQ2=0.5D0*COMFAC*AS**2*4D0/9D0*( SH*XMG2/XMU**2 )
25998 FACQQB=0.5D0*COMFAC*AS**2*4D0/9D0*( -2D0*SH*XMG2/3D0/
25999 & XMT/XMU )
26000 ENDIF
26001 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
26002 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
26003 DO 2190 I=-KFNSQI,KFNSQI,2*KFNSQI
26004 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 2190
26005 IA=IABS(I)
26006 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 2190
26007 KCHQ=2
26008 IF(I.LT.0) KCHQ=3
26009 DO 2180 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
26010 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 2180
26011 JA=IABS(J)
26012 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 2180
26013 IF(I*J.LT.0) GOTO 2180
26014 NCHN=NCHN+1
26015 ISIG(NCHN,1)=I
26016 ISIG(NCHN,2)=J
26017 ISIG(NCHN,3)=1
26018 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
26019 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
26020 IF(I.EQ.J) THEN
26021 IF(ILR.EQ.0) THEN
26022 SIGH(NCHN)=0.5D0*(FACQQ1+0.5D0*FACQQB)*RKF*
26023 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
26024 ELSE
26025 SIGH(NCHN)=0.5D0*FACQQ1*RKF*
26026 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
26027 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
26028 ENDIF
26029 NCHN=NCHN+1
26030 ISIG(NCHN,1)=I
26031 ISIG(NCHN,2)=J
26032 ISIG(NCHN,3)=2
26033 IF(ILR.EQ.0) THEN
26034 SIGH(NCHN)=0.5D0*(FACQQ2+0.5D0*FACQQB)*RKF*
26035 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
26036 ELSE
26037 SIGH(NCHN)=0.5D0*FACQQ2*RKF*
26038 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
26039 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
26040 ENDIF
26041 ENDIF
26042 2180 CONTINUE
26043 2190 CONTINUE
26044
26045 ELSEIF(ISUB.EQ.274) THEN
26046C...q + qbar' -> ~q + ~qbar'
26047 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
26048 XMT=XMG2-TH
26049 XMU=XMG2-UH
26050 IF(ILR.EQ.0) THEN
26051C...Mrenna...Normalization.and.1/XMT
26052 FACQQ1=COMFAC*AS**2*2D0/9D0*(
26053 & (UH*TH-SQM3*SQM4)/XMT**2 )
26054 FACQQB=COMFAC*AS**2*2D0/9D0*(
26055 & (UH*TH-SQM3*SQM4)/SH2*(2D0-2D0/3D0*SH/XMT))
26056 FACQQB=FACQQB+FACQQ1
26057 ELSE
26058 FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )
26059 FACQQB=FACQQ1
26060 ENDIF
26061 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
26062 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
26063 DO 2210 I=-KFNSQI,KFNSQI,2*KFNSQI
26064 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 2210
26065 IA=IABS(I)
26066 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 2210
26067 KCHQ=2
26068 IF(I.LT.0) KCHQ=3
26069 DO 2200 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
26070 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 2200
26071 JA=IABS(J)
26072 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 2200
26073 IF(I*J.GT.0) GOTO 2200
26074 NCHN=NCHN+1
26075 ISIG(NCHN,1)=I
26076 ISIG(NCHN,2)=J
26077 ISIG(NCHN,3)=1
26078 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
26079 & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
26080 IF(I.EQ.-J) SIGH(NCHN)=FACQQB*RKF*
26081 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
26082 2200 CONTINUE
26083 2210 CONTINUE
26084
26085 ELSEIF(ISUB.EQ.277) THEN
26086C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
26087C...if i .eq. j covered in 274
26088 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )
26089 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
26090 FAC0=0D0
26091 DO 2220 I=MMIN1,MMAX1
26092 IA=IABS(I)
26093 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.
26094 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2220
26095 IF(IA.EQ.KFNSQ) GOTO 2220
26096 IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN
26097 EI=KCHG(IA,1)/3D0
26098 EJ=KCHG(KFNSQ,1)/3D0
26099 T3J=SIGN(0.5D0,EJ)
26100 T3I=SIGN(1D0,EI)/2D0
26101 IF(ILR.EQ.0) THEN
26102 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1)
26103 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2)
26104 ELSE
26105 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3)
26106 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4)
26107 ENDIF
26108 XLF=2D0*(T3I-EI*XW)
26109 XRF=2D0*(-EI*XW)
26110 IF(ILR.EQ.0) THEN
26111 XRQ=0D0
26112 ELSE
26113 XLQ=0D0
26114 ENDIF
26115 TAA=0.5D0*(EI*EJ)**2
26116 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
26117 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
26118 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
26119 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
26120 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
26121 ELSEIF(IA.LE.6) THEN
26122 FAC0=AS**2*8D0/9D0/2D0
26123 ENDIF
26124 NCHN=NCHN+1
26125 ISIG(NCHN,1)=I
26126 ISIG(NCHN,2)=-I
26127 ISIG(NCHN,3)=1
26128 SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
26129 2220 CONTINUE
26130
26131 ELSEIF(ISUB.EQ.279) THEN
26132C...g + g -> ~q_j + ~q_jbar
26133 XSU=SQM3-UH
26134 XST=SQM3-TH
26135C...5=RKF because ~t ~tbar treated separately
26136 FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )
26137 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
26138 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
26139 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 2230
26140 NCHN=NCHN+1
26141 ISIG(NCHN,1)=21
26142 ISIG(NCHN,2)=21
26143 ISIG(NCHN,3)=1
26144 SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
26145 NCHN=NCHN+1
26146 ISIG(NCHN,1)=21
26147 ISIG(NCHN,2)=21
26148 ISIG(NCHN,3)=2
26149 SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
26150 2230 CONTINUE
26151
26152 ENDIF
26153CMRENNA--
26154
26155 ELSEIF(ISUB.LE.340) THEN
26156
26157 ELSEIF(ISUB.LE.360) THEN
26158
26159 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
26160C...l + l -> H_L++/-- or H_R++/--.
26161 KFRES=KFPR(ISUB,1)
26162 KFREC=PYCOMP(KFRES)
26163 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
26164 HS=SHR*WDTP(0)
26165 FACBW=8D0*COMFAC/((SH-PMAS(KFREC,1)**2)**2+HS**2)
26166 DO 2250 I=MMIN1,MMAX1
26167 IA=IABS(I)
26168 IF((IA.NE.11.AND.IA.NE.13.AND.IA.NE.15).OR.KFAC(1,I).EQ.0)
26169 & GOTO 2250
26170 DO 2240 J=MMIN2,MMAX2
26171 JA=IABS(J)
26172 IF((JA.NE.11.AND.JA.NE.13.AND.JA.NE.15).OR.KFAC(2,J).EQ.0)
26173 & GOTO 2240
26174 IF(I*J.LT.0) GOTO 2240
26175 KCHH=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
26176 NCHN=NCHN+1
26177 ISIG(NCHN,1)=I
26178 ISIG(NCHN,2)=J
26179 ISIG(NCHN,3)=1
26180 HI=SH*PARP(181+3*((IA-11)/2)+(JA-11)/2)**2/(8D0*PARU(1))
26181 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
26182 SIGH(NCHN)=HI*FACBW*HF
26183 2240 CONTINUE
26184 2250 CONTINUE
26185
26186 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
26187C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'.
26188 KFRES=KFPR(ISUB,1)
26189 KFREC=PYCOMP(KFRES)
26190C...Propagators: as simulated in PYOFSH and as desired
26191 HBW3=PMAS(KFREC,1)*PMAS(KFREC,2)/((SQM3-PMAS(KFREC,1)**2)**2+
26192 & (PMAS(KFREC,1)*PMAS(KFREC,2))**2)
26193 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
26194 GMMC=SQRT(SQM3)*WDTP(0)
26195 HBW3C=GMMC/((SQM3-PMAS(KFREC,1)**2)**2+GMMC**2)
26196 FHCC=COMFAC*AEM*HBW3C/HBW3
26197 DO 2270 I=MMINA,MMAXA
26198 IA=IABS(I)
26199 IF(IA.NE.11.AND.IA.NE.13.AND.IA.NE.15) GOTO 2270
26200 SQML=PMAS(IA,1)**2
26201 J=ISIGN(KFPR(ISUB,2),-I)
26202 KCHH=ISIGN(2,KCHG(IA,1)*ISIGN(1,I))
26203 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))/WDTP(0)
26204 SMM1=8D0*(SH+TH-SQM3)*(SH+TH-2D0*SQM3-SQML-SQM4)/
26205 & (UH-SQM3)**2
26206 SMM2=2D0*((2D0*SQM3-3D0*SQML)*SQM4+(SQML-2D0*SQM4)*TH-
26207 & (TH-SQM4)*SH)/(TH-SQM4)**2
26208 SMM3=2D0*((2D0*SQM3-3D0*SQM4+TH)*SQML-(2D0*SQML-SQM4+TH)*
26209 & SH)/(SH-SQML)**2
26210 SMM12=4D0*((2D0*SQML-SQM4-2D0*SQM3+TH)*SH+(TH-3D0*SQM3-
26211 & 3D0*SQM4)*TH+(2D0*SQM3-2D0*SQML+3D0*SQM4)*SQM3)/
26212 & ((UH-SQM3)*(TH-SQM4))
26213 SMM13=-4D0*((TH+SQML-2D0*SQM4)*TH-(SQM3+3D0*SQML-2D0*SQM4)*
26214 & SQM3+(SQM3+3D0*SQML+TH)*SH-(TH-SQM3+SH)**2)/
26215 & ((UH-SQM3)*(SH-SQML))
26216 SMM23=-4D0*((SQML-SQM4+SQM3)*TH-SQM3**2+SQM3*(SQML+SQM4)-
26217 & 3D0*SQML*SQM4-(SQML-SQM4-SQM3+TH)*SH)/
26218 & ((SH-SQML)*(TH-SQM4))
26219 SMM=(SH/(SH-SQML))**2*(SMM1+SMM2+SMM3+SMM12+SMM13+SMM23)*
26220 & PARP(181+3*((IA-11)/2)+(IABS(J)-11)/2)**2/(4D0*PARU(1))
26221 DO 2260 ISDE=1,2
26222 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 2260
26223 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 2260
26224 NCHN=NCHN+1
26225 ISIG(NCHN,ISDE)=I
26226 ISIG(NCHN,3-ISDE)=22
26227 ISIG(NCHN,3)=0
26228 SIGH(NCHN)=FHCC*SMM*WIDSC
26229 2260 CONTINUE
26230 2270 CONTINUE
26231
26232 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
26233C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R--
26234 KFRES=KFPR(ISUB,1)
26235 KFREC=PYCOMP(KFRES)
26236 SQMH=PMAS(KFREC,1)**2
26237 GMMH=PMAS(KFREC,1)*PMAS(KFREC,2)
26238C...Propagators: H++/-- as simulated in PYOFSH and as desired
26239 HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2)
26240 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
26241 GMMH3=SQRT(SQM3)*WDTP(0)
26242 HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2)
26243 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
26244 CALL PYWIDT(KFRES,SQM4,WDTP,WDTE)
26245 GMMH4=SQRT(SQM4)*WDTP(0)
26246 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
26247C...Kinematical and coupling functions
26248 FACHH=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*(TH*UH-SQM3*SQM4)
26249 XWHH=(1D0-2D0*XWV)/(8D0*XWV*(1D0-XWV))
26250C...Loop over allowed flavours
26251 DO 2280 I=MMINA,MMAXA
26252 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2280
26253 EI=KCHG(IABS(I),1)/3D0
26254 AI=SIGN(1D0,EI+0.1D0)
26255 VI=AI-4D0*EI*XWV
26256 FCOI=1D0
26257 IF(IABS(I).LE.10) FCOI=FACA/3D0
26258 IF(ISUB.EQ.349) THEN
26259 HBWZ=1D0/((SH-SQMZ)**2+GMMZ**2)
26260 IF(IABS(I).LT.10) THEN
26261 DSIGHH=8D0*AEM**2*(EI**2/SH2+
26262 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
26263 & (VI**2+AI**2)*XWHH**2*HBWZ)
26264 ELSE
26265 IAOFF=181+3*((IABS(I)-11)/2)
26266 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
26267 & (4D0*PARU(1))
26268 DSIGHH=8D0*AEM**2*(EI**2/SH2+
26269 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
26270 & (VI**2+AI**2)*XWHH**2*HBWZ)+
26271 & 8D0*AEM*(EI*HSUM/(SH*TH)+
26272 & (VI+AI)*XWHH*HSUM*(SH-SQMZ)*HBWZ/TH)+
26273 & 4D0*HSUM**2/TH2
26274 ENDIF
26275 ELSE
26276 IF(IABS(I).LT.10) THEN
26277 DSIGHH=8D0*AEM**2*EI**2/SH2
26278 ELSE
26279 IAOFF=181+3*((IABS(I)-11)/2)
26280 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
26281 & (4D0*PARU(1))
26282 DSIGHH=8D0*AEM**2*EI**2/SH2+8D0*AEM*EI*HSUM/(SH*TH)+
26283 & 4D0*HSUM**2/TH2
26284 ENDIF
26285 ENDIF
26286 NCHN=NCHN+1
26287 ISIG(NCHN,1)=I
26288 ISIG(NCHN,2)=-I
26289 ISIG(NCHN,3)=1
26290 SIGH(NCHN)=FACHH*FCOI*DSIGHH
26291 2280 CONTINUE
26292
26293 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
26294C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process)
26295 KFRES=KFPR(ISUB,1)
26296 KFREC=PYCOMP(KFRES)
26297 SQMH=PMAS(KFREC,1)**2
26298 IF(ISUB.EQ.351) FACNOR=PARP(190)**8*PARP(192)**2
26299 IF(ISUB.EQ.352) FACNOR=PARP(191)**6*2D0*
26300 & PMAS(PYCOMP(9900024),1)**2
26301 FACWW=COMFAC*FACNOR*TAUP*VINT(2)*VINT(219)
26302 FACPRT=1D0/((VINT(204)**2-VINT(215))*
26303 & (VINT(209)**2-VINT(216)))
26304 FACPRU=1D0/((VINT(204)**2+2D0*VINT(217))*
26305 & (VINT(209)**2+2D0*VINT(218)))
26306 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
26307 HS=SHR*WDTP(0)
26308 FACBW=(1D0/PARU(1))*VINT(2)/((SH-SQMH)**2+HS**2)
26309 IF(ABS(SHR-PMAS(KFREC,1)).GT.PARP(48)*PMAS(KFREC,2))
26310 & FACBW=0D0
26311 DO 2300 I=MMIN1,MMAX1
26312 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 2300
26313 IF(ISUB.EQ.352.AND.IABS(I).GT.10) GOTO 2300
26314 KCHWI=(1-2*MOD(IABS(I),2))*ISIGN(1,I)
26315 DO 2290 J=MMIN2,MMAX2
26316 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 2290
26317 IF(ISUB.EQ.352.AND.IABS(J).GT.10) GOTO 2290
26318 KCHWJ=(1-2*MOD(IABS(J),2))*ISIGN(1,J)
26319 KCHH=KCHWI+KCHWJ
26320 IF(IABS(KCHH).NE.2) GOTO 2290
26321 FACLR=VINT(180+I)*VINT(180+J)
26322 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
26323 IF(I.EQ.J.AND.IABS(I).GT.10) THEN
26324 FACPRP=0.5D0*(FACPRT+FACPRU)**2
26325 ELSE
26326 FACPRP=FACPRT**2
26327 ENDIF
26328 NCHN=NCHN+1
26329 ISIG(NCHN,1)=I
26330 ISIG(NCHN,2)=J
26331 ISIG(NCHN,3)=1
26332 SIGH(NCHN)=FACLR*FACWW*FACPRP*FACBW*HF
26333 2290 CONTINUE
26334 2300 CONTINUE
26335
26336 ELSEIF(ISUB.EQ.353) THEN
26337C...f + fbar -> Z_R0
26338 SQMZR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
26339 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
26340 HS=SHR*WDTP(0)
26341 FACBW=4D0*COMFAC/((SH-SQMZR)**2+HS**2)*3D0
26342 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26343 HP=(AEM/(3D0*(1D0-2D0*XW)))*XWC*SH
26344 DO 2310 I=MMINA,MMAXA
26345 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2310
26346 IF(IABS(I).LE.8) THEN
26347 EI=KCHG(IABS(I),1)/3D0
26348 AI=SIGN(1D0,EI+0.1D0)*(1D0-2D0*XW)
26349 VI=SIGN(1D0,EI+0.1D0)-4D0*EI*XW
26350 ELSE
26351 AI=-(1D0-2D0*XW)
26352 VI=-1D0+4D0*XW
26353 ENDIF
26354 HI=HP*(VI**2+AI**2)
26355 IF(IABS(I).LE.10) HI=HI*FACA/3D0
26356 NCHN=NCHN+1
26357 ISIG(NCHN,1)=I
26358 ISIG(NCHN,2)=-I
26359 ISIG(NCHN,3)=1
26360 SIGH(NCHN)=HI*FACBW*HF
26361 2310 CONTINUE
26362
26363 ELSEIF(ISUB.EQ.354) THEN
26364C...f + fbar' -> W_R+/-
26365 SQMWR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
26366 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
26367 HS=SHR*WDTP(0)
26368 FACBW=4D0*COMFAC/((SH-SQMWR)**2+HS**2)*3D0
26369 HP=AEM/(24D0*XW)*SH
26370 DO 2330 I=MMIN1,MMAX1
26371 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 2330
26372 IA=IABS(I)
26373 DO 2320 J=MMIN2,MMAX2
26374 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 2320
26375 JA=IABS(J)
26376 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 2320
26377 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
26378 & GOTO 2320
26379 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
26380 HI=HP*2D0
26381 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
26382 NCHN=NCHN+1
26383 ISIG(NCHN,1)=I
26384 ISIG(NCHN,2)=J
26385 ISIG(NCHN,3)=1
26386 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
26387 SIGH(NCHN)=HI*FACBW*HF
26388 2320 CONTINUE
26389 2330 CONTINUE
26390 ENDIF
26391
26392 ELSEIF(ISUB.LE.380) THEN
26393
26394 IF(ISUB.EQ.361) THEN
26395C...f + fbar -> W_L W_L, W_L pi_tc, pi_tc pi_tc
26396 FACA=(SH**2*BE34**2-(TH-UH)**2)
26397 ALPRHT=2.91D0*(3D0/PARP(144))
26398 HP=(1D0/12D0)*AEM*ALPRHT*CAB2*COMFAC*FACA*3D0
26399 FAR=SQRT(AEM/ALPRHT)
26400 FAO=FAR*QUPD
26401 FZR=FAR*CT2W
26402 FZO=-FAO*TANW
26403 SFAR=FAR**2
26404 SFAO=FAO**2
26405 SFZR=FZR**2
26406 SFZO=FZO**2
26407 CALL PYWIDT(23,SH,WDTP,WDTE)
26408 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
26409 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
26410 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
26411 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
26412 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
26413 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
26414 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
26415 DARHO=(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)/DETD/SH
26416 DZRHO=(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH
26417
26418 DO 2340 I=MMINA,MMAXA
26419 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2340
26420 IA=IABS(I)
26421 EI=KCHG(IABS(I),1)/3D0
26422 AI=SIGN(1D0,EI+0.1D0)
26423 VI=AI-4D0*EI*XWV
26424 VALI=0.25D0*(VI+AI)
26425 VARI=0.25D0*(VI-AI)
26426 F2L=EI*DARHO+VALI*DZRHO/SQRT(XW*XW1)
26427 F2R=EI*DARHO+VARI*DZRHO/SQRT(XW*XW1)
26428 HI=ABS(F2L)**2+ABS(F2R)**2
26429 IF(IA.LE.10) HI=HI/3D0
26430 NCHN=NCHN+1
26431 ISIG(NCHN,1)=I
26432 ISIG(NCHN,2)=-I
26433 ISIG(NCHN,3)=1
26434 IF(KFA.EQ.KFB) THEN
26435 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),1)
26436 ELSE
26437 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
26438 NCHN=NCHN+1
26439 ISIG(NCHN,1)=I
26440 ISIG(NCHN,2)=-I
26441 ISIG(NCHN,3)=2
26442 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
26443 ENDIF
26444 2340 CONTINUE
26445
26446 ELSEIF(ISUB.EQ.364) THEN
26447C...f + fbar -> gamma pi_tc, gamma pi_tc', Z pi_tc, Z pi_tc',
26448C...W pi_tc
26449 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)/SQTV*SH
26450 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)/SQTA*SH
26451
26452 ALPRHT=2.91D0*(3D0/PARP(144))
26453 HP=(1D0/24D0)*AEM**2*COMFAC*3D0
26454 FAR=SQRT(AEM/ALPRHT)
26455 FAO=FAR*QUPD
26456 FZR=FAR*CT2W
26457 FZO=-FAO*TANW
26458 SFAR=FAR**2
26459 SFAO=FAO**2
26460 SFZR=FZR**2
26461 SFZO=FZO**2
26462 CALL PYWIDT(23,SH,WDTP,WDTE)
26463 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
26464 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
26465 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
26466 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
26467 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
26468 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
26469 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
26470 DARHO=(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)/DETD/SH
26471 DZRHO=(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH
26472 DAOME=(-FAO*SFZR+FAR*FZO*FZR+FAO*SSMR*SSMZ)/DETD/SH
26473 DZOME=(-FZO*SFAR+FAR*FAO*FZR+FZO*SSMR)/DETD/SH
26474
26475 DO 2350 I=MMINA,MMAXA
26476 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2350
26477 IA=IABS(I)
26478 EI=KCHG(IABS(I),1)/3D0
26479 AI=SIGN(1D0,EI+0.1D0)
26480 VI=AI-4D0*EI*XWV
26481 VALI=0.25D0*(VI+AI)
26482 VARI=0.25D0*(VI-AI)
26483 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*VRGP
26484 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*VOGP
26485 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*VRGP
26486 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*VOGP
26487 HI=(ABS(F2L)**2+ABS(F2R)**2)*VFAC
26488 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*ARGP
26489 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*AOGP
26490 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*ARGP
26491 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*AOGP
26492 HJ=(ABS(F2L)**2+ABS(F2R)**2)*AFAC
26493 HI=HI+HJ
26494 IF(IA.LE.10) HI=HI/3D0
26495 NCHN=NCHN+1
26496 ISIG(NCHN,1)=I
26497 ISIG(NCHN,2)=-I
26498 ISIG(NCHN,3)=1
26499 IF(ISUBSV.NE.368) THEN
26500 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),2)
26501 ELSE
26502 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
26503 NCHN=NCHN+1
26504 ISIG(NCHN,1)=I
26505 ISIG(NCHN,2)=-I
26506 ISIG(NCHN,3)=2
26507 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
26508 ENDIF
26509 2350 CONTINUE
26510
26511 ELSEIF(ISUB.EQ.370) THEN
26512C...f + fbar' -> W_L Z_L, W_L pi_tc, Z_L pi_tc, pi_tc pi_tc
26513
26514 FACA=(SH**2*BE34**2-(TH-UH)**2)
26515 ALPRHT=2.91D0*(3D0/PARP(144))
26516 HP=(1D0/24D0)*AEM*ALPRHT*CAB2*COMFAC*FACA*3D0/XW
26517
26518 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
26519 CALL PYWIDT(24,SH,WDTP,WDTE)
26520 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
26521 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
26522 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
26523
26524 DETD=SSMZ*SSMR-DCMPLX(FWR**2,0D0)
26525 HP=HP*FWR**2/ABS(DETD)**2/SH**2
26526
26527 DO 2370 I=MMIN1,MMAX1
26528 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 2370
26529 IA=IABS(I)
26530 DO 2360 J=MMIN2,MMAX2
26531 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 2360
26532 JA=IABS(J)
26533 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 2360
26534 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
26535 & GOTO 2360
26536 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
26537 HI=HP
26538 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
26539 NCHN=NCHN+1
26540 ISIG(NCHN,1)=I
26541 ISIG(NCHN,2)=J
26542 ISIG(NCHN,3)=1
26543 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
26544 & WIDS(PYCOMP(KFB),2)
26545 2360 CONTINUE
26546 2370 CONTINUE
26547
26548 ELSEIF(ISUB.EQ.374) THEN
26549C...f + fbar' -> gamma pi_tc
26550 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)/SQTV*VRGP**2
26551 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)/SQTA*ARGP**2
26552
26553 ALPRHT=2.91D0*(3D0/PARP(144))
26554 HP=(1D0/48D0)*AEM**2/XW*COMFAC*3D0*(VFAC+AFAC)*SH
26555
26556 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
26557 CALL PYWIDT(24,SH,WDTP,WDTE)
26558 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
26559 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
26560 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
26561
26562 DETD=SSMZ*SSMR-DCMPLX(FWR**2,0D0)
26563 HP=HP*FWR**2/ABS(DETD)**2/SH**2
26564
26565 DO 2390 I=MMIN1,MMAX1
26566 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 2390
26567 IA=IABS(I)
26568 DO 2380 J=MMIN2,MMAX2
26569 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 2380
26570 JA=IABS(J)
26571 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 2380
26572 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
26573 & GOTO 2380
26574 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
26575 HI=HP
26576 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
26577 NCHN=NCHN+1
26578 ISIG(NCHN,1)=I
26579 ISIG(NCHN,2)=J
26580 ISIG(NCHN,3)=1
26581 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
26582 & WIDS(PYCOMP(KFB),2)
26583 2380 CONTINUE
26584 2390 CONTINUE
26585
26586 ENDIF
26587
26588 ELSEIF(ISUB.LE.400) THEN
26589
26590 IF(ISUB.EQ.391) THEN
26591C...f + fbar -> G*.
26592 KFGSTR=KFPR(ISUB,1)
26593 KCGSTR=PYCOMP(KFGSTR)
26594 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
26595 HS=SHR*WDTP(0)
26596 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26597 FACG=COMFAC*PARP(50)**2/(16D0*PARU(1))*SH*HF/
26598 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
26599 DO 2400 I=MMINA,MMAXA
26600 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2400
26601 HI=1D0
26602 IF(IABS(I).LE.10) HI=HI*FACA/3D0
26603 NCHN=NCHN+1
26604 ISIG(NCHN,1)=I
26605 ISIG(NCHN,2)=-I
26606 ISIG(NCHN,3)=1
26607 SIGH(NCHN)=FACG*HI
26608 2400 CONTINUE
26609
26610 ELSEIF(ISUB.EQ.392) THEN
26611C...g + g -> G*.
26612 KFGSTR=KFPR(ISUB,1)
26613 KCGSTR=PYCOMP(KFGSTR)
26614 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
26615 HS=SHR*WDTP(0)
26616 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26617 FACG=COMFAC*PARP(50)**2/(32D0*PARU(1))*SH*HF/
26618 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
26619 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 2410
26620 NCHN=NCHN+1
26621 ISIG(NCHN,1)=21
26622 ISIG(NCHN,2)=21
26623 ISIG(NCHN,3)=1
26624 SIGH(NCHN)=FACG
26625 2410 CONTINUE
26626
26627 ELSEIF(ISUB.EQ.393) THEN
26628C...q + qbar -> g + G*.
26629 KFGSTR=KFPR(ISUB,2)
26630 KCGSTR=PYCOMP(KFGSTR)
26631 FACG=COMFAC*PARP(50)**2*AS*SH/(72D0*PARU(1)*SQM4)*
26632 & (4D0*(TH2+UH2)/SH2+9D0*(TH+UH)/SH+(TH2/UH+UH2/TH)/SH+
26633 & 3D0*(4D0+TH/UH+UH/TH)+4D0*(SH/UH+SH/TH)+
26634 & 2D0*SH2/(TH*UH))
26635C...Propagators: as simulated in PYOFSH and as desired
26636 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
26637 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
26638 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
26639 HS=SQRT(SQM4)*WDTP(0)
26640 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26641 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
26642 FACG=FACG*HBW4C/HBW4
26643 DO 2420 I=MMINA,MMAXA
26644 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
26645 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2420
26646 NCHN=NCHN+1
26647 ISIG(NCHN,1)=I
26648 ISIG(NCHN,2)=-I
26649 ISIG(NCHN,3)=1
26650 SIGH(NCHN)=FACG
26651 2420 CONTINUE
26652
26653 ELSEIF(ISUB.EQ.394) THEN
26654C...q + g -> q + G*.
26655 KFGSTR=KFPR(ISUB,2)
26656 KCGSTR=PYCOMP(KFGSTR)
26657 FACG=-COMFAC*PARP(50)**2*AS*SH/(192D0*PARU(1)*SQM4)*
26658 & (4D0*(SH2+UH2)/(TH*SH)+9D0*(SH+UH)/SH+SH/UH+UH2/SH2+
26659 & 3D0*TH*(4D0+SH/UH+UH/SH)/SH+4D0*TH2*(1D0/UH+1D0/SH)/SH+
26660 & 2D0*TH2*TH/(UH*SH2))
26661C...Propagators: as simulated in PYOFSH and as desired
26662 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
26663 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
26664 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
26665 HS=SQRT(SQM4)*WDTP(0)
26666 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26667 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
26668 FACG=FACG*HBW4C/HBW4
26669 DO 2440 I=MMINA,MMAXA
26670 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2440
26671 DO 2430 ISDE=1,2
26672 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2430
26673 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2430
26674 NCHN=NCHN+1
26675 ISIG(NCHN,ISDE)=I
26676 ISIG(NCHN,3-ISDE)=21
26677 ISIG(NCHN,3)=1
26678 SIGH(NCHN)=FACG
26679 2430 CONTINUE
26680 2440 CONTINUE
26681
26682 ELSEIF(ISUB.EQ.395) THEN
26683C...g + g -> g + G*.
26684 KFGSTR=KFPR(ISUB,2)
26685 KCGSTR=PYCOMP(KFGSTR)
26686 FACG=COMFAC*3D0*PARP(50)**2*AS*SH/(32D0*PARU(1)*SQM4)*
26687 & ((TH2+TH*UH+UH2)**2/(SH2*TH*UH)+2D0*(TH2/UH+UH2/TH)/SH+
26688 & 3D0*(TH/UH+UH/TH)+2D0*(SH/UH+SH/TH)+SH2/(TH*UH))
26689C...Propagators: as simulated in PYOFSH and as desired
26690 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
26691 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
26692 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
26693 HS=SQRT(SQM4)*WDTP(0)
26694 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26695 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
26696 FACG=FACG*HBW4C/HBW4
26697 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
26698 NCHN=NCHN+1
26699 ISIG(NCHN,1)=21
26700 ISIG(NCHN,2)=21
26701 ISIG(NCHN,3)=1
26702 SIGH(NCHN)=FACG
26703 ENDIF
26704
26705 ENDIF
26706 ENDIF
26707
26708C...Multiply with parton distributions
26709 IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
26710 DO 2450 ICHN=1,NCHN
26711 IF(MINT(45).GE.2) THEN
26712 KFL1=ISIG(ICHN,1)
26713 SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
26714 ENDIF
26715 IF(MINT(46).GE.2) THEN
26716 KFL2=ISIG(ICHN,2)
26717 SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
26718 ENDIF
26719 SIGS=SIGS+SIGH(ICHN)
26720 2450 CONTINUE
26721 ENDIF
26722
26723 RETURN
26724 END
26725
26726C*********************************************************************
26727
26728C...PYPDFU
26729C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon
26730C...parton distributions according to a few different parametrizations.
26731C...Note that what is coded is x times the probability distribution,
26732C...i.e. xq(x,Q2) etc.
26733
26734 SUBROUTINE PYPDFU(KF,X,Q2,XPQ)
26735
26736C...Double precision and integer declarations.
26737 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26738 IMPLICIT INTEGER(I-N)
26739 INTEGER PYK,PYCHGE,PYCOMP
26740C...Commonblocks.
26741 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
26742 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
26743 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
26744 COMMON/PYINT1/MINT(400),VINT(400)
26745 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
26746 &XPDIR(-6:6)
26747 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/
26748C...Local arrays.
26749 DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
26750 &XPPI(-6:6),XPPR(-6:6)
26751
26752C...Interface to PDFLIB.
26753 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
26754 SAVE /W50513/
26755 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
26756 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
26757 CHARACTER*20 PARM(20)
26758 DATA VALUE/20*0D0/,PARM/20*' '/
26759
26760C...Data related to Schuler-Sjostrand photon distributions.
26761 DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
26762
26763C...Reset parton distributions.
26764 MINT(92)=0
26765 DO 100 KFL=-25,25
26766 XPQ(KFL)=0D0
26767 100 CONTINUE
26768
26769C...Check x and particle species.
26770 IF(X.LE.0D0.OR.X.GE.1D0) THEN
26771 WRITE(MSTU(11),5000) X
26772 RETURN
26773 ENDIF
26774 KFA=IABS(KF)
26775 IF(KFA.NE.11.AND.KFA.NE.13.AND.KFA.NE.15.AND.KFA.NE.22.AND.
26776 &KFA.NE.211.AND.KFA.NE.2112.AND.KFA.NE.2212.AND.KFA.NE.3122.AND.
26777 &KFA.NE.3112.AND.KFA.NE.3212.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.
26778 &KFA.NE.3322.AND.KFA.NE.3334.AND.KFA.NE.111.AND.KFA.NE.321.AND.
26779 &KFA.NE.310.AND.KFA.NE.130) THEN
26780 WRITE(MSTU(11),5100) KF
26781 RETURN
26782 ENDIF
26783
26784C...Electron (or muon or tau) parton distribution call.
26785 IF(KFA.EQ.11.OR.KFA.EQ.13.OR.KFA.EQ.15) THEN
26786 CALL PYPDEL(KFA,X,Q2,XPEL)
26787 DO 110 KFL=-25,25
26788 XPQ(KFL)=XPEL(KFL)
26789 110 CONTINUE
26790
26791C...Photon parton distribution call (VDM+anomalous).
26792 ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
26793 IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
26794 CALL PYPDGA(X,Q2,XPGA)
26795 DO 120 KFL=-6,6
26796 XPQ(KFL)=XPGA(KFL)
26797 120 CONTINUE
26798 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
26799 Q2MX=Q2
26800 P2MX=0.36D0
26801 IF(MSTP(55).GE.7) P2MX=4.0D0
26802 IF(MSTP(57).EQ.0) Q2MX=P2MX
26803 P2=0D0
26804 IF(VINT(120).LT.0D0) P2=VINT(120)**2
26805 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
26806 DO 130 KFL=-6,6
26807 XPQ(KFL)=XPGA(KFL)
26808 130 CONTINUE
26809 VINT(231)=P2MX
26810 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
26811 Q2MX=Q2
26812 P2MX=0.36D0
26813 IF(MSTP(55).GE.11) P2MX=4.0D0
26814 IF(MSTP(57).EQ.0) Q2MX=P2MX
26815 P2=0D0
26816 IF(VINT(120).LT.0D0) P2=VINT(120)**2
26817 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
26818 DO 140 KFL=-6,6
26819 XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
26820 140 CONTINUE
26821 VINT(231)=P2MX
26822 ELSEIF(MSTP(56).EQ.2) THEN
26823C...Call PDFLIB parton distributions.
26824 PARM(1)='NPTYPE'
26825 VALUE(1)=3
26826 PARM(2)='NGROUP'
26827 VALUE(2)=MSTP(55)/1000
26828 PARM(3)='NSET'
26829 VALUE(3)=MOD(MSTP(55),1000)
26830 IF(MINT(93).NE.3000000+MSTP(55)) THEN
26831 CALL PDFSET(PARM,VALUE)
26832 MINT(93)=3000000+MSTP(55)
26833 ENDIF
26834 XX=X
26835 QQ2=MAX(0D0,Q2MIN,Q2)
26836 IF(MSTP(57).EQ.0) QQ2=Q2MIN
26837 P2=0D0
26838 IF(VINT(120).LT.0D0) P2=VINT(120)**2
26839 IP2=MSTP(60)
26840 IF(MSTP(55).EQ.5004) THEN
26841 IF(5D0*P2.LT.QQ2.AND.
26842 & QQ2.GT.0.6D0.AND.QQ2.LT.5D4.AND.
26843 & P2.GE.0D0.AND.P2.LT.10D0.AND.
26844 & XX.GT.1D-4.AND.XX.LT.1D0) THEN
26845 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
26846 & BOT,TOP,GLU)
26847 ELSE
26848 UPV=0D0
26849 DNV=0D0
26850 USEA=0D0
26851 DSEA=0D0
26852 STR=0D0
26853 CHM=0D0
26854 BOT=0D0
26855 TOP=0D0
26856 GLU=0D0
26857 ENDIF
26858 ELSE
26859 IF(P2.LT.QQ2) THEN
26860 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
26861 & BOT,TOP,GLU)
26862 ELSE
26863 UPV=0D0
26864 DNV=0D0
26865 USEA=0D0
26866 DSEA=0D0
26867 STR=0D0
26868 CHM=0D0
26869 BOT=0D0
26870 TOP=0D0
26871 GLU=0D0
26872 ENDIF
26873 ENDIF
26874 VINT(231)=Q2MIN
26875 XPQ(0)=GLU
26876 XPQ(1)=DNV
26877 XPQ(-1)=DNV
26878 XPQ(2)=UPV
26879 XPQ(-2)=UPV
26880 XPQ(3)=STR
26881 XPQ(-3)=STR
26882 XPQ(4)=CHM
26883 XPQ(-4)=CHM
26884 XPQ(5)=BOT
26885 XPQ(-5)=BOT
26886 XPQ(6)=TOP
26887 XPQ(-6)=TOP
26888 ELSE
26889 WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
26890 ENDIF
26891
26892C...Pion/gammaVDM parton distribution call.
26893 ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.KFA.EQ.321.OR.KFA.EQ.130.OR.
26894 &KFA.EQ.310.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
26895 IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
26896 & MSTP(55).LE.12) THEN
26897 ISET=1+MOD(MSTP(55)-1,4)
26898 Q2MX=Q2
26899 P2MX=0.36D0
26900 IF(ISET.GE.3) P2MX=4.0D0
26901 IF(MSTP(57).EQ.0) Q2MX=P2MX
26902 P2=0D0
26903 IF(VINT(120).LT.0D0) P2=VINT(120)**2
26904 CALL PYGGAM(ISET,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
26905 DO 150 KFL=-6,6
26906 XPQ(KFL)=XPVMD(KFL)
26907 150 CONTINUE
26908 VINT(231)=P2MX
26909 ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
26910 CALL PYPDPI(X,Q2,XPPI)
26911 DO 160 KFL=-6,6
26912 XPQ(KFL)=XPPI(KFL)
26913 160 CONTINUE
26914 ELSEIF(MSTP(54).EQ.2) THEN
26915C...Call PDFLIB parton distributions.
26916 PARM(1)='NPTYPE'
26917 VALUE(1)=2
26918 PARM(2)='NGROUP'
26919 VALUE(2)=MSTP(53)/1000
26920 PARM(3)='NSET'
26921 VALUE(3)=MOD(MSTP(53),1000)
26922 IF(MINT(93).NE.2000000+MSTP(53)) THEN
26923 CALL PDFSET(PARM,VALUE)
26924 MINT(93)=2000000+MSTP(53)
26925 ENDIF
26926 XX=X
26927 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
26928 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
26929 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
26930 VINT(231)=Q2MIN
26931 XPQ(0)=GLU
26932 XPQ(1)=DSEA
26933 XPQ(-1)=UPV+DSEA
26934 XPQ(2)=UPV+USEA
26935 XPQ(-2)=USEA
26936 XPQ(3)=STR
26937 XPQ(-3)=STR
26938 XPQ(4)=CHM
26939 XPQ(-4)=CHM
26940 XPQ(5)=BOT
26941 XPQ(-5)=BOT
26942 XPQ(6)=TOP
26943 XPQ(-6)=TOP
26944 ELSE
26945 WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
26946 ENDIF
26947
26948C...Anomalous photon parton distribution call.
26949 ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
26950 Q2MX=Q2
26951 P2MX=PARP(15)**2
26952 IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
26953 IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
26954 IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
26955 IF(MSTP(57).EQ.0) Q2MX=P2MX
26956 P2=0D0
26957 IF(VINT(120).LT.0D0) P2=VINT(120)**2
26958 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
26959 DO 170 KFL=-6,6
26960 XPQ(KFL)=XPANL(KFL)+XPANH(KFL)
26961 170 CONTINUE
26962 VINT(231)=P2MX
26963 ELSEIF(MSTP(56).EQ.1) THEN
26964 IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
26965 IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
26966 IF(MSTP(57).EQ.0) Q2MX=P2MX
26967 P2=0D0
26968 IF(VINT(120).LT.0D0) P2=VINT(120)**2
26969 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
26970 DO 180 KFL=-6,6
26971 XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
26972 180 CONTINUE
26973 VINT(231)=P2MX
26974 ELSEIF(MSTP(56).EQ.2) THEN
26975 IF(MSTP(57).EQ.0) Q2MX=P2MX
26976 CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
26977 DO 190 KFL=-6,6
26978 XPQ(KFL)=XPGA(KFL)
26979 190 CONTINUE
26980 VINT(231)=P2MX
26981 ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
26982 IF(MSTP(57).EQ.0) Q2MX=P2MX
26983 CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
26984 DO 200 KFL=-6,6
26985 XPQ(KFL)=XPGA(KFL)
26986 200 CONTINUE
26987 VINT(231)=P2MX
26988 ELSE
26989 210 RKF=11D0*PYR(0)
26990 KFR=1
26991 IF(RKF.GT.1D0) KFR=2
26992 IF(RKF.GT.5D0) KFR=3
26993 IF(RKF.GT.6D0) KFR=4
26994 IF(RKF.GT.10D0) KFR=5
26995 IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 210
26996 IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 210
26997 IF(MSTP(57).EQ.0) Q2MX=P2MX
26998 CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
26999 DO 220 KFL=-6,6
27000 XPQ(KFL)=XPGA(KFL)
27001 220 CONTINUE
27002 VINT(231)=P2MX
27003 ENDIF
27004
27005C...Proton parton distribution call.
27006 ELSE
27007 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
27008 CALL PYPDPR(X,Q2,XPPR)
27009 DO 230 KFL=-6,6
27010 XPQ(KFL)=XPPR(KFL)
27011 230 CONTINUE
27012 ELSEIF(MSTP(52).EQ.2) THEN
27013C...Call PDFLIB parton distributions.
27014 PARM(1)='NPTYPE'
27015 VALUE(1)=1
27016 PARM(2)='NGROUP'
27017 VALUE(2)=MSTP(51)/1000
27018 PARM(3)='NSET'
27019 VALUE(3)=MOD(MSTP(51),1000)
27020 IF(MINT(93).NE.1000000+MSTP(51)) THEN
27021C .... ALICE
27022 CALL PDFSET_ALICE(PARM,VALUE)
27023 MINT(93)=1000000+MSTP(51)
27024 ENDIF
27025 XX=X
27026 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
27027 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
27028C .... ALICE
27029 CALL STRUCTM_ALICE
27030 + (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
27031 VINT(231)=Q2MIN
27032 XPQ(0)=GLU
27033 XPQ(1)=DNV+DSEA
27034 XPQ(-1)=DSEA
27035 XPQ(2)=UPV+USEA
27036 XPQ(-2)=USEA
27037 XPQ(3)=STR
27038 XPQ(-3)=STR
27039 XPQ(4)=CHM
27040 XPQ(-4)=CHM
27041 XPQ(5)=BOT
27042 XPQ(-5)=BOT
27043 XPQ(6)=TOP
27044 XPQ(-6)=TOP
27045 ELSE
27046 WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
27047 ENDIF
27048 ENDIF
27049
27050C...Isospin average for pi0/gammaVDM.
27051 IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
27052 IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
27053 XPV=XPQ(2)-XPQ(1)
27054 XPQ(2)=XPQ(1)
27055 XPQ(-2)=XPQ(-1)
27056 ELSE
27057 XPS=0.5D0*(XPQ(1)+XPQ(-2))
27058 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
27059 XPQ(2)=XPS
27060 XPQ(-1)=XPS
27061 ENDIF
27062 IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
27063 XPQ(1)=XPQ(1)+0.2D0*XPV
27064 XPQ(-1)=XPQ(-1)+0.2D0*XPV
27065 XPQ(2)=XPQ(2)+0.8D0*XPV
27066 XPQ(-2)=XPQ(-2)+0.8D0*XPV
27067 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
27068 XPQ(3)=XPQ(3)+XPV
27069 XPQ(-3)=XPQ(-3)+XPV
27070 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
27071 XPQ(4)=XPQ(4)+XPV
27072 XPQ(-4)=XPQ(-4)+XPV
27073 IF(MSTP(55).GE.9) THEN
27074 DO 240 KFL=-6,6
27075 XPQ(KFL)=0D0
27076 240 CONTINUE
27077 ENDIF
27078 ELSE
27079 XPQ(1)=XPQ(1)+0.5D0*XPV
27080 XPQ(-1)=XPQ(-1)+0.5D0*XPV
27081 XPQ(2)=XPQ(2)+0.5D0*XPV
27082 XPQ(-2)=XPQ(-2)+0.5D0*XPV
27083 ENDIF
27084
27085C...Rescale for gammaVDM by effective gamma -> rho coupling.
27086C+++Do not rescale?
27087 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND..NOT.(MSTP(56).EQ.1
27088 & .AND.MSTP(55).GE.5.AND.MSTP(55).LE.12)) THEN
27089 DO 250 KFL=-6,6
27090 XPQ(KFL)=VINT(281)*XPQ(KFL)
27091 250 CONTINUE
27092 VINT(232)=VINT(281)*XPV
27093 ENDIF
27094
27095C...Simple recipes for kaons.
27096 ELSEIF(KFA.EQ.321) THEN
27097 XPQ(-3)=XPQ(-3)+XPQ(-1)-XPQ(1)
27098 XPQ(-1)=XPQ(1)
27099 ELSEIF(KFA.EQ.130.OR.KFA.EQ.310) THEN
27100 XPS=0.5D0*(XPQ(1)+XPQ(-2))
27101 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
27102 XPQ(2)=XPS
27103 XPQ(-1)=XPS
27104 XPQ(1)=XPQ(1)+0.5D0*XPV
27105 XPQ(-1)=XPQ(-1)+0.5D0*XPV
27106 XPQ(3)=XPQ(3)+0.5D0*XPV
27107 XPQ(-3)=XPQ(-3)+0.5D0*XPV
27108
27109C...Isospin conjugation for neutron.
27110 ELSEIF(KFA.EQ.2112) THEN
27111 XPS=XPQ(1)
27112 XPQ(1)=XPQ(2)
27113 XPQ(2)=XPS
27114 XPS=XPQ(-1)
27115 XPQ(-1)=XPQ(-2)
27116 XPQ(-2)=XPS
27117
27118C...Simple recipes for hyperon (average valence parton distribution).
27119 ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
27120 & .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
27121 XPVAL=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
27122 XPSEA=0.5D0*(XPQ(-1)+XPQ(-2))
27123 XPQ(1)=XPSEA
27124 XPQ(2)=XPSEA
27125 XPQ(-1)=XPSEA
27126 XPQ(-2)=XPSEA
27127 XPQ(KFA/1000)=XPQ(KFA/1000)+XPVAL
27128 XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPVAL
27129 XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPVAL
27130 ENDIF
27131
27132C...Charge conjugation for antiparticle.
27133 IF(KF.LT.0) THEN
27134 DO 260 KFL=1,25
27135 IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 260
27136 XPS=XPQ(KFL)
27137 XPQ(KFL)=XPQ(-KFL)
27138 XPQ(-KFL)=XPS
27139 260 CONTINUE
27140 ENDIF
27141
27142C...Allow gluon also in position 21.
27143 XPQ(21)=XPQ(0)
27144
27145C...Check positivity and reset above maximum allowed flavour.
27146 DO 270 KFL=-25,25
27147 XPQ(KFL)=MAX(0D0,XPQ(KFL))
27148 IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0
27149 270 CONTINUE
27150
27151C...Formats for error printouts.
27152 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
27153 5100 FORMAT(' Error: illegal particle code for parton distribution;',
27154 &' KF =',I5)
27155 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
27156 &3I5)
27157
27158 RETURN
27159 END
27160
27161C*********************************************************************
27162
27163C...PYPDFL
27164C...Gives proton parton distribution at small x and/or Q^2 according to
27165C...correct limiting behaviour.
27166
27167 SUBROUTINE PYPDFL(KF,X,Q2,XPQ)
27168
27169C...Double precision and integer declarations.
27170 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27171 IMPLICIT INTEGER(I-N)
27172 INTEGER PYK,PYCHGE,PYCOMP
27173C...Commonblocks.
27174 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27175 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27176 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27177 COMMON/PYINT1/MINT(400),VINT(400)
27178 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
27179C...Local arrays.
27180 DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3)
27181 DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/
27182
27183C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
27184 MINT(92)=0
27185 KFA=IABS(KF)
27186 IACC=0
27187 IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1
27188 IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1
27189 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1
27190 IF(IACC.EQ.0) THEN
27191 CALL PYPDFU(KF,X,Q2,XPQ)
27192 RETURN
27193 ENDIF
27194
27195C...Reset. Check x.
27196 DO 100 KFL=-25,25
27197 XPQ(KFL)=0D0
27198 100 CONTINUE
27199 IF(X.LE.0D0.OR.X.GE.1D0) THEN
27200 WRITE(MSTU(11),5000) X
27201 RETURN
27202 ENDIF
27203
27204C...Define valence content.
27205 KFC=KF
27206 NV1=2
27207 NV2=1
27208 IF(KF.EQ.2212) THEN
27209 KFV1=2
27210 KFV2=1
27211 ELSEIF(KF.EQ.-2212) THEN
27212 KFV1=-2
27213 KFV2=-1
27214 ELSEIF(KF.EQ.2112) THEN
27215 KFV1=1
27216 KFV2=2
27217 ELSEIF(KF.EQ.-2112) THEN
27218 KFV1=-1
27219 KFV2=-2
27220 ELSEIF(KF.EQ.211) THEN
27221 NV1=1
27222 KFV1=2
27223 KFV2=-1
27224 ELSEIF(KF.EQ.-211) THEN
27225 NV1=1
27226 KFV1=-2
27227 KFV2=1
27228 ELSEIF(MINT(105).LE.223) THEN
27229 KFV1=1
27230 WTV1=0.2D0
27231 KFV2=2
27232 WTV2=0.8D0
27233 ELSEIF(MINT(105).EQ.333) THEN
27234 KFV1=3
27235 WTV1=1.0D0
27236 KFV2=1
27237 WTV2=0.0D0
27238 ELSEIF(MINT(105).EQ.443) THEN
27239 KFV1=4
27240 WTV1=1.0D0
27241 KFV2=1
27242 WTV2=0.0D0
27243 ENDIF
27244
27245C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
27246 CALL PYPDFU(KFC,X,Q2,XPA)
27247 Q2MN=MAX(3D0,VINT(231))
27248 Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X))))
27249 XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0
27250
27251C...Large Q2 and large x: naive call is enough.
27252 IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN
27253 DO 110 KFL=-25,25
27254 XPQ(KFL)=XPA(KFL)
27255 110 CONTINUE
27256 MINT(92)=1
27257
27258C...Small Q2 and large x: dampen boundary value.
27259 ELSEIF(X.GT.XMN) THEN
27260
27261C...Evaluate at boundary and define dampening factors.
27262 CALL PYPDFU(KFC,X,Q2MN,XPA)
27263 FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN))
27264 FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0
27265
27266C...Separate valence and sea parts of parton distribution.
27267 IF(KFA.NE.22) THEN
27268 XFV1=XPA(KFV1)-XPA(-KFV1)
27269 XPA(KFV1)=XPA(-KFV1)
27270 XFV2=XPA(KFV2)-XPA(-KFV2)
27271 XPA(KFV2)=XPA(-KFV2)
27272 ELSE
27273 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
27274 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
27275 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
27276 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
27277 ENDIF
27278
27279C...Dampen valence and sea separately. Put back together.
27280 DO 120 KFL=-25,25
27281 XPQ(KFL)=FS*XPA(KFL)
27282 120 CONTINUE
27283 IF(KFA.NE.22) THEN
27284 XPQ(KFV1)=XPQ(KFV1)+FV*XFV1
27285 XPQ(KFV2)=XPQ(KFV2)+FV*XFV2
27286 ELSE
27287 XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232)
27288 XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232)
27289 XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232)
27290 XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232)
27291 ENDIF
27292 MINT(92)=2
27293
27294C...Large Q2 and small x: interpolate behaviour.
27295 ELSEIF(Q2.GT.Q2MN) THEN
27296
27297C...Evaluate at extremes and define coefficients for interpolation.
27298 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
27299 VI232A=VINT(232)
27300 CALL PYPDFU(KFC,X,Q2B,XPB)
27301 VI232B=VINT(232)
27302 FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN)
27303 FVA=(X/XMN)**0.45D0*FLA
27304 FSA=(X/XMN)**(-0.08D0)*FLA
27305 FB=1D0-FLA
27306
27307C...Separate valence and sea parts of parton distribution.
27308 IF(KFA.NE.22) THEN
27309 XFVA1=XPA(KFV1)-XPA(-KFV1)
27310 XPA(KFV1)=XPA(-KFV1)
27311 XFVA2=XPA(KFV2)-XPA(-KFV2)
27312 XPA(KFV2)=XPA(-KFV2)
27313 XFVB1=XPB(KFV1)-XPB(-KFV1)
27314 XPB(KFV1)=XPB(-KFV1)
27315 XFVB2=XPB(KFV2)-XPB(-KFV2)
27316 XPB(KFV2)=XPB(-KFV2)
27317 ELSE
27318 XPA(KFV1)=XPA(KFV1)-WTV1*VI232A
27319 XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A
27320 XPA(KFV2)=XPA(KFV2)-WTV2*VI232A
27321 XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A
27322 XPB(KFV1)=XPB(KFV1)-WTV1*VI232B
27323 XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B
27324 XPB(KFV2)=XPB(KFV2)-WTV2*VI232B
27325 XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B
27326 ENDIF
27327
27328C...Interpolate for valence and sea. Put back together.
27329 DO 130 KFL=-25,25
27330 XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL)
27331 130 CONTINUE
27332 IF(KFA.NE.22) THEN
27333 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1)
27334 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2)
27335 ELSE
27336 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
27337 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
27338 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
27339 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
27340 ENDIF
27341 MINT(92)=3
27342
27343C...Small Q2 and small x: dampen boundary value and add term.
27344 ELSE
27345
27346C...Evaluate at boundary and define dampening factors.
27347 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
27348 FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN)
27349 FA=1D0-FB
27350 FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0
27351 FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0
27352 FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0
27353 FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0
27354 FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0
27355 FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0
27356
27357C...Separate valence and sea parts of parton distribution.
27358 IF(KFA.NE.22) THEN
27359 XFV1=XPA(KFV1)-XPA(-KFV1)
27360 XPA(KFV1)=XPA(-KFV1)
27361 XFV2=XPA(KFV2)-XPA(-KFV2)
27362 XPA(KFV2)=XPA(-KFV2)
27363 ELSE
27364 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
27365 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
27366 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
27367 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
27368 ENDIF
27369
27370C...Dampen valence and sea separately. Add constant terms.
27371C...Put back together.
27372 DO 140 KFL=-25,25
27373 XPQ(KFL)=FSA*XPA(KFL)
27374 140 CONTINUE
27375 IF(KFA.NE.22) THEN
27376 DO 150 KFL=-3,3
27377 XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL)
27378 150 CONTINUE
27379 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1)
27380 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2)
27381 ELSE
27382 DO 160 KFL=-3,3
27383 XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL)
27384 160 CONTINUE
27385 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
27386 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
27387 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
27388 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
27389 ENDIF
27390 XPQ(21)=XPQ(0)
27391 MINT(92)=4
27392 ENDIF
27393
27394C...Format for error printout.
27395 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
27396
27397 RETURN
27398 END
27399
27400C*********************************************************************
27401
27402C...PYPDEL
27403C...Gives electron (or muon, or tau) parton distribution.
27404
27405 SUBROUTINE PYPDEL(KFA,X,Q2,XPEL)
27406
27407C...Double precision and integer declarations.
27408 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27409 IMPLICIT INTEGER(I-N)
27410 INTEGER PYK,PYCHGE,PYCOMP
27411C...Commonblocks.
27412 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27413 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27414 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27415 COMMON/PYINT1/MINT(400),VINT(400)
27416 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
27417C...Local arrays.
27418 DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6)
27419
27420C...Interface to PDFLIB.
27421 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
27422 SAVE /W50513/
27423 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
27424 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
27425 CHARACTER*20 PARM(20)
27426 DATA VALUE/20*0D0/,PARM/20*' '/
27427
27428C...Some common constants.
27429 DO 100 KFL=-25,25
27430 XPEL(KFL)=0D0
27431 100 CONTINUE
27432 AEM=PARU(101)
27433 PME=PMAS(11,1)
27434 IF(KFA.EQ.13) PME=PMAS(13,1)
27435 IF(KFA.EQ.15) PME=PMAS(15,1)
27436 XL=LOG(MAX(1D-10,X))
27437 X1L=LOG(MAX(1D-10,1D0-X))
27438 HLE=LOG(MAX(3D0,Q2/PME**2))
27439 HBE2=(AEM/PARU(1))*(HLE-1D0)
27440
27441C...Electron inside electron, see R. Kleiss et al., in Z physics at
27442C...LEP 1, CERN 89-08, p. 34
27443 IF(MSTP(59).LE.1) THEN
27444 HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2*
27445 & (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0)
27446 HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))-
27447 & 0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)-
27448 & 4D0*XL/(1D0-X)-5D0-X)
27449 ELSE
27450 HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/
27451 & PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*
27452 & (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X)
27453 ENDIF
27454C...Zero distribution for very large x and rescale it for intermediate.
27455 IF(X.GT.1D0-1D-10) THEN
27456 HEE=0D0
27457 ELSEIF(X.GT.1D0-1D-7) THEN
27458 HEE=HEE*1000D0**HBE2/(1000D0**HBE2-1D0)
27459 ENDIF
27460 XPEL(KFA)=X*HEE
27461
27462C...Photon and (transverse) W- inside electron.
27463 AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2)
27464 IF(MSTP(13).LE.1) THEN
27465 HLG=HLE
27466 ELSE
27467 HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2))
27468 ENDIF
27469 XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2)
27470 HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102))
27471 XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2)
27472
27473C...Electron or positron inside photon inside electron.
27474 IF(KFA.EQ.11.AND.MSTP(12).EQ.1) THEN
27475 XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+
27476 & 2D0*X*(1D0+X)*XL)
27477 XPEL(11)=XPEL(11)+XFSEA
27478 XPEL(-11)=XFSEA
27479
27480C...Initialize PDFLIB photon parton distributions.
27481 IF(MSTP(56).EQ.2) THEN
27482 PARM(1)='NPTYPE'
27483 VALUE(1)=3
27484 PARM(2)='NGROUP'
27485 VALUE(2)=MSTP(55)/1000
27486 PARM(3)='NSET'
27487 VALUE(3)=MOD(MSTP(55),1000)
27488 IF(MINT(93).NE.3000000+MSTP(55)) THEN
27489 CALL PDFSET(PARM,VALUE)
27490 MINT(93)=3000000+MSTP(55)
27491 ENDIF
27492 ENDIF
27493
27494C...Quarks and gluons inside photon inside electron:
27495C...numerical convolution required.
27496 DO 110 KFL=0,6
27497 SXP(KFL)=0D0
27498 110 CONTINUE
27499 SUMXPP=0D0
27500 ITER=-1
27501 120 ITER=ITER+1
27502 SUMXP=SUMXPP
27503 NSTP=2**(ITER-1)
27504 IF(ITER.EQ.0) NSTP=2
27505 DO 130 KFL=0,6
27506 SXP(KFL)=0.5D0*SXP(KFL)
27507 130 CONTINUE
27508 WTSTP=0.5D0/NSTP
27509 IF(ITER.EQ.0) WTSTP=0.5D0
27510C...Pick grid of x_{gamma} values logarithmically even.
27511 DO 150 ISTP=1,NSTP
27512 IF(ITER.EQ.0) THEN
27513 XLE=XL*(ISTP-1)
27514 ELSE
27515 XLE=XL*(ISTP-0.5D0)/NSTP
27516 ENDIF
27517 XE=MIN(1D0-1D-10,EXP(XLE))
27518 XG=MIN(1D0-1D-10,X/XE)
27519C...Evaluate photon inside electron parton distribution for convolution.
27520 XPGP=1D0+(1D0-XE)**2
27521 IF(MSTP(13).LE.1) THEN
27522 XPGP=XPGP*HLE
27523 ELSE
27524 XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2))
27525 ENDIF
27526C...Evaluate photon parton distributions for convolution.
27527 IF(MSTP(56).EQ.1) THEN
27528 CALL PYPDGA(XG,Q2,XPGA)
27529 DO 140 KFL=0,5
27530 SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL)
27531 140 CONTINUE
27532 ELSEIF(MSTP(56).EQ.2) THEN
27533C...Call PDFLIB parton distributions.
27534 XX=XG
27535 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
27536 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
27537 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
27538 SXP(0)=SXP(0)+WTSTP*XPGP*GLU
27539 SXP(1)=SXP(1)+WTSTP*XPGP*DNV
27540 SXP(2)=SXP(2)+WTSTP*XPGP*UPV
27541 SXP(3)=SXP(3)+WTSTP*XPGP*STR
27542 SXP(4)=SXP(4)+WTSTP*XPGP*CHM
27543 SXP(5)=SXP(5)+WTSTP*XPGP*BOT
27544 SXP(6)=SXP(6)+WTSTP*XPGP*TOP
27545 ENDIF
27546 150 CONTINUE
27547 SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2)
27548 IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT.
27549 & PARP(14)*(SUMXPP+SUMXP))) GOTO 120
27550
27551C...Put convolution into output arrays.
27552 FCONV=AEMP*(-XL)
27553 XPEL(0)=FCONV*SXP(0)
27554 DO 160 KFL=1,6
27555 XPEL(KFL)=FCONV*SXP(KFL)
27556 XPEL(-KFL)=XPEL(KFL)
27557 160 CONTINUE
27558 ENDIF
27559
27560 RETURN
27561 END
27562
27563C*********************************************************************
27564
27565C...PYPDGA
27566C...Gives photon parton distribution.
27567
27568 SUBROUTINE PYPDGA(X,Q2,XPGA)
27569
27570C...Double precision and integer declarations.
27571 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27572 IMPLICIT INTEGER(I-N)
27573 INTEGER PYK,PYCHGE,PYCOMP
27574C...Commonblocks.
27575 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27576 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27577 COMMON/PYINT1/MINT(400),VINT(400)
27578 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
27579C...Local arrays.
27580 DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3),
27581 &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3),
27582 &DGCS(4,3),DGDS(4,3),DGES(4,3)
27583
27584C...The following data lines are coefficients needed in the
27585C...Drees and Grassie photon parton distribution parametrization.
27586 DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0,
27587 &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/
27588 DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0,
27589 &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/
27590 DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0,
27591 &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/
27592 DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0,
27593 &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/
27594 DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0,
27595 &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/
27596 DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1,
27597 &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/
27598 DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0,
27599 &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/
27600 DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0,
27601 &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/
27602 DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0,
27603 &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/
27604 DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0,
27605 &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/
27606 DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0,
27607 &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/
27608 DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0,
27609 &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/
27610 DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0,
27611 &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/
27612
27613C...Photon parton distribution from Drees and Grassie.
27614C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
27615 DO 100 KFL=-6,6
27616 XPGA(KFL)=0D0
27617 100 CONTINUE
27618 VINT(231)=1D0
27619 IF(MSTP(57).LE.0) THEN
27620 T=LOG(1D0/0.16D0)
27621 ELSE
27622 T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0)
27623 ENDIF
27624 X1=1D0-X
27625 NF=3
27626 IF(Q2.GT.25D0) NF=4
27627 IF(Q2.GT.300D0) NF=5
27628 NFE=NF-2
27629 AEM=PARU(101)
27630
27631C...Evaluate gluon content.
27632 DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE))
27633 DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE))
27634 DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE))
27635 XPGL=DGA*X**DGB*X1**DGC
27636
27637C...Evaluate up- and down-type quark content.
27638 DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE))
27639 DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE))
27640 DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE))
27641 DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE))
27642 DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE))
27643 XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
27644 DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE))
27645 DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE))
27646 DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE))
27647 DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE))
27648 DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE))
27649 DGF=9D0
27650 IF(NF.EQ.4) DGF=10D0
27651 IF(NF.EQ.5) DGF=55D0/6D0
27652 XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
27653 IF(NF.LE.3) THEN
27654 XPQU=(XPQS+9D0*XPQN)/6D0
27655 XPQD=(XPQS-4.5D0*XPQN)/6D0
27656 ELSEIF(NF.EQ.4) THEN
27657 XPQU=(XPQS+6D0*XPQN)/8D0
27658 XPQD=(XPQS-6D0*XPQN)/8D0
27659 ELSE
27660 XPQU=(XPQS+7.5D0*XPQN)/10D0
27661 XPQD=(XPQS-5D0*XPQN)/10D0
27662 ENDIF
27663
27664C...Put into output arrays.
27665 XPGA(0)=AEM*XPGL
27666 XPGA(1)=AEM*XPQD
27667 XPGA(2)=AEM*XPQU
27668 XPGA(3)=AEM*XPQD
27669 IF(NF.GE.4) XPGA(4)=AEM*XPQU
27670 IF(NF.GE.5) XPGA(5)=AEM*XPQD
27671 DO 110 KFL=1,6
27672 XPGA(-KFL)=XPGA(KFL)
27673 110 CONTINUE
27674
27675 RETURN
27676 END
27677
27678C*********************************************************************
27679
27680C...PYGGAM
27681C...Constructs the F2 and parton distributions of the photon
27682C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
27683C...For F2, c and b are included by the Bethe-Heitler formula;
27684C...in the 'MSbar' scheme additionally a Cgamma term is added.
27685C...Contains the SaS sets 1D, 1M, 2D and 2M.
27686C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
27687
27688 SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
27689
27690C...Double precision and integer declarations.
27691 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27692 IMPLICIT INTEGER(I-N)
27693 INTEGER PYK,PYCHGE,PYCOMP
27694C...Commonblocks.
27695 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
27696 &XPDIR(-6:6)
27697 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
27698 SAVE /PYINT8/,/PYINT9/
27699C...Local arrays.
27700 DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6)
27701C...Charm and bottom masses (low to compensate for J/psi etc.).
27702 DATA PMC/1.3D0/, PMB/4.6D0/
27703C...alpha_em and alpha_em/(2*pi).
27704 DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/
27705C...Lambda value for 4 flavours.
27706 DATA ALAM/0.20D0/
27707C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
27708 DATA FRACU/0.8D0/
27709C...VMD couplings f_V**2/(4*pi).
27710 DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/
27711C...Masses for rho (=omega) and phi.
27712 DATA PMRHO/0.770D0/, PMPHI/1.020D0/
27713C...Number of points in integration for IP2=1.
27714 DATA NSTEP/100/
27715
27716C...Reset output.
27717 F2GM=0D0
27718 DO 100 KFL=-6,6
27719 XPDFGM(KFL)=0D0
27720 XPVMD(KFL)=0D0
27721 XPANL(KFL)=0D0
27722 XPANH(KFL)=0D0
27723 XPBEH(KFL)=0D0
27724 XPDIR(KFL)=0D0
27725 VXPVMD(KFL)=0D0
27726 VXPANL(KFL)=0D0
27727 VXPANH(KFL)=0D0
27728 VXPDGM(KFL)=0D0
27729 100 CONTINUE
27730
27731C...Set Q0 cut-off parameter as function of set used.
27732 IF(ISET.LE.2) THEN
27733 Q0=0.6D0
27734 ELSE
27735 Q0=2D0
27736 ENDIF
27737 Q02=Q0**2
27738
27739C...Scale choice for off-shell photon; common factors.
27740 Q2A=Q2
27741 FACNOR=1D0
27742 IF(IP2.EQ.1) THEN
27743 P2MX=P2+Q02
27744 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
27745 FACNOR=LOG(Q2/Q02)/NSTEP
27746 ELSEIF(IP2.EQ.2) THEN
27747 P2MX=MAX(P2,Q02)
27748 ELSEIF(IP2.EQ.3) THEN
27749 P2MX=P2+Q02
27750 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
27751 ELSEIF(IP2.EQ.4) THEN
27752 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
27753 & ((Q2+P2)*(Q02+P2)))
27754 ELSEIF(IP2.EQ.5) THEN
27755 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
27756 & ((Q2+P2)*(Q02+P2)))
27757 P2MX=Q0*SQRT(P2MXA)
27758 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
27759 ELSEIF(IP2.EQ.6) THEN
27760 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
27761 & ((Q2+P2)*(Q02+P2)))
27762 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
27763 ELSE
27764 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
27765 & ((Q2+P2)*(Q02+P2)))
27766 P2MX=Q0*SQRT(P2MXA)
27767 P2MXB=P2MX
27768 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
27769 P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA
27770 IF(ABS(Q2-Q02).GT.1D-6) THEN
27771 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
27772 ELSEIF(P2.LT.Q02) THEN
27773 FACNOR=Q02**3/(Q02+P2)/(Q02**2-P2**2/2D0)
27774 ELSE
27775 FACNOR=1D0
27776 ENDIF
27777 ENDIF
27778
27779C...Call VMD parametrization for d quark and use to give rho, omega,
27780C...phi. Note dipole dampening for off-shell photon.
27781 CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
27782 XFVAL=VXPGA(1)
27783 XPGA(1)=XPGA(2)
27784 XPGA(-1)=XPGA(-2)
27785 FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
27786 FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
27787 DO 110 KFL=-5,5
27788 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
27789 110 CONTINUE
27790 XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL
27791 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
27792 XPVMD(3)=XPVMD(3)+FACS*XFVAL
27793 XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL
27794 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
27795 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
27796 VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL
27797 VXPVMD(2)=FRACU*FACUD*XFVAL
27798 VXPVMD(3)=FACS*XFVAL
27799 VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL
27800 VXPVMD(-2)=FRACU*FACUD*XFVAL
27801 VXPVMD(-3)=FACS*XFVAL
27802
27803 IF(IP2.NE.1) THEN
27804C...Anomalous parametrizations for different strategies
27805C...for off-shell photons; except full integration.
27806
27807C...Call anomalous parametrization for d + u + s.
27808 CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
27809 DO 120 KFL=-5,5
27810 XPANL(KFL)=FACNOR*XPGA(KFL)
27811 VXPANL(KFL)=FACNOR*VXPGA(KFL)
27812 120 CONTINUE
27813
27814C...Call anomalous parametrization for c and b.
27815 CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
27816 DO 130 KFL=-5,5
27817 XPANH(KFL)=FACNOR*XPGA(KFL)
27818 VXPANH(KFL)=FACNOR*VXPGA(KFL)
27819 130 CONTINUE
27820 CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
27821 DO 140 KFL=-5,5
27822 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
27823 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
27824 140 CONTINUE
27825
27826 ELSE
27827C...Special option: loop over flavours and integrate over k2.
27828 DO 170 KF=1,5
27829 DO 160 ISTEP=1,NSTEP
27830 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP)
27831 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
27832 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
27833 CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
27834 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
27835 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0)
27836 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0)
27837 DO 150 KFL=-5,5
27838 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
27839 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
27840 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
27841 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
27842 150 CONTINUE
27843 160 CONTINUE
27844 170 CONTINUE
27845 ENDIF
27846
27847C...Call Bethe-Heitler term expression for charm and bottom.
27848 CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH)
27849 XPBEH(4)=XPBH
27850 XPBEH(-4)=XPBH
27851 CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH)
27852 XPBEH(5)=XPBH
27853 XPBEH(-5)=XPBH
27854
27855C...For MSbar subtraction call C^gamma term expression for d, u, s.
27856 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
27857 CALL PYGDIR(X,Q2,P2,Q02,XPGA)
27858 DO 180 KFL=-5,5
27859 XPDIR(KFL)=XPGA(KFL)
27860 180 CONTINUE
27861 ENDIF
27862
27863C...Store result in output array.
27864 DO 190 KFL=-5,5
27865 CHSQ=1D0/9D0
27866 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0
27867 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
27868 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
27869 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
27870 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
27871 190 CONTINUE
27872
27873 RETURN
27874 END
27875
27876C*********************************************************************
27877
27878C...PYGVMD
27879C...Evaluates the VMD parton distributions of a photon,
27880C...evolved homogeneously from an initial scale P2 to Q2.
27881C...Does not include dipole suppression factor.
27882C...ISET is parton distribution set, see above;
27883C...additionally ISET=0 is used for the evolution of an anomalous photon
27884C...which branched at a scale P2 and then evolved homogeneously to Q2.
27885C...ALAM is the 4-flavour Lambda, which is automatically converted
27886C...to 3- and 5-flavour equivalents as needed.
27887C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
27888
27889 SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
27890
27891C...Double precision and integer declarations.
27892 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27893 IMPLICIT INTEGER(I-N)
27894 INTEGER PYK,PYCHGE,PYCOMP
27895C...Local arrays and data.
27896 DIMENSION XPGA(-6:6), VXPGA(-6:6)
27897 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
27898
27899C...Reset output.
27900 DO 100 KFL=-6,6
27901 XPGA(KFL)=0D0
27902 VXPGA(KFL)=0D0
27903 100 CONTINUE
27904 KFA=IABS(KF)
27905
27906C...Calculate Lambda; protect against unphysical Q2 and P2 input.
27907 ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
27908 ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
27909 P2EFF=MAX(P2,1.2D0*ALAM3**2)
27910 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
27911 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
27912 Q2EFF=MAX(Q2,P2EFF)
27913
27914C...Find number of flavours at lower and upper scale.
27915 NFP=4
27916 IF(P2EFF.LT.PMC**2) NFP=3
27917 IF(P2EFF.GT.PMB**2) NFP=5
27918 NFQ=4
27919 IF(Q2EFF.LT.PMC**2) NFQ=3
27920 IF(Q2EFF.GT.PMB**2) NFQ=5
27921
27922C...Find s as sum of 3-, 4- and 5-flavour parts.
27923 S=0D0
27924 IF(NFP.EQ.3) THEN
27925 Q2DIV=PMC**2
27926 IF(NFQ.EQ.3) Q2DIV=Q2EFF
27927 S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
27928 ENDIF
27929 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
27930 P2DIV=P2EFF
27931 IF(NFP.EQ.3) P2DIV=PMC**2
27932 Q2DIV=Q2EFF
27933 IF(NFQ.EQ.5) Q2DIV=PMB**2
27934 S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
27935 ENDIF
27936 IF(NFQ.EQ.5) THEN
27937 P2DIV=PMB**2
27938 IF(NFP.EQ.5) P2DIV=P2EFF
27939 S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
27940 ENDIF
27941
27942C...Calculate frequent combinations of x and s.
27943 X1=1D0-X
27944 XL=-LOG(X)
27945 S2=S**2
27946 S3=S**3
27947 S4=S**4
27948
27949C...Evaluate homogeneous anomalous parton distributions below or
27950C...above threshold.
27951 IF(ISET.EQ.0) THEN
27952 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
27953 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
27954 XVAL = X * 1.5D0 * (X**2+X1**2)
27955 XGLU = 0D0
27956 XSEA = 0D0
27957 ELSE
27958 XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
27959 & (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
27960 & 5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
27961 & X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
27962 XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
27963 & X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
27964 & ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
27965 XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
27966 & X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
27967 & ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
27968 & (2D0*X-1D0)*X*XL**2)
27969 ENDIF
27970
27971C...Evaluate set 1D parton distributions below or above threshold.
27972 ELSEIF(ISET.EQ.1) THEN
27973 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
27974 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
27975 XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
27976 XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
27977 XSEA = 0.100D0 * X1**3.76D0
27978 ELSE
27979 XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
27980 & X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
27981 XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
27982 & X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
27983 & XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
27984 & X**0.40D0 * X1**(1.76D0+3D0*S)
27985 XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
27986 & (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
27987 & X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
27988 XSEA0 = 0.100D0 * X1**3.76D0
27989 ENDIF
27990
27991C...Evaluate set 1M parton distributions below or above threshold.
27992 ELSEIF(ISET.EQ.2) THEN
27993 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
27994 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
27995 XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
27996 XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
27997 XSEA = 0D0
27998 ELSE
27999 XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
28000 & X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
28001 XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
28002 & EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
28003 & X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
28004 & EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
28005 XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
28006 & X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
28007 & XL**(2.8D0*S)
28008 XSEA0 = 0D0
28009 ENDIF
28010
28011C...Evaluate set 2D parton distributions below or above threshold.
28012 ELSEIF(ISET.EQ.3) THEN
28013 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
28014 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
28015 XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
28016 XGLU = 1.925D0 * X1**2
28017 XSEA = 0.242D0 * X1**4
28018 ELSE
28019 XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
28020 & X**(0.46D0+0.25D0*S) *
28021 & X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
28022 & (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
28023 XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
28024 & EXP(-18.67D0*S) *
28025 & X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
28026 & * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
28027 & XL**(9.3D0*S/(1D0+1.7D0*S))
28028 XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
28029 & (1D0-0.607D0*S+21.95D0*S2) *
28030 & X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
28031 XSEA0 = 0.242D0 * X1**4
28032 ENDIF
28033
28034C...Evaluate set 2M parton distributions below or above threshold.
28035 ELSEIF(ISET.EQ.4) THEN
28036 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
28037 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
28038 XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
28039 XGLU = 1.808D0 * X1**2
28040 XSEA = 0.209D0 * X1**4
28041 ELSE
28042 XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
28043 & X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
28044 & X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
28045 & XL**(5.15D0*S/(1D0+2D0*S)) +
28046 & (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
28047 XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
28048 & X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
28049 & X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
28050 & XL**(10.9D0*S/(1D0+2.5D0*S))
28051 XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
28052 & X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
28053 & X1**(4D0+S) * XL**(0.45D0*S)
28054 XSEA0 = 0.209D0 * X1**4
28055 ENDIF
28056 ENDIF
28057
28058C...Threshold factors for c and b sea.
28059 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
28060 XCHM=0D0
28061 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
28062 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
28063 IF(ISET.EQ.0) THEN
28064 XCHM=XSEA*(1D0-(SCH/SLL)**2)
28065 ELSE
28066 XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
28067 ENDIF
28068 ENDIF
28069 XBOT=0D0
28070 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
28071 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
28072 IF(ISET.EQ.0) THEN
28073 XBOT=XSEA*(1D0-(SBT/SLL)**2)
28074 ELSE
28075 XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
28076 ENDIF
28077 ENDIF
28078
28079C...Fill parton distributions.
28080 XPGA(0)=XGLU
28081 XPGA(1)=XSEA
28082 XPGA(2)=XSEA
28083 XPGA(3)=XSEA
28084 XPGA(4)=XCHM
28085 XPGA(5)=XBOT
28086 XPGA(KFA)=XPGA(KFA)+XVAL
28087 DO 110 KFL=1,5
28088 XPGA(-KFL)=XPGA(KFL)
28089 110 CONTINUE
28090 VXPGA(KFA)=XVAL
28091 VXPGA(-KFA)=XVAL
28092
28093 RETURN
28094 END
28095
28096C*********************************************************************
28097
28098C...PYGANO
28099C...Evaluates the parton distributions of the anomalous photon,
28100C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
28101C...KF=0 gives the sum over (up to) 5 flavours,
28102C...KF<0 limits to flavours up to abs(KF),
28103C...KF>0 is for flavour KF only.
28104C...ALAM is the 4-flavour Lambda, which is automatically converted
28105C...to 3- and 5-flavour equivalents as needed.
28106C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
28107
28108 SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
28109
28110C...Double precision and integer declarations.
28111 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28112 IMPLICIT INTEGER(I-N)
28113 INTEGER PYK,PYCHGE,PYCOMP
28114C...Local arrays and data.
28115 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
28116 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
28117
28118C...Reset output.
28119 DO 100 KFL=-6,6
28120 XPGA(KFL)=0D0
28121 VXPGA(KFL)=0D0
28122 100 CONTINUE
28123 IF(Q2.LE.P2) RETURN
28124 KFA=IABS(KF)
28125
28126C...Calculate Lambda; protect against unphysical Q2 and P2 input.
28127 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2
28128 ALAMSQ(4)=ALAM**2
28129 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2
28130 P2EFF=MAX(P2,1.2D0*ALAMSQ(3))
28131 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
28132 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
28133 Q2EFF=MAX(Q2,P2EFF)
28134 XL=-LOG(X)
28135
28136C...Find number of flavours at lower and upper scale.
28137 NFP=4
28138 IF(P2EFF.LT.PMC**2) NFP=3
28139 IF(P2EFF.GT.PMB**2) NFP=5
28140 NFQ=4
28141 IF(Q2EFF.LT.PMC**2) NFQ=3
28142 IF(Q2EFF.GT.PMB**2) NFQ=5
28143
28144C...Define range of flavour loop.
28145 IF(KF.EQ.0) THEN
28146 KFLMN=1
28147 KFLMX=5
28148 ELSEIF(KF.LT.0) THEN
28149 KFLMN=1
28150 KFLMX=KFA
28151 ELSE
28152 KFLMN=KFA
28153 KFLMX=KFA
28154 ENDIF
28155
28156C...Loop over flavours the photon can branch into.
28157 DO 110 KFL=KFLMN,KFLMX
28158
28159C...Light flavours: calculate t range and (approximate) s range.
28160 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
28161 TDIFF=LOG(Q2EFF/P2EFF)
28162 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
28163 & LOG(P2EFF/ALAMSQ(NFQ)))
28164 IF(NFQ.GT.NFP) THEN
28165 Q2DIV=PMB**2
28166 IF(NFQ.EQ.4) Q2DIV=PMC**2
28167 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
28168 & LOG(P2EFF/ALAMSQ(NFQ)))
28169 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
28170 & LOG(P2EFF/ALAMSQ(NFQ-1)))
28171 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
28172 ENDIF
28173 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
28174 Q2DIV=PMC**2
28175 SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
28176 & LOG(P2EFF/ALAMSQ(4)))
28177 SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
28178 & LOG(P2EFF/ALAMSQ(3)))
28179 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
28180 ENDIF
28181
28182C...u and s quark do not need a separate treatment when d has been done.
28183 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
28184
28185C...Charm: as above, but only include range above c threshold.
28186 ELSEIF(KFL.EQ.4) THEN
28187 IF(Q2.LE.PMC**2) GOTO 110
28188 P2EFF=MAX(P2EFF,PMC**2)
28189 Q2EFF=MAX(Q2EFF,P2EFF)
28190 TDIFF=LOG(Q2EFF/P2EFF)
28191 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
28192 & LOG(P2EFF/ALAMSQ(NFQ)))
28193 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
28194 Q2DIV=PMB**2
28195 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
28196 & LOG(P2EFF/ALAMSQ(NFQ)))
28197 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
28198 & LOG(P2EFF/ALAMSQ(NFQ-1)))
28199 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
28200 ENDIF
28201
28202C...Bottom: as above, but only include range above b threshold.
28203 ELSEIF(KFL.EQ.5) THEN
28204 IF(Q2.LE.PMB**2) GOTO 110
28205 P2EFF=MAX(P2EFF,PMB**2)
28206 Q2EFF=MAX(Q2,P2EFF)
28207 TDIFF=LOG(Q2EFF/P2EFF)
28208 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
28209 & LOG(P2EFF/ALAMSQ(NFQ)))
28210 ENDIF
28211
28212C...Evaluate flavour-dependent prefactor (charge^2 etc.).
28213 CHSQ=1D0/9D0
28214 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0
28215 FAC=AEM2PI*2D0*CHSQ*TDIFF
28216
28217C...Evaluate parton distributions (normalized to unit momentum sum).
28218 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
28219 XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 +
28220 & (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 +
28221 & 1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) *
28222 & X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S))
28223 XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) *
28224 & X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) *
28225 & ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL)
28226 XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) *
28227 & X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) *
28228 & ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 +
28229 & (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2)
28230
28231C...Threshold factors for c and b sea.
28232 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
28233 XCHM=0D0
28234 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
28235 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
28236 XCHM=XSEA*(1D0-(SCH/SLL)**3)
28237 ENDIF
28238 XBOT=0D0
28239 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
28240 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
28241 XBOT=XSEA*(1D0-(SBT/SLL)**3)
28242 ENDIF
28243 ENDIF
28244
28245C...Add contribution of each valence flavour.
28246 XPGA(0)=XPGA(0)+FAC*XGLU
28247 XPGA(1)=XPGA(1)+FAC*XSEA
28248 XPGA(2)=XPGA(2)+FAC*XSEA
28249 XPGA(3)=XPGA(3)+FAC*XSEA
28250 XPGA(4)=XPGA(4)+FAC*XCHM
28251 XPGA(5)=XPGA(5)+FAC*XBOT
28252 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
28253 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
28254 110 CONTINUE
28255 DO 120 KFL=1,5
28256 XPGA(-KFL)=XPGA(KFL)
28257 VXPGA(-KFL)=VXPGA(KFL)
28258 120 CONTINUE
28259
28260 RETURN
28261 END
28262
28263C*********************************************************************
28264
28265C...PYGBEH
28266C...Evaluates the Bethe-Heitler cross section for heavy flavour
28267C...production.
28268C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
28269
28270 SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)
28271
28272C...Double precision and integer declarations.
28273 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28274 IMPLICIT INTEGER(I-N)
28275 INTEGER PYK,PYCHGE,PYCOMP
28276
28277C...Local data.
28278 DATA AEM2PI/0.0011614D0/
28279
28280C...Reset output.
28281 XPBH=0D0
28282 SIGBH=0D0
28283
28284C...Check kinematics limits.
28285 IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
28286 W2=Q2*(1D0-X)/X-P2
28287 BETA2=1D0-4D0*PM2/W2
28288 IF(BETA2.LT.1D-10) RETURN
28289 BETA=SQRT(BETA2)
28290 RMQ=4D0*PM2/Q2
28291
28292C...Simple case: P2 = 0.
28293 IF(P2.LT.1D-4) THEN
28294 IF(BETA.LT.0.99D0) THEN
28295 XBL=LOG((1D0+BETA)/(1D0-BETA))
28296 ELSE
28297 XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
28298 ENDIF
28299 SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
28300 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)
28301
28302C...Complicated case: P2 > 0, based on approximation of
28303C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
28304 ELSE
28305 RPQ=1D0-4D0*X**2*P2/Q2
28306 IF(RPQ.GT.1D-10) THEN
28307 RPBE=SQRT(RPQ*BETA2)
28308 IF(RPBE.LT.0.99D0) THEN
28309 XBL=LOG((1D0+RPBE)/(1D0-RPBE))
28310 XBI=2D0*RPBE/(1D0-RPBE**2)
28311 ELSE
28312 RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
28313 XBL=LOG((1D0+RPBE)**2/RPBESN)
28314 XBI=2D0*RPBE/RPBESN
28315 ENDIF
28316 SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
28317 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
28318 & XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
28319 ENDIF
28320 ENDIF
28321
28322C...Multiply by charge-squared etc. to get parton distribution.
28323 CHSQ=1D0/9D0
28324 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0
28325 XPBH=3D0*CHSQ*AEM2PI*X*SIGBH
28326
28327 RETURN
28328 END
28329
28330C*********************************************************************
28331
28332C...PYGDIR
28333C...Evaluates the direct contribution, i.e. the C^gamma term,
28334C...as needed in MSbar parametrizations.
28335C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
28336
28337 SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA)
28338
28339C...Double precision and integer declarations.
28340 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28341 IMPLICIT INTEGER(I-N)
28342 INTEGER PYK,PYCHGE,PYCOMP
28343C...Local array and data.
28344 DIMENSION XPGA(-6:6)
28345 DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/
28346
28347C...Reset output.
28348 DO 100 KFL=-6,6
28349 XPGA(KFL)=0D0
28350 100 CONTINUE
28351
28352C...Evaluate common x-dependent expression.
28353 XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0
28354 CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X))
28355
28356C...d, u, s part by simple charge factor.
28357 XPGA(1)=(1D0/9D0)*CGAM
28358 XPGA(2)=(4D0/9D0)*CGAM
28359 XPGA(3)=(1D0/9D0)*CGAM
28360
28361C...Also fill for antiquarks.
28362 DO 110 KF=1,5
28363 XPGA(-KF)=XPGA(KF)
28364 110 CONTINUE
28365
28366 RETURN
28367 END
28368
28369C*********************************************************************
28370
28371C...PYPDPI
28372C...Gives pi+ parton distribution according to two different
28373C...parametrizations.
28374
28375 SUBROUTINE PYPDPI(X,Q2,XPPI)
28376
28377C...Double precision and integer declarations.
28378 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28379 IMPLICIT INTEGER(I-N)
28380 INTEGER PYK,PYCHGE,PYCOMP
28381C...Commonblocks.
28382 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28383 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28384 COMMON/PYINT1/MINT(400),VINT(400)
28385 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
28386C...Local arrays.
28387 DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6)
28388
28389C...The following data lines are coefficients needed in the
28390C...Owens pion parton distribution parametrizations, see below.
28391C...Expansion coefficients for up and down valence quark distributions.
28392 DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
28393 &4.0000D-01, 7.0000D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
28394 &-6.2120D-02, 6.4780D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
28395 &-7.1090D-03, 1.3350D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
28396 DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
28397 &4.0000D-01, 6.2800D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
28398 &-5.9090D-02, 6.4360D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
28399 &-6.5240D-03, 1.4510D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
28400C...Expansion coefficients for gluon distribution.
28401 DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
28402 &8.8800D-01, 0.0000D+00, 3.1100D+00, 6.0000D+00, 0.0000D+00,
28403 &-1.8020D+00, -1.5760D+00, -1.3170D-01, 2.8010D+00, -1.7280D+01,
28404 &1.8120D+00, 1.2000D+00, 5.0680D-01, -1.2160D+01, 2.0490D+01/
28405 DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
28406 &7.9400D-01, 0.0000D+00, 2.8900D+00, 6.0000D+00, 0.0000D+00,
28407 &-9.1440D-01, -1.2370D+00, 5.9660D-01, -3.6710D+00, -8.1910D+00,
28408 &5.9660D-01, 6.5820D-01, -2.5500D-01, -2.3040D+00, 7.7580D+00/
28409C...Expansion coefficients for (up+down+strange) quark sea distribution.
28410 DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
28411 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
28412 &-2.4280D-01, -2.1200D-01, 8.6730D-01, 1.2660D+00, 2.3820D+00,
28413 &1.3860D-01, 3.6710D-03, 4.7470D-02, -2.2150D+00, 3.4820D-01/
28414 DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
28415 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
28416 &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00, 5.6210D-01,
28417 &-1.7400D-01, -9.6230D-02, 1.5750D+00, 1.3780D+00, -2.7010D-01/
28418C...Expansion coefficients for charm quark sea distribution.
28419 DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
28420 &0.0000D+00, -2.2120D-02, 2.8940D+00, 0.0000D+00, 0.0000D+00,
28421 &7.9280D-02, -3.7850D-01, 9.4330D+00, 5.2480D+00, 8.3880D+00,
28422 &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/
28423 DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
28424 &0.0000D+00, -8.8200D-02, 1.9240D+00, 0.0000D+00, 0.0000D+00,
28425 &6.2290D-02, -2.8920D-01, 2.4240D-01, -4.4630D+00, -8.3670D-01,
28426 &-4.0990D-02, -1.0820D-01, 2.0360D+00, 5.2090D+00, -4.8400D-02/
28427
28428C...Euler's beta function, requires ordinary Gamma function
28429 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
28430
28431C...Reset output array.
28432 DO 100 KFL=-6,6
28433 XPPI(KFL)=0D0
28434 100 CONTINUE
28435
28436 IF(MSTP(53).LE.2) THEN
28437C...Pion parton distributions from Owens.
28438C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
28439
28440C...Determine set, Lambda and s expansion variable.
28441 NSET=MSTP(53)
28442 IF(NSET.EQ.1) ALAM=0.2D0
28443 IF(NSET.EQ.2) ALAM=0.4D0
28444 VINT(231)=4D0
28445 IF(MSTP(57).LE.0) THEN
28446 SD=0D0
28447 ELSE
28448 Q2IN=MIN(2D3,MAX(4D0,Q2))
28449 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
28450 ENDIF
28451
28452C...Calculate parton distributions.
28453 DO 120 KFL=1,4
28454 DO 110 IS=1,5
28455 TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
28456 & COW(3,IS,KFL,NSET)*SD**2
28457 110 CONTINUE
28458 IF(KFL.EQ.1) THEN
28459 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0)
28460 ELSE
28461 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
28462 & TS(5)*X**2)
28463 ENDIF
28464 120 CONTINUE
28465
28466C...Put into output array.
28467 XPPI(0)=XQ(2)
28468 XPPI(1)=XQ(3)/6D0
28469 XPPI(2)=XQ(1)+XQ(3)/6D0
28470 XPPI(3)=XQ(3)/6D0
28471 XPPI(4)=XQ(4)
28472 XPPI(-1)=XQ(1)+XQ(3)/6D0
28473 XPPI(-2)=XQ(3)/6D0
28474 XPPI(-3)=XQ(3)/6D0
28475 XPPI(-4)=XQ(4)
28476
28477C...Leading order pion parton distributions from Glueck, Reya and Vogt.
28478C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
28479C...10^-5 < x < 1.
28480 ELSE
28481
28482C...Determine s expansion variable and some x expressions.
28483 VINT(231)=0.25D0
28484 IF(MSTP(57).LE.0) THEN
28485 SD=0D0
28486 ELSE
28487 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
28488 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
28489 ENDIF
28490 SD2=SD**2
28491 XL=-LOG(X)
28492 XS=SQRT(X)
28493
28494C...Evaluate valence, gluon and sea distributions.
28495 XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)*
28496 & (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD)
28497 XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0*
28498 & SD-0.175D0*SD2)+
28499 & (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+
28500 & SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0*
28501 & XL)))*
28502 & (1D0-X)**(0.390D0+1.053D0*SD)
28503 XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0-
28504 & X)**3.359D0*
28505 & EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0*
28506 & XL))/
28507 & XL**(2.538D0-0.763D0*SD)
28508 IF(SD.LE.0.888D0) THEN
28509 XFCHM=0D0
28510 ELSE
28511 XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+
28512 & 0.771D0*SD)*
28513 & EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0*
28514 & XL))
28515 ENDIF
28516 IF(SD.LE.1.351D0) THEN
28517 XFBOT=0D0
28518 ELSE
28519 XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)*
28520 & EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0*
28521 & XL))
28522 ENDIF
28523
28524C...Put into output array.
28525 XPPI(0)=XFGLU
28526 XPPI(1)=XFSEA
28527 XPPI(2)=XFSEA
28528 XPPI(3)=XFSEA
28529 XPPI(4)=XFCHM
28530 XPPI(5)=XFBOT
28531 DO 130 KFL=1,5
28532 XPPI(-KFL)=XPPI(KFL)
28533 130 CONTINUE
28534 XPPI(2)=XPPI(2)+XFVAL
28535 XPPI(-1)=XPPI(-1)+XFVAL
28536 ENDIF
28537
28538 RETURN
28539 END
28540
28541C*********************************************************************
28542
28543C...PYPDPR
28544C...Gives proton parton distributions according to a few different
28545C...parametrizations.
28546
28547 SUBROUTINE PYPDPR(X,Q2,XPPR)
28548
28549C...Double precision and integer declarations.
28550 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28551 IMPLICIT INTEGER(I-N)
28552 INTEGER PYK,PYCHGE,PYCOMP
28553C...Commonblocks.
28554 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28555 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28556 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28557 COMMON/PYINT1/MINT(400),VINT(400)
28558 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
28559C...Arrays and data.
28560 DIMENSION XPPR(-6:6),Q2MIN(16)
28561 DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0,
28562 &1.0D0, 1.0D0, 2*0D0, 0.25D0, 5D0, 5D0, 4D0, 4D0, 0D0/
28563
28564C...Reset output array.
28565 DO 100 KFL=-6,6
28566 XPPR(KFL)=0D0
28567 100 CONTINUE
28568
28569C...Common preliminaries.
28570 NSET=MAX(1,MIN(16,MSTP(51)))
28571 IF(NSET.EQ.9.OR.NSET.EQ.10) NSET=6
28572 VINT(231)=Q2MIN(NSET)
28573 IF(MSTP(57).EQ.0) THEN
28574 Q2L=Q2MIN(NSET)
28575 ELSE
28576 Q2L=MAX(Q2MIN(NSET),Q2)
28577 ENDIF
28578
28579 IF(NSET.GE.1.AND.NSET.LE.3) THEN
28580C...Interface to the CTEQ 3 parton distributions.
28581 QRT=SQRT(MAX(1D0,Q2L))
28582
28583C...Loop over flavours.
28584 DO 110 I=-6,6
28585 IF(I.LE.0) THEN
28586 XPPR(I)=PYCTEQ(NSET,I,X,QRT)
28587 ELSEIF(I.LE.2) THEN
28588 XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I)
28589 ELSE
28590 XPPR(I)=XPPR(-I)
28591 ENDIF
28592 110 CONTINUE
28593
28594 ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN
28595C...Interface to the GRV 94 distributions.
28596 IF(NSET.EQ.4) THEN
28597 CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
28598 ELSEIF(NSET.EQ.5) THEN
28599 CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
28600 ELSE
28601 CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
28602 ENDIF
28603
28604C...Put into output array.
28605 XPPR(0)=GL
28606 XPPR(-1)=0.5D0*(UDB+DEL)
28607 XPPR(-2)=0.5D0*(UDB-DEL)
28608 XPPR(-3)=SB
28609 XPPR(-4)=CHM
28610 XPPR(-5)=BOT
28611 XPPR(1)=DV+XPPR(-1)
28612 XPPR(2)=UV+XPPR(-2)
28613 XPPR(3)=SB
28614 XPPR(4)=CHM
28615 XPPR(5)=BOT
28616
28617 ELSEIF(NSET.EQ.7) THEN
28618C...Interface to the CTEQ 5L parton distributions.
28619C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by
28620C...freezing x*f(x,Q2) at borders.
28621 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
28622 XIN=MAX(1D-6,MIN(1D0,X))
28623
28624C...Loop over flavours (with u <-> d notation mismatch).
28625 SUMUDB=PYCT5L(-1,XIN,QRT)
28626 RATUDB=PYCT5L(-2,XIN,QRT)
28627 DO 120 I=-5,2
28628 IF(I.EQ.1) THEN
28629 XPPR(I)=XIN*PYCT5L(2,XIN,QRT)
28630 ELSEIF(I.EQ.2) THEN
28631 XPPR(I)=XIN*PYCT5L(1,XIN,QRT)
28632 ELSEIF(I.EQ.-1) THEN
28633 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
28634 ELSEIF(I.EQ.-2) THEN
28635 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
28636 ELSE
28637 XPPR(I)=XIN*PYCT5L(I,XIN,QRT)
28638 IF(I.LT.0) XPPR(-I)=XPPR(I)
28639 ENDIF
28640 120 CONTINUE
28641
28642 ELSEIF(NSET.EQ.8) THEN
28643C...Interface to the CTEQ 5M1 parton distributions.
28644 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
28645 XIN=MAX(1D-6,MIN(1D0,X))
28646
28647C...Loop over flavours (with u <-> d notation mismatch).
28648 SUMUDB=PYCT5M(-1,XIN,QRT)
28649 RATUDB=PYCT5M(-2,XIN,QRT)
28650 DO 130 I=-5,2
28651 IF(I.EQ.1) THEN
28652 XPPR(I)=XIN*PYCT5M(2,XIN,QRT)
28653 ELSEIF(I.EQ.2) THEN
28654 XPPR(I)=XIN*PYCT5M(1,XIN,QRT)
28655 ELSEIF(I.EQ.-1) THEN
28656 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
28657 ELSEIF(I.EQ.-2) THEN
28658 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
28659 ELSE
28660 XPPR(I)=XIN*PYCT5M(I,XIN,QRT)
28661 IF(I.LT.0) XPPR(-I)=XPPR(I)
28662 ENDIF
28663 130 CONTINUE
28664
28665 ELSEIF(NSET.GE.11.AND.NSET.LE.15) THEN
28666C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions:
28667C...obsolete but offers backwards compatibility.
28668 CALL PYPDPO(X,Q2L,XPPR)
28669
28670C...Symmetric choice for debugging only
28671 ELSEIF(NSET.EQ.16) THEN
28672 XPPR(0)=.5D0/X
28673 XPPR(1)=.05D0/X
28674 XPPR(2)=.05D0/X
28675 XPPR(3)=.05D0/X
28676 XPPR(4)=.05D0/X
28677 XPPR(5)=.05D0/X
28678 XPPR(-1)=.05D0/X
28679 XPPR(-2)=.05D0/X
28680 XPPR(-3)=.05D0/X
28681 XPPR(-4)=.05D0/X
28682 XPPR(-5)=.05D0/X
28683
28684 ENDIF
28685
28686 RETURN
28687 END
28688
28689C*********************************************************************
28690
28691C...PYCTEQ
28692C...Gives the CTEQ 3 parton distribution function sets in
28693C...parametrized form, of October 24, 1994.
28694C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
28695C...J. Qiu, W.K. Tung and H. Weerts.
28696
28697 FUNCTION PYCTEQ (ISET, IPRT, X, Q)
28698
28699C...Double precision declaration.
28700 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28701 IMPLICIT INTEGER(I-N)
28702
28703C...Data on Lambda values of fits, minimum Q and quark masses.
28704 DIMENSION ALM(3), QMS(4:6)
28705 DATA ALM / 0.177D0, 0.239D0, 0.247D0 /
28706 DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 /
28707
28708C....Check flavour thresholds. Set up QI for SB.
28709 IP = IABS(IPRT)
28710 IF(IP .GE. 4) THEN
28711 IF(Q .LE. QMS(IP)) THEN
28712 PYCTEQ = 0D0
28713 RETURN
28714 ENDIF
28715 QI = QMS(IP)
28716 ELSE
28717 QI = QMN
28718 ENDIF
28719
28720C...Use "standard lambda" of parametrization program for expansion.
28721 ALAM = ALM (ISET)
28722 SBL = LOG(Q/ALAM) / LOG(QI/ALAM)
28723 SB = LOG (SBL)
28724 SB2 = SB*SB
28725 SB3 = SB2*SB
28726
28727C...Expansion for CTEQ3L.
28728 IF(ISET .EQ. 1) THEN
28729 IF(IPRT .EQ. 2) THEN
28730 A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2-
28731 & 0.3171D+00*SB3)
28732 A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3
28733 A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3
28734 A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3
28735 A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3
28736 A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3
28737 ELSEIF(IPRT .EQ. 1) THEN
28738 A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+
28739 & 0.7728D+00*SB3)
28740 A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3
28741 A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3
28742 A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3
28743 A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3
28744 A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3
28745 ELSEIF(IPRT .EQ. 0) THEN
28746 A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+
28747 & 0.5343D+00*SB3)
28748 A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3
28749 A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3
28750 A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3
28751 A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3
28752 A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3
28753 ELSEIF(IPRT .EQ. -1) THEN
28754 A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2-
28755 & 0.2031D+01*SB3)
28756 A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3
28757 A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3
28758 A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3
28759 A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3
28760 A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3
28761 ELSEIF(IPRT .EQ. -2) THEN
28762 A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2-
28763 & 0.9872D-01*SB3)
28764 A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3
28765 A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3
28766 A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3
28767 A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3
28768 A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3
28769 ELSEIF(IPRT .EQ. -3) THEN
28770 A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+
28771 & 0.8390D+00*SB3)
28772 A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3
28773 A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3
28774 A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3
28775 A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3
28776 A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3
28777 ELSEIF(IPRT .EQ. -4) THEN
28778 A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB +
28779 & 0.1651D-01*SB2)
28780 A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3
28781 A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3
28782 A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3
28783 A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3
28784 A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3
28785 ELSEIF(IPRT .EQ. -5) THEN
28786 A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB +
28787 & 0.3702D+01*SB2)
28788 A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3
28789 A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3
28790 A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3
28791 A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3
28792 A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3
28793 ELSEIF(IPRT .EQ. -6) THEN
28794 A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB -
28795 & 0.6943D+00*SB2)
28796 A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3
28797 A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3
28798 A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3
28799 A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3
28800 A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3
28801 ENDIF
28802
28803C...Expansion for CTEQ3M.
28804 ELSEIF(ISET .EQ. 2) THEN
28805 IF(IPRT .EQ. 2) THEN
28806 A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2-
28807 & 0.2935D+00*SB3)
28808 A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3
28809 A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3
28810 A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3
28811 A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3
28812 A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3
28813 ELSEIF(IPRT .EQ. 1) THEN
28814 A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2-
28815 & 0.4305D-01*SB3)
28816 A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3
28817 A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3
28818 A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3
28819 A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3
28820 A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3
28821 ELSEIF(IPRT .EQ. 0) THEN
28822 A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+
28823 & 0.1037D-01*SB3)
28824 A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3
28825 A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3
28826 A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3
28827 A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3
28828 A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3
28829 ELSEIF(IPRT .EQ. -1) THEN
28830 A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2-
28831 & 0.1602D+01*SB3)
28832 A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3
28833 A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3
28834 A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3
28835 A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3
28836 A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3
28837 ELSEIF(IPRT .EQ. -2) THEN
28838 A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+
28839 & 0.2496D+00*SB3)
28840 A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3
28841 A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3
28842 A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3
28843 A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3
28844 A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3
28845 ELSEIF(IPRT .EQ. -3) THEN
28846 A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+
28847 & 0.1936D+01*SB3)
28848 A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3
28849 A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3
28850 A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3
28851 A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3
28852 A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3
28853 ELSEIF(IPRT .EQ. -4) THEN
28854 A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB +
28855 & 0.5348D+00*SB2)
28856 A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3
28857 A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3
28858 A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3
28859 A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3
28860 A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3
28861 ELSEIF(IPRT .EQ. -5) THEN
28862 A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB +
28863 & 0.1569D+01*SB2)
28864 A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3
28865 A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3
28866 A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3
28867 A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3
28868 A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3
28869 ELSEIF(IPRT .EQ. -6) THEN
28870 A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB +
28871 & 0.8838D+01*SB2)
28872 A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3
28873 A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3
28874 A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3
28875 A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3
28876 A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3
28877 ENDIF
28878
28879C...Expansion for CTEQ3D.
28880 ELSEIF(ISET .EQ. 3) THEN
28881 IF(IPRT .EQ. 2) THEN
28882 A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2-
28883 & 0.2902D+00*SB3)
28884 A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3
28885 A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3
28886 A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3
28887 A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3
28888 A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3
28889 ELSEIF(IPRT .EQ. 1) THEN
28890 A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+
28891 & 0.7257D+00*SB3)
28892 A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3
28893 A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3
28894 A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3
28895 A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3
28896 A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3
28897 ELSEIF(IPRT .EQ. 0) THEN
28898 A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2-
28899 & 0.2734D-04*SB3)
28900 A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3
28901 A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3
28902 A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3
28903 A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3
28904 A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3
28905 ELSEIF(IPRT .EQ. -1) THEN
28906 A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2-
28907 & 0.1671D+01*SB3)
28908 A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3
28909 A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3
28910 A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3
28911 A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3
28912 A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3
28913 ELSEIF(IPRT .EQ. -2) THEN
28914 A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+
28915 & 0.2223D+00*SB3)
28916 A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3
28917 A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3
28918 A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3
28919 A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3
28920 A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3
28921 ELSEIF(IPRT .EQ. -3) THEN
28922 A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+
28923 & 0.1937D+01*SB3)
28924 A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3
28925 A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3
28926 A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3
28927 A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3
28928 A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3
28929 ELSEIF(IPRT .EQ. -4) THEN
28930 A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB +
28931 & 0.5137D+00*SB2)
28932 A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3
28933 A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3
28934 A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3
28935 A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3
28936 A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3
28937 ELSEIF(IPRT .EQ. -5) THEN
28938 A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB +
28939 & 0.2143D+01*SB2)
28940 A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3
28941 A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3
28942 A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3
28943 A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3
28944 A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3
28945 ELSEIF(IPRT .EQ. -6) THEN
28946 A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB +
28947 & 0.9998D+01*SB2)
28948 A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3
28949 A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3
28950 A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3
28951 A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3
28952 A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3
28953 ENDIF
28954 ENDIF
28955
28956C...Calculation of x * f(x, Q).
28957 PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4))
28958 & *(LOG(1D0+1D0/X))**A5 )
28959
28960 RETURN
28961 END
28962
28963C*********************************************************************
28964
28965C...PYGRVL
28966C...Gives the GRV 94 L (leading order) parton distribution function set
28967C...in parametrized form.
28968C...Authors: M. Glueck, E. Reya and A. Vogt.
28969
28970 SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
28971
28972C...Double precision declaration.
28973 IMPLICIT DOUBLE PRECISION (A - Z)
28974
28975C...Common expressions.
28976 MU2 = 0.23D0
28977 LAM2 = 0.2322D0 * 0.2322D0
28978 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
28979 DS = SQRT (S)
28980 S2 = S * S
28981 S3 = S2 * S
28982
28983C...uv :
28984 NU = 2.284D0 + 0.802D0 * S + 0.055D0 * S2
28985 AKU = 0.590D0 - 0.024D0 * S
28986 BKU = 0.131D0 + 0.063D0 * S
28987 AU = -0.449D0 - 0.138D0 * S - 0.076D0 * S2
28988 BU = 0.213D0 + 2.669D0 * S - 0.728D0 * S2
28989 CU = 8.854D0 - 9.135D0 * S + 1.979D0 * S2
28990 DU = 2.997D0 + 0.753D0 * S - 0.076D0 * S2
28991 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
28992
28993C...dv :
28994 ND = 0.371D0 + 0.083D0 * S + 0.039D0 * S2
28995 AKD = 0.376D0
28996 BKD = 0.486D0 + 0.062D0 * S
28997 AD = -0.509D0 + 3.310D0 * S - 1.248D0 * S2
28998 BD = 12.41D0 - 10.52D0 * S + 2.267D0 * S2
28999 CD = 6.373D0 - 6.208D0 * S + 1.418D0 * S2
29000 DD = 3.691D0 + 0.799D0 * S - 0.071D0 * S2
29001 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
29002
29003C...del :
29004 NE = 0.082D0 + 0.014D0 * S + 0.008D0 * S2
29005 AKE = 0.409D0 - 0.005D0 * S
29006 BKE = 0.799D0 + 0.071D0 * S
29007 AE = -38.07D0 + 36.13D0 * S - 0.656D0 * S2
29008 BE = 90.31D0 - 74.15D0 * S + 7.645D0 * S2
29009 CE = 0.0D0
29010 DE = 7.486D0 + 1.217D0 * S - 0.159D0 * S2
29011 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
29012
29013C...udb :
29014 ALX = 1.451D0
29015 BEX = 0.271D0
29016 AKX = 0.410D0 - 0.232D0 * S
29017 BKX = 0.534D0 - 0.457D0 * S
29018 AGX = 0.890D0 - 0.140D0 * S
29019 BGX = -0.981D0
29020 CX = 0.320D0 + 0.683D0 * S
29021 DX = 4.752D0 + 1.164D0 * S + 0.286D0 * S2
29022 EX = 4.119D0 + 1.713D0 * S
29023 ESX = 0.682D0 + 2.978D0 * S
29024 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
29025 & DX, EX, ESX)
29026
29027C...sb :
29028 STS = 0D0
29029 ALS = 0.914D0
29030 BES = 0.577D0
29031 AKS = 1.798D0 - 0.596D0 * S
29032 AS = -5.548D0 + 3.669D0 * DS - 0.616D0 * S
29033 BS = 18.92D0 - 16.73D0 * DS + 5.168D0 * S
29034 DST = 6.379D0 - 0.350D0 * S + 0.142D0 * S2
29035 EST = 3.981D0 + 1.638D0 * S
29036 ESS = 6.402D0
29037 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
29038
29039C...cb :
29040 STC = 0.888D0
29041 ALC = 1.01D0
29042 BEC = 0.37D0
29043 AKC = 0D0
29044 AC = 0D0
29045 BC = 4.24D0 - 0.804D0 * S
29046 DCT = 3.46D0 - 1.076D0 * S
29047 ECT = 4.61D0 + 1.49D0 * S
29048 ESC = 2.555D0 + 1.961D0 * S
29049 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
29050
29051C...bb :
29052 STB = 1.351D0
29053 ALB = 1.00D0
29054 BEB = 0.51D0
29055 AKB = 0D0
29056 AB = 0D0
29057 BB = 1.848D0
29058 DBT = 2.929D0 + 1.396D0 * S
29059 EBT = 4.71D0 + 1.514D0 * S
29060 ESB = 4.02D0 + 1.239D0 * S
29061 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
29062
29063C...gl :
29064 ALG = 0.524D0
29065 BEG = 1.088D0
29066 AKG = 1.742D0 - 0.930D0 * S
29067 BKG = - 0.399D0 * S2
29068 AG = 7.486D0 - 2.185D0 * S
29069 BG = 16.69D0 - 22.74D0 * S + 5.779D0 * S2
29070 CG = -25.59D0 + 29.71D0 * S - 7.296D0 * S2
29071 DG = 2.792D0 + 2.215D0 * S + 0.422D0 * S2 - 0.104D0 * S3
29072 EG = 0.807D0 + 2.005D0 * S
29073 ESG = 3.841D0 + 0.316D0 * S
29074 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG,
29075 & DG, EG, ESG)
29076
29077 RETURN
29078 END
29079
29080C*********************************************************************
29081
29082C...PYGRVM
29083C...Gives the GRV 94 M (MSbar) parton distribution function set
29084C...in parametrized form.
29085C...Authors: M. Glueck, E. Reya and A. Vogt.
29086
29087 SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
29088
29089C...Double precision declaration.
29090 IMPLICIT DOUBLE PRECISION (A - Z)
29091
29092C...Common expressions.
29093 MU2 = 0.34D0
29094 LAM2 = 0.248D0 * 0.248D0
29095 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
29096 DS = SQRT (S)
29097 S2 = S * S
29098 S3 = S2 * S
29099
29100C...uv :
29101 NU = 1.304D0 + 0.863D0 * S
29102 AKU = 0.558D0 - 0.020D0 * S
29103 BKU = 0.183D0 * S
29104 AU = -0.113D0 + 0.283D0 * S - 0.321D0 * S2
29105 BU = 6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3
29106 CU = 7.771D0 - 10.09D0 * S + 2.630D0 * S2
29107 DU = 3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3
29108 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
29109
29110C...dv :
29111 ND = 0.102D0 - 0.017D0 * S + 0.005D0 * S2
29112 AKD = 0.270D0 - 0.019D0 * S
29113 BKD = 0.260D0
29114 AD = 2.393D0 + 6.228D0 * S - 0.881D0 * S2
29115 BD = 46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3
29116 CD = 17.83D0 - 53.47D0 * S + 21.24D0 * S2
29117 DD = 4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3
29118 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
29119
29120C...del :
29121 NE = 0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3
29122 AKE = 0.409D0 - 0.007D0 * S
29123 BKE = 0.782D0 + 0.082D0 * S
29124 AE = -29.65D0 + 26.49D0 * S + 5.429D0 * S2
29125 BE = 90.20D0 - 74.97D0 * S + 4.526D0 * S2
29126 CE = 0.0D0
29127 DE = 8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3
29128 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
29129
29130C...udb :
29131 ALX = 0.877D0
29132 BEX = 0.561D0
29133 AKX = 0.275D0
29134 BKX = 0.0D0
29135 AGX = 0.997D0
29136 BGX = 3.210D0 - 1.866D0 * S
29137 CX = 7.300D0
29138 DX = 9.010D0 + 0.896D0 * DS + 0.222D0 * S2
29139 EX = 3.077D0 + 1.446D0 * S
29140 ESX = 3.173D0 - 2.445D0 * DS + 2.207D0 * S
29141 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
29142 & DX, EX, ESX)
29143
29144C...sb :
29145 STS = 0D0
29146 ALS = 0.756D0
29147 BES = 0.216D0
29148 AKS = 1.690D0 + 0.650D0 * DS - 0.922D0 * S
29149 AS = -4.329D0 + 1.131D0 * S
29150 BS = 9.568D0 - 1.744D0 * S
29151 DST = 9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2
29152 EST = 3.031D0 + 1.639D0 * S
29153 ESS = 5.837D0 + 0.815D0 * S
29154 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
29155
29156C...cb :
29157 STC = 0.820D0
29158 ALC = 0.98D0
29159 BEC = 0D0
29160 AKC = -0.625D0 - 0.523D0 * S
29161 AC = 0D0
29162 BC = 1.896D0 + 1.616D0 * S
29163 DCT = 4.12D0 + 0.683D0 * S
29164 ECT = 4.36D0 + 1.328D0 * S
29165 ESC = 0.677D0 + 0.679D0 * S
29166 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
29167
29168C...bb :
29169 STB = 1.297D0
29170 ALB = 0.99D0
29171 BEB = 0D0
29172 AKB = - 0.193D0 * S
29173 AB = 0D0
29174 BB = 0D0
29175 DBT = 3.447D0 + 0.927D0 * S
29176 EBT = 4.68D0 + 1.259D0 * S
29177 ESB = 1.892D0 + 2.199D0 * S
29178 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
29179
29180C...gl :
29181 ALG = 1.014D0
29182 BEG = 1.738D0
29183 AKG = 1.724D0 + 0.157D0 * S
29184 BKG = 0.800D0 + 1.016D0 * S
29185 AG = 7.517D0 - 2.547D0 * S
29186 BG = 34.09D0 - 52.21D0 * DS + 17.47D0 * S
29187 CG = 4.039D0 + 1.491D0 * S
29188 DG = 3.404D0 + 0.830D0 * S
29189 EG = -1.112D0 + 3.438D0 * S - 0.302D0 * S2
29190 ESG = 3.256D0 - 0.436D0 * S
29191 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
29192
29193 RETURN
29194 END
29195
29196C*********************************************************************
29197
29198C...PYGRVD
29199C...Gives the GRV 94 D (DIS) parton distribution function set
29200C...in parametrized form.
29201C...Authors: M. Glueck, E. Reya and A. Vogt.
29202
29203 SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
29204
29205C...Double precision declaration.
29206 IMPLICIT DOUBLE PRECISION (A - Z)
29207
29208C...Common expressions.
29209 MU2 = 0.34D0
29210 LAM2 = 0.248D0 * 0.248D0
29211 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
29212 DS = SQRT (S)
29213 S2 = S * S
29214 S3 = S2 * S
29215
29216C...uv :
29217 NU = 2.484D0 + 0.116D0 * S + 0.093D0 * S2
29218 AKU = 0.563D0 - 0.025D0 * S
29219 BKU = 0.054D0 + 0.154D0 * S
29220 AU = -0.326D0 - 0.058D0 * S - 0.135D0 * S2
29221 BU = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3
29222 CU = 11.52D0 - 12.99D0 * S + 3.161D0 * S2
29223 DU = 2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3
29224 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
29225
29226C...dv :
29227 ND = 0.156D0 - 0.017D0 * S
29228 AKD = 0.299D0 - 0.022D0 * S
29229 BKD = 0.259D0 - 0.015D0 * S
29230 AD = 3.445D0 + 1.278D0 * S + 0.326D0 * S2
29231 BD = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3
29232 CD = 55.45D0 - 69.92D0 * S + 20.78D0 * S2
29233 DD = 3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3
29234 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
29235
29236C...del :
29237 NE = 0.099D0 + 0.019D0 * S + 0.002D0 * S2
29238 AKE = 0.419D0 - 0.013D0 * S
29239 BKE = 1.064D0 - 0.038D0 * S
29240 AE = -44.00D0 + 98.70D0 * S - 14.79D0 * S2
29241 BE = 28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3
29242 CE = 84.57D0 - 108.8D0 * S + 31.52D0 * S2
29243 DE = 7.469D0 + 2.480D0 * S - 0.866D0 * S2
29244 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
29245
29246C...udb :
29247 ALX = 1.215D0
29248 BEX = 0.466D0
29249 AKX = 0.326D0 + 0.150D0 * S
29250 BKX = 0.956D0 + 0.405D0 * S
29251 AGX = 0.272D0
29252 BGX = 3.794D0 - 2.359D0 * DS
29253 CX = 2.014D0
29254 DX = 7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2
29255 EX = 3.049D0 + 1.597D0 * S
29256 ESX = 4.396D0 - 4.594D0 * DS + 3.268D0 * S
29257 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
29258 & DX, EX, ESX)
29259
29260C...sb :
29261 STS = 0D0
29262 ALS = 0.175D0
29263 BES = 0.344D0
29264 AKS = 1.415D0 - 0.641D0 * DS
29265 AS = 0.580D0 - 9.763D0 * DS + 6.795D0 * S - 0.558D0 * S2
29266 BS = 5.617D0 + 5.709D0 * DS - 3.972D0 * S
29267 DST = 13.78D0 - 9.581D0 * S + 5.370D0 * S2 - 0.996D0 * S3
29268 EST = 4.546D0 + 0.372D0 * S2
29269 ESS = 5.053D0 - 1.070D0 * S + 0.805D0 * S2
29270 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
29271
29272C...cb :
29273 STC = 0.820D0
29274 ALC = 0.98D0
29275 BEC = 0D0
29276 AKC = -0.625D0 - 0.523D0 * S
29277 AC = 0D0
29278 BC = 1.896D0 + 1.616D0 * S
29279 DCT = 4.12D0 + 0.683D0 * S
29280 ECT = 4.36D0 + 1.328D0 * S
29281 ESC = 0.677D0 + 0.679D0 * S
29282 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
29283
29284C...bb :
29285 STB = 1.297D0
29286 ALB = 0.99D0
29287 BEB = 0D0
29288 AKB = - 0.193D0 * S
29289 AB = 0D0
29290 BB = 0D0
29291 DBT = 3.447D0 + 0.927D0 * S
29292 EBT = 4.68D0 + 1.259D0 * S
29293 ESB = 1.892D0 + 2.199D0 * S
29294 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
29295
29296C...gl :
29297 ALG = 1.258D0
29298 BEG = 1.846D0
29299 AKG = 2.423D0
29300 BKG = 2.427D0 + 1.311D0 * S - 0.153D0 * S2
29301 AG = 25.09D0 - 7.935D0 * S
29302 BG = -14.84D0 - 124.3D0 * DS + 72.18D0 * S
29303 CG = 590.3D0 - 173.8D0 * S
29304 DG = 5.196D0 + 1.857D0 * S
29305 EG = -1.648D0 + 3.988D0 * S - 0.432D0 * S2
29306 ESG = 3.232D0 - 0.542D0 * S
29307 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
29308
29309 RETURN
29310 END
29311
29312C*********************************************************************
29313
29314C...PYGRVV
29315C...Auxiliary for the GRV 94 parton distribution functions
29316C...for u and d valence and d-u sea.
29317C...Authors: M. Glueck, E. Reya and A. Vogt.
29318
29319 FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D)
29320
29321C...Double precision declaration.
29322 IMPLICIT DOUBLE PRECISION (A - Z)
29323
29324C...Evaluation.
29325 DX = SQRT (X)
29326 PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) *
29327 & (1D0- X)**D
29328
29329 RETURN
29330 END
29331
29332C*********************************************************************
29333
29334C...PYGRVW
29335C...Auxiliary for the GRV 94 parton distribution functions
29336C...for d+u sea and gluon.
29337C...Authors: M. Glueck, E. Reya and A. Vogt.
29338
29339 FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
29340
29341C...Double precision declaration.
29342 IMPLICIT DOUBLE PRECISION (A - Z)
29343
29344C...Evaluation.
29345 LX = LOG (1D0/X)
29346 PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
29347 & * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D
29348
29349 RETURN
29350 END
29351
29352C*********************************************************************
29353
29354C...PYGRVS
29355C...Auxiliary for the GRV 94 parton distribution functions
29356C...for s, c and b sea.
29357C...Authors: M. Glueck, E. Reya and A. Vogt.
29358
29359 FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
29360
29361C...Double precision declaration.
29362 IMPLICIT DOUBLE PRECISION (A - Z)
29363
29364C...Evaluation.
29365 IF(S.LE.STH) THEN
29366 PYGRVS = 0D0
29367 ELSE
29368 DX = SQRT (X)
29369 LX = LOG (1D0/X)
29370 PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) *
29371 & (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX))
29372 ENDIF
29373
29374 RETURN
29375 END
29376
29377C*********************************************************************
29378
29379C...PYCT5L
29380C...Auxiliary function for parametrization of CTEQ5L.
29381C...Author: J. Pumplin 9/99.
29382
29383C...CTEQ5M1 and CTEQ5L Parton Distribution Functions
29384C...in Parametrized Form
29385C... September 15, 1999
29386C
29387C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON:
29388C... CTEQ5 PPARTON DISTRIBUTIONS"
29389C...hep-ph/9903282
29390
29391C...The CTEQ5M1 set given here is an updated version of the original
29392C...CTEQ5M set posted, in the table version, on the Web page of CTEQ.
29393C...The differences between CTEQ5M and CTEQ5M1 are insignificant for
29394C...almost all applications.
29395C...The improvement is in the QCD evolution which is now more
29396C...accurate, and which agrees completely with the benchmark work
29397C...of the HERA 96/97 Workshop.
29398C...The differences between the parametrized and the corresponding
29399C...table versions (on which it is based) are of similar order as
29400C...between the two version.
29401
29402C...!! Because accurate parametrizations over a wide range of (x,Q)
29403C...is hard to obtain, only the most widely used sets CTEQ5M and
29404C...CTEQ5L are available in parametrized form for now.
29405
29406C...These parametrizations were obtained by Jon Pumplin.
29407
29408C Iset PDF Description Alpha_s(Mz) Lam4 Lam5
29409C -------------------------------------------------------------------
29410C 1 CTEQ5M1 Standard NLO MSbar scheme 0.118 326 226
29411C 3 CTEQ5L Leading Order 0.127 192 146
29412C -------------------------------------------------------------------
29413C...Note the Qcd-lambda values given for CTEQ5L is for the leading
29414C...order form of Alpha_s!! Alpha_s(Mz) gives the absolute
29415C...calibration.
29416
29417C...The two Iset value are adopted to agree with the standard table
29418C...versions.
29419
29420C...Range of validity:
29421C...The range of (x, Q) covered by this parametrization of the QCD
29422C...evolved parton distributions is 1E-6 < x < 1 ;
29423C...1.1 GeV < Q < 10 TeV. Of course, the PDF's are constrained by
29424C...data only in a subset of that region; and the assumed DGLAP
29425C...evolution is unlikely to be valid for all of it either.
29426
29427C...The range of (x, Q) used in the CTEQ5 round of global analysis is
29428C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for
29429C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and
29430C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data.
29431
29432 FUNCTION PYCT5L(IFL,X,Q)
29433
29434C...Double precision declaration.
29435 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29436 IMPLICIT INTEGER(I-N)
29437
29438 PARAMETER (NEX=8, NLF=2)
29439 DIMENSION AM(0:NEX,0:NLF,-5:2)
29440 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
29441 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
29442 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
29443 DIMENSION AF(0:NEX)
29444
29445 DATA MEXVEC( 2) / 8 /
29446 DATA MLFVEC( 2) / 2 /
29447 DATA UT1VEC( 2) / 0.4971265E+01 /
29448 DATA UT2VEC( 2) / -0.1105128E+01 /
29449 DATA ALFVEC( 2) / 0.2987216E+00 /
29450 DATA QMAVEC( 2) / 0.0000000E+00 /
29451 DATA (AM( 0,K, 2),K=0, 2)
29452 & / 0.5292616E+01, -0.2751910E+01, -0.2488990E+01 /
29453 DATA (AM( 1,K, 2),K=0, 2)
29454 & / 0.9714424E+00, 0.1011827E-01, -0.1023660E-01 /
29455 DATA (AM( 2,K, 2),K=0, 2)
29456 & / -0.1651006E+02, 0.7959721E+01, 0.8810563E+01 /
29457 DATA (AM( 3,K, 2),K=0, 2)
29458 & / -0.1643394E+02, 0.5892854E+01, 0.9348874E+01 /
29459 DATA (AM( 4,K, 2),K=0, 2)
29460 & / 0.3067422E+02, 0.4235796E+01, -0.5112136E+00 /
29461 DATA (AM( 5,K, 2),K=0, 2)
29462 & / 0.2352526E+02, -0.5305168E+01, -0.1169174E+02 /
29463 DATA (AM( 6,K, 2),K=0, 2)
29464 & / -0.1095451E+02, 0.3006577E+01, 0.5638136E+01 /
29465 DATA (AM( 7,K, 2),K=0, 2)
29466 & / -0.1172251E+02, -0.2183624E+01, 0.4955794E+01 /
29467 DATA (AM( 8,K, 2),K=0, 2)
29468 & / 0.1662533E-01, 0.7622870E-02, -0.4895887E-03 /
29469
29470 DATA MEXVEC( 1) / 8 /
29471 DATA MLFVEC( 1) / 2 /
29472 DATA UT1VEC( 1) / 0.2612618E+01 /
29473 DATA UT2VEC( 1) / -0.1258304E+06 /
29474 DATA ALFVEC( 1) / 0.3407552E+00 /
29475 DATA QMAVEC( 1) / 0.0000000E+00 /
29476 DATA (AM( 0,K, 1),K=0, 2)
29477 & / 0.9905300E+00, -0.4502235E+00, 0.1624441E+00 /
29478 DATA (AM( 1,K, 1),K=0, 2)
29479 & / 0.8867534E+00, 0.1630829E-01, -0.4049085E-01 /
29480 DATA (AM( 2,K, 1),K=0, 2)
29481 & / 0.8547974E+00, 0.3336301E+00, 0.1371388E+00 /
29482 DATA (AM( 3,K, 1),K=0, 2)
29483 & / 0.2941113E+00, -0.1527905E+01, 0.2331879E+00 /
29484 DATA (AM( 4,K, 1),K=0, 2)
29485 & / 0.3384235E+02, 0.3715315E+01, 0.8276930E+00 /
29486 DATA (AM( 5,K, 1),K=0, 2)
29487 & / 0.6230115E+01, 0.3134639E+01, -0.1729099E+01 /
29488 DATA (AM( 6,K, 1),K=0, 2)
29489 & / -0.1186928E+01, -0.3282460E+00, 0.1052020E+00 /
29490 DATA (AM( 7,K, 1),K=0, 2)
29491 & / -0.8545702E+01, -0.6247947E+01, 0.3692561E+01 /
29492 DATA (AM( 8,K, 1),K=0, 2)
29493 & / 0.1724598E-01, 0.7120465E-02, 0.4003646E-04 /
29494
29495 DATA MEXVEC( 0) / 8 /
29496 DATA MLFVEC( 0) / 2 /
29497 DATA UT1VEC( 0) / -0.4656819E+00 /
29498 DATA UT2VEC( 0) / -0.2742390E+03 /
29499 DATA ALFVEC( 0) / 0.4491863E+00 /
29500 DATA QMAVEC( 0) / 0.0000000E+00 /
29501 DATA (AM( 0,K, 0),K=0, 2)
29502 & / 0.1193572E+03, -0.3886845E+01, -0.1133965E+01 /
29503 DATA (AM( 1,K, 0),K=0, 2)
29504 & / -0.9421449E+02, 0.3995885E+01, 0.1607363E+01 /
29505 DATA (AM( 2,K, 0),K=0, 2)
29506 & / 0.4206383E+01, 0.2485954E+00, 0.2497468E+00 /
29507 DATA (AM( 3,K, 0),K=0, 2)
29508 & / 0.1210557E+03, -0.3015765E+01, -0.1423651E+01 /
29509 DATA (AM( 4,K, 0),K=0, 2)
29510 & / -0.1013897E+03, -0.7113478E+00, 0.2621865E+00 /
29511 DATA (AM( 5,K, 0),K=0, 2)
29512 & / -0.1312404E+01, -0.9297691E+00, -0.1562531E+00 /
29513 DATA (AM( 6,K, 0),K=0, 2)
29514 & / 0.1627137E+01, 0.4954111E+00, -0.6387009E+00 /
29515 DATA (AM( 7,K, 0),K=0, 2)
29516 & / 0.1537698E+00, -0.2487878E+00, 0.8305947E+00 /
29517 DATA (AM( 8,K, 0),K=0, 2)
29518 & / 0.2496448E-01, 0.2457823E-02, 0.8234276E-03 /
29519
29520 DATA MEXVEC(-1) / 8 /
29521 DATA MLFVEC(-1) / 2 /
29522 DATA UT1VEC(-1) / 0.3862583E+01 /
29523 DATA UT2VEC(-1) / -0.1265969E+01 /
29524 DATA ALFVEC(-1) / 0.2457668E+00 /
29525 DATA QMAVEC(-1) / 0.0000000E+00 /
29526 DATA (AM( 0,K,-1),K=0, 2)
29527 & / 0.2647441E+02, 0.1059277E+02, -0.9176654E+00 /
29528 DATA (AM( 1,K,-1),K=0, 2)
29529 & / 0.1990636E+01, 0.8558918E-01, 0.4248667E-01 /
29530 DATA (AM( 2,K,-1),K=0, 2)
29531 & / -0.1476095E+02, -0.3276255E+02, 0.1558110E+01 /
29532 DATA (AM( 3,K,-1),K=0, 2)
29533 & / -0.2966889E+01, -0.3649037E+02, 0.1195914E+01 /
29534 DATA (AM( 4,K,-1),K=0, 2)
29535 & / -0.1000519E+03, -0.2464635E+01, 0.1964849E+00 /
29536 DATA (AM( 5,K,-1),K=0, 2)
29537 & / 0.3718331E+02, 0.4700389E+02, -0.2772142E+01 /
29538 DATA (AM( 6,K,-1),K=0, 2)
29539 & / -0.1872722E+02, -0.2291189E+02, 0.1089052E+01 /
29540 DATA (AM( 7,K,-1),K=0, 2)
29541 & / -0.1628146E+02, -0.1823993E+02, 0.2537369E+01 /
29542 DATA (AM( 8,K,-1),K=0, 2)
29543 & / -0.1156300E+01, -0.1280495E+00, 0.5153245E-01 /
29544
29545 DATA MEXVEC(-2) / 7 /
29546 DATA MLFVEC(-2) / 2 /
29547 DATA UT1VEC(-2) / 0.1895615E+00 /
29548 DATA UT2VEC(-2) / -0.3069097E+01 /
29549 DATA ALFVEC(-2) / 0.5293999E+00 /
29550 DATA QMAVEC(-2) / 0.0000000E+00 /
29551 DATA (AM( 0,K,-2),K=0, 2)
29552 & / -0.6556775E+00, 0.2490190E+00, 0.3966485E-01 /
29553 DATA (AM( 1,K,-2),K=0, 2)
29554 & / 0.1305102E+01, -0.1188925E+00, -0.4600870E-02 /
29555 DATA (AM( 2,K,-2),K=0, 2)
29556 & / -0.2371436E+01, 0.3566814E+00, -0.2834683E+00 /
29557 DATA (AM( 3,K,-2),K=0, 2)
29558 & / -0.6152826E+01, 0.8339877E+00, -0.7233230E+00 /
29559 DATA (AM( 4,K,-2),K=0, 2)
29560 & / -0.8346558E+01, 0.2892168E+01, 0.2137099E+00 /
29561 DATA (AM( 5,K,-2),K=0, 2)
29562 & / 0.1279530E+02, 0.1021114E+00, 0.5787439E+00 /
29563 DATA (AM( 6,K,-2),K=0, 2)
29564 & / 0.5858816E+00, -0.1940375E+01, -0.4029269E+00 /
29565 DATA (AM( 7,K,-2),K=0, 2)
29566 & / -0.2795725E+02, -0.5263392E+00, 0.1290229E+01 /
29567
29568 DATA MEXVEC(-3) / 7 /
29569 DATA MLFVEC(-3) / 2 /
29570 DATA UT1VEC(-3) / 0.3753257E+01 /
29571 DATA UT2VEC(-3) / -0.1113085E+01 /
29572 DATA ALFVEC(-3) / 0.3713141E+00 /
29573 DATA QMAVEC(-3) / 0.0000000E+00 /
29574 DATA (AM( 0,K,-3),K=0, 2)
29575 & / 0.1580931E+01, -0.2273826E+01, -0.1822245E+01 /
29576 DATA (AM( 1,K,-3),K=0, 2)
29577 & / 0.2702644E+01, 0.6763243E+00, 0.7231586E-02 /
29578 DATA (AM( 2,K,-3),K=0, 2)
29579 & / -0.1857924E+02, 0.3907500E+01, 0.5850109E+01 /
29580 DATA (AM( 3,K,-3),K=0, 2)
29581 & / -0.3044793E+02, 0.2639332E+01, 0.5566644E+01 /
29582 DATA (AM( 4,K,-3),K=0, 2)
29583 & / -0.4258011E+01, -0.5429244E+01, 0.4418946E+00 /
29584 DATA (AM( 5,K,-3),K=0, 2)
29585 & / 0.3465259E+02, -0.5532604E+01, -0.4904153E+01 /
29586 DATA (AM( 6,K,-3),K=0, 2)
29587 & / -0.1658858E+02, 0.2923275E+01, 0.2266286E+01 /
29588 DATA (AM( 7,K,-3),K=0, 2)
29589 & / -0.1149263E+02, 0.2877475E+01, -0.7999105E+00 /
29590
29591 DATA MEXVEC(-4) / 7 /
29592 DATA MLFVEC(-4) / 2 /
29593 DATA UT1VEC(-4) / 0.4400772E+01 /
29594 DATA UT2VEC(-4) / -0.1356116E+01 /
29595 DATA ALFVEC(-4) / 0.3712017E-01 /
29596 DATA QMAVEC(-4) / 0.1300000E+01 /
29597 DATA (AM( 0,K,-4),K=0, 2)
29598 & / -0.8293661E+00, -0.3982375E+01, -0.6494283E-01 /
29599 DATA (AM( 1,K,-4),K=0, 2)
29600 & / 0.2754618E+01, 0.8338636E+00, -0.6885160E-01 /
29601 DATA (AM( 2,K,-4),K=0, 2)
29602 & / -0.1657987E+02, 0.1439143E+02, -0.6887240E+00 /
29603 DATA (AM( 3,K,-4),K=0, 2)
29604 & / -0.2800703E+02, 0.1535966E+02, -0.7377693E+00 /
29605 DATA (AM( 4,K,-4),K=0, 2)
29606 & / -0.6460216E+01, -0.4783019E+01, 0.4913297E+00 /
29607 DATA (AM( 5,K,-4),K=0, 2)
29608 & / 0.3141830E+02, -0.3178031E+02, 0.7136013E+01 /
29609 DATA (AM( 6,K,-4),K=0, 2)
29610 & / -0.1802509E+02, 0.1862163E+02, -0.4632843E+01 /
29611 DATA (AM( 7,K,-4),K=0, 2)
29612 & / -0.1240412E+02, 0.2565386E+02, -0.1066570E+02 /
29613
29614 DATA MEXVEC(-5) / 6 /
29615 DATA MLFVEC(-5) / 2 /
29616 DATA UT1VEC(-5) / 0.5562568E+01 /
29617 DATA UT2VEC(-5) / -0.1801317E+01 /
29618 DATA ALFVEC(-5) / 0.4952010E-02 /
29619 DATA QMAVEC(-5) / 0.4500000E+01 /
29620 DATA (AM( 0,K,-5),K=0, 2)
29621 & / -0.6031237E+01, 0.1992727E+01, -0.1076331E+01 /
29622 DATA (AM( 1,K,-5),K=0, 2)
29623 & / 0.2933912E+01, 0.5839674E+00, 0.7509435E-01 /
29624 DATA (AM( 2,K,-5),K=0, 2)
29625 & / -0.8284919E+01, 0.1488593E+01, -0.8251678E+00 /
29626 DATA (AM( 3,K,-5),K=0, 2)
29627 & / -0.1925986E+02, 0.2805753E+01, -0.3015446E+01 /
29628 DATA (AM( 4,K,-5),K=0, 2)
29629 & / -0.9480483E+01, -0.9767837E+00, -0.1165544E+01 /
29630 DATA (AM( 5,K,-5),K=0, 2)
29631 & / 0.2193195E+02, -0.1788518E+02, 0.9460908E+01 /
29632 DATA (AM( 6,K,-5),K=0, 2)
29633 & / -0.1327377E+02, 0.1201754E+02, -0.6277844E+01 /
29634
29635 IF(Q .LE. QMAVEC(IFL)) THEN
29636 PYCT5L = 0.D0
29637 RETURN
29638 ENDIF
29639
29640 IF(X .GE. 1.D0) THEN
29641 PYCT5L = 0.D0
29642 RETURN
29643 ENDIF
29644
29645 TMP = LOG(Q/ALFVEC(IFL))
29646 IF(TMP .LE. 0.D0) THEN
29647 PYCT5L = 0.D0
29648 RETURN
29649 ENDIF
29650
29651 SB = LOG(TMP)
29652 SB1 = SB - 1.2D0
29653 SB2 = SB1*SB1
29654
29655 DO 110 I = 0, NEX
29656 AF(I) = 0.D0
29657 SBX = 1.D0
29658 DO 100 K = 0, MLFVEC(IFL)
29659 AF(I) = AF(I) + SBX*AM(I,K,IFL)
29660 SBX = SB1*SBX
29661 100 CONTINUE
29662 110 CONTINUE
29663
29664 Y = -LOG(X)
29665 U = LOG(X/0.00001D0)
29666
29667 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
29668 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
29669 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
29670 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
29671 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
29672
29673 PYCT5L = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
29674
29675C...Include threshold factor.
29676 PYCT5L = PYCT5L * (1.D0 - QMAVEC(IFL)/Q)
29677
29678 RETURN
29679 END
29680
29681C*********************************************************************
29682
29683C...PYCT5M
29684C...Auxiliary function for parametrization of CTEQ5M1.
29685C...Author: J. Pumplin 9/99.
29686
29687 FUNCTION PYCT5M(IFL,X,Q)
29688
29689C...Double precision declaration.
29690 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29691 IMPLICIT INTEGER(I-N)
29692
29693 PARAMETER (NEX=8, NLF=2)
29694 DIMENSION AM(0:NEX,0:NLF,-5:2)
29695 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
29696 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
29697 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
29698 DIMENSION AF(0:NEX)
29699
29700 DATA MEXVEC( 2) / 8 /
29701 DATA MLFVEC( 2) / 2 /
29702 DATA UT1VEC( 2) / 0.5141718E+01 /
29703 DATA UT2VEC( 2) / -0.1346944E+01 /
29704 DATA ALFVEC( 2) / 0.5260555E+00 /
29705 DATA QMAVEC( 2) / 0.0000000E+00 /
29706 DATA (AM( 0,K, 2),K=0, 2)
29707 & / 0.4289071E+01, -0.2536870E+01, -0.1259948E+01 /
29708 DATA (AM( 1,K, 2),K=0, 2)
29709 & / 0.9839410E+00, 0.4168426E-01, -0.5018952E-01 /
29710 DATA (AM( 2,K, 2),K=0, 2)
29711 & / -0.1651961E+02, 0.9246261E+01, 0.5996400E+01 /
29712 DATA (AM( 3,K, 2),K=0, 2)
29713 & / -0.2077936E+02, 0.9786469E+01, 0.7656465E+01 /
29714 DATA (AM( 4,K, 2),K=0, 2)
29715 & / 0.3054926E+02, 0.1889536E+01, 0.1380541E+01 /
29716 DATA (AM( 5,K, 2),K=0, 2)
29717 & / 0.3084695E+02, -0.1212303E+02, -0.1053551E+02 /
29718 DATA (AM( 6,K, 2),K=0, 2)
29719 & / -0.1426778E+02, 0.6239537E+01, 0.5254819E+01 /
29720 DATA (AM( 7,K, 2),K=0, 2)
29721 & / -0.1909811E+02, 0.3695678E+01, 0.5495729E+01 /
29722 DATA (AM( 8,K, 2),K=0, 2)
29723 & / 0.1889751E-01, 0.5027193E-02, 0.6624896E-03 /
29724
29725 DATA MEXVEC( 1) / 8 /
29726 DATA MLFVEC( 1) / 2 /
29727 DATA UT1VEC( 1) / 0.4138426E+01 /
29728 DATA UT2VEC( 1) / -0.3221374E+01 /
29729 DATA ALFVEC( 1) / 0.4960962E+00 /
29730 DATA QMAVEC( 1) / 0.0000000E+00 /
29731 DATA (AM( 0,K, 1),K=0, 2)
29732 & / 0.1332497E+01, -0.3703718E+00, 0.1288638E+00 /
29733 DATA (AM( 1,K, 1),K=0, 2)
29734 & / 0.7544687E+00, 0.3255075E-01, -0.4706680E-01 /
29735 DATA (AM( 2,K, 1),K=0, 2)
29736 & / -0.7638814E+00, 0.5008313E+00, -0.9237374E-01 /
29737 DATA (AM( 3,K, 1),K=0, 2)
29738 & / -0.3689889E+00, -0.1055098E+01, -0.4645065E+00 /
29739 DATA (AM( 4,K, 1),K=0, 2)
29740 & / 0.3991610E+02, 0.1979881E+01, 0.1775814E+01 /
29741 DATA (AM( 5,K, 1),K=0, 2)
29742 & / 0.6201080E+01, 0.2046288E+01, 0.3804571E+00 /
29743 DATA (AM( 6,K, 1),K=0, 2)
29744 & / -0.8027900E+00, -0.7011688E+00, -0.8049612E+00 /
29745 DATA (AM( 7,K, 1),K=0, 2)
29746 & / -0.8631305E+01, -0.3981200E+01, 0.6970153E+00 /
29747 DATA (AM( 8,K, 1),K=0, 2)
29748 & / 0.2371230E-01, 0.5372683E-02, 0.1118701E-02 /
29749
29750 DATA MEXVEC( 0) / 8 /
29751 DATA MLFVEC( 0) / 2 /
29752 DATA UT1VEC( 0) / -0.1026789E+01 /
29753 DATA UT2VEC( 0) / -0.9051707E+01 /
29754 DATA ALFVEC( 0) / 0.9462977E+00 /
29755 DATA QMAVEC( 0) / 0.0000000E+00 /
29756 DATA (AM( 0,K, 0),K=0, 2)
29757 & / 0.1191990E+03, -0.8548739E+00, -0.1963040E+01 /
29758 DATA (AM( 1,K, 0),K=0, 2)
29759 & / -0.9449972E+02, 0.1074771E+01, 0.2056055E+01 /
29760 DATA (AM( 2,K, 0),K=0, 2)
29761 & / 0.3701064E+01, -0.1167947E-02, 0.1933573E+00 /
29762 DATA (AM( 3,K, 0),K=0, 2)
29763 & / 0.1171345E+03, -0.1064540E+01, -0.1875312E+01 /
29764 DATA (AM( 4,K, 0),K=0, 2)
29765 & / -0.1014453E+03, -0.5707427E+00, 0.4511242E-01 /
29766 DATA (AM( 5,K, 0),K=0, 2)
29767 & / 0.6365168E+01, 0.1275354E+01, -0.4964081E+00 /
29768 DATA (AM( 6,K, 0),K=0, 2)
29769 & / -0.3370693E+01, -0.1122020E+01, 0.5947751E-01 /
29770 DATA (AM( 7,K, 0),K=0, 2)
29771 & / -0.5327270E+01, -0.9293556E+00, 0.6629940E+00 /
29772 DATA (AM( 8,K, 0),K=0, 2)
29773 & / 0.2437513E-01, 0.1600939E-02, 0.6855336E-03 /
29774
29775 DATA MEXVEC(-1) / 8 /
29776 DATA MLFVEC(-1) / 2 /
29777 DATA UT1VEC(-1) / 0.5243571E+01 /
29778 DATA UT2VEC(-1) / -0.2870513E+01 /
29779 DATA ALFVEC(-1) / 0.6701448E+00 /
29780 DATA QMAVEC(-1) / 0.0000000E+00 /
29781 DATA (AM( 0,K,-1),K=0, 2)
29782 & / 0.2428863E+02, 0.1907035E+01, -0.4606457E+00 /
29783 DATA (AM( 1,K,-1),K=0, 2)
29784 & / 0.2006810E+01, -0.1265915E+00, 0.7153556E-02 /
29785 DATA (AM( 2,K,-1),K=0, 2)
29786 & / -0.1884546E+02, -0.2339471E+01, 0.5740679E+01 /
29787 DATA (AM( 3,K,-1),K=0, 2)
29788 & / -0.2527892E+02, -0.2044124E+01, 0.1280470E+02 /
29789 DATA (AM( 4,K,-1),K=0, 2)
29790 & / -0.1013824E+03, -0.1594199E+01, 0.2216401E+00 /
29791 DATA (AM( 5,K,-1),K=0, 2)
29792 & / 0.8070930E+02, 0.1792072E+01, -0.2164364E+02 /
29793 DATA (AM( 6,K,-1),K=0, 2)
29794 & / -0.4641050E+02, 0.1977338E+00, 0.1273014E+02 /
29795 DATA (AM( 7,K,-1),K=0, 2)
29796 & / -0.3910568E+02, 0.1719632E+01, 0.1086525E+02 /
29797 DATA (AM( 8,K,-1),K=0, 2)
29798 & / -0.1185496E+01, -0.1905847E+00, -0.8744118E-03 /
29799
29800 DATA MEXVEC(-2) / 7 /
29801 DATA MLFVEC(-2) / 2 /
29802 DATA UT1VEC(-2) / 0.4782210E+01 /
29803 DATA UT2VEC(-2) / -0.1976856E+02 /
29804 DATA ALFVEC(-2) / 0.7558374E+00 /
29805 DATA QMAVEC(-2) / 0.0000000E+00 /
29806 DATA (AM( 0,K,-2),K=0, 2)
29807 & / -0.6216935E+00, 0.2369963E+00, -0.7909949E-02 /
29808 DATA (AM( 1,K,-2),K=0, 2)
29809 & / 0.1245440E+01, -0.1031510E+00, 0.4916523E-02 /
29810 DATA (AM( 2,K,-2),K=0, 2)
29811 & / -0.7060824E+01, -0.3875283E-01, 0.1784981E+00 /
29812 DATA (AM( 3,K,-2),K=0, 2)
29813 & / -0.7430595E+01, 0.1964572E+00, -0.1284999E+00 /
29814 DATA (AM( 4,K,-2),K=0, 2)
29815 & / -0.6897810E+01, 0.2620543E+01, 0.8012553E-02 /
29816 DATA (AM( 5,K,-2),K=0, 2)
29817 & / 0.1507713E+02, 0.2340307E-01, 0.2482535E+01 /
29818 DATA (AM( 6,K,-2),K=0, 2)
29819 & / -0.1815341E+01, -0.1538698E+01, -0.2014208E+01 /
29820 DATA (AM( 7,K,-2),K=0, 2)
29821 & / -0.2571932E+02, 0.2903941E+00, -0.2848206E+01 /
29822
29823 DATA MEXVEC(-3) / 7 /
29824 DATA MLFVEC(-3) / 2 /
29825 DATA UT1VEC(-3) / 0.4518239E+01 /
29826 DATA UT2VEC(-3) / -0.2690590E+01 /
29827 DATA ALFVEC(-3) / 0.6124079E+00 /
29828 DATA QMAVEC(-3) / 0.0000000E+00 /
29829 DATA (AM( 0,K,-3),K=0, 2)
29830 & / -0.2734458E+01, -0.7245673E+00, -0.6351374E+00 /
29831 DATA (AM( 1,K,-3),K=0, 2)
29832 & / 0.2927174E+01, 0.4822709E+00, -0.1088787E-01 /
29833 DATA (AM( 2,K,-3),K=0, 2)
29834 & / -0.1771017E+02, -0.1416635E+01, 0.8467622E+01 /
29835 DATA (AM( 3,K,-3),K=0, 2)
29836 & / -0.4972782E+02, -0.3348547E+01, 0.1767061E+02 /
29837 DATA (AM( 4,K,-3),K=0, 2)
29838 & / -0.7102770E+01, -0.3205337E+01, 0.4101704E+00 /
29839 DATA (AM( 5,K,-3),K=0, 2)
29840 & / 0.7169698E+02, -0.2205985E+01, -0.2463931E+02 /
29841 DATA (AM( 6,K,-3),K=0, 2)
29842 & / -0.4090347E+02, 0.2103486E+01, 0.1416507E+02 /
29843 DATA (AM( 7,K,-3),K=0, 2)
29844 & / -0.2952639E+02, 0.5376136E+01, 0.7825585E+01 /
29845
29846 DATA MEXVEC(-4) / 7 /
29847 DATA MLFVEC(-4) / 2 /
29848 DATA UT1VEC(-4) / 0.2783230E+01 /
29849 DATA UT2VEC(-4) / -0.1746328E+01 /
29850 DATA ALFVEC(-4) / 0.1115653E+01 /
29851 DATA QMAVEC(-4) / 0.1300000E+01 /
29852 DATA (AM( 0,K,-4),K=0, 2)
29853 & / -0.1743872E+01, -0.1128921E+01, -0.2841969E+00 /
29854 DATA (AM( 1,K,-4),K=0, 2)
29855 & / 0.3345755E+01, 0.3187765E+00, 0.1378124E+00 /
29856 DATA (AM( 2,K,-4),K=0, 2)
29857 & / -0.2037615E+02, 0.4121687E+01, 0.2236520E+00 /
29858 DATA (AM( 3,K,-4),K=0, 2)
29859 & / -0.4703104E+02, 0.5353087E+01, -0.1455347E+01 /
29860 DATA (AM( 4,K,-4),K=0, 2)
29861 & / -0.1060230E+02, -0.1551122E+01, -0.1078863E+01 /
29862 DATA (AM( 5,K,-4),K=0, 2)
29863 & / 0.5088892E+02, -0.8197304E+01, 0.8083451E+01 /
29864 DATA (AM( 6,K,-4),K=0, 2)
29865 & / -0.2819070E+02, 0.4554086E+01, -0.5890995E+01 /
29866 DATA (AM( 7,K,-4),K=0, 2)
29867 & / -0.1098238E+02, 0.2590096E+01, -0.8062879E+01 /
29868
29869 DATA MEXVEC(-5) / 6 /
29870 DATA MLFVEC(-5) / 2 /
29871 DATA UT1VEC(-5) / 0.1619654E+02 /
29872 DATA UT2VEC(-5) / -0.3367346E+01 /
29873 DATA ALFVEC(-5) / 0.5109891E-02 /
29874 DATA QMAVEC(-5) / 0.4500000E+01 /
29875 DATA (AM( 0,K,-5),K=0, 2)
29876 & / -0.6800138E+01, 0.2493627E+01, -0.1075724E+01 /
29877 DATA (AM( 1,K,-5),K=0, 2)
29878 & / 0.3036555E+01, 0.3324733E+00, 0.2008298E+00 /
29879 DATA (AM( 2,K,-5),K=0, 2)
29880 & / -0.5203879E+01, -0.8493476E+01, -0.4523208E+01 /
29881 DATA (AM( 3,K,-5),K=0, 2)
29882 & / -0.1524239E+01, -0.3411912E+01, -0.1771867E+02 /
29883 DATA (AM( 4,K,-5),K=0, 2)
29884 & / -0.1099444E+02, 0.1320930E+01, -0.2353831E+01 /
29885 DATA (AM( 5,K,-5),K=0, 2)
29886 & / 0.1699299E+02, -0.3565802E+02, 0.3566872E+02 /
29887 DATA (AM( 6,K,-5),K=0, 2)
29888 & / -0.1465793E+02, 0.2703365E+02, -0.2176372E+02 /
29889
29890 IF(Q .LE. QMAVEC(IFL)) THEN
29891 PYCT5M = 0.D0
29892 RETURN
29893 ENDIF
29894
29895 IF(X .GE. 1.D0) THEN
29896 PYCT5M = 0.D0
29897 RETURN
29898 ENDIF
29899
29900 TMP = LOG(Q/ALFVEC(IFL))
29901 IF(TMP .LE. 0.D0) THEN
29902 PYCT5M = 0.D0
29903 RETURN
29904 ENDIF
29905
29906 SB = LOG(TMP)
29907 SB1 = SB - 1.2D0
29908 SB2 = SB1*SB1
29909
29910 DO 110 I = 0, NEX
29911 AF(I) = 0.D0
29912 SBX = 1.D0
29913 DO 100 K = 0, MLFVEC(IFL)
29914 AF(I) = AF(I) + SBX*AM(I,K,IFL)
29915 SBX = SB1*SBX
29916 100 CONTINUE
29917 110 CONTINUE
29918
29919 Y = -LOG(X)
29920 U = LOG(X/0.00001D0)
29921
29922 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
29923 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
29924 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
29925 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
29926 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
29927
29928 PYCT5M = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
29929
29930C...Include threshold factor.
29931 PYCT5M = PYCT5M * (1.D0 - QMAVEC(IFL)/Q)
29932
29933 RETURN
29934 END
29935
29936C*********************************************************************
29937
29938C...PYPDPO
29939C...Auxiliary to PYPDPR. Gives proton parton distributions according to
29940C...a few older parametrizations, now obsolete but convenient for
29941C...backwards checks.
29942
29943 SUBROUTINE PYPDPO(X,Q2,XPPR)
29944
29945C...Double precision and integer declarations.
29946 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29947 IMPLICIT INTEGER(I-N)
29948 INTEGER PYK,PYCHGE,PYCOMP
29949C...Commonblocks.
29950 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29951 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29952 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29953 COMMON/PYINT1/MINT(400),VINT(400)
29954 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
29955 DIMENSION XPPR(-6:6),XQ(9),TX(6),TT(6),TS(6),NEHLQ(8,2),
29956 &CEHLQ(6,6,2,8,2),CDO(3,6,5,2)
29957
29958
29959C...The following data lines are coefficients needed in the
29960C...Eichten, Hinchliffe, Lane, Quigg proton structure function
29961C...parametrizations, see below.
29962C...Powers of 1-x in different cases.
29963 DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
29964C...Expansion coefficients for up valence quark distribution.
29965 DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
29966 1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04,
29967 2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03,
29968 3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03,
29969 4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03,
29970 5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03,
29971 6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04,
29972 1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04,
29973 2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03,
29974 3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04,
29975 4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04,
29976 5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05,
29977 6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/
29978 DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
29979 1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04,
29980 2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03,
29981 3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03,
29982 4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03,
29983 5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03,
29984 6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04,
29985 1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04,
29986 2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03,
29987 3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04,
29988 4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04,
29989 5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05,
29990 6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/
29991C...Expansion coefficients for down valence quark distribution.
29992 DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
29993 1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04,
29994 2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03,
29995 3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03,
29996 4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03,
29997 5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04,
29998 6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04,
29999 1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04,
30000 2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03,
30001 3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04,
30002 4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04,
30003 5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05,
30004 6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/
30005 DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
30006 1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04,
30007 2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03,
30008 3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03,
30009 4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03,
30010 5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04,
30011 6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04,
30012 1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04,
30013 2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03,
30014 3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04,
30015 4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04,
30016 5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05,
30017 6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/
30018C...Expansion coefficients for up and down sea quark distributions.
30019 DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
30020 1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04,
30021 2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03,
30022 3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05,
30023 4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04,
30024 5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04,
30025 6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05,
30026 1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04,
30027 2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03,
30028 3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04,
30029 4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05,
30030 5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00,
30031 6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/
30032 DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
30033 1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04,
30034 2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03,
30035 3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04,
30036 4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04,
30037 5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04,
30038 6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04,
30039 1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03,
30040 2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03,
30041 3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04,
30042 4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05,
30043 5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05,
30044 6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/
30045C...Expansion coefficients for gluon distribution.
30046 DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
30047 1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02,
30048 2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02,
30049 3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02,
30050 4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03,
30051 5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04,
30052 6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03,
30053 1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02,
30054 2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02,
30055 3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02,
30056 4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03,
30057 5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03,
30058 6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/
30059 DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
30060 1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02,
30061 2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02,
30062 3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02,
30063 4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02,
30064 5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02,
30065 6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02,
30066 1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02,
30067 2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01,
30068 3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02,
30069 4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03,
30070 5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03,
30071 6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/
30072C...Expansion coefficients for strange sea quark distribution.
30073 DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
30074 1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04,
30075 2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03,
30076 3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04,
30077 4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04,
30078 5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04,
30079 6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05,
30080 1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04,
30081 2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03,
30082 3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04,
30083 4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05,
30084 5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00,
30085 6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/
30086 DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
30087 1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04,
30088 2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03,
30089 3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04,
30090 4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04,
30091 5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04,
30092 6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04,
30093 1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03,
30094 2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03,
30095 3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04,
30096 4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05,
30097 5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05,
30098 6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/
30099C...Expansion coefficients for charm sea quark distribution.
30100 DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
30101 1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03,
30102 2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03,
30103 3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04,
30104 4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05,
30105 5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05,
30106 6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05,
30107 1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04,
30108 2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03,
30109 3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04,
30110 4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04,
30111 5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05,
30112 6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/
30113 DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
30114 1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03,
30115 2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03,
30116 3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04,
30117 4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05,
30118 5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05,
30119 6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05,
30120 1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03,
30121 2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03,
30122 3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04,
30123 4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04,
30124 5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05,
30125 6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/
30126C...Expansion coefficients for bottom sea quark distribution.
30127 DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
30128 1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03,
30129 2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04,
30130 3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04,
30131 4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05,
30132 5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05,
30133 6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05,
30134 1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03,
30135 2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03,
30136 3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04,
30137 4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05,
30138 5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05,
30139 6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/
30140 DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
30141 1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03,
30142 2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04,
30143 3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04,
30144 4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05,
30145 5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00,
30146 6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05,
30147 1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03,
30148 2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03,
30149 3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04,
30150 4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05,
30151 5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05,
30152 6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/
30153C...Expansion coefficients for top sea quark distribution.
30154 DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
30155 1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04,
30156 2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04,
30157 3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04,
30158 4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00,
30159 5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05,
30160 6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
30161 1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03,
30162 2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03,
30163 3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04,
30164 4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05,
30165 5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00,
30166 6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/
30167 DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
30168 1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04,
30169 2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04,
30170 3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04,
30171 4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00,
30172 5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05,
30173 6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
30174 1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03,
30175 2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03,
30176 3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04,
30177 4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05,
30178 5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00,
30179 6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/
30180
30181C...The following data lines are coefficients needed in the
30182C...Duke, Owens proton structure function parametrizations, see below.
30183C...Expansion coefficients for (up+down) valence quark distribution.
30184 DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/
30185 1 4.190D-01, 3.460D+00, 4.400D+00, 0.000D+00, 0.000D+00, 0.000D+00,
30186 2 4.000D-03, 7.240D-01,-4.860D+00, 0.000D+00, 0.000D+00, 0.000D+00,
30187 3-7.000D-03,-6.600D-02, 1.330D+00, 0.000D+00, 0.000D+00, 0.000D+00/
30188 DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/
30189 1 3.740D-01, 3.330D+00, 6.030D+00, 0.000D+00, 0.000D+00, 0.000D+00,
30190 2 1.400D-02, 7.530D-01,-6.220D+00, 0.000D+00, 0.000D+00, 0.000D+00,
30191 3 0.000D+00,-7.600D-02, 1.560D+00, 0.000D+00, 0.000D+00, 0.000D+00/
30192C...Expansion coefficients for down valence quark distribution.
30193 DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/
30194 1 7.630D-01, 4.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
30195 2-2.370D-01, 6.270D-01,-4.210D-01, 0.000D+00, 0.000D+00, 0.000D+00,
30196 3 2.600D-02,-1.900D-02, 3.300D-02, 0.000D+00, 0.000D+00, 0.000D+00/
30197 DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/
30198 1 7.610D-01, 3.830D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
30199 2-2.320D-01, 6.270D-01,-4.180D-01, 0.000D+00, 0.000D+00, 0.000D+00,
30200 3 2.300D-02,-1.900D-02, 3.600D-02, 0.000D+00, 0.000D+00, 0.000D+00/
30201C...Expansion coefficients for (up+down+strange) sea quark distribution.
30202 DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/
30203 1 1.265D+00, 0.000D+00, 8.050D+00, 0.000D+00, 0.000D+00, 0.000D+00,
30204 2-1.132D+00,-3.720D-01, 1.590D+00, 6.310D+00,-1.050D+01, 1.470D+01,
30205 3 2.930D-01,-2.900D-02,-1.530D-01,-2.730D-01,-3.170D+00, 9.800D+00/
30206 DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/
30207 1 1.670D+00, 0.000D+00, 9.150D+00, 0.000D+00, 0.000D+00, 0.000D+00,
30208 2-1.920D+00,-2.730D-01, 5.300D-01, 1.570D+01,-1.010D+02, 2.230D+02,
30209 3 5.820D-01,-1.640D-01,-7.630D-01,-2.830D+00, 4.470D+01,-1.170D+02/
30210C...Expansion coefficients for charm sea quark distribution.
30211 DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/
30212 1 0.000D+00,-3.600D-02, 6.350D+00, 0.000D+00, 0.000D+00, 0.000D+00,
30213 2 1.350D-01,-2.220D-01, 3.260D+00,-3.030D+00, 1.740D+01,-1.790D+01,
30214 3-7.500D-02,-5.800D-02,-9.090D-01, 1.500D+00,-1.130D+01, 1.560D+01/
30215 DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/
30216 1 0.000D+00,-1.200D-01, 3.510D+00, 0.000D+00, 0.000D+00, 0.000D+00,
30217 2 6.700D-02,-2.330D-01, 3.660D+00,-4.740D-01, 9.500D+00,-1.660D+01,
30218 3-3.100D-02,-2.300D-02,-4.530D-01, 3.580D-01,-5.430D+00, 1.550D+01/
30219C...Expansion coefficients for gluon distribution.
30220 DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/
30221 1 1.560D+00, 0.000D+00, 6.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
30222 2-1.710D+00,-9.490D-01, 1.440D+00,-7.190D+00,-1.650D+01, 1.530D+01,
30223 3 6.380D-01, 3.250D-01,-1.050D+00, 2.550D-01, 1.090D+01,-1.010D+01/
30224 DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/
30225 1 8.790D-01, 0.000D+00, 4.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
30226 2-9.710D-01,-1.160D+00, 1.230D+00,-5.640D+00,-7.540D+00,-5.960D-01,
30227 3 4.340D-01, 4.760D-01,-2.540D-01,-8.170D-01, 5.500D+00, 1.260D-01/
30228
30229C...Euler's beta function, requires ordinary Gamma function
30230 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
30231
30232C...Leading order proton parton distributions from Glueck, Reya and
30233C...Vogt. Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
30234C...10^-5 < x < 1.
30235 IF(MSTP(51).EQ.11) THEN
30236
30237C...Determine s expansion variable and some x expressions.
30238 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
30239 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
30240 SD2=SD**2
30241 XL=-LOG(X)
30242 XS=SQRT(X)
30243
30244C...Evaluate valence, gluon and sea distributions.
30245 XFVUD=(0.663D0+0.191D0*SD-0.041D0*SD2+0.031D0*SD**3)*
30246 & X**0.326D0*(1D0+(-1.97D0+6.74D0*SD-1.96D0*SD2)*XS+
30247 & (24.4D0-20.7D0*SD+4.08D0*SD2)*X)*
30248 & (1D0-X)**(2.86D0+0.70D0*SD-0.02D0*SD2)
30249 XFVDD=(0.579D0+0.283D0*SD+0.047D0*SD2)*X**(0.523D0-0.015D0*SD)*
30250 & (1D0+(2.22D0-0.59D0*SD-0.27D0*SD2)*XS+(5.95D0-6.19D0*SD+
30251 & 1.55D0*SD2)*X)*(1D0-X)**(3.57D0+0.94D0*SD-0.16D0*SD2)
30252 XFGLU=(X**(1.00D0-0.17D0*SD)*((4.879D0*SD-1.383D0*SD2)+
30253 & (25.92D0-28.97D0*SD+5.596D0*SD2)*X+(-25.69D0+23.68D0*SD-
30254 & 1.975D0*SD2)*X**2)+SD**0.558D0*EXP(-(0.595D0+2.138D0*SD)+
30255 & SQRT(4.066D0*SD**1.218D0*XL)))*
30256 & (1D0-X)**(2.537D0+1.718D0*SD+0.353D0*SD2)
30257 XFSEA=(X**(0.412D0-0.171D0*SD)*(0.363D0-1.196D0*X+(1.029D0+
30258 & 1.785D0*SD-0.459D0*SD2)*X**2)*XL**(0.566D0-0.496D0*SD)+
30259 & SD**1.396D0*EXP(-(3.838D0+1.944D0*SD)+SQRT(2.845D0*SD**1.331D0*
30260 & XL)))*(1D0-X)**(4.696D0+2.109D0*SD)
30261 XFSTR=SD**0.803D0*(1D0+(-3.055D0+1.024D0*SD**0.67D0)*XS+
30262 & (27.4D0-20.0D0*SD**0.154D0)*X)*(1D0-X)**6.22D0*
30263 & EXP(-(4.33D0+1.408D0*SD)+SQRT((8.27D0-0.437D0*SD)*
30264 & SD**0.563D0*XL))/XL**(2.082D0-0.577D0*SD)
30265 IF(SD.LE.0.888D0) THEN
30266 XFCHM=0D0
30267 ELSE
30268 XFCHM=(SD-0.888D0)**1.01D0*(1.+(4.24D0-0.804D0*SD)*X)*
30269 & (1D0-X)**(3.46D0+1.076D0*SD)*EXP(-(4.61D0+1.49D0*SD)+
30270 & SQRT((2.555D0+1.961D0*SD)*SD**0.37D0*XL))
30271 ENDIF
30272 IF(SD.LE.1.351D0) THEN
30273 XFBOT=0D0
30274 ELSE
30275 XFBOT=(SD-1.351D0)*(1D0+1.848D0*X)*(1D0-X)**(2.929D0+
30276 & 1.396D0*SD)*EXP(-(4.71D0+1.514D0*SD)+
30277 & SQRT((4.02D0+1.239D0*SD)*SD**0.51D0*XL))
30278 ENDIF
30279
30280C...Put into output array.
30281 XPPR(0)=XFGLU
30282 XPPR(1)=XFVDD+XFSEA
30283 XPPR(2)=XFVUD-XFVDD+XFSEA
30284 XPPR(3)=XFSTR
30285 XPPR(4)=XFCHM
30286 XPPR(5)=XFBOT
30287 XPPR(-1)=XFSEA
30288 XPPR(-2)=XFSEA
30289 XPPR(-3)=XFSTR
30290 XPPR(-4)=XFCHM
30291 XPPR(-5)=XFBOT
30292
30293C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg.
30294C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1
30295 ELSEIF(MSTP(51).EQ.12.OR.MSTP(51).EQ.13) THEN
30296
30297C...Determine set, Lambda and x and t expansion variables.
30298 NSET=MSTP(51)-11
30299 IF(NSET.EQ.1) ALAM=0.2D0
30300 IF(NSET.EQ.2) ALAM=0.29D0
30301 TMIN=LOG(5D0/ALAM**2)
30302 TMAX=LOG(1D8/ALAM**2)
30303 T=LOG(MAX(1D0,Q2/ALAM**2))
30304 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
30305 NX=1
30306 IF(X.LE.0.1D0) NX=2
30307 IF(NX.EQ.1) VX=(2D0*X-1.1D0)/0.9D0
30308 IF(NX.EQ.2) VX=MAX(-1D0,(2D0*LOG(X)+11.51293D0)/6.90776D0)
30309
30310C...Chebyshev polynomials for x and t expansion.
30311 TX(1)=1D0
30312 TX(2)=VX
30313 TX(3)=2D0*VX**2-1D0
30314 TX(4)=4D0*VX**3-3D0*VX
30315 TX(5)=8D0*VX**4-8D0*VX**2+1D0
30316 TX(6)=16D0*VX**5-20D0*VX**3+5D0*VX
30317 TT(1)=1D0
30318 TT(2)=VT
30319 TT(3)=2D0*VT**2-1D0
30320 TT(4)=4D0*VT**3-3D0*VT
30321 TT(5)=8D0*VT**4-8D0*VT**2+1D0
30322 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
30323
30324C...Calculate structure functions.
30325 DO 120 KFL=1,6
30326 XQSUM=0D0
30327 DO 110 IT=1,6
30328 DO 100 IX=1,6
30329 XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)
30330 100 CONTINUE
30331 110 CONTINUE
30332 XQ(KFL)=XQSUM*(1D0-X)**NEHLQ(KFL,NSET)
30333 120 CONTINUE
30334
30335C...Put into output array.
30336 XPPR(0)=XQ(4)
30337 XPPR(1)=XQ(2)+XQ(3)
30338 XPPR(2)=XQ(1)+XQ(3)
30339 XPPR(3)=XQ(5)
30340 XPPR(4)=XQ(6)
30341 XPPR(-1)=XQ(3)
30342 XPPR(-2)=XQ(3)
30343 XPPR(-3)=XQ(5)
30344 XPPR(-4)=XQ(6)
30345
30346C...Special expansion for bottom (threshold effects).
30347 IF(MSTP(58).GE.5) THEN
30348 IF(NSET.EQ.1) TMIN=8.1905D0
30349 IF(NSET.EQ.2) TMIN=7.4474D0
30350 IF(T.GT.TMIN) THEN
30351 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
30352 TT(1)=1D0
30353 TT(2)=VT
30354 TT(3)=2D0*VT**2-1D0
30355 TT(4)=4D0*VT**3-3D0*VT
30356 TT(5)=8D0*VT**4-8D0*VT**2+1D0
30357 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
30358 XQSUM=0D0
30359 DO 140 IT=1,6
30360 DO 130 IX=1,6
30361 XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)
30362 130 CONTINUE
30363 140 CONTINUE
30364 XPPR(5)=XQSUM*(1D0-X)**NEHLQ(7,NSET)
30365 XPPR(-5)=XPPR(5)
30366 ENDIF
30367 ENDIF
30368
30369C...Special expansion for top (threshold effects).
30370 IF(MSTP(58).GE.6) THEN
30371 IF(NSET.EQ.1) TMIN=11.5528D0
30372 IF(NSET.EQ.2) TMIN=10.8097D0
30373 TMIN=TMIN+2D0*LOG(PMAS(6,1)/30D0)
30374 TMAX=TMAX+2D0*LOG(PMAS(6,1)/30D0)
30375 IF(T.GT.TMIN) THEN
30376 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
30377 TT(1)=1D0
30378 TT(2)=VT
30379 TT(3)=2D0*VT**2-1D0
30380 TT(4)=4D0*VT**3-3D0*VT
30381 TT(5)=8D0*VT**4-8D0*VT**2+1D0
30382 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
30383 XQSUM=0D0
30384 DO 160 IT=1,6
30385 DO 150 IX=1,6
30386 XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)
30387 150 CONTINUE
30388 160 CONTINUE
30389 XPPR(6)=XQSUM*(1D0-X)**NEHLQ(8,NSET)
30390 XPPR(-6)=XPPR(6)
30391 ENDIF
30392 ENDIF
30393
30394C...Proton parton distributions from Duke, Owens.
30395C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2.
30396 ELSEIF(MSTP(51).EQ.14.OR.MSTP(51).EQ.15) THEN
30397
30398C...Determine set, Lambda and s expansion parameter.
30399 NSET=MSTP(51)-13
30400 IF(NSET.EQ.1) ALAM=0.2D0
30401 IF(NSET.EQ.2) ALAM=0.4D0
30402 Q2IN=MIN(1D6,MAX(4D0,Q2))
30403 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
30404
30405C...Calculate structure functions.
30406 DO 180 KFL=1,5
30407 DO 170 IS=1,6
30408 TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+
30409 & CDO(3,IS,KFL,NSET)*SD**2
30410 170 CONTINUE
30411 IF(KFL.LE.2) THEN
30412 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)*(1D0+TS(3)*X)/(EULBET(TS(1),
30413 & TS(2)+1D0)*(1D0+TS(3)*TS(1)/(TS(1)+TS(2)+1D0)))
30414 ELSE
30415 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
30416 & TS(5)*X**2+TS(6)*X**3)
30417 ENDIF
30418 180 CONTINUE
30419
30420C...Put into output arrays.
30421 XPPR(0)=XQ(5)
30422 XPPR(1)=XQ(2)+XQ(3)/6D0
30423 XPPR(2)=3D0*XQ(1)-XQ(2)+XQ(3)/6D0
30424 XPPR(3)=XQ(3)/6D0
30425 XPPR(4)=XQ(4)
30426 XPPR(-1)=XQ(3)/6D0
30427 XPPR(-2)=XQ(3)/6D0
30428 XPPR(-3)=XQ(3)/6D0
30429 XPPR(-4)=XQ(4)
30430
30431 ENDIF
30432
30433 RETURN
30434 END
30435
30436C*********************************************************************
30437
30438C...PYHFTH
30439C...Gives threshold attractive/repulsive factor for heavy flavour
30440C...production.
30441
30442 FUNCTION PYHFTH(SH,SQM,FRATT)
30443
30444C...Double precision and integer declarations.
30445 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30446 IMPLICIT INTEGER(I-N)
30447 INTEGER PYK,PYCHGE,PYCOMP
30448C...Commonblocks.
30449 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30450 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30451 COMMON/PYINT1/MINT(400),VINT(400)
30452 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
30453
30454C...Value for alpha_strong.
30455 IF(MSTP(35).LE.1) THEN
30456 ALSSG=PARP(35)
30457 ELSE
30458 MST115=MSTU(115)
30459 MSTU(115)=MSTP(36)
30460 Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+
30461 & PARP(36)**2)))
30462 ALSSG=PYALPS(Q2BN)
30463 MSTU(115)=MST115
30464 ENDIF
30465
30466C...Evaluate attractive and repulsive factors.
30467 XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
30468 FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
30469 XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
30470 FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
30471 PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU
30472 VINT(138)=PYHFTH
30473
30474 RETURN
30475 END
30476
30477C*********************************************************************
30478
30479C...PYSPLI
30480C...Splits a hadron remnant into two (partons or hadron + parton)
30481C...in case it is more complicated than just a quark or a diquark.
30482
30483 SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
30484
30485C...Double precision and integer declarations.
30486 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30487 IMPLICIT INTEGER(I-N)
30488 INTEGER PYK,PYCHGE,PYCOMP
30489C...Commonblocks. PYDAT1 temporary
30490 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30491 COMMON/PYINT1/MINT(400),VINT(400)
30492 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30493 SAVE /PYPARS/,/PYINT1/,/PYDAT1/
30494C...Local array.
30495 DIMENSION KFL(3)
30496
30497C...Preliminaries. Parton composition.
30498 KFA=IABS(KF)
30499 KFS=ISIGN(1,KF)
30500 KFL(1)=MOD(KFA/1000,10)
30501 KFL(2)=MOD(KFA/100,10)
30502 KFL(3)=MOD(KFA/10,10)
30503 IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
30504 KFL(2)=INT(1.5D0+PYR(0))
30505 IF(MINT(105).EQ.333) KFL(2)=3
30506 IF(MINT(105).EQ.443) KFL(2)=4
30507 KFL(3)=KFL(2)
30508 ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN
30509 KFL(2)=2
30510 KFL(3)=2
30511 ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN
30512 KFL(2)=1
30513 KFL(3)=1
30514 ELSEIF((KFA.EQ.130.OR.KFA.EQ.310).AND.PYR(0).GT.0.5D0) THEN
30515 KFL(2)=MOD(KFA/10,10)
30516 KFL(3)=MOD(KFA/100,10)
30517 ENDIF
30518 IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN
30519 KFLR=KFLIN*KFS
30520 ELSE
30521 KFLR=KFLIN
30522 ENDIF
30523 KFLCH=0
30524
30525C...Subdivide lepton.
30526 IF(KFA.GE.11.AND.KFA.LE.18) THEN
30527 IF(KFLR.EQ.KFA) THEN
30528 KFLSP=KFS*22
30529 ELSEIF(KFLR.EQ.22) THEN
30530 KFLSP=KFA
30531 ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN
30532 KFLSP=KFA+1
30533 ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN
30534 KFLSP=KFA-1
30535 ELSEIF(KFLR.EQ.21) THEN
30536 KFLSP=KFA
30537 KFLCH=KFS*21
30538 ELSE
30539 KFLSP=KFA
30540 KFLCH=-KFLR
30541 ENDIF
30542
30543C...Subdivide photon.
30544 ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN
30545 IF(KFLR.NE.21) THEN
30546 KFLSP=-KFLR
30547 ELSE
30548 RAGR=0.75D0*PYR(0)
30549 KFLSP=1
30550 IF(RAGR.GT.0.125D0) KFLSP=2
30551 IF(RAGR.GT.0.625D0) KFLSP=3
30552 IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP
30553 KFLCH=-KFLSP
30554 ENDIF
30555
30556C...Subdivide Reggeon or Pomeron.
30557 ELSEIF(KFA.EQ.110.OR.KFA.EQ.990) THEN
30558 IF(KFLIN.EQ.21) THEN
30559 KFLSP=KFS*21
30560 ELSE
30561 KFLSP=-KFLIN
30562 ENDIF
30563
30564C...Subdivide meson.
30565 ELSEIF(KFL(1).EQ.0) THEN
30566 KFL(2)=KFL(2)*(-1)**KFL(2)
30567 KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
30568 IF(KFLR.EQ.KFL(2)) THEN
30569 KFLSP=KFL(3)
30570 ELSEIF(KFLR.EQ.KFL(3)) THEN
30571 KFLSP=KFL(2)
30572 ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN
30573 KFLSP=KFL(2)
30574 KFLCH=KFL(3)
30575 ELSEIF(KFLR.EQ.21) THEN
30576 KFLSP=KFL(3)
30577 KFLCH=KFL(2)
30578 ELSEIF(KFLR*KFL(2).GT.0) THEN
30579 NTRY=0
30580 100 NTRY=NTRY+1
30581 CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
30582 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
30583 GOTO 100
30584 ELSEIF(KFLCH.EQ.0) THEN
30585 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
30586 MINT(51)=1
30587 RETURN
30588 ENDIF
30589 KFLSP=KFL(3)
30590 ELSE
30591 NTRY=0
30592 110 NTRY=NTRY+1
30593 CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
30594 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
30595 GOTO 110
30596 ELSEIF(KFLCH.EQ.0) THEN
30597 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
30598 MINT(51)=1
30599 RETURN
30600 ENDIF
30601 KFLSP=KFL(2)
30602 ENDIF
30603
30604C...Subdivide baryon.
30605 ELSE
30606 NAGR=0
30607 DO 120 J=1,3
30608 IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
30609 120 CONTINUE
30610 IF(NAGR.GE.1) THEN
30611 RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0)
30612 IAGR=0
30613 DO 130 J=1,3
30614 IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0
30615 IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J
30616 130 CONTINUE
30617 ELSE
30618 IAGR=1.00001D0+2.99998D0*PYR(0)
30619 ENDIF
30620 ID1=1
30621 IF(IAGR.EQ.1) ID1=2
30622 IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
30623 ID2=6-IAGR-ID1
30624 KSP=3
30625 IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
30626 IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1
30627 ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
30628 IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1
30629 ELSEIF(MOD(KFA,10).EQ.2) THEN
30630 IF(IAGR.EQ.1) KSP=1
30631 IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1
30632 ENDIF
30633 KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
30634 IF(KFLR.EQ.21) THEN
30635 KFLCH=KFL(IAGR)
30636 ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
30637 NTRY=0
30638 140 NTRY=NTRY+1
30639 CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
30640 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
30641 GOTO 140
30642 ELSEIF(KFLCH.EQ.0) THEN
30643 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
30644 MINT(51)=1
30645 RETURN
30646 ENDIF
30647 ELSEIF(NAGR.EQ.0) THEN
30648 NTRY=0
30649 150 NTRY=NTRY+1
30650 CALL PYKFDI(10000*KFL(ID1)+KFLSP,-KFLR,KFDUMP,KFLCH)
30651 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
30652 GOTO 150
30653 ELSEIF(KFLCH.EQ.0) THEN
30654 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
30655 MINT(51)=1
30656 RETURN
30657 ENDIF
30658 KFLSP=KFL(IAGR)
30659 ENDIF
30660 ENDIF
30661
30662C...Add on correct sign for result.
30663 KFLCH=KFLCH*KFS
30664 KFLSP=KFLSP*KFS
30665
30666 RETURN
30667 END
30668
30669C*********************************************************************
30670
30671C...PYGAMM
30672C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
30673C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
30674C...(Dover, 1965) 6.1.36.
30675
30676 FUNCTION PYGAMM(X)
30677
30678C...Double precision and integer declarations.
30679 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30680 IMPLICIT INTEGER(I-N)
30681 INTEGER PYK,PYCHGE,PYCOMP
30682C...Local array and data.
30683 DIMENSION B(8)
30684 DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
30685 &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/
30686
30687 NX=INT(X)
30688 DX=X-NX
30689
30690 PYGAMM=1D0
30691 DXP=1D0
30692 DO 100 I=1,8
30693 DXP=DXP*DX
30694 PYGAMM=PYGAMM+B(I)*DXP
30695 100 CONTINUE
30696 IF(X.LT.1D0) THEN
30697 PYGAMM=PYGAMM/X
30698 ELSE
30699 DO 110 IX=1,NX-1
30700 PYGAMM=(X-IX)*PYGAMM
30701 110 CONTINUE
30702 ENDIF
30703
30704 RETURN
30705 END
30706
30707C***********************************************************************
30708
30709C...PYWAUX
30710C...Calculates real and imaginary parts of the auxiliary functions W1
30711C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
30712C...der Bij, Nucl. Phys. B297 (1988) 221.
30713
30714 SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)
30715
30716C...Double precision and integer declarations.
30717 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30718 IMPLICIT INTEGER(I-N)
30719 INTEGER PYK,PYCHGE,PYCOMP
30720C...Commonblocks.
30721 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30722 SAVE /PYDAT1/
30723
30724 ASINH(X)=LOG(X+SQRT(X**2+1D0))
30725 ACOSH(X)=LOG(X+SQRT(X**2-1D0))
30726
30727 IF(EPS.LT.0D0) THEN
30728 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
30729 IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
30730 WIM=0D0
30731 ELSEIF(EPS.LT.1D0) THEN
30732 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
30733 IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
30734 IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
30735 IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
30736 ELSE
30737 IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
30738 IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
30739 WIM=0D0
30740 ENDIF
30741
30742 RETURN
30743 END
30744
30745C***********************************************************************
30746
30747C...PYI3AU
30748C...Calculates real and imaginary parts of the auxiliary function I3;
30749C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
30750C...Nucl. Phys. B297 (1988) 221.
30751
30752 SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM)
30753
30754C...Double precision and integer declarations.
30755 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30756 IMPLICIT INTEGER(I-N)
30757 INTEGER PYK,PYCHGE,PYCOMP
30758C...Commonblocks.
30759 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30760 SAVE /PYDAT1/
30761
30762 BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS))
30763 IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS))
30764
30765 IF(EPS.LT.0D0) THEN
30766 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
30767 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
30768 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
30769 & PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)-
30770 & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-
30771 & LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)*
30772 & LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+
30773 & LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)*
30774 & EPS))
30775 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
30776 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
30777 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
30778 & PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)-
30779 & PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+
30780 & 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+
30781 & LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+
30782 & LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS))
30783 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
30784 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
30785 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
30786 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)-
30787 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+
30788 & 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+
30789 & LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+
30790 & LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS))
30791 ELSE
30792 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
30793 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)-
30794 & PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2-
30795 & LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+
30796 & LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0))
30797 ENDIF
30798 F3IM=0D0
30799 ELSEIF(EPS.LT.1D0) THEN
30800 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
30801 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
30802 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
30803 & PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)-
30804 & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
30805 & (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
30806 & (0.25D0*(RAT+1D0)*EPS))
30807 F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
30808 & (0.25D0*(RAT+1D0)*EPS))
30809 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
30810 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
30811 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
30812 & PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)-
30813 & PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+
30814 & LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))*
30815 & LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
30816 F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
30817 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
30818 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
30819 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
30820 & PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)-
30821 & PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+
30822 & LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/
30823 & (1D0+0.25D0*RAT*EPS-GA))
30824 F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/
30825 & (1D0+0.25D0*RAT*EPS-GA))
30826 ELSE
30827 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
30828 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)-
30829 & PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))*
30830 & LOG((GA+BE-1D0)/(BE-GA))
30831 F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA))
30832 ENDIF
30833 ELSE
30834 RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2)
30835 RCTHE=RSQ*(1D0-2D0*BE/EPS)
30836 RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2))
30837 RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS)
30838 RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2))
30839 R=SQRT(RSQ)
30840 THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R)))
30841 PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R)))
30842 F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
30843 & PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
30844 & (PHI-THE)*(PHI+THE-PARU(1))
30845 F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
30846 & PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
30847 ENDIF
30848
30849 Y3RE=2D0/(2D0*BE-1D0)*F3RE
30850 Y3IM=2D0/(2D0*BE-1D0)*F3IM
30851
30852 RETURN
30853 END
30854
30855C***********************************************************************
30856
30857C...PYSPEN
30858C...Calculates real and imaginary part of Spence function; see
30859C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
30860
30861 FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
30862
30863C...Double precision and integer declarations.
30864 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30865 IMPLICIT INTEGER(I-N)
30866 INTEGER PYK,PYCHGE,PYCOMP
30867C...Commonblocks.
30868 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30869 SAVE /PYDAT1/
30870C...Local array and data.
30871 DIMENSION B(0:14)
30872 DATA B/
30873 &1.000000D+00, -5.000000D-01, 1.666667D-01,
30874 &0.000000D+00, -3.333333D-02, 0.000000D+00,
30875 &2.380952D-02, 0.000000D+00, -3.333333D-02,
30876 &0.000000D+00, 7.575757D-02, 0.000000D+00,
30877 &-2.531135D-01, 0.000000D+00, 1.166667D+00/
30878
30879 XRE=XREIN
30880 XIM=XIMIN
30881 IF(ABS(1D0-XRE).LT.1D-6.AND.ABS(XIM).LT.1D-6) THEN
30882 IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
30883 IF(IREIM.EQ.2) PYSPEN=0D0
30884 RETURN
30885 ENDIF
30886
30887 XMOD=SQRT(XRE**2+XIM**2)
30888 IF(XMOD.LT.1D-6) THEN
30889 IF(IREIM.EQ.1) PYSPEN=0D0
30890 IF(IREIM.EQ.2) PYSPEN=0D0
30891 RETURN
30892 ENDIF
30893
30894 XARG=SIGN(ACOS(XRE/XMOD),XIM)
30895 SP0RE=0D0
30896 SP0IM=0D0
30897 SGN=1D0
30898 IF(XMOD.GT.1D0) THEN
30899 ALGXRE=LOG(XMOD)
30900 ALGXIM=XARG-SIGN(PARU(1),XARG)
30901 SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
30902 SP0IM=-ALGXRE*ALGXIM
30903 SGN=-1D0
30904 XMOD=1D0/XMOD
30905 XARG=-XARG
30906 XRE=XMOD*COS(XARG)
30907 XIM=XMOD*SIN(XARG)
30908 ENDIF
30909 IF(XRE.GT.0.5D0) THEN
30910 ALGXRE=LOG(XMOD)
30911 ALGXIM=XARG
30912 XRE=1D0-XRE
30913 XIM=-XIM
30914 XMOD=SQRT(XRE**2+XIM**2)
30915 XARG=SIGN(ACOS(XRE/XMOD),XIM)
30916 ALGYRE=LOG(XMOD)
30917 ALGYIM=XARG
30918 SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
30919 SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
30920 SGN=-SGN
30921 ENDIF
30922
30923 XRE=1D0-XRE
30924 XIM=-XIM
30925 XMOD=SQRT(XRE**2+XIM**2)
30926 XARG=SIGN(ACOS(XRE/XMOD),XIM)
30927 ZRE=-LOG(XMOD)
30928 ZIM=-XARG
30929
30930 SPRE=0D0
30931 SPIM=0D0
30932 SAVERE=1D0
30933 SAVEIM=0D0
30934 DO 100 I=0,14
30935 IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
30936 TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
30937 TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
30938 SAVERE=TERMRE
30939 SAVEIM=TERMIM
30940 SPRE=SPRE+B(I)*TERMRE
30941 SPIM=SPIM+B(I)*TERMIM
30942 100 CONTINUE
30943
30944 110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
30945 IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
30946
30947 RETURN
30948 END
30949
30950C***********************************************************************
30951
30952C...PYQQBH
30953C...Calculates the matrix element for the processes
30954C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
30955C...REDUCE output and part of the rest courtesy Z. Kunszt, see
30956C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
30957
30958 SUBROUTINE PYQQBH(WTQQBH)
30959
30960C...Double precision and integer declarations.
30961 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30962 IMPLICIT INTEGER(I-N)
30963 INTEGER PYK,PYCHGE,PYCOMP
30964C...Commonblocks.
30965 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30966 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30967 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30968 COMMON/PYINT1/MINT(400),VINT(400)
30969 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
30970 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/
30971C...Local arrays and function.
30972 DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8)
30973 DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)-
30974 &PP(I,3)*PP(J,3)
30975
30976C...Mass parameters.
30977 WTQQBH=0D0
30978 ISUB=MINT(1)
30979 SHPR=SQRT(VINT(26))*VINT(1)
30980 PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1)
30981 PH=SQRT(VINT(21))*VINT(1)
30982 SPQ=PQ**2
30983 SPH=PH**2
30984
30985C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
30986 DO 100 I=1,2
30987 PT=SQRT(MAX(0D0,VINT(197+5*I)))
30988 PP(I,1)=PT*COS(VINT(198+5*I))
30989 PP(I,2)=PT*SIN(VINT(198+5*I))
30990 100 CONTINUE
30991 PP(3,1)=-PP(1,1)-PP(2,1)
30992 PP(3,2)=-PP(1,2)-PP(2,2)
30993 PMS1=SPQ+PP(1,1)**2+PP(1,2)**2
30994 PMS2=SPQ+PP(2,1)**2+PP(2,2)**2
30995 PMS3=SPH+PP(3,1)**2+PP(3,2)**2
30996 PMT3=SQRT(PMS3)
30997 PP(3,3)=PMT3*SINH(VINT(211))
30998 PP(3,4)=PMT3*COSH(VINT(211))
30999 PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2
31000 PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
31001 &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12)
31002 PP(2,3)=-PP(1,3)-PP(3,3)
31003 PP(1,4)=SQRT(PMS1+PP(1,3)**2)
31004 PP(2,4)=SQRT(PMS2+PP(2,3)**2)
31005
31006C...Set up incoming kinematics and derived momentum combinations.
31007 DO 110 I=4,5
31008 PP(I,1)=0D0
31009 PP(I,2)=0D0
31010 PP(I,3)=-0.5D0*SHPR*(-1)**I
31011 PP(I,4)=-0.5D0*SHPR
31012 110 CONTINUE
31013 DO 120 J=1,4
31014 PP(6,J)=PP(1,J)+PP(2,J)
31015 PP(7,J)=PP(1,J)+PP(3,J)
31016 PP(8,J)=PP(1,J)+PP(4,J)
31017 PP(9,J)=PP(1,J)+PP(5,J)
31018 PP(10,J)=-PP(2,J)-PP(3,J)
31019 PP(11,J)=-PP(2,J)-PP(4,J)
31020 PP(12,J)=-PP(2,J)-PP(5,J)
31021 PP(13,J)=-PP(4,J)-PP(5,J)
31022 120 CONTINUE
31023
31024C...Derived kinematics invariants.
31025 X1=DOT(1,2)
31026 X2=DOT(1,3)
31027 X3=DOT(1,4)
31028 X4=DOT(1,5)
31029 X5=DOT(2,3)
31030 X6=DOT(2,4)
31031 X7=DOT(2,5)
31032 X8=DOT(3,4)
31033 X9=DOT(3,5)
31034 X10=DOT(4,5)
31035
31036C...Propagators.
31037 SS1=DOT(7,7)-SPQ
31038 SS2=DOT(8,8)-SPQ
31039 SS3=DOT(9,9)-SPQ
31040 SS4=DOT(10,10)-SPQ
31041 SS5=DOT(11,11)-SPQ
31042 SS6=DOT(12,12)-SPQ
31043 SS7=DOT(13,13)
31044 DX(1)=SS1*SS6
31045 DX(2)=SS2*SS6
31046 DX(3)=SS2*SS4
31047 DX(4)=SS1*SS5
31048 DX(5)=SS3*SS5
31049 DX(6)=SS3*SS4
31050 DX(7)=SS7*SS1
31051 DX(8)=SS7*SS4
31052
31053C...Define colour coefficients for g + g -> Q + Qbar + H.
31054 IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN
31055 DO 140 I=1,3
31056 DO 130 J=1,3
31057 CLR(I,J)=16D0/3D0
31058 CLR(I+3,J+3)=16D0/3D0
31059 CLR(I,J+3)=-2D0/3D0
31060 CLR(I+3,J)=-2D0/3D0
31061 130 CONTINUE
31062 140 CONTINUE
31063 DO 160 L=1,2
31064 DO 150 I=1,3
31065 CLR(I,6+L)=-6D0
31066 CLR(I+3,6+L)=6D0
31067 CLR(6+L,I)=-6D0
31068 CLR(6+L,I+3)=6D0
31069 150 CONTINUE
31070 160 CONTINUE
31071 DO 180 K1=1,2
31072 DO 170 K2=1,2
31073 CLR(6+K1,6+K2)=12D0
31074 170 CONTINUE
31075 180 CONTINUE
31076
31077C...Evaluate matrix elements for g + g -> Q + Qbar + H.
31078 FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2*
31079 & X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2*
31080 & X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7
31081 FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2
31082 & *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2*
31083 & X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+
31084 & X10)
31085 FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4*
31086 & X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10
31087 & +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
31088 & -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7
31089 & -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+
31090 & X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6)
31091 FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10-
31092 & X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6
31093 & )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+
31094 & 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2*
31095 & X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6)
31096 FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1*
31097 & X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1*
31098 & X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4
31099 & *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1**
31100 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4*
31101 & X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7
31102 & +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5-
31103 & X4*X6*X5)
31104 FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4-
31105 & X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3*
31106 & X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2
31107 & *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5
31108 & +X4*X9*X5+X4*X5**2)
31109 FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2*
31110 & PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1*
31111 & X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3*
31112 & X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7*
31113 & X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7-
31114 & X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5)
31115 FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2*
31116 & PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+
31117 & 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8*
31118 & X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6
31119 & +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8*
31120 & X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4*
31121 & X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2*
31122 & X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+
31123 & X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2)
31124 FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*(
31125 & X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7
31126 FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2
31127 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3*
31128 & X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+
31129 & X6)
31130 FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1*
31131 & X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1*
31132 & X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4
31133 & *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1
31134 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4
31135 & *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3*
31136 & X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6*
31137 & X5+X4*X6*X5)
31138 FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1
31139 & *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3-
31140 & 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4-
31141 & X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1*
31142 & X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3
31143 & *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4*
31144 & X6**2)
31145 FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1*
31146 & X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1*
31147 & X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4*
31148 & X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1**
31149 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4*
31150 & X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7
31151 & -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5-
31152 & X4*X6*X5)
31153 FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
31154 & 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
31155 & X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3*
31156 & X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2
31157 & *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5
31158 & +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
31159 & -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1*
31160 & X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1*
31161 & X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3*
31162 & X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3
31163 & *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5)
31164 FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
31165 & 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
31166 & X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2*
31167 & X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4
31168 & *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5-
31169 & X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
31170 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9-
31171 & X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9
31172 & *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10*
31173 & X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3*
31174 & X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5)
31175 FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6
31176 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3*
31177 & X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5
31178 FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3-
31179 & X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3*
31180 & X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2
31181 & *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5
31182 & +X3*X8*X5+X3*X5**2)
31183 FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1*
31184 & X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1*
31185 & X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3
31186 & *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1
31187 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3
31188 & *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3*
31189 & X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7*
31190 & X5+X4*X6*X5)
31191 FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+
31192 & X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6
31193 & )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2*
31194 & X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2*
31195 & X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10)
31196 FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2*
31197 & PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4*
31198 & X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+
31199 & X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4*
31200 & X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+
31201 & X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3*
31202 & X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2
31203 & *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7
31204 & +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5)
31205 FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2*
31206 & PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+
31207 & 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7
31208 & +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9*
31209 & X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4
31210 & *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8)
31211 FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2*
31212 & X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2*
31213 & X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6
31214 FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4
31215 & *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+
31216 & X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+
31217 & X10)
31218 FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2*
31219 & X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10
31220 & +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
31221 & -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7
31222 & -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+
31223 & X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7)
31224 FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2
31225 & *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1*
31226 & X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3*
31227 & X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7*
31228 & X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2*
31229 & X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5)
31230 FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2
31231 & *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9
31232 & +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4
31233 & *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4*
31234 & X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2
31235 & *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3
31236 & *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2
31237 & *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9*
31238 & X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2)
31239 FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*(
31240 & X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6
31241 FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2
31242 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4*
31243 & X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+
31244 & X7)
31245 FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
31246 & 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
31247 & X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+
31248 & 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+
31249 & 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+
31250 & 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(-
31251 & X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3
31252 & *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10*
31253 & X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2*
31254 & X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4
31255 & *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5)
31256 FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
31257 & 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
31258 & X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+
31259 & 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2*
31260 & X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+
31261 & 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(
31262 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3*
31263 & X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9
31264 & *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10*
31265 & X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+
31266 & X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5)
31267 FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7
31268 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4*
31269 & X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5
31270 FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2
31271 & *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4
31272 & -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9
31273 & -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+
31274 & 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9
31275 & *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4
31276 & *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2
31277 & **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+
31278 & 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5)
31279 FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2
31280 & *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*
31281 & X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12*
31282 & X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9
31283 & *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2*
31284 & X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8)
31285 FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9*
31286 & X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7*
31287 & X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2
31288 & *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8
31289 & *X6)
31290 FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+
31291 & 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4*
31292 & X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9*
31293 & X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3*
31294 & X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2
31295 & +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+
31296 & 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5)
31297 FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2
31298 & *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4
31299 & *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2*
31300 & X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4*
31301 & X8)
31302 FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
31303 & X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6
31304 & )+2*X2*(-X10*X5+X9*X6+X8*X7)
31305 FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
31306 & X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2
31307 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3*
31308 & X9*X5)
31309 FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
31310 & X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2
31311 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4*
31312 & X8*X5)
31313 FM(9,10)=0.5D0*(FMXX+FM(9,10))
31314 FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
31315 & X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6
31316 & )+2*X5*(-X10*X2+X9*X3+X8*X4)
31317
31318C...Repackage matrix elements.
31319 DO 200 I=1,8
31320 DO 190 J=1,8
31321 RM(I,J)=FM(I,J)
31322 190 CONTINUE
31323 200 CONTINUE
31324 RM(7,7)=FM(7,7)-2D0*FM(9,9)
31325 RM(7,8)=FM(7,8)-2D0*FM(9,10)
31326 RM(8,8)=FM(8,8)-2D0*FM(10,10)
31327
31328C...Produce final result: matrix elements * colours * propagators.
31329 DO 220 I=1,8
31330 DO 210 J=I,8
31331 FAC=8D0
31332 IF(I.EQ.J)FAC=4D0
31333 WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J))
31334 210 CONTINUE
31335 220 CONTINUE
31336 WTQQBH=-WTQQBH/256D0
31337
31338 ELSE
31339C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
31340 A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3
31341 & *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9
31342 & *X6+X8*X7)
31343 A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8-
31344 & 2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7
31345 & +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8*
31346 & X5)
31347 A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3*
31348 & X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3
31349 & *X9+X4*X8)
31350
31351C...Produce final result: matrix elements * propagators.
31352 A11=A11/DX(7)**2
31353 A12=A12/(DX(7)*DX(8))
31354 A22=A22/DX(8)**2
31355 WTQQBH=-(A11+A22+2D0*A12)*8D0/9D0
31356 ENDIF
31357
31358 RETURN
31359 END
31360
31361C*********************************************************************
31362
31363C...PYMSIN
31364C...Initializes supersymmetry: finds sparticle masses and
31365C...branching ratios and stores this information.
31366C...AUTHOR: STEPHEN MRENNA
31367
31368 SUBROUTINE PYMSIN
31369
31370C...Double precision and integer declarations.
31371 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31372 IMPLICIT INTEGER(I-N)
31373 INTEGER PYK,PYCHGE,PYCOMP
31374C...Parameter statement to help give large particle numbers.
31375 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
31376 &KEXCIT=4000000,KDIMEN=5000000)
31377C...Commonblocks.
31378 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31379 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31380 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
31381 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
31382 COMMON/PYINT4/MWID(500),WIDS(500,5)
31383 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
31384 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
31385 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
31386 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
31387 COMMON/PYHTRI/HHH(7)
31388 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT4/,/PYMSSM/,
31389 &/PYMSRV/,/PYSSMT/
31390
31391C...Local variables.
31392 DOUBLE PRECISION ALFA,BETA
31393 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
31394 INTEGER I,J,J1,I1,K1
31395 INTEGER KC,LKNT,IDLAM(300,3)
31396 DOUBLE PRECISION XLAM(0:300)
31397 DOUBLE PRECISION WDTP(0:300),WDTE(0:300,0:5)
31398 DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
31399 DOUBLE PRECISION DELM,XMDIF
31400 DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
31401 DOUBLE PRECISION ARG,SGNMU,R
31402 INTEGER IMSSM
31403 INTEGER IRPRTY
31404 INTEGER KFSUSY(36),MWIDSU(36),MDCYSU(36)
31405 SAVE MWIDSU,MDCYSU
31406 DATA KFSUSY/
31407 &1000001,2000001,1000002,2000002,1000003,2000003,
31408 &1000004,2000004,1000005,2000005,1000006,2000006,
31409 &1000011,2000011,1000012,2000012,1000013,2000013,
31410 &1000014,2000014,1000015,2000015,1000016,2000016,
31411 &1000021,1000022,1000023,1000025,1000035,1000024,
31412 &1000037,1000039, 25, 35, 36, 37/
31413 DATA INIT/0/
31414
31415C...Do nothing if SUSY not requested.
31416 IMSSM=IMSS(1)
31417 IF(IMSSM.EQ.0) RETURN
31418
31419C...Save copy of MWID(KC) and MDCY(KC,1) values before
31420C...they are set to zero for the LSP.
31421 IF(INIT.EQ.0) THEN
31422 INIT=1
31423 DO 100 I=1,36
31424 KF=KFSUSY(I)
31425 KC=PYCOMP(KF)
31426 MWIDSU(I)=MWID(KC)
31427 MDCYSU(I)=MDCY(KC,1)
31428 100 CONTINUE
31429 ENDIF
31430
31431C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP.
31432 DO 110 I=1,36
31433 KF=KFSUSY(I)
31434 KC=PYCOMP(KF)
31435 IF(MDCY(KC,1).EQ.0.AND.MDCYSU(I).NE.0) THEN
31436 MWID(KC)=MWIDSU(I)
31437 MDCY(KC,1)=MDCYSU(I)
31438 ENDIF
31439 110 CONTINUE
31440
31441C...First part of routine: set masses and couplings.
31442
31443C...Reset mixing values in sfermion sector to pure left/right.
31444 DO 120 I=1,16
31445 SFMIX(I,1)=1D0
31446 SFMIX(I,4)=1D0
31447 SFMIX(I,2)=0D0
31448 SFMIX(I,3)=0D0
31449 120 CONTINUE
31450
31451C...Common couplings.
31452 TANB=RMSS(5)
31453 BETA=ATAN(TANB)
31454 COSB=COS(BETA)
31455 SINB=TANB*COSB
31456 COS2B=COS(2D0*BETA)
31457 ALFA=RMSS(18)
31458 XMW2=PMAS(24,1)**2
31459 XMZ2=PMAS(23,1)**2
31460 XW=PARU(102)
31461
31462C...Define sparticle masses for a general MSSM simulation.
31463 IF(IMSSM.EQ.1) THEN
31464 IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9)
31465 DO 130 I=1,5,2
31466 KC=PYCOMP(KSUSY1+I)
31467 PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0)
31468 KC=PYCOMP(KSUSY2+I)
31469 PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0)
31470 KC=PYCOMP(KSUSY1+I+1)
31471 PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0)
31472 KC=PYCOMP(KSUSY2+I+1)
31473 PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0)
31474 130 CONTINUE
31475 XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA))
31476 IF(XARG.LT.0D0) THEN
31477 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
31478 & ' FROM THE SUM RULE. '
31479 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
31480 RETURN
31481 ELSE
31482 XARG=SQRT(XARG)
31483 ENDIF
31484 DO 140 I=11,15,2
31485 PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6)
31486 PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7)
31487 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
31488 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
31489 140 CONTINUE
31490 IF(IMSS(8).EQ.1) THEN
31491 RMSS(13)=RMSS(6)
31492 RMSS(14)=RMSS(7)
31493 ENDIF
31494
31495C...Alternatively derive masses from SUGRA relations.
31496 ELSEIF(IMSSM.EQ.2) THEN
31497 CALL PYAPPS
31498 ENDIF
31499
31500C...Add in extra D-term contributions.
31501 IF(IMSS(7).EQ.1) THEN
31502 R=0.43D0
31503 DX=RMSS(23)
31504 DY=RMSS(24)
31505 DS=RMSS(25)
31506 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
31507 WRITE(MSTU(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
31508 WRITE(MSTU(11),*) 'C IN A U(B-L) THEORY '
31509 WRITE(MSTU(11),*) 'C DX = ',DX
31510 WRITE(MSTU(11),*) 'C DY = ',DY
31511 WRITE(MSTU(11),*) 'C DS = ',DS
31512 WRITE(MSTU(11),*) 'C '
31513 DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS
31514 WRITE(MSTU(11),*) 'C DY AT THE WEAK SCALE = ',DY
31515 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
31516 DQ2=DY/6D0-DX/3D0-DS/3D0
31517 DU2=-2D0*DY/3D0-DX/3D0-DS/3D0
31518 DD2=DY/3D0+DX-2D0*DS/3D0
31519 DL2=-DY/2D0+DX-2D0*DS/3D0
31520 DE2=DY-DX/3D0-DS/3D0
31521 DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0
31522 DHD2=-DY/2D0-2D0*DX/3D0+DS
31523 DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS)
31524 & /ABS(COS2B)
31525 DMA2 = 2D0*DMU2+DHU2+DHD2
31526 DO 150 I=1,5,2
31527 KC=PYCOMP(KSUSY1+I)
31528 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
31529 KC=PYCOMP(KSUSY2+I)
31530 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2)
31531 KC=PYCOMP(KSUSY1+I+1)
31532 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
31533 KC=PYCOMP(KSUSY2+I+1)
31534 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2)
31535 150 CONTINUE
31536 DO 160 I=11,15,2
31537 KC=PYCOMP(KSUSY1+I)
31538 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
31539 KC=PYCOMP(KSUSY2+I)
31540 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2)
31541 KC=PYCOMP(KSUSY1+I+1)
31542 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
31543 160 CONTINUE
31544 IF(RMSS(4)**2+DMU2.LT.0D0) THEN
31545 WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE '
31546 STOP
31547 ENDIF
31548 SGNMU=SIGN(1D0,RMSS(4))
31549 RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2)
31550 ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2
31551 RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
31552 ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2
31553 RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
31554 ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2
31555 RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
31556 ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2
31557 RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
31558 ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2
31559 RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG)
31560 IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN
31561 WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW '
31562 STOP
31563 ENDIF
31564 RMSS(19)=SQRT(RMSS(19)**2+DMA2)
31565 RMSS(6)=SQRT(RMSS(6)**2+DL2)
31566 RMSS(7)=SQRT(RMSS(7)**2+DE2)
31567 WRITE(MSTU(11),*) ' MTL = ',RMSS(10)
31568 WRITE(MSTU(11),*) ' MBR = ',RMSS(11)
31569 WRITE(MSTU(11),*) ' MTR = ',RMSS(12)
31570 WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13)
31571 WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14)
31572 ENDIF
31573
31574C...Fix the third generation sfermions.
31575 CALL PYTHRG
31576 XARG=RMSS(13)**2-PMAS(24,1)**2*ABS(COS2B)
31577 IF(XARG.LT.0D0) THEN
31578 WRITE(MSTU(11),*) ' TAU SNEUTRINO MASS IS NEGATIVE FROM'//
31579 & ' THE SUM RULE. '
31580 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
31581 RETURN
31582 ELSE
31583 PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG)
31584 ENDIF
31585
31586C...Fix the neutralino--chargino--gluino sector.
31587 CALL PYINOM
31588
31589C...Fix the Higgs sector.
31590 CALL PYHGGM(ALFA)
31591
31592C...Choose the Gunion-Haber convention.
31593 ALFA=-ALFA
31594 RMSS(18)=ALFA
31595
31596C...Print information on mass parameters.
31597 IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN
31598 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
31599 WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
31600 WRITE(MSTU(11),*) ' M0 = ',RMSS(8)
31601 WRITE(MSTU(11),*) ' M1/2=',RMSS(1)
31602 WRITE(MSTU(11),*) ' TANB=',RMSS(5)
31603 WRITE(MSTU(11),*) ' MU = ',RMSS(4)
31604 WRITE(MSTU(11),*) ' AT = ',RMSS(16)
31605 WRITE(MSTU(11),*) ' MA = ',RMSS(19)
31606 WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1)
31607 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
31608 ENDIF
31609 IF(IMSS(20).EQ.1) THEN
31610 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
31611 WRITE(MSTU(11),*) ' DEBUG MODE '
31612 WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2),
31613 & UMIX(2,1),UMIX(2,2)
31614 WRITE(MSTU(11),*) ' UMIXI = ',UMIXI(1,1),UMIXI(1,2),
31615 & UMIXI(2,1),UMIXI(2,2)
31616 WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2),
31617 & VMIX(2,1),VMIX(2,2)
31618 WRITE(MSTU(11),*) ' VMIXI = ',VMIXI(1,1),VMIXI(1,2),
31619 & VMIXI(2,1),VMIXI(2,2)
31620 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(1,I),I=1,4)
31621 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(1,I),I=1,4)
31622 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(2,I),I=1,4)
31623 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(2,I),I=1,4)
31624 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(3,I),I=1,4)
31625 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(3,I),I=1,4)
31626 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(4,I),I=1,4)
31627 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(4,I),I=1,4)
31628 WRITE(MSTU(11),*) ' ALFA = ',ALFA
31629 WRITE(MSTU(11),*) ' BETA = ',BETA
31630 WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4)
31631 WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4)
31632 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
31633 ENDIF
31634
31635C...Set up the Higgs couplings - needed here since initialization
31636C...in PYINRE did not yet occur when PYWIDT is called below.
31637 AL=ALFA
31638 BE=BETA
31639 SINA=SIN(AL)
31640 COSA=COS(AL)
31641 COSB=COS(BE)
31642 SINB=TANB*COSB
31643 SBMA=SIN(BE-AL)
31644 SAPB=SIN(AL+BE)
31645 CAPB=COS(AL+BE)
31646 CBMA=COS(BE-AL)
31647 C2A=COS(2D0*AL)
31648 C2B=COSB**2-SINB**2
31649C...tanb (used for H+)
31650 PARU(141)=TANB
31651
31652C...Firstly: h
31653C...Coupling to d-type quarks
31654 PARU(161)=SINA/COSB
31655C...Coupling to u-type quarks
31656 PARU(162)=-COSA/SINB
31657C...Coupling to leptons
31658 PARU(163)=PARU(161)
31659C...Coupling to Z
31660 PARU(164)=SBMA
31661C...Coupling to W
31662 PARU(165)=PARU(164)
31663
31664C...Secondly: H
31665C...Coupling to d-type quarks
31666 PARU(171)=-COSA/COSB
31667C...Coupling to u-type quarks
31668 PARU(172)=-SINA/SINB
31669C...Coupling to leptons
31670 PARU(173)=PARU(171)
31671C...Coupling to Z
31672 PARU(174)=CBMA
31673C...Coupling to W
31674 PARU(175)=PARU(174)
31675C...Coupling to h
31676 IF(IMSS(4).EQ.2) THEN
31677 PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
31678 ELSE
31679 HHH(3)=HHH(3)+HHH(4)+HHH(5)
31680 PARU(176)=-3D0/HHH(1)*(HHH(1)*SINA**2*COSB*COSA+
31681 1 HHH(2)*COSA**2*SINB*SINA+HHH(3)*(SINA**3*SINB+COSA**3*COSB-
31682 2 2D0/3D0*CBMA)-HHH(6)*SINA*(COSB*C2A+COSA*CAPB)+
31683 3 HHH(7)*COSA*(SINB*C2A+SINA*CAPB))
31684 ENDIF
31685C...Coupling to H+
31686C...Define later
31687 IF(IMSS(4).EQ.2) THEN
31688 PARU(168)=-SBMA-COS(2D0*BE)*SAPB/2D0/(1D0-XW)
31689 ELSE
31690 PARU(168)=1D0/HHH(1)*(HHH(1)*SINB**2*COSB*SINA-
31691 1 HHH(2)*COSB**2*SINB*COSA-HHH(3)*(SINB**3*COSA-COSB**3*SINA)+
31692 2 2D0*HHH(5)*SBMA-HHH(6)*SINB*(COSB*SAPB+SINA*C2B)-
31693 3 HHH(7)*COSB*(COSA*C2B-SINB*SAPB)-(HHH(5)-HHH(4))*SBMA)
31694 ENDIF
31695C...Coupling to A
31696 IF(IMSS(4).EQ.2) THEN
31697 PARU(177)=COS(2D0*BE)*COS(BE+AL)
31698 ELSE
31699 PARU(177)=-1D0/HHH(1)*(HHH(1)*SINB**2*COSB*COSA+
31700 1 HHH(2)*COSB**2*SINB*SINA+HHH(3)*(SINB**3*SINA+COSB**3*COSA)-
31701 2 2D0*HHH(5)*CBMA-HHH(6)*SINB*(COSB*CAPB+COSA*C2B)+
31702 3 HHH(7)*COSB*(SINB*CAPB+SINA*C2B))
31703 ENDIF
31704C...Coupling to H+
31705 IF(IMSS(4).EQ.2) THEN
31706 PARU(178)=PARU(177)
31707 ELSE
31708 PARU(178)=PARU(177)-(HHH(5)-HHH(4))/HHH(1)*CBMA
31709 ENDIF
31710C...Thirdly, A
31711C...Coupling to d-type quarks
31712 PARU(181)=TANB
31713C...Coupling to u-type quarks
31714 PARU(182)=1D0/PARU(181)
31715C...Coupling to leptons
31716 PARU(183)=PARU(181)
31717 PARU(184)=0D0
31718 PARU(185)=0D0
31719C...Coupling to Z h
31720 PARU(186)=COS(BE-AL)
31721C...Coupling to Z H
31722 PARU(187)=SIN(BE-AL)
31723 PARU(188)=0D0
31724 PARU(189)=0D0
31725 PARU(190)=0D0
31726
31727C...Finally: H+
31728C...Coupling to W h
31729 PARU(195)=COS(BE-AL)
31730
31731C...Tell that all Higgs couplings have been set.
31732 MSTP(4)=1
31733
31734C...Set R-Violating couplings
31735C...Set lambda couplings to common value or "natural values".
31736 IF ((IMSS(51).NE.3).AND.(IMSS(51).NE.0)) THEN
31737 VIR3=1D0/(126D0)**3
31738 DO 190 IRI=1,3
31739 DO 180 IRJ=1,3
31740 DO 170 IRK=1,3
31741 IF (IRI.NE.IRJ) THEN
31742 RVLAM(IRI,IRJ,IRK)=RMSS(51)
31743 IF (IMSS(51).EQ.2) RVLAM(IRI,IRJ,IRK)=RMSS(51)
31744 & *SQRT(PMAS(9+2*IRI,1)*PMAS(9+2*IRJ,1)*PMAS(9+2
31745 & *IRK,1)*VIR3)
31746 ENDIF
31747 IF (IRI.GT.IRJ) RVLAM(IRI,IRJ,IRK)=-RVLAM(IRI,IRJ,IRK)
31748 170 CONTINUE
31749 180 CONTINUE
31750 190 CONTINUE
31751 ENDIF
31752C...Set lambda' couplings to common value or "natural values".
31753 IF ((IMSS(52).NE.3).AND.(IMSS(52).NE.0)) THEN
31754 VIR3=1D0/(126D0)**3
31755 DO 220 IRI=1,3
31756 DO 210 IRJ=1,3
31757 DO 200 IRK=1,3
31758 RVLAMP(IRI,IRJ,IRK)=RMSS(52)
31759 IF (IMSS(52).EQ.2) RVLAMP(IRI,IRJ,IRK)=RMSS(52)
31760 & *SQRT(PMAS(9+2*IRI,1)*0.5*(PMAS(2*IRJ,1)+PMAS(2*IRJ
31761 & -1,1))*PMAS(2*IRK-1,1)*VIR3)
31762 200 CONTINUE
31763 210 CONTINUE
31764 220 CONTINUE
31765 ENDIF
31766
31767C...Second part of routine: set decay modes and branching ratios.
31768
31769C...Allow chi10 -> gravitino + gamma or not.
31770 KC=PYCOMP(KSUSY1+39)
31771 IF( IMSS(11) .NE. 0 ) THEN
31772 PMAS(KC,1)=RMSS(21)/1000000000D0
31773 PMAS(KC,2)=0.0001D0
31774 IRPRTY=0
31775 WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
31776 ELSE IF (IMSS(51).GE.1.OR.IMSS(52).GE.1) THEN
31777 IRPRTY=0
31778 WRITE(MSTU(11),*) ' ALLOWING L-VIOLATING DECAYS '
31779 ELSE
31780 PMAS(KC,1)=9999D0
31781 IRPRTY=1
31782 ENDIF
31783
31784C...Loop over sparticle and Higgs species.
31785 PMCHI1=PMAS(PYCOMP(KSUSY1+22),1)
31786C...Find the LSP or NLSP for a gravitino LSP
31787 ILSP=0
31788 PMLSP=1D20
31789 DO 230 I=1,36
31790 KF=KFSUSY(I)
31791 IF(KF.EQ.1000039) GOTO 230
31792 KC=PYCOMP(KF)
31793 IF(PMAS(KC,1).LT.PMLSP) THEN
31794 ILSP=I
31795 PMLSP=PMAS(KC,1)
31796 ENDIF
31797 230 CONTINUE
31798 DO 300 I=1,36
31799 KF=KFSUSY(I)
31800 KC=PYCOMP(KF)
31801 LKNT=0
31802
31803C...Sfermion decays.
31804 IF(I.LE.24) THEN
31805C...First check to see if sneutrino is lighter than chi10.
31806 IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND.
31807 & PMAS(KC,1).LT.PMCHI1) THEN
31808 ELSE
31809 CALL PYSFDC(KF,XLAM,IDLAM,LKNT)
31810 ENDIF
31811
31812C...Gluino decays.
31813 ELSEIF(I.EQ.25) THEN
31814 CALL PYGLUI(KF,XLAM,IDLAM,LKNT)
31815 IF(I.EQ.ILSP) LKNT=0
31816
31817C...Neutralino decays.
31818 ELSEIF(I.GE.26.AND.I.LE.29) THEN
31819 CALL PYNJDC(KF,XLAM,IDLAM,LKNT)
31820C...chi10 stable or chi10 -> gravitino + gamma.
31821 IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN
31822 PMAS(KC,2)=1D-6
31823 MDCY(KC,1)=0
31824 MWID(KC)=0
31825 ENDIF
31826
31827C...Chargino decays.
31828 ELSEIF(I.GE.30.AND.I.LE.31) THEN
31829 CALL PYCJDC(KF,XLAM,IDLAM,LKNT)
31830
31831C...Gravitino is stable.
31832 ELSEIF(I.EQ.32) THEN
31833 MDCY(KC,1)=0
31834 MWID(KC)=0
31835
31836C...Higgs decays.
31837 ELSEIF(I.GE.33.AND.I.LE.36) THEN
31838C...Calculate decays to non-SUSY particles.
31839 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
31840 LKNT=0
31841 DO 240 I1=0,100
31842 XLAM(I1)=0D0
31843 240 CONTINUE
31844 DO 260 I1=1,MDCY(KC,3)
31845 K1=MDCY(KC,2)+I1-1
31846 IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR.
31847 & IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 260
31848 XLAM(I1)=WDTP(I1)
31849 XLAM(0)=XLAM(0)+XLAM(I1)
31850 DO 250 J1=1,3
31851 IDLAM(I1,J1)=KFDP(K1,J1)
31852 250 CONTINUE
31853 LKNT=LKNT+1
31854 260 CONTINUE
31855C...Add the decays to SUSY particles.
31856 CALL PYHEXT(KF,XLAM,IDLAM,LKNT)
31857 ENDIF
31858C...Zero the branching ratios for use in loop mode
31859C...thanks to K. Matchev (FNAL)
31860 DO 270 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
31861 BRAT(IDC)=0D0
31862 270 CONTINUE
31863
31864C...Set stable particles.
31865 IF(LKNT.EQ.0) THEN
31866 MDCY(KC,1)=0
31867 MWID(KC)=0
31868 PMAS(KC,2)=1D-6
31869 PMAS(KC,3)=1D-5
31870 PMAS(KC,4)=0D0
31871
31872C...Store branching ratios in the standard tables.
31873 ELSE
31874 IDC=MDCY(KC,2)+MDCY(KC,3)-1
31875 DELM=1D6
31876 DO 290 IL=1,LKNT
31877 IDCSV=IDC
31878 280 IDC=IDC+1
31879 BRAT(IDC)=0D0
31880 IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2)
31881 IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ.
31882 & KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN
31883 BRAT(IDC)=XLAM(IL)/XLAM(0)
31884 XMDIF=PMAS(KC,1)
31885 IF(MDME(IDC,1).GE.1) THEN
31886 XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)-
31887 & PMAS(PYCOMP(KFDP(IDC,2)),1)
31888 IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF-
31889 & PMAS(PYCOMP(KFDP(IDC,3)),1)
31890 ENDIF
31891 IF(I.LE.32) THEN
31892 IF(XMDIF.GE.0D0) THEN
31893 DELM=MIN(DELM,XMDIF)
31894 ELSE
31895 WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF
31896 WRITE(MSTU(11),*) ' KF = ',KF
31897 WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3)
31898 ENDIF
31899 ENDIF
31900 GOTO 290
31901 ELSEIF(IDC.EQ.IDCSV) THEN
31902 WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ',
31903 & 'channel not recognized:'
31904 WRITE(MSTU(11),*) KF,' -> ',(IDLAM(I,J),J=1,3)
31905 GOTO 290
31906 ELSE
31907 GOTO 280
31908 ENDIF
31909 290 CONTINUE
31910
31911C...Store width, cutoff and lifetime.
31912 PMAS(KC,2)=XLAM(0)
31913 IF(PMAS(KC,2).LT.0.1D0*DELM) THEN
31914 PMAS(KC,3)=PMAS(KC,2)*10D0
31915 ELSE
31916 PMAS(KC,3)=0.95D0*DELM
31917 ENDIF
31918 IF(PMAS(KC,2).NE.0D0) THEN
31919 PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12
31920 ENDIF
31921 ENDIF
31922 300 CONTINUE
31923
31924 RETURN
31925 END
31926
31927C*********************************************************************
31928
31929C...PYAPPS
31930C...Uses approximate analytical formulae to determine the full set of
31931C...MSSM parameters from SUGRA input.
31932C...See M. Drees and S.P. Martin, hep-ph/9504124
31933
31934 SUBROUTINE PYAPPS
31935
31936C...Double precision and integer declarations.
31937 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31938 IMPLICIT INTEGER(I-N)
31939 INTEGER PYK,PYCHGE,PYCOMP
31940C...Parameter statement to help give large particle numbers.
31941 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
31942 &KEXCIT=4000000,KDIMEN=5000000)
31943C...Commonblocks.
31944 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31945 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31946 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
31947 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/
31948
31949 IMSS(5)=0
31950 XMT=PMAS(6,1)
31951 XMZ2=PMAS(23,1)**2
31952 XMW2=PMAS(24,1)**2
31953 TANB=RMSS(5)
31954 BETA=ATAN(TANB)
31955 XW=PARU(102)
31956 XMG=RMSS(1)
31957 XMG2=XMG*XMG
31958 XM0=RMSS(8)
31959 XM02=XM0*XM0
31960 AT=-RMSS(16)
31961 RMSS(15)=AT
31962 RMSS(17)=AT
31963 COSB=COS(BETA)
31964 SINB=TANB/SQRT(TANB**2+1D0)
31965 COSB=SINB/TANB
31966
31967 DTERM=XMZ2*COS(2D0*BETA)
31968 XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM)
31969 XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM)
31970 RMSS(6)=XMEL
31971 RMSS(7)=XMER
31972 XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM))
31973 XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM))
31974 XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM))
31975 XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM))
31976 DO 100 I=1,5,2
31977 PMAS(PYCOMP(KSUSY1+I),1)=XMDL
31978 PMAS(PYCOMP(KSUSY2+I),1)=XMDR
31979 PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL
31980 PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR
31981 100 CONTINUE
31982 XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA))
31983 IF(XARG.LT.0D0) THEN
31984 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
31985 & ' FROM THE SUM RULE. '
31986 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
31987 RETURN
31988 ELSE
31989 XARG=SQRT(XARG)
31990 ENDIF
31991 DO 110 I=11,15,2
31992 PMAS(PYCOMP(KSUSY1+I),1)=XMEL
31993 PMAS(PYCOMP(KSUSY2+I),1)=XMER
31994 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
31995 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
31996 110 CONTINUE
31997C XMNU=XARG
31998
31999 RMT=PYRNMT(XMT)
32000 XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+
32001 &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG))
32002 RMB=3D0
32003 XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+
32004 &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG))
32005 XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0)
32006 ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/
32007 &SINB)**2)
32008 RMSS(16)=-ATP
32009C XMU2=-XM02-0.52D0*XMG2-0.5D0*XMZ2+XTOP/(1D0-1D0/TANB**2)
32010C.....
32011 XMU2=-.5D0*XMZ2+(SINB**2*(XM02+.52D0*XMG2-XTOP)-
32012 &COSB**2*(XM02+.52D0*XMG2-XBOT-XTAU/3D0))/(COSB**2-SINB**2)
32013C XMA2=(XMNU**2+XMU2-XBOT-XTAU/3D0)/SINB**2
32014C.....
32015 XMA2=2D0*(XM02+.52D0*XMG2)-XTOP-XBOT-XTAU/3D0+2D0*XMU2
32016 XMU=SIGN(SQRT(XMU2),RMSS(4))
32017 RMSS(4)=XMU
32018 RMSS(19)=SQRT(XMA2)
32019 ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM
32020 IF(ARG.GT.0D0) THEN
32021 RMSS(14)=SQRT(ARG)
32022 ELSE
32023 WRITE(MSTU(11),*) ' RIGHT STAU MASS < 0 '
32024 STOP
32025 ENDIF
32026 ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM
32027 IF(ARG.GT.0D0) THEN
32028 RMSS(13)=SQRT(ARG)
32029 ELSE
32030 WRITE(MSTU(11),*) ' LEFT STAU MASS < 0 '
32031 STOP
32032 ENDIF
32033 ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0)
32034 IF(ARG.GT.0D0) THEN
32035 RMSS(10)=SQRT(ARG)
32036 ELSE
32037 RMSS(10)=-SQRT(-ARG)
32038 ENDIF
32039 ARG=PYRNMQ(2,-2D0*XTOP/3D0)
32040 IF(ARG.GT.0D0) THEN
32041 RMSS(12)=SQRT(ARG)
32042 ELSE
32043 RMSS(12)=-SQRT(-ARG)
32044 ENDIF
32045 ARG=PYRNMQ(3,-2D0*XBOT/3D0)
32046 IF(ARG.GT.0D0) THEN
32047 RMSS(11)=SQRT(ARG)
32048 ELSE
32049 RMSS(11)=-SQRT(-ARG)
32050 ENDIF
32051
32052 RETURN
32053 END
32054
32055C*********************************************************************
32056
32057C...PYRNMQ
32058C...Determines the running mass of quarks.
32059
32060 FUNCTION PYRNMQ(ID,DTERM)
32061
32062C...Double precision and integer declarations.
32063 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32064 IMPLICIT INTEGER(I-N)
32065 INTEGER PYK,PYCHGE,PYCOMP
32066C...Commonblock.
32067 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
32068 SAVE /PYMSSM/
32069
32070C...Local variables.
32071 DOUBLE PRECISION PI,R
32072 DOUBLE PRECISION TOL
32073 DOUBLE PRECISION CI(3)
32074 EXTERNAL PYALPS
32075 DOUBLE PRECISION PYALPS
32076 DATA TOL/0.001D0/
32077 DATA PI,R/3.141592654D0,.61803399D0/
32078 DATA CI/0.47D0,0.07D0,0.02D0/
32079
32080 C=1D0-R
32081 CA=CI(ID)
32082 AG=(0.71D0)**2/4D0/PI
32083 AG=RMSS(20)
32084 XM0=RMSS(8)
32085 XMG=RMSS(1)
32086 XM02=XM0*XM0
32087 XMG2=XMG*XMG
32088
32089 AS=PYALPS(XM02+6D0*XMG2)
32090 CG=8D0/9D0*((AS/AG)**2-1D0)
32091 BX=XM02+(CA+CG)*XMG2+DTERM
32092 AX=MIN(50D0**2,0.5D0*BX)
32093 CX=MAX(2000D0**2,2D0*BX)
32094
32095 X0=AX
32096 X3=CX
32097 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
32098 X1=BX
32099 X2=BX+C*(CX-BX)
32100 ELSE
32101 X2=BX
32102 X1=BX-C*(BX-AX)
32103 ENDIF
32104 AS1=PYALPS(X1)
32105 CG=8D0/9D0*((AS1/AG)**2-1D0)
32106 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
32107 AS2=PYALPS(X2)
32108 CG=8D0/9D0*((AS2/AG)**2-1D0)
32109 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
32110 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
32111 IF(F2.LT.F1) THEN
32112 X0=X1
32113 X1=X2
32114 X2=R*X1+C*X3
32115 F1=F2
32116 AS2=PYALPS(X2)
32117 CG=8D0/9D0*((AS2/AG)**2-1D0)
32118 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
32119 ELSE
32120 X3=X2
32121 X2=X1
32122 X1=R*X2+C*X0
32123 F2=F1
32124 AS1=PYALPS(X1)
32125 CG=8D0/9D0*((AS1/AG)**2-1D0)
32126 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
32127 ENDIF
32128 GOTO 100
32129 ENDIF
32130 IF(F1.LT.F2) THEN
32131 PYRNMQ=X1
32132 XMIN=X1
32133 ELSE
32134 PYRNMQ=X2
32135 XMIN=X2
32136 ENDIF
32137
32138 RETURN
32139 END
32140
32141C*********************************************************************
32142
32143C...PYRNMT
32144C...Determines the running mass of the top quark.
32145
32146 FUNCTION PYRNMT(XMT)
32147
32148C...Double precision and integer declarations.
32149 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32150 IMPLICIT INTEGER(I-N)
32151 INTEGER PYK,PYCHGE,PYCOMP
32152C...Commonblock.
32153 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
32154 SAVE /PYMSSM/
32155
32156C...Local variables.
32157 DOUBLE PRECISION XMT
32158 DOUBLE PRECISION PI,R
32159 DOUBLE PRECISION TOL
32160 EXTERNAL PYALPS
32161 DOUBLE PRECISION PYALPS
32162 DATA TOL/0.001D0/
32163 DATA PI,R/3.141592654D0,0.61803399D0/
32164
32165 C=1D0-R
32166
32167 BX=XMT
32168 AX=MIN(50D0,BX*0.5D0)
32169 CX=MAX(300D0,2D0*BX)
32170
32171 X0=AX
32172 X3=CX
32173 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
32174 X1=BX
32175 X2=BX+C*(CX-BX)
32176 ELSE
32177 X2=BX
32178 X1=BX-C*(BX-AX)
32179 ENDIF
32180 AS1=PYALPS(X1**2)/PI
32181 F1=ABS(XMT/(1D0+4D0/3D0*AS1+11D0*AS1**2)-X1)
32182 AS2=PYALPS(X2**2)/PI
32183 F2=ABS(XMT/(1D0+4D0/3D0*AS2+11D0*AS2**2)-X2)
32184 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
32185 IF(F2.LT.F1) THEN
32186 X0=X1
32187 X1=X2
32188 X2=R*X1+C*X3
32189 F1=F2
32190 AS2=PYALPS(X2**2)/PI
32191 F2=ABS(XMT/(1D0+4D0/3D0*AS2+11D0*AS2**2)-X2)
32192 ELSE
32193 X3=X2
32194 X2=X1
32195 X1=R*X2+C*X0
32196 F2=F1
32197 AS1=PYALPS(X1**2)/PI
32198 F1=ABS(XMT/(1D0+4D0/3D0*AS1+11D0*AS1**2)-X1)
32199 ENDIF
32200 GOTO 100
32201 ENDIF
32202 IF(F1.LT.F2) THEN
32203 PYRNMT=X1
32204 XMIN=X1
32205 ELSE
32206 PYRNMT=X2
32207 XMIN=X2
32208 ENDIF
32209
32210 RETURN
32211 END
32212
32213C*********************************************************************
32214
32215C...PYTHRG
32216C...Calculates the mass eigenstates of the third generation sfermions.
32217C...Created: 5-31-96
32218
32219 SUBROUTINE PYTHRG
32220
32221C...Double precision and integer declarations.
32222 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32223 IMPLICIT INTEGER(I-N)
32224 INTEGER PYK,PYCHGE,PYCOMP
32225C...Parameter statement to help give large particle numbers.
32226 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
32227 &KEXCIT=4000000,KDIMEN=5000000)
32228C...Commonblocks.
32229 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32230 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32231 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
32232 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
32233 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
32234 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
32235
32236C...Local variables.
32237 DOUBLE PRECISION BETA
32238 DOUBLE PRECISION PYRNMT
32239 DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
32240 DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
32241 DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
32242 DOUBLE PRECISION ATR,AMQR,AMQL
32243 INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
32244 INTEGER IF,I,J,II,JJ,IT,L
32245 LOGICAL DTERM
32246 DATA SMALL/1D-3/
32247 DATA ID1/10,10,13/
32248 DATA ID2/5,6,15/
32249 DATA ID3/15,16,17/
32250 DATA ID4/11,12,14/
32251 DATA DTERM/.TRUE./
32252
32253 XMZ2=PMAS(23,1)**2
32254 XMW2=PMAS(24,1)**2
32255 TANB=RMSS(5)
32256 XMU=-RMSS(4)
32257 BETA=ATAN(TANB)
32258 COS2B=COS(2D0*BETA)
32259
32260C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
32261
32262 IOPT=IMSS(5)
32263 IF(IOPT.EQ.1) THEN
32264 CTT=DCOS(RMSS(27))
32265 CTT2=CTT**2
32266 STT=DSIN(RMSS(27))
32267 STT2=STT**2
32268 XM12=RMSS(10)**2
32269 XM22=RMSS(12)**2
32270 XMQL2=CTT2*XM12+STT2*XM22
32271 XMQR2=STT2*XM12+CTT2*XM22
32272 XMFR=PMAS(6,1)
32273 XMF2=PYRNMT(XMFR)**2
32274 ATOP=-XMU/TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
32275c ATMT=SQRT(XMF2)*(ATOP+XMU/TANB)
32276c XTEST=(XMQL2-XMQR2)*(CTT2-STT2)
32277c IF(XTEST.GT.4D0*STT*CTT*ATMT) THEN
32278c STT=-STT
32279c ATOP=-XMU/TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
32280c ENDIF
32281 RMSS(16)=ATOP
32282C......SUBTRACT OUT D-TERM AND FERMION MASS
32283 XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0
32284 XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0
32285 IF(XMQL2.GE.0D0) THEN
32286 RMSS(10)=SQRT(XMQL2)
32287 ELSE
32288 RMSS(10)=-SQRT(-XMQL2)
32289 ENDIF
32290 IF(XMQR2.GE.0D0) THEN
32291 RMSS(12)=SQRT(XMQR2)
32292 ELSE
32293 RMSS(12)=-SQRT(-XMQR2)
32294 ENDIF
32295
32296C SAME FOR BOTTOM SQUARK
32297 CTT=DCOS(RMSS(26))
32298 CTT2=CTT**2
32299 STT=DSIN(RMSS(26))
32300 STT2=STT**2
32301 XMF=3D00
32302 XMF2=XMF**2
32303 XM12=RMSS(11)**2
32304 XMQL2=SIGN(RMSS(10)**2,RMSS(10))-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2
32305
32306 IF(ABS(CTT).GE..9999D0) THEN
32307 ABOT=-XMU*TANB
32308 XMQR2=RMSS(11)**2
32309 ELSEIF(ABS(CTT).LE.1D-4) THEN
32310 ABOT=-XMU*TANB
32311 XMQR2=RMSS(11)**2
32312 ELSE
32313 XM22=(XMQL2-CTT2*XM12)/STT2
32314 XMQR2=STT2*XM12+CTT2*XM22
32315 ABOT=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
32316 ENDIF
32317c ATMT=SQRT(XMF2)*(ABOT+XMU*TANB)
32318c XTEST=(XMQL2-XMQR2)*(CTT2-STT2)
32319c IF(XTEST.GT.4D0*STT*CTT*ATMT) THEN
32320c STT=-STT
32321c ABOT=-XMU*TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
32322c ENDIF
32323 RMSS(15)=ABOT
32324C......SUBTRACT OUT D-TERM AND FERMION MASS
32325 XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2
32326 IF(XMQR2.GE.0D0) THEN
32327 RMSS(11)=SQRT(XMQR2)
32328 ELSE
32329 RMSS(11)=-SQRT(-XMQR2)
32330 ENDIF
32331C SAME FOR TAU SLEPTON
32332 CTT=DCOS(RMSS(28))
32333 CTT2=CTT**2
32334 STT=DSIN(RMSS(28))
32335 STT2=STT**2
32336 XM12=RMSS(13)**2
32337 XM22=RMSS(14)**2
32338 XMQL2=CTT2*XM12+STT2*XM22
32339 XMQR2=STT2*XM12+CTT2*XM22
32340 XMFR=PMAS(15,1)
32341 XMF2=XMFR**2
32342 ATAU=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
32343c ATMT=SQRT(XMF2)*(ATAU+XMU*TANB)
32344c XTEST=(XMQL2-XMQR2)*(CTT2-STT2)
32345c IF(XTEST.GT.4D0*STT*CTT*ATMT) THEN
32346c STT=-STT
32347c ATAU=-XMU*TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
32348c ENDIF
32349 RMSS(17)=ATAU
32350C......SUBTRACT OUT D-TERM AND FERMION MASS
32351 XMQL2=XMQL2-XMF2+(-.5D0*XMZ2+XMW2)*COS2B
32352 XMQR2=XMQR2-XMF2+(XMZ2-XMW2)*COS2B
32353 IF(XMQL2.GE.0D0) THEN
32354 RMSS(13)=SQRT(XMQL2)
32355 ELSE
32356 RMSS(13)=-SQRT(-XMQL2)
32357 ENDIF
32358 IF(XMQR2.GE.0D0) THEN
32359 RMSS(14)=SQRT(XMQR2)
32360 ELSE
32361 RMSS(14)=-SQRT(-XMQR2)
32362 ENDIF
32363 ENDIF
32364 DO 170 L=1,3
32365 AMQL=RMSS(ID1(L))
32366 IF(AMQL.LT.0D0) THEN
32367 XMQL2=-AMQL**2
32368 ELSE
32369 XMQL2=AMQL**2
32370 ENDIF
32371 IF=ID2(L)
32372 XMF=PMAS(IF,1)
32373 IF(L.EQ.1) XMF=3D0
32374 IF(L.EQ.2) XMF=PYRNMT(XMF)
32375 XMF2=XMF**2
32376 ATR=RMSS(ID3(L))
32377 AMQR=RMSS(ID4(L))
32378 IF(AMQR.LT.0D0) THEN
32379 XMQR2=-AMQR**2
32380 ELSE
32381 XMQR2=AMQR**2
32382 ENDIF
32383 AM2(1,1)=XMQL2+XMF2
32384 AM2(2,2)=XMQR2+XMF2
32385 IF(AM2(1,1).EQ.AM2(2,2)) AM2(2,2)=AM2(2,2)*1.00001D0
32386 IF(DTERM) THEN
32387 IF(L.EQ.1) THEN
32388 AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0
32389 AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
32390 AM2(1,2)=XMF*(ATR+XMU*TANB)
32391 ELSEIF(L.EQ.2) THEN
32392 AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0
32393 AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0
32394 AM2(1,2)=XMF*(ATR+XMU/TANB)
32395 ELSEIF(L.EQ.3) THEN
32396 IF(IMSS(8).EQ.1) THEN
32397 AM2(1,1)=RMSS(6)**2
32398 AM2(2,2)=RMSS(7)**2
32399 AM2(1,2)=0D0
32400 RMSS(13)=RMSS(6)
32401 RMSS(14)=RMSS(7)
32402 ELSE
32403 AM2(1,1)=AM2(1,1)-(-.5D0*XMZ2+XMW2)*COS2B
32404 AM2(2,2)=AM2(2,2)-(XMZ2-XMW2)*COS2B
32405 AM2(1,2)=XMF*(ATR+XMU*TANB)
32406 ENDIF
32407 ENDIF
32408 ENDIF
32409 AM2(2,1)=AM2(1,2)
32410 DETM=AM2(1,1)*AM2(2,2)-AM2(2,1)**2
32411 IF(DETM.LT.0D0) THEN
32412 WRITE(MSTU(11),*) ID2(L),DETM,AM2
32413 CALL PYERRM(30,' NEGATIVE**2 MASS FOR SFERMION IN PYTHRG ')
32414 ENDIF
32415 SAME=0.5D0*(AM2(1,1)+AM2(2,2))
32416 DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1))
32417 XMF12=SAME-DIFF
32418 XMF22=SAME+DIFF
32419 IT=0
32420 IF(XMF22-XMF12.GT.0D0) THEN
32421 RT(1,1) = SQRT(MAX(0D0,(XMF22-AM2(1,1))/(XMF22-XMF12)))
32422 RT(2,2) = RT(1,1)
32423 RT(1,2) = -SIGN(SQRT(MAX(0D0,1D0-RT(1,1)**2)),
32424 & AM2(1,2)/(XMF22-XMF12))
32425 RT(2,1) = -RT(1,2)
32426 ELSE
32427 RT(1,1) = 1D0
32428 RT(2,2) = RT(1,1)
32429 RT(1,2) = 0D0
32430 RT(2,1) = -RT(1,2)
32431 ENDIF
32432 100 CONTINUE
32433 IT=IT+1
32434
32435 DO 140 I=1,2
32436 DO 130 JJ=1,2
32437 DI(I,JJ)=0D0
32438 DO 120 II=1,2
32439 DO 110 J=1,2
32440 DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II)
32441 110 CONTINUE
32442 120 CONTINUE
32443 130 CONTINUE
32444 140 CONTINUE
32445
32446 IF(DI(1,1).GT.DI(2,2)) THEN
32447 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION '
32448 WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22)
32449 WRITE(MSTU(11),*) AM2
32450 WRITE(MSTU(11),*) DI
32451 WRITE(MSTU(11),*) RT
32452 DI(1,1)=-RT(2,1)
32453 DI(2,2)=RT(1,2)
32454 DI(1,2)=-RT(2,2)
32455 DI(2,1)=RT(1,1)
32456 DO 160 I=1,2
32457 DO 150 J=1,2
32458 RT(I,J)=DI(I,J)
32459 150 CONTINUE
32460 160 CONTINUE
32461 GOTO 100
32462 ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN
32463 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
32464 & ' OFF DIAGONAL ELEMENTS '
32465 WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22)
32466 WRITE(MSTU(11),*) DI
32467 WRITE(MSTU(11),*) ' ROTATION = ',RT
32468C...STOP
32469 ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN
32470 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
32471 & ' NEGATIVE MASSES '
32472 STOP
32473 ENDIF
32474 PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12)
32475 PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22)
32476 SFMIX(IF,1)=RT(1,1)
32477 SFMIX(IF,2)=RT(1,2)
32478 SFMIX(IF,3)=RT(2,1)
32479 SFMIX(IF,4)=RT(2,2)
32480 170 CONTINUE
32481
32482 RETURN
32483 END
32484
32485C*********************************************************************
32486
32487C...PYINOM
32488C...Finds the mass eigenstates and mixing matrices for neutralinos
32489C...and charginos.
32490
32491 SUBROUTINE PYINOM
32492
32493C...Double precision and integer declarations.
32494 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32495 IMPLICIT INTEGER(I-N)
32496 INTEGER PYCOMP
32497C...Parameter statement to help give large particle numbers.
32498 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
32499 &KEXCIT=4000000,KDIMEN=5000000)
32500C...Commonblocks.
32501 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32502 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32503 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
32504 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
32505 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
32506 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
32507
32508C...Local variables.
32509 DOUBLE PRECISION XMW,XMZ,XM(4)
32510 DOUBLE PRECISION AR(4,4),WR(4),ZR(4,4),ZI(4,4),AI(4,4)
32511 DOUBLE PRECISION WI(4),FV1(4),FV2(4),FV3(4)
32512 DOUBLE PRECISION COSW,SINW
32513 DOUBLE PRECISION XMU
32514 DOUBLE PRECISION TANB,COSB,SINB
32515 DOUBLE PRECISION XM1,XM2,XM3,BETA
32516 DOUBLE PRECISION Q2,AEM,A1,A2,AQ,RM1,RM2
32517 DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
32518 DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
32519 DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
32520 DOUBLE PRECISION PYALPS,PYALEM
32521 DOUBLE PRECISION PYRNM3
32522 COMPLEX*16 CAR(4,4),CAI(4,4),CA1,CA2
32523 INTEGER IERR,INDEX(4),I,J,K,IOPT,ILR,KFNCHI(4)
32524 DATA KFNCHI/1000022,1000023,1000025,1000035/
32525
32526 IOPT=IMSS(2)
32527 IF(IMSS(1).EQ.2) THEN
32528 IOPT=1
32529 ENDIF
32530C...M1, M2, AND M3 ARE INDEPENDENT
32531 IF(IOPT.EQ.0) THEN
32532 XM1=RMSS(1)
32533 XM2=RMSS(2)
32534 XM3=RMSS(3)
32535 ELSEIF(IOPT.GE.1) THEN
32536 Q2=PMAS(23,1)**2
32537 AEM=PYALEM(Q2)
32538 A2=AEM/PARU(102)
32539 A1=AEM/(1D0-PARU(102))
32540 XM1=RMSS(1)
32541 XM2=RMSS(2)
32542 IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0
32543 IF(IOPT.EQ.1) THEN
32544 XM2=XM1*A2/A1*3D0/5D0
32545 RMSS(2)=XM2
32546 ELSEIF(IOPT.EQ.3) THEN
32547 XM1=XM2*5D0/3D0*A1/A2
32548 RMSS(1)=XM1
32549 ENDIF
32550 XM3=PYRNM3(XM2/A2)
32551 RMSS(3)=XM3
32552 IF(XM3.LE.0D0) THEN
32553 WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3
32554 STOP
32555 ENDIF
32556 ENDIF
32557
32558C...GLUINO MASS
32559 IF(IMSS(3).EQ.1) THEN
32560 PMAS(PYCOMP(KSUSY1+21),1)=XM3
32561 ELSE
32562 AQ=0D0
32563 DO 110 I=1,4
32564 DO 100 ILR=1,2
32565 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
32566 AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0)
32567 & +(1D0-RM1)**2*LOG(ABS(1D0-RM1)))
32568 100 CONTINUE
32569 110 CONTINUE
32570
32571 DO 130 I=5,6
32572 DO 120 ILR=1,2
32573 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
32574 RM2=PMAS(I,1)**2/XM3**2
32575 ARG=(RM1-RM2-1D0)**2-4D0*RM2**2
32576 IF(ARG.GE.0D0) THEN
32577 X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG))
32578 AX0=ABS(X0)
32579 X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG))
32580 AX1=ABS(X1)
32581 IF(X0.EQ.1D0) THEN
32582 AT=-1D0
32583 BT=0.25D0
32584 ELSEIF(X0.EQ.0D0) THEN
32585 AT=0D0
32586 BT=-0.25D0
32587 ELSE
32588 AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+
32589 & 0.5D0*X0**2*LOG(AX0)
32590 BT=(-1D0-2D0*X0)/4D0
32591 ENDIF
32592 IF(X1.EQ.1D0) THEN
32593 AT=-1D0+AT
32594 BT=0.25D0+BT
32595 ELSEIF(X1.EQ.0D0) THEN
32596 AT=0D0+AT
32597 BT=-0.25D0+BT
32598 ELSE
32599 AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0*
32600 & X1**2*LOG(AX1)+AT
32601 BT=(-1D0-2D0*X1)/4D0+BT
32602 ENDIF
32603 AQ=AQ+AT+BT
32604 ELSE
32605 X0=0.5D0*(1D0+RM2-RM1)
32606 Y0=-0.5D0*SQRT(-ARG)
32607 AMGX0=SQRT(X0**2+Y0**2)
32608 AM1X0=SQRT((1D0-X0)**2+Y0**2)
32609 ARGX0=ATAN2(-X0,-Y0)
32610 AR1X0=ATAN2(1D0-X0,Y0)
32611 X1=X0
32612 Y1=-Y0
32613 AMGX1=AMGX0
32614 AM1X1=AM1X0
32615 ARGX1=ATAN2(-X1,-Y1)
32616 AR1X1=ATAN2(1D0-X1,Y1)
32617 AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2)
32618 & +0.5D0*(X0**2-Y0**2)*LOG(AMGX0)
32619 BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 )
32620 AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2)
32621 & +0.5D0*(X1**2-Y1**2)*LOG(AMGX1)
32622 BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 )
32623 AQ=AQ+AT+BT
32624 ENDIF
32625 120 CONTINUE
32626 130 CONTINUE
32627 PMAS(PYCOMP(KSUSY1+21),1)=XM3*(1D0+PYALPS(XM3**2)/(2D0*PARU(2))*
32628 & (15D0+AQ))
32629 ENDIF
32630
32631C...NEUTRALINO MASSES
32632 DO 150 I=1,4
32633 DO 140 J=1,4
32634 AI(I,J)=0D0
32635 140 CONTINUE
32636 150 CONTINUE
32637 XMZ=PMAS(23,1)
32638 XMW=PMAS(24,1)
32639 XMU=RMSS(4)
32640 SINW=SQRT(PARU(102))
32641 COSW=SQRT(1D0-PARU(102))
32642 TANB=RMSS(5)
32643 BETA=ATAN(TANB)
32644 COSB=COS(BETA)
32645 SINB=TANB*COSB
32646
32647C... Definitions:
32648C... psi^0 =(-i bino^0, -i wino^0, h_d^0(=H_1^0), h_u^0(=H_2^0))
32649C... => L_neutralino = -1/2*(psi^0)^T * [AR] * psi^0 + h.c.
32650 AR(1,1) = XM1*COS(RMSS(30))
32651 AI(1,1) = XM1*SIN(RMSS(30))
32652 AR(2,2) = XM2*COS(RMSS(31))
32653 AI(2,2) = XM2*SIN(RMSS(31))
32654 AR(3,3) = 0D0
32655 AR(4,4) = 0D0
32656 AR(1,2) = 0D0
32657 AR(2,1) = 0D0
32658 AR(1,3) = -XMZ*SINW*COSB
32659 AR(3,1) = AR(1,3)
32660 AR(1,4) = XMZ*SINW*SINB
32661 AR(4,1) = AR(1,4)
32662 AR(2,3) = XMZ*COSW*COSB
32663 AR(3,2) = AR(2,3)
32664 AR(2,4) = -XMZ*COSW*SINB
32665 AR(4,2) = AR(2,4)
32666 AR(3,4) = -XMU*COS(RMSS(33))
32667 AI(3,4) = -XMU*SIN(RMSS(33))
32668 AR(4,3) = -XMU*COS(RMSS(33))
32669 AI(4,3) = -XMU*SIN(RMSS(33))
32670C CALL PYEIG4(AR,WR,ZR)
32671 CALL PYEICG(4,4,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
32672 IF(IERR.NE.0) THEN
32673 WRITE(MSTU(11),*) ' PROBLEM WITH PYEICG IN PYINOM '
32674 ENDIF
32675 DO 160 I=1,4
32676 INDEX(I)=I
32677 XM(I)=ABS(WR(I))
32678 160 CONTINUE
32679 DO 180 I=2,4
32680 K=I
32681 DO 170 J=I-1,1,-1
32682 IF(XM(K).LT.XM(J)) THEN
32683 ITMP=INDEX(J)
32684 XTMP=XM(J)
32685 INDEX(J)=INDEX(K)
32686 XM(J)=XM(K)
32687 INDEX(K)=ITMP
32688 XM(K)=XTMP
32689 K=K-1
32690 ELSE
32691 GOTO 180
32692 ENDIF
32693 170 CONTINUE
32694 180 CONTINUE
32695
32696
32697 DO 210 I=1,4
32698 K=INDEX(I)
32699 SMZ(I)=WR(K)
32700 PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I))
32701 S=0D0
32702 DO 190 J=1,4
32703 S=S+ZR(J,K)**2+ZI(J,K)**2
32704 190 CONTINUE
32705 DO 200 J=1,4
32706 ZMIX(I,J)=ZR(J,K)/SQRT(S)
32707 ZMIXI(I,J)=ZI(J,K)/SQRT(S)
32708 IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0
32709 IF(ABS(ZMIXI(I,J)).LT.1D-6) ZMIXI(I,J)=0D0
32710 200 CONTINUE
32711 210 CONTINUE
32712
32713C...CHARGINO MASSES
32714C.....Find eigenvectors of X X^*
32715 AI(1,1) = 0D0
32716 AI(2,2) = 0D0
32717 AR(1,1) = XM2**2+2D0*XMW**2*SINB**2
32718 AR(2,2) = XMU**2+2D0*XMW**2*COSB**2
32719 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
32720 &XMU*COS(RMSS(33))*SINB)
32721 AI(1,2) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*COSB-
32722 &XMU*SIN(RMSS(33))*SINB)
32723 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
32724 &XMU*COS(RMSS(33))*SINB)
32725 AI(2,1) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*COSB+
32726 &XMU*SIN(RMSS(33))*SINB)
32727 CALL PYEICG(4,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
32728 IF(IERR.NE.0) THEN
32729 WRITE(MSTU(11),*) ' PROBLEM WITH PYEICG IN PYINOM '
32730 ENDIF
32731 INDEX(1)=1
32732 INDEX(2)=2
32733 IF(WR(2).LT.WR(1)) THEN
32734 INDEX(1)=2
32735 INDEX(2)=1
32736 ENDIF
32737
32738 DO 240 I=1,2
32739 K=INDEX(I)
32740 SMW(I)=SQRT(WR(K))
32741 S=0D0
32742 DO 220 J=1,2
32743 S=S+ZR(J,K)**2+ZI(J,K)**2
32744 220 CONTINUE
32745 DO 230 J=1,2
32746 UMIX(I,J)=ZR(J,K)/SQRT(S)
32747 UMIXI(I,J)=-ZI(J,K)/SQRT(S)
32748 IF(ABS(UMIX(I,J)).LT.1D-6) UMIX(I,J)=0D0
32749 IF(ABS(UMIXI(I,J)).LT.1D-6) UMIXI(I,J)=0D0
32750 230 CONTINUE
32751 240 CONTINUE
32752 IF(ABS(SMW(1)).LT.ABS(SMZ(1))) THEN
32753 SMW(1)=SIGN(ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1),SMW(1))
32754 ENDIF
32755 PMAS(PYCOMP(KSUSY1+24),1)=SMW(1)
32756 PMAS(PYCOMP(KSUSY1+37),1)=SMW(2)
32757
32758C.....Find eigenvectors of X^* X
32759 AI(1,1) = 0D0
32760 AI(2,2) = 0D0
32761 AR(1,1) = XM2**2+2D0*XMW**2*COSB**2
32762 AR(2,2) = XMU**2+2D0*XMW**2*SINB**2
32763 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
32764 &XMU*COS(RMSS(33))*COSB)
32765 AI(1,2) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*SINB+
32766 &XMU*SIN(RMSS(33))*COSB)
32767 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
32768 &XMU*COS(RMSS(33))*COSB)
32769 AI(2,1) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*SINB-
32770 &XMU*SIN(RMSS(33))*COSB)
32771 CALL PYEICG(4,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
32772 IF(IERR.NE.0) THEN
32773 WRITE(MSTU(11),*) ' PROBLEM WITH PYEICG IN PYINOM '
32774 ENDIF
32775 INDEX(1)=1
32776 INDEX(2)=2
32777 IF(WR(2).LT.WR(1)) THEN
32778 INDEX(1)=2
32779 INDEX(2)=1
32780 ENDIF
32781
32782 DO 270 I=1,2
32783 K=INDEX(I)
32784 S=0D0
32785 DO 250 J=1,2
32786 S=S+ZR(J,K)**2+ZI(J,K)**2
32787 250 CONTINUE
32788 DO 260 J=1,2
32789 VMIX(I,J)=ZR(J,K)/SQRT(S)
32790 VMIXI(I,J)=-ZI(J,K)/SQRT(S)
32791 IF(ABS(VMIX(I,J)).LT.1D-6) VMIX(I,J)=0D0
32792 IF(ABS(VMIXI(I,J)).LT.1D-6) VMIXI(I,J)=0D0
32793 260 CONTINUE
32794 270 CONTINUE
32795
32796
32797 RETURN
32798 END
32799
32800C*********************************************************************
32801
32802C...PYRNM3
32803C...Calculates the running of M3, the SU(3) gluino mass parameter.
32804
32805 FUNCTION PYRNM3(RGUT)
32806
32807C...Double precision and integer declarations.
32808 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32809 IMPLICIT INTEGER(I-N)
32810 INTEGER PYK,PYCHGE,PYCOMP
32811
32812C...Local variables.
32813 DOUBLE PRECISION R
32814 DOUBLE PRECISION TOL
32815 EXTERNAL PYALPS
32816 DOUBLE PRECISION PYALPS
32817 DATA TOL/0.001D0/
32818 DATA R/0.61803399D0/
32819
32820 C=1D0-R
32821
32822 BX=RGUT*PYALPS(RGUT**2)
32823 AX=MIN(50D0,BX*0.5D0)
32824 CX=MAX(2000D0,2D0*BX)
32825
32826 X0=AX
32827 X3=CX
32828 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
32829 X1=BX
32830 X2=BX+C*(CX-BX)
32831 ELSE
32832 X2=BX
32833 X1=BX-C*(BX-AX)
32834 ENDIF
32835 AS1=PYALPS(X1**2)
32836 F1=ABS(X1-RGUT*AS1)
32837 AS2=PYALPS(X2**2)
32838 F2=ABS(X2-RGUT*AS2)
32839 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
32840 IF(F2.LT.F1) THEN
32841 X0=X1
32842 X1=X2
32843 X2=R*X1+C*X3
32844 F1=F2
32845 AS2=PYALPS(X2**2)
32846 F2=ABS(X2-RGUT*AS2)
32847 ELSE
32848 X3=X2
32849 X2=X1
32850 X1=R*X2+C*X0
32851 F2=F1
32852 AS1=PYALPS(X1**2)
32853 F1=ABS(X1-RGUT*AS1)
32854 ENDIF
32855 GOTO 100
32856 ENDIF
32857 IF(F1.LT.F2) THEN
32858 PYRNM3=X1
32859 XMIN=X1
32860 ELSE
32861 PYRNM3=X2
32862 XMIN=X2
32863 ENDIF
32864
32865 RETURN
32866 END
32867
32868C*********************************************************************
32869
32870C...PYEIG4
32871C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
32872C...Specific application: mixing in neutralino sector.
32873
32874 SUBROUTINE PYEIG4(A,W,Z)
32875
32876C...Double precision and integer declarations.
32877 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32878 IMPLICIT INTEGER(I-N)
32879 INTEGER PYK,PYCHGE,PYCOMP
32880
32881C...Arrays: in call and local.
32882 DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)
32883
32884C...Coefficients of fourth-degree equation from matrix.
32885C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
32886 B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
32887 B2=0D0
32888 DO 110 I=1,3
32889 DO 100 J=I+1,4
32890 B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
32891 100 CONTINUE
32892 110 CONTINUE
32893 B1=0D0
32894 B0=0D0
32895 DO 120 I=1,4
32896 I1=MOD(I,4)+1
32897 I2=MOD(I+1,4)+1
32898 I3=MOD(I+2,4)+1
32899 B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
32900 & A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
32901 & A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
32902 B0=B0+(-1D0)**(I+1)*A(1,I)*(
32903 & A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
32904 & A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
32905 & A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
32906 120 CONTINUE
32907
32908C...Coefficients of third-degree equation needed for
32909C...separation into two second-degree equations.
32910C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
32911 C2=-B2
32912 C1=B1*B3-4D0*B0
32913 C0=-B1**2-B0*B3**2+4D0*B0*B2
32914 CQ=C1/3D0-C2**2/9D0
32915 CR=C1*C2/6D0-C0/2D0-C2**3/27D0
32916 CQR=CQ**3+CR**2
32917
32918C...Cases with one or three real roots.
32919 IF(CQR.GE.0D0) THEN
32920 S1=(CR+SQRT(CQR))**(1D0/3D0)
32921 S2=(CR-SQRT(CQR))**(1D0/3D0)
32922 U=S1+S2-C2/3D0
32923 ELSE
32924 SABS=SQRT(-CQ)
32925 THE=ACOS(CR/SABS**3)/3D0
32926 SRE=SABS*COS(THE)
32927 U=2D0*SRE-C2/3D0
32928 ENDIF
32929
32930C...Find and solve two second-degree equations.
32931 P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
32932 P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
32933 Q1=U/2D0+SQRT(U**2/4D0-B0)
32934 Q2=U/2D0-SQRT(U**2/4D0-B0)
32935 IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
32936 QSAV=Q1
32937 Q1=Q2
32938 Q2=QSAV
32939 ENDIF
32940 X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
32941 X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
32942 X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
32943 X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)
32944
32945C...Order eigenvalues in asceding mass.
32946 W(1)=X(1)
32947 DO 150 I1=2,4
32948 DO 130 I2=I1-1,1,-1
32949 IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
32950 W(I2+1)=W(I2)
32951 130 CONTINUE
32952 140 W(I2+1)=X(I1)
32953 150 CONTINUE
32954
32955C...Find equation system for eigenvectors.
32956 DO 250 I=1,4
32957 DO 170 J1=1,4
32958 D(J1,J1)=A(J1,J1)-W(I)
32959 DO 160 J2=J1+1,4
32960 D(J1,J2)=A(J1,J2)
32961 D(J2,J1)=A(J2,J1)
32962 160 CONTINUE
32963 170 CONTINUE
32964
32965C...Find largest element in matrix.
32966 DAMAX=0D0
32967 DO 190 J1=1,4
32968 DO 180 J2=1,4
32969 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
32970 JA=J1
32971 JB=J2
32972 DAMAX=ABS(D(J1,J2))
32973 180 CONTINUE
32974 190 CONTINUE
32975
32976C...Subtract others by multiple of row selected above.
32977 DAMAX=0D0
32978 DO 210 J3=JA+1,JA+3
32979 J1=J3-4*((J3-1)/4)
32980 RL=D(J1,JB)/D(JA,JB)
32981 DO 200 J2=1,4
32982 D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
32983 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
32984 JC=J1
32985 JD=J2
32986 DAMAX=ABS(D(J1,J2))
32987 200 CONTINUE
32988 210 CONTINUE
32989
32990C...Do one more subtraction of a row.
32991 DAMAX=0D0
32992 DO 230 J3=JC+1,JC+3
32993 J1=J3-4*((J3-1)/4)
32994 IF(J1.EQ.JA) GOTO 230
32995 RL=D(J1,JD)/D(JC,JD)
32996 DO 220 J2=1,4
32997 IF(J2.EQ.JB) GOTO 220
32998 D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
32999 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
33000 JE=J1
33001 DAMAX=ABS(D(J1,J2))
33002 220 CONTINUE
33003 230 CONTINUE
33004
33005C...Construct unnormalized eigenvector.
33006 JF1=JD+1-4*(JD/4)
33007 JF2=JD+2-4*((JD+1)/4)
33008 IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
33009 IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
33010 E(JF1)=-D(JE,JF2)
33011 E(JF2)=D(JE,JF1)
33012 E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
33013 E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
33014 & D(JA,JB)
33015
33016C...Normalize and fill in final array.
33017 EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
33018 SGN=(-1D0)**INT(PYR(0)+0.5D0)
33019 DO 240 J=1,4
33020 Z(I,J)=SGN*E(J)/EA
33021 240 CONTINUE
33022 250 CONTINUE
33023
33024 RETURN
33025 END
33026
33027C*********************************************************************
33028
33029C...PYHGGM
33030C...Determines the Higgs boson mass spectrum using several inputs.
33031
33032 SUBROUTINE PYHGGM(ALPHA)
33033
33034C...Double precision and integer declarations.
33035 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33036 IMPLICIT INTEGER(I-N)
33037 INTEGER PYK,PYCHGE,PYCOMP
33038C...Parameter statement to help give large particle numbers.
33039 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
33040 &KEXCIT=4000000,KDIMEN=5000000)
33041C...Commonblocks.
33042 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33043 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33044 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
33045 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
33046 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/
33047
33048C...Local variables.
33049 DOUBLE PRECISION AT,AB,XMU,TANB
33050 DOUBLE PRECISION ALPHA
33051 INTEGER IHOPT
33052 DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
33053 DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
33054 DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
33055 DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
33056
33057 IHOPT=IMSS(4)
33058 IF(IHOPT.EQ.2) THEN
33059 ALPHA=RMSS(18)
33060 RETURN
33061 ENDIF
33062 AT=RMSS(16)
33063 AB=RMSS(15)
33064 DMGL=RMSS(3)
33065 XMU=RMSS(4)
33066 TANB=RMSS(5)
33067
33068 DMA=RMSS(19)
33069 DTANB=TANB
33070 DMQ=RMSS(10)
33071 DMUR=RMSS(12)
33072 DMDR=RMSS(11)
33073 DMTOP=PMAS(6,1)
33074 DMC=PMAS(PYCOMP(KSUSY1+37),1)
33075 DAU=AT
33076 DAD=AB
33077 DMU=XMU
33078 RMSS(40)=0D0
33079 RMSS(41)=0D0
33080
33081 IF(IHOPT.EQ.0) THEN
33082 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
33083 & DMHCH,DSA,DCA,DTANBA)
33084 ELSEIF(IHOPT.EQ.1) THEN
33085 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
33086 & DMHCH,DSA,DCA,DTANBA)
33087 CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU,
33088 & DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA,
33089 & DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA,DMGL,DDT,DDB)
33090 RMSS(40)=DDT
33091 RMSS(41)=DDB
33092 DMH=DMHP
33093 DHM=DHMP
33094 DMA=DAMP
33095 IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.5D-1) THEN
33096 WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
33097 WRITE(MSTU(11),*) ' STOP1 MASSES = ',
33098 & PMAS(PYCOMP(1000006),1),DSTOP2
33099 ENDIF
33100 IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.5D-1) THEN
33101 WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
33102 WRITE(MSTU(11),*) ' STOP2 MASSES = ',
33103 & PMAS(PYCOMP(2000006),1),DSTOP1
33104 ENDIF
33105 IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.5D-1) THEN
33106 WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
33107 WRITE(MSTU(11),*) ' SBOT1 MASSES = ',
33108 & PMAS(PYCOMP(1000005),1),DSBOT2
33109 ENDIF
33110 IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.5D-1) THEN
33111 WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
33112 WRITE(MSTU(11),*) ' SBOT2 MASSES = ',
33113 & PMAS(PYCOMP(2000005),1),DSBOT1
33114 ENDIF
33115
33116 ENDIF
33117
33118 ALPHA=ACOS(DCA)
33119
33120 PMAS(25,1)=DMH
33121 PMAS(35,1)=DHM
33122 PMAS(36,1)=DMA
33123 PMAS(37,1)=DMHCH
33124
33125 RETURN
33126 END
33127
33128C*********************************************************************
33129
33130C...PYSUBH
33131C...This routine computes the renormalization group improved
33132C...values of Higgs masses and couplings in the MSSM.
33133
33134C...Program based on the work by M. Carena, J.R. Espinosa,
33135c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
33136
33137C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
33138C...All masses in GeV units. MA is the CP-odd Higgs mass,
33139C...MTOP is the physical top mass, MQ and MUR are the soft
33140C...supersymmetry breaking mass parameters of left handed
33141C...and right handed stops respectively, AU and AD are the
33142C...stop and sbottom trilinear soft breaking terms,
33143C...respectively, and MU is the supersymmetric
33144C...Higgs mass parameter. We use the conventions from
33145C...the physics report of Haber and Kane: left right
33146C...stop mixing term proportional to (AU - MU/TANB)
33147C...We use as input TANB defined at the scale MTOP
33148
33149C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
33150C...where MH and HM are the lightest and heaviest CP-even
33151C...Higgs masses, MHCH is the charged Higgs mass and
33152C...ALPHA is the Higgs mixing angle
33153C...TANBA is the angle TANB at the CP-odd Higgs mass scale
33154
33155C...Range of validity:
33156C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
33157C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
33158C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
33159C...are the sbottom mass eigenvalues, respectively. This
33160C...range automatically excludes the existence of tachyons.
33161C...For the charged Higgs mass computation, the method is
33162C...valid if
33163C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
33164C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
33165C...where M_SUSY**2 is the average of the squared stop mass
33166C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
33167C...masses have been assumed to be of order of the stop ones
33168C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
33169
33170 SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
33171 &XMHCH,SA,CA,TANBA)
33172
33173C...Double precision and integer declarations.
33174 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33175 IMPLICIT INTEGER(I-N)
33176 INTEGER PYK,PYCHGE,PYCOMP
33177C...Parameter statement to help give large particle numbers.
33178 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
33179 &KEXCIT=4000000,KDIMEN=5000000)
33180C...Commonblocks.
33181 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33182 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33183 COMMON/PYHTRI/HHH(7)
33184 SAVE /PYDAT1/,/PYDAT2/
33185
33186C...Local variables.
33187 DOUBLE PRECISION PYALEM,PYALPS
33188 DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
33189 DOUBLE PRECISION XMHCH,SA,CA
33190 DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
33191 DOUBLE PRECISION Q02
33192 DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
33193 DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
33194 DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
33195 DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
33196 DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
33197 DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
33198 DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
33199 DOUBLE PRECISION AU2,XMU2,XMZ,XMS3
33200
33201 XMZ = PMAS(23,1)
33202 Q02=XMZ**2
33203 AEM=PYALEM(Q02)
33204 ALP1=AEM/(1D0-PARU(102))
33205 ALP2=AEM/PARU(102)
33206 ALPH3Z=PYALPS(Q02)
33207
33208 ALP1 = 0.0101D0
33209 ALP2 = 0.0337D0
33210 ALPH3Z = 0.12D0
33211
33212 V = 174.1D0
33213 PI = PARU(1)
33214 TANBA = TANB
33215 TANBT = TANB
33216
33217C...MBOTTOM(MTOP) = 3. GEV
33218 XMB = 3D0
33219 ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z*
33220 &LOG(XMTOP**2/XMZ**2))
33221
33222C...RMTOP= RUNNING TOP QUARK MASS
33223 RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
33224 XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0
33225 T = LOG(XMS**2/XMTOP**2)
33226 SINB = TANB/((1D0 + TANB**2)**0.5D0)
33227 COSB = SINB/TANB
33228C...IF(MA.LE.XMTOP) TANBA = TANBT
33229 IF(XMA.GT.XMTOP)
33230 &TANBA = TANBT*(1D0-3D0/32D0/PI**2*
33231 &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
33232 &LOG(XMA**2/XMTOP**2))
33233
33234 SINBT = TANBT/SQRT(1D0 + TANBT**2)
33235 COSBT = 1D0/SQRT(1D0 + TANBT**2)
33236C COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
33237 G1 = SQRT(ALP1*4D0*PI)
33238 G2 = SQRT(ALP2*4D0*PI)
33239 G3 = SQRT(ALP3*4D0*PI)
33240 HU = RMTOP/V/SINBT
33241 HD = XMB/V/COSBT
33242 HU2=HU*HU
33243 HD2=HD*HD
33244 HU4=HU2*HU2
33245 HD4=HD2*HD2
33246 AU2=AU**2
33247 AD2=AD**2
33248 XMS2=XMS**2
33249 XMS3=XMS**3
33250 XMS4=XMS2*XMS2
33251 XMU2=XMU*XMU
33252 PI2=PI*PI
33253
33254 XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2)
33255 XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2)
33256 AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4
33257 &+ 3D0*(AU + AD)**2/XMS2)/6D0
33258 XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2)
33259 &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
33260 &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2)
33261 &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2
33262 &- 16D0*G3**2) *T/16D0/PI2)
33263 XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2)
33264 &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
33265 &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2)
33266 &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2
33267 &- 16D0*G3**2) *T/16D0/PI2)
33268 XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
33269 &(HU2 + HD2)*T/16D0/PI2)
33270 &+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
33271 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
33272 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
33273 &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0
33274 &- 16D0*G3**2) *T/16D0/PI2)
33275 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
33276 &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2
33277 &- 16D0*G3**2) *T/16D0/PI2)
33278 XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2)
33279 &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
33280 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
33281 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
33282 &XMS4)*
33283 &(1+ (6D0*HU2 -2D0* HD2
33284 &- 16D0*G3**2) *T/16D0/PI2)
33285 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
33286 &XMS4)*
33287 &(1+ (6D0*HD2 -2D0* HU2/2D0
33288 &- 16D0*G3**2) *T/16D0/PI2)
33289 XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) *
33290 &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2)
33291 &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) *
33292 &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2)
33293 XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) *
33294 &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
33295 &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) *
33296 &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
33297 XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) *
33298 &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
33299 &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) *
33300 &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
33301 HHH(1)=XLAM1
33302 HHH(2)=XLAM2
33303 HHH(3)=XLAM3
33304 HHH(4)=XLAM4
33305 HHH(5)=XLAM5
33306 HHH(6)=XLAM6
33307 HHH(7)=XLAM7
33308 TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 +
33309 &2D0* XLAM6*SINBT*COSBT
33310 &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT
33311 &+ XLAM5*COSBT**2)
33312 DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) +
33313 &XLAM6*COSBT**2
33314 &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 +
33315 &2D0* XLAM6* COSBT*SINBT
33316 &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
33317 &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 *
33318 &((XLAM1* COSBT**2 +2D0*
33319 &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 +
33320 &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2)
33321 &*SINBT**2
33322 &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3
33323 &+ XLAM4) + XLAM6*COSBT**2
33324 &+ XLAM7* SINBT**2))
33325
33326 XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0
33327 XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0
33328 XHM = SQRT(XHM2)
33329 XMH = SQRT(XMH2)
33330 XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2
33331 XMHCH = SQRT(XMHCH2)
33332
33333 SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) -
33334 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
33335 &XLAM6* COSBT*SINBT
33336 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
33337 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
33338 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/
33339 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0
33340
33341 COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) +
33342 &XLAM6*COSBT**2 + XLAM7* SINBT**2) -
33343 &XMA**2*SINBT*COSBT))/2D0**0.5D0/
33344 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)*
33345 &(((TRM2**2 - 4D0* DETM2)**0.5D0) -
33346 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
33347 &XLAM6* COSBT*SINBT
33348 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
33349 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
33350 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2))))
33351
33352 SA = -SINALP
33353 CA = -COSALP
33354
33355 100 CONTINUE
33356
33357 RETURN
33358 END
33359
33360C*********************************************************************
33361
33362C...PYPOLE
33363C...This subroutine computes the CP-even higgs and CP-odd pole
33364c...Higgs masses and mixing angles.
33365
33366C...Program based on the work by M. Carena, M. Quiros
33367C...and C.E.M. Wagner, "Effective potential methods and
33368C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
33369
33370C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
33371C...AT,AB,MU
33372C...where MCHI is the largest chargino mass, MA is the running
33373C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
33374C...expectaion values at the scale MTOP, MQ is the third generation
33375C...left handed squark mass parameter, MUR is the third generation
33376C...right handed stop mass parameter, MDR is the third generation
33377C...right handed sbottom mass parameter, MTOP is the pole top quark
33378C...mass; AT,AB are the soft supersymmetry breaking trilinear
33379C...couplings of the stop and sbottoms, respectively, and MU is the
33380C...supersymmetric mass parameter
33381
33382C...The parameter IHIGGS=0,1,2,3 corresponds to the number of
33383C...Higgses whose pole mass is computed. If IHIGGS=0 only running
33384C...masses are given, what makes the running of the program
33385c...much faster and it is quite generally a good approximation
33386c...(for a theoretical discussion see ref. above). If IHIGGS=1,
33387C...only the pole mass for H is computed. If IHIGGS=2, then h and H,
33388c...and if IHIGGS=3, then h,H,A polarizations are computed
33389
33390C...Output: MH and MHP which are the lightest CP-even Higgs running
33391C...and pole masses, respectively; HM and HMP are the heaviest CP-even
33392C...Higgs running and pole masses, repectively; SA and CA are the
33393C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
33394C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
33395C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
33396C...the value of TANB at the CP-odd Higgs mass scale
33397
33398C...This subroutine makes use of CERN library subroutine
33399C...integration package, which makes the computation of the
33400C...pole Higgs masses somewhat faster. We thank P. Janot for this
33401C...improvement. Those who are not able to call the CERN
33402C...libraries, please use the subroutine SUBHPOLE2.F, which
33403C...although somewhat slower, gives identical results
33404
33405 SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
33406 &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA,XMG,DT,DB)
33407
33408C...Double precision and integer declarations.
33409 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33410 IMPLICIT INTEGER(I-N)
33411
33412C...Parameters.
33413 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33414 SAVE /PYDAT1/
33415 INTEGER PYK,PYCHGE,PYCOMP
33416
33417C...Local variables.
33418 DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
33419 &SSBOT2(2),B(2,2),COUPB(2,2),
33420 &HCOUPT(2,2),HCOUPB(2,2),
33421 &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
33422
33423 DELTA(1,1) = 1D0
33424 DELTA(2,2) = 1D0
33425 DELTA(1,2) = 0D0
33426 DELTA(2,1) = 0D0
33427 V = 174.1D0
33428 XMZ=91.18D0
33429 PI=PARU(1)
33430C ALP3Z=0.12D0
33431C ALP3=1D0/(1D0/ALP3Z+23D0/6D0/PI*LOG(XMT/XMZ))
33432
33433C RXMT = XMT/(1D0+4*ALP3/3D0/PI)
33434 RXMT = PYRNMT(XMT)
33435 CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
33436 &XMU,XMH,HM,XMCH,SA,CA,SAB,CAB,TANBA,XMG,DT,DB)
33437
33438 SINB = TANB/(TANB**2+1D0)**0.5D0
33439 COSB = 1D0/(TANB**2+1D0)**0.5D0
33440 COS2B = SINB**2 - COSB**2
33441 SINBPA = SINB*CA + COSB*SA
33442 COSBPA = COSB*CA - SINB*SA
33443 RMBOT = 3D0
33444 XMQ2 = XMQ**2
33445 XMUR2 = XMUR**2
33446 IF(XMUR.LT.0D0) XMUR2=-XMUR2
33447 XMDR2 = XMDR**2
33448 XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B
33449 XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
33450 IF(XMST11.LT.0D0) GOTO 500
33451 IF(XMST22.LT.0D0) GOTO 500
33452 XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B
33453 XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
33454 IF(XMSB11.LT.0D0) GOTO 500
33455 IF(XMSB22.LT.0D0) GOTO 500
33456C WMST11 = RXMT**2 + XMQ2
33457C WMST22 = RXMT**2 + XMUR2
33458 XMST12 = RXMT*(AT - XMU/TANB)
33459 XMSB12 = RMBOT*(AB - XMU*TANB)
33460
33461CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33462C...STOP EIGENVALUES CALCULATION
33463CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33464
33465 STOP12 = 0.5D0*(XMST11+XMST22) +
33466 &0.5D0*((XMST11+XMST22)**2 -
33467 &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
33468 STOP22 = 0.5D0*(XMST11+XMST22) -
33469 &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
33470 &XMST12**2))**0.5D0
33471
33472 IF(STOP22.LT.0D0) GOTO 500
33473 SSTOP2(1) = STOP12
33474 SSTOP2(2) = STOP22
33475 STOP1 = STOP12**0.5D0
33476 STOP2 = STOP22**0.5D0
33477C STOP1W = STOP1
33478C STOP2W = STOP2
33479
33480 IF(XMST12.EQ.0D0) XST11 = 1D0
33481 IF(XMST12.EQ.0D0) XST12 = 0D0
33482 IF(XMST12.EQ.0D0) XST21 = 0D0
33483 IF(XMST12.EQ.0D0) XST22 = 1D0
33484
33485 IF(XMST12.EQ.0D0) GOTO 110
33486
33487 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
33488 XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
33489 XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
33490 XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
33491
33492 110 T(1,1) = XST11
33493 T(2,2) = XST22
33494 T(1,2) = XST12
33495 T(2,1) = XST21
33496
33497 SBOT12 = 0.5D0*(XMSB11+XMSB22) +
33498 &0.5D0*((XMSB11+XMSB22)**2 -
33499 &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
33500 SBOT22 = 0.5D0*(XMSB11+XMSB22) -
33501 &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
33502 &XMSB12**2))**0.5D0
33503 IF(SBOT22.LT.0D0) GOTO 500
33504 SBOT1 = SBOT12**0.5D0
33505 SBOT2 = SBOT22**0.5D0
33506
33507 SSBOT2(1) = SBOT12
33508 SSBOT2(2) = SBOT22
33509
33510 IF(XMSB12.EQ.0D0) XSB11 = 1D0
33511 IF(XMSB12.EQ.0D0) XSB12 = 0D0
33512 IF(XMSB12.EQ.0D0) XSB21 = 0D0
33513 IF(XMSB12.EQ.0D0) XSB22 = 1D0
33514
33515 IF(XMSB12.EQ.0D0) GOTO 130
33516
33517 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
33518 XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
33519 XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
33520 XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
33521
33522 130 B(1,1) = XSB11
33523 B(2,2) = XSB22
33524 B(1,2) = XSB12
33525 B(2,1) = XSB21
33526
33527
33528 SINT = 0.2320D0
33529 SQR = DSQRT(2D0)
33530 VP = 174.1D0*SQR
33531
33532CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33533C...STARTING OF LIGHT HIGGS
33534CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33535
33536 IF(IHIGGS.EQ.0) GOTO 490
33537
33538 DO 150 I = 1,2
33539 DO 140 J = 1,2
33540 COUPT(I,J) =
33541 & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
33542 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
33543 & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
33544 & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
33545 & T(1,J)*T(2,I))
33546 140 CONTINUE
33547 150 CONTINUE
33548
33549
33550 DO 170 I = 1,2
33551 DO 160 J = 1,2
33552 COUPB(I,J) =
33553 & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
33554 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
33555 & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
33556 & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
33557 & B(1,J)*B(2,I))
33558 160 CONTINUE
33559 170 CONTINUE
33560
33561 PRUN = XMH
33562 EPS = 1D-4*PRUN
33563 ITER = 0
33564 180 ITER = ITER + 1
33565 DO 230 I3 = 1,3
33566
33567 PR(I3)=PRUN+(I3-2)*EPS/2
33568 P2=PR(I3)**2
33569 POLT = 0D0
33570 DO 200 I = 1,2
33571 DO 190 J = 1,2
33572 POLT = POLT + COUPT(I,J)**2*3D0*
33573 & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
33574 190 CONTINUE
33575 200 CONTINUE
33576
33577 POLB = 0D0
33578 DO 220 I = 1,2
33579 DO 210 J = 1,2
33580 POLB = POLB + COUPB(I,J)**2*3D0*
33581 & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
33582 210 CONTINUE
33583 220 CONTINUE
33584C RXMT2 = RXMT**2
33585 XMT2=XMT**2
33586
33587 POLTT =
33588 & 3D0*RXMT**2/8D0/PI**2/ V **2*
33589 & CA**2/SINB**2 *
33590 & (-2D0*XMT**2+0.5D0*P2)*
33591 & PYFINT(P2,XMT2,XMT2)
33592
33593 POL = POLT + POLB + POLTT
33594 POLAR(I3) = P2 - XMH**2 - POL
33595 230 CONTINUE
33596 DERIV = (POLAR(3)-POLAR(1))/EPS
33597 DRUN = - POLAR(2)/DERIV
33598 PRUN = PRUN + DRUN
33599 P2 = PRUN**2
33600 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 240
33601 GOTO 180
33602 240 CONTINUE
33603
33604 XMHP = DSQRT(P2)
33605
33606CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33607C...END OF LIGHT HIGGS
33608CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33609
33610 250 IF(IHIGGS.EQ.1) GOTO 490
33611
33612CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33613C... STARTING OF HEAVY HIGGS
33614CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33615
33616 DO 270 I = 1,2
33617 DO 260 J = 1,2
33618 HCOUPT(I,J) =
33619 & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
33620 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
33621 & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
33622 & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
33623 & T(1,J)*T(2,I))
33624 260 CONTINUE
33625 270 CONTINUE
33626
33627 DO 290 I = 1,2
33628 DO 280 J = 1,2
33629 HCOUPB(I,J) =
33630 & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
33631 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
33632 & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
33633 & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
33634 & B(1,J)*B(2,I))
33635 HCOUPB(I,J)=0D0
33636 280 CONTINUE
33637 290 CONTINUE
33638
33639 PRUN = HM
33640 EPS = 1D-4*PRUN
33641 ITER = 0
33642 300 ITER = ITER + 1
33643 DO 350 I3 = 1,3
33644 PR(I3)=PRUN+(I3-2)*EPS/2
33645 HP2=PR(I3)**2
33646
33647 HPOLT = 0D0
33648 DO 320 I = 1,2
33649 DO 310 J = 1,2
33650 HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
33651 & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
33652 310 CONTINUE
33653 320 CONTINUE
33654
33655 HPOLB = 0D0
33656 DO 340 I = 1,2
33657 DO 330 J = 1,2
33658 HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
33659 & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
33660 330 CONTINUE
33661 340 CONTINUE
33662
33663C RXMT2 = RXMT**2
33664 XMT2 = XMT**2
33665
33666 HPOLTT =
33667 & 3D0*RXMT**2/8D0/PI**2/ V **2*
33668 & SA**2/SINB**2 *
33669 & (-2D0*XMT**2+0.5D0*HP2)*
33670 & PYFINT(HP2,XMT2,XMT2)
33671
33672 HPOL = HPOLT + HPOLB + HPOLTT
33673 POLAR(I3) =HP2-HM**2-HPOL
33674 350 CONTINUE
33675 DERIV = (POLAR(3)-POLAR(1))/EPS
33676 DRUN = - POLAR(2)/DERIV
33677 PRUN = PRUN + DRUN
33678 HP2 = PRUN**2
33679 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 360
33680 GOTO 300
33681 360 CONTINUE
33682
33683
33684 370 CONTINUE
33685 HMP = HP2**0.5D0
33686
33687CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33688C... END OF HEAVY HIGGS
33689CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33690
33691 IF(IHIGGS.EQ.2) GOTO 490
33692
33693CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33694C...BEGINNING OF PSEUDOSCALAR HIGGS
33695CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33696
33697 DO 390 I = 1,2
33698 DO 380 J = 1,2
33699 ACOUPT(I,J) =
33700 & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
33701 & (T(1,I)*T(2,J) -T(1,J)*T(2,I))
33702 380 CONTINUE
33703 390 CONTINUE
33704 DO 410 I = 1,2
33705 DO 400 J = 1,2
33706 ACOUPB(I,J) =
33707 & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
33708 & (B(1,I)*B(2,J) -B(1,J)*B(2,I))
33709 400 CONTINUE
33710 410 CONTINUE
33711
33712 PRUN = XMA
33713 EPS = 1D-4*PRUN
33714 ITER = 0
33715 420 ITER = ITER + 1
33716 DO 470 I3 = 1,3
33717 PR(I3)=PRUN+(I3-2)*EPS/2
33718 AP2=PR(I3)**2
33719 APOLT = 0D0
33720 DO 440 I = 1,2
33721 DO 430 J = 1,2
33722 APOLT = APOLT + ACOUPT(I,J)**2*3D0*
33723 & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
33724 430 CONTINUE
33725 440 CONTINUE
33726 APOLB = 0D0
33727 DO 460 I = 1,2
33728 DO 450 J = 1,2
33729 APOLB = APOLB + ACOUPB(I,J)**2*3D0*
33730 & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
33731 450 CONTINUE
33732 460 CONTINUE
33733C RXMT2 = RXMT**2
33734 XMT2=XMT**2
33735 APOLTT =
33736 & 3D0*RXMT**2/8D0/PI**2/ V **2*
33737 & COSB**2/SINB**2 *
33738 & (-0.5D0*AP2)*
33739 & PYFINT(AP2,XMT2,XMT2)
33740 APOL = APOLT + APOLB + APOLTT
33741 POLAR(I3) = AP2 - XMA**2 -APOL
33742 470 CONTINUE
33743 DERIV = (POLAR(3)-POLAR(1))/EPS
33744 DRUN = - POLAR(2)/DERIV
33745 PRUN = PRUN + DRUN
33746 AP2 = PRUN**2
33747 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 480
33748 GOTO 420
33749 480 CONTINUE
33750
33751 AMP = DSQRT(AP2)
33752
33753CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33754C...END OF PSEUDOSCALAR HIGGS
33755CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33756
33757 IF(IHIGGS.EQ.3) GOTO 490
33758
33759 490 CONTINUE
33760 RETURN
33761 500 CONTINUE
33762 WRITE(MSTU(11),*) ' EXITING IN PYPOLE '
33763 WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
33764 WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
33765 WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
33766 STOP
33767 END
33768
33769C*********************************************************************
33770
33771C...PYRGHM
33772C...Auxiliary to PYPOLE.
33773
33774 SUBROUTINE PYRGHM(MCHI,MA,TANB,MQ,MUR,MD,MTOP,AU,AD,MU,
33775 * MHP,HMP,MCH,SA,CA,SAB,CAB,TANBA,MGLU,DELTAMT,DELTAMB)
33776 IMPLICIT DOUBLE PRECISION(A-H,L,M,O-Z)
33777 DIMENSION VH(2,2),M2(2,2),M2P(2,2)
33778C...Parameters.
33779 INTEGER MSTU,MSTJ
33780 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33781 SAVE /PYDAT1/
33782
33783 MZ = 91.18D0
33784 PI = PARU(1)
33785 V = 174.1D0
33786 ALPHA1 = 0.0101D0
33787 ALPHA2 = 0.0337D0
33788 ALPHA3Z = 0.12D0
33789 TANBA = TANB
33790 TANBT = TANB
33791C MBOTTOM(MTOP) = 3. GEV
33792 MB = 3D0
33793 ALPHA3 = ALPHA3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPHA3Z*
33794 *LOG(MTOP**2/MZ**2))
33795C RMTOP= RUNNING TOP QUARK MASS
33796 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
33797 TQ = LOG((MQ**2+MTOP**2)/MTOP**2)
33798 TU = LOG((MUR**2 + MTOP**2)/MTOP**2)
33799 TD = LOG((MD**2 + MTOP**2)/MTOP**2)
33800CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33801C
33802C NEW DEFINITION, TGLU.
33803C
33804CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33805 TGLU = LOG(MGLU**2/MTOP**2)
33806 SINB = TANB/DSQRT(1D0 + TANB**2)
33807 COSB = SINB/TANB
33808 IF(MA.GT.MTOP)
33809 *TANBA = TANB*(1D0-3D0/32D0/PI**2*
33810 *(RMTOP**2/V**2/SINB**2-MB**2/V**2/COSB**2)*
33811 *LOG(MA**2/MTOP**2))
33812 IF(MA.LT.MTOP.OR.MA.EQ.MTOP) TANBT = TANBA
33813 SINB = TANBT/SQRT(1D0 + TANBT**2)
33814 COSB = 1D0/DSQRT(1D0 + TANBT**2)
33815 G1 = SQRT(ALPHA1*4D0*PI)
33816 G2 = SQRT(ALPHA2*4D0*PI)
33817 G3 = SQRT(ALPHA3*4D0*PI)
33818 HU = RMTOP/V/SINB
33819 HD = MB/V/COSB
33820 CALL PYGFXX(MA,TANBA,MQ,MUR,MD,MTOP,AU,AD,MU,MGLU,VH,STOP1,STOP2,
33821 *SBOT1,SBOT2,DELTAMT,DELTAMB)
33822 IF(MQ.GT.MUR) TP = TQ - TU
33823 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TP = TU - TQ
33824 IF(MQ.GT.MUR) TDP = TU
33825 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TDP = TQ
33826 IF(MQ.GT.MD) TPD = TQ - TD
33827 IF(MQ.LT.MD.OR.MQ.EQ.MD) TPD = TD - TQ
33828 IF(MQ.GT.MD) TDPD = TD
33829 IF(MQ.LT.MD.OR.MQ.EQ.MD) TDPD = TQ
33830
33831 IF(MQ.GT.MD) DLAMBDA1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD
33832 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA1 = 3D0/32D0/PI**2*
33833 * HD**2*(G1**2/3D0+G2**2)*TPD
33834
33835 IF(MQ.GT.MUR) DLAMBDA2 =12D0/96D0/PI**2*G1**2*HU**2*TP
33836 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA2 = 3D0/32D0/PI**2*
33837 * HU**2*(-G1**2/3D0+G2**2)*TP
33838
33839CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33840C
33841C DLAMBDAP1 AND DLAMBDAP2 ARE THE NEW LOG CORRECTIONS DUE TO
33842C THE PRESENCE OF THE GLUINO MASS. THEY ARE IN GENERAL VERY SMALL,
33843C AND ONLY PRESENT IF THERE IS A HIERARCHY OF MASSES BETWEEN THE
33844C TWO STOPS.
33845C
33846C
33847CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33848
33849 IF(MGLU.LT.MUR.OR.MGLU.LT.MQ) THEN
33850 IF(MQ.GT.MUR.AND.MGLU.GT.MUR) THEN
33851 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TGLU**2)
33852 ENDIF
33853
33854 IF(MQ.GT.MUR.AND.MGLU.LT.MUR) THEN
33855 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
33856 ENDIF
33857
33858 IF(MQ.GT.MUR.AND.MGLU.EQ.MUR) THEN
33859 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
33860 ENDIF
33861
33862 IF(MUR.GT.MQ.AND.MGLU.GT.MQ) THEN
33863 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TGLU**2)
33864 ENDIF
33865
33866 IF(MUR.GT.MQ.AND.MGLU.LT.MQ) THEN
33867 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
33868 ENDIF
33869
33870 IF(MUR.GT.MQ.AND.MGLU.EQ.MQ) THEN
33871 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
33872 ENDIF
33873 ENDIF
33874 DLAMBDA3 = 0D0
33875 DLAMBDA4 = 0D0
33876 IF(MQ.GT.MD) DLAMBDA3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD
33877 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA3 = 3D0/64D0/PI**2*HD**2*
33878 *(G2**2-G1**2/3D0)*TPD
33879 IF(MQ.GT.MUR) DLAMBDA3 = DLAMBDA3 -
33880 *1D0/16D0/PI**2*G1**2*HU**2*TP
33881 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA3 = DLAMBDA3 +
33882 * 3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP
33883 IF(MQ.LT.MUR) DLAMBDA4 = -3D0/32D0/PI**2*G2**2*HU**2*TP
33884 IF(MQ.LT.MD) DLAMBDA4 = DLAMBDA4 - 3D0/32D0/PI**2*G2**2*
33885 *HD**2*TPD
33886 LAMBDA1 = ((G1**2 + G2**2)/4D0)*
33887 * (1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2)
33888 *+(3D0*HD**4D0/16D0/PI**2) *TPD*(1D0
33889 *+ (3D0*HD**2/2D0 + HU**2/2D0
33890 *- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2)
33891 *+(3D0*HD**4D0/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0
33892 *- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAMBDA1
33893 LAMBDA2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2*
33894 *(TP + TDP)/8D0/PI**2)
33895 *+(3D0*HU**4D0/16D0/PI**2) *TP*(1D0
33896 *+ (3D0*HU**2/2D0 + HD**2/2D0
33897 *- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2)
33898 *+(3D0*HU**4D0/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0
33899 *- 8D0*G3**2) * TDP/16D0/PI**2) + DLAMBDA2 + DLAMBDAP2
33900 LAMBDA3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
33901 *(HU**2)*(TP + TDP)/16D0/PI**2 -3D0*
33902 *(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA3
33903 LAMBDA4 = (- G2**2/2D0)*(1D0
33904 *-3D0*(HU**2)*(TP + TDP)/16D0/PI**2
33905 *-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA4
33906
33907 LAMBDA5 = 0D0
33908 LAMBDA6 = 0D0
33909 LAMBDA7 = 0D0
33910
33911 M2(1,1) = 2D0*V**2*(LAMBDA1*COSB**2+2D0*LAMBDA6*
33912 *COSB*SINB + LAMBDA5*SINB**2) + MA**2*SINB**2
33913
33914 M2(2,2) = 2D0*V**2*(LAMBDA5*COSB**2+2D0*LAMBDA7*
33915 *COSB*SINB + LAMBDA2*SINB**2) + MA**2*COSB**2
33916 M2(1,2) = 2D0*V**2*(LAMBDA6*COSB**2+(LAMBDA3+LAMBDA4)*
33917 *COSB*SINB + LAMBDA7*SINB**2) - MA**2*SINB*COSB
33918
33919 M2(2,1) = M2(1,2)
33920CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33921CCC THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
33922CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33923
33924 MSSUSY=DSQRT(.5D0*(MQ**2+MUR**2)+MTOP**2)
33925
33926 IF(MCHI.GT.MSSUSY) GOTO 100
33927 IF(MCHI.LT.MTOP) MCHI=MTOP
33928
33929 TCHAR=LOG(MSSUSY**2/MCHI**2)
33930
33931 DELTAL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR
33932 DELTAL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4
33933 *+4D0/32D0/PI**2*G1**2*G2**2)*TCHAR
33934
33935 DELTAM112=2D0*DELTAL12*V**2*COSB**2
33936 DELTAM222=2D0*DELTAL12*V**2*SINB**2
33937 DELTAM122=2D0*DELTAL3P4*V**2*SINB*COSB
33938
33939 M2(1,1)=M2(1,1)+DELTAM112
33940 M2(2,2)=M2(2,2)+DELTAM222
33941 M2(1,2)=M2(1,2)+DELTAM122
33942 M2(2,1)=M2(2,1)+DELTAM122
33943
33944 100 CONTINUE
33945
33946CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33947CCC END OF CHARGINOS/NEUTRALINOS
33948CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33949
33950 DO 120 I = 1,2
33951 DO 110 J = 1,2
33952 M2P(I,J) = M2(I,J) + VH(I,J)
33953 110 CONTINUE
33954 120 CONTINUE
33955 TRM2P = M2P(1,1) + M2P(2,2)
33956 DETM2P = M2P(1,1)*M2P(2,2) - M2P(1,2)*M2P(2,1)
33957 MH2P = (TRM2P - DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
33958 HM2P = (TRM2P + DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
33959 HMP = DSQRT(HM2P)
33960 MCH2=MA**2+(LAMBDA5-LAMBDA4)*V**2
33961 MCH=DSQRT(MCH2)
33962 IF(MH2P.LT.0.) GOTO 130
33963 MHP = SQRT(MH2P)
33964 SIN2ALPHA = 2D0*M2P(1,2)/SQRT(TRM2P**2-4D0*DETM2P)
33965 COS2ALPHA = (M2P(1,1)-M2P(2,2))/SQRT(TRM2P**2-4D0*DETM2P)
33966 IF(COS2ALPHA.GT.0.) ALPHA = ASIN(SIN2ALPHA)/2D0
33967 IF(COS2ALPHA.LT.0.) ALPHA = -PI/2D0-ASIN(SIN2ALPHA)/2D0
33968 SA = SIN(ALPHA)
33969 CA = COS(ALPHA)
33970CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33971C
33972C HERE THE VALUES OF SAB AND CAB ARE DEFINED, IN ORDER
33973C TO DEFINE THE NEW COUPLINGS OF THE LIGHTEST AND
33974C HEAVY CP-EVEN HIGGS TO THE BOTTOM QUARK.
33975C
33976C
33977CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33978 SAB = SA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0+CA/SA/TANB))
33979 CAB = CA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0-SA/CA/TANB))
33980 130 CONTINUE
33981 RETURN
33982 END
33983
33984C*********************************************************************
33985
33986C...PYGFXX
33987C...Auxiliary to PYRGHM.
33988
33989 SUBROUTINE PYGFXX(MA,TANB,MQ,MUR,MD,MTOP,AT,AB,XMU,XMGL,VH,
33990 * STOP1,STOP2,SBOT1,SBOT2,DELTAMT,DELTAMB)
33991 IMPLICIT DOUBLE PRECISION(A-H,M,O-Z)
33992 DIMENSION VH(2,2),VH3T(2,2),VH3B(2,2),AL(2,2)
33993C...Commonblocks.
33994 INTEGER MSTU,MSTJ,KCHG
33995 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33996 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33997 SAVE /PYDAT1/,/PYDAT2/
33998
33999 G(X,Y) = 2.D0 - (X+Y)/(X-Y)*DLOG(X/Y)
34000
34001 T(X,Y,Z) = (X**2*Y**2*LOG(X**2/Y**2) + X**2*Z**2*LOG(Z**2/X**2)
34002 * + Y**2*Z**2*LOG(Y**2/Z**2))/((X**2-Y**2)*(Y**2-Z**2)*(X**2-Z**2))
34003
34004 IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0
34005 MQ2 = MQ**2
34006 MUR2 = MUR**2
34007 MD2 = MD**2
34008 TANBA = TANB
34009 SINBA = TANBA/DSQRT(TANBA**2+1D0)
34010 COSBA = SINBA/TANBA
34011
34012 SINB = TANB/DSQRT(TANB**2+1D0)
34013 COSB = SINB/TANB
34014
34015 PI = PARU(1)
34016 MZ = PMAS(23,1)
34017 MW = PMAS(24,1)
34018 SW = 1D0-MW**2/MZ**2
34019 V = 174.1D0
34020
34021 ALPHA3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(MTOP**2/MZ**2))
34022 G2 = DSQRT(0.0336D0*4D0*PI)
34023 G1 = DSQRT(0.0101D0*4D0*PI)
34024
34025 MB = 3D0
34026 IF(MQ.GT.MUR) MST = MQ
34027 IF(MUR.GT.MQ.OR.MUR.EQ.MQ) MST = MUR
34028
34029 MSUSYT = DSQRT(MST**2 + MTOP**2)
34030
34031 IF(MQ.GT.MD) MSB = MQ
34032 IF(MD.GT.MQ.OR.MD.EQ.MQ) MSB = MD
34033
34034 MSUSYB = DSQRT(MSB**2 + MB**2)
34035 TT = LOG(MSUSYT**2/MTOP**2)
34036 TB = LOG(MSUSYB**2/MTOP**2)
34037
34038 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
34039 HT = RMTOP/(V*SINB)
34040 HTST = RMTOP/V
34041 HB = MB/V/COSB
34042 G32 = ALPHA3*4D0*PI
34043 BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2
34044 BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2
34045 AL2 = 3D0/8D0/PI**2*HT**2
34046C BT2ST = -(8.*G32 - 9.*HTST**2/2.)/(4.*PI)**2
34047C ALST = 3./8./PI**2*HTST**2
34048 AL1 = 3D0/8D0/PI**2*HB**2
34049
34050 AL(1,1) = AL1
34051 AL(1,2) = (AL2+AL1)/2D0
34052 AL(2,1) = (AL2+AL1)/2D0
34053 AL(2,2) = AL2
34054
34055 IF(MA.GT.MTOP) THEN
34056 VI = V*(1D0 + 3D0/32D0/PI**2*HTST**2*
34057 * LOG(MTOP**2/MA**2))
34058 H1I = VI* COSBA
34059 H2I = VI*SINBA
34060 H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYT**2))**.25D0
34061 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYT**2))**.25D0
34062 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYB**2))**.25D0
34063 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYB**2))**.25D0
34064 ELSE
34065 VI = V
34066 H1I = VI*COSB
34067 H2I = VI*SINB
34068 H1T=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYT**2))**.25D0
34069 H2T=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYT**2))**.25D0
34070 H1B=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYB**2))**.25D0
34071 H2B=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYB**2))**.25D0
34072 ENDIF
34073
34074 TANBST = H2T/H1T
34075 SINBT = TANBST/DSQRT(1D0+TANBST**2)
34076
34077 TANBSB = H2B/H1B
34078 SINBB = TANBSB/DSQRT(1D0+TANBSB**2)
34079 COSBB = SINBB/TANBSB
34080
34081 DELTAMT = 0D0
34082 DELTAMB = 0D0
34083
34084 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
34085 MTOP2 = DSQRT(MTOP4)
34086 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
34087 * /(1D0+DELTAMB)**4
34088 MBOT2 = DSQRT(MBOT4)
34089
34090 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
34091 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
34092 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
34093 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
34094 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
34095 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
34096 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
34097 * MQ2 - MUR2)**2*0.25D0
34098 * + MTOP2*(AT-XMU/TANBST)**2)
34099 IF(STOP22.LT.0.) GOTO 120
34100 SBOT12 = (MQ2 + MD2)*.5D0
34101 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
34102 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
34103 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
34104 SBOT22 = (MQ2 + MD2)*.5D0
34105 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
34106 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
34107 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
34108 IF(SBOT22.LT.0.) SBOT22 = 10000D0
34109
34110 STOP1 = DSQRT(STOP12)
34111 STOP2 = DSQRT(STOP22)
34112 SBOT1 = DSQRT(SBOT12)
34113 SBOT2 = DSQRT(SBOT22)
34114
34115CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34116C
34117C HERE IS THE DEFINITION OF DELTAMB AND DELTAMT, WHICH
34118C ARE THE VERTEX CORRECTIONS TO THE BOTTOM AND TOP QUARK
34119C MASS, KEEPING THE DOMINANT QCD AND TOP YUKAWA COUPLING
34120C INDUCED CORRECTIONS.
34121C
34122CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34123
34124 X=SBOT1
34125 Y=SBOT2
34126 Z=XMGL
34127 IF(X.EQ.Y) X = X - 0.00001D0
34128 IF(X.EQ.Z) X = X - 0.00002D0
34129 IF(Y.EQ.Z) Y = Y - 0.00003D0
34130
34131 T1=T(X,Y,Z)
34132 X=STOP1
34133 Y=STOP2
34134 Z=XMU
34135 IF(X.EQ.Y) X = X - 0.00001D0
34136 IF(X.EQ.Z) X = X - 0.00002D0
34137 IF(Y.EQ.Z) Y = Y - 0.00003D0
34138 T2=T(X,Y,Z)
34139 DELTAMB = -2*ALPHA3/3D0/PI*XMGL*(AB-XMU*TANB)*T1
34140 * + HT**2/(4D0*PI)**2*(AT-XMU/TANB)*XMU*TANB*T2
34141 X=STOP1
34142 Y=STOP2
34143 Z=XMGL
34144 IF(X.EQ.Y) X = X - 0.00001D0
34145 IF(X.EQ.Z) X = X - 0.00002D0
34146 IF(Y.EQ.Z) Y = Y - 0.00003D0
34147 T3=T(X,Y,Z)
34148 DELTAMT = -2D0*ALPHA3/3D0/PI*(AT-XMU/TANB)*XMGL*T3
34149
34150CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34151C
34152C HERE THE NEW VALUES OF THE TOP AND BOTTOM QUARK MASSES AT
34153C THE SCALE MS ARE DEFINED, TO BE USED IN THE EFFECTIVE
34154C POTENTIAL APPROXIMATION. THEY ARE JUST THE OLD ONES, BUT
34155C INCLUDING THE FINITE CORRECTIONS DELTAMT AND DELTAMB.
34156C THE DELTAMB CORRECTIONS CAN BECOME LARGE AND ARE RESUMMED
34157C TO ALL ORDERS, AS SUGGESTED IN THE TWO RECENT WORKS BY M. CARENA,
34158C S. MRENNA AND C.E.M. WAGNER, AS WELL AS IN THE WORK BY M. CARENA,
34159C D. GARCIA, U. NIERSTE AND C.E.M. WAGNER, TO APPEAR. THE TOP
34160C QUARK MASS CORRECTIONS ARE SMALL AND ARE KEPT IN THE PERTURBATIVE
34161C FORMULATION. THE FUNCTION T(X,Y,Z) IS NECESSARY FOR THE
34162C CALCULATION. THE ENTRIES ARE MASSES AND NOT THEIR SQUARES !
34163C
34164C
34165CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34166
34167 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
34168 MTOP2 = DSQRT(MTOP4)
34169 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
34170 * /(1D0+DELTAMB)**4
34171 MBOT2 = DSQRT(MBOT4)
34172
34173 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
34174 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
34175 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
34176 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
34177 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
34178 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
34179 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
34180 * MQ2 - MUR2)**2*0.25D0
34181 * + MTOP2*(AT-XMU/TANBST)**2)
34182
34183 IF(STOP22.LT.0.) GOTO 120
34184 SBOT12 = (MQ2 + MD2)*.5D0
34185 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
34186 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
34187 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
34188 SBOT22 = (MQ2 + MD2)*.5D0
34189 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
34190 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
34191 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
34192 IF(SBOT22.LT.0.) GOTO 120
34193
34194
34195 STOP1 = DSQRT(STOP12)
34196 STOP2 = DSQRT(STOP22)
34197 SBOT1 = DSQRT(SBOT12)
34198 SBOT2 = DSQRT(SBOT22)
34199
34200CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34201CCC D-TERMS
34202CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34203 STW=SW
34204
34205 F1T=(MQ2-MUR2)/(STOP12-STOP22)*(.5D0-4D0/3D0*STW)*
34206 * LOG(STOP1/STOP2)
34207 * +(.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(MQ2+MTOP2))
34208 * + 2D0/3D0*STW*LOG(STOP1*STOP2/(MUR2+MTOP2))
34209
34210 F1B=(MQ2-MD2)/(SBOT12-SBOT22)*(-.5D0+2D0/3D0*STW)*
34211 * LOG(SBOT1/SBOT2)
34212 * +(-.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(MQ2+MBOT2))
34213 * - 1D0/3D0*STW*LOG(SBOT1*SBOT2/(MD2+MBOT2))
34214
34215 F2T=DSQRT(MTOP2)*(AT-XMU/TANBST)/(STOP12-STOP22)*
34216 * (-.5D0*LOG(STOP12/STOP22)
34217 * +(4D0/3D0*STW-.5D0)*(MQ2-MUR2)/(STOP12-STOP22)*
34218 * G(STOP12,STOP22))
34219
34220 F2B=DSQRT(MBOT2)*(AB-XMU*TANBSB)/(SBOT12-SBOT22)*
34221 * (.5D0*LOG(SBOT12/SBOT22)
34222 * +(-2D0/3D0*STW+.5D0)*(MQ2-MD2)/(SBOT12-SBOT22)*
34223 * G(SBOT12,SBOT22))
34224
34225 VH3B(1,1) = MBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/
34226 * (MQ2+MBOT2)/(MD2+MBOT2))
34227 * + 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))*
34228 * LOG(SBOT1**2/SBOT2**2)) +
34229 * MBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/
34230 * (SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22)
34231
34232 VH3T(1,1) =
34233 * MTOP4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2
34234 * -STOP2**2))**2*G(STOP12,STOP22)
34235
34236 VH3B(1,1)=VH3B(1,1)+
34237 * MZ**2*(2*MBOT2*F1B-DSQRT(MBOT2)*AB*F2B)
34238
34239 VH3T(1,1) = VH3T(1,1) +
34240 * MZ**2*(DSQRT(MTOP2)*XMU/TANBST*F2T)
34241
34242 VH3T(2,2) = MTOP4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/
34243 * (MQ2+MTOP2)/(MUR2+MTOP2))
34244 * + 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))*
34245 * LOG(STOP1**2/STOP2**2)) +
34246 * MTOP4/(SINBT**2)*(AT*(AT-XMU/TANBST)/
34247 * (STOP1**2-STOP2**2))**2*G(STOP12,STOP22)
34248
34249 VH3B(2,2) =
34250 * MBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2
34251 * -SBOT2**2))**2*G(SBOT12,SBOT22)
34252
34253 VH3T(2,2)=VH3T(2,2)+
34254 * MZ**2*(-2*MTOP2*F1T+DSQRT(MTOP2)*AT*F2T)
34255 VH3B(2,2) = VH3B(2,2) -MZ**2*DSQRT(MBOT2)*XMU*TANBSB*F2B
34256 VH3T(1,2) = -
34257 * MTOP4/(SINBT**2)*XMU*(AT-XMU/TANBST)/
34258 * (STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT*
34259 * (AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22))
34260
34261 VH3B(1,2) =
34262 * - MBOT4/(COSBB**2)*XMU*(AB-XMU*TANBSB)/
34263 * (SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB*
34264 * (AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22))
34265
34266
34267 VH3T(1,2)=VH3T(1,2) +
34268 *MZ**2*(MTOP2/TANBST*F1T-DSQRT(MTOP2)*(AT/TANBST+XMU)/2D0*F2T)
34269
34270 VH3B(1,2)=VH3B(1,2) +
34271 *MZ**2*(-MBOT2*TANBSB*F1B+DSQRT(MBOT2)*(AB*TANBSB+XMU)/2D0*F2B)
34272
34273 VH3T(2,1) = VH3T(1,2)
34274 VH3B(2,1) = VH3B(1,2)
34275
34276C TQ = LOG((MQ2 + MTOP2)/MTOP2)
34277C TU = LOG((MUR2+MTOP2)/MTOP2)
34278C TQD = LOG((MQ2 + MB**2)/MB**2)
34279C TD = LOG((MD2+MB**2)/MB**2)
34280
34281 DO 110 I = 1,2
34282 DO 100 J = 1,2
34283 VH(I,J) =
34284 * 6D0/(8D0*PI**2*(H1T**2+H2T**2))
34285 * *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) +
34286 * 6D0/(8D0*PI**2*(H1B**2+H2B**2))
34287 * *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0)
34288 100 CONTINUE
34289 110 CONTINUE
34290
34291 GOTO 150
34292 120 DO 140 I =1,2
34293 DO 130 J = 1,2
34294 VH(I,J) = -1D15
34295 130 CONTINUE
34296 140 CONTINUE
34297
34298
34299 150 RETURN
34300 END
34301
34302
34303
34304
34305
34306C*********************************************************************
34307
34308C...PYFINT
34309C...Auxiliary routine to PYPOLE for SUSY Higgs calculations.
34310
34311 FUNCTION PYFINT(A,B,C)
34312
34313C...Double precision and integer declarations.
34314 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34315 IMPLICIT INTEGER(I-N)
34316 INTEGER PYK,PYCHGE,PYCOMP
34317C...Commonblock.
34318 COMMON/PYINTS/XXM(20)
34319 SAVE/PYINTS/
34320
34321C...Local variables.
34322 EXTERNAL PYFISB
34323 DOUBLE PRECISION PYFISB
34324
34325 XXM(1)=A
34326 XXM(2)=B
34327 XXM(3)=C
34328 XLO=0D0
34329 XHI=1D0
34330 PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3)
34331
34332 RETURN
34333 END
34334
34335C*********************************************************************
34336
34337C...PYFISB
34338C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
34339
34340 FUNCTION PYFISB(X)
34341
34342C...Double precision and integer declarations.
34343 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34344 IMPLICIT INTEGER(I-N)
34345 INTEGER PYK,PYCHGE,PYCOMP
34346C...Commonblock.
34347 COMMON/PYINTS/XXM(20)
34348 SAVE/PYINTS/
34349
34350 PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/
34351 &(X*(XXM(2)-XXM(3))+XXM(3)))
34352
34353 RETURN
34354 END
34355
34356C*********************************************************************
34357
34358C...PYSFDC
34359C...Calculates decays of sfermions.
34360
34361 SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT)
34362
34363C...Double precision and integer declarations.
34364 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34365 IMPLICIT INTEGER(I-N)
34366 INTEGER PYK,PYCHGE,PYCOMP
34367C...Parameter statement to help give large particle numbers.
34368 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
34369 &KEXCIT=4000000,KDIMEN=5000000)
34370C...Commonblocks.
34371 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34372 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34373 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
34374 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
34375 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
34376 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
34377
34378C...Local variables.
34379 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2)
34380 COMPLEX*16 CAL,CAR,CBL,CBR,CALP,CARP,CBLP,CBRP,CA,CB
34381 INTEGER KFIN,KCIN
34382 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,AXMJ
34383 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
34384 DOUBLE PRECISION PYLAMF,XL
34385 DOUBLE PRECISION TANW,XW,AEM,C1,AS
34386 DOUBLE PRECISION AL,AR,BL,BR
34387 DOUBLE PRECISION CH1,CH2,CH3,CH4
34388 DOUBLE PRECISION XMBOT,XMTOP
34389 DOUBLE PRECISION XLAM(0:300)
34390 INTEGER IDLAM(300,3)
34391 INTEGER LKNT,IX,ILR,IDU,J,I,IKNT,IFL,II
34392 DOUBLE PRECISION SR2
34393 DOUBLE PRECISION CBETA,SBETA
34394 DOUBLE PRECISION CW
34395 DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
34396 DOUBLE PRECISION COSA,SINA,TANB
34397 DOUBLE PRECISION PYALEM,PI,PYALPS,EI,PYRNMT
34398 DOUBLE PRECISION GHRR,GHLL,GHLR,XMB,BLR
34399 INTEGER IG,KF1,KF2
34400 INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
34401 DATA IGG/23,25,35,36/
34402 DATA PI/3.141592654D0/
34403 DATA SR2/1.4142136D0/
34404 DATA KFNCHI/1000022,1000023,1000025,1000035/
34405 DATA KFCCHI/1000024,1000037/
34406
34407C...COUNT THE NUMBER OF DECAY MODES
34408 LKNT=0
34409
34410C...NO NU_R DECAYS
34411 IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR.
34412 &KFIN.EQ.KSUSY2+16) RETURN
34413
34414 XMW=PMAS(24,1)
34415 XMW2=XMW**2
34416 XMZ=PMAS(23,1)
34417 XW=PARU(102)
34418 TANW = SQRT(XW/(1D0-XW))
34419 CW=SQRT(1D0-XW)
34420
34421 DO 110 I=1,4
34422 DO 100 J=1,4
34423 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
34424 100 CONTINUE
34425 110 CONTINUE
34426 DO 130 I=1,2
34427 DO 120 J=1,2
34428 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
34429 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
34430 120 CONTINUE
34431 130 CONTINUE
34432
34433C...KCIN
34434 KCIN=PYCOMP(KFIN)
34435C...ILR is 1 for left and 2 for right.
34436 ILR=KFIN/KSUSY1
34437C...IFL is matching non-SUSY flavour.
34438 IFL=MOD(KFIN,KSUSY1)
34439C...IDU is weak isospin, 1 for down and 2 for up.
34440 IDU=2-MOD(IFL,2)
34441
34442 XMI=PMAS(KCIN,1)
34443 XMI2=XMI**2
34444 AEM=PYALEM(XMI2)
34445 AS =PYALPS(XMI2)
34446 C1=AEM/XW
34447 XMI3=XMI**3
34448 EI=KCHG(IFL,1)/3D0
34449
34450 XMBOT=3D0
34451 XMTOP=PYRNMT(PMAS(6,1))
34452 XMBOT=0D0
34453
34454 TANB=RMSS(5)
34455 BETA=ATAN(TANB)
34456 ALFA=RMSS(18)
34457 CBETA=COS(BETA)
34458 SBETA=TANB*CBETA
34459 SINA=SIN(ALFA)
34460 COSA=COS(ALFA)
34461 XMU=-RMSS(4)
34462 ATRIT=RMSS(16)
34463 ATRIB=RMSS(15)
34464 ATRIL=RMSS(17)
34465
34466C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
34467
34468 IF(IMSS(11).EQ.1) THEN
34469 XMP=RMSS(29)
34470 IDG=39+KSUSY1
34471 XMGR=PMAS(PYCOMP(IDG),1)
34472 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
34473 IF(IFL.EQ.5) THEN
34474 XMF=XMBOT
34475 ELSEIF(IFL.EQ.6) THEN
34476 XMF=XMTOP
34477 ELSE
34478 XMF=PMAS(IFL,1)
34479 ENDIF
34480 IF(XMI.GT.XMGR+XMF) THEN
34481 LKNT=LKNT+1
34482 IDLAM(LKNT,1)=IDG
34483 IDLAM(LKNT,2)=IFL
34484 IDLAM(LKNT,3)=0
34485 XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4
34486 ENDIF
34487 ENDIF
34488
34489C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
34490
34491C...CHARGED DECAYS:
34492 DO 140 IX=1,2
34493C...DI -> U CHI1-,CHI2-
34494 IF(IDU.EQ.1) THEN
34495 XMFP=PMAS(IFL+1,1)
34496 XMF =PMAS(IFL,1)
34497C...UI -> D CHI1+,CHI2+
34498 ELSE
34499 XMFP=PMAS(IFL-1,1)
34500 XMF =PMAS(IFL,1)
34501 ENDIF
34502 XMJ=SMW(IX)
34503 AXMJ=ABS(XMJ)
34504 IF(XMI.GE.AXMJ+XMFP) THEN
34505 XMA2=XMJ**2
34506 XMB2=XMFP**2
34507 IF(IDU.EQ.2) THEN
34508 IF(IFL.EQ.6) THEN
34509 XMFP=XMBOT
34510 XMF =XMTOP
34511 ELSEIF(IFL.LT.6) THEN
34512 XMF=0D0
34513 XMFP=0D0
34514 ENDIF
34515 CBL=VMIXC(IX,1)
34516 CAL=-XMFP*UMIXC(IX,2)/SR2/XMW/CBETA
34517 CBR=-XMF*VMIXC(IX,2)/SR2/XMW/SBETA
34518 CAR=0D0
34519 ELSE
34520 IF(IFL.EQ.5) THEN
34521 XMF =XMBOT
34522 XMFP=XMTOP
34523 ELSEIF(IFL.LT.5) THEN
34524 XMF=0D0
34525 XMFP=0D0
34526 ENDIF
34527 CBL=UMIXC(IX,1)
34528 CAL=-XMFP*VMIXC(IX,2)/SR2/XMW/SBETA
34529 CBR=-XMF*UMIXC(IX,2)/SR2/XMW/CBETA
34530 CAR=0D0
34531 ENDIF
34532
34533 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
34534 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
34535 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
34536 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
34537 CAL=CALP
34538 CBL=CBLP
34539 CAR=CARP
34540 CBR=CBRP
34541
34542C...F1 -> F` CHI
34543 IF(ILR.EQ.1) THEN
34544 CA=CAL
34545 CB=CBL
34546C...F2 -> F` CHI
34547 ELSE
34548 CA=CAR
34549 CB=CBR
34550 ENDIF
34551 LKNT=LKNT+1
34552 XL=PYLAMF(XMI2,XMA2,XMB2)
34553C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
34554 XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
34555 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMFP)
34556 IDLAM(LKNT,3)=0
34557 IF(IDU.EQ.1) THEN
34558 IDLAM(LKNT,1)=-KFCCHI(IX)
34559 IDLAM(LKNT,2)=IFL+1
34560 ELSE
34561 IDLAM(LKNT,1)=KFCCHI(IX)
34562 IDLAM(LKNT,2)=IFL-1
34563 ENDIF
34564 ENDIF
34565 140 CONTINUE
34566
34567C...NEUTRAL DECAYS
34568 DO 150 IX=1,4
34569C...DI -> D CHI10
34570 XMF=PMAS(IFL,1)
34571 XMJ=SMZ(IX)
34572 AXMJ=ABS(XMJ)
34573 IF(XMI.GE.AXMJ+XMF) THEN
34574 XMA2=XMJ**2
34575 XMB2=XMF**2
34576 IF(IDU.EQ.1) THEN
34577 IF(IFL.EQ.5) THEN
34578 XMF=XMBOT
34579 ELSEIF(IFL.LT.5) THEN
34580 XMF=0D0
34581 ENDIF
34582 CBL=-ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI+1)
34583 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
34584 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
34585 CBR=CAL
34586 ELSE
34587 IF(IFL.EQ.6) THEN
34588 XMF=XMTOP
34589 ELSEIF(IFL.LT.5) THEN
34590 XMF=0D0
34591 ENDIF
34592 CBL=ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-1)
34593 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
34594 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
34595 CBR=CAL
34596 ENDIF
34597
34598 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
34599 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
34600 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
34601 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
34602 CAL=CALP
34603 CBL=CBLP
34604 CAR=CARP
34605 CBR=CBRP
34606
34607C...F1 -> F CHI
34608 IF(ILR.EQ.1) THEN
34609 CA=CAL
34610 CB=CBL
34611C...F2 -> F CHI
34612 ELSE
34613 CA=CAR
34614 CB=CBR
34615 ENDIF
34616 LKNT=LKNT+1
34617 XL=PYLAMF(XMI2,XMA2,XMB2)
34618C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
34619 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
34620 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMF)
34621 IDLAM(LKNT,1)=KFNCHI(IX)
34622 IDLAM(LKNT,2)=IFL
34623 IDLAM(LKNT,3)=0
34624 ENDIF
34625 150 CONTINUE
34626
34627C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
34628C...IG=23,25,35,36
34629 DO 160 II=1,4
34630 IG=IGG(II)
34631 IF(ILR.EQ.1) GOTO 160
34632 XMB=PMAS(IG,1)
34633 XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1)
34634 IF(XMI.LT.XMSF1+XMB) GOTO 160
34635 IF(IG.EQ.23) THEN
34636 BL=-SIGN(.5D0,EI)/CW+EI*XW/CW
34637 BR=EI*XW/CW
34638 BLR=0D0
34639 ELSEIF(IG.EQ.25) THEN
34640 IF(IFL.EQ.5) THEN
34641 XMF=XMBOT
34642 ELSEIF(IFL.EQ.6) THEN
34643 XMF=XMTOP
34644 ELSEIF(IFL.LT.5) THEN
34645 XMF=0D0
34646 ELSE
34647 XMF=PMAS(IFL,1)
34648 ENDIF
34649 IF(IDU.EQ.2) THEN
34650 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
34651 & XMF**2/XMW*COSA/SBETA
34652 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
34653 & XMF**2/XMW*COSA/SBETA
34654 ELSE
34655 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
34656 & XMF**2/XMW*(-SINA)/CBETA
34657 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
34658 & XMF**2/XMW*(-SINA)/CBETA
34659 ENDIF
34660 IF(IFL.EQ.5) THEN
34661 AT=ATRIB
34662 ELSEIF(IFL.EQ.6) THEN
34663 AT=ATRIT
34664 ELSEIF(IFL.EQ.15) THEN
34665 AT=ATRIL
34666 ELSE
34667 AT=0D0
34668 ENDIF
34669C.........need to complexify
34670 IF(IDU.EQ.2) THEN
34671 GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+
34672 & AT*COSA)
34673 ELSE
34674 GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA-
34675 & AT*SINA)
34676 ENDIF
34677 BL=GHLL
34678 BR=GHRR
34679 BLR=-GHLR
34680 ELSEIF(IG.EQ.35) THEN
34681 IF(IFL.EQ.5) THEN
34682 XMF=XMBOT
34683 ELSEIF(IFL.EQ.6) THEN
34684 XMF=XMTOP
34685 ELSEIF(IFL.LT.5) THEN
34686 XMF=0D0
34687 ELSE
34688 XMF=PMAS(IFL,1)
34689 ENDIF
34690 IF(IDU.EQ.2) THEN
34691 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
34692 & XMF**2/XMW*SINA/SBETA
34693 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
34694 & XMF**2/XMW*SINA/SBETA
34695 ELSE
34696 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
34697 & XMF**2/XMW*COSA/CBETA
34698 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
34699 & XMF**2/XMW*COSA/CBETA
34700 ENDIF
34701 IF(IFL.EQ.5) THEN
34702 AT=ATRIB
34703 ELSEIF(IFL.EQ.6) THEN
34704 AT=ATRIT
34705 ELSEIF(IFL.EQ.15) THEN
34706 AT=ATRIL
34707 ELSE
34708 AT=0D0
34709 ENDIF
34710C.........Need to complexify
34711 IF(IDU.EQ.2) THEN
34712 GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+
34713 & AT*SINA)
34714 ELSE
34715 GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+
34716 & AT*COSA)
34717 ENDIF
34718 BL=GHLL
34719 BR=GHRR
34720 BLR=GHLR
34721 ELSEIF(IG.EQ.36) THEN
34722 GHLL=0D0
34723 GHRR=0D0
34724 IF(IFL.EQ.5) THEN
34725 XMF=XMBOT
34726 ELSEIF(IFL.EQ.6) THEN
34727 XMF=XMTOP
34728 ELSEIF(IFL.LT.5) THEN
34729 XMF=0D0
34730 ELSE
34731 XMF=PMAS(IFL,1)
34732 ENDIF
34733 IF(IFL.EQ.5) THEN
34734 AT=ATRIB
34735 ELSEIF(IFL.EQ.6) THEN
34736 AT=ATRIT
34737 ELSEIF(IFL.EQ.15) THEN
34738 AT=ATRIL
34739 ELSE
34740 AT=0D0
34741 ENDIF
34742C.........Need to complexify
34743 IF(IDU.EQ.2) THEN
34744 GHLR=XMF/2D0/XMW*(-XMU+AT/TANB)
34745 ELSE
34746 GHLR=XMF/2D0/XMW/(-XMU+AT*TANB)
34747 ENDIF
34748 BL=GHLL
34749 BR=GHRR
34750 BLR=GHLR
34751 ENDIF
34752 AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+
34753 & SFMIX(IFL,2)*SFMIX(IFL,4)*BR+
34754 & (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR
34755 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
34756 LKNT=LKNT+1
34757 IF(IG.EQ.23) THEN
34758 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
34759 ELSE
34760 XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2
34761 ENDIF
34762 IDLAM(LKNT,3)=0
34763 IDLAM(LKNT,1)=KFIN-KSUSY1
34764 IDLAM(LKNT,2)=IG
34765 160 CONTINUE
34766
34767C...SF -> SF' + W
34768 XMB=PMAS(24,1)
34769 IF(MOD(IFL,2).EQ.0) THEN
34770 KF1=KSUSY1+IFL-1
34771 ELSE
34772 KF1=KSUSY1+IFL+1
34773 ENDIF
34774 KF2=KF1+KSUSY1
34775 XMSF1=PMAS(PYCOMP(KF1),1)
34776 XMSF2=PMAS(PYCOMP(KF2),1)
34777 IF(XMI.GT.XMB+XMSF1) THEN
34778 IF(MOD(IFL,2).EQ.0) THEN
34779 IF(ILR.EQ.1) THEN
34780 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1)
34781 ELSE
34782 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1)
34783 ENDIF
34784 ELSE
34785 IF(ILR.EQ.1) THEN
34786 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1)
34787 ELSE
34788 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1)
34789 ENDIF
34790 ENDIF
34791 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
34792 LKNT=LKNT+1
34793 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
34794 IDLAM(LKNT,3)=0
34795 IDLAM(LKNT,1)=KF1
34796 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
34797 ENDIF
34798 IF(XMI.GT.XMB+XMSF2) THEN
34799 IF(MOD(IFL,2).EQ.0) THEN
34800 IF(ILR.EQ.1) THEN
34801 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3)
34802 ELSE
34803 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3)
34804 ENDIF
34805 ELSE
34806 IF(ILR.EQ.1) THEN
34807 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3)
34808 ELSE
34809 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3)
34810 ENDIF
34811 ENDIF
34812 XL=PYLAMF(XMI2,XMSF2**2,XMB**2)
34813 LKNT=LKNT+1
34814 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
34815 IDLAM(LKNT,3)=0
34816 IDLAM(LKNT,1)=KF2
34817 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
34818 ENDIF
34819
34820C...SF -> SF' + HC
34821 XMB=PMAS(37,1)
34822 IF(MOD(IFL,2).EQ.0) THEN
34823 KF1=KSUSY1+IFL-1
34824 ELSE
34825 KF1=KSUSY1+IFL+1
34826 ENDIF
34827 KF2=KF1+KSUSY1
34828 XMSF1=PMAS(PYCOMP(KF1),1)
34829 XMSF2=PMAS(PYCOMP(KF2),1)
34830 IF(XMI.GT.XMB+XMSF1) THEN
34831 XMF=0D0
34832 XMFP=0D0
34833 AT=0D0
34834 AB=0D0
34835 IF(MOD(IFL,2).EQ.0) THEN
34836C...T1-> B1 HC
34837 IF(ILR.EQ.1) THEN
34838 CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1)
34839 CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2)
34840 CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2)
34841 CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1)
34842C...T2-> B1 HC
34843 ELSE
34844 CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1)
34845 CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2)
34846 CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2)
34847 CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1)
34848 ENDIF
34849 IF(IFL.EQ.6) THEN
34850 XMF=XMTOP
34851 XMFP=XMBOT
34852 AT=ATRIT
34853 AB=ATRIB
34854 ENDIF
34855 ELSE
34856C...B1 -> T1 HC
34857 IF(ILR.EQ.1) THEN
34858 CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1)
34859 CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2)
34860 CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2)
34861 CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1)
34862C...B2-> T1 HC
34863 ELSE
34864 CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1)
34865 CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2)
34866 CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1)
34867 CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2)
34868 ENDIF
34869 IF(IFL.EQ.5) THEN
34870 XMF=XMTOP
34871 XMFP=XMBOT
34872 AT=ATRIT
34873 AB=ATRIB
34874 ENDIF
34875 ENDIF
34876 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
34877 LKNT=LKNT+1
34878C.......Need to complexify
34879 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
34880 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
34881 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
34882 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
34883 IDLAM(LKNT,3)=0
34884 IDLAM(LKNT,1)=KF1
34885 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
34886 ENDIF
34887 IF(XMI.GT.XMB+XMSF2) THEN
34888 XMF=0D0
34889 XMFP=0D0
34890 AT=0D0
34891 AB=0D0
34892 IF(MOD(IFL,2).EQ.0) THEN
34893C...T1-> B2 HC
34894 IF(ILR.EQ.1) THEN
34895 CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1)
34896 CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2)
34897 CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1)
34898 CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2)
34899C...T2-> B2 HC
34900 ELSE
34901 CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3)
34902 CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4)
34903 CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4)
34904 CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3)
34905 ENDIF
34906 IF(IFL.EQ.6) THEN
34907 XMF=XMTOP
34908 XMFP=XMBOT
34909 AT=ATRIT
34910 AB=ATRIB
34911 ENDIF
34912 ELSE
34913C...B1 -> T2 HC
34914 IF(ILR.EQ.1) THEN
34915 CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1)
34916 CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2)
34917 CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2)
34918 CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1)
34919C...B2-> T2 HC
34920 ELSE
34921 CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3)
34922 CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4)
34923 CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4)
34924 CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3)
34925 ENDIF
34926 IF(IFL.EQ.5) THEN
34927 XMF=XMTOP
34928 XMFP=XMBOT
34929 AT=ATRIT
34930 AB=ATRIB
34931 ENDIF
34932 ENDIF
34933 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
34934 LKNT=LKNT+1
34935C.......Need to complexify
34936 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
34937 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
34938 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
34939 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
34940 IDLAM(LKNT,3)=0
34941 IDLAM(LKNT,1)=KF2
34942 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
34943 ENDIF
34944
34945C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
34946
34947 IF(IFL.LE.6) THEN
34948 XMFP=0D0
34949 XMF=0D0
34950 IF(IFL.EQ.6) XMF=PMAS(6,1)
34951 IF(IFL.EQ.5) XMF=PMAS(5,1)
34952 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
34953 AXMJ=ABS(XMJ)
34954 IF(XMI.GE.AXMJ+XMF) THEN
34955 AL=-SFMIX(IFL,3)
34956 BL=SFMIX(IFL,1)
34957 AR=-SFMIX(IFL,4)
34958 BR=SFMIX(IFL,2)
34959C...F1 -> F CHI
34960 IF(ILR.EQ.1) THEN
34961 XCA=AL
34962 XCB=BL
34963C...F2 -> F CHI
34964 ELSE
34965 XCA=AR
34966 XCB=BR
34967 ENDIF
34968 LKNT=LKNT+1
34969 XMA2=XMJ**2
34970 XMB2=XMF**2
34971 XL=PYLAMF(XMI2,XMA2,XMB2)
34972 XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
34973 & (XCA**2+XCB**2)+4D0*XCA*XCB*XMJ*XMF)
34974 IDLAM(LKNT,1)=KSUSY1+21
34975 IDLAM(LKNT,2)=IFL
34976 IDLAM(LKNT,3)=0
34977 ENDIF
34978 ENDIF
34979
34980C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
34981 IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT.
34982 &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN
34983C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
34984C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
34985C...M*M = C1**2 * G**2/(16PI**2)
34986C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
34987 LKNT=LKNT+1
34988 XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
34989 XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL)
34990 IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3
34991 IDLAM(LKNT,1)=KSUSY1+22
34992 IDLAM(LKNT,2)=4
34993 IDLAM(LKNT,3)=0
34994 ENDIF
34995
34996C...R-violating sfermion decays (SKANDS).
34997 CALL PYRVSF(KFIN,XLAM,IDLAM,LKNT)
34998
34999 IKNT=LKNT
35000 XLAM(0)=0D0
35001 DO 170 I=1,IKNT
35002 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
35003 XLAM(0)=XLAM(0)+XLAM(I)
35004 170 CONTINUE
35005 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3
35006
35007 RETURN
35008 END
35009
35010C*********************************************************************
35011
35012C...PYGLUI
35013C...Calculates gluino decay modes.
35014
35015 SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT)
35016
35017C...Double precision and integer declarations.
35018 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35019 IMPLICIT INTEGER(I-N)
35020 INTEGER PYK,PYCHGE,PYCOMP
35021C...Parameter statement to help give large particle numbers.
35022 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
35023 &KEXCIT=4000000,KDIMEN=5000000)
35024C...Commonblocks.
35025 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35026 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35027 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
35028 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
35029 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
35030CC &SFMIX(16,4),
35031C COMMON/PYINTS/XXM(20)
35032 COMPLEX*16 CXC
35033 COMMON/PYINTC/XXC(10),CXC(8)
35034 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
35035
35036C...Local variables
35037 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
35038 DOUBLE PRECISION XMI,XMJ,XMF,AXMJ,AXMI
35039 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
35040 DOUBLE PRECISION PYLAMF,XL
35041 DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
35042 DOUBLE PRECISION CA,CB,AL,AR,BL,BR
35043 DOUBLE PRECISION XLAM(0:300)
35044 INTEGER IDLAM(300,3)
35045 INTEGER LKNT,IX,ILR,I,IKNT,IFL
35046 DOUBLE PRECISION SR2
35047 DOUBLE PRECISION GAM
35048 DOUBLE PRECISION PYALEM,PI,PYALPS,EI,T3I
35049 EXTERNAL PYGAUS,PYXXZ6
35050 DOUBLE PRECISION PYGAUS,PYXXZ6
35051 DOUBLE PRECISION PREC
35052 INTEGER KFNCHI(4),KFCCHI(2)
35053 DATA PI/3.141592654D0/
35054 DATA SR2/1.4142136D0/
35055 DATA PREC/1D-2/
35056 DATA KFNCHI/1000022,1000023,1000025,1000035/
35057 DATA KFCCHI/1000024,1000037/
35058
35059C...COUNT THE NUMBER OF DECAY MODES
35060 LKNT=0
35061 IF(KFIN.NE.KSUSY1+21) RETURN
35062 KCIN=PYCOMP(KFIN)
35063
35064 XW=PARU(102)
35065 TANW = SQRT(XW/(1D0-XW))
35066
35067 XMI=PMAS(KCIN,1)
35068 AXMI=ABS(XMI)
35069 XMI2=XMI**2
35070 AEM=PYALEM(XMI2)
35071 AS =PYALPS(XMI2)
35072 C1=AEM/XW
35073 XMI3=XMI**3
35074
35075C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
35076
35077 IF(IMSS(11).EQ.1) THEN
35078 XMP=RMSS(29)
35079 IDG=39+KSUSY1
35080 XMGR=PMAS(PYCOMP(IDG),1)
35081 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
35082 IF(AXMI.GT.XMGR) THEN
35083 LKNT=LKNT+1
35084 IDLAM(LKNT,1)=IDG
35085 IDLAM(LKNT,2)=21
35086 IDLAM(LKNT,3)=0
35087 XLAM(LKNT)=XFAC
35088 ENDIF
35089 ENDIF
35090
35091C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
35092
35093 DO 110 IFL=1,6
35094 DO 100 ILR=1,2
35095 XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1)
35096 AXMJ=ABS(XMJ)
35097 XMF=PMAS(IFL,1)
35098 IF(XMI.GE.AXMJ+XMF) THEN
35099C...Minus sign difference from gluino-quark-squark feynman rules
35100 AL=SFMIX(IFL,1)
35101 BL=-SFMIX(IFL,3)
35102 AR=SFMIX(IFL,2)
35103 BR=-SFMIX(IFL,4)
35104C...F1 -> F CHI
35105 IF(ILR.EQ.1) THEN
35106 CA=AL
35107 CB=BL
35108C...F2 -> F CHI
35109 ELSE
35110 CA=AR
35111 CB=BR
35112 ENDIF
35113 LKNT=LKNT+1
35114 XMA2=XMJ**2
35115 XMB2=XMF**2
35116 XL=PYLAMF(XMI2,XMA2,XMB2)
35117 XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)*
35118 & (CA**2+CB**2)-4D0*CA*CB*XMI*XMF)
35119 IDLAM(LKNT,1)=ILR*KSUSY1+IFL
35120 IDLAM(LKNT,2)=-IFL
35121 IDLAM(LKNT,3)=0
35122 LKNT=LKNT+1
35123 XLAM(LKNT)=XLAM(LKNT-1)
35124 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
35125 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
35126 IDLAM(LKNT,3)=0
35127 ENDIF
35128 100 CONTINUE
35129 110 CONTINUE
35130
35131C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
35132C...GLUINO -> NI Q QBAR
35133 DO 170 IX=1,4
35134 XMJ=SMZ(IX)
35135 AXMJ=ABS(XMJ)
35136 IF(XMI.GE.AXMJ) THEN
35137 DO 120 I=1,4
35138 ZMIXC(IX,I)=DCMPLX(ZMIX(IX,I),ZMIXI(IX,I))
35139 120 CONTINUE
35140 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))/SR2
35141 ORPP=DCONJG(OLPP)
35142 XXC(1)=0D0
35143 XXC(2)=XMJ
35144 XXC(3)=0D0
35145 XXC(4)=XMI
35146 IA=1
35147 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
35148 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
35149 XXC(7)=XXC(5)
35150 XXC(8)=XXC(6)
35151 XXC(9)=1D6
35152 XXC(10)=0D0
35153 EI=KCHG(IA,1)/3D0
35154 T3I=SIGN(1D0,EI+1D-6)/2D0
35155 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
35156 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
35157 CXC(1)=0D0
35158 CXC(2)=-GLIJ
35159 CXC(3)=0D0
35160 CXC(4)=DCONJG(GLIJ)
35161 CXC(5)=0D0
35162 CXC(6)=GRIJ
35163 CXC(7)=0D0
35164 CXC(8)=-DCONJG(GRIJ)
35165 S12MIN=0D0
35166 S12MAX=(AXMI-AXMJ)**2
35167 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 130
35168 IF(XMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
35169 LKNT=LKNT+1
35170 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
35171 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
35172 IDLAM(LKNT,1)=KFNCHI(IX)
35173 IDLAM(LKNT,2)=1
35174 IDLAM(LKNT,3)=-1
35175 ENDIF
35176 IF(XMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
35177 LKNT=LKNT+1
35178 XLAM(LKNT)=XLAM(LKNT-1)
35179 IDLAM(LKNT,1)=KFNCHI(IX)
35180 IDLAM(LKNT,2)=3
35181 IDLAM(LKNT,3)=-3
35182 ENDIF
35183 130 CONTINUE
35184 IF(XMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
35185 CALL PYTBBN(IX,80,-1D0/3D0,AXMI,GAM)
35186 LKNT=LKNT+1
35187 XLAM(LKNT)=GAM
35188 IDLAM(LKNT,1)=KFNCHI(IX)
35189 IDLAM(LKNT,2)=5
35190 IDLAM(LKNT,3)=-5
35191 ENDIF
35192C...U-TYPE QUARKS
35193 140 CONTINUE
35194 IA=2
35195 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
35196 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
35197C IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 290
35198 XXC(7)=XXC(5)
35199 XXC(8)=XXC(6)
35200 EI=KCHG(IA,1)/3D0
35201 T3I=SIGN(1D0,EI+1D-6)/2D0
35202 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
35203 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
35204 CXC(2)=-GLIJ
35205 CXC(4)=DCONJG(GLIJ)
35206 CXC(6)=GRIJ
35207 CXC(8)=-DCONJG(GRIJ)
35208 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 150
35209 IF(XMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
35210 LKNT=LKNT+1
35211 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
35212 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
35213 IDLAM(LKNT,1)=KFNCHI(IX)
35214 IDLAM(LKNT,2)=2
35215 IDLAM(LKNT,3)=-2
35216 ENDIF
35217 IF(XMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
35218 LKNT=LKNT+1
35219 XLAM(LKNT)=XLAM(LKNT-1)
35220 IDLAM(LKNT,1)=KFNCHI(IX)
35221 IDLAM(LKNT,2)=4
35222 IDLAM(LKNT,3)=-4
35223 ENDIF
35224 150 CONTINUE
35225C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
35226C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
35227 IF(XMI.GE.PMAS(PYCOMP(KSUSY1+6),1)+PMAS(6,1)) GOTO 160
35228 XMF=PMAS(6,1)
35229 IF(XMI.GE.AXMJ+2D0*XMF) THEN
35230 CALL PYTBBN(IX,80,2D0/3D0,AXMI,GAM)
35231 LKNT=LKNT+1
35232 XLAM(LKNT)=GAM
35233 IDLAM(LKNT,1)=KFNCHI(IX)
35234 IDLAM(LKNT,2)=6
35235 IDLAM(LKNT,3)=-6
35236 ENDIF
35237 160 CONTINUE
35238 ENDIF
35239 170 CONTINUE
35240
35241C...GLUINO -> CI Q QBAR'
35242 DO 210 IX=1,2
35243 XMJ=SMW(IX)
35244 AXMJ=ABS(XMJ)
35245 IF(XMI.GE.AXMJ) THEN
35246 DO 180 I=1,2
35247 VMIXC(IX,I)=DCMPLX(VMIX(IX,I),VMIXI(IX,I))
35248 UMIXC(IX,I)=DCMPLX(UMIX(IX,I),UMIXI(IX,I))
35249 180 CONTINUE
35250 S12MIN=0D0
35251 S12MAX=(AXMI-AXMJ)**2
35252 XXC(1)=0D0
35253 XXC(2)=XMJ
35254 XXC(3)=0D0
35255 XXC(4)=XMI
35256 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
35257 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
35258 XXC(9)=1D6
35259 XXC(10)=0D0
35260 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
35261 ORPP=DCONJG(OLPP)
35262 CXC(1)=DCMPLX(0D0,0D0)
35263 CXC(3)=DCMPLX(0D0,0D0)
35264 CXC(5)=DCMPLX(0D0,0D0)
35265 CXC(7)=DCMPLX(0D0,0D0)
35266 CXC(2)=UMIXC(IX,1)*OLPP/SR2
35267 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
35268 CXC(6)=DCMPLX(0D0,0D0)
35269 CXC(8)=DCMPLX(0D0,0D0)
35270 IF(XXC(5).LT.AXMI) THEN
35271 XXC(5)=1D6
35272 ELSEIF(XXC(6).LT.AXMI) THEN
35273 XXC(6)=1D6
35274 ENDIF
35275 XXC(7)=XXC(6)
35276 XXC(8)=XXC(5)
35277 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 190
35278 IF(XMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
35279 LKNT=LKNT+1
35280 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
35281 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
35282 IDLAM(LKNT,1)=KFCCHI(IX)
35283 IDLAM(LKNT,2)=1
35284 IDLAM(LKNT,3)=-2
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 IF(XMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
35292 LKNT=LKNT+1
35293 XLAM(LKNT)=XLAM(LKNT-1)
35294 IDLAM(LKNT,1)=KFCCHI(IX)
35295 IDLAM(LKNT,2)=3
35296 IDLAM(LKNT,3)=-4
35297 LKNT=LKNT+1
35298 XLAM(LKNT)=XLAM(LKNT-1)
35299 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
35300 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
35301 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
35302 ENDIF
35303 190 CONTINUE
35304
35305 IF(XMI.GE.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) GOTO 200
35306 IF(XMI.GE.PMAS(PYCOMP(KSUSY1+6),1)+PMAS(6,1)) GOTO 200
35307 XMF=PMAS(6,1)
35308 XMFP=PMAS(5,1)
35309 IF(XMI.GE.AXMJ+XMF+XMFP) THEN
35310 CALL PYTBBC(IX,80,AXMI,GAM)
35311 LKNT=LKNT+1
35312 XLAM(LKNT)=GAM
35313 IDLAM(LKNT,1)=KFCCHI(IX)
35314 IDLAM(LKNT,2)=5
35315 IDLAM(LKNT,3)=-6
35316 LKNT=LKNT+1
35317 XLAM(LKNT)=XLAM(LKNT-1)
35318 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
35319 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
35320 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
35321 ENDIF
35322 200 CONTINUE
35323 ENDIF
35324 210 CONTINUE
35325
35326 IKNT=LKNT
35327 XLAM(0)=0D0
35328 DO 220 I=1,IKNT
35329 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
35330 XLAM(0)=XLAM(0)+XLAM(I)
35331 220 CONTINUE
35332 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
35333
35334 RETURN
35335 END
35336
35337C*********************************************************************
35338
35339C...PYTBBN
35340C...Calculates the three-body decay of gluinos into
35341C...neutralinos and third generation fermions.
35342
35343 SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
35344
35345C...Double precision and integer declarations.
35346 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35347 IMPLICIT INTEGER(I-N)
35348 INTEGER PYK,PYCHGE,PYCOMP
35349C...Parameter statement to help give large particle numbers.
35350 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
35351 &KEXCIT=4000000,KDIMEN=5000000)
35352C...Commonblocks.
35353 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35354 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35355 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
35356 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
35357 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
35358 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
35359
35360C...Local variables.
35361 EXTERNAL PYSIMP,PYLAMF
35362 DOUBLE PRECISION PYSIMP,PYLAMF
35363 INTEGER LIN,NN
35364 DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
35365 DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
35366 DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
35367 DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
35368 DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
35369 DOUBLE PRECISION XLN1,XLN2,B1,B2
35370 DOUBLE PRECISION E,XMGLU,GAM
35371 DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
35372 SAVE HRB,HLB,FLB,FRB
35373 DOUBLE PRECISION ALPHAW,ALPHAS
35374 DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
35375 SAVE HLT,HRT,FLT,FRT
35376 DOUBLE PRECISION AMN(4),AN(4,4),ZN(3)
35377 SAVE AMN,AN,ZN
35378 DOUBLE PRECISION AMBOT,SINC,COSC
35379 DOUBLE PRECISION AMTOP,SINA,COSA
35380 DOUBLE PRECISION SINW,COSW,TANW
35381 DOUBLE PRECISION ROT1(4,4)
35382 LOGICAL IFIRST
35383 SAVE IFIRST
35384 DATA IFIRST/.TRUE./
35385
35386 TANB=RMSS(5)
35387 SINB=TANB/SQRT(1D0+TANB**2)
35388 COSB=SINB/TANB
35389 XW=PARU(102)
35390 SINW=SQRT(XW)
35391 COSW=SQRT(1D0-XW)
35392 TANW=SINW/COSW
35393 AMW=PMAS(24,1)
35394 COSC=SFMIX(5,1)
35395 SINC=SFMIX(5,3)
35396 COSA=SFMIX(6,1)
35397 SINA=SFMIX(6,3)
35398 AMBOT=0D0
35399 AMTOP=PYRNMT(PMAS(6,1))
35400 W2=SQRT(2D0)
35401 FAKT1=AMBOT/W2/AMW/COSB
35402 FAKT2=AMTOP/W2/AMW/SINB
35403 IF(IFIRST) THEN
35404 DO 110 II=1,4
35405 AMN(II)=SMZ(II)
35406 DO 100 J=1,4
35407 ROT1(II,J)=0D0
35408 AN(II,J)=0D0
35409 100 CONTINUE
35410 110 CONTINUE
35411 ROT1(1,1)=COSW
35412 ROT1(1,2)=-SINW
35413 ROT1(2,1)=-ROT1(1,2)
35414 ROT1(2,2)=ROT1(1,1)
35415 ROT1(3,3)=COSB
35416 ROT1(3,4)=SINB
35417 ROT1(4,3)=-ROT1(3,4)
35418 ROT1(4,4)=ROT1(3,3)
35419 DO 140 II=1,4
35420 DO 130 J=1,4
35421 DO 120 JJ=1,4
35422 AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J)
35423 120 CONTINUE
35424 130 CONTINUE
35425 140 CONTINUE
35426 DO 150 J=1,4
35427 ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4))
35428 ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
35429 ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0*
35430 & XW)*AN(J,2)/COSW
35431 HRT(J)=ZN(1)*COSA-ZN(3)*SINA
35432 HLT(J)=ZN(1)*COSA+ZN(2)*SINA
35433 FLT(J)=ZN(3)*COSA+ZN(1)*SINA
35434 FRT(J)=ZN(2)*COSA-ZN(1)*SINA
35435C FLU(J)=ZN(3)
35436C FRU(J)=ZN(2)
35437 ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4))
35438 ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
35439 ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW
35440 HRB(J)=ZN(1)*COSC-ZN(3)*SINC
35441 HLB(J)=ZN(1)*COSC+ZN(2)*SINC
35442 FLB(J)=ZN(3)*COSC+ZN(1)*SINC
35443 FRB(J)=ZN(2)*COSC-ZN(1)*SINC
35444C FLD(J)=ZN(3)
35445C FRD(J)=ZN(2)
35446 150 CONTINUE
35447C AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
35448C AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
35449C AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
35450C AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
35451 IFIRST=.FALSE.
35452 ENDIF
35453
35454 IF(NINT(3D0*E).EQ.2) THEN
35455 HL=HLT(I)
35456 HR=HRT(I)
35457 FL=FLT(I)
35458 FR=FRT(I)
35459 COSD=SFMIX(6,1)
35460 SIND=SFMIX(6,3)
35461 XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2
35462 XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2
35463 XM=PMAS(6,1)
35464 ELSE
35465 HL=HLB(I)
35466 HR=HRB(I)
35467 FL=FLB(I)
35468 FR=FRB(I)
35469 COSD=SFMIX(5,1)
35470 SIND=SFMIX(5,3)
35471 XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2
35472 XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2
35473 XM=PMAS(5,1)
35474 ENDIF
35475 COSD2=COSD*COSD
35476 SIND2=SIND*SIND
35477 COS2D=COSD2-SIND2
35478 SIN2D=SIND*COSD*2D0
35479 HL2=HL*HL
35480 HR2=HR*HR
35481 FL2=FL*FL
35482 FR2=FR*FR
35483 FF=FL*FR
35484 HH=HL*HR
35485 HFL=HL*FL
35486 HFR=HR*FR
35487 HRFL=HR*FL
35488 HLFR=HL*FR
35489 XM2=XM*XM
35490 XMG=XMGLU
35491 XMG2=XMG*XMG
35492 ALPHAW=PYALEM(XMG2)
35493 ALPHAS=PYALPS(XMG2)
35494 XMR=AMN(I)
35495 XMR2=XMR*XMR
35496 XMQ4=XMG*XM2*XMR
35497 XM24=(XMG2+XM2)*(XM2+XMR2)
35498 SMIN=4D0*XM2
35499 SMAX=(XMG-ABS(XMR))**2
35500 XMQA=XMG2+2D0*XM2+XMR2
35501 DO 170 LIN=1,NN-1
35502 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
35503 GRS=SBAR-XMQA
35504 W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR)
35505 W=DSQRT(W)
35506 XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W)))
35507 XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W)))
35508 B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W)
35509 B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W)
35510 G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D
35511 & +2D0*(FF*SIND2-HH*COSD2))*W
35512 G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D)
35513 & +4D0*HFL*XM*XMR)*XLN1
35514 & +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24
35515 & +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D)
35516 & -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1))
35517 & +8D0*HFL*XMQ4*SIN2D)*B1
35518 G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D)
35519 & +4D0*HFR*XMR*XM)*XLN2
35520 & +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24
35521 & +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2))
35522 & +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2)
35523 & -8D0*HFR*XMQ4*SIN2D)*B2
35524 G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
35525 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR
35526 & -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2)
35527 & +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2)
35528 & -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1
35529 G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))*
35530 & (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2)
35531 & +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1))
35532 G(5)=(2D0*(HH*COSD2-FF*SIND2)
35533 & *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2
35534 & +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1)
35535 & +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR)
35536 & *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2)
35537 & +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2)
35538 & +COS2D*XM*(SBAR+XMG2-XMR2))
35539 & +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2))
35540 & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
35541 G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
35542 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR
35543 & -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2)
35544 & -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2)
35545 & -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2
35546 SUMME(LIN)=0D0
35547 DO 160 J=0,6
35548 SUMME(LIN)=SUMME(LIN)+G(J)
35549 160 CONTINUE
35550 170 CONTINUE
35551 SUMME(0)=0D0
35552 SUMME(NN)=0D0
35553 GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
35554 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
35555
35556 RETURN
35557 END
35558
35559C*********************************************************************
35560
35561C...PYTBBC
35562C...Calculates the three-body decay of gluinos into
35563C...charginos and third generation fermions.
35564
35565 SUBROUTINE PYTBBC(I,NN,XMGLU,GAM)
35566
35567C...Double precision and integer declarations.
35568 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35569 IMPLICIT INTEGER(I-N)
35570 INTEGER PYK,PYCHGE,PYCOMP
35571C...Parameter statement to help give large particle numbers.
35572 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
35573 &KEXCIT=4000000,KDIMEN=5000000)
35574C...Commonblocks.
35575 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35576 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35577 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
35578 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
35579 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
35580 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
35581
35582C...Local variables.
35583 EXTERNAL PYSIMP,PYLAMF
35584 DOUBLE PRECISION PYSIMP,PYLAMF
35585 INTEGER I,NN,LIN
35586 DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
35587 DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
35588 DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
35589 DOUBLE PRECISION SUMME(0:100),A(4,8)
35590 DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
35591 DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
35592 DOUBLE PRECISION XMGLU,GAM
35593 DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
35594 &DDD(2),EEE(2),FFF(2)
35595 SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF
35596 DOUBLE PRECISION ALPHAW,ALPHAS
35597 DOUBLE PRECISION AMC(2)
35598 SAVE AMC
35599 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
35600 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
35601 SAVE AMSB,AMST
35602 LOGICAL IFIRST
35603 SAVE IFIRST
35604 DATA IFIRST/.TRUE./
35605
35606 TANB=RMSS(5)
35607 SINB=TANB/SQRT(1D0+TANB**2)
35608 COSB=SINB/TANB
35609 XW=PARU(102)
35610 AMW=PMAS(24,1)
35611 COSC=SFMIX(5,1)
35612 SINC=SFMIX(5,3)
35613 COSA=SFMIX(6,1)
35614 SINA=SFMIX(6,3)
35615 AMBOT=0D0
35616 AMTOP=PYRNMT(PMAS(6,1))
35617 W2=SQRT(2D0)
35618 AMW=PMAS(24,1)
35619 FAKT1=AMBOT/W2/AMW/COSB
35620 FAKT2=AMTOP/W2/AMW/SINB
35621 IF(IFIRST) THEN
35622 AMC(1)=SMW(1)
35623 AMC(2)=SMW(2)
35624 DO 100 JJ=1,2
35625 CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC
35626 EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC
35627 DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC
35628 FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC
35629 XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA
35630 AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA
35631 XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA
35632 BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA
35633 100 CONTINUE
35634 AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
35635 AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
35636 AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
35637 AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
35638 IFIRST=.FALSE.
35639 ENDIF
35640 AMTOP=PMAS(6,1)
35641
35642 ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I)
35643 ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I)
35644 VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I)
35645 VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I)
35646
35647 COS2A=COSA**2-SINA**2
35648 SIN2A=SINA*COSA*2D0
35649 COS2C=COSC**2-SINC**2
35650 SIN2C=SINC*COSC*2D0
35651
35652 XMG=XMGLU
35653 XMT=AMTOP
35654 XMB=0D0
35655 XMR=AMC(I)
35656 XMG2=XMG*XMG
35657 ALPHAW=PYALEM(XMG2)
35658 ALPHAS=PYALPS(XMG2)
35659 XMT2=XMT*XMT
35660 XMB2=XMB*XMB
35661 XMR2=XMR*XMR
35662 XMQ2=XMG2+XMT2+XMB2+XMR2
35663 XMQ4=XMG*XMT*XMB*XMR
35664 XMQ3=XMG2*XMR2+XMT2*XMB2
35665 XMGBTR=(XMG2+XMB2)*(XMT2+XMR2)
35666 XMGTBR=(XMG2+XMT2)*(XMB2+XMR2)
35667
35668 XMST(1)=AMST(1)*AMST(1)
35669 XMST(2)=AMST(1)*AMST(1)
35670 XMST(3)=AMST(2)*AMST(2)
35671 XMST(4)=AMST(2)*AMST(2)
35672 XMSB(1)=AMSB(1)*AMSB(1)
35673 XMSB(2)=AMSB(2)*AMSB(2)
35674 XMSB(3)=AMSB(1)*AMSB(1)
35675 XMSB(4)=AMSB(2)*AMSB(2)
35676
35677 A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I)
35678 A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I))
35679 A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I))
35680 A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I))
35681 A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I))
35682 A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I))
35683 A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I))
35684 A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I))
35685
35686 A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I)
35687 A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I))
35688 A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I))
35689 A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I))
35690 A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I))
35691 A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I))
35692 A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I))
35693 A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I))
35694
35695 A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I)
35696 A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I))
35697 A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I))
35698 A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I))
35699 A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I))
35700 A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I))
35701 A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I))
35702 A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I))
35703
35704 A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I)
35705 A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I))
35706 A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I))
35707 A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I))
35708 A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I))
35709 A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I))
35710 A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I))
35711 A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I))
35712
35713 SMAX=(XMG-ABS(XMR))**2
35714 SMIN=(XMB+XMT)**2+0.1D0
35715
35716 DO 120 LIN=0,NN-1
35717 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
35718 AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR
35719 GRS=SBAR-XMQ2
35720 W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2)
35721 W=DSQRT(W)/2D0/SBAR
35722 ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W)))
35723 ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W)))
35724 ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W)))
35725 ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W)))
35726 SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A)
35727 & +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1
35728 & +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR
35729 & -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2))
35730 & +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2)
35731 & +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4)
35732 & *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W))
35733 SUMME(LIN)=SUMME(LIN)-ULR(2)*W
35734 & +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A)
35735 & -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2
35736 & +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR
35737 & +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2))
35738 & -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2)
35739 & +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4)
35740 & *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W))
35741 SUMME(LIN)=SUMME(LIN)-VLR(1)*W
35742 & +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C)
35743 & +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1
35744 & +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR
35745 & -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2))
35746 & +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2)
35747 & +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4)
35748 & *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W))
35749 SUMME(LIN)=SUMME(LIN)-VLR(2)*W
35750 & +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C)
35751 & -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2
35752 & +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR
35753 & +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2))
35754 & -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2)
35755 & +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4)
35756 & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
35757 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1))
35758 & *((AAA(I)*BBB(I)-XX1(I)*XX2(I))
35759 & *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1)
35760 & +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1))
35761 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1))
35762 & *((EEE(I)*FFF(I)-CCC(I)*DDD(I))
35763 & *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1)
35764 & +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1))
35765 DO 110 J=1,4
35766 SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W
35767 & +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3)
35768 & +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2)
35769 & +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2)
35770 & -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR)
35771 & -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8))
35772 & *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W)))
35773 & -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3)
35774 & +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2)
35775 & +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2)
35776 & -A(J,6)*(XMG2+XMR2-SBAR)
35777 & -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8))
35778 & *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W))))
35779 & /(GRS+XMSB(J)+XMST(J))
35780 110 CONTINUE
35781 120 CONTINUE
35782 SUMME(NN)=0D0
35783 GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
35784 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
35785
35786 RETURN
35787 END
35788
35789C*********************************************************************
35790
35791C...PYNJDC
35792C...Calculates decay widths for the neutralinos (admixtures of
35793C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
35794
35795C...Input: KCIN = KF code for particle
35796C...Output: XLAM = widths
35797C... IDLAM = KF codes for decay particles
35798C... IKNT = number of decay channels defined
35799C...AUTHOR: STEPHEN MRENNA
35800C...Last change:
35801C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
35802C...when CHIGAMMA .NE. 0
35803C...10 FEB 96: Calculate this decay for small tan(beta)
35804
35805 SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT)
35806
35807C...Double precision and integer declarations.
35808 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35809 IMPLICIT INTEGER(I-N)
35810 INTEGER PYK,PYCHGE,PYCOMP
35811C...Parameter statement to help give large particle numbers.
35812 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
35813 &KEXCIT=4000000,KDIMEN=5000000)
35814C...Commonblocks.
35815 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35816 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35817 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
35818c COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
35819c &SFMIX(16,4)
35820 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
35821 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
35822C COMMON/PYINTS/XXM(20)
35823 COMPLEX*16 CXC
35824 COMMON/PYINTC/XXC(10),CXC(8)
35825 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
35826
35827C...Local variables.
35828 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
35829 COMPLEX*16 QIJ,RIJ,F21K,F12K,CAL,CAR,CBL,CBR,CA,CB
35830 INTEGER KFIN
35831 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
35832 &XMZ,XMZ2,AXMJ,AXMI
35833 DOUBLE PRECISION S12MIN,S12MAX
35834 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2
35835 DOUBLE PRECISION PYLAMF,XL
35836 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I
35837 DOUBLE PRECISION PYX2XH,PYX2XG
35838 DOUBLE PRECISION XLAM(0:300)
35839 INTEGER IDLAM(300,3)
35840 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
35841 INTEGER ITH(3),KF1,KF2
35842 INTEGER ITHC
35843 DOUBLE PRECISION DH(3),EH(3)
35844 DOUBLE PRECISION SR2
35845 DOUBLE PRECISION CBETA,SBETA
35846 DOUBLE PRECISION GAMCON,XMT1,XMT2
35847 DOUBLE PRECISION PYALEM,PI,PYALPS
35848 DOUBLE PRECISION RAT1,RAT2
35849 DOUBLE PRECISION T3T,FCOL
35850 DOUBLE PRECISION ALFA,BETA,TANB
35851 DOUBLE PRECISION PYXXGA
35852 EXTERNAL PYGAUS,PYXXZ6
35853 DOUBLE PRECISION PYGAUS,PYXXZ6
35854 DOUBLE PRECISION PREC
35855 INTEGER KFNCHI(4),KFCCHI(2)
35856 DATA ITH/25,35,36/
35857 DATA ITHC/37/
35858 DATA PREC/1D-2/
35859 DATA PI/3.141592654D0/
35860 DATA SR2/1.4142136D0/
35861 DATA KFNCHI/1000022,1000023,1000025,1000035/
35862 DATA KFCCHI/1000024,1000037/
35863
35864C...COUNT THE NUMBER OF DECAY MODES
35865 LKNT=0
35866
35867 XMW=PMAS(24,1)
35868 XMW2=XMW**2
35869 XMZ=PMAS(23,1)
35870 XMZ2=XMZ**2
35871 XW=1D0-XMW2/XMZ2
35872 XW1=1D0-XW
35873 TANW = SQRT(XW/XW1)
35874
35875C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
35876 IX=1
35877 IF(KFIN.EQ.KFNCHI(2)) IX=2
35878 IF(KFIN.EQ.KFNCHI(3)) IX=3
35879 IF(KFIN.EQ.KFNCHI(4)) IX=4
35880
35881 XMI=SMZ(IX)
35882 XMI2=XMI**2
35883 AXMI=ABS(XMI)
35884 AEM=PYALEM(XMI2)
35885 AS =PYALPS(XMI2)
35886 C1=AEM/XW
35887 XMI3=ABS(XMI**3)
35888
35889 TANB=RMSS(5)
35890 BETA=ATAN(TANB)
35891 ALFA=RMSS(18)
35892 CBETA=COS(BETA)
35893 SBETA=TANB*CBETA
35894 CALFA=COS(ALFA)
35895 SALFA=SIN(ALFA)
35896
35897 DO 110 I=1,4
35898 DO 100 J=1,4
35899 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
35900 100 CONTINUE
35901 110 CONTINUE
35902 DO 130 I=1,2
35903 DO 120 J=1,2
35904 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
35905 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
35906 120 CONTINUE
35907 130 CONTINUE
35908
35909C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
35910 IF(IX.EQ.1.AND.IMSS(11).EQ.0) GOTO 300
35911
35912C...FORCE CHI0_2 -> CHI0_1 + GAMMA
35913 IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN
35914 XMJ=SMZ(1)
35915 AXMJ=ABS(XMJ)
35916 LKNT=LKNT+1
35917 GAMCON=AEM**3/8D0/PI/XMW2/XW
35918 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
35919 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
35920 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
35921 IDLAM(LKNT,1)=KSUSY1+22
35922 IDLAM(LKNT,2)=22
35923 IDLAM(LKNT,3)=0
35924 WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT)
35925 GOTO 340
35926 ENDIF
35927
35928C...GRAVITINO DECAY MODES
35929
35930 IF(IMSS(11).EQ.1) THEN
35931 XMP=RMSS(29)
35932 IDG=39+KSUSY1
35933 XMGR=PMAS(PYCOMP(IDG),1)
35934 SINW=SQRT(XW)
35935 COSW=SQRT(1D0-XW)
35936 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
35937 IF(AXMI.GT.XMGR+PMAS(22,1)) THEN
35938 LKNT=LKNT+1
35939 IDLAM(LKNT,1)=IDG
35940 IDLAM(LKNT,2)=22
35941 IDLAM(LKNT,3)=0
35942 XLAM(LKNT)=XFAC*ABS(ZMIXC(IX,1)*COSW+ZMIXC(IX,2)*SINW)**2
35943 ENDIF
35944 IF(AXMI.GT.XMGR+XMZ) THEN
35945 LKNT=LKNT+1
35946 IDLAM(LKNT,1)=IDG
35947 IDLAM(LKNT,2)=23
35948 IDLAM(LKNT,3)=0
35949 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,1)*SINW-ZMIXC(IX,2)*COSW)**2 +
35950 $ .5D0*ABS(ZMIXC(IX,3)*CBETA-ZMIXC(IX,4)*SBETA)**2)*
35951 & (1D0-XMZ2/XMI2)**4
35952 ENDIF
35953 IF(AXMI.GT.XMGR+PMAS(25,1)) THEN
35954 LKNT=LKNT+1
35955 IDLAM(LKNT,1)=IDG
35956 IDLAM(LKNT,2)=25
35957 IDLAM(LKNT,3)=0
35958 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SALFA-ZMIXC(IX,4)*CALFA)**2)*
35959 $ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4
35960 ENDIF
35961 IF(AXMI.GT.XMGR+PMAS(35,1)) THEN
35962 LKNT=LKNT+1
35963 IDLAM(LKNT,1)=IDG
35964 IDLAM(LKNT,2)=35
35965 IDLAM(LKNT,3)=0
35966 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*CALFA+ZMIXC(IX,4)*SALFA)**2)*
35967 $ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4
35968 ENDIF
35969 IF(AXMI.GT.XMGR+PMAS(36,1)) THEN
35970 LKNT=LKNT+1
35971 IDLAM(LKNT,1)=IDG
35972 IDLAM(LKNT,2)=36
35973 IDLAM(LKNT,3)=0
35974 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SBETA+ZMIXC(IX,4)*CBETA)**2)*
35975 $ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4
35976 ENDIF
35977 IF(IX.EQ.1) GOTO 300
35978 ENDIF
35979
35980 DO 220 IJ=1,IX-1
35981 XMJ=SMZ(IJ)
35982 AXMJ=ABS(XMJ)
35983 XMJ2=XMJ**2
35984
35985C...CHI0_I -> CHI0_J + GAMMA
35986 IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN
35987 RAT1=ABS(ZMIXC(IJ,1))**2+ABS(ZMIXC(IJ,2))**2
35988 RAT1=RAT1/( 1D-6+ABS(ZMIXC(IX,3))**2+ABS(ZMIXC(IX,4))**2 )
35989 RAT2=ABS(ZMIXC(IX,1))**2+ABS(ZMIXC(IX,2))**2
35990 RAT2=RAT2/( 1D-6+ABS(ZMIXC(IJ,3))**2+ABS(ZMIXC(IJ,4))**2 )
35991 IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR.
35992 & (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN
35993 LKNT=LKNT+1
35994 IDLAM(LKNT,1)=KFNCHI(IJ)
35995 IDLAM(LKNT,2)=22
35996 IDLAM(LKNT,3)=0
35997 GAMCON=AEM**3/8D0/PI/XMW2/XW
35998 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
35999 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
36000 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
36001 ENDIF
36002 ENDIF
36003
36004C...CHI0_I -> CHI0_J + Z0
36005 IF(AXMI.GE.AXMJ+XMZ) THEN
36006 LKNT=LKNT+1
36007 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
36008 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
36009 ORPP=-DCONJG(OLPP)
36010 GX2=ABS(OLPP)**2+ABS(ORPP)**2
36011 GLR=DBLE(OLPP*DCONJG(ORPP))
36012 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
36013 IDLAM(LKNT,1)=KFNCHI(IJ)
36014 IDLAM(LKNT,2)=23
36015 IDLAM(LKNT,3)=0
36016 ELSEIF(AXMI.GE.AXMJ) THEN
36017 XXC(1)=0D0
36018 XXC(2)=XMJ
36019 XXC(3)=0D0
36020 XXC(4)=XMI
36021 XXC(9)=XMZ
36022 XXC(10)=PMAS(23,2)
36023 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
36024 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
36025 ORPP=DCONJG(OLPP)
36026C...CHARGED LEPTONS
36027 FID=11
36028 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
36029 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
36030 EI=KCHG(FID,1)/3D0
36031 T3I=SIGN(1D0,EI+1D-6)/2D0
36032 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
36033 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
36034 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
36035 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
36036 CXC(2)=-GLIJ
36037 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
36038 CXC(4)=DCONJG(GLIJ)
36039 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
36040 CXC(6)=GRIJ
36041 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
36042 CXC(8)=-DCONJG(GRIJ)
36043 S12MIN=0D0
36044 S12MAX=(AXMI-AXMJ)**2
36045 IF( XXC(5).LT.AXMI ) THEN
36046 XXC(5)=1D6
36047 ENDIF
36048 IF(XXC(6).LT.AXMI ) THEN
36049 XXC(6)=1D6
36050 ENDIF
36051 XXC(7)=XXC(5)
36052 XXC(8)=XXC(6)
36053
36054 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
36055 LKNT=LKNT+1
36056 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
36057 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
36058 IDLAM(LKNT,1)=KFNCHI(IJ)
36059 IDLAM(LKNT,2)=FID
36060 IDLAM(LKNT,3)=-FID
36061 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
36062 LKNT=LKNT+1
36063 XLAM(LKNT)=XLAM(LKNT-1)
36064 IDLAM(LKNT,1)=KFNCHI(IJ)
36065 IDLAM(LKNT,2)=13
36066 IDLAM(LKNT,3)=-13
36067 ENDIF
36068 ENDIF
36069 140 CONTINUE
36070 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
36071 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
36072 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
36073 ELSE
36074 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
36075 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
36076 ENDIF
36077 IF( XXC(5).LT.AXMI ) THEN
36078 XXC(5)=1D6
36079 ENDIF
36080 IF(XXC(6).LT.AXMI ) THEN
36081 XXC(6)=1D6
36082 ENDIF
36083 XXC(7)=XXC(5)
36084 XXC(8)=XXC(6)
36085
36086 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
36087 LKNT=LKNT+1
36088 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
36089 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
36090 IDLAM(LKNT,1)=KFNCHI(IJ)
36091 IDLAM(LKNT,2)=15
36092 IDLAM(LKNT,3)=-15
36093 ENDIF
36094
36095C...NEUTRINOS
36096 150 CONTINUE
36097 FID=12
36098 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
36099 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
36100 EI=KCHG(FID,1)/3D0
36101 T3I=SIGN(1D0,EI+1D-6)/2D0
36102 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
36103 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
36104 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
36105 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
36106 CXC(2)=-GLIJ
36107 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
36108 CXC(4)=DCONJG(GLIJ)
36109 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
36110 CXC(6)=GRIJ
36111 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
36112 CXC(8)=-DCONJG(GRIJ)
36113 S12MIN=0D0
36114 S12MAX=(AXMI-AXMJ)**2
36115 IF( XXC(5).LT.AXMI ) THEN
36116 XXC(5)=1D6
36117 ENDIF
36118 IF( XXC(6).LT.AXMI ) THEN
36119 XXC(6)=1D6
36120 ENDIF
36121 XXC(7)=XXC(5)
36122 XXC(8)=XXC(6)
36123
36124 LKNT=LKNT+1
36125 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
36126 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
36127 IDLAM(LKNT,1)=KFNCHI(IJ)
36128 IDLAM(LKNT,2)=12
36129 IDLAM(LKNT,3)=-12
36130 LKNT=LKNT+1
36131 XLAM(LKNT)=XLAM(LKNT-1)
36132 IDLAM(LKNT,1)=KFNCHI(IJ)
36133 IDLAM(LKNT,2)=14
36134 IDLAM(LKNT,3)=-14
36135 160 CONTINUE
36136
36137 IF(PMAS(PYCOMP(KSUSY1+16),1).NE.PMAS(PYCOMP(KSUSY1+12),1))
36138 & THEN
36139 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
36140 IF( XXC(5).LT.AXMI ) THEN
36141 XXC(5)=1D6
36142 ENDIF
36143 XXC(7)=XXC(5)
36144 LKNT=LKNT+1
36145 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
36146 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
36147 ELSE
36148 LKNT=LKNT+1
36149 XLAM(LKNT)=XLAM(LKNT-1)
36150 ENDIF
36151 IDLAM(LKNT,1)=KFNCHI(IJ)
36152 IDLAM(LKNT,2)=16
36153 IDLAM(LKNT,3)=-16
36154C...D-TYPE QUARKS
36155 170 CONTINUE
36156 FID=1
36157 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
36158 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
36159 EI=KCHG(FID,1)/3D0
36160 T3I=SIGN(1D0,EI+1D-6)/2D0
36161 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
36162 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
36163 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
36164 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
36165 CXC(2)=-GLIJ
36166 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
36167 CXC(4)=DCONJG(GLIJ)
36168 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
36169 CXC(6)=GRIJ
36170 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
36171 CXC(8)=-DCONJG(GRIJ)
36172 S12MIN=0D0
36173 S12MAX=(AXMI-AXMJ)**2
36174 IF( XXC(5).LT.AXMI ) THEN
36175 XXC(5)=1D6
36176 ENDIF
36177 IF( XXC(6).LT.AXMI ) THEN
36178 XXC(6)=1D6
36179 ENDIF
36180 XXC(7)=XXC(5)
36181 XXC(8)=XXC(6)
36182
36183 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
36184 LKNT=LKNT+1
36185 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
36186 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
36187 IDLAM(LKNT,1)=KFNCHI(IJ)
36188 IDLAM(LKNT,2)=1
36189 IDLAM(LKNT,3)=-1
36190 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
36191 LKNT=LKNT+1
36192 XLAM(LKNT)=XLAM(LKNT-1)
36193 IDLAM(LKNT,1)=KFNCHI(IJ)
36194 IDLAM(LKNT,2)=3
36195 IDLAM(LKNT,3)=-3
36196 ENDIF
36197 ENDIF
36198 180 CONTINUE
36199 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
36200 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
36201 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
36202 ELSE
36203 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
36204 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
36205 ENDIF
36206 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
36207 IF(XXC(5).LT.AXMI) THEN
36208 XXC(5)=1D6
36209 ELSEIF(XXC(6).LT.AXMI) THEN
36210 XXC(6)=1D6
36211 ENDIF
36212 XXC(7)=XXC(5)
36213 XXC(8)=XXC(6)
36214 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
36215 LKNT=LKNT+1
36216 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
36217 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
36218 IDLAM(LKNT,1)=KFNCHI(IJ)
36219 IDLAM(LKNT,2)=5
36220 IDLAM(LKNT,3)=-5
36221 ENDIF
36222
36223C...U-TYPE QUARKS
36224 190 CONTINUE
36225 FID=2
36226 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
36227 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
36228 EI=KCHG(FID,1)/3D0
36229 T3I=SIGN(1D0,EI+1D-6)/2D0
36230 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
36231 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
36232 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
36233 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
36234 CXC(2)=-GLIJ
36235 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
36236 CXC(4)=DCONJG(GLIJ)
36237 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
36238 CXC(6)=GRIJ
36239 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
36240 CXC(8)=-DCONJG(GRIJ)
36241
36242 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 200
36243 IF(XXC(5).LT.AXMI) THEN
36244 XXC(5)=1D6
36245 ELSEIF(XXC(6).LT.AXMI) THEN
36246 XXC(6)=1D6
36247 ENDIF
36248 XXC(7)=XXC(5)
36249 XXC(8)=XXC(6)
36250
36251 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
36252 LKNT=LKNT+1
36253 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
36254 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
36255 IDLAM(LKNT,1)=KFNCHI(IJ)
36256 IDLAM(LKNT,2)=2
36257 IDLAM(LKNT,3)=-2
36258 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
36259 LKNT=LKNT+1
36260 XLAM(LKNT)=XLAM(LKNT-1)
36261 IDLAM(LKNT,1)=KFNCHI(IJ)
36262 IDLAM(LKNT,2)=4
36263 IDLAM(LKNT,3)=-4
36264 ENDIF
36265 ENDIF
36266 200 CONTINUE
36267 ENDIF
36268
36269C...CHI0_I -> CHI0_J + H0_K
36270 EH(1)=SIN(ALFA)
36271 EH(2)=COS(ALFA)
36272 EH(3)=-SIN(BETA)
36273 DH(1)=COS(ALFA)
36274 DH(2)=-SIN(ALFA)
36275 DH(3)=COS(BETA)
36276 QIJ=ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,2))+
36277 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,2)-
36278 & TANW*(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,1))+
36279 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,1))
36280 RIJ=DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,2)+
36281 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,2))-
36282 & TANW*(DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,1)+
36283 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,1)))
36284 DO 210 IH=1,3
36285 XMH=PMAS(ITH(IH),1)
36286 XMH2=XMH**2
36287 IF(AXMI.GE.AXMJ+XMH) THEN
36288 LKNT=LKNT+1
36289 XL=PYLAMF(XMI2,XMJ2,XMH2)
36290 F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH))
36291 F12K=F21K
36292C...SIGN OF MASSES I,J
36293 XMK=XMJ
36294 IF(IH.EQ.3) XMK=-XMK
36295 GX2=ABS(F21K)**2+ABS(F12K)**2
36296 GLR=DBLE(F21K*DCONJG(F12K))
36297 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
36298 IDLAM(LKNT,1)=KFNCHI(IJ)
36299 IDLAM(LKNT,2)=ITH(IH)
36300 IDLAM(LKNT,3)=0
36301 ENDIF
36302 210 CONTINUE
36303 220 CONTINUE
36304
36305C...CHI0_I -> CHI+_J + W-
36306 DO 260 IJ=1,2
36307 XMJ=SMW(IJ)
36308 AXMJ=ABS(XMJ)
36309 XMJ2=XMJ**2
36310 IF(AXMI.GE.AXMJ+XMW) THEN
36311 LKNT=LKNT+1
36312 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
36313 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)/SR2)
36314 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
36315 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))/SR2)
36316 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
36317 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
36318 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
36319 IDLAM(LKNT,1)=KFCCHI(IJ)
36320 IDLAM(LKNT,2)=-24
36321 IDLAM(LKNT,3)=0
36322 LKNT=LKNT+1
36323 XLAM(LKNT)=XLAM(LKNT-1)
36324 IDLAM(LKNT,1)=-KFCCHI(IJ)
36325 IDLAM(LKNT,2)=24
36326 IDLAM(LKNT,3)=0
36327 ELSEIF(AXMI.GE.AXMJ) THEN
36328 S12MIN=0D0
36329 S12MAX=(AXMI-AXMJ)**2
36330 RT2I = 1D0/SQRT(2D0)
36331 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
36332 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)*RT2I)*RT2I
36333 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
36334 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))*RT2I)*RT2I
36335 CXC(5)=DCMPLX(0D0,0D0)
36336 CXC(7)=DCMPLX(0D0,0D0)
36337 IA=11
36338 JA=12
36339 EI=KCHG(IA,1)/3D0
36340 T3I=SIGN(1D0,EI+1D-6)/2D0
36341 EJ=KCHG(JA,1)/3D0
36342 T3J=SIGN(1D0,EJ+1D-6)/2D0
36343 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
36344 & TANW+ZMIXC(IX,2)*T3J)*RT2I
36345 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
36346 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)*RT2I
36347 CXC(6)=DCMPLX(0D0,0D0)
36348 CXC(8)=DCMPLX(0D0,0D0)
36349 XXC(1)=0D0
36350 XXC(2)=XMJ
36351 XXC(3)=0D0
36352 XXC(4)=XMI
36353 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
36354 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
36355 XXC(9)=PMAS(24,1)
36356 XXC(10)=PMAS(24,2)
36357 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 230
36358 IF(XXC(5).LT.AXMI) THEN
36359 XXC(5)=1D6
36360 ELSEIF(XXC(6).LT.AXMI) THEN
36361 XXC(6)=1D6
36362 ENDIF
36363 XXC(7)=XXC(6)
36364 XXC(8)=XXC(5)
36365 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
36366 LKNT=LKNT+1
36367 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
36368 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
36369 IDLAM(LKNT,1)=KFCCHI(IJ)
36370 IDLAM(LKNT,2)=11
36371 IDLAM(LKNT,3)=-12
36372 LKNT=LKNT+1
36373 XLAM(LKNT)=XLAM(LKNT-1)
36374 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36375 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36376 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
36377 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
36378 LKNT=LKNT+1
36379 XLAM(LKNT)=XLAM(LKNT-1)
36380 IDLAM(LKNT,1)=KFCCHI(IJ)
36381 IDLAM(LKNT,2)=13
36382 IDLAM(LKNT,3)=-14
36383 LKNT=LKNT+1
36384 XLAM(LKNT)=XLAM(LKNT-1)
36385 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36386 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36387 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
36388 ENDIF
36389 ENDIF
36390 230 CONTINUE
36391 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
36392 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
36393 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
36394 ELSE
36395 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
36396 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
36397 ENDIF
36398 IF(XXC(5).LT.AXMI) THEN
36399 XXC(5)=1D6
36400 ENDIF
36401 IF(XXC(6).LT.AXMI) THEN
36402 XXC(6)=1D6
36403 ENDIF
36404 XXC(7)=XXC(6)
36405 XXC(8)=XXC(5)
36406 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
36407 LKNT=LKNT+1
36408 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
36409 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
36410 XLAM(LKNT)=XLAM(LKNT-1)
36411 IDLAM(LKNT,1)=KFCCHI(IJ)
36412 IDLAM(LKNT,2)=15
36413 IDLAM(LKNT,3)=-16
36414 LKNT=LKNT+1
36415 XLAM(LKNT)=XLAM(LKNT-1)
36416 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36417 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36418 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
36419 ENDIF
36420
36421C...NOW, DO THE QUARKS
36422 240 CONTINUE
36423 IA=1
36424 JA=2
36425 EI=KCHG(IA,1)/3D0
36426 T3I=SIGN(1D0,EI+1D-6)/2D0
36427 EJ=KCHG(JA,1)/3D0
36428 T3J=SIGN(1D0,EJ+1D-6)/2D0
36429 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
36430 & TANW+ZMIXC(IX,2)*T3J)
36431 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
36432 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)
36433 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
36434 XXC(6)=PMAS(PYCOMP(KSUSY1+JA),1)
36435 IF(XXC(5).LT.AXMI) THEN
36436 XXC(5)=1D6
36437 ENDIF
36438 IF(XXC(6).LT.AXMI) THEN
36439 XXC(6)=1D6
36440 ENDIF
36441 XXC(7)=XXC(6)
36442 XXC(8)=XXC(5)
36443 IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN
36444 LKNT=LKNT+1
36445 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
36446 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
36447 IDLAM(LKNT,1)=KFCCHI(IJ)
36448 IDLAM(LKNT,2)=1
36449 IDLAM(LKNT,3)=-2
36450 LKNT=LKNT+1
36451 XLAM(LKNT)=XLAM(LKNT-1)
36452 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36453 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36454 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
36455 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
36456 LKNT=LKNT+1
36457 XLAM(LKNT)=XLAM(LKNT-1)
36458 IDLAM(LKNT,1)=KFCCHI(IJ)
36459 IDLAM(LKNT,2)=3
36460 IDLAM(LKNT,3)=-4
36461 LKNT=LKNT+1
36462 XLAM(LKNT)=XLAM(LKNT-1)
36463 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36464 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36465 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
36466 ENDIF
36467 ENDIF
36468 250 CONTINUE
36469 ENDIF
36470 260 CONTINUE
36471 270 CONTINUE
36472
36473C...CHI0_I -> CHI+_I + H-
36474 DO 280 IJ=1,2
36475 XMJ=SMW(IJ)
36476 AXMJ=ABS(XMJ)
36477 XMJ2=XMJ**2
36478 XMHP=PMAS(ITHC,1)
36479 IF(AXMI.GE.AXMJ+XMHP) THEN
36480 LKNT=LKNT+1
36481 OLPP=CBETA*(ZMIXC(IX,4)*DCONJG(VMIXC(IJ,1))+(ZMIXC(IX,2)+
36482 & ZMIXC(IX,1)*TANW)*DCONJG(VMIXC(IJ,2))/SR2)
36483 ORPP=SBETA*(DCONJG(ZMIXC(IX,3))*UMIXC(IJ,1)-
36484 & (DCONJG(ZMIXC(IX,2))+DCONJG(ZMIXC(IX,1))*TANW)*
36485 & UMIXC(IJ,2)/SR2)
36486 GX2=ABS(OLPP)**2+ABS(ORPP)**2
36487 GLR=DBLE(OLPP*DCONJG(ORPP))
36488 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
36489 IDLAM(LKNT,1)=KFCCHI(IJ)
36490 IDLAM(LKNT,2)=-ITHC
36491 IDLAM(LKNT,3)=0
36492 LKNT=LKNT+1
36493 XLAM(LKNT)=XLAM(LKNT-1)
36494 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36495 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36496 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
36497 ELSE
36498
36499 ENDIF
36500 280 CONTINUE
36501
36502C...2-BODY DECAYS TO FERMION SFERMION
36503 DO 290 J=1,16
36504 IF(J.GE.7.AND.J.LE.10) GOTO 290
36505 KF1=KSUSY1+J
36506 KF2=KSUSY2+J
36507 XMSF1=PMAS(PYCOMP(KF1),1)
36508 XMSF2=PMAS(PYCOMP(KF2),1)
36509 XMF=PMAS(J,1)
36510 IF(J.LE.6) THEN
36511 FCOL=3D0
36512 ELSE
36513 FCOL=1D0
36514 ENDIF
36515
36516 EI=KCHG(J,1)/3D0
36517 T3T=SIGN(1D0,EI)
36518 IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0
36519 IF(MOD(J,2).EQ.0) THEN
36520 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
36521 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
36522 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
36523 CBR=CAL
36524 ELSE
36525 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
36526 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
36527 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
36528 CBR=CAL
36529 ENDIF
36530
36531C...D~ D_L
36532 IF(AXMI.GE.XMF+XMSF1) THEN
36533 LKNT=LKNT+1
36534 XMA2=XMSF1**2
36535 XMB2=XMF**2
36536 XL=PYLAMF(XMI2,XMA2,XMB2)
36537 CA=CAL*SFMIX(J,1)+CAR*SFMIX(J,2)
36538 CB=CBL*SFMIX(J,1)+CBR*SFMIX(J,2)
36539 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
36540 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
36541 IDLAM(LKNT,1)=KF1
36542 IDLAM(LKNT,2)=-J
36543 IDLAM(LKNT,3)=0
36544 LKNT=LKNT+1
36545 XLAM(LKNT)=XLAM(LKNT-1)
36546 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36547 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36548 IDLAM(LKNT,3)=0
36549 ENDIF
36550
36551C...D~ D_R
36552 IF(AXMI.GE.XMF+XMSF2) THEN
36553 LKNT=LKNT+1
36554 XMA2=XMSF2**2
36555 XMB2=XMF**2
36556 CA=CAL*SFMIX(J,3)+CAR*SFMIX(J,4)
36557 CB=CBL*SFMIX(J,3)+CBR*SFMIX(J,4)
36558 XL=PYLAMF(XMI2,XMA2,XMB2)
36559 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
36560 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
36561 IDLAM(LKNT,1)=KF2
36562 IDLAM(LKNT,2)=-J
36563 IDLAM(LKNT,3)=0
36564 LKNT=LKNT+1
36565 XLAM(LKNT)=XLAM(LKNT-1)
36566 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36567 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36568 IDLAM(LKNT,3)=0
36569 ENDIF
36570 290 CONTINUE
36571 300 CONTINUE
36572C...3-BODY DECAY TO Q Q~ GLUINO
36573 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
36574 IF(AXMI.GE.XMJ) THEN
36575 RT2I = 1D0/SQRT(2D0)
36576 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))*RT2I
36577 ORPP=DCONJG(OLPP)
36578 AXMJ=ABS(XMJ)
36579 XXC(1)=0D0
36580 XXC(2)=XMJ
36581 XXC(3)=0D0
36582 XXC(4)=XMI
36583 FID=1
36584 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
36585 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
36586 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 310
36587 XXC(7)=XXC(5)
36588 XXC(8)=XXC(6)
36589 XXC(9)=1D6
36590 XXC(10)=0D0
36591 EI=KCHG(FID,1)/3D0
36592 T3I=SIGN(1D0,EI+1D-6)/2D0
36593 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
36594 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
36595 CXC(1)=0D0
36596 CXC(2)=-GLIJ
36597 CXC(3)=0D0
36598 CXC(4)=DCONJG(GLIJ)
36599 CXC(5)=0D0
36600 CXC(6)=GRIJ
36601 CXC(7)=0D0
36602 CXC(8)=-DCONJG(GRIJ)
36603 S12MIN=0D0
36604 S12MAX=(AXMI-AXMJ)**2
36605C...ALL QUARKS BUT T
36606 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
36607 LKNT=LKNT+1
36608 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
36609 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
36610 IDLAM(LKNT,1)=KSUSY1+21
36611 IDLAM(LKNT,2)=1
36612 IDLAM(LKNT,3)=-1
36613 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
36614 LKNT=LKNT+1
36615 XLAM(LKNT)=XLAM(LKNT-1)
36616 IDLAM(LKNT,1)=KSUSY1+21
36617 IDLAM(LKNT,2)=3
36618 IDLAM(LKNT,3)=-3
36619 ENDIF
36620 ENDIF
36621 310 CONTINUE
36622 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
36623 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
36624 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
36625 ELSE
36626 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
36627 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
36628 ENDIF
36629 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 320
36630 XXC(7)=XXC(5)
36631 XXC(8)=XXC(6)
36632 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
36633 LKNT=LKNT+1
36634 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
36635 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
36636 IDLAM(LKNT,1)=KSUSY1+21
36637 IDLAM(LKNT,2)=5
36638 IDLAM(LKNT,3)=-5
36639 ENDIF
36640C...U-TYPE QUARKS
36641 320 CONTINUE
36642 FID=2
36643 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
36644 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
36645 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 330
36646 XXC(7)=XXC(5)
36647 XXC(8)=XXC(6)
36648 EI=KCHG(FID,1)/3D0
36649 T3I=SIGN(1D0,EI+1D-6)/2D0
36650 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
36651 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
36652 CXC(2)=-GLIJ
36653 CXC(4)=DCONJG(GLIJ)
36654 CXC(6)=GRIJ
36655 CXC(8)=-DCONJG(GRIJ)
36656 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
36657 LKNT=LKNT+1
36658 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
36659 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
36660 IDLAM(LKNT,1)=KSUSY1+21
36661 IDLAM(LKNT,2)=2
36662 IDLAM(LKNT,3)=-2
36663 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
36664 LKNT=LKNT+1
36665 XLAM(LKNT)=XLAM(LKNT-1)
36666 IDLAM(LKNT,1)=KSUSY1+21
36667 IDLAM(LKNT,2)=4
36668 IDLAM(LKNT,3)=-4
36669 ENDIF
36670 ENDIF
36671 330 CONTINUE
36672 ENDIF
36673
36674C...R-violating decay modes (SKANDS).
36675 CALL PYRVNE(KFIN,XLAM,IDLAM,LKNT)
36676
36677 340 IKNT=LKNT
36678 XLAM(0)=0D0
36679 DO 350 I=1,IKNT
36680 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
36681 XLAM(0)=XLAM(0)+XLAM(I)
36682 350 CONTINUE
36683 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
36684
36685 RETURN
36686 END
36687
36688C*********************************************************************
36689
36690C...PYCJDC
36691C...Calculate decay widths for the charginos (admixtures of
36692C...charged Wino and charged Higgsino.
36693
36694C...Input: KCIN = KF code for particle
36695C...Output: XLAM = widths
36696C... IDLAM = KF codes for decay particles
36697C... IKNT = number of decay channels defined
36698C...AUTHOR: STEPHEN MRENNA
36699C...Last change:
36700C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
36701C...when CHIENU .NE. 0
36702
36703 SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT)
36704
36705C...Double precision and integer declarations.
36706 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36707 IMPLICIT INTEGER(I-N)
36708 INTEGER PYK,PYCHGE,PYCOMP
36709C...Parameter statement to help give large particle numbers.
36710 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
36711 &KEXCIT=4000000,KDIMEN=5000000)
36712C...Commonblocks.
36713 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36714 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36715 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
36716 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
36717 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
36718CC &SFMIX(16,4),
36719C COMMON/PYINTS/XXM(20)
36720 COMPLEX*16 CXC
36721 COMMON/PYINTC/XXC(10),CXC(8)
36722 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
36723
36724C...Local variables
36725 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
36726 COMPLEX*16 CAL,CBL,CAR,CBR,CA,CB
36727 INTEGER KFIN,KCIN
36728 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
36729 &XMZ,XMZ2,AXMJ,AXMI
36730 DOUBLE PRECISION S12MIN,S12MAX
36731 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2,XMK
36732 DOUBLE PRECISION PYLAMF,XL
36733 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I,BETA,ALFA
36734 DOUBLE PRECISION PYX2XH,PYX2XG
36735 DOUBLE PRECISION XLAM(0:300)
36736 INTEGER IDLAM(300,3)
36737 INTEGER LKNT,IX,IH,J,IJ,I,IKNT
36738 INTEGER ITH(3)
36739 INTEGER ITHC
36740 DOUBLE PRECISION ETAH(3),DH(3),EH(3)
36741 DOUBLE PRECISION SR2
36742 DOUBLE PRECISION CBETA,SBETA,TANB
36743
36744 DOUBLE PRECISION PYALEM,PI,PYALPS
36745 DOUBLE PRECISION FCOL
36746 INTEGER KF1,KF2,ISF
36747 INTEGER KFNCHI(4),KFCCHI(2)
36748
36749 DOUBLE PRECISION TEMP
36750 EXTERNAL PYGAUS,PYXXZ6
36751 DOUBLE PRECISION PYGAUS,PYXXZ6
36752 DOUBLE PRECISION PREC
36753 DATA ITH/25,35,36/
36754 DATA ITHC/37/
36755 DATA ETAH/1D0,1D0,-1D0/
36756 DATA SR2/1.4142136D0/
36757 DATA PI/3.141592654D0/
36758 DATA PREC/1D-2/
36759 DATA KFNCHI/1000022,1000023,1000025,1000035/
36760 DATA KFCCHI/1000024,1000037/
36761
36762C...COUNT THE NUMBER OF DECAY MODES
36763 LKNT=0
36764 XMW=PMAS(24,1)
36765 XMW2=XMW**2
36766 XMZ=PMAS(23,1)
36767 XMZ2=XMZ**2
36768 XW=1D0-XMW2/XMZ2
36769 XW1=1D0-XW
36770 TANW = SQRT(XW/XW1)
36771
36772C...1 OR 2 DEPENDING ON CHARGINO TYPE
36773 IX=1
36774 IF(KFIN.EQ.KFCCHI(2)) IX=2
36775 KCIN=PYCOMP(KFIN)
36776
36777 XMI=SMW(IX)
36778 XMI2=XMI**2
36779 AXMI=ABS(XMI)
36780 AEM=PYALEM(XMI2)
36781 AS =PYALPS(XMI2)
36782 C1=AEM/XW
36783 XMI3=ABS(XMI**3)
36784 TANB=RMSS(5)
36785 BETA=ATAN(TANB)
36786 CBETA=COS(BETA)
36787 SBETA=TANB*CBETA
36788 ALFA=RMSS(18)
36789
36790 DO 110 I=1,2
36791 DO 100 J=1,2
36792 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
36793 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
36794 100 CONTINUE
36795 110 CONTINUE
36796
36797C...GRAVITINO DECAY MODES
36798
36799 IF(IMSS(11).EQ.1) THEN
36800 XMP=RMSS(29)
36801 IDG=39+KSUSY1
36802 XMGR=PMAS(PYCOMP(IDG),1)
36803C SINW=SQRT(XW)
36804C COSW=SQRT(1D0-XW)
36805 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
36806 IF(AXMI.GT.XMGR+XMW) THEN
36807 LKNT=LKNT+1
36808 IDLAM(LKNT,1)=IDG
36809 IDLAM(LKNT,2)=24
36810 IDLAM(LKNT,3)=0
36811 XLAM(LKNT)=XFAC*(
36812 & .5D0*(ABS(VMIXC(IX,1))**2+ABS(UMIXC(IX,1))**2)+
36813 & .5D0*((ABS(VMIXC(IX,2))*SBETA)**2+(ABS(UMIXC(IX,2))*CBETA)**2))*
36814 & (1D0-XMW2/XMI2)**4
36815 ENDIF
36816 IF(AXMI.GT.XMGR+PMAS(37,1)) THEN
36817 LKNT=LKNT+1
36818 IDLAM(LKNT,1)=IDG
36819 IDLAM(LKNT,2)=37
36820 IDLAM(LKNT,3)=0
36821 XLAM(LKNT)=XFAC*(.5D0*((ABS(VMIXC(IX,2))*CBETA)**2+
36822 & (ABS(UMIXC(IX,2))*SBETA)**2))
36823 & *(1D0-PMAS(37,1)**2/XMI2)**4
36824 ENDIF
36825 ENDIF
36826
36827C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
36828 IF(IX.EQ.1) GOTO 170
36829 XMJ=SMW(1)
36830 AXMJ=ABS(XMJ)
36831 XMJ2=XMJ**2
36832
36833C...CHI_2+ -> CHI_1+ + Z0
36834 IF(AXMI.GE.AXMJ+XMZ) THEN
36835 LKNT=LKNT+1
36836 IJ=1
36837 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
36838 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
36839 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
36840 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
36841 GX2=ABS(OLPP)**2+ABS(ORPP)**2
36842 GLR=DBLE(OLPP*DCONJG(ORPP))
36843 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
36844 IDLAM(LKNT,1)=KFCCHI(1)
36845 IDLAM(LKNT,2)=23
36846 IDLAM(LKNT,3)=0
36847
36848C...CHARGED LEPTONS
36849 ELSEIF(AXMI.GE.AXMJ) THEN
36850 S12MIN=0D0
36851 S12MAX=(AXMI-AXMJ)**2
36852 IA=11
36853 JA=12
36854 EI=KCHG(IABS(IA),1)/3D0
36855 T3I=SIGN(1D0,EI+1D-6)/2D0
36856 XXC(1)=0D0
36857 XXC(2)=XMJ
36858 XXC(3)=0D0
36859 XXC(4)=XMI
36860 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
36861 XXC(6)=1D6
36862 XXC(9)=PMAS(23,1)
36863 XXC(10)=PMAS(23,2)
36864 IJ=1
36865 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
36866 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
36867 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
36868 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
36869 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
36870 CXC(2)=DCMPLX(0D0,0D0)
36871 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
36872 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
36873 CXC(5)=-DCMPLX(EI/XW1)*ORPP
36874 CXC(6)=DCMPLX(0D0,0D0)
36875 CXC(7)=-DCMPLX(EI/XW1)*OLPP
36876 CXC(8)=DCMPLX(0D0,0D0)
36877 IF( XXC(5).LT.AXMI ) THEN
36878 XXC(5)=1D6
36879 ENDIF
36880 XXC(7)=XXC(5)
36881 XXC(8)=XXC(6)
36882 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
36883 LKNT=LKNT+1
36884 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
36885 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
36886 IDLAM(LKNT,1)=KFCCHI(1)
36887 IDLAM(LKNT,2)=11
36888 IDLAM(LKNT,3)=-11
36889 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
36890 LKNT=LKNT+1
36891 XLAM(LKNT)=XLAM(LKNT-1)
36892 IDLAM(LKNT,1)=KFCCHI(1)
36893 IDLAM(LKNT,2)=13
36894 IDLAM(LKNT,3)=-13
36895 ENDIF
36896 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
36897 LKNT=LKNT+1
36898 XLAM(LKNT)=XLAM(LKNT-1)
36899 IDLAM(LKNT,1)=KFCCHI(1)
36900 IDLAM(LKNT,2)=15
36901 IDLAM(LKNT,3)=-15
36902 ENDIF
36903 ENDIF
36904
36905C...NEUTRINOS
36906 120 CONTINUE
36907 IA=12
36908 JA=11
36909 EI=KCHG(IABS(IA),1)/3D0
36910 T3I=SIGN(1D0,EI+1D-6)/2D0
36911 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
36912 XXC(6)=1D6
36913 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
36914 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
36915 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
36916 CXC(5)=-DCMPLX(EI/XW1)*ORPP
36917 CXC(7)=-DCMPLX(EI/XW1)*OLPP
36918 IF( XXC(5).LT.AXMI ) THEN
36919 XXC(5)=1D6
36920 ENDIF
36921 XXC(7)=XXC(5)
36922 XXC(8)=XXC(6)
36923 IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN
36924 LKNT=LKNT+1
36925 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
36926 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
36927 IDLAM(LKNT,1)=KFCCHI(1)
36928 IDLAM(LKNT,2)=12
36929 IDLAM(LKNT,3)=-12
36930 LKNT=LKNT+1
36931 XLAM(LKNT)=XLAM(LKNT-1)
36932 IDLAM(LKNT,1)=KFCCHI(1)
36933 IDLAM(LKNT,2)=14
36934 IDLAM(LKNT,3)=-14
36935 ENDIF
36936 IF(AXMI.GE.AXMJ+2D0*PMAS(16,1)) THEN
36937 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
36938 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
36939 ELSE
36940 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
36941 ENDIF
36942 IF( XXC(5).LT.AXMI ) THEN
36943 XXC(5)=1D6
36944 ENDIF
36945 XXC(7)=XXC(5)
36946 LKNT=LKNT+1
36947 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
36948 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
36949 IDLAM(LKNT,1)=KFCCHI(1)
36950 IDLAM(LKNT,2)=16
36951 IDLAM(LKNT,3)=-16
36952 ENDIF
36953
36954C...D-TYPE QUARKS
36955 130 CONTINUE
36956 IA=1
36957 JA=2
36958 EI=KCHG(IABS(IA),1)/3D0
36959 T3I=SIGN(1D0,EI+1D-6)/2D0
36960 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
36961 XXC(6)=1D6
36962 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
36963 CXC(2)=DCMPLX(0D0,0D0)
36964 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
36965 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
36966 CXC(5)=-DCMPLX(EI/XW1)*ORPP
36967 CXC(6)=DCMPLX(0D0,0D0)
36968 CXC(7)=-DCMPLX(EI/XW1)*OLPP
36969 CXC(8)=DCMPLX(0D0,0D0)
36970 IF( XXC(5).LT.AXMI ) THEN
36971 XXC(5)=1D6
36972 ENDIF
36973 XXC(7)=XXC(5)
36974 XXC(8)=XXC(6)
36975 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
36976 LKNT=LKNT+1
36977 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
36978 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
36979 IDLAM(LKNT,1)=KFCCHI(1)
36980 IDLAM(LKNT,2)=1
36981 IDLAM(LKNT,3)=-1
36982 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
36983 LKNT=LKNT+1
36984 XLAM(LKNT)=XLAM(LKNT-1)
36985 IDLAM(LKNT,1)=KFCCHI(1)
36986 IDLAM(LKNT,2)=3
36987 IDLAM(LKNT,3)=-3
36988 ENDIF
36989 ENDIF
36990 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
36991 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
36992 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
36993 ELSE
36994 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
36995 ENDIF
36996 IF( XXC(5).LT.AXMI ) THEN
36997 XXC(5)=1D6
36998 ENDIF
36999 XXC(7)=XXC(5)
37000 LKNT=LKNT+1
37001 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
37002 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
37003 IDLAM(LKNT,1)=KFCCHI(1)
37004 IDLAM(LKNT,2)=5
37005 IDLAM(LKNT,3)=-5
37006 ENDIF
37007
37008C...U-TYPE QUARKS
37009 140 CONTINUE
37010 IA=2
37011 JA=1
37012 EI=KCHG(IABS(IA),1)/3D0
37013 T3I=SIGN(1D0,EI+1D-6)/2D0
37014 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
37015 XXC(6)=1D6
37016 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
37017 CXC(2)=DCMPLX(0D0,0D0)
37018 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
37019 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
37020 CXC(5)=-DCMPLX(EI/XW1)*ORPP
37021 CXC(6)=DCMPLX(0D0,0D0)
37022 CXC(7)=-DCMPLX(EI/XW1)*OLPP
37023 CXC(8)=DCMPLX(0D0,0D0)
37024 IF( XXC(5).LT.AXMI ) THEN
37025 XXC(5)=1D6
37026 ENDIF
37027 XXC(7)=XXC(5)
37028 XXC(8)=XXC(6)
37029 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
37030 LKNT=LKNT+1
37031 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
37032 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
37033 IDLAM(LKNT,1)=KFCCHI(1)
37034 IDLAM(LKNT,2)=2
37035 IDLAM(LKNT,3)=-2
37036 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
37037 LKNT=LKNT+1
37038 XLAM(LKNT)=XLAM(LKNT-1)
37039 IDLAM(LKNT,1)=KFCCHI(1)
37040 IDLAM(LKNT,2)=4
37041 IDLAM(LKNT,3)=-4
37042 ENDIF
37043 ENDIF
37044 150 CONTINUE
37045 ENDIF
37046
37047C...CHI_2+ -> CHI_1+ + H0_K
37048 EH(2)=COS(ALFA)
37049 EH(1)=SIN(ALFA)
37050 EH(3)=-SBETA
37051 DH(2)=-SIN(ALFA)
37052 DH(1)=COS(ALFA)
37053 DH(3)=COS(BETA)
37054 DO 160 IH=1,3
37055 XMH=PMAS(ITH(IH),1)
37056 XMH2=XMH**2
37057C...NO 3-BODY OPTION
37058 IF(AXMI.GE.AXMJ+XMH) THEN
37059 LKNT=LKNT+1
37060 XL=PYLAMF(XMI2,XMJ2,XMH2)
37061 OLPP=(VMIXC(2,1)*DCONJG(UMIXC(1,2))*EH(IH) -
37062 & VMIXC(2,2)*DCONJG(UMIXC(1,1))*DH(IH))/SR2
37063 ORPP=(DCONJG(VMIXC(1,1))*UMIXC(2,2)*EH(IH) -
37064 & DCONJG(VMIXC(1,2))*UMIXC(2,1)*DH(IH))/SR2
37065 XMK=XMJ*ETAH(IH)
37066 GX2=ABS(OLPP)**2+ABS(ORPP)**2
37067 GLR=DBLE(OLPP*DCONJG(ORPP))
37068 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
37069 IDLAM(LKNT,1)=KFCCHI(1)
37070 IDLAM(LKNT,2)=ITH(IH)
37071 IDLAM(LKNT,3)=0
37072 ENDIF
37073 160 CONTINUE
37074
37075C...CHI1 JUMPS TO HERE
37076 170 CONTINUE
37077
37078C...CHI+_I -> CHI0_J + W+
37079 DO 220 IJ=1,4
37080 XMJ=SMZ(IJ)
37081 AXMJ=ABS(XMJ)
37082 XMJ2=XMJ**2
37083 IF(AXMI.GE.AXMJ+XMW) THEN
37084 LKNT=LKNT+1
37085 DO 180 I=1,4
37086 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
37087 180 CONTINUE
37088 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
37089 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)
37090 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
37091 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)
37092 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
37093 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
37094 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
37095 IDLAM(LKNT,1)=KFNCHI(IJ)
37096 IDLAM(LKNT,2)=24
37097 IDLAM(LKNT,3)=0
37098C...LEPTONS
37099 ELSEIF(AXMI.GE.AXMJ) THEN
37100 S12MIN=0D0
37101 S12MAX=(AXMI-AXMJ)**2
37102 DO 190 I=1,4
37103 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
37104 190 CONTINUE
37105 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
37106 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)/SR2
37107 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
37108 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)/SR2
37109 CXC(5)=DCMPLX(0D0,0D0)
37110 CXC(7)=DCMPLX(0D0,0D0)
37111 IA=11
37112 JA=12
37113 EI=KCHG(IA,1)/3D0
37114 T3I=SIGN(1D0,EI+1D-6)/2D0
37115 EJ=KCHG(JA,1)/3D0
37116 T3J=SIGN(1D0,EJ+1D-6)/2D0
37117 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
37118 & TANW+ZMIXC(IJ,2)*T3J)/SR2
37119 CXC(4)=-DCONJG(UMIXC(IX,1))*(
37120 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)/SR2
37121 CXC(6)=DCMPLX(0D0,0D0)
37122 CXC(8)=DCMPLX(0D0,0D0)
37123 XXC(1)=0D0
37124 XXC(2)=XMJ
37125 XXC(3)=0D0
37126 XXC(4)=XMI
37127 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
37128 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
37129 XXC(9)=PMAS(24,1)
37130 XXC(10)=PMAS(24,2)
37131CCC IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
37132 IF(XXC(5).LT.AXMI) THEN
37133 XXC(5)=1D6
37134 ELSEIF(XXC(6).LT.AXMI) THEN
37135 XXC(6)=1D6
37136 ENDIF
37137 XXC(7)=XXC(6)
37138 XXC(8)=XXC(5)
37139C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
37140C...--> 1/(16PI)/M**3*(AEM/XW)**2
37141 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
37142 LKNT=LKNT+1
37143 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
37144 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
37145 IDLAM(LKNT,1)=KFNCHI(IJ)
37146 IDLAM(LKNT,2)=-11
37147 IDLAM(LKNT,3)=12
37148C...ONLY DECAY CHI+1 -> E+ NU_E
37149 IF( IMSS(12).NE. 0 ) GOTO 260
37150 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
37151 LKNT=LKNT+1
37152 XLAM(LKNT)=XLAM(LKNT-1)
37153 IDLAM(LKNT,1)=KFNCHI(IJ)
37154 IDLAM(LKNT,2)=-13
37155 IDLAM(LKNT,3)=14
37156 ENDIF
37157 ENDIF
37158 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
37159 LKNT=LKNT+1
37160 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
37161 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
37162 ELSE
37163 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
37164 ENDIF
37165 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
37166 IF(XXC(5).LT.AXMI) THEN
37167 XXC(5)=1D6
37168 ELSEIF(XXC(6).LT.AXMI) THEN
37169 XXC(6)=1D6
37170 ENDIF
37171 XXC(7)=XXC(6)
37172 XXC(8)=XXC(5)
37173 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
37174 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
37175 IDLAM(LKNT,1)=KFNCHI(IJ)
37176 IDLAM(LKNT,2)=-15
37177 IDLAM(LKNT,3)=16
37178 ENDIF
37179
37180C...NOW, DO THE QUARKS
37181 200 CONTINUE
37182 IA=1
37183 JA=2
37184 EI=KCHG(IA,1)/3D0
37185 T3I=SIGN(1D0,EI+1D-6)/2D0
37186 EJ=KCHG(JA,1)/3D0
37187 T3J=SIGN(1D0,EJ+1D-6)/2D0
37188 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
37189 & TANW+ZMIXC(IX,2)*T3J)
37190 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
37191 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)
37192 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
37193 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
37194 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 210
37195 IF(XXC(5).LT.AXMI) THEN
37196 XXC(5)=1D6
37197 ENDIF
37198 IF(XXC(6).LT.AXMI) THEN
37199 XXC(6)=1D6
37200 ENDIF
37201 XXC(7)=XXC(6)
37202 XXC(8)=XXC(5)
37203 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
37204 LKNT=LKNT+1
37205 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
37206 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
37207 IDLAM(LKNT,1)=KFNCHI(IJ)
37208 IDLAM(LKNT,2)=-1
37209 IDLAM(LKNT,3)=2
37210 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
37211 LKNT=LKNT+1
37212 XLAM(LKNT)=XLAM(LKNT-1)
37213 IDLAM(LKNT,1)=KFNCHI(IJ)
37214 IDLAM(LKNT,2)=-3
37215 IDLAM(LKNT,3)=4
37216 ENDIF
37217 ENDIF
37218 210 CONTINUE
37219 ENDIF
37220 220 CONTINUE
37221
37222C...CHI+_I -> CHI0_J + H+
37223 DO 230 IJ=1,4
37224 XMJ=SMZ(IJ)
37225 AXMJ=ABS(XMJ)
37226 XMJ2=XMJ**2
37227 XMHP=PMAS(ITHC,1)
37228 IF(AXMI.GE.AXMJ+XMHP) THEN
37229 LKNT=LKNT+1
37230 OLPP=CBETA*(ZMIXC(IJ,4)*DCONJG(VMIXC(IX,1))+(ZMIXC(IJ,2)+
37231 & ZMIXC(IJ,1)*TANW)*DCONJG(VMIXC(IX,2))/SR2)
37232 ORPP=SBETA*(DCONJG(ZMIXC(IJ,3))*UMIXC(IX,1)-
37233 & (DCONJG(ZMIXC(IJ,2))+DCONJG(ZMIXC(IJ,1))*TANW)*
37234 & UMIXC(IX,2)/SR2)
37235 GX2=ABS(OLPP)**2+ABS(ORPP)**2
37236 GLR=DBLE(OLPP*DCONJG(ORPP))
37237 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
37238 IDLAM(LKNT,1)=KFNCHI(IJ)
37239 IDLAM(LKNT,2)=ITHC
37240 IDLAM(LKNT,3)=0
37241 ELSE
37242
37243 ENDIF
37244 230 CONTINUE
37245
37246C...2-BODY DECAYS TO FERMION SFERMION
37247 DO 240 J=1,16
37248 IF(J.GE.7.AND.J.LE.10) GOTO 240
37249 IF(MOD(J,2).EQ.0) THEN
37250 KF1=KSUSY1+J-1
37251 ELSE
37252 KF1=KSUSY1+J+1
37253 ENDIF
37254 KF2=KF1+KSUSY1
37255 XMSF1=PMAS(PYCOMP(KF1),1)
37256 XMSF2=PMAS(PYCOMP(KF2),1)
37257 XMF=PMAS(J,1)
37258 IF(J.LE.6) THEN
37259 FCOL=3D0
37260 ELSE
37261 FCOL=1D0
37262 ENDIF
37263
37264C...U~ D_L
37265 IF(MOD(J,2).EQ.0) THEN
37266 XMFP=PMAS(J-1,1)
37267 CAL=UMIXC(IX,1)
37268 CBL=-XMF*VMIXC(IX,2)/XMW/SBETA/SR2
37269 CAR=-XMFP*UMIXC(IX,2)/XMW/CBETA/SR2
37270 CBR=0D0
37271 ISF=J-1
37272 ELSE
37273 XMFP=PMAS(J+1,1)
37274 CAL=VMIXC(IX,1)
37275 CBL=-XMF*UMIXC(IX,2)/XMW/CBETA/SR2
37276 CBR=0D0
37277 CAR=-XMFP*VMIXC(IX,2)/XMW/SBETA/SR2
37278 ISF=J+1
37279 ENDIF
37280
37281C...~U_L D
37282 IF(AXMI.GE.XMF+XMSF1) THEN
37283 LKNT=LKNT+1
37284 XMA2=XMSF1**2
37285 XMB2=XMF**2
37286 XL=PYLAMF(XMI2,XMA2,XMB2)
37287 CA=CAL*SFMIX(ISF,1)+CAR*SFMIX(ISF,2)
37288 CB=CBL*SFMIX(ISF,1)+CBR*SFMIX(ISF,2)
37289 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
37290 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
37291 IDLAM(LKNT,3)=0
37292 IF(MOD(J,2).EQ.0) THEN
37293 IDLAM(LKNT,1)=-KF1
37294 IDLAM(LKNT,2)=J
37295 ELSE
37296 IDLAM(LKNT,1)=KF1
37297 IDLAM(LKNT,2)=-J
37298 ENDIF
37299 ENDIF
37300
37301C...U~ D_R
37302 IF(AXMI.GE.XMF+XMSF2) THEN
37303 LKNT=LKNT+1
37304 XMA2=XMSF2**2
37305 XMB2=XMF**2
37306 CA=CAL*SFMIX(ISF,3)+CAR*SFMIX(ISF,4)
37307 CB=CBL*SFMIX(ISF,3)+CBR*SFMIX(ISF,4)
37308 XL=PYLAMF(XMI2,XMA2,XMB2)
37309 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
37310 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
37311 IDLAM(LKNT,3)=0
37312 IF(MOD(J,2).EQ.0) THEN
37313 IDLAM(LKNT,1)=-KF2
37314 IDLAM(LKNT,2)=J
37315 ELSE
37316 IDLAM(LKNT,1)=KF2
37317 IDLAM(LKNT,2)=-J
37318 ENDIF
37319 ENDIF
37320 240 CONTINUE
37321
37322C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
37323C...A 2-BODY -- 2-BODY CHAIN
37324 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
37325 IF(AXMI.GE.XMJ) THEN
37326 AXMJ=ABS(XMJ)
37327 S12MIN=0D0
37328 S12MAX=(AXMI-AXMJ)**2
37329 XXC(1)=0D0
37330 XXC(2)=XMJ
37331 XXC(3)=0D0
37332 XXC(4)=XMI
37333 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
37334 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
37335 XXC(9)=1D6
37336 XXC(10)=0D0
37337 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
37338 ORPP=DCONJG(OLPP)
37339 CXC(1)=DCMPLX(0D0,0D0)
37340 CXC(3)=DCMPLX(0D0,0D0)
37341 CXC(5)=DCMPLX(0D0,0D0)
37342 CXC(7)=DCMPLX(0D0,0D0)
37343 CXC(2)=UMIXC(IX,1)*OLPP/SR2
37344 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
37345 CXC(6)=DCMPLX(0D0,0D0)
37346 CXC(8)=DCMPLX(0D0,0D0)
37347 IF(XXC(5).LT.AXMI) THEN
37348 XXC(5)=1D6
37349 ELSEIF(XXC(6).LT.AXMI) THEN
37350 XXC(6)=1D6
37351 ENDIF
37352 XXC(7)=XXC(6)
37353 XXC(8)=XXC(5)
37354 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 250
37355 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
37356 LKNT=LKNT+1
37357 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
37358 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
37359 IDLAM(LKNT,1)=KSUSY1+21
37360 IDLAM(LKNT,2)=-1
37361 IDLAM(LKNT,3)=2
37362 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
37363 LKNT=LKNT+1
37364 XLAM(LKNT)=XLAM(LKNT-1)
37365 IDLAM(LKNT,1)=KSUSY1+21
37366 IDLAM(LKNT,2)=-3
37367 IDLAM(LKNT,3)=4
37368 ENDIF
37369 ENDIF
37370 250 CONTINUE
37371 ENDIF
37372
37373C...R-violating decay modes (SKANDS).
37374 CALL PYRVCH(KFIN,XLAM,IDLAM,LKNT)
37375
37376 260 IKNT=LKNT
37377 XLAM(0)=0D0
37378 DO 270 I=1,IKNT
37379 XLAM(0)=XLAM(0)+XLAM(I)
37380 IF(XLAM(I).LT.0D0) THEN
37381 WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN,
37382 & (IDLAM(I,J),J=1,3)
37383 XLAM(I)=0D0
37384 ENDIF
37385 270 CONTINUE
37386 IF(XLAM(0).EQ.0D0) THEN
37387 XLAM(0)=1D-6
37388 WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0)
37389 WRITE(MSTU(11),*) LKNT
37390 WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT)
37391 ENDIF
37392
37393 RETURN
37394 END
37395
37396C*********************************************************************
37397
37398C...PYXXZ6
37399C...Used in the calculation of inoi -> inoj + f + ~f.
37400
37401 FUNCTION PYXXZ6(X)
37402
37403C...Double precision and integer declarations.
37404 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37405 IMPLICIT INTEGER(I-N)
37406 INTEGER PYK,PYCHGE,PYCOMP
37407C...Parameter statement to help give large particle numbers.
37408 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
37409 &KEXCIT=4000000,KDIMEN=5000000)
37410C...Commonblocks.
37411 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37412C COMMON/PYINTS/XXM(20)
37413 COMPLEX*16 CXC
37414 COMMON/PYINTC/XXC(10),CXC(8)
37415 SAVE /PYDAT1/,/PYINTC/
37416
37417C...Local variables.
37418 COMPLEX*16 QLLS,QRRS,QRLS,QLRS,QLLU,QRRU,QLRT,QRLT
37419 DOUBLE PRECISION PYXXZ6,X
37420 DOUBLE PRECISION XM12,XM22,XM32,S,S13,WPROP2
37421 DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
37422 DOUBLE PRECISION SIJ
37423 DOUBLE PRECISION XMV,XMG,XMSU1,XMSU2,XMSD1,XMSD2
37424 DOUBLE PRECISION OL2
37425 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
37426 INTEGER I
37427
37428C...Statement functions.
37429C...Integral from x to y of (t-a)(b-t) dt.
37430 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
37431C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
37432 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
37433 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
37434C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
37435 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
37436 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
37437C...Integral from x to y of (t-a)/(b-t) dt.
37438 UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
37439C...Integral from x to y of 1/(t-a) dt.
37440 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
37441
37442 XM12=XXC(1)**2
37443 XM22=XXC(2)**2
37444 XM32=XXC(3)**2
37445 S=XXC(4)**2
37446 S13=X
37447
37448 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
37449 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
37450 &( (X-XM22-S)**2 -4D0*XM22*S ) )
37451
37452 S23MIN=(S23AVE-S23DEL)
37453 S23MAX=(S23AVE+S23DEL)
37454
37455 XMSD1=XXC(5)**2
37456 XMSD2=XXC(7)**2
37457 XMSU1=XXC(6)**2
37458 XMSU2=XXC(8)**2
37459
37460 XMV=XXC(9)
37461 XMG=XXC(10)
37462 QLLS=CXC(1)
37463 QLLU=CXC(2)
37464 QLRS=CXC(3)
37465 QLRT=CXC(4)
37466 QRLS=CXC(5)
37467 QRLT=CXC(6)
37468 QRRS=CXC(7)
37469 QRRU=CXC(8)
37470 WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
37471 SIJ=2D0*XXC(2)*XXC(4)*S13
37472 IF(XMV.LE.1000D0) THEN
37473 OL2=ABS(QLLS)**2+ABS(QRRS)**2+ABS(QLRS)**2+ABS(QRLS)**2
37474 OLR=-2D0*DBLE(QLRS*DCONJG(QLLS)+QRLS*DCONJG(QRRS))
37475 WW=(OL2*2D0*TINT(S23MAX,S23MIN,XM22,S)
37476 & +OLR*SIJ*(S23MAX-S23MIN))/WPROP2
37477 IF(XXC(5).LE.10000D0) THEN
37478 WFL1=4D0*(DBLE(QLLS*DCONJG(QLLU))*
37479 & TINT2(S23MAX,S23MIN,XM22,S,XMSD1)-
37480 & .5D0*DBLE(QLLS*DCONJG(QLRT))*SIJ*TPROP(S23MAX,S23MIN,XMSD2)+
37481 & DBLE(QLRS*DCONJG(QLRT))*TINT2(S23MAX,S23MIN,XM22,S,XMSD2)-
37482 & .5D0*DBLE(QLRS*DCONJG(QLLU))*SIJ*TPROP(S23MAX,S23MIN,XMSD1))
37483 & *(S13-XMV**2)/WPROP2
37484 ELSE
37485 WFL1=0D0
37486 ENDIF
37487
37488 IF(XXC(6).LE.10000D0) THEN
37489 WFL2=4D0*(DBLE(QRRS*DCONJG(QRRU))*
37490 & TINT2(S23MAX,S23MIN,XM22,S,XMSU1)-
37491 & .5D0*DBLE(QRRS*DCONJG(QRLT))*SIJ*TPROP(S23MAX,S23MIN,XMSU2)+
37492 & DBLE(QRLS*DCONJG(QRLT))*TINT2(S23MAX,S23MIN,XM22,S,XMSU2)-
37493 & .5D0*DBLE(QRLS*DCONJG(QRRU))*SIJ*TPROP(S23MAX,S23MIN,XMSU1))
37494 & *(S13-XMV**2)/WPROP2
37495 ELSE
37496 WFL2=0D0
37497 ENDIF
37498 ELSE
37499 WW=0D0
37500 WFL1=0D0
37501 WFL2=0D0
37502 ENDIF
37503 IF(XXC(5).LE.10000D0) THEN
37504 WF1=2D0*ABS(QLLU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD1)
37505 & +2D0*ABS(QLRT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD2)
37506 & - 2D0*DBLE(QLRT*DCONJG(QLLU))*
37507 & SIJ*UTINT(S23MAX,S23MIN,XMSD1,XM22+S-S13-XMSD2)
37508 ELSE
37509 WF1=0D0
37510 ENDIF
37511 IF(XXC(6).LE.10000D0) THEN
37512 WF2=2D0*ABS(QRRU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU1)
37513 & +2D0*ABS(QRLT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU2)
37514 & - 2D0*DBLE(QRLT*DCONJG(QRRU))*
37515 & SIJ*UTINT(S23MAX,S23MIN,XMSU1,XM22+S-S13-XMSU2)
37516 ELSE
37517 WF2=0D0
37518 ENDIF
37519
37520 PYXXZ6=(WW+WF1+WF2+WFL1+WFL2)
37521
37522 IF(PYXXZ6.LT.0D0) THEN
37523 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ6 '
37524 WRITE(MSTU(11),*) XXc(1),XXc(2),XXc(3),XXc(4)
37525 WRITE(MSTU(11),*) (XXc(I),I=5,8)
37526 WRITE(MSTU(11),*) (XXc(I),I=9,12)
37527 WRITE(MSTU(11),*) (XXc(I),I=13,16)
37528 WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2
37529 WRITE(MSTU(11),*) S23MIN,S23MAX
37530 PYXXZ6=0D0
37531 ENDIF
37532
37533 RETURN
37534 END
37535
37536
37537C*********************************************************************
37538
37539C...PYXXGA
37540C...Calculates chi0_i -> chi0_j + gamma.
37541
37542 FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL)
37543
37544C...Double precision and integer declarations.
37545 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37546 IMPLICIT INTEGER(I-N)
37547 INTEGER PYK,PYCHGE,PYCOMP
37548
37549C...Local variables.
37550 DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
37551 DOUBLE PRECISION F1,F2
37552
37553 F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR)
37554 F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL)
37555 PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3
37556 PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2
37557
37558 RETURN
37559 END
37560
37561C*********************************************************************
37562
37563C...PYX2XG
37564C...Calculates the decay rate for ino -> ino + gauge boson.
37565
37566 FUNCTION PYX2XG(C1,XM1,XM2,XM3,GX2,GLR)
37567
37568C...Double precision and integer declarations.
37569 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37570 IMPLICIT INTEGER(I-N)
37571 INTEGER PYK,PYCHGE,PYCOMP
37572
37573C...Local variables.
37574 DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GX2,GLR
37575 DOUBLE PRECISION XL,PYLAMF,C1
37576 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
37577
37578 XMI2=XM1**2
37579 XMI3=ABS(XM1**3)
37580 XMJ2=XM2**2
37581 XMV2=XM3**2
37582 XL=PYLAMF(XMI2,XMJ2,XMV2)
37583 PYX2XG=C1/8D0/XMI3*SQRT(XL)
37584 &*(GX2*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))-
37585 &12D0*GLR*XM1*XM2*XMV2)
37586
37587 RETURN
37588 END
37589
37590C*********************************************************************
37591
37592C...PYX2XH
37593C...Calculates the decay rate for ino -> ino + H.
37594
37595 FUNCTION PYX2XH(C1,XM1,XM2,XM3,GX2,GLR)
37596
37597C...Double precision and integer declarations.
37598 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37599 IMPLICIT INTEGER(I-N)
37600 INTEGER PYK,PYCHGE,PYCOMP
37601
37602C...Local variables.
37603 DOUBLE PRECISION PYX2XH,XM1,XM2,XM3
37604 DOUBLE PRECISION XL,PYLAMF,C1
37605 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
37606
37607 XMI2=XM1**2
37608 XMI3=ABS(XM1**3)
37609 XMJ2=XM2**2
37610 XMV2=XM3**2
37611 XL=PYLAMF(XMI2,XMJ2,XMV2)
37612 PYX2XH=C1/8D0/XMI3*SQRT(XL)
37613 &*(GX2*(XMI2+XMJ2-XMV2)+
37614 &4D0*GLR*XM1*XM2)
37615
37616 RETURN
37617 END
37618
37619C*********************************************************************
37620
37621C...PYHEXT
37622C...Calculates the non-standard decay modes of the Higgs boson.
37623C...
37624C...Author: Stephen Mrenna
37625C...Last Update: April 2001
37626C......Allow complex values for Z,U, and V
37627
37628 SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT)
37629
37630C...Double precision and integer declarations.
37631 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37632 IMPLICIT INTEGER(I-N)
37633 INTEGER PYK,PYCHGE,PYCOMP
37634C...Parameter statement to help give large particle numbers.
37635 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
37636 &KEXCIT=4000000,KDIMEN=5000000)
37637C...Commonblocks.
37638 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37639 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37640 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
37641 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
37642 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
37643 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
37644 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/
37645
37646C...Local variables.
37647 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
37648 COMPLEX*16 QIJ,RIJ,F21K,F12K
37649 INTEGER KFIN
37650 DOUBLE PRECISION XMI,XMJ,XMF,XMW,XMW2,XMZ,AXMJ,AXMI
37651 DOUBLE PRECISION XMI2,XMI3,XMJ2
37652 DOUBLE PRECISION PYLAMF,XL,CF,EI
37653 INTEGER IDU,IFL
37654 DOUBLE PRECISION TANW,XW,AEM,C1,AS
37655 DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
37656 DOUBLE PRECISION XLAM(0:300)
37657 INTEGER IDLAM(300,3)
37658 INTEGER LKNT,IH,J,IJ,I,IKNT,IK
37659 INTEGER ITH(4)
37660 INTEGER KFNCHI(4),KFCCHI(2)
37661 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
37662 DOUBLE PRECISION SR2
37663 DOUBLE PRECISION BETA,ALFA
37664 DOUBLE PRECISION CBETA,SBETA,GR,GL,TANB
37665 DOUBLE PRECISION PYALEM
37666 DOUBLE PRECISION AL,AR,ALR
37667 DOUBLE PRECISION XMK,AXMK,COSA,SINA,CW,XML
37668 DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
37669 DOUBLE PRECISION XMJL,XMJR,XM1,XM2
37670 DATA ITH/25,35,36,37/
37671 DATA ETAH/1D0,1D0,-1D0/
37672 DATA SR2/1.4142136D0/
37673 DATA KFNCHI/1000022,1000023,1000025,1000035/
37674 DATA KFCCHI/1000024,1000037/
37675
37676C...COUNT THE NUMBER OF DECAY MODES
37677 LKNT=IKNT
37678
37679 XMW=PMAS(24,1)
37680 XMW2=XMW**2
37681 XMZ=PMAS(23,1)
37682 XW=PARU(102)
37683 TANW = SQRT(XW/(1D0-XW))
37684 CW=SQRT(1D0-XW)
37685
37686C...1 - 4 DEPENDING ON Higgs species.
37687 IH=1
37688 IF(KFIN.EQ.ITH(2)) IH=2
37689 IF(KFIN.EQ.ITH(3)) IH=3
37690 IF(KFIN.EQ.ITH(4)) IH=4
37691
37692 XMI=PMAS(KFIN,1)
37693 XMI2=XMI**2
37694 AXMI=ABS(XMI)
37695 AEM=PYALEM(XMI2)
37696 C1=AEM/XW
37697 XMI3=ABS(XMI**3)
37698
37699 TANB=RMSS(5)
37700 BETA=ATAN(TANB)
37701 CBETA=COS(BETA)
37702 SBETA=TANB*CBETA
37703 ALFA=RMSS(18)
37704 COSA=COS(ALFA)
37705 SINA=SIN(ALFA)
37706 ATRIT=RMSS(16)
37707 ATRIB=RMSS(15)
37708 ATRIL=RMSS(17)
37709 XMUZ=-RMSS(4)
37710
37711 DO 110 I=1,4
37712 DO 100 J=1,4
37713 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
37714 100 CONTINUE
37715 110 CONTINUE
37716 DO 130 I=1,2
37717 DO 120 J=1,2
37718 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
37719 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
37720 120 CONTINUE
37721 130 CONTINUE
37722
37723
37724 IF(IH.EQ.4) GOTO 220
37725
37726C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
37727C...H0_K -> CHI0_I + CHI0_J
37728 EH(2)=SINA
37729 EH(1)=COSA
37730 EH(3)=CBETA
37731 DH(2)=COSA
37732 DH(1)=-SINA
37733 DH(3)=SBETA
37734 DO 150 IJ=1,4
37735 XMJ=SMZ(IJ)
37736 AXMJ=ABS(XMJ)
37737 DO 140 IK=1,IJ
37738 XMK=SMZ(IK)
37739 AXMK=ABS(XMK)
37740 IF(AXMI.GE.AXMJ+AXMK) THEN
37741 LKNT=LKNT+1
37742 QIJ=ZMIXC(IK,3)*ZMIXC(IJ,2)+
37743 & ZMIXC(IJ,3)*ZMIXC(IK,2)-
37744 & TANW*(ZMIXC(IK,3)*ZMIXC(IJ,1)+
37745 & ZMIXC(IJ,3)*ZMIXC(IK,1))
37746 RIJ=ZMIXC(IK,4)*ZMIXC(IJ,2)+
37747 & ZMIXC(IJ,4)*ZMIXC(IK,2)-
37748 & TANW*(ZMIXC(IK,4)*ZMIXC(IJ,1)+
37749 & ZMIXC(IJ,4)*ZMIXC(IK,1))
37750 F21K=0.5D0*DCONJG(QIJ*DH(IH)-RIJ*EH(IH))
37751 F12K=0.5D0*(QIJ*DH(IH)-RIJ*EH(IH))
37752C...SIGN OF MASSES I,J
37753 XML=XMK*ETAH(IH)
37754 GX2=ABS(F12K)**2+ABS(F21K)**2
37755 GLR=DBLE(F12K*DCONJG(F21K))
37756 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
37757 IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0
37758 IDLAM(LKNT,1)=KFNCHI(IJ)
37759 IDLAM(LKNT,2)=KFNCHI(IK)
37760 IDLAM(LKNT,3)=0
37761 ENDIF
37762 140 CONTINUE
37763 150 CONTINUE
37764
37765C...H0_K -> CHI+_I CHI-_J
37766 DO 170 IJ=1,2
37767 XMJ=SMW(IJ)
37768 AXMJ=ABS(XMJ)
37769 DO 160 IK=1,2
37770 XMK=SMW(IK)
37771 AXMK=ABS(XMK)
37772 IF(AXMI.GE.AXMJ+AXMK) THEN
37773 LKNT=LKNT+1
37774 OLPP=DCONJG(VMIXC(IJ,1)*UMIXC(IK,2)*DH(IH) +
37775 & VMIXC(IJ,2)*UMIXC(IK,1)*EH(IH))/SR2
37776 ORPP=(VMIXC(IK,1)*UMIXC(IJ,2)*DH(IH) +
37777 & VMIXC(IK,2)*UMIXC(IJ,1)*EH(IH))/SR2
37778 GX2=ABS(OLPP)**2+ABS(ORPP)**2
37779 GLR=DBLE(OLPP*DCONJG(ORPP))
37780 XML=XMK*ETAH(IH)
37781 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
37782 IDLAM(LKNT,1)=KFCCHI(IJ)
37783 IDLAM(LKNT,2)=-KFCCHI(IK)
37784 IDLAM(LKNT,3)=0
37785 ENDIF
37786 160 CONTINUE
37787 170 CONTINUE
37788
37789C...HIGGS TO SFERMION SFERMION
37790 DO 200 IFL=1,16
37791 IF(IFL.GE.7.AND.IFL.LE.10) GOTO 200
37792 IJ=KSUSY1+IFL
37793 XMJL=PMAS(PYCOMP(IJ),1)
37794 XMJR=PMAS(PYCOMP(IJ+KSUSY1),1)
37795 IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN
37796 XMJ=XMJL
37797 XMJ2=XMJ**2
37798 XL=PYLAMF(XMI2,XMJ2,XMJ2)
37799 XMF=PMAS(IFL,1)
37800 EI=KCHG(IFL,1)/3D0
37801 IDU=2-MOD(IFL,2)
37802
37803 IF(IH.EQ.1) THEN
37804 IF(IDU.EQ.1) THEN
37805 GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+
37806 & XMF**2/XMW*SINA/CBETA
37807 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+
37808 & XMF**2/XMW*SINA/CBETA
37809 IF(IFL.EQ.5) THEN
37810 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
37811 & ATRIB*SINA)
37812 ELSEIF(IFL.EQ.15) THEN
37813 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
37814 & ATRIL*SINA)
37815 ELSE
37816 GHLR=0D0
37817 ENDIF
37818 ELSE
37819 GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)-
37820 & XMF**2/XMW*COSA/SBETA
37821 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)-
37822 & XMF**2/XMW*COSA/SBETA
37823 IF(IFL.EQ.6) THEN
37824 GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA-
37825 & ATRIT*COSA)
37826 ELSE
37827 GHLR=0D0
37828 ENDIF
37829 ENDIF
37830
37831 ELSEIF(IH.EQ.2) THEN
37832 IF(IDU.EQ.1) THEN
37833 GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)-
37834 & XMF**2/XMW*COSA/CBETA
37835 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
37836 & XMF**2/XMW*COSA/CBETA
37837 IF(IFL.EQ.5) THEN
37838 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
37839 & ATRIB*COSA)
37840 ELSEIF(IFL.EQ.15) THEN
37841 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
37842 & ATRIL*COSA)
37843 ELSE
37844 GHLR=0D0
37845 ENDIF
37846 ELSE
37847 GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)-
37848 & XMF**2/XMW*SINA/SBETA
37849 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
37850 & XMF**2/XMW*SINA/SBETA
37851 IF(IFL.EQ.6) THEN
37852 GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+
37853 & ATRIT*SINA)
37854 ELSE
37855 GHLR=0D0
37856 ENDIF
37857 ENDIF
37858
37859 ELSEIF(IH.EQ.3) THEN
37860 GHLL=0D0
37861 GHRR=0D0
37862 GHLR=0D0
37863 IF(IDU.EQ.1) THEN
37864 IF(IFL.EQ.5) THEN
37865 GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ)
37866 ELSEIF(IFL.EQ.15) THEN
37867 GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ)
37868 ENDIF
37869 ELSE
37870 IF(IFL.EQ.6) THEN
37871 GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ)
37872 ENDIF
37873 ENDIF
37874 ENDIF
37875 IF(IH.EQ.3) GOTO 180
37876
37877 AL=SFMIX(IFL,1)**2
37878 AR=SFMIX(IFL,2)**2
37879 ALR=SFMIX(IFL,1)*SFMIX(IFL,2)
37880 IF(IFL.LE.6) THEN
37881 CF=3D0
37882 ELSE
37883 CF=1D0
37884 ENDIF
37885
37886 IF(AXMI.GE.2D0*XMJ) THEN
37887 LKNT=LKNT+1
37888 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
37889 & (GHLL*AL+GHRR*AR
37890 & +2D0*GHLR*ALR)**2
37891 IDLAM(LKNT,1)=IJ
37892 IDLAM(LKNT,2)=-IJ
37893 IDLAM(LKNT,3)=0
37894 ENDIF
37895
37896 IF(AXMI.GE.2D0*XMJR) THEN
37897 LKNT=LKNT+1
37898 AL=SFMIX(IFL,3)**2
37899 AR=SFMIX(IFL,4)**2
37900 ALR=SFMIX(IFL,3)*SFMIX(IFL,4)
37901 XMJ=XMJR
37902 XMJ2=XMJ**2
37903 XL=PYLAMF(XMI2,XMJ2,XMJ2)
37904 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
37905 & (GHLL*AL+GHRR*AR
37906 & +2D0*GHLR*ALR)**2
37907 IDLAM(LKNT,1)=IJ+KSUSY1
37908 IDLAM(LKNT,2)=-(IJ+KSUSY1)
37909 IDLAM(LKNT,3)=0
37910 ENDIF
37911 180 CONTINUE
37912
37913 IF(AXMI.GE.XMJL+XMJR) THEN
37914 LKNT=LKNT+1
37915 AL=SFMIX(IFL,1)*SFMIX(IFL,3)
37916 AR=SFMIX(IFL,2)*SFMIX(IFL,4)
37917 ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3)
37918 XMJ=XMJR
37919 XMJ2=XMJ**2
37920 XL=PYLAMF(XMI2,XMJ2,XMJL**2)
37921 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
37922 & (GHLL*AL+GHRR*AR)**2
37923 IDLAM(LKNT,1)=IJ
37924 IDLAM(LKNT,2)=-(IJ+KSUSY1)
37925 IDLAM(LKNT,3)=0
37926 LKNT=LKNT+1
37927 IDLAM(LKNT,1)=-IJ
37928 IDLAM(LKNT,2)=IJ+KSUSY1
37929 IDLAM(LKNT,3)=0
37930 XLAM(LKNT)=XLAM(LKNT-1)
37931 ENDIF
37932 ENDIF
37933 190 CONTINUE
37934 200 CONTINUE
37935 210 CONTINUE
37936
37937 GOTO 270
37938 220 CONTINUE
37939
37940C...H+ -> CHI+_I + CHI0_J
37941 DO 240 IJ=1,4
37942 XMJ=SMZ(IJ)
37943 AXMJ=ABS(XMJ)
37944 XMJ2=XMJ**2
37945 DO 230 IK=1,2
37946 XMK=SMW(IK)
37947 AXMK=ABS(XMK)
37948 IF(AXMI.GE.AXMJ+AXMK) THEN
37949 LKNT=LKNT+1
37950 OLPP=CBETA*DCONJG(ZMIXC(IJ,4)*VMIXC(IK,1)+(ZMIXC(IJ,2)+
37951 & ZMIXC(IJ,1)*TANW)*VMIXC(IK,2)/SR2)
37952 ORPP=SBETA*(ZMIXC(IJ,3)*UMIXC(IK,1)-
37953 & (ZMIXC(IJ,2)+ZMIXC(IJ,1)*TANW)*UMIXC(IK,2)/SR2)
37954 GX2=ABS(OLPP)**2+ABS(ORPP)**2
37955 GLR=DBLE(OLPP*DCONJG(ORPP))
37956 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GX2,GLR)
37957 IDLAM(LKNT,1)=KFNCHI(IJ)
37958 IDLAM(LKNT,2)=KFCCHI(IK)
37959 IDLAM(LKNT,3)=0
37960 ENDIF
37961 230 CONTINUE
37962 240 CONTINUE
37963
37964 GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2)
37965 GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB)
37966 AL=0D0
37967 AR=0D0
37968 CF=3D0
37969
37970C...H+ -> T_1 B_1~
37971 XM1=PMAS(PYCOMP(KSUSY1+6),1)
37972 XM2=PMAS(PYCOMP(KSUSY1+5),1)
37973 IF(XMI.GE.XM1+XM2) THEN
37974 XL=PYLAMF(XMI2,XM1**2,XM2**2)
37975 LKNT=LKNT+1
37976 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
37977 & (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2
37978 IDLAM(LKNT,1)=KSUSY1+6
37979 IDLAM(LKNT,2)=-(KSUSY1+5)
37980 IDLAM(LKNT,3)=0
37981 ENDIF
37982
37983C...H+ -> T_2 B_1~
37984 XM1=PMAS(PYCOMP(KSUSY2+6),1)
37985 XM2=PMAS(PYCOMP(KSUSY1+5),1)
37986 IF(XMI.GE.XM1+XM2) THEN
37987 XL=PYLAMF(XMI2,XM1**2,XM2**2)
37988 LKNT=LKNT+1
37989 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
37990 & (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2
37991 IDLAM(LKNT,1)=KSUSY2+6
37992 IDLAM(LKNT,2)=-(KSUSY1+5)
37993 IDLAM(LKNT,3)=0
37994 ENDIF
37995
37996C...H+ -> T_1 B_2~
37997 XM1=PMAS(PYCOMP(KSUSY1+6),1)
37998 XM2=PMAS(PYCOMP(KSUSY2+5),1)
37999 IF(XMI.GE.XM1+XM2) THEN
38000 XL=PYLAMF(XMI2,XM1**2,XM2**2)
38001 LKNT=LKNT+1
38002 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
38003 & (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2
38004 IDLAM(LKNT,1)=KSUSY1+6
38005 IDLAM(LKNT,2)=-(KSUSY2+5)
38006 IDLAM(LKNT,3)=0
38007 ENDIF
38008
38009C...H+ -> T_2 B_2~
38010 XM1=PMAS(PYCOMP(KSUSY2+6),1)
38011 XM2=PMAS(PYCOMP(KSUSY2+5),1)
38012 IF(XMI.GE.XM1+XM2) THEN
38013 XL=PYLAMF(XMI2,XM1**2,XM2**2)
38014 LKNT=LKNT+1
38015 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
38016 & (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2
38017 IDLAM(LKNT,1)=KSUSY2+6
38018 IDLAM(LKNT,2)=-(KSUSY2+5)
38019 IDLAM(LKNT,3)=0
38020 ENDIF
38021
38022C...H+ -> UL DL~
38023 GL=-XMW/SR2*SIN(2D0*BETA)
38024 DO 250 IJ=1,3,2
38025 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
38026 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
38027 IF(XMI.GE.XM1+XM2) THEN
38028 XL=PYLAMF(XMI2,XM1**2,XM2**2)
38029 LKNT=LKNT+1
38030 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
38031 IDLAM(LKNT,1)=-(KSUSY1+IJ)
38032 IDLAM(LKNT,2)=KSUSY1+IJ+1
38033 IDLAM(LKNT,3)=0
38034 ENDIF
38035 250 CONTINUE
38036
38037C...H+ -> EL~ NUL
38038 CF=1D0
38039 DO 260 IJ=11,13,2
38040 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
38041 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
38042 IF(XMI.GE.XM1+XM2) THEN
38043 XL=PYLAMF(XMI2,XM1**2,XM2**2)
38044 LKNT=LKNT+1
38045 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
38046 IDLAM(LKNT,1)=-(KSUSY1+IJ)
38047 IDLAM(LKNT,2)=KSUSY1+IJ+1
38048 IDLAM(LKNT,3)=0
38049 ENDIF
38050 260 CONTINUE
38051
38052C...H+ -> TAU1 NUTAUL
38053 XM1=PMAS(PYCOMP(KSUSY1+15),1)
38054 XM2=PMAS(PYCOMP(KSUSY1+16),1)
38055 IF(XMI.GE.XM1+XM2) THEN
38056 XL=PYLAMF(XMI2,XM1**2,XM2**2)
38057 LKNT=LKNT+1
38058 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,1)**2
38059 IDLAM(LKNT,1)=-(KSUSY1+15)
38060 IDLAM(LKNT,2)= KSUSY1+16
38061 IDLAM(LKNT,3)=0
38062 ENDIF
38063
38064C...H+ -> TAU2 NUTAUL
38065 XM1=PMAS(PYCOMP(KSUSY2+15),1)
38066 XM2=PMAS(PYCOMP(KSUSY1+16),1)
38067 IF(XMI.GE.XM1+XM2) THEN
38068 XL=PYLAMF(XMI2,XM1**2,XM2**2)
38069 LKNT=LKNT+1
38070 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,3)**2
38071 IDLAM(LKNT,1)=-(KSUSY2+15)
38072 IDLAM(LKNT,2)= KSUSY1+16
38073 IDLAM(LKNT,3)=0
38074 ENDIF
38075
38076 270 CONTINUE
38077 IKNT=LKNT
38078 XLAM(0)=0D0
38079 DO 280 I=1,IKNT
38080 IF(XLAM(I).LE.0D0) XLAM(I)=0D0
38081 XLAM(0)=XLAM(0)+XLAM(I)
38082 280 CONTINUE
38083 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
38084
38085 RETURN
38086 END
38087
38088C*********************************************************************
38089
38090C...PYH2XX
38091C...Calculates the decay rate for a Higgs to an ino pair.
38092
38093 FUNCTION PYH2XX(C1,XM1,XM2,XM3,GX2,GLR)
38094
38095C...Double precision and integer declarations.
38096 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38097 IMPLICIT INTEGER(I-N)
38098 INTEGER PYK,PYCHGE,PYCOMP
38099C...Commonblocks.
38100 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38101 SAVE /PYDAT1/
38102
38103C...Local variables.
38104 DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
38105 DOUBLE PRECISION XL,PYLAMF,C1
38106 DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
38107
38108 XMI2=XM1**2
38109 XMI3=ABS(XM1**3)
38110 XMJ2=XM2**2
38111 XMK2=XM3**2
38112 XL=PYLAMF(XMI2,XMJ2,XMK2)
38113 PYH2XX=C1/4D0/XMI3*SQRT(XL)
38114 &*(GX2*(XMI2-XMJ2-XMK2)-
38115 &4D0*GLR*XM3*XM2)
38116 IF(PYH2XX.LT.0D0) THEN
38117 WRITE(MSTU(11),*) ' NEGATIVE WIDTH IN PYH2XX '
38118 WRITE(MSTU(11),*) XMI2,XMJ2,XMK2,GX2,GLR,XM1,XM2,XM3
38119 STOP
38120 ENDIF
38121
38122 RETURN
38123 END
38124
38125C*********************************************************************
38126
38127C...PYGAUS
38128C...Integration by adaptive Gaussian quadrature.
38129C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
38130
38131 FUNCTION PYGAUS(F, A, B, EPS)
38132
38133C...Double precision and integer declarations.
38134 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38135 IMPLICIT INTEGER(I-N)
38136 INTEGER PYK,PYCHGE,PYCOMP
38137
38138C...Local declarations.
38139 EXTERNAL F
38140 DOUBLE PRECISION F,W(12), X(12)
38141 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
38142 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
38143 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
38144 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
38145 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
38146 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
38147 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
38148 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
38149 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
38150 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
38151 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
38152 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
38153
38154C...The Gaussian quadrature algorithm.
38155 H = 0D0
38156 IF(B .EQ. A) GOTO 140
38157 CONST = 5D-3 / ABS(B-A)
38158 BB = A
38159 100 CONTINUE
38160 AA = BB
38161 BB = B
38162 110 CONTINUE
38163 C1 = 0.5D0*(BB+AA)
38164 C2 = 0.5D0*(BB-AA)
38165 S8 = 0D0
38166 DO 120 I = 1, 4
38167 U = C2*X(I)
38168 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
38169 120 CONTINUE
38170 S16 = 0D0
38171 DO 130 I = 5, 12
38172 U = C2*X(I)
38173 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
38174 130 CONTINUE
38175 S16 = C2*S16
38176 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
38177 H = H + S16
38178 IF(BB .NE. B) GOTO 100
38179 ELSE
38180 BB = C1
38181 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
38182 H = 0D0
38183 CALL PYERRM(18,'(PYGAUS:) too high accuracy required')
38184 GOTO 140
38185 ENDIF
38186 140 CONTINUE
38187 PYGAUS = H
38188
38189 RETURN
38190 END
38191
38192C*********************************************************************
38193
38194C...PYSIMP
38195C...Simpson formula for an integral.
38196
38197 FUNCTION PYSIMP(Y,X0,X1,N)
38198
38199C...Double precision and integer declarations.
38200 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38201 IMPLICIT INTEGER(I-N)
38202 INTEGER PYK,PYCHGE,PYCOMP
38203
38204C...Local variables.
38205 DOUBLE PRECISION Y,X0,X1,H,S
38206 DIMENSION Y(0:N)
38207
38208 S=0D0
38209 H=(X1-X0)/N
38210 DO 100 I=0,N-2,2
38211 S=S+Y(I)+4D0*Y(I+1)+Y(I+2)
38212 100 CONTINUE
38213 PYSIMP=S*H/3D0
38214
38215 RETURN
38216 END
38217
38218C*********************************************************************
38219
38220C...PYLAMF
38221C...The standard lambda function.
38222
38223 FUNCTION PYLAMF(X,Y,Z)
38224
38225C...Double precision and integer declarations.
38226 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38227 IMPLICIT INTEGER(I-N)
38228 INTEGER PYK,PYCHGE,PYCOMP
38229
38230C...Local variables.
38231 DOUBLE PRECISION PYLAMF,X,Y,Z
38232
38233 PYLAMF=(X-(Y+Z))**2-4D0*Y*Z
38234 IF(PYLAMF.LT.0D0) PYLAMF=0D0
38235
38236 RETURN
38237 END
38238
38239C*********************************************************************
38240
38241C...PYTBDY
38242C...Generates 3-body decays of gauginos.
38243
38244 SUBROUTINE PYTBDY(IDIN)
38245
38246C...Double precision and integer declarations.
38247 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38248 IMPLICIT INTEGER(I-N)
38249 INTEGER PYK,PYCHGE,PYCOMP
38250C...Parameter statement to help give large particle numbers.
38251 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
38252 &KEXCIT=4000000,KDIMEN=5000000)
38253C...Commonblocks.
38254 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
38255 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38256 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38257C COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
38258C COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38259 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
38260 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
38261C SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYSSMT/
38262 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSSMT/
38263
38264C...Local variables.
38265 DOUBLE PRECISION XM(5)
38266 COMPLEX*16 OLPP,ORPP,QLL,QLR,QRR,QRL,GLIJ,GRIJ,PROPZ
38267 COMPLEX*16 QLLS,QRRS,QLRS,QRLS,QLLU,QRRU,QLRT,QRLT
38268 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
38269 DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
38270 DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
38271 DOUBLE PRECISION CPHI1,SPHI1
38272 DOUBLE PRECISION S23DEL,EPS
38273 DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
38274 PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3)
38275 DOUBLE PRECISION F1,F2,X0,X1,X2,X3
38276 INTEGER INOID(4)
38277 DATA INOID/22,23,25,35/
38278 DATA EPS/1D-6/
38279
38280 ID=IDIN
38281 ISKIP=1
38282 XM(1)=P(N+1,5)
38283 XM(2)=P(N+2,5)
38284 XM(3)=P(N+3,5)
38285 XM(5)=P(ID,5)
38286
38287C...GENERATE S12
38288 S12MIN=(XM(1)+XM(2))**2
38289 S12MAX=(XM(5)-XM(3))**2
38290 YJACO1=S12MAX-S12MIN
38291
38292C...Initialize some parameters
38293 XW=PARU(102)
38294 XW1=1D0-XW
38295 TANW=SQRT(XW/XW1)
38296 IZID1=0
38297 IWID1=0
38298 IZID2=0
38299 IWID2=0
38300 DO 100 I1=1,4
38301 IF(MOD(K(N+1,2),KSUSY1).EQ.INOID(I1)) IZID1=I1
38302 IF(MOD(K(ID,2),KSUSY1).EQ.INOID(I1)) IZID2=I1
38303 100 CONTINUE
38304 IF(MOD(K(N+1,2),KSUSY1).EQ.24) IWID1=1
38305 IF(MOD(K(N+1,2),KSUSY1).EQ.37) IWID1=2
38306 IF(MOD(K(ID,2),KSUSY1).EQ.24) IWID2=1
38307 IF(MOD(K(ID,2),KSUSY1).EQ.37) IWID2=2
38308 IA=K(N+2,2)
38309 JA=K(N+3,2)
38310 ZM12=XM(5)**2
38311 ZM22=XM(1)**2
38312 EI=KCHG(IABS(IA),1)/3D0
38313 T3I=SIGN(1D0,EI+1D-6)/2D0
38314 IF(MAX(ABS(IA),ABS(JA)).EQ.6) THEN
38315 ISKIP=0
38316 ELSEIF(IZID1*IZID2.NE.0) THEN
38317 SQMZ=PMAS(23,1)**2
38318 GMMZ=PMAS(23,1)*PMAS(23,2)
38319 DO 110 I=1,4
38320 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
38321 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
38322 110 CONTINUE
38323 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
38324 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
38325 ORPP=DCONJG(OLPP)
38326 XLL2=PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
38327 XLR2=XLL2
38328 XRR2=PMAS(PYCOMP(KSUSY2+IABS(IA)),1)**2
38329 XRL2=XRR2
38330 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
38331 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
38332 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
38333 XM1M2=SMZ(IZID1)*SMZ(IZID2)
38334 QLLS=DCMPLX((T3I-EI*XW)/XW1)*OLPP
38335 QLLU=-GLIJ
38336 QLRS=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
38337 QLRT=DCONJG(GLIJ)
38338 QRLS=-DCMPLX((EI*XW)/XW1)*OLPP
38339 QRLT=GRIJ
38340 QRRS=DCMPLX((EI*XW)/XW1)*ORPP
38341 QRRU=-DCONJG(GRIJ)
38342 ELSEIF(IZID1*IWID2.NE.0.OR.IZID2*IWID1.NE.0) THEN
38343 IF(IZID1.NE.0) THEN
38344 XM1M2=SMZ(IZID1)*SMW(IWID2)
38345 IZID1=IWID2
38346 IZID2=IZID1
38347 ELSE
38348 XM1M2=SMZ(IZID2)*SMW(IWID1)
38349 IZID1=IWID1
38350 ENDIF
38351 RT2I = 1D0/SQRT(2D0)
38352 SQMZ=PMAS(24,1)**2
38353 GMMZ=PMAS(24,1)*PMAS(24,2)
38354 DO 120 I=1,2
38355 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
38356 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
38357 120 CONTINUE
38358 DO 130 I=1,4
38359 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
38360 130 CONTINUE
38361 QLLS=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
38362 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)
38363 QLRS=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
38364 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)
38365 EJ=KCHG(JA,1)/3D0
38366 T3J=SIGN(1D0,EJ+1D-6)/2D0
38367 QRLS=DCMPLX(0D0,0D0)
38368 QRLT=QRLS
38369 QRRS=QRLS
38370 QRRU=QRLS
38371 XRR2=1D6**2
38372 XRL2=XRR2
38373 XLR2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
38374 XLL2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
38375 IF(MOD(IA,2).EQ.0) THEN
38376 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
38377 & TANW+ZMIXC(IZID2,2)*T3I)
38378 QLRT=-DCONJG(UMIXC(IZID1,1))*(
38379 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
38380 ELSE
38381 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
38382 & TANW+ZMIXC(IZID2,2)*T3J)
38383 QLRT=-DCONJG(UMIXC(IZID1,1))*(
38384 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
38385 ENDIF
38386 ELSEIF(IWID1*IWID2.NE.0) THEN
38387 IZID1=IWID1
38388 IZID2=IWID2
38389 XM1M2=SMW(IWID1)*SMW(IWID2)
38390 SQMZ=PMAS(23,1)**2
38391 GMMZ=PMAS(23,1)*PMAS(23,2)
38392 DO 140 I=1,2
38393 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
38394 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
38395 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
38396 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
38397 140 CONTINUE
38398 OLPP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
38399 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0
38400 ORPP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
38401 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0
38402 QRLS=-DCMPLX(EI/XW1)*ORPP
38403 QLLS=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
38404 QRRS=-DCMPLX(EI/XW1)*OLPP
38405 QLRS=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
38406 IF(MOD(IA,2).EQ.0) THEN
38407 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)-1),1)**2
38408 QLRT=-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*DCMPLX(T3I/XW)
38409 ELSE
38410 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)+1),1)**2
38411 QLRT=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*DCMPLX(T3I/XW)
38412 ENDIF
38413 ELSEIF(MOD(K(N+1,2),KSUSY1).EQ.21.OR.MOD(K(ID,2),KSUSY1).EQ.21)
38414 &THEN
38415 ISKIP=0
38416 ELSE
38417 ISKIP=0
38418 ENDIF
38419
38420 IF(ISKIP.NE.0) THEN
38421 WTMAX=0D0
38422 DO 160 KT=1,100
38423 S12=S12MIN+YJACO1*(KT-1)/99
38424 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
38425 & *(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
38426 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
38427 & -(2D0*XM(1)*XM(2))**2
38428 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
38429 & -(2D0*XM(3)*XM(5))**2
38430 S23DF1=S23DF1*EPS
38431 S23DF2=S23DF2*EPS
38432 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
38433 S23DEL=S23DEL/EPS
38434 S23MIN=S23AVE-S23DEL
38435 S23MAX=S23AVE+S23DEL
38436 YJACO2=S23MAX-S23MIN
38437 TH=S12
38438 DO 150 KS=1,100
38439 S23=S23MIN+YJACO2*(KS-1)/99
38440 SH=S23
38441 UH=ZM12+ZM22-SH-TH
38442 WU2 = (UH-ZM12)*(UH-ZM22)
38443 WT2 = (TH-ZM12)*(TH-ZM22)
38444 WS2 = XM1M2*SH
38445 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
38446 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
38447 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
38448 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
38449 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
38450 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
38451 WT0=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
38452 & (ABS(QRL)**2+ABS(QLR)**2)*WT2+
38453 & 2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
38454 IF(WT0.GT.WTMAX) WTMAX=WT0
38455 150 CONTINUE
38456 160 CONTINUE
38457
38458 WTMAX=WTMAX*1.05D0
38459 ENDIF
38460
38461C...FIND S12*
38462 AX=S12MIN
38463 CX=S12MAX
38464 BX=S12MIN+0.5D0*YJACO1
38465 X0=AX
38466 X3=CX
38467 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
38468 X1=BX
38469 X2=BX+C*(CX-BX)
38470 ELSE
38471 X2=BX
38472 X1=BX-C*(BX-AX)
38473 ENDIF
38474
38475C...SOLVE FOR F1 AND F2
38476 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
38477 &-(2D0*XM(1)*XM(2))**2
38478 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
38479 &-(2D0*XM(3)*XM(5))**2
38480 S23DF1=S23DF1*EPS
38481 S23DF2=S23DF2*EPS
38482 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
38483 F1=-2D0*S23DEL/EPS
38484 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
38485 &-(2D0*XM(1)*XM(2))**2
38486 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
38487 &-(2D0*XM(3)*XM(5))**2
38488 S23DF1=S23DF1*EPS
38489 S23DF2=S23DF2*EPS
38490 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
38491 F2=-2D0*S23DEL/EPS
38492
38493 170 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
38494C...Possibility of infinite loop with .LT.; changed to .LE. (SKANDS)
38495 IF(F2.LE.F1)THEN
38496 X0=X1
38497 X1=X2
38498 X2=R*X1+C*X3
38499 F1=F2
38500 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
38501 & -(2D0*XM(1)*XM(2))**2
38502 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
38503 & -(2D0*XM(3)*XM(5))**2
38504 S23DF1=S23DF1*EPS
38505 S23DF2=S23DF2*EPS
38506 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
38507 F2=-2D0*S23DEL/EPS
38508 ELSE
38509 X3=X2
38510 X2=X1
38511 X1=R*X2+C*X0
38512 F2=F1
38513 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
38514 & -(2D0*XM(1)*XM(2))**2
38515 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
38516 & -(2D0*XM(3)*XM(5))**2
38517 S23DF1=S23DF1*EPS
38518 S23DF2=S23DF2*EPS
38519 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
38520 F1=-2D0*S23DEL/EPS
38521 ENDIF
38522 GOTO 170
38523 ENDIF
38524C...WE WANT THE MAXIMUM, NOT THE MINIMUM
38525 IF(F1.LT.F2)THEN
38526 GOLDEN=-F1
38527 XMIN=X1
38528 ELSE
38529 GOLDEN=-F2
38530 XMIN=X2
38531 ENDIF
38532
38533 IKNT=0
38534 180 S12=S12MIN+PYR(0)*YJACO1
38535 IKNT=IKNT+1
38536C...GENERATE S23
38537 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
38538 &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
38539 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
38540 &-(2D0*XM(1)*XM(2))**2
38541 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
38542 &-(2D0*XM(3)*XM(5))**2
38543 S23DF1=S23DF1*EPS
38544 S23DF2=S23DF2*EPS
38545 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
38546 S23DEL=S23DEL/EPS
38547 S23MIN=S23AVE-S23DEL
38548 S23MAX=S23AVE+S23DEL
38549 YJACO2=S23MAX-S23MIN
38550 S23=S23MIN+PYR(0)*YJACO2
38551
38552C...CHECK THE SAMPLING
38553 IF(IKNT.GT.100) THEN
38554 WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY '
38555 GOTO 190
38556 ENDIF
38557 IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 180
38558
38559 IF(ISKIP.EQ.0) GOTO 190
38560
38561 SH=S23
38562 TH=S12
38563 UH=ZM12+ZM22-SH-TH
38564
38565 WU2 = (UH-ZM12)*(UH-ZM22)
38566 WT2 = (TH-ZM12)*(TH-ZM22)
38567 WS2 = XM1M2*SH
38568 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
38569 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
38570
38571 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
38572 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
38573 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
38574 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
38575c QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
38576c QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
38577c &/DCMPLX(TH-XML2)
38578c QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
38579c QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
38580c &-DCONJG(GRIJ)/DCMPLX(UH-XMR2)
38581 WT=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
38582 &(ABS(QRL)**2+ABS(QLR)**2)*WT2+
38583 &2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
38584
38585 IF(WT.LT.PYR(0)*WTMAX) GOTO 180
38586 IF(WT.GT.WTMAX) PRINT*,' WT > WTMAX ',WT,WTMAX
38587
38588 190 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5))
38589 D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5))
38590 D2=XM(5)-D1-D3
38591 P1=SQRT(D1*D1-XM(1)**2)
38592 P2=SQRT(D2*D2-XM(2)**2)
38593 P3=SQRT(D3*D3-XM(3)**2)
38594 CTHE1=2D0*PYR(0)-1D0
38595 ANG1=2D0*PYR(0)*PARU(1)
38596 CPHI1=COS(ANG1)
38597 SPHI1=SIN(ANG1)
38598 ARG=1D0-CTHE1**2
38599 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
38600 STHE1=SQRT(ARG)
38601 P(N+1,1)=P1*STHE1*CPHI1
38602 P(N+1,2)=P1*STHE1*SPHI1
38603 P(N+1,3)=P1*CTHE1
38604 P(N+1,4)=D1
38605
38606C...GET CPHI3
38607 ANG3=2D0*PYR(0)*PARU(1)
38608 CPHI3=COS(ANG3)
38609 SPHI3=SIN(ANG3)
38610 CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3
38611 ARG=1D0-CTHE3**2
38612 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
38613 STHE3=SQRT(ARG)
38614 P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1
38615 &+P3*STHE3*SPHI3*SPHI1
38616 &+P3*CTHE3*STHE1*CPHI1
38617 P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1
38618 &-P3*STHE3*SPHI3*CPHI1
38619 &+P3*CTHE3*STHE1*SPHI1
38620 P(N+3,3)=P3*STHE3*CPHI3*STHE1
38621 &+P3*CTHE3*CTHE1
38622 P(N+3,4)=D3
38623
38624 DO 200 I=1,3
38625 P(N+2,I)=-P(N+1,I)-P(N+3,I)
38626 200 CONTINUE
38627 P(N+2,4)=D2
38628
38629 RETURN
38630 END
38631
38632C*********************************************************************
38633
38634C...PYTECM
38635C...Finds the s-hat dependent eigenvalues of the inverse propagator
38636C...matrix for gamma, Z, techni-rho, and techni-omega to optimize the
38637C...phase space generation.
38638
38639 SUBROUTINE PYTECM(S1,S2)
38640
38641C...Double precision and integer declarations.
38642 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38643 IMPLICIT INTEGER(I-N)
38644 INTEGER PYK,PYCHGE,PYCOMP
38645C...Parameter statement to help give large particle numbers.
38646 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
38647 &KEXCIT=4000000,KDIMEN=5000000)
38648C...Commonblocks.
38649 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38650 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38651 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38652 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/
38653
38654C...Local variables.
38655 DOUBLE PRECISION AR(4,4),WR(4),ZR(4,4),ZI(4,4),WORK(12,12),
38656 &AT(4,4),WI(4),FV1(4),FV2(4),FV3(4),sh,aem,tanw,ct2w,qupd,alprht,
38657 &far,fao,fzr,fzo,shr,R1,R2,S1,S2,WDTP(0:300),WDTE(0:300,0:5)
38658 INTEGER i,j,ierr
38659
38660 SH=PMAS(PYCOMP(KTECHN+113),1)**2
38661 AEM=PYALEM(SH)
38662
38663 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
38664 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
38665 QUPD=2D0*PARP(143)-1D0
38666
38667 ALPRHT=2.91D0*(3D0/PARP(144))
38668 FAR=SQRT(AEM/ALPRHT)
38669 FAO=FAR*QUPD
38670 FZR=FAR*CT2W
38671 FZO=-FAO*TANW
38672
38673 AR(1,1) = SH
38674 AR(2,2) = SH-PMAS(23,1)**2
38675 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+113),1)**2
38676 AR(4,4) = SH-PMAS(PYCOMP(KTECHN+223),1)**2
38677 AR(1,2) = 0D0
38678 AR(2,1) = 0D0
38679 AR(1,3) = -SH*FAR
38680 AR(3,1) = AR(1,3)
38681 AR(1,4) = -SH*FAO
38682 AR(4,1) = AR(1,4)
38683 AR(2,3) = -SH*FZR
38684 AR(3,2) = AR(2,3)
38685 AR(2,4) = -SH*FZO
38686 AR(4,2) = AR(2,4)
38687 AR(3,4) = 0D0
38688 AR(4,3) = 0D0
38689CCCCCCCC
38690 DO 110 I=1,4
38691 DO 100 J=1,4
38692 AT(I,J)=0D0
38693 100 CONTINUE
38694 110 CONTINUE
38695 SHR=SQRT(SH)
38696 CALL PYWIDT(23,SH,WDTP,WDTE)
38697 AT(2,2) = WDTP(0)*SHR
38698 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
38699 AT(3,3) = WDTP(0)*SHR
38700 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
38701 AT(4,4) = WDTP(0)*SHR
38702CCCC
38703 CALL PYEICG(4,4,AR,AT,WR,WI,0,ZR,ZI,FV1,FV2,FV3,IERR)
38704 DO 120 I=1,4
38705 WI(I)=SQRT(ABS(SH-WR(I)))
38706 WR(I)=ABS(WR(I))
38707 120 CONTINUE
38708 R1=MIN(WR(1),WR(2),WR(3),WR(4))
38709 R2=1D20
38710 S1=0D0
38711 S2=0D0
38712 DO 130 I=1,4
38713 IF(ABS(WR(I)-R1).LT.1D-6) THEN
38714 S1=WI(I)
38715 GOTO 130
38716 ENDIF
38717 IF(WR(I).LE.R2) THEN
38718 R2=WR(I)
38719 S2=WI(I)
38720 ENDIF
38721 130 CONTINUE
38722 S1=S1**2
38723 S2=S2**2
38724 RETURN
38725 END
38726
38727C*********************************************************************
38728
38729C...PYEIGC
38730C...Finds eigenvalues of a general complex matrix
38731C
38732C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
38733C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
38734C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
38735C OF A COMPLEX GENERAL MATRIX.
38736C
38737C ON INPUT
38738C
38739C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
38740C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
38741C DIMENSION STATEMENT.
38742C
38743C N IS THE ORDER OF THE MATRIX A=(AR,AI).
38744C
38745C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
38746C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
38747C
38748C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
38749C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
38750C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
38751C
38752C ON OUTPUT
38753C
38754C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
38755C RESPECTIVELY, OF THE EIGENVALUES.
38756C
38757C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
38758C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
38759C
38760C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
38761C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
38762C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO.
38763C
38764C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS.
38765C
38766C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
38767C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
38768C
38769C THIS VERSION DATED AUGUST 1983.
38770C
38771
38772 SUBROUTINE PYEICG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
38773
38774 INTEGER N,NM,IS1,IS2,IERR,MATZ
38775 DOUBLE PRECISION AR(4,4),AI(4,4),WR(4),WI(4),ZR(4,4),ZI(4,4),
38776 X FV1(4),FV2(4),FV3(4)
38777 IF (N .LE. NM) GOTO 100
38778 IERR = 10 * N
38779 GOTO 120
38780C
38781 100 CALL PYCBAL(NM,N,AR,AI,IS1,IS2,FV1)
38782 CALL PYCRTH(NM,N,IS1,IS2,AR,AI,FV2,FV3)
38783 IF (MATZ .NE. 0) GOTO 110
38784C .......... FIND EIGENVALUES ONLY ..........
38785 CALL PYCMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR)
38786 GOTO 120
38787C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
38788 110 CALL PYCMQ2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR)
38789 IF (IERR .NE. 0) GOTO 120
38790 CALL PYCBA2(NM,N,IS1,IS2,FV1,N,ZR,ZI)
38791 120 RETURN
38792 END
38793
38794C*********************************************************************
38795
38796C...PYCMQR
38797C...Auxiliary to PYEICG.
38798C
38799C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
38800C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
38801C AND WILKINSON.
38802C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
38803C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
38804C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
38805C
38806C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
38807C UPPER HESSENBERG MATRIX BY THE QR METHOD.
38808C
38809C ON INPUT
38810C
38811C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
38812C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
38813C DIMENSION STATEMENT.
38814C
38815C N IS THE ORDER OF THE MATRIX.
38816C
38817C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
38818C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
38819C SET LOW=1, IGH=N.
38820C
38821C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
38822C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
38823C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
38824C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
38825C THE REDUCTION BY CORTH, IF PERFORMED.
38826C
38827C ON OUTPUT
38828C
38829C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
38830C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE
38831C CALLING COMQR IF SUBSEQUENT CALCULATION OF
38832C EIGENVECTORS IS TO BE PERFORMED.
38833C
38834C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
38835C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
38836C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
38837C FOR INDICES IERR+1,...,N.
38838C
38839C IERR IS SET TO
38840C ZERO FOR NORMAL RETURN,
38841C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
38842C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
38843C
38844C CALLS PYCDIV FOR COMPLEX DIVISION.
38845C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
38846C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
38847C
38848C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
38849C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
38850C
38851C THIS VERSION DATED AUGUST 1983.
38852C
38853
38854 SUBROUTINE PYCMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
38855
38856 INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
38857 DOUBLE PRECISION HR(4,4),HI(4,4),WR(4),WI(4)
38858 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
38859 X PYTHAG
38860
38861 IERR = 0
38862 IF (LOW .EQ. IGH) GOTO 130
38863C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
38864 L = LOW + 1
38865C
38866 DO 120 I = L, IGH
38867 LL = MIN0(I+1,IGH)
38868 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 120
38869 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
38870 YR = HR(I,I-1) / NORM
38871 YI = HI(I,I-1) / NORM
38872 HR(I,I-1) = NORM
38873 HI(I,I-1) = 0.0D0
38874C
38875 DO 100 J = I, IGH
38876 SI = YR * HI(I,J) - YI * HR(I,J)
38877 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
38878 HI(I,J) = SI
38879 100 CONTINUE
38880C
38881 DO 110 J = LOW, LL
38882 SI = YR * HI(J,I) + YI * HR(J,I)
38883 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
38884 HI(J,I) = SI
38885 110 CONTINUE
38886C
38887 120 CONTINUE
38888C .......... STORE ROOTS ISOLATED BY CBAL ..........
38889 130 DO 140 I = 1, N
38890 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
38891 WR(I) = HR(I,I)
38892 WI(I) = HI(I,I)
38893 140 CONTINUE
38894C
38895 EN = IGH
38896 TR = 0.0D0
38897 TI = 0.0D0
38898 ITN = 30*N
38899C .......... SEARCH FOR NEXT EIGENVALUE ..........
38900 150 IF (EN .LT. LOW) GOTO 320
38901 ITS = 0
38902 ENM1 = EN - 1
38903C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
38904C FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
38905 160 DO 170 LL = LOW, EN
38906 L = EN + LOW - LL
38907 IF (L .EQ. LOW) GOTO 180
38908 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
38909 X + DABS(HR(L,L)) + DABS(HI(L,L))
38910 TST2 = TST1 + DABS(HR(L,L-1))
38911 IF (TST2 .EQ. TST1) GOTO 180
38912 170 CONTINUE
38913C .......... FORM SHIFT ..........
38914 180 IF (L .EQ. EN) GOTO 300
38915 IF (ITN .EQ. 0) GOTO 310
38916 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 200
38917 SR = HR(EN,EN)
38918 SI = HI(EN,EN)
38919 XR = HR(ENM1,EN) * HR(EN,ENM1)
38920 XI = HI(ENM1,EN) * HR(EN,ENM1)
38921 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 210
38922 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
38923 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
38924 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
38925 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 190
38926 ZZR = -ZZR
38927 ZZI = -ZZI
38928 190 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
38929 SR = SR - XR
38930 SI = SI - XI
38931 GOTO 210
38932C .......... FORM EXCEPTIONAL SHIFT ..........
38933 200 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
38934 SI = 0.0D0
38935C
38936 210 DO 220 I = LOW, EN
38937 HR(I,I) = HR(I,I) - SR
38938 HI(I,I) = HI(I,I) - SI
38939 220 CONTINUE
38940C
38941 TR = TR + SR
38942 TI = TI + SI
38943 ITS = ITS + 1
38944 ITN = ITN - 1
38945C .......... REDUCE TO TRIANGLE (ROWS) ..........
38946 LP1 = L + 1
38947C
38948 DO 240 I = LP1, EN
38949 SR = HR(I,I-1)
38950 HR(I,I-1) = 0.0D0
38951 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
38952 XR = HR(I-1,I-1) / NORM
38953 WR(I-1) = XR
38954 XI = HI(I-1,I-1) / NORM
38955 WI(I-1) = XI
38956 HR(I-1,I-1) = NORM
38957 HI(I-1,I-1) = 0.0D0
38958 HI(I,I-1) = SR / NORM
38959C
38960 DO 230 J = I, EN
38961 YR = HR(I-1,J)
38962 YI = HI(I-1,J)
38963 ZZR = HR(I,J)
38964 ZZI = HI(I,J)
38965 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
38966 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
38967 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
38968 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
38969 230 CONTINUE
38970C
38971 240 CONTINUE
38972C
38973 SI = HI(EN,EN)
38974 IF (SI .EQ. 0.0D0) GOTO 250
38975 NORM = PYTHAG(HR(EN,EN),SI)
38976 SR = HR(EN,EN) / NORM
38977 SI = SI / NORM
38978 HR(EN,EN) = NORM
38979 HI(EN,EN) = 0.0D0
38980C .......... INVERSE OPERATION (COLUMNS) ..........
38981 250 DO 280 J = LP1, EN
38982 XR = WR(J-1)
38983 XI = WI(J-1)
38984C
38985 DO 270 I = L, J
38986 YR = HR(I,J-1)
38987 YI = 0.0D0
38988 ZZR = HR(I,J)
38989 ZZI = HI(I,J)
38990 IF (I .EQ. J) GOTO 260
38991 YI = HI(I,J-1)
38992 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
38993 260 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
38994 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
38995 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
38996 270 CONTINUE
38997C
38998 280 CONTINUE
38999C
39000 IF (SI .EQ. 0.0D0) GOTO 160
39001C
39002 DO 290 I = L, EN
39003 YR = HR(I,EN)
39004 YI = HI(I,EN)
39005 HR(I,EN) = SR * YR - SI * YI
39006 HI(I,EN) = SR * YI + SI * YR
39007 290 CONTINUE
39008C
39009 GOTO 160
39010C .......... A ROOT FOUND ..........
39011 300 WR(EN) = HR(EN,EN) + TR
39012 WI(EN) = HI(EN,EN) + TI
39013 EN = ENM1
39014 GOTO 150
39015C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
39016C CONVERGED AFTER 30*N ITERATIONS ..........
39017 310 IERR = EN
39018 320 RETURN
39019 END
39020
39021C*********************************************************************
39022
39023C...PYCMQ2
39024C...Auxiliary to PYEICG.
39025C
39026C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
39027C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
39028C AND WILKINSON.
39029C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
39030C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
39031C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
39032C
39033C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
39034C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
39035C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
39036C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE
39037C THIS GENERAL MATRIX TO HESSENBERG FORM.
39038C
39039C ON INPUT
39040C
39041C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
39042C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
39043C DIMENSION STATEMENT.
39044C
39045C N IS THE ORDER OF THE MATRIX.
39046C
39047C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
39048C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
39049C SET LOW=1, IGH=N.
39050C
39051C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
39052C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED.
39053C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS
39054C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
39055C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
39056C
39057C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
39058C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
39059C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
39060C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
39061C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF
39062C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
39063C ARBITRARY.
39064C
39065C ON OUTPUT
39066C
39067C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
39068C HAVE BEEN DESTROYED.
39069C
39070C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
39071C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
39072C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
39073C FOR INDICES IERR+1,...,N.
39074C
39075C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
39076C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS
39077C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF
39078C THE EIGENVECTORS HAS BEEN FOUND.
39079C
39080C IERR IS SET TO
39081C ZERO FOR NORMAL RETURN,
39082C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
39083C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
39084C
39085C CALLS PYCDIV FOR COMPLEX DIVISION.
39086C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
39087C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
39088C
39089C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
39090C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
39091C
39092C THIS VERSION DATED OCTOBER 1989.
39093C
39094C MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG)
39095C MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG)
39096C
39097
39098 SUBROUTINE PYCMQ2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
39099
39100 INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
39101 X ITN,ITS,LOW,LP1,ENM1,IEND,IERR
39102 DOUBLE PRECISION HR(4,4),HI(4,4),WR(4),WI(4),ZR(4,4),ZI(4,4),
39103 X ORTR(4),ORTI(4)
39104 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
39105 X PYTHAG
39106
39107 IERR = 0
39108C .......... INITIALIZE EIGENVECTOR MATRIX ..........
39109 DO 110 J = 1, N
39110C
39111 DO 100 I = 1, N
39112 ZR(I,J) = 0.0D0
39113 ZI(I,J) = 0.0D0
39114 100 CONTINUE
39115 ZR(J,J) = 1.0D0
39116 110 CONTINUE
39117C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
39118C FROM THE INFORMATION LEFT BY CORTH ..........
39119 IEND = IGH - LOW - 1
39120 IF (IEND.LT.0) GOTO 220
39121 IF (IEND.EQ.0) GOTO 170
39122C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
39123 DO 160 II = 1, IEND
39124 I = IGH - II
39125 IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GOTO 160
39126 IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GOTO 160
39127C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
39128 NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I)
39129 IP1 = I + 1
39130C
39131 DO 120 K = IP1, IGH
39132 ORTR(K) = HR(K,I-1)
39133 ORTI(K) = HI(K,I-1)
39134 120 CONTINUE
39135C
39136 DO 150 J = I, IGH
39137 SR = 0.0D0
39138 SI = 0.0D0
39139C
39140 DO 130 K = I, IGH
39141 SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J)
39142 SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J)
39143 130 CONTINUE
39144C
39145 SR = SR / NORM
39146 SI = SI / NORM
39147C
39148 DO 140 K = I, IGH
39149 ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K)
39150 ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K)
39151 140 CONTINUE
39152C
39153 150 CONTINUE
39154C
39155 160 CONTINUE
39156C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
39157 170 L = LOW + 1
39158C
39159 DO 210 I = L, IGH
39160 LL = MIN0(I+1,IGH)
39161 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 210
39162 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
39163 YR = HR(I,I-1) / NORM
39164 YI = HI(I,I-1) / NORM
39165 HR(I,I-1) = NORM
39166 HI(I,I-1) = 0.0D0
39167C
39168 DO 180 J = I, N
39169 SI = YR * HI(I,J) - YI * HR(I,J)
39170 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
39171 HI(I,J) = SI
39172 180 CONTINUE
39173C
39174 DO 190 J = 1, LL
39175 SI = YR * HI(J,I) + YI * HR(J,I)
39176 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
39177 HI(J,I) = SI
39178 190 CONTINUE
39179C
39180 DO 200 J = LOW, IGH
39181 SI = YR * ZI(J,I) + YI * ZR(J,I)
39182 ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I)
39183 ZI(J,I) = SI
39184 200 CONTINUE
39185C
39186 210 CONTINUE
39187C .......... STORE ROOTS ISOLATED BY CBAL ..........
39188 220 DO 230 I = 1, N
39189 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 230
39190 WR(I) = HR(I,I)
39191 WI(I) = HI(I,I)
39192 230 CONTINUE
39193C
39194 EN = IGH
39195 TR = 0.0D0
39196 TI = 0.0D0
39197 ITN = 30*N
39198C .......... SEARCH FOR NEXT EIGENVALUE ..........
39199 240 IF (EN .LT. LOW) GOTO 430
39200 ITS = 0
39201 ENM1 = EN - 1
39202C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
39203C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
39204 250 DO 260 LL = LOW, EN
39205 L = EN + LOW - LL
39206 IF (L .EQ. LOW) GOTO 270
39207 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
39208 X + DABS(HR(L,L)) + DABS(HI(L,L))
39209 TST2 = TST1 + DABS(HR(L,L-1))
39210 IF (TST2 .EQ. TST1) GOTO 270
39211 260 CONTINUE
39212C .......... FORM SHIFT ..........
39213 270 IF (L .EQ. EN) GOTO 420
39214 IF (ITN .EQ. 0) GOTO 550
39215 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 290
39216 SR = HR(EN,EN)
39217 SI = HI(EN,EN)
39218 XR = HR(ENM1,EN) * HR(EN,ENM1)
39219 XI = HI(ENM1,EN) * HR(EN,ENM1)
39220 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 300
39221 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
39222 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
39223 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
39224 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 280
39225 ZZR = -ZZR
39226 ZZI = -ZZI
39227 280 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
39228 SR = SR - XR
39229 SI = SI - XI
39230 GOTO 300
39231C .......... FORM EXCEPTIONAL SHIFT ..........
39232 290 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
39233 SI = 0.0D0
39234C
39235 300 DO 310 I = LOW, EN
39236 HR(I,I) = HR(I,I) - SR
39237 HI(I,I) = HI(I,I) - SI
39238 310 CONTINUE
39239C
39240 TR = TR + SR
39241 TI = TI + SI
39242 ITS = ITS + 1
39243 ITN = ITN - 1
39244C .......... REDUCE TO TRIANGLE (ROWS) ..........
39245 LP1 = L + 1
39246C
39247 DO 330 I = LP1, EN
39248 SR = HR(I,I-1)
39249 HR(I,I-1) = 0.0D0
39250 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
39251 XR = HR(I-1,I-1) / NORM
39252 WR(I-1) = XR
39253 XI = HI(I-1,I-1) / NORM
39254 WI(I-1) = XI
39255 HR(I-1,I-1) = NORM
39256 HI(I-1,I-1) = 0.0D0
39257 HI(I,I-1) = SR / NORM
39258C
39259 DO 320 J = I, N
39260 YR = HR(I-1,J)
39261 YI = HI(I-1,J)
39262 ZZR = HR(I,J)
39263 ZZI = HI(I,J)
39264 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
39265 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
39266 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
39267 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
39268 320 CONTINUE
39269C
39270 330 CONTINUE
39271C
39272 SI = HI(EN,EN)
39273 IF (SI .EQ. 0.0D0) GOTO 350
39274 NORM = PYTHAG(HR(EN,EN),SI)
39275 SR = HR(EN,EN) / NORM
39276 SI = SI / NORM
39277 HR(EN,EN) = NORM
39278 HI(EN,EN) = 0.0D0
39279 IF (EN .EQ. N) GOTO 350
39280 IP1 = EN + 1
39281C
39282 DO 340 J = IP1, N
39283 YR = HR(EN,J)
39284 YI = HI(EN,J)
39285 HR(EN,J) = SR * YR + SI * YI
39286 HI(EN,J) = SR * YI - SI * YR
39287 340 CONTINUE
39288C .......... INVERSE OPERATION (COLUMNS) ..........
39289 350 DO 390 J = LP1, EN
39290 XR = WR(J-1)
39291 XI = WI(J-1)
39292C
39293 DO 370 I = 1, J
39294 YR = HR(I,J-1)
39295 YI = 0.0D0
39296 ZZR = HR(I,J)
39297 ZZI = HI(I,J)
39298 IF (I .EQ. J) GOTO 360
39299 YI = HI(I,J-1)
39300 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
39301 360 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
39302 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
39303 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
39304 370 CONTINUE
39305C
39306 DO 380 I = LOW, IGH
39307 YR = ZR(I,J-1)
39308 YI = ZI(I,J-1)
39309 ZZR = ZR(I,J)
39310 ZZI = ZI(I,J)
39311 ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
39312 ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
39313 ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
39314 ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
39315 380 CONTINUE
39316C
39317 390 CONTINUE
39318C
39319 IF (SI .EQ. 0.0D0) GOTO 250
39320C
39321 DO 400 I = 1, EN
39322 YR = HR(I,EN)
39323 YI = HI(I,EN)
39324 HR(I,EN) = SR * YR - SI * YI
39325 HI(I,EN) = SR * YI + SI * YR
39326 400 CONTINUE
39327C
39328 DO 410 I = LOW, IGH
39329 YR = ZR(I,EN)
39330 YI = ZI(I,EN)
39331 ZR(I,EN) = SR * YR - SI * YI
39332 ZI(I,EN) = SR * YI + SI * YR
39333 410 CONTINUE
39334C
39335 GOTO 250
39336C .......... A ROOT FOUND ..........
39337 420 HR(EN,EN) = HR(EN,EN) + TR
39338 WR(EN) = HR(EN,EN)
39339 HI(EN,EN) = HI(EN,EN) + TI
39340 WI(EN) = HI(EN,EN)
39341 EN = ENM1
39342 GOTO 240
39343C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
39344C VECTORS OF UPPER TRIANGULAR FORM ..........
39345 430 NORM = 0.0D0
39346C
39347 DO 440 I = 1, N
39348C
39349 DO 440 J = I, N
39350 TR = DABS(HR(I,J)) + DABS(HI(I,J))
39351 IF (TR .GT. NORM) NORM = TR
39352 440 CONTINUE
39353C
39354 IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GOTO 560
39355C .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
39356 DO 500 NN = 2, N
39357 EN = N + 2 - NN
39358 XR = WR(EN)
39359 XI = WI(EN)
39360 HR(EN,EN) = 1.0D0
39361 HI(EN,EN) = 0.0D0
39362 ENM1 = EN - 1
39363C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
39364 DO 490 II = 1, ENM1
39365 I = EN - II
39366 ZZR = 0.0D0
39367 ZZI = 0.0D0
39368 IP1 = I + 1
39369C
39370 DO 450 J = IP1, EN
39371 ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
39372 ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
39373 450 CONTINUE
39374C
39375 YR = XR - WR(I)
39376 YI = XI - WI(I)
39377 IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GOTO 470
39378 TST1 = NORM
39379 YR = TST1
39380 460 YR = 0.01D0 * YR
39381 TST2 = NORM + YR
39382 IF (TST2 .GT. TST1) GOTO 460
39383 470 CONTINUE
39384 CALL PYCDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
39385C .......... OVERFLOW CONTROL ..........
39386 TR = DABS(HR(I,EN)) + DABS(HI(I,EN))
39387 IF (TR .EQ. 0.0D0) GOTO 490
39388 TST1 = TR
39389 TST2 = TST1 + 1.0D0/TST1
39390 IF (TST2 .GT. TST1) GOTO 490
39391 DO 480 J = I, EN
39392 HR(J,EN) = HR(J,EN)/TR
39393 HI(J,EN) = HI(J,EN)/TR
39394 480 CONTINUE
39395C
39396 490 CONTINUE
39397C
39398 500 CONTINUE
39399C .......... END BACKSUBSTITUTION ..........
39400C .......... VECTORS OF ISOLATED ROOTS ..........
39401 DO 520 I = 1, N
39402 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 520
39403C
39404 DO 510 J = I, N
39405 ZR(I,J) = HR(I,J)
39406 ZI(I,J) = HI(I,J)
39407 510 CONTINUE
39408C
39409 520 CONTINUE
39410C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
39411C VECTORS OF ORIGINAL FULL MATRIX.
39412C FOR J=N STEP -1 UNTIL LOW DO -- ..........
39413 DO 540 JJ = LOW, N
39414 J = N + LOW - JJ
39415 M = MIN0(J,IGH)
39416C
39417 DO 540 I = LOW, IGH
39418 ZZR = 0.0D0
39419 ZZI = 0.0D0
39420C
39421 DO 530 K = LOW, M
39422 ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
39423 ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
39424 530 CONTINUE
39425C
39426 ZR(I,J) = ZZR
39427 ZI(I,J) = ZZI
39428 540 CONTINUE
39429C
39430 GOTO 560
39431C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
39432C CONVERGED AFTER 30*N ITERATIONS ..........
39433 550 IERR = EN
39434 560 RETURN
39435 END
39436
39437C*********************************************************************
39438
39439C...PYCDIV
39440C...Auxiliary to PYCMQR
39441C
39442C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
39443C
39444
39445 SUBROUTINE PYCDIV(AR,AI,BR,BI,CR,CI)
39446
39447 DOUBLE PRECISION AR,AI,BR,BI,CR,CI
39448 DOUBLE PRECISION S,ARS,AIS,BRS,BIS
39449
39450 S = DABS(BR) + DABS(BI)
39451 ARS = AR/S
39452 AIS = AI/S
39453 BRS = BR/S
39454 BIS = BI/S
39455 S = BRS**2 + BIS**2
39456 CR = (ARS*BRS + AIS*BIS)/S
39457 CI = (AIS*BRS - ARS*BIS)/S
39458 RETURN
39459 END
39460
39461C*********************************************************************
39462
39463C...PYCSRT
39464C...Auxiliary to PYCMQR
39465C
39466C (YR,YI) = COMPLEX DSQRT(XR,XI)
39467C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
39468C
39469
39470 SUBROUTINE PYCSRT(XR,XI,YR,YI)
39471
39472 DOUBLE PRECISION XR,XI,YR,YI
39473 DOUBLE PRECISION S,TR,TI,PYTHAG
39474
39475 TR = XR
39476 TI = XI
39477 S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR)))
39478 IF (TR .GE. 0.0D0) YR = S
39479 IF (TI .LT. 0.0D0) S = -S
39480 IF (TR .LE. 0.0D0) YI = S
39481 IF (TR .LT. 0.0D0) YR = 0.5D0*(TI/YI)
39482 IF (TR .GT. 0.0D0) YI = 0.5D0*(TI/YR)
39483 RETURN
39484 END
39485
39486 DOUBLE PRECISION FUNCTION PYTHAG(A,B)
39487 DOUBLE PRECISION A,B
39488C
39489C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
39490C
39491 DOUBLE PRECISION P,R,S,T,U
39492 P = DMAX1(DABS(A),DABS(B))
39493 IF (P .EQ. 0.0D0) GOTO 110
39494 R = (DMIN1(DABS(A),DABS(B))/P)**2
39495 100 CONTINUE
39496 T = 4.0D0 + R
39497 IF (T .EQ. 4.0D0) GOTO 110
39498 S = R/T
39499 U = 1.0D0 + 2.0D0*S
39500 P = U*P
39501 R = (S/U)**2 * R
39502 GOTO 100
39503 110 PYTHAG = P
39504 RETURN
39505 END
39506
39507C*********************************************************************
39508
39509C...PYCBAL
39510C...Auxiliary to PYEICG
39511C
39512C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
39513C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
39514C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
39515C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
39516C
39517C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
39518C EIGENVALUES WHENEVER POSSIBLE.
39519C
39520C ON INPUT
39521C
39522C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
39523C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
39524C DIMENSION STATEMENT.
39525C
39526C N IS THE ORDER OF THE MATRIX.
39527C
39528C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
39529C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
39530C
39531C ON OUTPUT
39532C
39533C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
39534C RESPECTIVELY, OF THE BALANCED MATRIX.
39535C
39536C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
39537C ARE EQUAL TO ZERO IF
39538C (1) I IS GREATER THAN J AND
39539C (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
39540C
39541C SCALE CONTAINS INFORMATION DETERMINING THE
39542C PERMUTATIONS AND SCALING FACTORS USED.
39543C
39544C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
39545C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
39546C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
39547C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN
39548C SCALE(J) = P(J), FOR J = 1,...,LOW-1
39549C = D(J,J) J = LOW,...,IGH
39550C = P(J) J = IGH+1,...,N.
39551C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
39552C THEN 1 TO LOW-1.
39553C
39554C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
39555C
39556C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
39557C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
39558C K,L HAVE BEEN REVERSED.)
39559C
39560C ARITHMETIC IS REAL THROUGHOUT.
39561C
39562C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
39563C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
39564C
39565C THIS VERSION DATED AUGUST 1983.
39566C
39567
39568 SUBROUTINE PYCBAL(NM,N,AR,AI,LOW,IGH,SCALE)
39569
39570 INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
39571 DOUBLE PRECISION AR(4,4),AI(4,4),SCALE(4)
39572 DOUBLE PRECISION C,F,G,R,S,B2,RADIX
39573 LOGICAL NOCONV
39574
39575 RADIX = 16.0D0
39576C
39577 B2 = RADIX * RADIX
39578 K = 1
39579 L = N
39580 GOTO 150
39581C .......... IN-LINE PROCEDURE FOR ROW AND
39582C COLUMN EXCHANGE ..........
39583 100 SCALE(M) = J
39584 IF (J .EQ. M) GOTO 130
39585C
39586 DO 110 I = 1, L
39587 F = AR(I,J)
39588 AR(I,J) = AR(I,M)
39589 AR(I,M) = F
39590 F = AI(I,J)
39591 AI(I,J) = AI(I,M)
39592 AI(I,M) = F
39593 110 CONTINUE
39594C
39595 DO 120 I = K, N
39596 F = AR(J,I)
39597 AR(J,I) = AR(M,I)
39598 AR(M,I) = F
39599 F = AI(J,I)
39600 AI(J,I) = AI(M,I)
39601 AI(M,I) = F
39602 120 CONTINUE
39603C
39604 130 IF(IEXC.EQ.1) GOTO 140
39605 IF(IEXC.EQ.2) GOTO 180
39606C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
39607C AND PUSH THEM DOWN ..........
39608 140 IF (L .EQ. 1) GOTO 320
39609 L = L - 1
39610C .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
39611 150 DO 170 JJ = 1, L
39612 J = L + 1 - JJ
39613C
39614 DO 160 I = 1, L
39615 IF (I .EQ. J) GOTO 160
39616 IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GOTO 170
39617 160 CONTINUE
39618C
39619 M = L
39620 IEXC = 1
39621 GOTO 100
39622 170 CONTINUE
39623C
39624 GOTO 190
39625C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
39626C AND PUSH THEM LEFT ..........
39627 180 K = K + 1
39628C
39629 190 DO 210 J = K, L
39630C
39631 DO 200 I = K, L
39632 IF (I .EQ. J) GOTO 200
39633 IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GOTO 210
39634 200 CONTINUE
39635C
39636 M = K
39637 IEXC = 2
39638 GOTO 100
39639 210 CONTINUE
39640C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
39641 DO 220 I = K, L
39642 220 SCALE(I) = 1.0D0
39643C .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
39644 230 NOCONV = .FALSE.
39645C
39646 DO 310 I = K, L
39647 C = 0.0D0
39648 R = 0.0D0
39649C
39650 DO 240 J = K, L
39651 IF (J .EQ. I) GOTO 240
39652 C = C + DABS(AR(J,I)) + DABS(AI(J,I))
39653 R = R + DABS(AR(I,J)) + DABS(AI(I,J))
39654 240 CONTINUE
39655C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
39656 IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GOTO 310
39657 G = R / RADIX
39658 F = 1.0D0
39659 S = C + R
39660 250 IF (C .GE. G) GOTO 260
39661 F = F * RADIX
39662 C = C * B2
39663 GOTO 250
39664 260 G = R * RADIX
39665 270 IF (C .LT. G) GOTO 280
39666 F = F / RADIX
39667 C = C / B2
39668 GOTO 270
39669C .......... NOW BALANCE ..........
39670 280 IF ((C + R) / F .GE. 0.95D0 * S) GOTO 310
39671 G = 1.0D0 / F
39672 SCALE(I) = SCALE(I) * F
39673 NOCONV = .TRUE.
39674C
39675 DO 290 J = K, N
39676 AR(I,J) = AR(I,J) * G
39677 AI(I,J) = AI(I,J) * G
39678 290 CONTINUE
39679C
39680 DO 300 J = 1, L
39681 AR(J,I) = AR(J,I) * F
39682 AI(J,I) = AI(J,I) * F
39683 300 CONTINUE
39684C
39685 310 CONTINUE
39686C
39687 IF (NOCONV) GOTO 230
39688C
39689 320 LOW = K
39690 IGH = L
39691 RETURN
39692 END
39693
39694C*********************************************************************
39695
39696C...PYCBA2
39697C...Auxiliary to PYEICG.
39698C
39699C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
39700C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
39701C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
39702C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
39703C
39704C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
39705C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
39706C BALANCED MATRIX DETERMINED BY CBAL.
39707C
39708C ON INPUT
39709C
39710C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
39711C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
39712C DIMENSION STATEMENT.
39713C
39714C N IS THE ORDER OF THE MATRIX.
39715C
39716C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL.
39717C
39718C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
39719C AND SCALING FACTORS USED BY CBAL.
39720C
39721C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
39722C
39723C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
39724C RESPECTIVELY, OF THE EIGENVECTORS TO BE
39725C BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
39726C
39727C ON OUTPUT
39728C
39729C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
39730C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
39731C IN THEIR FIRST M COLUMNS.
39732C
39733C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
39734C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
39735C
39736C THIS VERSION DATED AUGUST 1983.
39737C
39738
39739 SUBROUTINE PYCBA2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
39740
39741 INTEGER I,J,K,M,N,II,NM,IGH,LOW
39742 DOUBLE PRECISION SCALE(4),ZR(4,4),ZI(4,4)
39743 DOUBLE PRECISION S
39744
39745 IF (M .EQ. 0) GOTO 150
39746 IF (IGH .EQ. LOW) GOTO 120
39747C
39748 DO 110 I = LOW, IGH
39749 S = SCALE(I)
39750C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
39751C IF THE FOREGOING STATEMENT IS REPLACED BY
39752C S=1.0D0/SCALE(I). ..........
39753 DO 100 J = 1, M
39754 ZR(I,J) = ZR(I,J) * S
39755 ZI(I,J) = ZI(I,J) * S
39756 100 CONTINUE
39757C
39758 110 CONTINUE
39759C .......... FOR I=LOW-1 STEP -1 UNTIL 1,
39760C IGH+1 STEP 1 UNTIL N DO -- ..........
39761 120 DO 140 II = 1, N
39762 I = II
39763 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
39764 IF (I .LT. LOW) I = LOW - II
39765 K = SCALE(I)
39766 IF (K .EQ. I) GOTO 140
39767C
39768 DO 130 J = 1, M
39769 S = ZR(I,J)
39770 ZR(I,J) = ZR(K,J)
39771 ZR(K,J) = S
39772 S = ZI(I,J)
39773 ZI(I,J) = ZI(K,J)
39774 ZI(K,J) = S
39775 130 CONTINUE
39776C
39777 140 CONTINUE
39778C
39779 150 RETURN
39780 END
39781
39782C*********************************************************************
39783
39784C...PYCRTH
39785C...Auxiliary to PYEICG.
39786C
39787C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
39788C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
39789C BY MARTIN AND WILKINSON.
39790C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
39791C
39792C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
39793C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
39794C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
39795C UNITARY SIMILARITY TRANSFORMATIONS.
39796C
39797C ON INPUT
39798C
39799C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
39800C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
39801C DIMENSION STATEMENT.
39802C
39803C N IS THE ORDER OF THE MATRIX.
39804C
39805C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
39806C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
39807C SET LOW=1, IGH=N.
39808C
39809C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
39810C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
39811C
39812C ON OUTPUT
39813C
39814C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
39815C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION
39816C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
39817C IS STORED IN THE REMAINING TRIANGLES UNDER THE
39818C HESSENBERG MATRIX.
39819C
39820C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
39821C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED.
39822C
39823C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
39824C
39825C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
39826C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
39827C
39828C THIS VERSION DATED AUGUST 1983.
39829C
39830
39831 SUBROUTINE PYCRTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
39832
39833 INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
39834 DOUBLE PRECISION AR(4,4),AI(4,4),ORTR(4),ORTI(4)
39835 DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG
39836
39837 LA = IGH - 1
39838 KP1 = LOW + 1
39839 IF (LA .LT. KP1) GOTO 210
39840C
39841 DO 200 M = KP1, LA
39842 H = 0.0D0
39843 ORTR(M) = 0.0D0
39844 ORTI(M) = 0.0D0
39845 SCALE = 0.0D0
39846C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
39847 DO 100 I = M, IGH
39848 100 SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1))
39849C
39850 IF (SCALE .EQ. 0.0D0) GOTO 200
39851 MP = M + IGH
39852C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
39853 DO 110 II = M, IGH
39854 I = MP - II
39855 ORTR(I) = AR(I,M-1) / SCALE
39856 ORTI(I) = AI(I,M-1) / SCALE
39857 H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I)
39858 110 CONTINUE
39859C
39860 G = DSQRT(H)
39861 F = PYTHAG(ORTR(M),ORTI(M))
39862 IF (F .EQ. 0.0D0) GOTO 120
39863 H = H + F * G
39864 G = G / F
39865 ORTR(M) = (1.0D0 + G) * ORTR(M)
39866 ORTI(M) = (1.0D0 + G) * ORTI(M)
39867 GOTO 130
39868C
39869 120 ORTR(M) = G
39870 AR(M,M-1) = SCALE
39871C .......... FORM (I-(U*UT)/H) * A ..........
39872 130 DO 160 J = M, N
39873 FR = 0.0D0
39874 FI = 0.0D0
39875C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
39876 DO 140 II = M, IGH
39877 I = MP - II
39878 FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J)
39879 FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J)
39880 140 CONTINUE
39881C
39882 FR = FR / H
39883 FI = FI / H
39884C
39885 DO 150 I = M, IGH
39886 AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I)
39887 AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I)
39888 150 CONTINUE
39889C
39890 160 CONTINUE
39891C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
39892 DO 190 I = 1, IGH
39893 FR = 0.0D0
39894 FI = 0.0D0
39895C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
39896 DO 170 JJ = M, IGH
39897 J = MP - JJ
39898 FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J)
39899 FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J)
39900 170 CONTINUE
39901C
39902 FR = FR / H
39903 FI = FI / H
39904C
39905 DO 180 J = M, IGH
39906 AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J)
39907 AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J)
39908 180 CONTINUE
39909C
39910 190 CONTINUE
39911C
39912 ORTR(M) = SCALE * ORTR(M)
39913 ORTI(M) = SCALE * ORTI(M)
39914 AR(M,M-1) = -G * AR(M,M-1)
39915 AI(M,M-1) = -G * AI(M,M-1)
39916 200 CONTINUE
39917C
39918 210 RETURN
39919 END
39920
39921C*********************************************************************
39922
39923C...PYLDCM
39924C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
39925C...processes.
39926
39927 SUBROUTINE PYLDCM(A,N,NP,INDX,D)
39928 IMPLICIT NONE
39929 INTEGER N,NP,INDX(N)
39930 REAL*8 D,TINY
39931 COMPLEX*16 A(NP,NP)
39932 PARAMETER (TINY=1.0D-20)
39933 INTEGER I,IMAX,J,K
39934 REAL*8 AAMAX,VV(6),DUM
39935 COMPLEX*16 SUM,DUMC
39936
39937 D=1D0
39938 DO 110 I=1,N
39939 AAMAX=0D0
39940 DO 100 J=1,N
39941 IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
39942 100 CONTINUE
39943 IF (AAMAX.EQ.0D0) PAUSE 'SINGULAR MATRIX IN PYLDCM'
39944 VV(I)=1D0/AAMAX
39945 110 CONTINUE
39946 DO 180 J=1,N
39947 DO 130 I=1,J-1
39948 SUM=A(I,J)
39949 DO 120 K=1,I-1
39950 SUM=SUM-A(I,K)*A(K,J)
39951 120 CONTINUE
39952 A(I,J)=SUM
39953 130 CONTINUE
39954 AAMAX=0D0
39955 DO 150 I=J,N
39956 SUM=A(I,J)
39957 DO 140 K=1,J-1
39958 SUM=SUM-A(I,K)*A(K,J)
39959 140 CONTINUE
39960 A(I,J)=SUM
39961 DUM=VV(I)*ABS(SUM)
39962 IF (DUM.GE.AAMAX) THEN
39963 IMAX=I
39964 AAMAX=DUM
39965 ENDIF
39966 150 CONTINUE
39967 IF (J.NE.IMAX)THEN
39968 DO 160 K=1,N
39969 DUMC=A(IMAX,K)
39970 A(IMAX,K)=A(J,K)
39971 A(J,K)=DUMC
39972 160 CONTINUE
39973 D=-D
39974 VV(IMAX)=VV(J)
39975 ENDIF
39976 INDX(J)=IMAX
39977 IF(ABS(A(J,J)).EQ.0D0) A(J,J)=DCMPLX(TINY,0D0)
39978 IF(J.NE.N)THEN
39979 DO 170 I=J+1,N
39980 A(I,J)=A(I,J)/A(J,J)
39981 170 CONTINUE
39982 ENDIF
39983 180 CONTINUE
39984
39985 RETURN
39986 END
39987
39988C*********************************************************************
39989
39990C...PYBKSB
39991C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
39992C...processes.
39993
39994 SUBROUTINE PYBKSB(A,N,NP,INDX,B)
39995 IMPLICIT NONE
39996 INTEGER N,NP,INDX(N)
39997 COMPLEX*16 A(NP,NP),B(N)
39998 INTEGER I,II,J,LL
39999 COMPLEX*16 SUM
40000
40001 II=0
40002 DO 110 I=1,N
40003 LL=INDX(I)
40004 SUM=B(LL)
40005 B(LL)=B(I)
40006 IF (II.NE.0)THEN
40007 DO 100 J=II,I-1
40008 SUM=SUM-A(I,J)*B(J)
40009 100 CONTINUE
40010 ELSE IF (ABS(SUM).NE.0D0) THEN
40011 II=I
40012 ENDIF
40013 B(I)=SUM
40014 110 CONTINUE
40015 DO 130 I=N,1,-1
40016 SUM=B(I)
40017 DO 120 J=I+1,N
40018 SUM=SUM-A(I,J)*B(J)
40019 120 CONTINUE
40020 B(I)=SUM/A(I,I)
40021 130 CONTINUE
40022 RETURN
40023 END
40024
40025C***********************************************************************
40026
40027C...PYWIDX
40028C...Calculates full and partial widths of resonances.
40029C....copy of PYWIDT, used for techniparticle widths
40030
40031 SUBROUTINE PYWIDX(KFLR,SH,WDTP,WDTE)
40032
40033C...Double precision and integer declarations.
40034 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40035 IMPLICIT INTEGER(I-N)
40036 INTEGER PYK,PYCHGE,PYCOMP
40037C...Parameter statement to help give large particle numbers.
40038 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
40039 &KEXCIT=4000000,KDIMEN=5000000)
40040C...Commonblocks.
40041 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40042 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40043 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
40044 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
40045 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40046 COMMON/PYINT1/MINT(400),VINT(400)
40047 COMMON/PYINT4/MWID(500),WIDS(500,5)
40048 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
40049 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
40050 &/PYINT4/,/PYMSSM/
40051C...Local arrays and saved variables.
40052 DIMENSION WDTP(0:300),WDTE(0:300,0:5),MOFSV(3,2),WIDWSV(3,2),
40053 &WID2SV(3,2)
40054 SAVE MOFSV,WIDWSV,WID2SV
40055 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
40056
40057C...Compressed code and sign; mass.
40058 KFLA=IABS(KFLR)
40059 KFLS=ISIGN(1,KFLR)
40060 KC=PYCOMP(KFLA)
40061 SHR=SQRT(SH)
40062 PMR=PMAS(KC,1)
40063
40064C...Reset width information.
40065 DO 110 I=0,200
40066 WDTP(I)=0D0
40067 DO 100 J=0,5
40068 WDTE(I,J)=0D0
40069 100 CONTINUE
40070 110 CONTINUE
40071
40072C...Common electroweak and strong constants.
40073 XW=PARU(102)
40074 XWV=XW
40075 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
40076 XW1=1D0-XW
40077 AEM=PYALEM(SH)
40078 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
40079 AS=PYALPS(SH)
40080 RADC=1D0+AS/PARU(1)
40081
40082 IF(KFLA.EQ.23) THEN
40083C...Z0:
40084 ICASE=1
40085 XWC=1D0/(16D0*XW*XW1)
40086 FAC=(AEM*XWC/3D0)*SHR
40087 120 CONTINUE
40088 DO 130 I=1,MDCY(KC,3)
40089 IDC=I+MDCY(KC,2)-1
40090 IF(MDME(IDC,1).LT.0) GOTO 130
40091 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
40092 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
40093 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130
40094 WID2=1D0
40095 IF(I.LE.8) THEN
40096C...Z0 -> q + qbar
40097 EF=KCHG(I,1)/3D0
40098 AF=SIGN(1D0,EF+0.1D0)
40099 VF=AF-4D0*EF*XWV
40100 FCOF=3D0*RADC
40101 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
40102 IF(I.EQ.6) WID2=WIDS(6,1)
40103 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
40104 ELSEIF(I.LE.16) THEN
40105C...Z0 -> l+ + l-, nu + nubar
40106 EF=KCHG(I+2,1)/3D0
40107 AF=SIGN(1D0,EF+0.1D0)
40108 VF=AF-4D0*EF*XWV
40109 FCOF=1D0
40110 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
40111 ENDIF
40112 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
40113 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
40114 & BE34
40115 WDTP(0)=WDTP(0)+WDTP(I)
40116 IF(MDME(IDC,1).GT.0) THEN
40117 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
40118 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
40119 & WDTE(I,MDME(IDC,1))
40120 WDTE(I,0)=WDTE(I,MDME(IDC,1))
40121 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
40122 ENDIF
40123 130 CONTINUE
40124
40125
40126 ELSEIF(KFLA.EQ.24) THEN
40127C...W+/-:
40128 FAC=(AEM/(24D0*XW))*SHR
40129 DO 140 I=1,MDCY(KC,3)
40130 IDC=I+MDCY(KC,2)-1
40131 IF(MDME(IDC,1).LT.0) GOTO 140
40132 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
40133 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
40134 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
40135 WID2=1D0
40136 IF(I.LE.16) THEN
40137C...W+/- -> q + qbar'
40138 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
40139 IF(KFLR.GT.0) THEN
40140 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
40141 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
40142 IF(I.GE.13) WID2=WID2*WIDS(7,3)
40143 ELSE
40144 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
40145 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
40146 IF(I.GE.13) WID2=WID2*WIDS(7,2)
40147 ENDIF
40148 ELSEIF(I.LE.20) THEN
40149C...W+/- -> l+/- + nu
40150 FCOF=1D0
40151 IF(KFLR.GT.0) THEN
40152 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
40153 ELSE
40154 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
40155 ENDIF
40156 ENDIF
40157 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
40158 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
40159 WDTP(0)=WDTP(0)+WDTP(I)
40160 IF(MDME(IDC,1).GT.0) THEN
40161 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
40162 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
40163 WDTE(I,0)=WDTE(I,MDME(IDC,1))
40164 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
40165 ENDIF
40166 140 CONTINUE
40167 ENDIF
40168
40169 RETURN
40170 END
40171
40172C*********************************************************************
40173
40174C...PYRVSF
40175C...Calculates R-violating decays of sfermions.
40176C... * Only L-violating decays included at this point.
40177
40178 SUBROUTINE PYRVSF(KFIN,XLAM,IDLAM,LKNT)
40179
40180C...Double precision and integer declarations.
40181 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40182 IMPLICIT INTEGER(I-N)
40183C...Parameter statement to help give large particle numbers.
40184 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
40185 &KEXCIT=4000000,KDIMEN=5000000)
40186C...Commonblocks.
40187 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40188 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
40189 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
40190 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
40191 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
40192C...Local variables.
40193 DOUBLE PRECISION XLAM(0:300), RM2, SM, SMT
40194 INTEGER IDLAM(300,3), KFIN, KFSM, I, J, K, LKNT, ICNT,PYCOMP
40195 SAVE /PYMSRV/,/PYSSMT/,/PYMSSM/,/PYDAT2/
40196
40197C...IS L-VIOLATION ON ?
40198 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1)) THEN
40199C...Mass eigenstate counter
40200 ICNT=INT(KFIN/KSUSY1)
40201C...SM KF code of SUSY particle
40202 KFSM=KFIN-ICNT*KSUSY1
40203C...Squared Sparticle Mass
40204 SM=PMAS(PYCOMP(KFIN),1)**2
40205C... Squared mass of top quark
40206 SMT=PMAS(PYCOMP(6),1)**2
40207C...SLEPTON -> NU(BAR) + LEPTON and UBAR + D
40208 IF(ICNT.NE.0.AND.(KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15)) THEN
40209 K=INT((KFSM-9)/2)
40210 DO 110 I=1,3
40211 DO 100 J=1,3
40212 IF(I.NE.J) THEN
40213C...~e,~mu,~tau -> nu_I + lepton-_J
40214 LKNT = LKNT+1
40215 IDLAM(LKNT,1)= 12 +2*(I-1)
40216 IDLAM(LKNT,2)= 11 +2*(J-1)
40217 IDLAM(LKNT,3)= 0
40218 XLAM(LKNT)=0D0
40219 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2+ICNT)**2 * SM
40220 IF (IMSS(51).NE.0) XLAM(LKNT) =
40221 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
40222C...KINEMATICS CHECK
40223 IF (XLAM(LKNT).EQ.0D0) THEN
40224 LKNT=LKNT-1
40225 ENDIF
40226 ENDIF
40227 100 CONTINUE
40228 110 CONTINUE
40229C...~e,~mu,~tau -> nu_Ibar + lepton-_K
40230 J=INT((KFSM-9)/2)
40231 DO 130 I=1,3
40232 IF(I.NE.J) THEN
40233 DO 120 K=1,3
40234 LKNT = LKNT+1
40235 IDLAM(LKNT,1)=-12 -2*(I-1)
40236 IDLAM(LKNT,2)= 11 +2*(K-1)
40237 IDLAM(LKNT,3)= 0
40238 XLAM(LKNT)=0D0
40239 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,ICNT)**2 * SM
40240 IF (IMSS(51).NE.0) XLAM(LKNT) =
40241 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
40242C...KINEMATICS CHECK
40243 IF (XLAM(LKNT).EQ.0D0) THEN
40244 LKNT=LKNT-1
40245 ENDIF
40246 120 CONTINUE
40247 ENDIF
40248 130 CONTINUE
40249C...~e,~mu,~tau -> u_Jbar + d_K
40250 I=INT((KFSM-9)/2)
40251 DO 150 J=1,3
40252 DO 140 K=1,3
40253 LKNT = LKNT+1
40254 IDLAM(LKNT,1)=-2 -2*(J-1)
40255 IDLAM(LKNT,2)= 1 +2*(K-1)
40256 IDLAM(LKNT,3)= 0
40257 XLAM(LKNT)=0
40258 IF (IMSS(52).NE.0) THEN
40259C...Use massive top quark
40260 IF (IDLAM(LKNT,1).EQ.-6) THEN
40261 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,ICNT)**2
40262 & * (SM-SMT)
40263 XLAM(LKNT) =
40264 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
40265C...If no top quark, all decay products massless
40266 ELSE
40267 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,ICNT)**2 * SM
40268 XLAM(LKNT) =
40269 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
40270 ENDIF
40271C...KINEMATICS CHECK
40272 IF (XLAM(LKNT).EQ.0D0) THEN
40273 LKNT=LKNT-1
40274 ENDIF
40275 ENDIF
40276 140 CONTINUE
40277 150 CONTINUE
40278 ENDIF
40279C * SNEUTRINO -> LEPTON+ + LEPTON- and DBAR + D
40280C...No right-handed neutrinos
40281 IF(ICNT.EQ.1) THEN
40282 IF(KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16) THEN
40283 J=INT((KFSM-10)/2)
40284 DO 170 I=1,3
40285 DO 160 K=1,3
40286 IF (I.NE.J) THEN
40287C...~nu_J -> lepton+_I + lepton-_K
40288 LKNT = LKNT+1
40289 IDLAM(LKNT,1)=-11 -2*(I-1)
40290 IDLAM(LKNT,2)= 11 +2*(K-1)
40291 IDLAM(LKNT,3)= 0
40292 XLAM(LKNT)=0D0
40293 RM2=RVLAM(I,J,K)**2 * SM
40294 IF (IMSS(51).NE.0) XLAM(LKNT) =
40295 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
40296C...KINEMATICS CHECK
40297 IF (XLAM(LKNT).EQ.0D0) THEN
40298 LKNT=LKNT-1
40299 ENDIF
40300 ENDIF
40301 160 CONTINUE
40302 170 CONTINUE
40303C...~nu_I -> dbar_J + d_K
40304 I=INT((KFSM-10)/2)
40305 DO 190 J=1,3
40306 DO 180 K=1,3
40307 LKNT = LKNT+1
40308 IDLAM(LKNT,1)=-1 -2*(J-1)
40309 IDLAM(LKNT,2)= 1 +2*(K-1)
40310 IDLAM(LKNT,3)= 0
40311 XLAM(LKNT)=0D0
40312 RM2=3*RVLAMP(I,J,K)**2 * SM
40313 IF (IMSS(52).NE.0) XLAM(LKNT) =
40314 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
40315C...KINEMATICS CHECK
40316 IF (XLAM(LKNT).EQ.0D0) THEN
40317 LKNT=LKNT-1
40318 ENDIF
40319 180 CONTINUE
40320 190 CONTINUE
40321 ENDIF
40322 ENDIF
40323C * SDOWN -> NU(BAR) + D and LEPTON- + U
40324 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
40325 J=INT((KFSM+1)/2)
40326 DO 210 I=1,3
40327 DO 200 K=1,3
40328C...~d_J -> nu_Ibar + d_K
40329 LKNT = LKNT+1
40330 IDLAM(LKNT,1)=-12 -2*(I-1)
40331 IDLAM(LKNT,2)= 1 +2*(K-1)
40332 IDLAM(LKNT,3)= 0
40333 XLAM(LKNT)=0D0
40334 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,ICNT)**2 * SM
40335 IF (IMSS(52).NE.0) XLAM(LKNT) =
40336 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
40337C...KINEMATICS CHECK
40338 IF (XLAM(LKNT).EQ.0D0) THEN
40339 LKNT=LKNT-1
40340 ENDIF
40341 200 CONTINUE
40342 210 CONTINUE
40343 K=INT((KFSM+1)/2)
40344 DO 240 I=1,3
40345 DO 230 J=1,3
40346C...~d_K -> nu_I + d_J
40347 LKNT = LKNT+1
40348 IDLAM(LKNT,1)= 12 +2*(I-1)
40349 IDLAM(LKNT,2)= 1 +2*(J-1)
40350 IDLAM(LKNT,3)= 0
40351 XLAM(LKNT)=0D0
40352 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2+ICNT)**2 * SM
40353 IF (IMSS(52).NE.0) XLAM(LKNT) =
40354 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
40355C...KINEMATICS CHECK
40356 IF (XLAM(LKNT).EQ.0D0) THEN
40357 LKNT=LKNT-1
40358 ENDIF
40359C...~d_K -> lepton_I- + u_J
40360 220 LKNT = LKNT+1
40361 IDLAM(LKNT,1)= 11 +2*(I-1)
40362 IDLAM(LKNT,2)= 2 +2*(J-1)
40363 IDLAM(LKNT,3)= 0
40364 XLAM(LKNT)=0D0
40365 IF (IMSS(52).NE.0) THEN
40366C...Use massive top quark
40367 IF (IDLAM(LKNT,2).EQ.6) THEN
40368 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2+ICNT)**2*(SM-SMT)
40369 XLAM(LKNT) =
40370 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,2)
40371C...If no top quark, all decay products massless
40372 ELSE
40373 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2+ICNT)**2 * SM
40374 XLAM(LKNT) =
40375 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
40376 ENDIF
40377C...KINEMATICS CHECK
40378 IF (XLAM(LKNT).EQ.0D0) THEN
40379 LKNT=LKNT-1
40380 ENDIF
40381 ENDIF
40382 230 CONTINUE
40383 240 CONTINUE
40384 ENDIF
40385C * SUP -> LEPTON+ + D
40386 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
40387 J=INT((KFSM+1)/2)
40388 DO 260 I=1,3
40389 DO 250 K=1,3
40390C...~u_J -> lepton_I+ + d_K
40391 LKNT = LKNT+1
40392 IDLAM(LKNT,1)=-11 -2*(I-1)
40393 IDLAM(LKNT,2)= 1 +2*(K-1)
40394 IDLAM(LKNT,3)= 0
40395 XLAM(LKNT)=0D0
40396 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,ICNT)**2 * SM
40397 IF (IMSS(52).NE.0) XLAM(LKNT) =
40398 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
40399C...KINEMATICS CHECK
40400 IF (XLAM(LKNT).EQ.0D0) THEN
40401 LKNT=LKNT-1
40402 ENDIF
40403 250 CONTINUE
40404 260 CONTINUE
40405 ENDIF
40406 ENDIF
40407
40408 RETURN
40409 END
40410
40411C*********************************************************************
40412
40413C...PYRVNE
40414C...Calculates R-violating neutralino decay widths (pure 1->3 parts).
40415C... * Only L-violating decays included at this point.
40416
40417 SUBROUTINE PYRVNE(KFIN,XLAM,IDLAM,LKNT)
40418
40419C...Double precision and integer declarations.
40420 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40421 IMPLICIT INTEGER(I-N)
40422C...Parameter statement to help give large particle numbers.
40423 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
40424 &KEXCIT=4000000,KDIMEN=5000000)
40425C...Commonblocks.
40426 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40427 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40428 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
40429 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
40430 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
40431 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
40432C...Local parameters
40433 PARAMETER (UNB=80)
40434C...Local variables.
40435 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,5),IDR,IDR2,DCMASS,KFR(3)
40436 DOUBLE PRECISION XLAM(0:300),AB,RES,RMS
40437 DOUBLE PRECISION ZPMIX(4,4), NMIX(4,4), LAMC, RMQ(6)
40438 INTEGER IDLAM(300,3),LKNT,KFIN,PYCOMP,ISM,IDR,IDR2
40439 LOGICAL DCMASS
40440 CHARACTER*31 PRC
40441 CHARACTER*11 FNAME
40442 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/
40443
40444C...LEPTON NUMBER VIOLATING DECAYS
40445 IF (((IMSS(51).GE.1).OR.(IMSS(52).GE.1))) THEN
40446 KFSM=KFIN-KSUSY1
40447 IF(KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
40448C...WHICH NEUTRALINO ?
40449 NCHI=1
40450 IF (KFSM.EQ.23) NCHI=2
40451 IF (KFSM.EQ.25) NCHI=3
40452 IF (KFSM.EQ.35) NCHI=4
40453C...SIGN OF MASS
40454 ISM=1
40455 IF (SMZ(NCHI).LT.0D0) ISM=-ISM
40456
40457C...Useful parameters for the calculation of the A and B constants.
40458 WMASS = PMAS(PYCOMP(24),1)
40459 ECHG = 2*SQRT(PARU(103)*PARU(1))
40460 COSB=1/(SQRT(1+RMSS(5)**2))
40461 SINB=RMSS(5)/SQRT(1+RMSS(5)**2)
40462 COSW=SQRT(1-PARU(102))
40463 SINW=SQRT(PARU(102))
40464 GW=2D0*SQRT(PARU(103)*PARU(1))/SINW
40465C...Run quark masses to neutralino mass squared (for Higgs-type
40466C...couplings)
40467 SQMCHI=PMAS(PYCOMP(KFIN),1)**2
40468 DO 100 I=1,6
40469 RMQ(I)=PYMRUN(I,SQMCHI)
40470 100 CONTINUE
40471
40472C...EXPRESS NEUTRALINO MIXING IN (photino,Zino,~H_u,~H_d) BASIS
40473 DO 110 I = 1,4
40474 ZPMIX(I,1)= ZMIX(I,1)*COSW+ZMIX(I,2)*SINW
40475 ZPMIX(I,2)=-ZMIX(I,1)*SINW+ZMIX(I,2)*COSW
40476 ZPMIX(I,3)= ZMIX(I,3)
40477 ZPMIX(I,4)= ZMIX(I,4)
40478 110 CONTINUE
40479
40480 C1=GW*ZMIX(NCHI,3)/(2.*COSB*WMASS)
40481 C1U=GW*ZMIX(NCHI,4)/(2.*SINB*WMASS)
40482 C2=ECHG*ZPMIX(NCHI,1)
40483 C3=GW*ZPMIX(NCHI,2)/COSW
40484 EU=2D0/3D0
40485 ED=-1D0/3D0
40486C... AB(x,y,z):
40487C x=1-2 : Select A or B constant (1:A ; 2:B)
40488C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
40489C 11-16:e,nu_e,mu,...)
40490C z=1-2 : Mass eigenstate number
40491C...CALCULATE COUPLINGS
40492 DO 120 I = 11,15,2
40493 CMS=PMAS(PYCOMP(I),1)
40494 AB(1,I,1)=ISM*(CMS*C1*SFMIX(I,1) - SFMIX(I,3)
40495 & *(C2-C3*SINW**2))
40496 AB(1,I,2)=ISM*(-CMS*C1*SFMIX(I,2) + SFMIX(I,4)
40497 & *(C2-C3*SINW**2))
40498 AB(2,I,1)= -CMS*C1*SFMIX(I,3) - SFMIX(I,1)*(C2+C3*(5D-1-SINW
40499 & **2))
40500 AB(2,I,2)=CMS*C1*SFMIX(I,4) + SFMIX(I,2)*(C2+C3*(5D-1 - SINW
40501 & **2))
40502 AB(1,I+1,1)=0D0
40503 AB(2,I+1,1)=5D-1*C3
40504 AB(1,I+1,2)=0D0
40505 AB(2,I+1,2)=0D0
40506 J=I-10
40507 CMS=RMQ(J)
40508 AB(1,J,1)=ISM*(CMS*C1*SFMIX(J,1) + SFMIX(J,3)
40509 & *ED*(C2-ED*C3*SINW**2))
40510 AB(1,J,2)=ISM*(-CMS*C1*SFMIX(J,2) - SFMIX(J,4)
40511 & *ED*(C2-ED*C3*SINW**2))
40512 AB(2,J,1)=-CMS*C1*SFMIX(J,3) + SFMIX(J,1)
40513 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
40514 AB(2,J,2)=CMS*C1*SFMIX(J,4) - SFMIX(J,2)
40515 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
40516 J=J+1
40517 CMS=RMQ(J)
40518 AB(1,J,1)=ISM*(CMS*C1U*SFMIX(J,1) + SFMIX(J,3)
40519 & *EU*(C2-C3*SINW**2))
40520 AB(1,J,2)=ISM*(-CMS*C1U*SFMIX(J,2) - SFMIX(J,4)
40521 & *EU*(C2-C3*SINW**2))
40522 AB(2,J,1)=-CMS*C1U*SFMIX(J,3) + SFMIX(J,1)
40523 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
40524 AB(2,J,2)=CMS*C1U*SFMIX(J,4) - SFMIX(J,2)
40525 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
40526 120 CONTINUE
40527
40528C...LAMBDA COUPLINGS (LLE TYPE R-VIOLATION)
40529C * CHI0_I -> NUBAR_I + LEPTON+_J + lEPTON-_K.
40530C...STEP IN I,J,K USING SINGLE COUNTER
40531 DO 140 ISC=0,26
40532C...LAMBDA COUPLING ASYM IN I,J
40533 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
40534 LKNT = LKNT+1
40535 IDLAM(LKNT,1)=-12 -2*MOD(ISC/9,3)
40536 IDLAM(LKNT,2)=-11 -2*MOD(ISC/3,3)
40537 IDLAM(LKNT,3)= 11 +2*MOD(ISC,3)
40538 XLAM(LKNT)=0D0
40539 IF(IMSS(51).EQ.0) GOTO 130
40540C...Set coupling, and decay product masses on/off
40541 LAMC=RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
40542 DCMASS=.FALSE.
40543C...Resonance KF codes (1=I,2=J,3=K)
40544 KFR(1)=-IDLAM(LKNT,1)
40545 KFR(2)=-IDLAM(LKNT,2)
40546 KFR(3)=-IDLAM(LKNT,3)
40547C...Calculate width.
40548 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
40549 & ,XLAM(LKNT))
40550 XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*32)
40551C...Charge conjugate mode.
40552 130 LKNT=LKNT+1
40553 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
40554 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
40555 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
40556 XLAM(LKNT)=XLAM(LKNT-1)
40557C...KINEMATICS CHECK
40558 IF (XLAM(LKNT).EQ.0D0) THEN
40559 LKNT=LKNT-2
40560 ENDIF
40561 ENDIF
40562 140 CONTINUE
40563
40564C...LAMBDA' COUPLINGS. (LQD TYPE R-VIOLATION)
40565C * CHI0 -> NUBAR_I + DBAR_J + D_K
40566 DO 170 ISC=0,26
40567 LKNT = LKNT+1
40568 IDLAM(LKNT,1)=-12 -2*MOD(ISC/9,3)
40569 IDLAM(LKNT,2)= -1 -2*MOD(ISC/3,3)
40570 IDLAM(LKNT,3)= 1 +2*MOD(ISC,3)
40571 XLAM(LKNT)=0D0
40572 IF(IMSS(52).EQ.0) GOTO 150
40573C...Set coupling, and decay product masses on/off
40574 LAMC=3*RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
40575 DCMASS=.FALSE.
40576C...Resonance KF codes (1=I,2=J,3=K)
40577 KFR(1)=-IDLAM(LKNT,1)
40578 KFR(2)=-IDLAM(LKNT,2)
40579 KFR(3)=-IDLAM(LKNT,3)
40580C...Calculate width.
40581 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
40582 & ,XLAM(LKNT))
40583 XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*32)
40584C...Charge conjugate mode.
40585 150 LKNT=LKNT+1
40586 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
40587 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
40588 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
40589 XLAM(LKNT)=XLAM(LKNT-1)
40590C...KINEMATICS CHECK
40591 IF (XLAM(LKNT).EQ.0D0) THEN
40592 LKNT=LKNT-2
40593 ENDIF
40594
40595C * CHI0 -> LEPTON_I+ + UBAR_J + D_K
40596 LKNT = LKNT+1
40597 IDLAM(LKNT,1)=-11 -2*MOD(ISC/9,3)
40598 IDLAM(LKNT,2)= -2 -2*MOD(ISC/3,3)
40599 IDLAM(LKNT,3)= 1 +2*MOD(ISC,3)
40600 XLAM(LKNT)=0D0
40601 IF(IMSS(52).EQ.0) GOTO 160
40602C...Set coupling, and decay product masses on/off
40603 LAMC=3*RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
40604 DCMASS=.FALSE.
40605 IF (IDLAM(LKNT,2).EQ.-6) DCMASS=.TRUE.
40606C...Resonance KF codes (1=I,2=J,3=K)
40607 KFR(1)=-IDLAM(LKNT,1)
40608 KFR(2)=-IDLAM(LKNT,2)
40609 KFR(3)=-IDLAM(LKNT,3)
40610C...Calculate width.
40611 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
40612 & ,XLAM(LKNT))
40613 XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*32)
40614C...Charge conjugate mode.
40615 160 LKNT=LKNT+1
40616 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
40617 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
40618 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
40619 XLAM(LKNT)=XLAM(LKNT-1)
40620C...KINEMATICS CHECK
40621 IF (XLAM(LKNT).EQ.0D0) THEN
40622 LKNT=LKNT-2
40623 ENDIF
40624 170 CONTINUE
40625
40626 ENDIF
40627 ENDIF
40628
40629 RETURN
40630 END
40631
40632C*********************************************************************
40633
40634C...PYRVCH
40635C...Calculates R-violating chargino decay widths.
40636C... * Only L-violating decays included at this point.
40637
40638 SUBROUTINE PYRVCH(KFIN,XLAM,IDLAM,LKNT)
40639
40640C...Double precision and integer declarations.
40641 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40642 IMPLICIT INTEGER(I-N)
40643C...Parameter statement to help give large particle numbers.
40644 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
40645 &KEXCIT=4000000,KDIMEN=5000000)
40646C...Commonblocks.
40647 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40648 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40649 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
40650 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
40651 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
40652 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
40653C...Local variables.
40654 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,5),IDR,IDR2,DCMASS,KFR(3)
40655 DOUBLE PRECISION XLAM(0:300),AB, RES, RMS, C1U, C1V, C2, C3
40656 DOUBLE PRECISION LAMC, RMQ(6)
40657 INTEGER IDLAM(300,3),LKNT,KFIN,PYCOMP
40658 LOGICAL DCMASS
40659 CHARACTER*31 PRC
40660 CHARACTER*10 FNAME
40661 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/
40662
40663C...LEPTON NUMBER VIOLATING DECAYS
40664 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1)) THEN
40665 KFSM=KFIN-KSUSY1
40666 IF(KFSM.EQ.24.OR.KFSM.EQ.37) THEN
40667 ISM = 1
40668C...WHICH CHARGINO ?
40669 NCHI = 1
40670 IF (KFSM.EQ.37) NCHI = 2
40671
40672C...Useful parameters for calculating the A and B constants.
40673 IF (SMW(NCHI).LT.0D0) ISM=-1
40674 WMASS = PMAS(PYCOMP(24),1)
40675 COSB = 1/(SQRT(1+RMSS(5)**2))
40676 SINB = RMSS(5)/SQRT(1+RMSS(5)**2)
40677 GW2 = 4*PARU(103)*PARU(1)/PARU(102)
40678 SQMCHI = PMAS(PYCOMP(KFSM),1)**2
40679C...Running masses at Q^2=MCHI^2.
40680 DO 100 I=1,6
40681 RMQ(I)=PYMRUN(I,SQMCHI)
40682 100 CONTINUE
40683
40684C...Signs chosen to agree with U & V convention used in hep-ph/9912407.
40685 C1U = -UMIX(NCHI,2)/(SQRT(2D0)*COSB*WMASS)
40686 C1V = -VMIX(NCHI,2)/(SQRT(2D0)*SINB*WMASS)
40687 C2 = -UMIX(NCHI,1)
40688 C3 = -VMIX(NCHI,1)
40689C... AB(x,y,z):
40690C x=1-2 : A or B coefficient (1:A ; 2:B)
40691C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
40692C 11-16:e,nu_e,mu,...)
40693C z=1-2 : Mass eigenstate number
40694 DO 110 I = 11,15,2
40695 AB(1,I,1) = 0D0
40696 AB(1,I,2) = 0D0
40697 AB(2,I,1) = PMAS(PYCOMP(I),1)*C1U*SFMIX(I,3) +
40698 & SFMIX(I,1)*C2
40699 AB(2,I,2) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,4) -
40700 & SFMIX(I,2)*C2
40701 AB(1,I+1,1) = -PMAS(PYCOMP(I),1)*C1U
40702 AB(1,I+1,2) = 0D0
40703 AB(2,I+1,1) = ISM*C3
40704 AB(2,I+1,2) = 0D0
40705 J=I-10
40706 AB(1,J,1) = -RMQ(J+1)*C1V*SFMIX(J,1)
40707 AB(1,J,2) = RMQ(J+1)*C1V*SFMIX(J,2)
40708 AB(2,J,1) = ISM*(RMQ(J)*C1U*SFMIX(J,3) + SFMIX(J,1)*C2)
40709 AB(2,J,2) = -ISM*(RMQ(J)*C1U*SFMIX(J,4) + SFMIX(J,2)*C2)
40710 J=J+1
40711 AB(1,J,1) = -RMQ(J-1)*C1U*SFMIX(J,1)
40712 AB(1,J,2) = RMQ(J-1)*C1U*SFMIX(J,2)
40713 AB(2,J,1) = ISM*(RMQ(J)*C1V*SFMIX(J,3) - SFMIX(J,1)*C3)
40714 AB(2,J,2) = -ISM*(RMQ(J)*C1V*SFMIX(J,4) + SFMIX(J,2)*C3)
40715 110 CONTINUE
40716
40717C...LOOP OVER DECAY MODES
40718 DO 140 ISC=0,26
40719
40720C...CHI+ -> NUBAR_I + LEPTON+_J + NU_K.
40721 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
40722 LKNT = LKNT+1
40723 IDLAM(LKNT,1) = -12 -2*MOD(ISC/9,3)
40724 IDLAM(LKNT,2) = -11 -2*MOD(ISC/3,3)
40725 IDLAM(LKNT,3) = 12 +2*MOD(ISC,3)
40726 XLAM(LKNT)=0D0
40727 IF(IMSS(51).EQ.0) GOTO 120
40728C...Set coupling, and decay product masses on/off
40729 LAMC = GW2 *
40730 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
40731 DCMASS=.FALSE.
40732C...Resonance KF codes (1=I,2=J,3=K).
40733 KFR(1) = 0
40734 KFR(2) = 0
40735 KFR(3) = -IDLAM(LKNT,3)+1
40736C...Calculate width.
40737 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
40738 & ,XLAM(LKNT))
40739 XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*64)
40740C...KINEMATICS CHECK
40741 IF (XLAM(LKNT).EQ.0D0) THEN
40742 LKNT=LKNT-1
40743 ENDIF
40744
40745C * CHI+ -> NU_I + NU_J + LEPTON+_K. (NOTE: SYMM. IN I AND J)
40746 120 IF (MOD(ISC/9,3).LT.MOD(ISC/3,3)) THEN
40747 LKNT = LKNT+1
40748 IDLAM(LKNT,1)= 12 +2*MOD(ISC/9,3)
40749 IDLAM(LKNT,2)= 12 +2*MOD(ISC/3,3)
40750 IDLAM(LKNT,3)=-11 -2*MOD(ISC,3)
40751 XLAM(LKNT)=0D0
40752 IF(IMSS(51).EQ.0) GOTO 130
40753C...Set coupling, and decay product masses on/off
40754 LAMC = GW2 *
40755 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
40756C...I,J SYMMETRY => FACTOR 2
40757 LAMC=2*LAMC
40758 DCMASS=.FALSE.
40759C...Resonance KF codes (1=I,2=J,3=K)
40760 KFR(1)=IDLAM(LKNT,1)-1
40761 KFR(2)=IDLAM(LKNT,2)-1
40762 KFR(3)=0
40763C...Calculate width.
40764 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
40765 & IDLAM(LKNT,3),XLAM(LKNT))
40766 XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*64)
40767C...KINEMATICS CHECK
40768 IF (XLAM(LKNT).EQ.0D0) THEN
40769 LKNT=LKNT-1
40770 ENDIF
40771 130 ENDIF
40772
40773C * CHI+ -> LEPTON+_I + LEPTON+_J + LEPTON-_K
40774 LKNT = LKNT+1
40775 IDLAM(LKNT,1)=-11 -2*MOD(ISC/9,3)
40776 IDLAM(LKNT,2)=-11 -2*MOD(ISC/3,3)
40777 IDLAM(LKNT,3)= 11 +2*MOD(ISC,3)
40778 XLAM(LKNT)=0D0
40779 IF(IMSS(51).EQ.0) GOTO 140
40780C...Set coupling, and decay product masses on/off
40781 LAMC = GW2 *
40782 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
40783C...I,J SYMMETRY => FACTOR 2
40784 LAMC=2*LAMC
40785 DCMASS=.FALSE.
40786C...Resonance KF codes (1=I,2=J,3=K)
40787 KFR(1)=-IDLAM(LKNT,1)+1
40788 KFR(2)=-IDLAM(LKNT,2)+1
40789 KFR(3)=0
40790C...Calculate width.
40791 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
40792 & ,XLAM(LKNT))
40793 XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*64)
40794C...KINEMATICS CHECK
40795 IF (XLAM(LKNT).EQ.0D0) THEN
40796 LKNT=LKNT-1
40797 ENDIF
40798 ENDIF
40799 140 CONTINUE
40800
40801C...LQD TYPE R-VIOLATION
40802C...LOOP OVER DECAY MODES
40803 DO 180 ISC=0,26
40804
40805C...CHI+ -> NUBAR_I + DBAR_J + U_K
40806 LKNT = LKNT+1
40807 IDLAM(LKNT,1)=-12 -2*MOD(ISC/9,3)
40808 IDLAM(LKNT,2)= -1 -2*MOD(ISC/3,3)
40809 IDLAM(LKNT,3)= 2 +2*MOD(ISC,3)
40810 XLAM(LKNT)=0D0
40811 IF(IMSS(52).EQ.0) GOTO 150
40812C...Set coupling, and decay product masses on/off
40813 LAMC = 3 * GW2 *
40814 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
40815 DCMASS=.FALSE.
40816 IF (IDLAM(LKNT,3).EQ.6) DCMASS=.TRUE.
40817C...Resonance KF codes (1=I,2=J,3=K)
40818 KFR(1)=0
40819 KFR(2)=0
40820 KFR(3)=-IDLAM(LKNT,3)+1
40821C...Calculate width.
40822 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
40823 & ,XLAM(LKNT))
40824 XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*64)
40825C...KINEMATICS CHECK
40826 IF (XLAM(LKNT).EQ.0D0) THEN
40827 LKNT=LKNT-1
40828 ENDIF
40829
40830C * CHI+ -> LEPTON+_I + UBAR_J + U_K.
40831 150 LKNT = LKNT+1
40832 IDLAM(LKNT,1)=-11 -2*MOD(ISC/9,3)
40833 IDLAM(LKNT,2)= -2 -2*MOD(ISC/3,3)
40834 IDLAM(LKNT,3)= 2 +2*MOD(ISC,3)
40835 XLAM(LKNT)=0D0
40836 IF(IMSS(52).EQ.0) GOTO 160
40837C...Set coupling, and decay product masses on/off
40838 LAMC = 3 * GW2 *
40839 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
40840 DCMASS=.FALSE.
40841 IF (-IDLAM(LKNT,2).EQ.6.OR.IDLAM(LKNT,3).EQ.6) DCMASS=.TRUE.
40842C...Resonance KF codes (1=I,2=J,3=K)
40843 KFR(1)=0
40844 KFR(2)=0
40845 KFR(3)=-IDLAM(LKNT,3)+1
40846C...Calculate width.
40847 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
40848 & ,XLAM(LKNT))
40849 XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*64)
40850C...KINEMATICS CHECK
40851 IF (XLAM(LKNT).EQ.0D0) THEN
40852 LKNT=LKNT-1
40853 ENDIF
40854
40855C * CHI+ -> LEPTON+_I + DBAR_J + D_K.
40856 160 LKNT = LKNT+1
40857 IDLAM(LKNT,1)=-11 -2*MOD(ISC/9,3)
40858 IDLAM(LKNT,2)= -1 -2*MOD(ISC/3,3)
40859 IDLAM(LKNT,3)= 1 +2*MOD(ISC,3)
40860 XLAM(LKNT)=0D0
40861 IF(IMSS(52).EQ.0) GOTO 170
40862C...Set coupling, and decay product masses on/off
40863 LAMC = 3 * GW2 *
40864 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
40865 DCMASS=.FALSE.
40866C...Resonance KF codes (1=I,2=J,3=K)
40867 KFR(1)=-IDLAM(LKNT,1)+1
40868 KFR(2)=-IDLAM(LKNT,2)+1
40869 KFR(3)=0
40870C...Calculate width.
40871 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
40872 & ,XLAM(LKNT))
40873 XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*64)
40874C...KINEMATICS CHECK
40875 IF (XLAM(LKNT).EQ.0D0) THEN
40876 LKNT=LKNT-1
40877 ENDIF
40878
40879C * CHI+ -> NU_I + U_J + DBAR_K.
40880 170 LKNT = LKNT+1
40881 IDLAM(LKNT,1)= 12 +2*MOD(ISC/9,3)
40882 IDLAM(LKNT,2)= 2 +2*MOD(ISC/3,3)
40883 IDLAM(LKNT,3)= -1 -2*MOD(ISC,3)
40884 XLAM(LKNT)=0D0
40885 IF(IMSS(52).EQ.0) GOTO 180
40886C...Set coupling, and decay product masses on/off
40887 DCMASS=.FALSE.
40888 LAMC = 3 * GW2 *
40889 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
40890 IF (IDLAM(LKNT,2).EQ.6) DCMASS=.TRUE.
40891C...Resonance KF codes (1=I,2=J,3=K)
40892 KFR(1)=-IDLAM(LKNT,1)+1
40893 KFR(2)=-IDLAM(LKNT,2)+1
40894 KFR(3)=0
40895C...Calculate width.
40896 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
40897 & ,XLAM(LKNT))
40898 XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*64)
40899C...KINEMATICS CHECK
40900 IF (XLAM(LKNT).EQ.0D0) THEN
40901 LKNT=LKNT-1
40902 ENDIF
40903
40904 180 CONTINUE
40905 ENDIF
40906 ENDIF
40907
40908 RETURN
40909 END
40910
40911C*********************************************************************
40912
40913C...PYRVSB
40914C...Auxiliary function to PYRVSF for calculating R-Violating
40915C...sfermion widths. Though the decay products are most often treated
40916C...as massless in the calculation, the kinematical boundary of phase
40917C...space is tested using the true masses.
40918C...MODE = 1: All decay products massive
40919C...MODE = 2: Decay product 1 massless
40920C...MODE = 3: Decay product 2 massless
40921C...MODE = 4: All decay products massless
40922
40923 FUNCTION PYRVSB(KFIN,ID1,ID2,RM2,MODE)
40924
40925 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
40926 IMPLICIT INTEGER (I-N)
40927 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40928 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40929 SAVE /PYDAT1/,/PYDAT2/
40930 DOUBLE PRECISION SM(3), PYRVSB, RM2
40931 CHARACTER*24 PRC
40932 INTEGER KFIN, ID1,ID2, PYCOMP, KC(3), MODE
40933 KC(1)=PYCOMP(KFIN)
40934 KC(2)=PYCOMP(ID1)
40935 KC(3)=PYCOMP(ID2)
40936 SM(1)=PMAS(KC(1),1)**2
40937 SM(2)=PMAS(KC(2),1)**2
40938 SM(3)=PMAS(KC(3),1)**2
40939C...Kinematics check
40940 IF ((SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2).LE.0D0) THEN
40941 PYRVSB=0D0
40942 RETURN
40943 ENDIF
40944C...CM momenta squared
40945 IF (MODE.EQ.1) THEN
40946 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2)
40947 & * (SM(1)-(PMAS(KC(2),1)-PMAS(KC(3),1))**2)
40948 ELSE IF (MODE.EQ.2) THEN
40949 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(3),1))**2)**2
40950 ELSE IF (MODE.EQ.3) THEN
40951 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1))**2)**2
40952 ELSE
40953 P2CM=SM(1)/4.
40954 ENDIF
40955C...Calculate Width
40956 PYRVSB=RM2*SQRT(MAX(0D0,P2CM))/(8*PARU(1)*SM(1))
40957
40958 RETURN
40959 END
40960
40961C*********************************************************************
40962
40963C...PYRVGW
40964C...Main routine for R-Violating neutralino/chargino 3-body widths.
40965
40966 SUBROUTINE PYRVGW(KFIN,ID1,ID2,ID3,XLAM)
40967
40968 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
40969 IMPLICIT INTEGER (I-N)
40970 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
40971 &KEXCIT=4000000,KDIMEN=5000000)
40972 PARAMETER (EPS=1D-2)
40973 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40974 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,5),IDR,IDR2,DCMASS,KFR(3)
40975 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
40976 & SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
40977 DOUBLE PRECISION RMS, XLIM(3,3), RES, XLAM, XLAM0, PREF
40978 INTEGER INTC, KC(0:3), KFIN,ID1,ID2,ID3,KFR,PYCOMP
40979 CHARACTER*31 PRC
40980 LOGICAL DCMASS, DCHECK(6)
40981 SAVE /PYDAT2/,/PYRVNV/,/PYSSMT/
40982
40983 KC(0)=PYCOMP(KFIN)
40984 KC(1)=PYCOMP(ID1)
40985 KC(2)=PYCOMP(ID2)
40986 KC(3)=PYCOMP(ID3)
40987 DO 100 INTC=0,3
40988 RMS(INTC)=PMAS(KC(INTC),1)
40989 100 CONTINUE
40990
40991C...INITIALIZE OUTER INTEGRATION LIMITS AND KINEMATICS CHECK
40992 XLIM(1,1)=(RMS(1)+RMS(2))**2
40993 XLIM(1,2)=(RMS(0)-RMS(3))**2
40994 XLIM(1,3)=XLIM(1,2)-XLIM(1,1)
40995 XLIM(2,1)=(RMS(2)+RMS(3))**2
40996 XLIM(2,2)=(RMS(0)-RMS(1))**2
40997 XLIM(2,3)=XLIM(2,2)-XLIM(2,1)
40998 XLIM(3,1)=(RMS(1)+RMS(3))**2
40999 XLIM(3,2)=(RMS(0)-RMS(2))**2
41000 XLIM(3,3)=XLIM(3,2)-XLIM(3,1)
41001 IF (XLIM(1,3).LT.0D0.OR.XLIM(2,3).LT.0D0.OR.XLIM(3,3).LT.0D0) THEN
41002 RETURN
41003 ENDIF
41004
41005C...INITIALIZE RESONANCE INFORMATION
41006 DO 120 JRES=1,3
41007 DO 110 IMASS=1,2
41008 IRES=2*(JRES-1)+IMASS
41009 RES(IRES,1)=0D0
41010 DCHECK(IRES)=.FALSE.
41011C...NO RIGHT-HANDED NEUTRINOS
41012 IF((IMASS.EQ.2).AND.((IABS(KFR(JRES)).EQ.12).OR.(IABS(KFR(JRES
41013 & )).EQ.14).OR.(IABS(KFR(JRES)).EQ.16))) GOTO 110
41014 RES(IRES,1) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),1)
41015 RES(IRES,2) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),2)
41016 RES(IRES,3) = IABS(KFR(JRES))
41017 RES(IRES,4) = IMASS
41018 IF (KFR(JRES).LT.0) RES(IRES,5) = 1D0
41019 IF (KFR(JRES).GT.0) RES(IRES,5) = 0D0
41020 110 CONTINUE
41021 120 CONTINUE
41022
41023C...SUM OVER DIAGRAMS AND INTEGRATE OVER PHASE SPACE
41024
41025C...RESONANCE CONTRIBUTIONS
41026C...(Only sum contributions where the resonance is off shell).
41027C...LOOP OVER MASS STATES
41028 DO 130 J=1,2
41029 IDR=J
41030 IF ((RMS(0).LT.(RMS(1)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(2)
41031 & +RMS(3)))).AND.ABS(SFMIX(NINT(RES(IDR,3)),J)).GT.EPS
41032 & .AND.RES(IDR,1).NE.0D0) THEN
41033 DCHECK(IDR) =.TRUE.
41034 XLAM = XLAM + SFMIX(NINT(RES(IDR,3)),J)**2 * PYRVI1(2,3,1)
41035 ENDIF
41036
41037 IDR=J+2
41038 IF ((RMS(0).LT.(RMS(2)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
41039 & +RMS(3)))).AND.ABS(SFMIX(NINT(RES(IDR,3)),J)).GT.EPS
41040 & .AND.RES(IDR,1).NE.0D0) THEN
41041 DCHECK(IDR) =.TRUE.
41042 XLAM = XLAM + SFMIX(NINT(RES(IDR,3)),J)**2 * PYRVI1(1,3,2)
41043 ENDIF
41044
41045 IDR=J+4
41046 IF ((RMS(0).LT.(RMS(3)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
41047 & +RMS(2)))).AND.ABS(SFMIX(NINT(RES(IDR,3)),2+J)).GT.EPS
41048 & .AND.RES(IDR,1).NE.0D0) THEN
41049 DCHECK(IDR) =.TRUE.
41050 XLAM = XLAM + SFMIX(NINT(RES(IDR,3)),2+J)**2 * PYRVI1(1,2,3)
41051 ENDIF
41052 130 CONTINUE
41053
41054C... L-R INTERFERENCES
41055C... (Only add contributions where both contributing diagrams
41056C... are non-resonant).
41057 IDR=1
41058 IF (DCHECK(1).AND.DCHECK(2)) THEN
41059 XLAM = XLAM + PYRVI2(2,1,3)
41060 & * SFMIX(NINT(RES(1,3)),1+2*NINT(RES(1,5)))
41061 & * SFMIX(NINT(RES(2,3)),2+2*NINT(RES(2,5)))
41062 ENDIF
41063
41064 IDR=3
41065 IF (DCHECK(3).AND.DCHECK(4)) THEN
41066 XLAM = XLAM + PYRVI2(1,3,2)
41067 & * SFMIX(NINT(RES(3,3)),1+2*NINT(RES(3,5)))
41068 & * SFMIX(NINT(RES(4,3)),2+2*NINT(RES(4,5)))
41069 ENDIF
41070
41071 IDR=5
41072 IF (DCHECK(5).AND.DCHECK(6)) THEN
41073 XLAM = XLAM + PYRVI2(1,2,3)
41074 & * SFMIX(NINT(RES(5,3)),1+2*NINT(RES(5,5)))
41075 & * SFMIX(NINT(RES(6,3)),2+2*NINT(RES(6,5)))
41076 ENDIF
41077
41078C... TRUE INTERFERENCES
41079C... (Only add contributions where both contributing diagrams
41080C... are non-resonant).
41081 PREF=-2.
41082 IF ((KFIN-KSUSY1).EQ.24.OR.(KFIN-KSUSY1).EQ.37) PREF=2.
41083 DO 150 IKR1 = 1,2
41084 DO 140 IKR2 = 1,2
41085 IDR = IKR1+2
41086 IDR2 = IKR2
41087 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
41088 XLAM = XLAM + PREF*PYRVI3(1,3,2) *
41089 & SFMIX(NINT(RES(IDR,3)),IKR1)*SFMIX(NINT(RES(IDR2,3)),IKR2)
41090 ENDIF
41091
41092 IDR = IKR1+4
41093 IDR2 = IKR2
41094 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
41095 XLAM = XLAM + PREF*PYRVI3(1,2,3) *
41096 & SFMIX(NINT(RES(IDR,3)),2+IKR1)*SFMIX(NINT(RES(IDR2,3)),IKR2)
41097 ENDIF
41098
41099 IDR = IKR1+4
41100 IDR2 = IKR2+2
41101 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
41102 XLAM = XLAM + PREF*PYRVI3(2,1,3) *
41103 & SFMIX(NINT(RES(IDR,3)),2+IKR1)*SFMIX(NINT(RES(IDR2,3)),IKR2)
41104 ENDIF
41105 140 CONTINUE
41106 150 CONTINUE
41107 RETURN
41108 END
41109
41110C*********************************************************************
41111
41112C...PYRVI1
41113C...Function to integrate resonance contributions
41114
41115 FUNCTION PYRVI1(ID1,ID2,ID3)
41116
41117 IMPLICIT NONE
41118 DOUBLE PRECISION LO,HI,PYRVI1,PYRVG1,PYGAUS
41119 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
41120 INTEGER ID1,ID2,ID3, IANTI, IDR, IDR2, KFR
41121 LOGICAL MFLAG,DCMASS
41122 EXTERNAL PYRVG1,PYGAUS
41123 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,5),IDR,IDR2,DCMASS,KFR(3)
41124 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
41125 SAVE/PYRVNV/,/PYRVPM/
41126C...Initialize mass and width information
41127 PYRVI1=0D0
41128 RM(0)=RMS(0)
41129 RM(1)=RMS(ID1)
41130 RM(2)=RMS(ID2)
41131 RM(3)=RMS(ID3)
41132 RESM(1)=RES(IDR,1)
41133 RESW(1)=RES(IDR,2)
41134C...A->B and B->A for antisparticles
41135 IANTI=NINT(RES(IDR,5))
41136 A(1)=AB(1+IANTI,NINT(RES(IDR,3)),NINT(RES(IDR,4)))
41137 B(1)=AB(2-IANTI,NINT(RES(IDR,3)),NINT(RES(IDR,4)))
41138C...Integration boundaries and mass flag
41139 LO=(RM(1)+RM(2))**2
41140 HI=(RM(0)-RM(3))**2
41141 MFLAG=DCMASS
41142 PYRVI1=PYGAUS(PYRVG1,LO,HI,1D-2)
41143 RETURN
41144 END
41145
41146C*********************************************************************
41147
41148C...PYRVI2
41149C...Function to integrate L-R interference contributions
41150
41151 FUNCTION PYRVI2(ID1,ID2,ID3)
41152
41153 IMPLICIT NONE
41154 DOUBLE PRECISION LO,HI,PYRVI2, PYRVG2, PYGAUS
41155 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
41156 INTEGER ID1,ID2,ID3, IANTI, IDR, IDR2, KFR
41157 LOGICAL MFLAG,DCMASS
41158 EXTERNAL PYRVG2,PYGAUS
41159 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,5),IDR,IDR2,DCMASS,KFR(3)
41160 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
41161 SAVE/PYRVNV/,/PYRVPM/
41162C...Initialize mass and width information
41163 PYRVI2=0D0
41164 RM(0)=RMS(0)
41165 RM(1)=RMS(ID1)
41166 RM(2)=RMS(ID2)
41167 RM(3)=RMS(ID3)
41168 RESM(1)=RES(IDR,1)
41169 RESW(1)=RES(IDR,2)
41170 RESM(2)=RES(IDR+1,1)
41171 RESW(2)=RES(IDR+1,2)
41172C...A->B and B->A for antisparticles
41173 IANTI=NINT(RES(IDR,5))
41174 A(1)=AB(1+IANTI,NINT(RES(IDR,3)),NINT(RES(IDR,4)))
41175 B(1)=AB(2-IANTI,NINT(RES(IDR,3)),NINT(RES(IDR,4)))
41176 A(2)=AB(1+IANTI,NINT(RES(IDR+1,3)),NINT(RES(IDR+1,4)))
41177 B(2)=AB(2-IANTI,NINT(RES(IDR+1,3)),NINT(RES(IDR+1,4)))
41178C...Boundaries and mass flag
41179 LO=(RM(1)+RM(2))**2
41180 HI=(RM(0)-RM(3))**2
41181 MFLAG=DCMASS
41182 PYRVI2=PYGAUS(PYRVG2,LO,HI,1D-2)
41183 RETURN
41184 END
41185
41186C*********************************************************************
41187
41188C...PYRVI3
41189C...Function to integrate true interference contributions
41190
41191 FUNCTION PYRVI3(ID1,ID2,ID3)
41192
41193 IMPLICIT NONE
41194 DOUBLE PRECISION LO,HI,PYRVI3, PYRVG3, PYGAUS
41195 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
41196 INTEGER ID1,ID2,ID3, IANTI, IDR, IDR2, KFR
41197 LOGICAL MFLAG,DCMASS
41198 EXTERNAL PYRVG3,PYGAUS
41199 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,5),IDR,IDR2,DCMASS,KFR(3)
41200 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
41201 SAVE/PYRVNV/,/PYRVPM/
41202C...Initialize mass and width information
41203 PYRVI3=0D0
41204 RM(0)=RMS(0)
41205 RM(1)=RMS(ID1)
41206 RM(2)=RMS(ID2)
41207 RM(3)=RMS(ID3)
41208 RESM(1)=RES(IDR,1)
41209 RESW(1)=RES(IDR,2)
41210 RESM(2)=RES(IDR2,1)
41211 RESW(2)=RES(IDR2,2)
41212C...A -> B and B -> A for antisparticles
41213 IANTI=NINT(RES(IDR,5))
41214 A(1)=AB(1+IANTI,NINT(RES(IDR,3)),NINT(RES(IDR,4)))
41215 B(1)=AB(2-IANTI,NINT(RES(IDR,3)),NINT(RES(IDR,4)))
41216 IANTI=NINT(RES(IDR2,5))
41217 A(2)=AB(1+IANTI,NINT(RES(IDR2,3)),NINT(RES(IDR2,4)))
41218 B(2)=AB(2-IANTI,NINT(RES(IDR2,3)),NINT(RES(IDR2,4)))
41219C...Boundaries and mass flag
41220 LO=(RM(1)+RM(2))**2
41221 HI=(RM(0)-RM(3))**2
41222 MFLAG=DCMASS
41223 PYRVI3=PYGAUS(PYRVG3,LO,HI,1D-2)
41224 RETURN
41225 END
41226
41227C*********************************************************************
41228
41229C...PYRVG1
41230C...Integrand for resonance contributions
41231
41232 FUNCTION PYRVG1(X)
41233
41234 IMPLICIT NONE
41235 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
41236 DOUBLE PRECISION X, RM, A, B, RESM, RESW, YMIN, YMAX, DELTAY,PYRVR
41237 DOUBLE PRECISION RVR,PYRVG1,E2,E3,C1,SQ1,SR1,SR2,A1,A2
41238 LOGICAL MFLAG
41239 SAVE/PYRVPM/
41240 RVR=PYRVR(X,RESM(1),RESW(1))
41241 C1=2D0*SQRT(MAX(0D0,X))
41242 IF (.NOT.MFLAG) THEN
41243 E2=X/C1
41244 E3=(RM(0)**2-X)/C1
41245 DELTAY=4D0*E2*E3
41246 PYRVG1=DELTAY*RVR*X*(A(1)**2+B(1)**2)*(RM(0)**2-X)
41247 ELSE
41248 E2=(X-RM(1)**2+RM(2)**2)/C1
41249 E3=(RM(0)**2-X-RM(3)**2)/C1
41250 SQ1=(E2+E3)**2
41251 SR1=SQRT(MAX(0D0,E2**2-RM(2)**2))
41252 SR2=SQRT(MAX(0D0,E3**2-RM(3)**2))
41253 YMIN=SQ1-(SR1+SR2)**2
41254 YMAX=SQ1-(SR1-SR2)**2
41255 DELTAY=YMAX-YMIN
41256 A1=4*A(1)*B(1)*RM(3)*RM(0)
41257 A2=(A(1)**2+B(1)**2)*(RM(0)**2+RM(3)**2-X)
41258 PYRVG1=DELTAY*RVR*(X-RM(1)**2-RM(2)**2)*(A1+A2)
41259 ENDIF
41260 RETURN
41261 END
41262
41263C*********************************************************************
41264
41265C...PYRVG2
41266C...Integrand for L-R interference contributions
41267
41268 FUNCTION PYRVG2(X)
41269
41270 IMPLICIT NONE
41271 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
41272 DOUBLE PRECISION X, RM, A, B, RESM, RESW, YMIN, YMAX, DELTAY,PYRVS
41273 DOUBLE PRECISION RVS,PYRVG2,E2,E3,C1,SQ1,SR1,SR2
41274 LOGICAL MFLAG
41275 SAVE/PYRVPM/
41276 C1=2D0*SQRT(MAX(0D0,X))
41277 RVS=PYRVS(X,X,RESM(1),RESW(1),RESM(2),RESW(2))
41278 IF (.NOT.MFLAG) THEN
41279 E2=X/C1
41280 E3=(RM(0)**2-X)/C1
41281 DELTAY=4D0*E2*E3
41282 PYRVG2=DELTAY*RVS*X*(A(1)*A(2)+B(1)*B(2))*(RM(0)**2-X)
41283 ELSE
41284 E2=(X-RM(1)**2+RM(2)**2)/C1
41285 E3=(RM(0)**2-X-RM(3)**2)/C1
41286 SQ1=(E2+E3)**2
41287 SR1=SQRT(MAX(0D0,E2**2-RM(2)**2))
41288 SR2=SQRT(MAX(0D0,E3**2-RM(3)**2))
41289 YMIN=SQ1-(SR1+SR2)**2
41290 YMAX=SQ1-(SR1-SR2)**2
41291 DELTAY=YMAX-YMIN
41292 PYRVG2=DELTAY*RVS*(X-RM(1)**2-RM(2)**2)*((A(1)*A(2)
41293 & + B(1)*B(2))*(RM(0)**2+RM(3)**2-X)
41294 & + 2*(A(1)*B(2)+A(2)*B(1))*RM(3)*RM(0))
41295 ENDIF
41296 RETURN
41297 END
41298
41299C*********************************************************************
41300
41301C...PYRVG3
41302C...Function to do Y integration over true interference contributions
41303
41304 FUNCTION PYRVG3(X)
41305
41306 IMPLICIT NONE
41307 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
41308C...Second Dalitz variable for PYRVG4
41309 COMMON/PYG2DX/X1
41310 DOUBLE PRECISION RM, A, B, RESM, RESW, X, X1
41311 DOUBLE PRECISION E2, E3, C1, SQ1, SR1, SR2, YMIN, YMAX
41312 DOUBLE PRECISION PYRVG3, PYRVG4, PYGAUS
41313 LOGICAL MFLAG
41314 EXTERNAL PYGAUS,PYRVG4
41315 SAVE/PYRVPM/,/PYG2DX/
41316 C1=2D0*SQRT(MAX(0D0,X))
41317 X1=X
41318 IF (.NOT.MFLAG) THEN
41319 E2=X/C1
41320 E3=(RM(0)**2-X)/C1
41321 YMIN=0D0
41322 YMAX=4D0*E2*E3
41323 ELSE
41324 E2=(X-RM(1)**2+RM(2)**2)/C1
41325 E3=(RM(0)**2-X-RM(3)**2)/C1
41326 SQ1=(E2+E3)**2
41327 SR1=SQRT(MAX(0D0,E2**2-RM(2)**2))
41328 SR2=SQRT(MAX(0D0,E3**2-RM(3)**2))
41329 YMIN=SQ1-(SR1+SR2)**2
41330 YMAX=SQ1-(SR1-SR2)**2
41331 ENDIF
41332 PYRVG3=PYGAUS(PYRVG4,YMIN,YMAX,1D-2)
41333 RETURN
41334 END
41335
41336C*********************************************************************
41337
41338C...PYRVG4
41339C...Integrand for true intereference contributions
41340
41341 FUNCTION PYRVG4(Y)
41342
41343 IMPLICIT NONE
41344 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
41345 COMMON/PYG2DX/X
41346 DOUBLE PRECISION X, Y, PYRVG4, RM, A, B, RESM, RESW, RVS, PYRVS
41347 LOGICAL MFLAG
41348 SAVE /PYRVPM/,/PYG2DX/
41349 PYRVG4=0D0
41350 RVS=PYRVS(X,Y,RESM(1),RESW(1),RESM(2),RESW(2))
41351 IF (.NOT.MFLAG) THEN
41352 PYRVG4=RVS*B(1)*B(2)*X*Y
41353 ELSE
41354 PYRVG4=RVS*(RM(1)*RM(3)*A(1)*A(2)*(X+Y-RM(1)**2-RM(3)**2)
41355 & + RM(1)*RM(0)*B(1)*A(2)*(Y-RM(2)**2-RM(3)**2)
41356 & + RM(3)*RM(0)*A(1)*B(2)*(X-RM(1)**2-RM(2)**2)
41357 & + B(1)*B(2)*(X*Y-(RM(1)*RM(3))**2-(RM(0)*RM(2))**2))
41358 ENDIF
41359 RETURN
41360 END
41361
41362C*********************************************************************
41363
41364C...PYRVR
41365C...Breit-Wigner for resonance contributions
41366
41367 FUNCTION PYRVR(Mab2,RM,RW)
41368
41369 IMPLICIT NONE
41370 DOUBLE PRECISION Mab2,RM,RW,PYRVR
41371 PYRVR = 1D0/((Mab2-RM**2)**2+RM**2*RW**2)
41372 RETURN
41373 END
41374
41375C*********************************************************************
41376
41377C...PYRVS
41378C...Interference function
41379
41380 FUNCTION PYRVS(X,Y,M1,W1,M2,W2)
41381
41382 IMPLICIT NONE
41383 DOUBLE PRECISION X, Y, PYRVS, PYRVR, M1, M2, W1, W2
41384 PYRVS = PYRVR(X,M1,W1)*PYRVR(Y,M2,W2)*((X-M1**2)*(Y-M2**2)
41385 & +W1*W2*M1*M2)
41386 RETURN
41387 END
41388
41389C*********************************************************************
41390
41391C...PY1ENT
41392C...Stores one parton/particle in commonblock PYJETS.
41393
41394 SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
41395
41396C...Double precision and integer declarations.
41397 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41398 IMPLICIT INTEGER(I-N)
41399 INTEGER PYK,PYCHGE,PYCOMP
41400C...Commonblocks.
41401 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
41402 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41403 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41404 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
41405
41406C...Standard checks.
41407 MSTU(28)=0
41408 IF(MSTU(12).GE.1) CALL PYLIST(0)
41409 IPA=MAX(1,IABS(IP))
41410 IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
41411 &'(PY1ENT:) writing outside PYJETS memory')
41412 KC=PYCOMP(KF)
41413 IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
41414
41415C...Find mass. Reset K, P and V vectors.
41416 PM=0D0
41417 IF(MSTU(10).EQ.1) PM=P(IPA,5)
41418 IF(MSTU(10).GE.2) PM=PYMASS(KF)
41419 DO 100 J=1,5
41420 K(IPA,J)=0
41421 P(IPA,J)=0D0
41422 V(IPA,J)=0D0
41423 100 CONTINUE
41424
41425C...Store parton/particle in K and P vectors.
41426 K(IPA,1)=1
41427 IF(IP.LT.0) K(IPA,1)=2
41428 K(IPA,2)=KF
41429 P(IPA,5)=PM
41430 P(IPA,4)=MAX(PE,PM)
41431 PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
41432 P(IPA,1)=PA*SIN(THE)*COS(PHI)
41433 P(IPA,2)=PA*SIN(THE)*SIN(PHI)
41434 P(IPA,3)=PA*COS(THE)
41435
41436C...Set N. Optionally fragment/decay.
41437 N=IPA
41438 IF(IP.EQ.0) CALL PYEXEC
41439
41440 RETURN
41441 END
41442
41443C*********************************************************************
41444
41445C...PY2ENT
41446C...Stores two partons/particles in their CM frame,
41447C...with the first along the +z axis.
41448
41449 SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
41450
41451C...Double precision and integer declarations.
41452 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41453 IMPLICIT INTEGER(I-N)
41454 INTEGER PYK,PYCHGE,PYCOMP
41455C...Commonblocks.
41456 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
41457 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41458 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41459 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
41460
41461C...Standard checks.
41462 MSTU(28)=0
41463 IF(MSTU(12).GE.1) CALL PYLIST(0)
41464 IPA=MAX(1,IABS(IP))
41465 IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
41466 &'(PY2ENT:) writing outside PYJETS memory')
41467 KC1=PYCOMP(KF1)
41468 KC2=PYCOMP(KF2)
41469 IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
41470 &'(PY2ENT:) unknown flavour code')
41471
41472C...Find masses. Reset K, P and V vectors.
41473 PM1=0D0
41474 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
41475 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
41476 PM2=0D0
41477 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
41478 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
41479 DO 110 I=IPA,IPA+1
41480 DO 100 J=1,5
41481 K(I,J)=0
41482 P(I,J)=0D0
41483 V(I,J)=0D0
41484 100 CONTINUE
41485 110 CONTINUE
41486
41487C...Check flavours.
41488 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
41489 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
41490 IF(MSTU(19).EQ.1) THEN
41491 MSTU(19)=0
41492 ELSE
41493 IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
41494 & '(PY2ENT:) unphysical flavour combination')
41495 ENDIF
41496 K(IPA,2)=KF1
41497 K(IPA+1,2)=KF2
41498
41499C...Store partons/particles in K vectors for normal case.
41500 IF(IP.GE.0) THEN
41501 K(IPA,1)=1
41502 IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
41503 K(IPA+1,1)=1
41504
41505C...Store partons in K vectors for parton shower evolution.
41506 ELSE
41507 K(IPA,1)=3
41508 K(IPA+1,1)=3
41509 K(IPA,4)=MSTU(5)*(IPA+1)
41510 K(IPA,5)=K(IPA,4)
41511 K(IPA+1,4)=MSTU(5)*IPA
41512 K(IPA+1,5)=K(IPA+1,4)
41513 ENDIF
41514
41515C...Check kinematics and store partons/particles in P vectors.
41516 IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
41517 &'(PY2ENT:) energy smaller than sum of masses')
41518 PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/
41519 &(2D0*PECM)
41520 P(IPA,3)=PA
41521 P(IPA,4)=SQRT(PM1**2+PA**2)
41522 P(IPA,5)=PM1
41523 P(IPA+1,3)=-PA
41524 P(IPA+1,4)=SQRT(PM2**2+PA**2)
41525 P(IPA+1,5)=PM2
41526
41527C...Set N. Optionally fragment/decay.
41528 N=IPA+1
41529 IF(IP.EQ.0) CALL PYEXEC
41530
41531 RETURN
41532 END
41533
41534C*********************************************************************
41535
41536C...PY3ENT
41537C...Stores three partons or particles in their CM frame,
41538C...with the first along the +z axis and the third in the (x,z)
41539C...plane with x > 0.
41540
41541 SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
41542
41543C...Double precision and integer declarations.
41544 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41545 IMPLICIT INTEGER(I-N)
41546 INTEGER PYK,PYCHGE,PYCOMP
41547C...Commonblocks.
41548 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
41549 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41550 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41551 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
41552
41553C...Standard checks.
41554 MSTU(28)=0
41555 IF(MSTU(12).GE.1) CALL PYLIST(0)
41556 IPA=MAX(1,IABS(IP))
41557 IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
41558 &'(PY3ENT:) writing outside PYJETS memory')
41559 KC1=PYCOMP(KF1)
41560 KC2=PYCOMP(KF2)
41561 KC3=PYCOMP(KF3)
41562 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
41563 &'(PY3ENT:) unknown flavour code')
41564
41565C...Find masses. Reset K, P and V vectors.
41566 PM1=0D0
41567 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
41568 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
41569 PM2=0D0
41570 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
41571 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
41572 PM3=0D0
41573 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
41574 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
41575 DO 110 I=IPA,IPA+2
41576 DO 100 J=1,5
41577 K(I,J)=0
41578 P(I,J)=0D0
41579 V(I,J)=0D0
41580 100 CONTINUE
41581 110 CONTINUE
41582
41583C...Check flavours.
41584 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
41585 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
41586 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
41587 IF(MSTU(19).EQ.1) THEN
41588 MSTU(19)=0
41589 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
41590 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
41591 & KQ1+KQ3.EQ.4)) THEN
41592 ELSE
41593 CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
41594 ENDIF
41595 K(IPA,2)=KF1
41596 K(IPA+1,2)=KF2
41597 K(IPA+2,2)=KF3
41598
41599C...Store partons/particles in K vectors for normal case.
41600 IF(IP.GE.0) THEN
41601 K(IPA,1)=1
41602 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
41603 K(IPA+1,1)=1
41604 IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
41605 K(IPA+2,1)=1
41606
41607C...Store partons in K vectors for parton shower evolution.
41608 ELSE
41609 K(IPA,1)=3
41610 K(IPA+1,1)=3
41611 K(IPA+2,1)=3
41612 KCS=4
41613 IF(KQ1.EQ.-1) KCS=5
41614 K(IPA,KCS)=MSTU(5)*(IPA+1)
41615 K(IPA,9-KCS)=MSTU(5)*(IPA+2)
41616 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
41617 K(IPA+1,9-KCS)=MSTU(5)*IPA
41618 K(IPA+2,KCS)=MSTU(5)*IPA
41619 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
41620 ENDIF
41621
41622C...Check kinematics.
41623 MKERR=0
41624 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR.
41625 &0.5D0*X3*PECM.LE.PM3) MKERR=1
41626 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
41627 PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2))
41628 PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2))
41629 CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2)
41630 CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3)
41631 IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1
41632 CTHE3=MAX(-1D0,MIN(1D0,CTHE3))
41633 IF(MKERR.NE.0) CALL PYERRM(13,
41634 &'(PY3ENT:) unphysical kinematical variable setup')
41635
41636C...Store partons/particles in P vectors.
41637 P(IPA,3)=PA1
41638 P(IPA,4)=SQRT(PA1**2+PM1**2)
41639 P(IPA,5)=PM1
41640 P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2)
41641 P(IPA+2,3)=PA3*CTHE3
41642 P(IPA+2,4)=SQRT(PA3**2+PM3**2)
41643 P(IPA+2,5)=PM3
41644 P(IPA+1,1)=-P(IPA+2,1)
41645 P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
41646 P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
41647 P(IPA+1,5)=PM2
41648
41649C...Set N. Optionally fragment/decay.
41650 N=IPA+2
41651 IF(IP.EQ.0) CALL PYEXEC
41652
41653 RETURN
41654 END
41655
41656C*********************************************************************
41657
41658C...PY4ENT
41659C...Stores four partons or particles in their CM frame, with
41660C...the first along the +z axis, the last in the xz plane with x > 0
41661C...and the second having y < 0 and y > 0 with equal probability.
41662
41663 SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
41664
41665C...Double precision and integer declarations.
41666 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41667 IMPLICIT INTEGER(I-N)
41668 INTEGER PYK,PYCHGE,PYCOMP
41669C...Commonblocks.
41670 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
41671 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41672 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41673 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
41674
41675C...Standard checks.
41676 MSTU(28)=0
41677 IF(MSTU(12).GE.1) CALL PYLIST(0)
41678 IPA=MAX(1,IABS(IP))
41679 IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
41680 &'(PY4ENT:) writing outside PYJETS momory')
41681 KC1=PYCOMP(KF1)
41682 KC2=PYCOMP(KF2)
41683 KC3=PYCOMP(KF3)
41684 KC4=PYCOMP(KF4)
41685 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
41686 &'(PY4ENT:) unknown flavour code')
41687
41688C...Find masses. Reset K, P and V vectors.
41689 PM1=0D0
41690 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
41691 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
41692 PM2=0D0
41693 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
41694 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
41695 PM3=0D0
41696 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
41697 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
41698 PM4=0D0
41699 IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
41700 IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
41701 DO 110 I=IPA,IPA+3
41702 DO 100 J=1,5
41703 K(I,J)=0
41704 P(I,J)=0D0
41705 V(I,J)=0D0
41706 100 CONTINUE
41707 110 CONTINUE
41708
41709C...Check flavours.
41710 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
41711 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
41712 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
41713 KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
41714 IF(MSTU(19).EQ.1) THEN
41715 MSTU(19)=0
41716 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
41717 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
41718 & KQ1+KQ4.EQ.4)) THEN
41719 ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
41720 & THEN
41721 ELSE
41722 CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
41723 ENDIF
41724 K(IPA,2)=KF1
41725 K(IPA+1,2)=KF2
41726 K(IPA+2,2)=KF3
41727 K(IPA+3,2)=KF4
41728
41729C...Store partons/particles in K vectors for normal case.
41730 IF(IP.GE.0) THEN
41731 K(IPA,1)=1
41732 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
41733 K(IPA+1,1)=1
41734 IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
41735 & K(IPA+1,1)=2
41736 K(IPA+2,1)=1
41737 IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
41738 K(IPA+3,1)=1
41739
41740C...Store partons for parton shower evolution from q-g-g-qbar or
41741C...g-g-g-g event.
41742 ELSEIF(KQ1+KQ2.NE.0) THEN
41743 K(IPA,1)=3
41744 K(IPA+1,1)=3
41745 K(IPA+2,1)=3
41746 K(IPA+3,1)=3
41747 KCS=4
41748 IF(KQ1.EQ.-1) KCS=5
41749 K(IPA,KCS)=MSTU(5)*(IPA+1)
41750 K(IPA,9-KCS)=MSTU(5)*(IPA+3)
41751 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
41752 K(IPA+1,9-KCS)=MSTU(5)*IPA
41753 K(IPA+2,KCS)=MSTU(5)*(IPA+3)
41754 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
41755 K(IPA+3,KCS)=MSTU(5)*IPA
41756 K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
41757
41758C...Store partons for parton shower evolution from q-qbar-q-qbar event.
41759 ELSE
41760 K(IPA,1)=3
41761 K(IPA+1,1)=3
41762 K(IPA+2,1)=3
41763 K(IPA+3,1)=3
41764 K(IPA,4)=MSTU(5)*(IPA+1)
41765 K(IPA,5)=K(IPA,4)
41766 K(IPA+1,4)=MSTU(5)*IPA
41767 K(IPA+1,5)=K(IPA+1,4)
41768 K(IPA+2,4)=MSTU(5)*(IPA+3)
41769 K(IPA+2,5)=K(IPA+2,4)
41770 K(IPA+3,4)=MSTU(5)*(IPA+2)
41771 K(IPA+3,5)=K(IPA+3,4)
41772 ENDIF
41773
41774C...Check kinematics.
41775 MKERR=0
41776 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR.
41777 &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4)
41778 &MKERR=1
41779 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
41780 PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2))
41781 PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2))
41782 X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
41783 CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4)
41784 IF(ABS(CTHE4).GE.1.002D0) MKERR=1
41785 CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
41786 STHE4=SQRT(1D0-CTHE4**2)
41787 CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2)
41788 IF(ABS(CTHE2).GE.1.002D0) MKERR=1
41789 CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
41790 STHE2=SQRT(1D0-CTHE2**2)
41791 CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/
41792 &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4)
41793 IF(ABS(CPHI2).GE.1.05D0) MKERR=1
41794 CPHI2=MAX(-1D0,MIN(1D0,CPHI2))
41795 IF(MKERR.EQ.1) CALL PYERRM(13,
41796 &'(PY4ENT:) unphysical kinematical variable setup')
41797
41798C...Store partons/particles in P vectors.
41799 P(IPA,3)=PA1
41800 P(IPA,4)=SQRT(PA1**2+PM1**2)
41801 P(IPA,5)=PM1
41802 P(IPA+3,1)=PA4*STHE4
41803 P(IPA+3,3)=PA4*CTHE4
41804 P(IPA+3,4)=SQRT(PA4**2+PM4**2)
41805 P(IPA+3,5)=PM4
41806 P(IPA+1,1)=PA2*STHE2*CPHI2
41807 P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0)
41808 P(IPA+1,3)=PA2*CTHE2
41809 P(IPA+1,4)=SQRT(PA2**2+PM2**2)
41810 P(IPA+1,5)=PM2
41811 P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
41812 P(IPA+2,2)=-P(IPA+1,2)
41813 P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
41814 P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
41815 P(IPA+2,5)=PM3
41816
41817C...Set N. Optionally fragment/decay.
41818 N=IPA+3
41819 IF(IP.EQ.0) CALL PYEXEC
41820
41821 RETURN
41822 END
41823
41824C*********************************************************************
41825
41826C...PY2FRM
41827C...An interface from a two-fermion generator to include
41828C...parton showers and hadronization.
41829
41830 SUBROUTINE PY2FRM(IRAD,ITAU,ICOM)
41831
41832C...Double precision and integer declarations.
41833 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41834 IMPLICIT INTEGER(I-N)
41835 INTEGER PYK,PYCHGE,PYCOMP
41836C...Commonblocks.
41837 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
41838 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41839 SAVE /PYJETS/,/PYDAT1/
41840C...Local arrays.
41841 DIMENSION IJOIN(2),INTAU(2)
41842
41843C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
41844 IF(ICOM.EQ.0) THEN
41845 MSTU(28)=0
41846 CALL PYHEPC(2)
41847 ENDIF
41848
41849C...Loop through entries and pick up all final fermions/antifermions.
41850 I1=0
41851 I2=0
41852 DO 100 I=1,N
41853 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
41854 KFA=IABS(K(I,2))
41855 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
41856 IF(K(I,2).GT.0) THEN
41857 IF(I1.EQ.0) THEN
41858 I1=I
41859 ELSE
41860 CALL PYERRM(16,'(PY2FRM:) more than one fermion')
41861 ENDIF
41862 ELSE
41863 IF(I2.EQ.0) THEN
41864 I2=I
41865 ELSE
41866 CALL PYERRM(16,'(PY2FRM:) more than one antifermion')
41867 ENDIF
41868 ENDIF
41869 ENDIF
41870 100 CONTINUE
41871
41872C...Check that event is arranged according to conventions.
41873 IF(I1.EQ.0.OR.I2.EQ.0) THEN
41874 CALL PYERRM(16,'(PY2FRM:) event contains too few fermions')
41875 ENDIF
41876 IF(I2.LT.I1) THEN
41877 CALL PYERRM(6,'(PY2FRM:) fermions arranged in wrong order')
41878 ENDIF
41879
41880C...Check whether fermion pair is quarks or leptons.
41881 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
41882 IQL12=1
41883 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
41884 IQL12=2
41885 ELSE
41886 CALL PYERRM(16,'(PY2FRM:) fermion pair inconsistent')
41887 ENDIF
41888
41889C...Decide whether to allow or not photon radiation in showers.
41890 MSTJ(41)=2
41891 IF(IRAD.EQ.0) MSTJ(41)=1
41892
41893C...Do colour joining and parton showers.
41894 IP1=I1
41895 IP2=I2
41896 IF(IQL12.EQ.1) THEN
41897 IJOIN(1)=IP1
41898 IJOIN(2)=IP2
41899 CALL PYJOIN(2,IJOIN)
41900 ENDIF
41901 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
41902 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
41903 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
41904 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
41905 ENDIF
41906
41907C...Do fragmentation and decays. Possibly except tau decay.
41908 IF(ITAU.EQ.0) THEN
41909 NTAU=0
41910 DO 110 I=1,N
41911 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
41912 NTAU=NTAU+1
41913 INTAU(NTAU)=I
41914 K(I,1)=11
41915 ENDIF
41916 110 CONTINUE
41917 ENDIF
41918 CALL PYEXEC
41919 IF(ITAU.EQ.0) THEN
41920 DO 120 I=1,NTAU
41921 K(INTAU(I),1)=1
41922 120 CONTINUE
41923 ENDIF
41924
41925C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
41926 IF(ICOM.EQ.0) THEN
41927 MSTU(28)=0
41928 CALL PYHEPC(1)
41929 ENDIF
41930
41931 END
41932
41933C*********************************************************************
41934
41935C...PY4FRM
41936C...An interface from a four-fermion generator to include
41937C...parton showers and hadronization.
41938
41939 SUBROUTINE PY4FRM(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)
41940
41941C...Double precision and integer declarations.
41942 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41943 IMPLICIT INTEGER(I-N)
41944 INTEGER PYK,PYCHGE,PYCOMP
41945C...Commonblocks.
41946 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
41947 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41948 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
41949 COMMON/PYINT1/MINT(400),VINT(400)
41950 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
41951C...Local arrays.
41952 DIMENSION IJOIN(2),INTAU(4)
41953
41954C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
41955 IF(ICOM.EQ.0) THEN
41956 MSTU(28)=0
41957 CALL PYHEPC(2)
41958 ENDIF
41959
41960C...Loop through entries and pick up all final fermions/antifermions.
41961 I1=0
41962 I2=0
41963 I3=0
41964 I4=0
41965 DO 100 I=1,N
41966 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
41967 KFA=IABS(K(I,2))
41968 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
41969 IF(K(I,2).GT.0) THEN
41970 IF(I1.EQ.0) THEN
41971 I1=I
41972 ELSEIF(I3.EQ.0) THEN
41973 I3=I
41974 ELSE
41975 CALL PYERRM(16,'(PY4FRM:) more than two fermions')
41976 ENDIF
41977 ELSE
41978 IF(I2.EQ.0) THEN
41979 I2=I
41980 ELSEIF(I4.EQ.0) THEN
41981 I4=I
41982 ELSE
41983 CALL PYERRM(16,'(PY4FRM:) more than two antifermions')
41984 ENDIF
41985 ENDIF
41986 ENDIF
41987 100 CONTINUE
41988
41989C...Check that event is arranged according to conventions.
41990 IF(I3.EQ.0.OR.I4.EQ.0) THEN
41991 CALL PYERRM(16,'(PY4FRM:) event contains too few fermions')
41992 ENDIF
41993 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
41994 CALL PYERRM(6,'(PY4FRM:) fermions arranged in wrong order')
41995 ENDIF
41996
41997C...Check which fermion pairs are quarks and which leptons.
41998 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
41999 IQL12=1
42000 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
42001 IQL12=2
42002 ELSE
42003 CALL PYERRM(16,'(PY4FRM:) first fermion pair inconsistent')
42004 ENDIF
42005 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
42006 IQL34=1
42007 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
42008 IQL34=2
42009 ELSE
42010 CALL PYERRM(16,'(PY4FRM:) second fermion pair inconsistent')
42011 ENDIF
42012
42013C...Decide whether to allow or not photon radiation in showers.
42014 MSTJ(41)=2
42015 IF(IRAD.EQ.0) MSTJ(41)=1
42016
42017C...Decide on dipole pairing.
42018 IP1=I1
42019 IP2=I2
42020 IP3=I3
42021 IP4=I4
42022 IF(IQL12.EQ.IQL34) THEN
42023 R1SQ=A1SQ
42024 R2SQ=A2SQ
42025 DELTA=ATOTSQ-A1SQ-A2SQ
42026 IF(ISTRAT.EQ.1) THEN
42027 IF(DELTA.GT.0D0) R1SQ=R1SQ+DELTA
42028 IF(DELTA.LT.0D0) R2SQ=MAX(0D0,R2SQ+DELTA)
42029 ELSEIF(ISTRAT.EQ.2) THEN
42030 IF(DELTA.GT.0D0) R2SQ=R2SQ+DELTA
42031 IF(DELTA.LT.0D0) R1SQ=MAX(0D0,R1SQ+DELTA)
42032 ENDIF
42033 IF(R2SQ.GT.PYR(0)*(R1SQ+R2SQ)) THEN
42034 IP2=I4
42035 IP4=I2
42036 ENDIF
42037 ENDIF
42038
42039C...If colour reconnection then bookkeep W+W- or Z0Z0
42040C...and copy q qbar q qbar consecutively.
42041 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
42042 K(N+1,1)=11
42043 K(N+1,3)=IP1
42044 K(N+1,4)=N+3
42045 K(N+1,5)=N+4
42046 K(N+2,1)=11
42047 K(N+2,3)=IP3
42048 K(N+2,4)=N+5
42049 K(N+2,5)=N+6
42050 IF(K(IP1,2)+K(IP2,2).EQ.0) THEN
42051 K(N+1,2)=23
42052 K(N+2,2)=23
42053 MINT(1)=22
42054 ELSEIF(PYCHGE(K(IP1,2)).GT.0) THEN
42055 K(N+1,2)=24
42056 K(N+2,2)=-24
42057 MINT(1)=25
42058 ELSE
42059 K(N+1,2)=-24
42060 K(N+2,2)=24
42061 MINT(1)=25
42062 ENDIF
42063 DO 110 J=1,5
42064 K(N+3,J)=K(IP1,J)
42065 K(N+4,J)=K(IP2,J)
42066 K(N+5,J)=K(IP3,J)
42067 K(N+6,J)=K(IP4,J)
42068 P(N+1,J)=P(IP1,J)+P(IP2,J)
42069 P(N+2,J)=P(IP3,J)+P(IP4,J)
42070 P(N+3,J)=P(IP1,J)
42071 P(N+4,J)=P(IP2,J)
42072 P(N+5,J)=P(IP3,J)
42073 P(N+6,J)=P(IP4,J)
42074 V(N+1,J)=V(IP1,J)
42075 V(N+2,J)=V(IP3,J)
42076 V(N+3,J)=V(IP1,J)
42077 V(N+4,J)=V(IP2,J)
42078 V(N+5,J)=V(IP3,J)
42079 V(N+6,J)=V(IP4,J)
42080 110 CONTINUE
42081 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
42082 & P(N+1,3)**2))
42083 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
42084 & P(N+2,3)**2))
42085 K(N+3,3)=N+1
42086 K(N+4,3)=N+1
42087 K(N+5,3)=N+2
42088 K(N+6,3)=N+2
42089C...Remove original q qbar q qbar and update counters.
42090 K(IP1,1)=K(IP1,1)+10
42091 K(IP2,1)=K(IP2,1)+10
42092 K(IP3,1)=K(IP3,1)+10
42093 K(IP4,1)=K(IP4,1)+10
42094 IW1=N+1
42095 IW2=N+2
42096 NSD1=N+2
42097 IP1=N+3
42098 IP2=N+4
42099 IP3=N+5
42100 IP4=N+6
42101 N=N+6
42102 ENDIF
42103
42104C...Do colour joinings and parton showers.
42105 IF(IQL12.EQ.1) THEN
42106 IJOIN(1)=IP1
42107 IJOIN(2)=IP2
42108 CALL PYJOIN(2,IJOIN)
42109 ENDIF
42110 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
42111 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
42112 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
42113 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
42114 ENDIF
42115 NAFT1=N
42116 IF(IQL34.EQ.1) THEN
42117 IJOIN(1)=IP3
42118 IJOIN(2)=IP4
42119 CALL PYJOIN(2,IJOIN)
42120 ENDIF
42121 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
42122 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
42123 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
42124 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
42125 ENDIF
42126
42127C...Optionally do colour reconnection.
42128 MINT(32)=0
42129 MSTI(32)=0
42130 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
42131 CALL PYRECO(IW1,IW2,NSD1,NAFT1)
42132 MSTI(32)=MINT(32)
42133 ENDIF
42134
42135C...Do fragmentation and decays. Possibly except tau decay.
42136 IF(ITAU.EQ.0) THEN
42137 NTAU=0
42138 DO 120 I=1,N
42139 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
42140 NTAU=NTAU+1
42141 INTAU(NTAU)=I
42142 K(I,1)=11
42143 ENDIF
42144 120 CONTINUE
42145 ENDIF
42146 CALL PYEXEC
42147 IF(ITAU.EQ.0) THEN
42148 DO 130 I=1,NTAU
42149 K(INTAU(I),1)=1
42150 130 CONTINUE
42151 ENDIF
42152
42153C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
42154 IF(ICOM.EQ.0) THEN
42155 MSTU(28)=0
42156 CALL PYHEPC(1)
42157 ENDIF
42158
42159 END
42160
42161C*********************************************************************
42162
42163C...PY6FRM
42164C...An interface from a six-fermion generator to include
42165C...parton showers and hadronization.
42166
42167 SUBROUTINE PY6FRM(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)
42168
42169C...Double precision and integer declarations.
42170 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42171 IMPLICIT INTEGER(I-N)
42172 INTEGER PYK,PYCHGE,PYCOMP
42173C...Commonblocks.
42174 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
42175 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42176 SAVE /PYJETS/,/PYDAT1/
42177C...Local arrays.
42178 DIMENSION IJOIN(2),INTAU(6),BETA(3),BETAO(3),BETAN(3)
42179
42180C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
42181 IF(ICOM.EQ.0) THEN
42182 MSTU(28)=0
42183 CALL PYHEPC(2)
42184 ENDIF
42185
42186C...Loop through entries and pick up all final fermions/antifermions.
42187 I1=0
42188 I2=0
42189 I3=0
42190 I4=0
42191 I5=0
42192 I6=0
42193 DO 100 I=1,N
42194 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
42195 KFA=IABS(K(I,2))
42196 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
42197 IF(K(I,2).GT.0) THEN
42198 IF(I1.EQ.0) THEN
42199 I1=I
42200 ELSEIF(I3.EQ.0) THEN
42201 I3=I
42202 ELSEIF(I5.EQ.0) THEN
42203 I5=I
42204 ELSE
42205 CALL PYERRM(16,'(PY6FRM:) more than three fermions')
42206 ENDIF
42207 ELSE
42208 IF(I2.EQ.0) THEN
42209 I2=I
42210 ELSEIF(I4.EQ.0) THEN
42211 I4=I
42212 ELSEIF(I6.EQ.0) THEN
42213 I6=I
42214 ELSE
42215 CALL PYERRM(16,'(PY6FRM:) more than three antifermions')
42216 ENDIF
42217 ENDIF
42218 ENDIF
42219 100 CONTINUE
42220
42221C...Check that event is arranged according to conventions.
42222 IF(I5.EQ.0.OR.I6.EQ.0) THEN
42223 CALL PYERRM(16,'(PY6FRM:) event contains too few fermions')
42224 ENDIF
42225 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3.OR.I5.LT.I4.OR.I6.LT.I5) THEN
42226 CALL PYERRM(6,'(PY6FRM:) fermions arranged in wrong order')
42227 ENDIF
42228
42229C...Check which fermion pairs are quarks and which leptons.
42230 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
42231 IQL12=1
42232 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
42233 IQL12=2
42234 ELSE
42235 CALL PYERRM(16,'(PY6FRM:) first fermion pair inconsistent')
42236 ENDIF
42237 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
42238 IQL34=1
42239 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
42240 IQL34=2
42241 ELSE
42242 CALL PYERRM(16,'(PY6FRM:) second fermion pair inconsistent')
42243 ENDIF
42244 IF(IABS(K(I5,2)).LT.10.AND.IABS(K(I6,2)).LT.10) THEN
42245 IQL56=1
42246 ELSEIF(IABS(K(I5,2)).GT.10.AND.IABS(K(I6,2)).GT.10) THEN
42247 IQL56=2
42248 ELSE
42249 CALL PYERRM(16,'(PY6FRM:) third fermion pair inconsistent')
42250 ENDIF
42251
42252C...Decide whether to allow or not photon radiation in showers.
42253 MSTJ(41)=2
42254 IF(IRAD.EQ.0) MSTJ(41)=1
42255
42256C...Allow dipole pairings only among leptons and quarks separately.
42257 P12D=P12
42258 P13D=0D0
42259 IF(IQL34.EQ.IQL56) P13D=P13
42260 P21D=0D0
42261 IF(IQL12.EQ.IQL34) P21D=P21
42262 P23D=0D0
42263 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P23D=P23
42264 P31D=0D0
42265 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P31D=P31
42266 P32D=0D0
42267 IF(IQL12.EQ.IQL56) P32D=P32
42268
42269C...Decide whether t+tbar.
42270 ITOP=0
42271 IF(PYR(0).LT.PTOP) THEN
42272 ITOP=1
42273
42274C...If t+tbar: reconstruct t's.
42275 IT=N+1
42276 ITB=N+2
42277 DO 110 J=1,5
42278 K(IT,J)=0
42279 K(ITB,J)=0
42280 P(IT,J)=P(I1,J)+P(I3,J)+P(I4,J)
42281 P(ITB,J)=P(I2,J)+P(I5,J)+P(I6,J)
42282 V(IT,J)=0D0
42283 V(ITB,J)=0D0
42284 110 CONTINUE
42285 K(IT,1)=1
42286 K(ITB,1)=1
42287 K(IT,2)=6
42288 K(ITB,2)=-6
42289 P(IT,5)=SQRT(MAX(0D0,P(IT,4)**2-P(IT,1)**2-P(IT,2)**2-
42290 & P(IT,3)**2))
42291 P(ITB,5)=SQRT(MAX(0D0,P(ITB,4)**2-P(ITB,1)**2-P(ITB,2)**2-
42292 & P(ITB,3)**2))
42293 N=N+2
42294
42295C...If t+tbar: colour join t's and let them shower.
42296 IJOIN(1)=IT
42297 IJOIN(2)=ITB
42298 CALL PYJOIN(2,IJOIN)
42299 PMTTS=(P(IT,4)+P(ITB,4))**2-(P(IT,1)+P(ITB,1))**2-
42300 & (P(IT,2)+P(ITB,2))**2-(P(IT,3)+P(ITB,3))**2
42301 CALL PYSHOW(IT,ITB,SQRT(MAX(0D0,PMTTS)))
42302
42303C...If t+tbar: pick up the t's after shower.
42304 ITNEW=IT
42305 ITBNEW=ITB
42306 DO 120 I=ITB+1,N
42307 IF(K(I,2).EQ.6) ITNEW=I
42308 IF(K(I,2).EQ.-6) ITBNEW=I
42309 120 CONTINUE
42310
42311C...If t+tbar: loop over two top systems.
42312 DO 200 IT1=1,2
42313 IF(IT1.EQ.1) THEN
42314 ITO=IT
42315 ITN=ITNEW
42316 IBO=I1
42317 IW1=I3
42318 IW2=I4
42319 ELSE
42320 ITO=ITB
42321 ITN=ITBNEW
42322 IBO=I2
42323 IW1=I5
42324 IW2=I6
42325 ENDIF
42326 IF(IABS(K(IBO,2)).NE.5) CALL PYERRM(6,
42327 & '(PY6FRM:) not b in t decay')
42328
42329C...If t+tbar: find boost from original to new top frame.
42330 DO 130 J=1,3
42331 BETAO(J)=P(ITO,J)/P(ITO,4)
42332 BETAN(J)=P(ITN,J)/P(ITN,4)
42333 130 CONTINUE
42334
42335C...If t+tbar: boost copy of b by t shower and connect it in colour.
42336 N=N+1
42337 IB=N
42338 K(IB,1)=3
42339 K(IB,2)=K(IBO,2)
42340 K(IB,3)=ITN
42341 DO 140 J=1,5
42342 P(IB,J)=P(IBO,J)
42343 V(IB,J)=0D0
42344 140 CONTINUE
42345 CALL PYROBO(IB,IB,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
42346 CALL PYROBO(IB,IB,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
42347 K(IB,4)=MSTU(5)*ITN
42348 K(IB,5)=MSTU(5)*ITN
42349 K(ITN,4)=K(ITN,4)+IB
42350 K(ITN,5)=K(ITN,5)+IB
42351 K(ITN,1)=K(ITN,1)+10
42352 K(IBO,1)=K(IBO,1)+10
42353
42354C...If t+tbar: construct W recoiling against b.
42355 N=N+1
42356 IW=N
42357 DO 150 J=1,5
42358 K(IW,J)=0
42359 V(IW,J)=0D0
42360 150 CONTINUE
42361 K(IW,1)=1
42362 KCHW=PYCHGE(K(IW1,2))+PYCHGE(K(IW2,2))
42363 IF(IABS(KCHW).EQ.3) THEN
42364 K(IW,2)=ISIGN(24,KCHW)
42365 ELSE
42366 CALL PYERRM(16,'(PY6FRM:) fermion pair inconsistent with W')
42367 ENDIF
42368 K(IW,3)=IW1
42369
42370C...If t+tbar: construct W momentum, including boost by t shower.
42371 DO 160 J=1,4
42372 P(IW,J)=P(IW1,J)+P(IW2,J)
42373 160 CONTINUE
42374 P(IW,5)=SQRT(MAX(0D0,P(IW,4)**2-P(IW,1)**2-P(IW,2)**2-
42375 & P(IW,3)**2))
42376 CALL PYROBO(IW,IW,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
42377 CALL PYROBO(IW,IW,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
42378
42379C...If t+tbar: boost b and W to top rest frame.
42380 DO 170 J=1,3
42381 BETA(J)=(P(IB,J)+P(IW,J))/(P(IB,4)+P(IW,4))
42382 170 CONTINUE
42383 CALL PYROBO(IB,IB,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
42384 CALL PYROBO(IW,IW,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
42385
42386C...If t+tbar: let b shower and pick up modified W.
42387 PMTS=(P(IB,4)+P(IW,4))**2-(P(IB,1)+P(IW,1))**2-
42388 & (P(IB,2)+P(IW,2))**2-(P(IB,3)+P(IW,3))**2
42389 CALL PYSHOW(IB,IW,SQRT(MAX(0D0,PMTS)))
42390 DO 180 I=IW,N
42391 IF(IABS(K(I,2)).EQ.24) IWM=I
42392 180 CONTINUE
42393
42394C...If t+tbar: take copy of W decay products.
42395 DO 190 J=1,5
42396 K(N+1,J)=K(IW1,J)
42397 P(N+1,J)=P(IW1,J)
42398 V(N+1,J)=V(IW1,J)
42399 K(N+2,J)=K(IW2,J)
42400 P(N+2,J)=P(IW2,J)
42401 V(N+2,J)=V(IW2,J)
42402 190 CONTINUE
42403 K(IW1,1)=K(IW1,1)+10
42404 K(IW2,1)=K(IW2,1)+10
42405 K(IWM,1)=K(IWM,1)+10
42406 K(IWM,4)=N+1
42407 K(IWM,5)=N+2
42408 K(N+1,3)=IWM
42409 K(N+2,3)=IWM
42410 IF(IT1.EQ.1) THEN
42411 I3=N+1
42412 I4=N+2
42413 ELSE
42414 I5=N+1
42415 I6=N+2
42416 ENDIF
42417 N=N+2
42418
42419C...If t+tbar: boost W decay products, first by effects of t shower,
42420C...then by those of b shower. b and its shower simple boost back.
42421 CALL PYROBO(N-1,N,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
42422 CALL PYROBO(N-1,N,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
42423 CALL PYROBO(N-1,N,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
42424 CALL PYROBO(N-1,N,0D0,0D0,-P(IW,1)/P(IW,4),
42425 & -P(IW,2)/P(IW,4),-P(IW,3)/P(IW,4))
42426 CALL PYROBO(N-1,N,0D0,0D0,P(IWM,1)/P(IWM,4),
42427 & P(IWM,2)/P(IWM,4),P(IWM,3)/P(IWM,4))
42428 CALL PYROBO(IB,IB,0D0,0D0,BETA(1),BETA(2),BETA(3))
42429 CALL PYROBO(IW,N,0D0,0D0,BETA(1),BETA(2),BETA(3))
42430 200 CONTINUE
42431 ENDIF
42432
42433C...Decide on dipole pairing.
42434 IP1=I1
42435 IP3=I3
42436 IP5=I5
42437 PRN=PYR(0)*(P12D+P13D+P21D+P23D+P31D+P32D)
42438 IF(ITOP.EQ.1.OR.PRN.LT.P12D) THEN
42439 IP2=I2
42440 IP4=I4
42441 IP6=I6
42442 ELSEIF(PRN.LT.P12D+P13D) THEN
42443 IP2=I2
42444 IP4=I6
42445 IP6=I4
42446 ELSEIF(PRN.LT.P12D+P13D+P21D) THEN
42447 IP2=I4
42448 IP4=I2
42449 IP6=I6
42450 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D) THEN
42451 IP2=I4
42452 IP4=I6
42453 IP6=I2
42454 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D+P31D) THEN
42455 IP2=I6
42456 IP4=I2
42457 IP6=I4
42458 ELSE
42459 IP2=I6
42460 IP4=I4
42461 IP6=I2
42462 ENDIF
42463
42464C...Do colour joinings and parton showers
42465C...(except ones already made for t+tbar).
42466 IF(ITOP.EQ.0) THEN
42467 IF(IQL12.EQ.1) THEN
42468 IJOIN(1)=IP1
42469 IJOIN(2)=IP2
42470 CALL PYJOIN(2,IJOIN)
42471 ENDIF
42472 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
42473 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
42474 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
42475 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
42476 ENDIF
42477 ENDIF
42478 IF(IQL34.EQ.1) THEN
42479 IJOIN(1)=IP3
42480 IJOIN(2)=IP4
42481 CALL PYJOIN(2,IJOIN)
42482 ENDIF
42483 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
42484 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
42485 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
42486 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
42487 ENDIF
42488 IF(IQL56.EQ.1) THEN
42489 IJOIN(1)=IP5
42490 IJOIN(2)=IP6
42491 CALL PYJOIN(2,IJOIN)
42492 ENDIF
42493 IF(IQL56.EQ.1.OR.IRAD.EQ.1) THEN
42494 PM56S=(P(IP5,4)+P(IP6,4))**2-(P(IP5,1)+P(IP6,1))**2-
42495 & (P(IP5,2)+P(IP6,2))**2-(P(IP5,3)+P(IP6,3))**2
42496 CALL PYSHOW(IP5,IP6,SQRT(MAX(0D0,PM56S)))
42497 ENDIF
42498
42499C...Do fragmentation and decays. Possibly except tau decay.
42500 IF(ITAU.EQ.0) THEN
42501 NTAU=0
42502 DO 210 I=1,N
42503 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
42504 NTAU=NTAU+1
42505 INTAU(NTAU)=I
42506 K(I,1)=11
42507 ENDIF
42508 210 CONTINUE
42509 ENDIF
42510 CALL PYEXEC
42511 IF(ITAU.EQ.0) THEN
42512 DO 220 I=1,NTAU
42513 K(INTAU(I),1)=1
42514 220 CONTINUE
42515 ENDIF
42516
42517C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
42518 IF(ICOM.EQ.0) THEN
42519 MSTU(28)=0
42520 CALL PYHEPC(1)
42521 ENDIF
42522
42523 END
42524
42525C*********************************************************************
42526
42527C...PY4JET
42528C...An interface from a four-parton generator to include
42529C...parton showers and hadronization.
42530
42531 SUBROUTINE PY4JET(PMAX,IRAD,ICOM)
42532
42533C...Double precision and integer declarations.
42534 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42535 IMPLICIT INTEGER(I-N)
42536 INTEGER PYK,PYCHGE,PYCOMP
42537C...Commonblocks.
42538 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
42539 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42540 SAVE /PYJETS/,/PYDAT1/
42541C...Local arrays.
42542 DIMENSION IJOIN(2),PTOT(4),BETA(3)
42543
42544C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
42545 IF(ICOM.EQ.0) THEN
42546 MSTU(28)=0
42547 CALL PYHEPC(2)
42548 ENDIF
42549
42550C...Loop through entries and pick up all final partons.
42551 I1=0
42552 I2=0
42553 I3=0
42554 I4=0
42555 DO 100 I=1,N
42556 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
42557 KFA=IABS(K(I,2))
42558 IF((KFA.GE.1.AND.KFA.LE.6).OR.KFA.EQ.21) THEN
42559 IF(K(I,2).GT.0.AND.K(I,2).LE.6) THEN
42560 IF(I1.EQ.0) THEN
42561 I1=I
42562 ELSEIF(I3.EQ.0) THEN
42563 I3=I
42564 ELSE
42565 CALL PYERRM(16,'(PY4JET:) more than two quarks')
42566 ENDIF
42567 ELSEIF(K(I,2).LT.0) THEN
42568 IF(I2.EQ.0) THEN
42569 I2=I
42570 ELSEIF(I4.EQ.0) THEN
42571 I4=I
42572 ELSE
42573 CALL PYERRM(16,'(PY4JET:) more than two antiquarks')
42574 ENDIF
42575 ELSE
42576 IF(I3.EQ.0) THEN
42577 I3=I
42578 ELSEIF(I4.EQ.0) THEN
42579 I4=I
42580 ELSE
42581 CALL PYERRM(16,'(PY4JET:) more than two gluons')
42582 ENDIF
42583 ENDIF
42584 ENDIF
42585 100 CONTINUE
42586
42587C...Check that event is arranged according to conventions.
42588 IF(I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0.OR.I4.EQ.0) THEN
42589 CALL PYERRM(16,'(PY4JET:) event contains too few partons')
42590 ENDIF
42591 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
42592 CALL PYERRM(6,'(PY4JET:) partons arranged in wrong order')
42593 ENDIF
42594
42595C...Check whether second pair are quarks or gluons.
42596 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
42597 IQG34=1
42598 ELSEIF(K(I3,2).EQ.21.AND.K(I4,2).EQ.21) THEN
42599 IQG34=2
42600 ELSE
42601 CALL PYERRM(16,'(PY4JET:) second parton pair inconsistent')
42602 ENDIF
42603
42604C...Boost partons to their cm frame.
42605 DO 110 J=1,4
42606 PTOT(J)=P(I1,J)+P(I2,J)+P(I3,J)+P(I4,J)
42607 110 CONTINUE
42608 ECM=SQRT(MAX(0D0,PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2))
42609 DO 120 J=1,3
42610 BETA(J)=PTOT(J)/PTOT(4)
42611 120 CONTINUE
42612 CALL PYROBO(I1,I1,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
42613 CALL PYROBO(I2,I2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
42614 CALL PYROBO(I3,I3,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
42615 CALL PYROBO(I4,I4,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
42616 NSAV=N
42617
42618C...Decide and set up shower history for q qbar q' qbar' events.
42619 IF(IQG34.EQ.1) THEN
42620 W1=PY4JTW(0,I1,I3,I4)
42621 W2=PY4JTW(0,I2,I3,I4)
42622 IF(W1.GT.PYR(0)*(W1+W2)) THEN
42623 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
42624 ELSE
42625 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
42626 ENDIF
42627
42628C...Decide and set up shower history for q qbar g g events.
42629 ELSE
42630 W1=PY4JTW(I1,I3,I2,I4)
42631 W2=PY4JTW(I1,I4,I2,I3)
42632 W3=PY4JTW(0,I3,I1,I4)
42633 W4=PY4JTW(0,I4,I1,I3)
42634 W5=PY4JTW(0,I3,I2,I4)
42635 W6=PY4JTW(0,I4,I2,I3)
42636 W7=PY4JTW(0,I1,I3,I4)
42637 W8=PY4JTW(0,I2,I3,I4)
42638 WR=(W1+W2+W3+W4+W5+W6+W7+W8)*PYR(0)
42639 IF(W1.GT.WR) THEN
42640 CALL PY4JTS(I1,I3,I2,I4,0,QMAX)
42641 ELSEIF(W1+W2.GT.WR) THEN
42642 CALL PY4JTS(I1,I4,I2,I3,0,QMAX)
42643 ELSEIF(W1+W2+W3.GT.WR) THEN
42644 CALL PY4JTS(0,I3,I1,I4,I2,QMAX)
42645 ELSEIF(W1+W2+W3+W4.GT.WR) THEN
42646 CALL PY4JTS(0,I4,I1,I3,I2,QMAX)
42647 ELSEIF(W1+W2+W3+W4+W5.GT.WR) THEN
42648 CALL PY4JTS(0,I3,I2,I4,I1,QMAX)
42649 ELSEIF(W1+W2+W3+W4+W5+W6.GT.WR) THEN
42650 CALL PY4JTS(0,I4,I2,I3,I1,QMAX)
42651 ELSEIF(W1+W2+W3+W4+W5+W6+W7.GT.WR) THEN
42652 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
42653 ELSE
42654 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
42655 ENDIF
42656 ENDIF
42657
42658C...Boost back original partons and mark them as deleted.
42659 CALL PYROBO(I1,I1,0D0,0D0,BETA(1),BETA(2),BETA(3))
42660 CALL PYROBO(I2,I2,0D0,0D0,BETA(1),BETA(2),BETA(3))
42661 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
42662 CALL PYROBO(I4,I4,0D0,0D0,BETA(1),BETA(2),BETA(3))
42663 K(I1,1)=K(I1,1)+10
42664 K(I2,1)=K(I2,1)+10
42665 K(I3,1)=K(I3,1)+10
42666 K(I4,1)=K(I4,1)+10
42667
42668C...Rotate shower initiating partons to be along z axis.
42669 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
42670 CALL PYROBO(NSAV+1,NSAV+6,0D0,-PHI,0D0,0D0,0D0)
42671 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
42672 CALL PYROBO(NSAV+1,NSAV+6,-THE,0D0,0D0,0D0,0D0)
42673
42674C...Set up copy of shower initiating partons as on mass shell.
42675 DO 140 I=N+1,N+2
42676 DO 130 J=1,5
42677 K(I,J)=0
42678 P(I,J)=0D0
42679 V(I,J)=V(I1,J)
42680 130 CONTINUE
42681 K(I,1)=1
42682 K(I,2)=K(I-6,2)
42683 140 CONTINUE
42684 IF(K(NSAV+1,2).EQ.K(I1,2)) THEN
42685 K(N+1,3)=I1
42686 P(N+1,5)=P(I1,5)
42687 K(N+2,3)=I2
42688 P(N+2,5)=P(I2,5)
42689 ELSE
42690 K(N+1,3)=I2
42691 P(N+1,5)=P(I2,5)
42692 K(N+2,3)=I1
42693 P(N+2,5)=P(I1,5)
42694 ENDIF
42695 PABS=SQRT(MAX(0D0,(ECM**2-P(N+1,5)**2-P(N+2,5)**2)**2-
42696 &(2D0*P(N+1,5)*P(N+2,5))**2))/(2D0*ECM)
42697 P(N+1,3)=PABS
42698 P(N+1,4)=SQRT(PABS**2+P(N+1,5)**2)
42699 P(N+2,3)=-PABS
42700 P(N+2,4)=SQRT(PABS**2+P(N+2,5)**2)
42701 N=N+2
42702
42703C...Decide whether to allow or not photon radiation in showers.
42704C...Connect up colours.
42705 MSTJ(41)=2
42706 IF(IRAD.EQ.0) MSTJ(41)=1
42707 IJOIN(1)=N-1
42708 IJOIN(2)=N
42709 CALL PYJOIN(2,IJOIN)
42710
42711C...Decide on maximum virtuality and do parton shower.
42712 IF(PMAX.LT.PARJ(82)) THEN
42713 PQMAX=QMAX
42714 ELSE
42715 PQMAX=PMAX
42716 ENDIF
42717 CALL PYSHOW(NSAV+1,-8,PQMAX)
42718
42719C...Rotate and boost back system.
42720 CALL PYROBO(NSAV+1,N,THE,PHI,BETA(1),BETA(2),BETA(3))
42721
42722C...Do fragmentation and decays.
42723 CALL PYEXEC
42724
42725C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
42726 IF(ICOM.EQ.0) THEN
42727 MSTU(28)=0
42728 CALL PYHEPC(1)
42729 ENDIF
42730
42731 RETURN
42732 END
42733
42734C*********************************************************************
42735
42736C...PY4JTW
42737C...Auxiliary to PY4JET, to evaluate weight of configuration.
42738
42739 FUNCTION PY4JTW(IA1,IA2,IA3,IA4)
42740
42741C...Double precision and integer declarations.
42742 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42743 IMPLICIT INTEGER(I-N)
42744 INTEGER PYK,PYCHGE,PYCOMP
42745C...Commonblocks.
42746 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
42747 SAVE /PYJETS/
42748
42749C...First case: when both original partons radiate.
42750C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4.
42751 IF(IA1.NE.0) THEN
42752 DO 100 J=1,4
42753 P(N+1,J)=P(IA1,J)+P(IA2,J)
42754 P(N+2,J)=P(IA3,J)+P(IA4,J)
42755 100 CONTINUE
42756 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
42757 & P(N+1,3)**2))
42758 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
42759 & P(N+2,3)**2))
42760 Z1=P(IA1,4)/P(N+1,4)
42761 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-P(IA1,5)**2)
42762 Z2=P(IA3,4)/P(N+2,4)
42763 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-P(IA3,5)**2)
42764
42765C...Second case: when one original parton radiates to three.
42766C...IA1 = 0: N+1 -> IA2 + N+2, N+2 -> IA3 + IA4.
42767 ELSE
42768 DO 110 J=1,4
42769 P(N+2,J)=P(IA3,J)+P(IA4,J)
42770 P(N+1,J)=P(N+2,J)+P(IA2,J)
42771 110 CONTINUE
42772 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
42773 & P(N+1,3)**2))
42774 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
42775 & P(N+2,3)**2))
42776 IF(K(IA2,2).EQ.21) THEN
42777 Z1=P(N+2,4)/P(N+1,4)
42778 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
42779 & P(IA3,5)**2)
42780 ELSE
42781 Z1=P(IA2,4)/P(N+1,4)
42782 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
42783 & P(IA2,5)**2)
42784 ENDIF
42785 Z2=P(IA3,4)/P(N+2,4)
42786 IF(K(IA2,2).EQ.21) THEN
42787 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-
42788 & P(IA3,5)**2)
42789 ELSEIF(K(IA3,2).EQ.21) THEN
42790 WT2=3D0*((1D0-Z2*(1D0-Z2))**2/(Z2*(1D0-Z2)))/P(N+2,5)**2
42791 ELSE
42792 WT2=0.5D0*(Z2**2+(1D0-Z2)**2)
42793 ENDIF
42794 ENDIF
42795
42796C...Total weight.
42797 PY4JTW=WT1*WT2
42798
42799 RETURN
42800 END
42801
42802C*********************************************************************
42803
42804C...PY4JTS
42805C...Auxiliary to PY4JET, to set up chosen configuration.
42806
42807 SUBROUTINE PY4JTS(IA1,IA2,IA3,IA4,IA5,QMAX)
42808
42809C...Double precision and integer declarations.
42810 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42811 IMPLICIT INTEGER(I-N)
42812 INTEGER PYK,PYCHGE,PYCOMP
42813C...Commonblocks.
42814 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
42815 SAVE /PYJETS/
42816
42817C...Reset info.
42818 DO 110 I=N+1,N+6
42819 DO 100 J=1,5
42820 K(I,J)=0
42821 V(I,J)=V(IA2,J)
42822 100 CONTINUE
42823 K(I,1)=16
42824 110 CONTINUE
42825
42826C...First case: when both original partons radiate.
42827C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
42828 IF(IA1.NE.0) THEN
42829
42830C...Set up flavour and history pointers for new partons.
42831 K(N+1,2)=K(IA1,2)
42832 K(N+2,2)=K(IA3,2)
42833 K(N+3,2)=K(IA1,2)
42834 K(N+4,2)=K(IA2,2)
42835 K(N+5,2)=K(IA3,2)
42836 K(N+6,2)=K(IA4,2)
42837 K(N+1,3)=IA1
42838 K(N+1,4)=N+3
42839 K(N+1,5)=N+4
42840 K(N+2,3)=IA3
42841 K(N+2,4)=N+5
42842 K(N+2,5)=N+6
42843 K(N+3,3)=N+1
42844 K(N+4,3)=N+1
42845 K(N+5,3)=N+2
42846 K(N+6,3)=N+2
42847
42848C...Set up momenta for new partons.
42849 DO 120 J=1,5
42850 P(N+1,J)=P(IA1,J)+P(IA2,J)
42851 P(N+2,J)=P(IA3,J)+P(IA4,J)
42852 P(N+3,J)=P(IA1,J)
42853 P(N+4,J)=P(IA2,J)
42854 P(N+5,J)=P(IA3,J)
42855 P(N+6,J)=P(IA4,J)
42856 120 CONTINUE
42857 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
42858 & P(N+1,3)**2))
42859 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
42860 & P(N+2,3)**2))
42861 QMAX=MIN(P(N+1,5),P(N+2,5))
42862
42863C...Second case: q radiates twice.
42864C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
42865C...IA5=N+2 does not radiate.
42866 ELSEIF(K(IA2,2).EQ.21) THEN
42867
42868C...Set up flavour and history pointers for new partons.
42869 K(N+1,2)=K(IA3,2)
42870 K(N+2,2)=K(IA5,2)
42871 K(N+3,2)=K(IA3,2)
42872 K(N+4,2)=K(IA2,2)
42873 K(N+5,2)=K(IA3,2)
42874 K(N+6,2)=K(IA4,2)
42875 K(N+1,3)=IA3
42876 K(N+1,4)=N+3
42877 K(N+1,5)=N+4
42878 K(N+2,3)=IA5
42879 K(N+3,3)=N+1
42880 K(N+3,4)=N+5
42881 K(N+3,5)=N+6
42882 K(N+4,3)=N+1
42883 K(N+5,3)=N+3
42884 K(N+6,3)=N+3
42885
42886C...Set up momenta for new partons.
42887 DO 130 J=1,5
42888 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
42889 P(N+2,J)=P(IA5,J)
42890 P(N+3,J)=P(IA3,J)+P(IA4,J)
42891 P(N+4,J)=P(IA2,J)
42892 P(N+5,J)=P(IA3,J)
42893 P(N+6,J)=P(IA4,J)
42894 130 CONTINUE
42895 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
42896 & P(N+1,3)**2))
42897 P(N+3,5)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,1)**2-P(N+3,2)**2-
42898 & P(N+3,3)**2))
42899 QMAX=P(N+3,5)
42900
42901C...Third case: q radiates g, g branches.
42902C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
42903C...IA5=N+2 does not radiate.
42904 ELSE
42905
42906C...Set up flavour and history pointers for new partons.
42907 K(N+1,2)=K(IA2,2)
42908 K(N+2,2)=K(IA5,2)
42909 K(N+3,2)=K(IA2,2)
42910 K(N+4,2)=21
42911 K(N+5,2)=K(IA3,2)
42912 K(N+6,2)=K(IA4,2)
42913 K(N+1,3)=IA2
42914 K(N+1,4)=N+3
42915 K(N+1,5)=N+4
42916 K(N+2,3)=IA5
42917 K(N+3,3)=N+1
42918 K(N+4,3)=N+1
42919 K(N+4,4)=N+5
42920 K(N+4,5)=N+6
42921 K(N+5,3)=N+4
42922 K(N+6,3)=N+4
42923
42924C...Set up momenta for new partons.
42925 DO 140 J=1,5
42926 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
42927 P(N+2,J)=P(IA5,J)
42928 P(N+3,J)=P(IA2,J)
42929 P(N+4,J)=P(IA3,J)+P(IA4,J)
42930 P(N+5,J)=P(IA3,J)
42931 P(N+6,J)=P(IA4,J)
42932 140 CONTINUE
42933 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
42934 & P(N+1,3)**2))
42935 P(N+4,5)=SQRT(MAX(0D0,P(N+4,4)**2-P(N+4,1)**2-P(N+4,2)**2-
42936 & P(N+4,3)**2))
42937 QMAX=P(N+4,5)
42938
42939 ENDIF
42940 N=N+6
42941
42942 RETURN
42943 END
42944
42945C*********************************************************************
42946
42947C...PYJOIN
42948C...Connects a sequence of partons with colour flow indices,
42949C...as required for subsequent shower evolution (or other operations).
42950
42951 SUBROUTINE PYJOIN(NJOIN,IJOIN)
42952
42953C...Double precision and integer declarations.
42954 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42955 IMPLICIT INTEGER(I-N)
42956 INTEGER PYK,PYCHGE,PYCOMP
42957C...Commonblocks.
42958 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
42959 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42960 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42961 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
42962C...Local array.
42963 DIMENSION IJOIN(*)
42964
42965C...Check that partons are of right types to be connected.
42966 IF(NJOIN.LT.2) GOTO 120
42967 KQSUM=0
42968 DO 100 IJN=1,NJOIN
42969 I=IJOIN(IJN)
42970 IF(I.LE.0.OR.I.GT.N) GOTO 120
42971 IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
42972 KC=PYCOMP(K(I,2))
42973 IF(KC.EQ.0) GOTO 120
42974 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
42975 IF(KQ.EQ.0) GOTO 120
42976 IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
42977 IF(KQ.NE.2) KQSUM=KQSUM+KQ
42978 IF(IJN.EQ.1) KQS=KQ
42979 100 CONTINUE
42980 IF(KQSUM.NE.0) GOTO 120
42981
42982C...Connect the partons sequentially (closing for gluon loop).
42983 KCS=(9-KQS)/2
42984 IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
42985 DO 110 IJN=1,NJOIN
42986 I=IJOIN(IJN)
42987 K(I,1)=3
42988 IF(IJN.NE.1) IP=IJOIN(IJN-1)
42989 IF(IJN.EQ.1) IP=IJOIN(NJOIN)
42990 IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
42991 IF(IJN.EQ.NJOIN) IN=IJOIN(1)
42992 K(I,KCS)=MSTU(5)*IN
42993 K(I,9-KCS)=MSTU(5)*IP
42994 IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
42995 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
42996 110 CONTINUE
42997
42998C...Error exit: no action taken.
42999 RETURN
43000 120 CALL PYERRM(12,
43001 &'(PYJOIN:) given entries can not be joined by one string')
43002
43003 RETURN
43004 END
43005
43006C*********************************************************************
43007
43008C...PYGIVE
43009C...Sets values of commonblock variables.
43010
43011 SUBROUTINE PYGIVE(CHIN)
43012
43013C...Double precision and integer declarations.
43014 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43015 IMPLICIT INTEGER(I-N)
43016 INTEGER PYK,PYCHGE,PYCOMP
43017C...Commonblocks.
43018 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43019 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43020 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43021 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
43022 COMMON/PYDAT4/CHAF(500,2)
43023 CHARACTER CHAF*16
43024 COMMON/PYDATR/MRPY(6),RRPY(100)
43025 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
43026 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
43027 COMMON/PYINT1/MINT(400),VINT(400)
43028 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
43029 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
43030 COMMON/PYINT4/MWID(500),WIDS(500,5)
43031 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
43032 COMMON/PYINT6/PROC(0:500)
43033 CHARACTER PROC*28
43034 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
43035 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
43036 &XPDIR(-6:6)
43037 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
43038 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
43039 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
43040 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,
43041 &/PYINT5/,/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/,/PYMSRV/
43042C...Local arrays and character variables.
43043 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
43044 &CHNEW2*28,CHNAM*6,CHVAR(52)*6,CHALP(2)*26,CHIND*8,CHINI*10,
43045 &CHINR*16
43046 DIMENSION MSVAR(52,8)
43047
43048C...For each variable to be translated give: name,
43049C...integer/real/character, no. of indices, lower&upper index bounds.
43050 DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
43051 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
43052 &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
43053 &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
43054 &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
43055 &'XPANH','XPBEH','XPDIR','IMSS','RMSS','RVLAM','RVLAMP','RVLAMB'/
43056 DATA ((MSVAR(I,J),J=1,8),I=1,52)/ 1,7*0, 1,2,1,4000,1,5,2*0,
43057 &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
43058 &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
43059 &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
43060 &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,8000,1,2,2*0,
43061 &2,1,1,8000,4*0, 1,2,1,8000,1,5,2*0, 3,2,1,500,1,2,2*0,
43062 &1,1,1,6,4*0, 2,1,1,100,4*0,
43063 &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
43064 &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
43065 &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
43066 &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
43067 &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
43068 &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
43069 &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
43070 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
43071 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0,
43072 &2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3/
43073 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
43074 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
43075
43076C...Length of character variable. Subdivide it into instructions.
43077 IF(MSTU(12).GE.1) CALL PYLIST(0)
43078 CHBIT=CHIN//' '
43079 LBIT=101
43080 100 LBIT=LBIT-1
43081 IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
43082 LTOT=0
43083 DO 110 LCOM=1,LBIT
43084 IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
43085 LTOT=LTOT+1
43086 CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
43087 110 CONTINUE
43088 LLOW=0
43089 120 LHIG=LLOW+1
43090 130 LHIG=LHIG+1
43091 IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
43092 LBIT=LHIG-LLOW-1
43093 CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
43094
43095C...Peel off any text following exclamation mark.
43096 LHIG2=LBIT
43097 DO 140 LLOW2=LHIG2,1,-1
43098 IF(CHBIT(LLOW2:LLOW2).EQ.'!') LBIT=LLOW2-1
43099 140 CONTINUE
43100 IF(LBIT.EQ.0) RETURN
43101
43102C...Identify commonblock variable.
43103 LNAM=1
43104 150 LNAM=LNAM+1
43105 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
43106 &LNAM.LE.6) GOTO 150
43107 CHNAM=CHBIT(1:LNAM-1)//' '
43108 DO 170 LCOM=1,LNAM-1
43109 DO 160 LALP=1,26
43110 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
43111 & CHALP(2)(LALP:LALP)
43112 160 CONTINUE
43113 170 CONTINUE
43114 IVAR=0
43115 DO 180 IV=1,52
43116 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
43117 180 CONTINUE
43118 IF(IVAR.EQ.0) THEN
43119 CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM)
43120 LLOW=LHIG
43121 IF(LLOW.LT.LTOT) GOTO 120
43122 RETURN
43123 ENDIF
43124
43125C...Identify any indices.
43126 I1=0
43127 I2=0
43128 I3=0
43129 NINDX=0
43130 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
43131 LIND=LNAM
43132 190 LIND=LIND+1
43133 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
43134 CHIND=' '
43135 IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c')
43136 & .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17.OR.
43137 & IVAR.EQ.37)) THEN
43138 CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
43139 READ(CHIND,'(I8)') KF
43140 I1=PYCOMP(KF)
43141 ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
43142 & 'c') THEN
43143 CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '//
43144 & CHNAM)
43145 LLOW=LHIG
43146 IF(LLOW.LT.LTOT) GOTO 120
43147 RETURN
43148 ELSE
43149 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
43150 READ(CHIND,'(I8)') I1
43151 ENDIF
43152 LNAM=LIND
43153 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
43154 NINDX=1
43155 ENDIF
43156 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
43157 LIND=LNAM
43158 200 LIND=LIND+1
43159 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
43160 CHIND=' '
43161 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
43162 READ(CHIND,'(I8)') I2
43163 LNAM=LIND
43164 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
43165 NINDX=2
43166 ENDIF
43167 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
43168 LIND=LNAM
43169 210 LIND=LIND+1
43170 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 210
43171 CHIND=' '
43172 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
43173 READ(CHIND,'(I8)') I3
43174 LNAM=LIND+1
43175 NINDX=3
43176 ENDIF
43177
43178C...Check that indices allowed.
43179 IERR=0
43180 IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
43181 IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
43182 &IERR=2
43183 IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
43184 &IERR=3
43185 IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
43186 &IERR=4
43187 IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
43188 IF(IERR.GE.1) THEN
43189 CALL PYERRM(18,'(PYGIVE:) unallowed indices for '//
43190 & CHBIT(1:LNAM-1))
43191 LLOW=LHIG
43192 IF(LLOW.LT.LTOT) GOTO 120
43193 RETURN
43194 ENDIF
43195
43196C...Save old value of variable.
43197 IF(IVAR.EQ.1) THEN
43198 IOLD=N
43199 ELSEIF(IVAR.EQ.2) THEN
43200 IOLD=K(I1,I2)
43201 ELSEIF(IVAR.EQ.3) THEN
43202 ROLD=P(I1,I2)
43203 ELSEIF(IVAR.EQ.4) THEN
43204 ROLD=V(I1,I2)
43205 ELSEIF(IVAR.EQ.5) THEN
43206 IOLD=MSTU(I1)
43207 ELSEIF(IVAR.EQ.6) THEN
43208 ROLD=PARU(I1)
43209 ELSEIF(IVAR.EQ.7) THEN
43210 IOLD=MSTJ(I1)
43211 ELSEIF(IVAR.EQ.8) THEN
43212 ROLD=PARJ(I1)
43213 ELSEIF(IVAR.EQ.9) THEN
43214 IOLD=KCHG(I1,I2)
43215 ELSEIF(IVAR.EQ.10) THEN
43216 ROLD=PMAS(I1,I2)
43217 ELSEIF(IVAR.EQ.11) THEN
43218 ROLD=PARF(I1)
43219 ELSEIF(IVAR.EQ.12) THEN
43220 ROLD=VCKM(I1,I2)
43221 ELSEIF(IVAR.EQ.13) THEN
43222 IOLD=MDCY(I1,I2)
43223 ELSEIF(IVAR.EQ.14) THEN
43224 IOLD=MDME(I1,I2)
43225 ELSEIF(IVAR.EQ.15) THEN
43226 ROLD=BRAT(I1)
43227 ELSEIF(IVAR.EQ.16) THEN
43228 IOLD=KFDP(I1,I2)
43229 ELSEIF(IVAR.EQ.17) THEN
43230 CHOLD=CHAF(I1,I2)
43231 ELSEIF(IVAR.EQ.18) THEN
43232 IOLD=MRPY(I1)
43233 ELSEIF(IVAR.EQ.19) THEN
43234 ROLD=RRPY(I1)
43235 ELSEIF(IVAR.EQ.20) THEN
43236 IOLD=MSEL
43237 ELSEIF(IVAR.EQ.21) THEN
43238 IOLD=MSUB(I1)
43239 ELSEIF(IVAR.EQ.22) THEN
43240 IOLD=KFIN(I1,I2)
43241 ELSEIF(IVAR.EQ.23) THEN
43242 ROLD=CKIN(I1)
43243 ELSEIF(IVAR.EQ.24) THEN
43244 IOLD=MSTP(I1)
43245 ELSEIF(IVAR.EQ.25) THEN
43246 ROLD=PARP(I1)
43247 ELSEIF(IVAR.EQ.26) THEN
43248 IOLD=MSTI(I1)
43249 ELSEIF(IVAR.EQ.27) THEN
43250 ROLD=PARI(I1)
43251 ELSEIF(IVAR.EQ.28) THEN
43252 IOLD=MINT(I1)
43253 ELSEIF(IVAR.EQ.29) THEN
43254 ROLD=VINT(I1)
43255 ELSEIF(IVAR.EQ.30) THEN
43256 IOLD=ISET(I1)
43257 ELSEIF(IVAR.EQ.31) THEN
43258 IOLD=KFPR(I1,I2)
43259 ELSEIF(IVAR.EQ.32) THEN
43260 ROLD=COEF(I1,I2)
43261 ELSEIF(IVAR.EQ.33) THEN
43262 IOLD=ICOL(I1,I2,I3)
43263 ELSEIF(IVAR.EQ.34) THEN
43264 ROLD=XSFX(I1,I2)
43265 ELSEIF(IVAR.EQ.35) THEN
43266 IOLD=ISIG(I1,I2)
43267 ELSEIF(IVAR.EQ.36) THEN
43268 ROLD=SIGH(I1)
43269 ELSEIF(IVAR.EQ.37) THEN
43270 IOLD=MWID(I1)
43271 ELSEIF(IVAR.EQ.38) THEN
43272 ROLD=WIDS(I1,I2)
43273 ELSEIF(IVAR.EQ.39) THEN
43274 IOLD=NGEN(I1,I2)
43275 ELSEIF(IVAR.EQ.40) THEN
43276 ROLD=XSEC(I1,I2)
43277 ELSEIF(IVAR.EQ.41) THEN
43278 CHOLD2=PROC(I1)
43279 ELSEIF(IVAR.EQ.42) THEN
43280 ROLD=SIGT(I1,I2,I3)
43281 ELSEIF(IVAR.EQ.43) THEN
43282 ROLD=XPVMD(I1)
43283 ELSEIF(IVAR.EQ.44) THEN
43284 ROLD=XPANL(I1)
43285 ELSEIF(IVAR.EQ.45) THEN
43286 ROLD=XPANH(I1)
43287 ELSEIF(IVAR.EQ.46) THEN
43288 ROLD=XPBEH(I1)
43289 ELSEIF(IVAR.EQ.47) THEN
43290 ROLD=XPDIR(I1)
43291 ELSEIF(IVAR.EQ.48) THEN
43292 IOLD=IMSS(I1)
43293 ELSEIF(IVAR.EQ.49) THEN
43294 ROLD=RMSS(I1)
43295 ELSEIF(IVAR.EQ.50) THEN
43296 ROLD=RVLAM(I1,I2,I3)
43297 ELSEIF(IVAR.EQ.51) THEN
43298 ROLD=RVLAMP(I1,I2,I3)
43299 ELSEIF(IVAR.EQ.52) THEN
43300 ROLD=RVLAMB(I1,I2,I3)
43301 ENDIF
43302
43303C...Print current value of variable. Loop back.
43304 IF(LNAM.GE.LBIT) THEN
43305 CHBIT(LNAM:14)=' '
43306 CHBIT(15:60)=' has the value '
43307 IF(MSVAR(IVAR,1).EQ.1) THEN
43308 WRITE(CHBIT(51:60),'(I10)') IOLD
43309 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
43310 WRITE(CHBIT(47:60),'(F14.5)') ROLD
43311 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
43312 CHBIT(53:60)=CHOLD
43313 ELSE
43314 CHBIT(33:60)=CHOLD
43315 ENDIF
43316 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
43317 LLOW=LHIG
43318 IF(LLOW.LT.LTOT) GOTO 120
43319 RETURN
43320 ENDIF
43321
43322C...Read in new variable value.
43323 IF(MSVAR(IVAR,1).EQ.1) THEN
43324 CHINI=' '
43325 CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
43326 READ(CHINI,'(I10)') INEW
43327 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
43328 CHINR=' '
43329 CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
43330 READ(CHINR,*) RNEW
43331 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
43332 CHNEW=CHBIT(LNAM+1:LBIT)//' '
43333 ELSE
43334 CHNEW2=CHBIT(LNAM+1:LBIT)//' '
43335 ENDIF
43336
43337C...Store new variable value.
43338 IF(IVAR.EQ.1) THEN
43339 N=INEW
43340 ELSEIF(IVAR.EQ.2) THEN
43341 K(I1,I2)=INEW
43342 ELSEIF(IVAR.EQ.3) THEN
43343 P(I1,I2)=RNEW
43344 ELSEIF(IVAR.EQ.4) THEN
43345 V(I1,I2)=RNEW
43346 ELSEIF(IVAR.EQ.5) THEN
43347 MSTU(I1)=INEW
43348 ELSEIF(IVAR.EQ.6) THEN
43349 PARU(I1)=RNEW
43350 ELSEIF(IVAR.EQ.7) THEN
43351 MSTJ(I1)=INEW
43352 ELSEIF(IVAR.EQ.8) THEN
43353 PARJ(I1)=RNEW
43354 ELSEIF(IVAR.EQ.9) THEN
43355 KCHG(I1,I2)=INEW
43356 ELSEIF(IVAR.EQ.10) THEN
43357 PMAS(I1,I2)=RNEW
43358 ELSEIF(IVAR.EQ.11) THEN
43359 PARF(I1)=RNEW
43360 ELSEIF(IVAR.EQ.12) THEN
43361 VCKM(I1,I2)=RNEW
43362 ELSEIF(IVAR.EQ.13) THEN
43363 MDCY(I1,I2)=INEW
43364 ELSEIF(IVAR.EQ.14) THEN
43365 MDME(I1,I2)=INEW
43366 ELSEIF(IVAR.EQ.15) THEN
43367 BRAT(I1)=RNEW
43368 ELSEIF(IVAR.EQ.16) THEN
43369 KFDP(I1,I2)=INEW
43370 ELSEIF(IVAR.EQ.17) THEN
43371 CHAF(I1,I2)=CHNEW
43372 ELSEIF(IVAR.EQ.18) THEN
43373 MRPY(I1)=INEW
43374 ELSEIF(IVAR.EQ.19) THEN
43375 RRPY(I1)=RNEW
43376 ELSEIF(IVAR.EQ.20) THEN
43377 MSEL=INEW
43378 ELSEIF(IVAR.EQ.21) THEN
43379 MSUB(I1)=INEW
43380 ELSEIF(IVAR.EQ.22) THEN
43381 KFIN(I1,I2)=INEW
43382 ELSEIF(IVAR.EQ.23) THEN
43383 CKIN(I1)=RNEW
43384 ELSEIF(IVAR.EQ.24) THEN
43385 MSTP(I1)=INEW
43386 ELSEIF(IVAR.EQ.25) THEN
43387 PARP(I1)=RNEW
43388 ELSEIF(IVAR.EQ.26) THEN
43389 MSTI(I1)=INEW
43390 ELSEIF(IVAR.EQ.27) THEN
43391 PARI(I1)=RNEW
43392 ELSEIF(IVAR.EQ.28) THEN
43393 MINT(I1)=INEW
43394 ELSEIF(IVAR.EQ.29) THEN
43395 VINT(I1)=RNEW
43396 ELSEIF(IVAR.EQ.30) THEN
43397 ISET(I1)=INEW
43398 ELSEIF(IVAR.EQ.31) THEN
43399 KFPR(I1,I2)=INEW
43400 ELSEIF(IVAR.EQ.32) THEN
43401 COEF(I1,I2)=RNEW
43402 ELSEIF(IVAR.EQ.33) THEN
43403 ICOL(I1,I2,I3)=INEW
43404 ELSEIF(IVAR.EQ.34) THEN
43405 XSFX(I1,I2)=RNEW
43406 ELSEIF(IVAR.EQ.35) THEN
43407 ISIG(I1,I2)=INEW
43408 ELSEIF(IVAR.EQ.36) THEN
43409 SIGH(I1)=RNEW
43410 ELSEIF(IVAR.EQ.37) THEN
43411 MWID(I1)=INEW
43412 ELSEIF(IVAR.EQ.38) THEN
43413 WIDS(I1,I2)=RNEW
43414 ELSEIF(IVAR.EQ.39) THEN
43415 NGEN(I1,I2)=INEW
43416 ELSEIF(IVAR.EQ.40) THEN
43417 XSEC(I1,I2)=RNEW
43418 ELSEIF(IVAR.EQ.41) THEN
43419 PROC(I1)=CHNEW2
43420 ELSEIF(IVAR.EQ.42) THEN
43421 SIGT(I1,I2,I3)=RNEW
43422 ELSEIF(IVAR.EQ.43) THEN
43423 XPVMD(I1)=RNEW
43424 ELSEIF(IVAR.EQ.44) THEN
43425 XPANL(I1)=RNEW
43426 ELSEIF(IVAR.EQ.45) THEN
43427 XPANH(I1)=RNEW
43428 ELSEIF(IVAR.EQ.46) THEN
43429 XPBEH(I1)=RNEW
43430 ELSEIF(IVAR.EQ.47) THEN
43431 XPDIR(I1)=RNEW
43432 ELSEIF(IVAR.EQ.48) THEN
43433 IMSS(I1)=INEW
43434 ELSEIF(IVAR.EQ.49) THEN
43435 RMSS(I1)=RNEW
43436 ELSEIF(IVAR.EQ.50) THEN
43437 RVLAM(I1,I2,I3)=RNEW
43438 ELSEIF(IVAR.EQ.51) THEN
43439 RVLAMP(I1,I2,I3)=RNEW
43440 ELSEIF(IVAR.EQ.52) THEN
43441 RVLAMB(I1,I2,I3)=RNEW
43442 ENDIF
43443
43444C...Write old and new value. Loop back.
43445 CHBIT(LNAM:14)=' '
43446 CHBIT(15:60)=' changed from to '
43447 IF(MSVAR(IVAR,1).EQ.1) THEN
43448 WRITE(CHBIT(33:42),'(I10)') IOLD
43449 WRITE(CHBIT(51:60),'(I10)') INEW
43450 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
43451 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
43452 WRITE(CHBIT(29:42),'(F14.5)') ROLD
43453 WRITE(CHBIT(47:60),'(F14.5)') RNEW
43454 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
43455 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
43456 CHBIT(35:42)=CHOLD
43457 CHBIT(53:60)=CHNEW
43458 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
43459 ELSE
43460 CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
43461 IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
43462 ENDIF
43463 LLOW=LHIG
43464 IF(LLOW.LT.LTOT) GOTO 120
43465
43466C...Format statement for output on unit MSTU(11) (by default 6).
43467 5000 FORMAT(5X,A60)
43468 5100 FORMAT(5X,A88)
43469
43470 RETURN
43471 END
43472
43473C*********************************************************************
43474
43475C...PYEXEC
43476C...Administrates the fragmentation and decay chain.
43477
43478 SUBROUTINE PYEXEC
43479
43480C...Double precision and integer declarations.
43481 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43482 IMPLICIT INTEGER(I-N)
43483 INTEGER PYK,PYCHGE,PYCOMP
43484C...Commonblocks.
43485 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43486 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43487 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43488 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
43489 COMMON/PYINT4/MWID(500),WIDS(500,5)
43490 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT4/
43491C...Local array.
43492 DIMENSION PS(2,6),IJOIN(100)
43493
43494C...Initialize and reset.
43495 MSTU(24)=0
43496 IF(MSTU(12).GE.1) CALL PYLIST(0)
43497 MSTU(31)=MSTU(31)+1
43498 MSTU(1)=0
43499 MSTU(2)=0
43500 MSTU(3)=0
43501 IF(MSTU(17).LE.0) MSTU(90)=0
43502 MCONS=1
43503
43504C...Sum up momentum, energy and charge for starting entries.
43505 NSAV=N
43506 DO 110 I=1,2
43507 DO 100 J=1,6
43508 PS(I,J)=0D0
43509 100 CONTINUE
43510 110 CONTINUE
43511 DO 130 I=1,N
43512 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
43513 DO 120 J=1,4
43514 PS(1,J)=PS(1,J)+P(I,J)
43515 120 CONTINUE
43516 PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
43517 130 CONTINUE
43518 PARU(21)=PS(1,4)
43519
43520C...Prepare system for subsequent fragmentation/decay.
43521 CALL PYPREP(0)
43522
43523C...Loop through jet fragmentation and particle decays.
43524 MBE=0
43525 140 MBE=MBE+1
43526 IP=0
43527 150 IP=IP+1
43528 KC=0
43529 IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
43530 IF(KC.EQ.0) THEN
43531
43532C...Deal with any remaining undecayed resonance
43533C...(normally the task of PYEVNT, so seldom used).
43534 ELSEIF(MWID(KC).NE.0) THEN
43535 IBEG=IP
43536 IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
43537 IBEG=IP+1
43538 160 IBEG=IBEG-1
43539 IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 160
43540 IF(K(IBEG,1).NE.2) IBEG=IBEG+1
43541 IEND=IP-1
43542 170 IEND=IEND+1
43543 IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 170
43544 IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 170
43545 NJOIN=0
43546 DO 180 I=IBEG,IEND
43547 IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
43548 NJOIN=NJOIN+1
43549 IJOIN(NJOIN)=I
43550 ENDIF
43551 180 CONTINUE
43552 ENDIF
43553 CALL PYRESD(IP)
43554 CALL PYPREP(IBEG)
43555
43556C...Particle decay if unstable and allowed. Save long-lived particle
43557C...decays until second pass after Bose-Einstein effects.
43558 ELSEIF(KCHG(KC,2).EQ.0) THEN
43559 IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
43560 & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
43561 & CALL PYDECY(IP)
43562
43563C...Decay products may develop a shower.
43564 IF(MSTJ(92).GT.0) THEN
43565 IP1=MSTJ(92)
43566 QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
43567 & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
43568 CALL PYSHOW(IP1,IP1+1,QMAX)
43569 CALL PYPREP(IP1)
43570 MSTJ(92)=0
43571 ELSEIF(MSTJ(92).LT.0) THEN
43572 IP1=-MSTJ(92)
43573 CALL PYSHOW(IP1,-3,P(IP,5))
43574 CALL PYPREP(IP1)
43575 MSTJ(92)=0
43576 ENDIF
43577
43578C...Jet fragmentation: string or independent fragmentation.
43579 ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
43580 MFRAG=MSTJ(1)
43581 IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
43582 IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
43583 IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
43584 & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
43585 IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
43586 ENDIF
43587 ENDIF
43588 IF(MFRAG.EQ.1) CALL PYSTRF(IP)
43589 IF(MFRAG.EQ.2) CALL PYINDF(IP)
43590 IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
43591 IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
43592 ENDIF
43593
43594C...Loop back if enough space left in PYJETS and no error abort.
43595 IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
43596 ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
43597 GOTO 150
43598 ELSEIF(IP.LT.N) THEN
43599 CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
43600 ENDIF
43601
43602C...Include simple Bose-Einstein effect parametrization if desired.
43603 IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
43604 CALL PYBOEI(NSAV)
43605 GOTO 140
43606 ENDIF
43607
43608C...Check that momentum, energy and charge were conserved.
43609 DO 200 I=1,N
43610 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 200
43611 DO 190 J=1,4
43612 PS(2,J)=PS(2,J)+P(I,J)
43613 190 CONTINUE
43614 PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
43615 200 CONTINUE
43616 PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
43617 &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
43618 IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
43619 &'(PYEXEC:) four-momentum was not conserved')
43620 IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
43621 &'(PYEXEC:) charge was not conserved')
43622
43623 RETURN
43624 END
43625
43626C*********************************************************************
43627
43628C...PYPREP
43629C...Rearranges partons along strings.
43630C...Allows small systems to collapse into one or two particles.
43631C...Checks flavours and colour singlet invarient masses.
43632
43633 SUBROUTINE PYPREP(IP)
43634
43635C...Double precision and integer declarations.
43636 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43637 INTEGER PYK,PYCHGE,PYCOMP
43638C...Commonblocks.
43639 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43640 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43641 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43642 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
43643 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
43644C...Local arrays.
43645 DIMENSION DPS(5),DPC(5),UE(3),PG(5),
43646 &E1(3),E2(3),E3(3),E4(3),ECL(3)
43647
43648C...Function to give four-product.
43649 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)
43650
43651C...Rearrange parton shower product listing along strings: begin loop.
43652 I1=N
43653 DO 130 MQGST=1,2
43654 DO 120 I=MAX(1,IP),N
43655 IF(K(I,1).NE.3) GOTO 120
43656 KC=PYCOMP(K(I,2))
43657 IF(KC.EQ.0) GOTO 120
43658 KQ=KCHG(KC,2)
43659 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 120
43660
43661C...Pick up loose string end.
43662 KCS=4
43663 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
43664 IA=I
43665 NSTP=0
43666 100 NSTP=NSTP+1
43667 IF(NSTP.GT.4*N) THEN
43668 CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
43669 RETURN
43670 ENDIF
43671
43672C...Copy undecayed parton.
43673 IF(K(IA,1).EQ.3) THEN
43674 IF(I1.GE.MSTU(4)-MSTU(32)-5) THEN
43675 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
43676 RETURN
43677 ENDIF
43678 I1=I1+1
43679 K(I1,1)=2
43680 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1
43681 K(I1,2)=K(IA,2)
43682 K(I1,3)=IA
43683 K(I1,4)=0
43684 K(I1,5)=0
43685 DO 110 J=1,5
43686 P(I1,J)=P(IA,J)
43687 V(I1,J)=V(IA,J)
43688 110 CONTINUE
43689 K(IA,1)=K(IA,1)+10
43690 IF(K(I1,1).EQ.1) GOTO 120
43691 ENDIF
43692
43693C...GOTO next parton in colour space.
43694 IB=IA
43695 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
43696 & .NE.0) THEN
43697 IA=MOD(K(IB,KCS),MSTU(5))
43698 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
43699 MREV=0
43700 ELSE
43701 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
43702 & MSTU(5)).EQ.0) KCS=9-KCS
43703 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
43704 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
43705 MREV=1
43706 ENDIF
43707 IF(IA.LE.0.OR.IA.GT.N) THEN
43708 CALL PYERRM(12,'(PYPREP:) colour rearrangement failed')
43709 RETURN
43710 ENDIF
43711 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
43712 & MSTU(5)).EQ.IB) THEN
43713 IF(MREV.EQ.1) KCS=9-KCS
43714 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
43715 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
43716 ELSE
43717 IF(MREV.EQ.0) KCS=9-KCS
43718 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
43719 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
43720 ENDIF
43721 IF(IA.NE.I) GOTO 100
43722 K(I1,1)=1
43723 120 CONTINUE
43724 130 CONTINUE
43725 N=I1
43726
43727C...Done if no checks on small-mass systems.
43728 IF(MSTJ(14).LT.0) RETURN
43729 IF(MSTJ(14).EQ.0) GOTO 540
43730
43731C...Find lowest-mass colour singlet jet system.
43732 NS=N
43733 140 NSIN=N-NS
43734 PDMIN=1D0+PARJ(32)
43735 IC=0
43736 DO 190 I=MAX(1,IP),N
43737 IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
43738 ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
43739 NSIN=NSIN+1
43740 IC=I
43741 DO 150 J=1,4
43742 DPS(J)=P(I,J)
43743 150 CONTINUE
43744 MSTJ(93)=1
43745 DPS(5)=PYMASS(K(I,2))
43746 ELSEIF(K(I,1).EQ.2) THEN
43747 DO 160 J=1,4
43748 DPS(J)=DPS(J)+P(I,J)
43749 160 CONTINUE
43750 ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
43751 DO 170 J=1,4
43752 DPS(J)=DPS(J)+P(I,J)
43753 170 CONTINUE
43754 MSTJ(93)=1
43755 DPS(5)=DPS(5)+PYMASS(K(I,2))
43756 PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-
43757 & DPS(5)
43758 IF(PD.LT.PDMIN) THEN
43759 PDMIN=PD
43760 DO 180 J=1,5
43761 DPC(J)=DPS(J)
43762 180 CONTINUE
43763 IC1=IC
43764 IC2=I
43765 ENDIF
43766 IC=0
43767 ELSE
43768 NSIN=NSIN+1
43769 ENDIF
43770 190 CONTINUE
43771
43772C...Done if lowest-mass system above threshold for string frag.
43773 IF(PDMIN.GE.PARJ(32)) GOTO 540
43774
43775C...Fill small-mass system as cluster.
43776 NSAV=N
43777 PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
43778 K(N+1,1)=11
43779 K(N+1,2)=91
43780 K(N+1,3)=IC1
43781 P(N+1,1)=DPC(1)
43782 P(N+1,2)=DPC(2)
43783 P(N+1,3)=DPC(3)
43784 P(N+1,4)=DPC(4)
43785 P(N+1,5)=PECM
43786
43787C...Set up history, assuming cluster -> 2 hadrons.
43788 NBODY=2
43789 K(N+1,4)=N+2
43790 K(N+1,5)=N+3
43791 K(N+2,1)=1
43792 K(N+3,1)=1
43793 IF(MSTU(16).NE.2) THEN
43794 K(N+2,3)=N+1
43795 K(N+3,3)=N+1
43796 ELSE
43797 K(N+2,3)=IC1
43798 K(N+3,3)=IC2
43799 ENDIF
43800 K(N+2,4)=0
43801 K(N+3,4)=0
43802 K(N+2,5)=0
43803 K(N+3,5)=0
43804 V(N+1,5)=0D0
43805 V(N+2,5)=0D0
43806 V(N+3,5)=0D0
43807
43808C...Form two particles from flavours of lowest-mass system, if feasible.
43809 NTRY = 0
43810 200 NTRY = NTRY + 1
43811C...Open string.
43812 IF(IABS(K(IC1,2)).NE.21) THEN
43813 KC1=PYCOMP(K(IC1,2))
43814 KC2=PYCOMP(K(IC2,2))
43815 IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 540
43816 KQ1=KCHG(KC1,2)*ISIGN(1,K(IC1,2))
43817 KQ2=KCHG(KC2,2)*ISIGN(1,K(IC2,2))
43818 IF(KQ1+KQ2.NE.0) GOTO 540
43819C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
43820 210 K1=K(IC1,2)
43821 IF(IABS(K(IC2,2)).GT.10) K1=K(IC2,2)
43822 MSTU(125)=0
43823 CALL PYDCYK(K1,0,KFLN,K(N+2,2))
43824 CALL PYDCYK(K(IC1,2)+K(IC2,2)-K1,-KFLN,KFLDMP,K(N+3,2))
43825 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 210
43826C...Closed string.
43827 ELSE
43828 IF(IABS(K(IC2,2)).NE.21) GOTO 540
43829C...No room for popcorn mesons in closed string -> 2 hadrons.
43830 MSTU(125)=0
43831 220 CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
43832 CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
43833 CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
43834 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 220
43835 ENDIF
43836 P(N+2,5)=PYMASS(K(N+2,2))
43837 P(N+3,5)=PYMASS(K(N+3,2))
43838
43839C...If it does not work: try again (a number of times), give up
43840C...(if no place to shuffle momentum), or form one hadron.
43841 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) THEN
43842 IF(NTRY.LT.MSTJ(17)) THEN
43843 GOTO 200
43844 ELSEIF(NSIN.EQ.1) THEN
43845 GOTO 540
43846 ELSE
43847 GOTO 290
43848 END IF
43849 END IF
43850
43851C...Perform two-particle decay of jet system.
43852C...First step: find reference axis in decaying system rest frame.
43853C...(Borrow slot N+2 for temporary direction.)
43854 DO 230 J=1,4
43855 P(N+2,J)=P(IC1,J)
43856 230 CONTINUE
43857 DO 250 I=IC1+1,IC2-1
43858 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
43859 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
43860 FRAC1=FOUR(IC2,I)/(FOUR(IC1,I)+FOUR(IC2,I))
43861 DO 240 J=1,4
43862 P(N+2,J)=P(N+2,J)+FRAC1*P(I,J)
43863 240 CONTINUE
43864 ENDIF
43865 250 CONTINUE
43866 CALL PYROBO(N+2,N+2,0D0,0D0,-DPC(1)/DPC(4),-DPC(2)/DPC(4),
43867 &-DPC(3)/DPC(4))
43868 THE1=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
43869 PHI1=PYANGL(P(N+2,1),P(N+2,2))
43870
43871C...Second step: generate isotropic/anisotropic decay.
43872 PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
43873 &(P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
43874 260 UE(3)=PYR(0)
43875 PT2=(1D0-UE(3)**2)*PA**2
43876 IF(MSTJ(16).LE.0) THEN
43877 PREV=0.5D0
43878 ELSE
43879 IF(EXP(-PT2/(2D0*PARJ(21)**2)).LT.PYR(0)) GOTO 260
43880 PR1=P(N+2,5)**2+PT2
43881 PR2=P(N+3,5)**2+PT2
43882 ALAMBD=SQRT(MAX(0D0,(PECM**2-PR1-PR2)**2-4D0*PR1*PR2))
43883 PREVCF=PARJ(42)
43884 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
43885 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*ALAMBD)))
43886 ENDIF
43887 IF(PYR(0).LT.PREV) UE(3)=-UE(3)
43888 PHI=PARU(2)*PYR(0)
43889 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
43890 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
43891 DO 270 J=1,3
43892 P(N+2,J)=PA*UE(J)
43893 P(N+3,J)=-PA*UE(J)
43894 270 CONTINUE
43895 P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
43896 P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
43897
43898C...Third step: move back to event frame and set production vertex.
43899 CALL PYROBO(N+2,N+3,THE1,PHI1,DPC(1)/DPC(4),DPC(2)/DPC(4),
43900 &DPC(3)/DPC(4))
43901 DO 280 J=1,4
43902 V(N+1,J)=V(IC1,J)
43903 V(N+2,J)=V(IC1,J)
43904 V(N+3,J)=V(IC2,J)
43905 280 CONTINUE
43906 N=N+3
43907 GOTO 520
43908
43909C...Else form one particle, if possible.
43910 290 NBODY=1
43911 K(N+1,5)=N+2
43912 DO 300 J=1,4
43913 V(N+1,J)=V(IC1,J)
43914 V(N+2,J)=V(IC1,J)
43915 300 CONTINUE
43916
43917C...Select hadron flavour from available quark flavours.
43918 310 IF(IABS(K(IC1,2)).GT.100.AND.IABS(K(IC2,2)).GT.100) THEN
43919 GOTO 540
43920 ELSEIF(IABS(K(IC1,2)).NE.21) THEN
43921 CALL PYKFDI(K(IC1,2),K(IC2,2),KFLDMP,K(N+2,2))
43922 ELSE
43923 KFLN=1+INT((2D0+PARJ(2))*PYR(0))
43924 CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
43925 ENDIF
43926 IF(K(N+2,2).EQ.0) GOTO 310
43927 P(N+2,5)=PYMASS(K(N+2,2))
43928
43929C...Use old algorithm for E/p conservation? (EN)
43930 IF (MSTJ(16).LE.0) GOTO 480
43931
43932C...Find the string piece closest to the cluster by a loop
43933C...over the undecayed partons not in present cluster. (EN)
43934 DGLOMI=1D30
43935 IBEG=0
43936 I0=0
43937 DO 340 I1=MAX(1,IP),N-1
43938 IF(I1.GE.IC1-1.AND.I1.LE.IC2) THEN
43939 I0=0
43940 ELSEIF(K(I1,1).EQ.2) THEN
43941 IF(I0.EQ.0) I0=I1
43942 I2=I1
43943 320 I2=I2+1
43944 IF(K(I2,1).GT.10) GOTO 320
43945 IF(KCHG(PYCOMP(K(I2,2)),2).EQ.0) GOTO 320
43946
43947C...Define velocity vectors e1, e2, ecl and differences e3, e4.
43948 DO 330 J=1,3
43949 E1(J)=P(I1,J)/P(I1,4)
43950 E2(J)=P(I2,J)/P(I2,4)
43951 ECL(J)=P(N+1,J)/P(N+1,4)
43952 E3(J)=E2(J)-E1(J)
43953 E4(J)=ECL(J)-E1(J)
43954 330 CONTINUE
43955
43956C...Calculate minimal D=(e4-alpha*e3)**2 for 0<alpha<1.
43957 E3S=E3(1)**2+E3(2)**2+E3(3)**2
43958 E4S=E4(1)**2+E4(2)**2+E4(3)**2
43959 E34=E3(1)*E4(1)+E3(2)*E4(2)+E3(3)*E4(3)
43960 IF(E34.LE.0D0) THEN
43961 DDMIN=E4S
43962 ELSEIF(E34.LT.E3S) THEN
43963 DDMIN=E4S-E34**2/E3S
43964 ELSE
43965 DDMIN=E4S-2D0*E34+E3S
43966 ENDIF
43967
43968C...Is this the smallest so far?
43969 IF(DDMIN.LT.DGLOMI) THEN
43970 DGLOMI=DDMIN
43971 IBEG=I0
43972 IPCS=I1
43973 ENDIF
43974 ELSEIF(K(I1,1).EQ.1.AND.KCHG(PYCOMP(K(I1,2)),2).NE.0) THEN
43975 I0=0
43976 ENDIF
43977 340 CONTINUE
43978
43979C... Check if there are any strings to connect to the new gluon. (EN)
43980 IF (IBEG.EQ.0) GOTO 480
43981
43982C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
43983 IF (P(N+1,5).GE.P(N+2,5)) THEN
43984
43985C...Construct 'gluon' that is needed to put hadron on the mass shell.
43986 FRAC=P(N+2,5)/P(N+1,5)
43987 DO 350 J=1,5
43988 P(N+2,J)=FRAC*P(N+1,J)
43989 PG(J)=(1D0-FRAC)*P(N+1,J)
43990 350 CONTINUE
43991
43992C... Copy string with new gluon put in.
43993 N=N+2
43994 I=IBEG-1
43995 360 I=I+1
43996 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 360
43997 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0) GOTO 360
43998 N=N+1
43999 DO 370 J=1,5
44000 K(N,J)=K(I,J)
44001 P(N,J)=P(I,J)
44002 V(N,J)=V(I,J)
44003 370 CONTINUE
44004 K(I,1)=K(I,1)+10
44005 K(I,4)=N
44006 K(I,5)=N
44007 K(N,3)=I
44008 IF(I.EQ.IPCS) THEN
44009 N=N+1
44010 DO 380 J=1,5
44011 K(N,J)=K(N-1,J)
44012 P(N,J)=PG(J)
44013 V(N,J)=V(N-1,J)
44014 380 CONTINUE
44015 K(N,2)=21
44016 K(N,3)=NSAV+1
44017 ENDIF
44018 IF(K(I,1).EQ.12) GOTO 360
44019 GOTO 520
44020
44021C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
44022C...from string piece endpoints.
44023 ELSE
44024
44025C...Begin by copying string that should give energy to cluster.
44026 N=N+2
44027 I=IBEG-1
44028 390 I=I+1
44029 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 390
44030 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0) GOTO 390
44031 N=N+1
44032 DO 400 J=1,5
44033 K(N,J)=K(I,J)
44034 P(N,J)=P(I,J)
44035 V(N,J)=V(I,J)
44036 400 CONTINUE
44037 K(I,1)=K(I,1)+10
44038 K(I,4)=N
44039 K(I,5)=N
44040 K(N,3)=I
44041 IF(I.EQ.IPCS) I1=N
44042 IF(K(I,1).EQ.12) GOTO 390
44043 I2=I1+1
44044
44045C...Set initial Phad.
44046 DO 410 J=1,4
44047 P(NSAV+2,J)=P(NSAV+1,J)
44048 410 CONTINUE
44049
44050C...Calculate Pg, a part of which will be added to Phad later. (EN)
44051 420 IF(MSTJ(16).EQ.1) THEN
44052 ALPHA=1D0
44053 BETA=1D0
44054 ELSE
44055 ALPHA=FOUR(NSAV+1,I2)/FOUR(I1,I2)
44056 BETA=FOUR(NSAV+1,I1)/FOUR(I1,I2)
44057 ENDIF
44058 DO 430 J=1,4
44059 PG(J)=ALPHA*P(I1,J)+BETA*P(I2,J)
44060 430 CONTINUE
44061 PG(5)=SQRT(MAX(1D-20,PG(4)**2-PG(1)**2-PG(2)**2-PG(3)**2))
44062
44063C..Solve 2nd order equation, use the best (smallest) solution. (EN)
44064 PMSCOL=P(NSAV+2,4)**2-P(NSAV+2,1)**2-P(NSAV+2,2)**2-
44065 & P(NSAV+2,3)**2
44066 PCLPG=(P(NSAV+2,4)*PG(4)-P(NSAV+2,1)*PG(1)-
44067 & P(NSAV+2,2)*PG(2)-P(NSAV+2,3)*PG(3))/PG(5)**2
44068 DELTA=SQRT(PCLPG**2+(P(NSAV+2,5)**2-PMSCOL)/PG(5)**2)-PCLPG
44069
44070C...If all gluon energy eaten, zero it and take a step back.
44071 ITER=0
44072 IF(DELTA*ALPHA.GT.1D0.AND.I1.GT.NSAV+3) THEN
44073 ITER=1
44074 DO 440 J=1,4
44075 P(NSAV+2,J)=P(NSAV+2,J)+P(I1,J)
44076 P(I1,J)=0D0
44077 440 CONTINUE
44078 P(I1,5)=0D0
44079 K(I1,1)=K(I1,1)+10
44080 I1=I1-1
44081 ENDIF
44082 IF(DELTA*BETA.GT.1D0.AND.I2.LT.N) THEN
44083 ITER=1
44084 DO 450 J=1,4
44085 P(NSAV+2,J)=P(NSAV+2,J)+P(I2,J)
44086 P(I2,J)=0D0
44087 450 CONTINUE
44088 P(I2,5)=0D0
44089 K(I2,1)=K(I2,1)+10
44090 I2=I2+1
44091 ENDIF
44092 IF(ITER.EQ.1) GOTO 420
44093
44094C...If also all endpoint energy eaten, revert to old procedure.
44095 IF((1D0-DELTA*ALPHA)*P(I1,4).LT.P(I1,5).OR.
44096 & (1D0-DELTA*BETA)*P(I2,4).LT.P(I2,5)) THEN
44097 DO 460 I=NSAV+3,N
44098 IM=K(I,3)
44099 K(IM,1)=K(IM,1)-10
44100 K(IM,4)=0
44101 K(IM,5)=0
44102 460 CONTINUE
44103 N=NSAV
44104 GOTO 480
44105 ENDIF
44106
44107C... Construct the collapsed hadron and modified string partons.
44108 DO 470 J=1,4
44109 P(NSAV+2,J)=P(NSAV+2,J)+DELTA*PG(J)
44110 P(I1,J)=(1D0-DELTA*ALPHA)*P(I1,J)
44111 P(I2,J)=(1D0-DELTA*BETA)*P(I2,J)
44112 470 CONTINUE
44113 P(I1,5)=(1D0-DELTA*ALPHA)*P(I1,5)
44114 P(I2,5)=(1D0-DELTA*BETA)*P(I2,5)
44115
44116C...Finished with string collapse in new scheme.
44117 GOTO 520
44118 ENDIF
44119
44120C... Use old algorithm; by choice or when in trouble.
44121 480 CONTINUE
44122C...Find parton/particle which combines to largest extra mass.
44123 IR=0
44124 HA=0D0
44125 HSM=0D0
44126 DO 500 MCOMB=1,3
44127 IF(IR.NE.0) GOTO 500
44128 DO 490 I=MAX(1,IP),N
44129 IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
44130 & .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 490
44131 IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
44132 IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 490
44133 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 490
44134 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
44135 & GOTO 490
44136 HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
44137 HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5)
44138 IF(HSR.GT.HSM) THEN
44139 IR=I
44140 HA=HCR
44141 HSM=HSR
44142 ENDIF
44143 490 CONTINUE
44144 500 CONTINUE
44145
44146C...Shuffle energy and momentum to put new particle on mass shell.
44147 IF(IR.NE.0) THEN
44148 HB=PECM**2+HA
44149 HC=P(N+2,5)**2+HA
44150 HD=P(IR,5)**2+HA
44151 HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/
44152 & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
44153 HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
44154 DO 510 J=1,4
44155 P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J)
44156 P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J)
44157 510 CONTINUE
44158 N=N+2
44159 ELSE
44160 CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
44161 RETURN
44162 ENDIF
44163
44164C...Mark collapsed system and store daughter pointers. Iterate.
44165 520 DO 530 I=IC1,IC2
44166 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
44167 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
44168 K(I,1)=K(I,1)+10
44169 IF(MSTU(16).NE.2) THEN
44170 K(I,4)=NSAV+1
44171 K(I,5)=NSAV+1
44172 ELSE
44173 K(I,4)=NSAV+2
44174 K(I,5)=NSAV+1+NBODY
44175 ENDIF
44176 ENDIF
44177 530 CONTINUE
44178 IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 140
44179
44180C...Check flavours and invariant masses in parton systems.
44181 540 NP=0
44182 KFN=0
44183 KQS=0
44184 DO 550 J=1,5
44185 DPS(J)=0D0
44186 550 CONTINUE
44187 DO 580 I=MAX(1,IP),N
44188 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 580
44189 KC=PYCOMP(K(I,2))
44190 IF(KC.EQ.0) GOTO 580
44191 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
44192 IF(KQ.EQ.0) GOTO 580
44193 NP=NP+1
44194 IF(KQ.NE.2) THEN
44195 KFN=KFN+1
44196 KQS=KQS+KQ
44197 MSTJ(93)=1
44198 DPS(5)=DPS(5)+PYMASS(K(I,2))
44199 ENDIF
44200 DO 560 J=1,4
44201 DPS(J)=DPS(J)+P(I,J)
44202 560 CONTINUE
44203 IF(K(I,1).EQ.1) THEN
44204 IF(NP.NE.1.AND.(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0)) CALL
44205 & PYERRM(2,'(PYPREP:) unphysical flavour combination')
44206 IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
44207 & (0.9D0*PARJ(32)+DPS(5))**2) THEN
44208 CALL PYERRM(3,'(PYPREP:) too small mass in jet system')
44209 END IF
44210 NP=0
44211 KFN=0
44212 KQS=0
44213 DO 570 J=1,5
44214 DPS(J)=0D0
44215 570 CONTINUE
44216 ENDIF
44217 580 CONTINUE
44218
44219 RETURN
44220 END
44221
44222C*********************************************************************
44223
44224C...PYSTRF
44225C...Handles the fragmentation of an arbitrary colour singlet
44226C...jet system according to the Lund string fragmentation model.
44227
44228 SUBROUTINE PYSTRF(IP)
44229
44230C...Double precision and integer declarations.
44231 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44232 IMPLICIT INTEGER(I-N)
44233 INTEGER PYK,PYCHGE,PYCOMP
44234C...Commonblocks.
44235 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
44236 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44237 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
44238 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
44239C...Local arrays. All MOPS variables ends with MO
44240 DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
44241 &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(3),PJU(5,5),
44242 &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
44243 &INMO(9),PM2QMO(2),XTMO(2)
44244
44245C...Function: four-product of two vectors.
44246 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)
44247 DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
44248 &DP(I,3)*DP(J,3)
44249
44250C...Reset counters. Identify parton system.
44251 MSTJ(91)=0
44252 NSAV=N
44253 MSTU90=MSTU(90)
44254 NP=0
44255 KQSUM=0
44256 DO 100 J=1,5
44257 DPS(J)=0D0
44258 100 CONTINUE
44259 MJU(1)=0
44260 MJU(2)=0
44261 I=IP-1
44262 110 I=I+1
44263 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
44264 CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
44265 IF(MSTU(21).GE.1) RETURN
44266 ENDIF
44267 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
44268 KC=PYCOMP(K(I,2))
44269 IF(KC.EQ.0) GOTO 110
44270 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
44271 IF(KQ.EQ.0) GOTO 110
44272 IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
44273 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
44274 IF(MSTU(21).GE.1) RETURN
44275 ENDIF
44276
44277C...Take copy of partons to be considered. Check flavour sum.
44278 NP=NP+1
44279 DO 120 J=1,5
44280 K(N+NP,J)=K(I,J)
44281 P(N+NP,J)=P(I,J)
44282 IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
44283 120 CONTINUE
44284 DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
44285 K(N+NP,3)=I
44286 IF(KQ.NE.2) KQSUM=KQSUM+KQ
44287 IF(K(I,1).EQ.41) THEN
44288 KQSUM=KQSUM+2*KQ
44289 IF(KQSUM.EQ.KQ) MJU(1)=N+NP
44290 IF(KQSUM.NE.KQ) MJU(2)=N+NP
44291 ENDIF
44292 IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
44293 IF(KQSUM.NE.0) THEN
44294 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
44295 IF(MSTU(21).GE.1) RETURN
44296 ENDIF
44297
44298C...Boost copied system to CM frame (for better numerical precision).
44299 IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
44300 MBST=0
44301 MSTU(33)=1
44302 CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
44303 & -DPS(3)/DPS(4))
44304 ELSE
44305 MBST=1
44306 HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
44307 DO 130 I=N+1,N+NP
44308 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
44309 IF(P(I,3).GT.0D0) THEN
44310 HHPEZ=MAX(1D-10,(P(I,4)+P(I,3))/HHBZ)
44311 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
44312 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
44313 ELSE
44314 HHPEZ=MAX(1D-10,(P(I,4)-P(I,3))*HHBZ)
44315 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
44316 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
44317 ENDIF
44318 130 CONTINUE
44319 ENDIF
44320
44321C...Search for very nearby partons that may be recombined.
44322 NTRYR=0
44323 PARU12=PARU(12)
44324 PARU13=PARU(13)
44325 MJU(3)=MJU(1)
44326 MJU(4)=MJU(2)
44327 NR=NP
44328 140 IF(NR.GE.3) THEN
44329 PDRMIN=2D0*PARU12
44330 DO 150 I=N+1,N+NR
44331 IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
44332 I1=I+1
44333 IF(I.EQ.N+NR) I1=N+1
44334 IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
44335 IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
44336 & GOTO 150
44337 IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
44338 & GOTO 150
44339 PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
44340 & P(I1,2)**2+P(I1,3)**2))
44341 PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
44342 PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP))
44343 IF(PDR.LT.PDRMIN) THEN
44344 IR=I
44345 PDRMIN=PDR
44346 ENDIF
44347 150 CONTINUE
44348
44349C...Recombine very nearby partons to avoid machine precision problems.
44350 IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
44351 DO 160 J=1,4
44352 P(N+1,J)=P(N+1,J)+P(N+NR,J)
44353 160 CONTINUE
44354 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
44355 & P(N+1,3)**2))
44356 NR=NR-1
44357 GOTO 140
44358 ELSEIF(PDRMIN.LT.PARU12) THEN
44359 DO 170 J=1,4
44360 P(IR,J)=P(IR,J)+P(IR+1,J)
44361 170 CONTINUE
44362 P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
44363 & P(IR,3)**2))
44364 DO 190 I=IR+1,N+NR-1
44365 K(I,2)=K(I+1,2)
44366 DO 180 J=1,5
44367 P(I,J)=P(I+1,J)
44368 180 CONTINUE
44369 190 CONTINUE
44370 IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
44371 NR=NR-1
44372 IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
44373 IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
44374 GOTO 140
44375 ENDIF
44376 ENDIF
44377 NTRYR=NTRYR+1
44378
44379C...Reset particle counter. Skip ahead if no junctions are present;
44380C...this is usually the case!
44381 NRS=MAX(5*NR+11,NP)
44382 NTRY=0
44383 200 NTRY=NTRY+1
44384 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
44385 PARU12=4D0*PARU12
44386 PARU13=2D0*PARU13
44387 GOTO 140
44388 ELSEIF(NTRY.GT.100) THEN
44389 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
44390 IF(MSTU(21).GE.1) RETURN
44391 ENDIF
44392 I=N+NRS
44393 MSTU(90)=MSTU90
44394 IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 580
44395 IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
44396 & ' junction strings not handled by MSTJ(12)>3 options')
44397 DO 570 JT=1,2
44398 NJS(JT)=0
44399 IF(MJU(JT).EQ.0) GOTO 570
44400 JS=3-2*JT
44401
44402C...Find and sum up momentum on three sides of junction. Check flavours.
44403 DO 220 IU=1,3
44404 IJU(IU)=0
44405 DO 210 J=1,5
44406 PJU(IU,J)=0D0
44407 210 CONTINUE
44408 220 CONTINUE
44409 IU=0
44410 DO 240 I1=N+1+(JT-1)*(NR-1),N+NR+(JT-1)*(1-NR),JS
44411 IF(K(I1,2).NE.21.AND.IU.LE.2) THEN
44412 IU=IU+1
44413 IJU(IU)=I1
44414 ENDIF
44415 DO 230 J=1,4
44416 PJU(IU,J)=PJU(IU,J)+P(I1,J)
44417 230 CONTINUE
44418 240 CONTINUE
44419 DO 250 IU=1,3
44420 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
44421 250 CONTINUE
44422 IF(K(IJU(3),2)/100.NE.10*K(IJU(1),2)+K(IJU(2),2).AND.
44423 & K(IJU(3),2)/100.NE.10*K(IJU(2),2)+K(IJU(1),2)) THEN
44424 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
44425 IF(MSTU(21).GE.1) RETURN
44426 ENDIF
44427
44428C...Calculate (approximate) boost to rest frame of junction.
44429 T12=(PJU(1,1)*PJU(2,1)+PJU(1,2)*PJU(2,2)+PJU(1,3)*PJU(2,3))/
44430 & (PJU(1,5)*PJU(2,5))
44431 T13=(PJU(1,1)*PJU(3,1)+PJU(1,2)*PJU(3,2)+PJU(1,3)*PJU(3,3))/
44432 & (PJU(1,5)*PJU(3,5))
44433 T23=(PJU(2,1)*PJU(3,1)+PJU(2,2)*PJU(3,2)+PJU(2,3)*PJU(3,3))/
44434 & (PJU(2,5)*PJU(3,5))
44435 T11=SQRT((2D0/3D0)*(1D0-T12)*(1D0-T13)/(1D0-T23))
44436 T22=SQRT((2D0/3D0)*(1D0-T12)*(1D0-T23)/(1D0-T13))
44437 TSQ=SQRT((2D0*T11*T22+T12-1D0)*(1D0+T12))
44438 T1F=(TSQ-T22*(1D0+T12))/(1D0-T12**2)
44439 T2F=(TSQ-T11*(1D0+T12))/(1D0-T12**2)
44440 DO 260 J=1,3
44441 TJU(J)=-(T1F*PJU(1,J)/PJU(1,5)+T2F*PJU(2,J)/PJU(2,5))
44442 260 CONTINUE
44443 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
44444 DO 270 IU=1,3
44445 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
44446 & TJU(3)*PJU(IU,3)
44447 270 CONTINUE
44448
44449C...Put junction at rest if motion could give inconsistencies.
44450 IF(PJU(1,5)+PJU(2,5).GT.PJU(1,4)+PJU(2,4)) THEN
44451 DO 280 J=1,3
44452 TJU(J)=0D0
44453 280 CONTINUE
44454 TJU(4)=1D0
44455 PJU(1,5)=PJU(1,4)
44456 PJU(2,5)=PJU(2,4)
44457 PJU(3,5)=PJU(3,4)
44458 ENDIF
44459
44460C...Start preparing for fragmentation of two strings from junction.
44461 ISTA=I
44462 DO 550 IU=1,2
44463 NS=IJU(IU+1)-IJU(IU)
44464
44465C...Junction strings: find longitudinal string directions.
44466 DO 310 IS=1,NS
44467 IS1=IJU(IU)+IS-1
44468 IS2=IJU(IU)+IS
44469 DO 290 J=1,5
44470 DP(1,J)=0.5D0*P(IS1,J)
44471 IF(IS.EQ.1) DP(1,J)=P(IS1,J)
44472 DP(2,J)=0.5D0*P(IS2,J)
44473 IF(IS.EQ.NS) DP(2,J)=-PJU(IU,J)
44474 290 CONTINUE
44475 IF(IS.EQ.NS) DP(2,4)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+
44476 & PJU(IU,3)**2)
44477 IF(IS.EQ.NS) DP(2,5)=0D0
44478 DP(3,5)=DFOUR(1,1)
44479 DP(4,5)=DFOUR(2,2)
44480 DHKC=DFOUR(1,2)
44481 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
44482 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
44483 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
44484 DP(3,5)=0D0
44485 DP(4,5)=0D0
44486 DHKC=DFOUR(1,2)
44487 ENDIF
44488 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
44489 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
44490 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
44491 IN1=N+NR+4*IS-3
44492 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
44493 DO 300 J=1,4
44494 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
44495 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
44496 300 CONTINUE
44497 310 CONTINUE
44498
44499C...Junction strings: initialize flavour, momentum and starting pos.
44500 ISAV=I
44501 MSTU91=MSTU(90)
44502 320 NTRY=NTRY+1
44503 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
44504 PARU12=4D0*PARU12
44505 PARU13=2D0*PARU13
44506 GOTO 140
44507 ELSEIF(NTRY.GT.100) THEN
44508 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
44509 IF(MSTU(21).GE.1) RETURN
44510 ENDIF
44511 I=ISAV
44512 MSTU(90)=MSTU91
44513 IRANKJ=0
44514 IE(1)=K(N+1+(JT/2)*(NP-1),3)
44515 IN(4)=N+NR+1
44516 IN(5)=IN(4)+1
44517 IN(6)=N+NR+4*NS+1
44518 DO 340 JQ=1,2
44519 DO 330 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
44520 P(IN1,1)=2-JQ
44521 P(IN1,2)=JQ-1
44522 P(IN1,3)=1D0
44523 330 CONTINUE
44524 340 CONTINUE
44525 KFL(1)=K(IJU(IU),2)
44526 PX(1)=0D0
44527 PY(1)=0D0
44528 GAM(1)=0D0
44529 DO 350 J=1,5
44530 PJU(IU+3,J)=0D0
44531 350 CONTINUE
44532
44533C...Junction strings: find initial transverse directions.
44534 DO 360 J=1,4
44535 DP(1,J)=P(IN(4),J)
44536 DP(2,J)=P(IN(4)+1,J)
44537 DP(3,J)=0D0
44538 DP(4,J)=0D0
44539 360 CONTINUE
44540 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
44541 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
44542 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
44543 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
44544 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
44545 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
44546 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
44547 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
44548 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
44549 DHC12=DFOUR(1,2)
44550 DHCX1=DFOUR(3,1)/DHC12
44551 DHCX2=DFOUR(3,2)/DHC12
44552 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
44553 DHCY1=DFOUR(4,1)/DHC12
44554 DHCY2=DFOUR(4,2)/DHC12
44555 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
44556 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
44557 DO 370 J=1,4
44558 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
44559 P(IN(6),J)=DP(3,J)
44560 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
44561 & DHCYX*DP(3,J))
44562 370 CONTINUE
44563
44564C...Junction strings: produce new particle, origin.
44565 380 I=I+1
44566 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
44567 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
44568 IF(MSTU(21).GE.1) RETURN
44569 ENDIF
44570 IRANKJ=IRANKJ+1
44571 K(I,1)=1
44572 K(I,3)=IE(1)
44573 K(I,4)=0
44574 K(I,5)=0
44575
44576C...Junction strings: generate flavour, hadron, pT, z and Gamma.
44577 390 CALL PYKFDI(KFL(1),0,KFL(3),K(I,2))
44578 IF(K(I,2).EQ.0) GOTO 320
44579 IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
44580 & IABS(KFL(3)).GT.10) THEN
44581 IF(PYR(0).GT.PARJ(19)) GOTO 390
44582 ENDIF
44583 P(I,5)=PYMASS(K(I,2))
44584 CALL PYPTDI(KFL(1),PX(3),PY(3))
44585 PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
44586 CALL PYZDIS(KFL(1),KFL(3),PR(1),Z)
44587 IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
44588 & MSTU(90).LT.8) THEN
44589 MSTU(90)=MSTU(90)+1
44590 MSTU(90+MSTU(90))=I
44591 PARU(90+MSTU(90))=Z
44592 ENDIF
44593 GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z)
44594 DO 400 J=1,3
44595 IN(J)=IN(3+J)
44596 400 CONTINUE
44597
44598C...Junction strings: stepping within or from 'low' string region easy.
44599 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
44600 & P(IN(1),5)**2.GE.PR(1)) THEN
44601 P(IN(1)+2,4)=Z*P(IN(1)+2,3)
44602 P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
44603 DO 410 J=1,4
44604 P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
44605 410 CONTINUE
44606 GOTO 500
44607 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
44608 P(IN(2)+2,4)=P(IN(2)+2,3)
44609 P(IN(2)+2,1)=1D0
44610 IN(2)=IN(2)+4
44611 IF(IN(2).GT.N+NR+4*NS) GOTO 320
44612 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
44613 P(IN(1)+2,4)=P(IN(1)+2,3)
44614 P(IN(1)+2,1)=0D0
44615 IN(1)=IN(1)+4
44616 ENDIF
44617 ENDIF
44618
44619C...Junction strings: find new transverse directions.
44620 420 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
44621 & IN(1).GT.IN(2)) GOTO 320
44622 IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
44623 DO 430 J=1,4
44624 DP(1,J)=P(IN(1),J)
44625 DP(2,J)=P(IN(2),J)
44626 DP(3,J)=0D0
44627 DP(4,J)=0D0
44628 430 CONTINUE
44629 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
44630 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
44631 DHC12=DFOUR(1,2)
44632 IF(DHC12.LE.1D-2) THEN
44633 P(IN(1)+2,4)=P(IN(1)+2,3)
44634 P(IN(1)+2,1)=0D0
44635 IN(1)=IN(1)+4
44636 GOTO 420
44637 ENDIF
44638 IN(3)=N+NR+4*NS+5
44639 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
44640 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
44641 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
44642 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
44643 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
44644 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
44645 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
44646 DHCX1=DFOUR(3,1)/DHC12
44647 DHCX2=DFOUR(3,2)/DHC12
44648 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
44649 DHCY1=DFOUR(4,1)/DHC12
44650 DHCY2=DFOUR(4,2)/DHC12
44651 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
44652 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
44653 DO 440 J=1,4
44654 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
44655 P(IN(3),J)=DP(3,J)
44656 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
44657 & DHCYX*DP(3,J))
44658 440 CONTINUE
44659C...Express pT with respect to new axes, if sensible.
44660 PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
44661 PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
44662 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
44663 PX(3)=PXP
44664 PY(3)=PYP
44665 ENDIF
44666 ENDIF
44667
44668C...Junction strings: sum up known four-momentum, coefficients for m2.
44669 DO 470 J=1,4
44670 DHG(J)=0D0
44671 P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
44672 & PY(3)*P(IN(3)+1,J)
44673 DO 450 IN1=IN(4),IN(1)-4,4
44674 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
44675 450 CONTINUE
44676 DO 460 IN2=IN(5),IN(2)-4,4
44677 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
44678 460 CONTINUE
44679 470 CONTINUE
44680 DHM(1)=FOUR(I,I)
44681 DHM(2)=2D0*FOUR(I,IN(1))
44682 DHM(3)=2D0*FOUR(I,IN(2))
44683 DHM(4)=2D0*FOUR(IN(1),IN(2))
44684
44685C...Junction strings: find coefficients for Gamma expression.
44686 DO 490 IN2=IN(1)+1,IN(2),4
44687 DO 480 IN1=IN(1),IN2-1,4
44688 DHC=2D0*FOUR(IN1,IN2)
44689 DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
44690 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
44691 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
44692 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
44693 480 CONTINUE
44694 490 CONTINUE
44695
44696C...Junction strings: solve (m2, Gamma) equation system for energies.
44697 DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
44698 IF(ABS(DHS1).LT.1D-4) GOTO 320
44699 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
44700 & (P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
44701 DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
44702 P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
44703 & ABS(DHS1)-DHS2/DHS1)
44704 IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 320
44705 P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
44706 & (DHM(2)+DHM(4)*P(IN(2)+2,4))
44707
44708C...Junction strings: step to new region if necessary.
44709 IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
44710 P(IN(2)+2,4)=P(IN(2)+2,3)
44711 P(IN(2)+2,1)=1D0
44712 IN(2)=IN(2)+4
44713 IF(IN(2).GT.N+NR+4*NS) GOTO 320
44714 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
44715 P(IN(1)+2,4)=P(IN(1)+2,3)
44716 P(IN(1)+2,1)=0D0
44717 IN(1)=IN(1)+4
44718 ENDIF
44719 GOTO 420
44720 ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
44721 P(IN(1)+2,4)=P(IN(1)+2,3)
44722 P(IN(1)+2,1)=0D0
44723 IN(1)=IN(1)+JS
44724 GOTO 890
44725 ENDIF
44726
44727C...Junction strings: particle four-momentum, remainder, loop back.
44728 500 DO 510 J=1,4
44729 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+
44730 & P(IN(2)+2,4)*P(IN(2),J)
44731 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
44732 510 CONTINUE
44733 IF(P(I,4).LT.P(I,5)) GOTO 320
44734 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
44735 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
44736 IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
44737 KFL(1)=-KFL(3)
44738 PX(1)=-PX(3)
44739 PY(1)=-PY(3)
44740 GAM(1)=GAM(3)
44741 IF(IN(3).NE.IN(6)) THEN
44742 DO 520 J=1,4
44743 P(IN(6),J)=P(IN(3),J)
44744 P(IN(6)+1,J)=P(IN(3)+1,J)
44745 520 CONTINUE
44746 ENDIF
44747 DO 530 JQ=1,2
44748 IN(3+JQ)=IN(JQ)
44749 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
44750 P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
44751 530 CONTINUE
44752 GOTO 380
44753 ENDIF
44754
44755C...Junction strings: save quantities left after each string.
44756 IF(IABS(KFL(1)).GT.10) GOTO 320
44757 I=I-1
44758 KFJH(IU)=KFL(1)
44759 DO 540 J=1,4
44760 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
44761 540 CONTINUE
44762 550 CONTINUE
44763
44764C...Junction strings: put together to new effective string endpoint.
44765 NJS(JT)=I-ISTA
44766 KFJS(JT)=K(K(MJU(JT+2),3),2)
44767 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
44768 IF(KFJH(1).EQ.KFJH(2)) KFLS=3
44769 IF(ISTA.NE.I) KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),
44770 & IABS(KFJH(2)))+100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+
44771 & KFLS,KFJH(1))
44772 DO 560 J=1,4
44773 PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
44774 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
44775 560 CONTINUE
44776 PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
44777 & PJS(JT,3)**2))
44778 570 CONTINUE
44779
44780C...Open versus closed strings. Choose breakup region for latter.
44781 580 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
44782 NS=MJU(2)-MJU(1)
44783 NB=MJU(1)-N
44784 ELSEIF(MJU(1).NE.0) THEN
44785 NS=N+NR-MJU(1)
44786 NB=MJU(1)-N
44787 ELSEIF(MJU(2).NE.0) THEN
44788 NS=MJU(2)-N
44789 NB=1
44790 ELSEIF(IABS(K(N+1,2)).NE.21) THEN
44791 NS=NR-1
44792 NB=1
44793 ELSE
44794 NS=NR+1
44795 W2SUM=0D0
44796 DO 590 IS=1,NR
44797 P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR))
44798 W2SUM=W2SUM+P(N+NR+IS,1)
44799 590 CONTINUE
44800 W2RAN=PYR(0)*W2SUM
44801 NB=0
44802 600 NB=NB+1
44803 W2SUM=W2SUM-P(N+NR+NB,1)
44804 IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 600
44805 ENDIF
44806
44807C...Find longitudinal string directions (i.e. lightlike four-vectors).
44808 DO 630 IS=1,NS
44809 IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
44810 IS2=N+IS+NB-NR*((IS+NB-1)/NR)
44811 DO 610 J=1,5
44812 DP(1,J)=P(IS1,J)
44813 IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J)
44814 IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
44815 DP(2,J)=P(IS2,J)
44816 IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J)
44817 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
44818 610 CONTINUE
44819 DP(3,5)=DFOUR(1,1)
44820 DP(4,5)=DFOUR(2,2)
44821 DHKC=DFOUR(1,2)
44822 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
44823 DP(3,5)=DP(1,5)**2
44824 DP(4,5)=DP(2,5)**2
44825 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2+DP(1,5)**2)
44826 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2+DP(2,5)**2)
44827 DHKC=DFOUR(1,2)
44828 ENDIF
44829 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
44830 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
44831 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
44832 IN1=N+NR+4*IS-3
44833 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
44834 DO 620 J=1,4
44835 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
44836 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
44837 620 CONTINUE
44838 630 CONTINUE
44839
44840C...Begin initialization: sum up energy, set starting position.
44841 ISAV=I
44842 MSTU91=MSTU(90)
44843 640 NTRY=NTRY+1
44844 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
44845 PARU12=4D0*PARU12
44846 PARU13=2D0*PARU13
44847 GOTO 140
44848 ELSEIF(NTRY.GT.100) THEN
44849 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
44850 IF(MSTU(21).GE.1) RETURN
44851 ENDIF
44852 I=ISAV
44853 MSTU(90)=MSTU91
44854 DO 660 J=1,4
44855 P(N+NRS,J)=0D0
44856 DO 650 IS=1,NR
44857 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
44858 650 CONTINUE
44859 660 CONTINUE
44860 DO 680 JT=1,2
44861 IRANK(JT)=0
44862 IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
44863 IF(NS.GT.NR) IRANK(JT)=1
44864 IE(JT)=K(N+1+(JT/2)*(NP-1),3)
44865 IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
44866 IN(3*JT+2)=IN(3*JT+1)+1
44867 IN(3*JT+3)=N+NR+4*NS+2*JT-1
44868 DO 670 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
44869 P(IN1,1)=2-JT
44870 P(IN1,2)=JT-1
44871 P(IN1,3)=1D0
44872 670 CONTINUE
44873 680 CONTINUE
44874C.. MOPS variables and switches
44875 NRVMO=0
44876 XBMO=1D0
44877 MSTU(121)=0
44878 MSTU(122)=0
44879
44880C...Initialize flavour and pT variables for open string.
44881 IF(NS.LT.NR) THEN
44882 PX(1)=0D0
44883 PY(1)=0D0
44884 IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1))
44885 PX(2)=-PX(1)
44886 PY(2)=-PY(1)
44887 DO 690 JT=1,2
44888 KFL(JT)=K(IE(JT),2)
44889 IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
44890 MSTJ(93)=1
44891 PMQ(JT)=PYMASS(KFL(JT))
44892 GAM(JT)=0D0
44893 690 CONTINUE
44894
44895C...Closed string: random initial breakup flavour, pT and vertex.
44896 ELSE
44897 KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
44898 IBMO=0
44899 700 CALL PYKFDI(KFL(3),0,KFL(1),KDUMP)
44900C.. Closed string: first vertex diq attempt => enforced second
44901C.. vertex diq
44902 IF(IABS(KFL(1)).GT.10)THEN
44903 IBMO=1
44904 MSTU(121)=0
44905 GOTO 700
44906 ENDIF
44907 IF(IBMO.EQ.1) MSTU(121)=-1
44908 KFL(2)=-KFL(1)
44909 CALL PYPTDI(KFL(1),PX(1),PY(1))
44910 PX(2)=-PX(1)
44911 PY(2)=-PY(1)
44912 PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2)
44913 710 CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
44914 ZR=PR3/(Z*P(N+NR+1,5)**2)
44915 IF(ZR.GE.1D0) GOTO 710
44916 DO 720 JT=1,2
44917 MSTJ(93)=1
44918 PMQ(JT)=PYMASS(KFL(JT))
44919 GAM(JT)=PR3*(1D0-Z)/Z
44920 IN1=N+NR+3+4*(JT/2)*(NS-1)
44921 P(IN1,JT)=1D0-Z
44922 P(IN1,3-JT)=JT-1
44923 P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z
44924 P(IN1+1,JT)=ZR
44925 P(IN1+1,3-JT)=2-JT
44926 P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR
44927 720 CONTINUE
44928 ENDIF
44929C.. MOPS variables
44930 DO 730 JT=1,2
44931 XTMO(JT)=1D0
44932 PM2QMO(JT)=PMQ(JT)**2
44933 IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
44934 730 CONTINUE
44935
44936C...Find initial transverse directions (i.e. spacelike four-vectors).
44937 DO 770 JT=1,2
44938 IF(JT.EQ.1.OR.NS.EQ.NR-1) THEN
44939 IN1=IN(3*JT+1)
44940 IN3=IN(3*JT+3)
44941 DO 740 J=1,4
44942 DP(1,J)=P(IN1,J)
44943 DP(2,J)=P(IN1+1,J)
44944 DP(3,J)=0D0
44945 DP(4,J)=0D0
44946 740 CONTINUE
44947 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
44948 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
44949 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
44950 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
44951 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
44952 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
44953 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
44954 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
44955 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
44956 DHC12=DFOUR(1,2)
44957 DHCX1=DFOUR(3,1)/DHC12
44958 DHCX2=DFOUR(3,2)/DHC12
44959 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
44960 DHCY1=DFOUR(4,1)/DHC12
44961 DHCY2=DFOUR(4,2)/DHC12
44962 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
44963 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
44964 DO 750 J=1,4
44965 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
44966 P(IN3,J)=DP(3,J)
44967 P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
44968 & DHCYX*DP(3,J))
44969 750 CONTINUE
44970 ELSE
44971 DO 760 J=1,4
44972 P(IN3+2,J)=P(IN3,J)
44973 P(IN3+3,J)=P(IN3+1,J)
44974 760 CONTINUE
44975 ENDIF
44976 770 CONTINUE
44977
44978C...Remove energy used up in junction string fragmentation.
44979 IF(MJU(1)+MJU(2).GT.0) THEN
44980 DO 790 JT=1,2
44981 IF(NJS(JT).EQ.0) GOTO 790
44982 DO 780 J=1,4
44983 P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
44984 780 CONTINUE
44985 790 CONTINUE
44986 ENDIF
44987
44988C...Produce new particle: side, origin.
44989 800 I=I+1
44990 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
44991 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
44992 IF(MSTU(21).GE.1) RETURN
44993 ENDIF
44994C.. New side priority for popcorn systems
44995 IF(MSTU(121).LE.0)THEN
44996 JT=1.5D0+PYR(0)
44997 IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
44998 IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
44999 ENDIF
45000 JR=3-JT
45001 JS=3-2*JT
45002 IRANK(JT)=IRANK(JT)+1
45003 K(I,1)=1
45004 K(I,3)=IE(JT)
45005 K(I,4)=0
45006 K(I,5)=0
45007
45008C...Generate flavour, hadron and pT.
45009 810 CONTINUE
45010 CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
45011 IF(K(I,2).EQ.0) GOTO 640
45012 MU90MO=MSTU(90)
45013 IF(MSTU(121).EQ.-1) GOTO 840
45014 IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
45015 &IABS(KFL(3)).GT.10) THEN
45016 IF(PYR(0).GT.PARJ(19)) GOTO 810
45017 ENDIF
45018 P(I,5)=PYMASS(K(I,2))
45019 CALL PYPTDI(KFL(JT),PX(3),PY(3))
45020 PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
45021
45022C...Final hadrons for small invariant mass.
45023 MSTJ(93)=1
45024 PMQ(3)=PYMASS(KFL(3))
45025 PARJST=PARJ(33)
45026 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
45027 WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
45028 IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
45029 &WMIN-0.5D0*PARJ(36)*PMQ(3)
45030 WREM2=FOUR(N+NRS,N+NRS)
45031 IF(WREM2.LT.0.10D0) GOTO 640
45032 IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)),
45033 &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1010
45034
45035C...Choose z, which gives Gamma. Shift z for heavy flavours.
45036 CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z)
45037 IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
45038 &MSTU(90).LT.8) THEN
45039 MSTU(90)=MSTU(90)+1
45040 MSTU(90+MSTU(90))=I
45041 PARU(90+MSTU(90))=Z
45042 ENDIF
45043 KFL1A=IABS(KFL(1))
45044 KFL2A=IABS(KFL(2))
45045 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
45046 &MOD(KFL2A/1000,10)).GE.4) THEN
45047 PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
45048 PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2)))
45049 Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2)
45050 PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
45051 IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1010
45052 ENDIF
45053 GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z)
45054
45055C.. MOPS baryon model modification
45056 XTMO3=(1D0-Z)*XTMO(JT)
45057 IF(IABS(KFL(3)).LE.10) NRVMO=0
45058 IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN
45059 GTSTMO=1D0
45060 PTSTMO=1D0
45061 RTSTMO=PYR(0)
45062 IF(IABS(KFL(JT)).LE.10)THEN
45063 XBMO=MIN(XTMO3,1D0-(2D-10))
45064 GBMO=GAM(3)
45065 PMMO=0D0
45066 PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT)
45067 GTSTMO=1D0-PARF(192)**PGMO
45068 ELSE
45069 IF(IRANK(JT).EQ.1) THEN
45070 GBMO=GAM(JT)
45071 PMMO=0D0
45072 XBMO=1D0
45073 ENDIF
45074 IF(XBMO.LT.1D0-(1D-10))THEN
45075 PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3)
45076 GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO)
45077 PGMO=PGNMO
45078 ENDIF
45079 IF(MSTJ(12).GE.5)THEN
45080 PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO))
45081 PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3)
45082 PTSTMO=EXP((PMMO-PMNMO)*PARF(193))
45083 PMMO=PMNMO
45084 ENDIF
45085 ENDIF
45086
45087C.. MOPS Accepting popcorn system hadron.
45088 IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN
45089 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN
45090 NRVMO=I-N-NR
45091 IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN
45092 CALL PYERRM(11,
45093 & '(PYSTRF:) no more memory left in PYJETS')
45094 IF(MSTU(21).GE.1) RETURN
45095 ENDIF
45096 IMO=I
45097 KFLMO=KFL(JT)
45098 PMQMO=PMQ(JT)
45099 PXMO=PX(JT)
45100 PYMO=PY(JT)
45101 GAMMO=GAM(JT)
45102 IRMO=IRANK(JT)
45103 XMO=XTMO(JT)
45104 DO 830 J=1,9
45105 IF(J.LE.5) THEN
45106 DO 820 LINE=1,I-N-NR
45107 P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J)
45108 K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J)
45109 820 CONTINUE
45110 ENDIF
45111 INMO(J)=IN(J)
45112 830 CONTINUE
45113 ENDIF
45114 ELSE
45115C..Reject popcorn system, flag=-1 if enforcing new one
45116 MSTU(121)=-1
45117 IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2
45118 ENDIF
45119 ENDIF
45120
45121
45122C..Lift restoring string outside MOPS block
45123 840 IF(MSTU(121).LT.0) THEN
45124 IF(MSTU(121).EQ.-2) MSTU(121)=0
45125 MSTU(90)=MU90MO
45126 NRVMO=0
45127 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 810
45128 I=IMO
45129 KFL(JT)=KFLMO
45130 PMQ(JT)=PMQMO
45131 PX(JT)=PXMO
45132 PY(JT)=PYMO
45133 GAM(JT)=GAMMO
45134 IRANK(JT)=IRMO
45135 XTMO(JT)=XMO
45136 DO 860 J=1,9
45137 IF(J.LE.5) THEN
45138 DO 850 LINE=1,I-N-NR
45139 P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J)
45140 K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J)
45141 850 CONTINUE
45142 ENDIF
45143 IN(J)=INMO(J)
45144 860 CONTINUE
45145 GOTO 810
45146 ENDIF
45147 XTMO(JT)=XTMO3
45148C.. MOPS end of modification
45149
45150 DO 870 J=1,3
45151 IN(J)=IN(3*JT+J)
45152 870 CONTINUE
45153
45154C...Stepping within or from 'low' string region easy.
45155 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
45156 &P(IN(1),5)**2.GE.PR(JT)) THEN
45157 P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
45158 P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
45159 DO 880 J=1,4
45160 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
45161 880 CONTINUE
45162 GOTO 970
45163 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
45164 P(IN(JR)+2,4)=P(IN(JR)+2,3)
45165 P(IN(JR)+2,JT)=1D0
45166 IN(JR)=IN(JR)+4*JS
45167 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 640
45168 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
45169 P(IN(JT)+2,4)=P(IN(JT)+2,3)
45170 P(IN(JT)+2,JT)=0D0
45171 IN(JT)=IN(JT)+4*JS
45172 ENDIF
45173 ENDIF
45174
45175C...Find new transverse directions (i.e. spacelike string vectors).
45176 890 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
45177 &IN(1).GT.IN(2)) GOTO 640
45178 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
45179 DO 900 J=1,4
45180 DP(1,J)=P(IN(1),J)
45181 DP(2,J)=P(IN(2),J)
45182 DP(3,J)=0D0
45183 DP(4,J)=0D0
45184 900 CONTINUE
45185 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
45186 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
45187 DHC12=DFOUR(1,2)
45188 IF(DHC12.LE.1D-2) THEN
45189 P(IN(JT)+2,4)=P(IN(JT)+2,3)
45190 P(IN(JT)+2,JT)=0D0
45191 IN(JT)=IN(JT)+4*JS
45192 GOTO 890
45193 ENDIF
45194 IN(3)=N+NR+4*NS+5
45195 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
45196 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
45197 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
45198 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
45199 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
45200 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
45201 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
45202 DHCX1=DFOUR(3,1)/DHC12
45203 DHCX2=DFOUR(3,2)/DHC12
45204 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
45205 DHCY1=DFOUR(4,1)/DHC12
45206 DHCY2=DFOUR(4,2)/DHC12
45207 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
45208 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
45209 DO 910 J=1,4
45210 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
45211 P(IN(3),J)=DP(3,J)
45212 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
45213 & DHCYX*DP(3,J))
45214 910 CONTINUE
45215C...Express pT with respect to new axes, if sensible.
45216 PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
45217 & FOUR(IN(3*JT+3)+1,IN(3)))
45218 PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
45219 & FOUR(IN(3*JT+3)+1,IN(3)+1))
45220 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
45221 PX(3)=PXP
45222 PY(3)=PYP
45223 ENDIF
45224 ENDIF
45225
45226C...Sum up known four-momentum. Gives coefficients for m2 expression.
45227 DO 940 J=1,4
45228 DHG(J)=0D0
45229 P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
45230 & PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
45231 DO 920 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
45232 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
45233 920 CONTINUE
45234 DO 930 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
45235 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
45236 930 CONTINUE
45237 940 CONTINUE
45238 DHM(1)=FOUR(I,I)
45239 DHM(2)=2D0*FOUR(I,IN(1))
45240 DHM(3)=2D0*FOUR(I,IN(2))
45241 DHM(4)=2D0*FOUR(IN(1),IN(2))
45242
45243C...Find coefficients for Gamma expression.
45244 DO 960 IN2=IN(1)+1,IN(2),4
45245 DO 950 IN1=IN(1),IN2-1,4
45246 DHC=2D0*FOUR(IN1,IN2)
45247 DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
45248 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
45249 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
45250 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
45251 950 CONTINUE
45252 960 CONTINUE
45253
45254C...Solve (m2, Gamma) equation system for energies taken.
45255 DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
45256 IF(ABS(DHS1).LT.1D-4) GOTO 640
45257 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
45258 &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
45259 DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
45260 P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
45261 &ABS(DHS1)-DHS2/DHS1)
45262 IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 640
45263 P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
45264 &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
45265
45266C...Step to new region if necessary.
45267 IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
45268 P(IN(JR)+2,4)=P(IN(JR)+2,3)
45269 P(IN(JR)+2,JT)=1D0
45270 IN(JR)=IN(JR)+4*JS
45271 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 640
45272 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
45273 P(IN(JT)+2,4)=P(IN(JT)+2,3)
45274 P(IN(JT)+2,JT)=0D0
45275 IN(JT)=IN(JT)+4*JS
45276 ENDIF
45277 GOTO 890
45278 ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
45279 P(IN(JT)+2,4)=P(IN(JT)+2,3)
45280 P(IN(JT)+2,JT)=0D0
45281 IN(JT)=IN(JT)+4*JS
45282 GOTO 890
45283 ENDIF
45284
45285C...Four-momentum of particle. Remaining quantities. Loop back.
45286 970 DO 980 J=1,4
45287 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
45288 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
45289 980 CONTINUE
45290 IF(P(I,4).LT.P(I,5)) GOTO 640
45291 KFL(JT)=-KFL(3)
45292 PMQ(JT)=PMQ(3)
45293 PX(JT)=-PX(3)
45294 PY(JT)=-PY(3)
45295 GAM(JT)=GAM(3)
45296 IF(IN(3).NE.IN(3*JT+3)) THEN
45297 DO 990 J=1,4
45298 P(IN(3*JT+3),J)=P(IN(3),J)
45299 P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
45300 990 CONTINUE
45301 ENDIF
45302 DO 1000 JQ=1,2
45303 IN(3*JT+JQ)=IN(JQ)
45304 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
45305 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
45306 1000 CONTINUE
45307 GOTO 800
45308
45309C...Final hadron: side, flavour, hadron, mass.
45310 1010 I=I+1
45311 K(I,1)=1
45312 K(I,3)=IE(JR)
45313 K(I,4)=0
45314 K(I,5)=0
45315 CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
45316 IF(K(I,2).EQ.0) GOTO 640
45317 P(I,5)=PYMASS(K(I,2))
45318 PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
45319
45320C...Final two hadrons: find common setup of four-vectors.
45321 JQ=1
45322 IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.
45323 &P(IN(7)+2,3)*P(IN(8)+2,3)*FOUR(IN(7),IN(8))) JQ=2
45324 DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
45325 DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
45326 DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
45327 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
45328 PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
45329 PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
45330 PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
45331 & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
45332 ENDIF
45333
45334C...Solve kinematics for final two hadrons, if possible.
45335 WREM2=WREM2+(PX(1)+PX(2))**2+(PY(1)+PY(2))**2
45336 FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
45337 IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200
45338 IF(FD.GE.1D0) GOTO 640
45339 FA=WREM2+PR(JT)-PR(JR)
45340 FB=SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT)))
45341 PREVCF=PARJ(42)
45342 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
45343 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*FB)))
45344 FB=SIGN(FB,JS*(PYR(0)-PREV))
45345 KFL1A=IABS(KFL(1))
45346 KFL2A=IABS(KFL(2))
45347 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
45348 &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2-
45349 &4D0*WREM2*PR(JT))),DBLE(JS))
45350 DO 1020 J=1,4
45351 P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
45352 & P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
45353 & DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
45354 P(I,J)=P(N+NRS,J)-P(I-1,J)
45355 1020 CONTINUE
45356 IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 640
45357
45358C...Mark jets as fragmented and give daughter pointers.
45359 N=I-NRS+1
45360 DO 1030 I=NSAV+1,NSAV+NP
45361 IM=K(I,3)
45362 K(IM,1)=K(IM,1)+10
45363 IF(MSTU(16).NE.2) THEN
45364 K(IM,4)=NSAV+1
45365 K(IM,5)=NSAV+1
45366 ELSE
45367 K(IM,4)=NSAV+2
45368 K(IM,5)=N
45369 ENDIF
45370 1030 CONTINUE
45371
45372C...Document string system. Move up particles.
45373 NSAV=NSAV+1
45374 K(NSAV,1)=11
45375 K(NSAV,2)=92
45376 K(NSAV,3)=IP
45377 K(NSAV,4)=NSAV+1
45378 K(NSAV,5)=N
45379 DO 1040 J=1,4
45380 P(NSAV,J)=DPS(J)
45381 V(NSAV,J)=V(IP,J)
45382 1040 CONTINUE
45383 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
45384 V(NSAV,5)=0D0
45385 DO 1060 I=NSAV+1,N
45386 DO 1050 J=1,5
45387 K(I,J)=K(I+NRS-1,J)
45388 P(I,J)=P(I+NRS-1,J)
45389 V(I,J)=0D0
45390 1050 CONTINUE
45391 1060 CONTINUE
45392 MSTU91=MSTU(90)
45393 DO 1070 IZ=MSTU90+1,MSTU91
45394 MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
45395 PARU9T(IZ)=PARU(90+IZ)
45396 1070 CONTINUE
45397 MSTU(90)=MSTU90
45398
45399C...Order particles in rank along the chain. Update mother pointer.
45400 DO 1090 I=NSAV+1,N
45401 DO 1080 J=1,5
45402 K(I-NSAV+N,J)=K(I,J)
45403 P(I-NSAV+N,J)=P(I,J)
45404 1080 CONTINUE
45405 1090 CONTINUE
45406 I1=NSAV
45407 DO 1120 I=N+1,2*N-NSAV
45408 IF(K(I,3).NE.IE(1)) GOTO 1120
45409 I1=I1+1
45410 DO 1100 J=1,5
45411 K(I1,J)=K(I,J)
45412 P(I1,J)=P(I,J)
45413 1100 CONTINUE
45414 IF(MSTU(16).NE.2) K(I1,3)=NSAV
45415 DO 1110 IZ=MSTU90+1,MSTU91
45416 IF(MSTU9T(IZ).EQ.I) THEN
45417 MSTU(90)=MSTU(90)+1
45418 MSTU(90+MSTU(90))=I1
45419 PARU(90+MSTU(90))=PARU9T(IZ)
45420 ENDIF
45421 1110 CONTINUE
45422 1120 CONTINUE
45423 DO 1150 I=2*N-NSAV,N+1,-1
45424 IF(K(I,3).EQ.IE(1)) GOTO 1150
45425 I1=I1+1
45426 DO 1130 J=1,5
45427 K(I1,J)=K(I,J)
45428 P(I1,J)=P(I,J)
45429 1130 CONTINUE
45430 IF(MSTU(16).NE.2) K(I1,3)=NSAV
45431 DO 1140 IZ=MSTU90+1,MSTU91
45432 IF(MSTU9T(IZ).EQ.I) THEN
45433 MSTU(90)=MSTU(90)+1
45434 MSTU(90+MSTU(90))=I1
45435 PARU(90+MSTU(90))=PARU9T(IZ)
45436 ENDIF
45437 1140 CONTINUE
45438 1150 CONTINUE
45439
45440C...Boost back particle system. Set production vertices.
45441 IF(MBST.EQ.0) THEN
45442 MSTU(33)=1
45443 CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),
45444 & DPS(3)/DPS(4))
45445 ELSE
45446 DO 1160 I=NSAV+1,N
45447 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
45448 IF(P(I,3).GT.0D0) THEN
45449 HHPEZ=(P(I,4)+P(I,3))*HHBZ
45450 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
45451 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
45452 ELSE
45453 HHPEZ=(P(I,4)-P(I,3))/HHBZ
45454 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
45455 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
45456 ENDIF
45457 1160 CONTINUE
45458 ENDIF
45459 DO 1180 I=NSAV+1,N
45460 DO 1170 J=1,4
45461 V(I,J)=V(IP,J)
45462 1170 CONTINUE
45463 1180 CONTINUE
45464
45465 RETURN
45466 END
45467
45468C*********************************************************************
45469
45470C...PYINDF
45471C...Handles the fragmentation of a jet system (or a single
45472C...jet) according to independent fragmentation models.
45473
45474 SUBROUTINE PYINDF(IP)
45475
45476C...Double precision and integer declarations.
45477 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45478 IMPLICIT INTEGER(I-N)
45479 INTEGER PYK,PYCHGE,PYCOMP
45480C...Commonblocks.
45481 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
45482 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45483 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45484 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
45485C...Local arrays.
45486 DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
45487 &KFLO(2),PXO(2),PYO(2),WO(2)
45488
45489C.. MOPS error message
45490 IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
45491 &' are not treated as expected in independent fragmentation')
45492
45493C...Reset counters. Identify parton system and take copy. Check flavour.
45494 NSAV=N
45495 MSTU90=MSTU(90)
45496 NJET=0
45497 KQSUM=0
45498 DO 100 J=1,5
45499 DPS(J)=0D0
45500 100 CONTINUE
45501 I=IP-1
45502 110 I=I+1
45503 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
45504 CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
45505 IF(MSTU(21).GE.1) RETURN
45506 ENDIF
45507 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
45508 KC=PYCOMP(K(I,2))
45509 IF(KC.EQ.0) GOTO 110
45510 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
45511 IF(KQ.EQ.0) GOTO 110
45512 NJET=NJET+1
45513 IF(KQ.NE.2) KQSUM=KQSUM+KQ
45514 DO 120 J=1,5
45515 K(NSAV+NJET,J)=K(I,J)
45516 P(NSAV+NJET,J)=P(I,J)
45517 DPS(J)=DPS(J)+P(I,J)
45518 120 CONTINUE
45519 K(NSAV+NJET,3)=I
45520 IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
45521 &K(I+1,1).EQ.2)) GOTO 110
45522 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
45523 CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
45524 IF(MSTU(21).GE.1) RETURN
45525 ENDIF
45526
45527C...Boost copied system to CM frame. Find CM energy and sum flavours.
45528 IF(NJET.NE.1) THEN
45529 MSTU(33)=1
45530 CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
45531 & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
45532 ENDIF
45533 PECM=0D0
45534 DO 130 J=1,3
45535 NFI(J)=0
45536 130 CONTINUE
45537 DO 140 I=NSAV+1,NSAV+NJET
45538 PECM=PECM+P(I,4)
45539 KFA=IABS(K(I,2))
45540 IF(KFA.LE.3) THEN
45541 NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
45542 ELSEIF(KFA.GT.1000) THEN
45543 KFLA=MOD(KFA/1000,10)
45544 KFLB=MOD(KFA/100,10)
45545 IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
45546 IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
45547 ENDIF
45548 140 CONTINUE
45549
45550C...Loop over attempts made. Reset counters.
45551 NTRY=0
45552 150 NTRY=NTRY+1
45553 IF(NTRY.GT.200) THEN
45554 CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
45555 IF(MSTU(21).GE.1) RETURN
45556 ENDIF
45557 N=NSAV+NJET
45558 MSTU(90)=MSTU90
45559 DO 160 J=1,3
45560 NFL(J)=NFI(J)
45561 IFET(J)=0
45562 KFLF(J)=0
45563 160 CONTINUE
45564
45565C...Loop over jets to be fragmented.
45566 DO 230 IP1=NSAV+1,NSAV+NJET
45567 MSTJ(91)=0
45568 NSAV1=N
45569 MSTU91=MSTU(90)
45570
45571C...Initial flavour and momentum values. Jet along +z axis.
45572 KFLH=IABS(K(IP1,2))
45573 IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
45574 KFLO(2)=0
45575 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
45576
45577C...Initial values for quark or diquark jet.
45578 170 IF(IABS(K(IP1,2)).NE.21) THEN
45579 NSTR=1
45580 KFLO(1)=K(IP1,2)
45581 CALL PYPTDI(0,PXO(1),PYO(1))
45582 WO(1)=WF
45583
45584C...Initial values for gluon treated like random quark jet.
45585 ELSEIF(MSTJ(2).LE.2) THEN
45586 NSTR=1
45587 IF(MSTJ(2).EQ.2) MSTJ(91)=1
45588 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
45589 CALL PYPTDI(0,PXO(1),PYO(1))
45590 WO(1)=WF
45591
45592C...Initial values for gluon treated like quark-antiquark jet pair,
45593C...sharing energy according to Altarelli-Parisi splitting function.
45594 ELSE
45595 NSTR=2
45596 IF(MSTJ(2).EQ.4) MSTJ(91)=1
45597 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
45598 KFLO(2)=-KFLO(1)
45599 CALL PYPTDI(0,PXO(1),PYO(1))
45600 PXO(2)=-PXO(1)
45601 PYO(2)=-PYO(1)
45602 WO(1)=WF*PYR(0)**(1D0/3D0)
45603 WO(2)=WF-WO(1)
45604 ENDIF
45605
45606C...Initial values for rank, flavour, pT and W+.
45607 DO 220 ISTR=1,NSTR
45608 180 I=N
45609 MSTU(90)=MSTU91
45610 IRANK=0
45611 KFL1=KFLO(ISTR)
45612 PX1=PXO(ISTR)
45613 PY1=PYO(ISTR)
45614 W=WO(ISTR)
45615
45616C...New hadron. Generate flavour and hadron species.
45617 190 I=I+1
45618 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
45619 CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS')
45620 IF(MSTU(21).GE.1) RETURN
45621 ENDIF
45622 IRANK=IRANK+1
45623 K(I,1)=1
45624 K(I,3)=IP1
45625 K(I,4)=0
45626 K(I,5)=0
45627 200 CALL PYKFDI(KFL1,0,KFL2,K(I,2))
45628 IF(K(I,2).EQ.0) GOTO 180
45629 IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN
45630 IF(PYR(0).GT.PARJ(19)) GOTO 200
45631 ENDIF
45632
45633C...Find hadron mass. Generate four-momentum.
45634 P(I,5)=PYMASS(K(I,2))
45635 CALL PYPTDI(KFL1,PX2,PY2)
45636 P(I,1)=PX1+PX2
45637 P(I,2)=PY1+PY2
45638 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
45639 CALL PYZDIS(KFL1,KFL2,PR,Z)
45640 MZSAV=0
45641 IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
45642 MZSAV=1
45643 MSTU(90)=MSTU(90)+1
45644 MSTU(90+MSTU(90))=I
45645 PARU(90+MSTU(90))=Z
45646 ENDIF
45647 P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W))
45648 P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W))
45649 IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
45650 & P(I,3).LE.0.001D0) THEN
45651 IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180
45652 P(I,3)=0.0001D0
45653 P(I,4)=SQRT(PR)
45654 Z=P(I,4)/W
45655 ENDIF
45656
45657C...Remaining flavour and momentum.
45658 KFL1=-KFL2
45659 PX1=-PX2
45660 PY1=-PY2
45661 W=(1D0-Z)*W
45662 DO 210 J=1,5
45663 V(I,J)=0D0
45664 210 CONTINUE
45665
45666C...Check if pL acceptable. Go back for new hadron if enough energy.
45667 IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN
45668 I=I-1
45669 IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
45670 ENDIF
45671 IF(W.GT.PARJ(31)) GOTO 190
45672 N=I
45673 220 CONTINUE
45674 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32)
45675 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
45676
45677C...Rotate jet to new direction.
45678 THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
45679 PHI=PYANGL(P(IP1,1),P(IP1,2))
45680 MSTU(33)=1
45681 CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
45682 K(K(IP1,3),4)=NSAV1+1
45683 K(K(IP1,3),5)=N
45684
45685C...End of jet generation loop. Skip conservation in some cases.
45686 230 CONTINUE
45687 IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
45688 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
45689
45690C...Subtract off produced hadron flavours, finished if zero.
45691 DO 240 I=NSAV+NJET+1,N
45692 KFA=IABS(K(I,2))
45693 KFLA=MOD(KFA/1000,10)
45694 KFLB=MOD(KFA/100,10)
45695 KFLC=MOD(KFA/10,10)
45696 IF(KFLA.EQ.0) THEN
45697 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
45698 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
45699 ELSE
45700 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
45701 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
45702 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
45703 ENDIF
45704 240 CONTINUE
45705 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
45706 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
45707 IF(NREQ.EQ.0) GOTO 320
45708
45709C...Take away flavour of low-momentum particles until enough freedom.
45710 NREM=0
45711 250 IREM=0
45712 P2MIN=PECM**2
45713 DO 260 I=NSAV+NJET+1,N
45714 P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
45715 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
45716 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
45717 260 CONTINUE
45718 IF(IREM.EQ.0) GOTO 150
45719 K(IREM,1)=7
45720 KFA=IABS(K(IREM,2))
45721 KFLA=MOD(KFA/1000,10)
45722 KFLB=MOD(KFA/100,10)
45723 KFLC=MOD(KFA/10,10)
45724 IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
45725 IF(K(IREM,1).EQ.8) GOTO 250
45726 IF(KFLA.EQ.0) THEN
45727 ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
45728 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
45729 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
45730 ELSE
45731 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
45732 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
45733 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
45734 ENDIF
45735 NREM=NREM+1
45736 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
45737 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
45738 IF(NREQ.GT.NREM) GOTO 250
45739 DO 270 I=NSAV+NJET+1,N
45740 IF(K(I,1).EQ.8) K(I,1)=1
45741 270 CONTINUE
45742
45743C...Find combination of existing and new flavours for hadron.
45744 280 NFET=2
45745 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
45746 IF(NREQ.LT.NREM) NFET=1
45747 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
45748 DO 290 J=1,NFET
45749 IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0)
45750 KFLF(J)=ISIGN(1,NFL(1))
45751 IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
45752 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
45753 290 CONTINUE
45754 IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
45755 &GOTO 280
45756 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
45757 &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
45758 &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
45759 IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0))
45760 IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
45761 IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1))
45762 IF(NFET.LE.2) KFLF(3)=0
45763 IF(KFLF(3).NE.0) THEN
45764 KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
45765 & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
45766 IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0)
45767 & KFLFC=KFLFC+ISIGN(2,KFLFC)
45768 ELSE
45769 KFLFC=KFLF(1)
45770 ENDIF
45771 CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
45772 IF(KF.EQ.0) GOTO 280
45773 DO 300 J=1,MAX(2,NFET)
45774 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
45775 300 CONTINUE
45776
45777C...Store hadron at random among free positions.
45778 NPOS=MIN(1+INT(PYR(0)*NREM),NREM)
45779 DO 310 I=NSAV+NJET+1,N
45780 IF(K(I,1).EQ.7) NPOS=NPOS-1
45781 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
45782 K(I,1)=1
45783 K(I,2)=KF
45784 P(I,5)=PYMASS(K(I,2))
45785 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
45786 310 CONTINUE
45787 NREM=NREM-1
45788 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
45789 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
45790 IF(NREM.GT.0) GOTO 280
45791
45792C...Compensate for missing momentum in global scheme (3 options).
45793 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
45794 DO 340 J=1,3
45795 PSI(J)=0D0
45796 DO 330 I=NSAV+NJET+1,N
45797 PSI(J)=PSI(J)+P(I,J)
45798 330 CONTINUE
45799 340 CONTINUE
45800 PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
45801 PWS=0D0
45802 DO 350 I=NSAV+NJET+1,N
45803 IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
45804 IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
45805 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
45806 IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0
45807 350 CONTINUE
45808 DO 370 I=NSAV+NJET+1,N
45809 IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
45810 IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
45811 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
45812 IF(MOD(MSTJ(3),5).EQ.3) PW=1D0
45813 DO 360 J=1,3
45814 P(I,J)=P(I,J)-PSI(J)*PW/PWS
45815 360 CONTINUE
45816 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
45817 370 CONTINUE
45818
45819C...Compensate for missing momentum withing each jet separately.
45820 ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
45821 DO 390 I=N+1,N+NJET
45822 K(I,1)=0
45823 DO 380 J=1,5
45824 P(I,J)=0D0
45825 380 CONTINUE
45826 390 CONTINUE
45827 DO 410 I=NSAV+NJET+1,N
45828 IR1=K(I,3)
45829 IR2=N+IR1-NSAV
45830 K(IR2,1)=K(IR2,1)+1
45831 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
45832 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
45833 DO 400 J=1,3
45834 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
45835 400 CONTINUE
45836 P(IR2,4)=P(IR2,4)+P(I,4)
45837 P(IR2,5)=P(IR2,5)+PLS
45838 410 CONTINUE
45839 PSS=0D0
45840 DO 420 I=N+1,N+NJET
45841 IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0))
45842 420 CONTINUE
45843 DO 440 I=NSAV+NJET+1,N
45844 IR1=K(I,3)
45845 IR2=N+IR1-NSAV
45846 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
45847 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
45848 DO 430 J=1,3
45849 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)*
45850 & PLS*P(IR1,J)
45851 430 CONTINUE
45852 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
45853 440 CONTINUE
45854 ENDIF
45855
45856C...Scale momenta for energy conservation.
45857 IF(MOD(MSTJ(3),5).NE.0) THEN
45858 PMS=0D0
45859 PES=0D0
45860 PQS=0D0
45861 DO 450 I=NSAV+NJET+1,N
45862 PMS=PMS+P(I,5)
45863 PES=PES+P(I,4)
45864 PQS=PQS+P(I,5)**2/P(I,4)
45865 450 CONTINUE
45866 IF(PMS.GE.PECM) GOTO 150
45867 NECO=0
45868 460 NECO=NECO+1
45869 PFAC=(PECM-PQS)/(PES-PQS)
45870 PES=0D0
45871 PQS=0D0
45872 DO 480 I=NSAV+NJET+1,N
45873 DO 470 J=1,3
45874 P(I,J)=PFAC*P(I,J)
45875 470 CONTINUE
45876 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
45877 PES=PES+P(I,4)
45878 PQS=PQS+P(I,5)**2/P(I,4)
45879 480 CONTINUE
45880 IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
45881 ENDIF
45882
45883C...Origin of produced particles and parton daughter pointers.
45884 490 DO 500 I=NSAV+NJET+1,N
45885 IF(MSTU(16).NE.2) K(I,3)=NSAV+1
45886 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
45887 500 CONTINUE
45888 DO 510 I=NSAV+1,NSAV+NJET
45889 I1=K(I,3)
45890 K(I1,1)=K(I1,1)+10
45891 IF(MSTU(16).NE.2) THEN
45892 K(I1,4)=NSAV+1
45893 K(I1,5)=NSAV+1
45894 ELSE
45895 K(I1,4)=K(I1,4)-NJET+1
45896 K(I1,5)=K(I1,5)-NJET+1
45897 IF(K(I1,5).LT.K(I1,4)) THEN
45898 K(I1,4)=0
45899 K(I1,5)=0
45900 ENDIF
45901 ENDIF
45902 510 CONTINUE
45903
45904C...Document independent fragmentation system. Remove copy of jets.
45905 NSAV=NSAV+1
45906 K(NSAV,1)=11
45907 K(NSAV,2)=93
45908 K(NSAV,3)=IP
45909 K(NSAV,4)=NSAV+1
45910 K(NSAV,5)=N-NJET+1
45911 DO 520 J=1,4
45912 P(NSAV,J)=DPS(J)
45913 V(NSAV,J)=V(IP,J)
45914 520 CONTINUE
45915 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
45916 V(NSAV,5)=0D0
45917 DO 540 I=NSAV+NJET,N
45918 DO 530 J=1,5
45919 K(I-NJET+1,J)=K(I,J)
45920 P(I-NJET+1,J)=P(I,J)
45921 V(I-NJET+1,J)=V(I,J)
45922 530 CONTINUE
45923 540 CONTINUE
45924 N=N-NJET+1
45925 DO 550 IZ=MSTU90+1,MSTU(90)
45926 MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
45927 550 CONTINUE
45928
45929C...Boost back particle system. Set production vertices.
45930 IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
45931 &DPS(2)/DPS(4),DPS(3)/DPS(4))
45932 DO 570 I=NSAV+1,N
45933 DO 560 J=1,4
45934 V(I,J)=V(IP,J)
45935 560 CONTINUE
45936 570 CONTINUE
45937
45938 RETURN
45939 END
45940
45941C*********************************************************************
45942
45943C...PYDECY
45944C...Handles the decay of unstable particles.
45945
45946 SUBROUTINE PYDECY(IP)
45947
45948C...Double precision and integer declarations.
45949 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45950 IMPLICIT INTEGER(I-N)
45951 INTEGER PYK,PYCHGE,PYCOMP
45952C...Commonblocks.
45953 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
45954 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45955 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45956 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
45957 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
45958C...Local arrays.
45959 DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
45960 &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
45961 CHARACTER CIDC*4
45962 DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
45963
45964C...Functions: momentum in two-particle decays and four-product.
45965 PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
45966 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)
45967
45968C...Initial values.
45969 NTRY=0
45970 NSAV=N
45971 KFA=IABS(K(IP,2))
45972 KFS=ISIGN(1,K(IP,2))
45973 KC=PYCOMP(KFA)
45974 MSTJ(92)=0
45975
45976C...Choose lifetime and determine decay vertex.
45977 IF(K(IP,1).EQ.5) THEN
45978 V(IP,5)=0D0
45979 ELSEIF(K(IP,1).NE.4) THEN
45980 V(IP,5)=-PMAS(KC,4)*LOG(PYR(0))
45981 ENDIF
45982 DO 100 J=1,4
45983 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
45984 100 CONTINUE
45985
45986C...Determine whether decay allowed or not.
45987 MOUT=0
45988 IF(MSTJ(22).EQ.2) THEN
45989 IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
45990 ELSEIF(MSTJ(22).EQ.3) THEN
45991 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
45992 ELSEIF(MSTJ(22).EQ.4) THEN
45993 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
45994 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
45995 ENDIF
45996 IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
45997 K(IP,1)=4
45998 RETURN
45999 ENDIF
46000
46001C...Interface to external tau decay library (for tau polarization).
46002 IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
46003
46004C...Starting values for pointers and momenta.
46005 ITAU=IP
46006 DO 110 J=1,4
46007 PTAU(J)=P(ITAU,J)
46008 PCMTAU(J)=P(ITAU,J)
46009 110 CONTINUE
46010
46011C...Iterate to find position and code of mother of tau.
46012 IMTAU=ITAU
46013 120 IMTAU=K(IMTAU,3)
46014
46015 IF(IMTAU.EQ.0) THEN
46016C...If no known origin then impossible to do anything further.
46017 KFORIG=0
46018 IORIG=0
46019
46020 ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
46021C...If tau -> tau + gamma then add gamma energy and loop.
46022 IF(K(K(IMTAU,4),2).EQ.22) THEN
46023 DO 130 J=1,4
46024 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
46025 130 CONTINUE
46026 ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
46027 DO 140 J=1,4
46028 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
46029 140 CONTINUE
46030 ENDIF
46031 GOTO 120
46032
46033 ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
46034C...If coming from weak decay of hadron then W is not stored in record,
46035C...but can be reconstructed by adding neutrino momentum.
46036 KFORIG=-ISIGN(24,K(ITAU,2))
46037 IORIG=0
46038 DO 160 II=K(IMTAU,4),K(IMTAU,5)
46039 IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
46040 DO 150 J=1,4
46041 PCMTAU(J)=PCMTAU(J)+P(II,J)
46042 150 CONTINUE
46043 ENDIF
46044 160 CONTINUE
46045
46046 ELSE
46047C...If coming from resonance decay then find latest copy of this
46048C...resonance (may not completely agree).
46049 KFORIG=K(IMTAU,2)
46050 IORIG=IMTAU
46051 DO 170 II=IMTAU+1,IP-1
46052 IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
46053 & ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II
46054 170 CONTINUE
46055 DO 180 J=1,4
46056 PCMTAU(J)=P(IORIG,J)
46057 180 CONTINUE
46058 ENDIF
46059
46060C...Boost tau to rest frame of production process (where known)
46061C...and rotate it to sit along +z axis.
46062 DO 190 J=1,3
46063 DBETAU(J)=PCMTAU(J)/PCMTAU(4)
46064 190 CONTINUE
46065 IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1),
46066 & -DBETAU(2),-DBETAU(3))
46067 PHITAU=PYANGL(P(ITAU,1),P(ITAU,2))
46068 CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0)
46069 THETAU=PYANGL(P(ITAU,3),P(ITAU,1))
46070 CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0)
46071
46072C...Call tau decay routine (if meaningful) and fill extra info.
46073 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
46074 CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
46075 DO 200 II=NSAV+1,NSAV+NDECAY
46076 K(II,1)=1
46077 K(II,3)=IP
46078 K(II,4)=0
46079 K(II,5)=0
46080 200 CONTINUE
46081 N=NSAV+NDECAY
46082 ENDIF
46083
46084C...Boost back decay tau and decay products.
46085 DO 210 J=1,4
46086 P(ITAU,J)=PTAU(J)
46087 210 CONTINUE
46088 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
46089 CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
46090 IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1),
46091 & DBETAU(2),DBETAU(3))
46092
46093C...Skip past ordinary tau decay treatment.
46094 MMAT=0
46095 MBST=0
46096 ND=0
46097 GOTO 630
46098 ENDIF
46099 ENDIF
46100
46101C...B-Bbar mixing: flip sign of meson appropriately.
46102 MMIX=0
46103 IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
46104 XBBMIX=PARJ(76)
46105 IF(KFA.EQ.531) XBBMIX=PARJ(77)
46106 IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1
46107 IF(MMIX.EQ.1) KFS=-KFS
46108 ENDIF
46109
46110C...Check existence of decay channels. Particle/antiparticle rules.
46111 KCA=KC
46112 IF(MDCY(KC,2).GT.0) THEN
46113 MDMDCY=MDME(MDCY(KC,2),2)
46114 IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
46115 ENDIF
46116 IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
46117 CALL PYERRM(9,'(PYDECY:) no decay channel defined')
46118 RETURN
46119 ENDIF
46120 IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS
46121 IF(KCHG(KC,3).EQ.0) THEN
46122 KFSP=1
46123 KFSN=0
46124 IF(PYR(0).GT.0.5D0) KFS=-KFS
46125 ELSEIF(KFS.GT.0) THEN
46126 KFSP=1
46127 KFSN=0
46128 ELSE
46129 KFSP=0
46130 KFSN=1
46131 ENDIF
46132
46133C...Sum branching ratios of allowed decay channels.
46134 220 NOPE=0
46135 BRSU=0D0
46136 DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
46137 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
46138 & KFSN*MDME(IDL,1).NE.3) GOTO 230
46139 IF(MDME(IDL,2).GT.100) GOTO 230
46140 NOPE=NOPE+1
46141 BRSU=BRSU+BRAT(IDL)
46142 230 CONTINUE
46143 IF(NOPE.EQ.0) THEN
46144 CALL PYERRM(2,'(PYDECY:) all decay channels closed by user')
46145 RETURN
46146 ENDIF
46147
46148C...Select decay channel among allowed ones.
46149 240 RBR=BRSU*PYR(0)
46150 IDL=MDCY(KCA,2)-1
46151 250 IDL=IDL+1
46152 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
46153 &KFSN*MDME(IDL,1).NE.3) THEN
46154 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
46155 ELSEIF(MDME(IDL,2).GT.100) THEN
46156 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
46157 ELSE
46158 IDC=IDL
46159 RBR=RBR-BRAT(IDL)
46160 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250
46161 ENDIF
46162
46163C...Start readout of decay channel: matrix element, reset counters.
46164 MMAT=MDME(IDC,2)
46165 260 NTRY=NTRY+1
46166 IF(MOD(NTRY,200).EQ.0) THEN
46167 WRITE(CIDC,'(I4)') IDC
46168C...Do not print warning for some well-known special cases.
46169 IF(KFA.NE.113.AND.KFA.NE.115.AND.KFA.NE.215)
46170 & CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'//
46171 & CIDC)
46172 GOTO 240
46173 ENDIF
46174 IF(NTRY.GT.1000) THEN
46175 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
46176 IF(MSTU(21).GE.1) RETURN
46177 ENDIF
46178 I=N
46179 NP=0
46180 NQ=0
46181 MBST=0
46182 IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1
46183 DO 270 J=1,4
46184 PV(1,J)=0D0
46185 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
46186 270 CONTINUE
46187 IF(MBST.EQ.1) PV(1,4)=P(IP,5)
46188 PV(1,5)=P(IP,5)
46189 PS=0D0
46190 PSQ=0D0
46191 MREM=0
46192 MHADDY=0
46193 IF(KFA.GT.80) MHADDY=1
46194C.. Random flavour and popcorn system memory.
46195 IRNDMO=0
46196 JTMO=0
46197 MSTU(121)=0
46198 MSTU(125)=10
46199
46200C...Read out decay products. Convert to standard flavour code.
46201 JTMAX=5
46202 IF(MDME(IDC+1,2).EQ.101) JTMAX=10
46203 DO 280 JT=1,JTMAX
46204 IF(JT.LE.5) KP=KFDP(IDC,JT)
46205 IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
46206 IF(KP.EQ.0) GOTO 280
46207 KPA=IABS(KP)
46208 KCP=PYCOMP(KPA)
46209 IF(KPA.GT.80) MHADDY=1
46210 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
46211 KFP=KP
46212 ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
46213 KFP=KFS*KP
46214 ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
46215 KFP=-KFS*MOD(KFA/10,10)
46216 ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
46217 KFP=KFS*(100*MOD(KFA/10,100)+3)
46218 ELSEIF(KPA.EQ.81) THEN
46219 KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
46220 ELSEIF(KP.EQ.82) THEN
46221 CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP)
46222 IF(KFP.EQ.0) GOTO 260
46223 KFP=-KFP
46224 IRNDMO=1
46225 MSTJ(93)=1
46226 IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260
46227 ELSEIF(KP.EQ.-82) THEN
46228 KFP=MSTU(124)
46229 ENDIF
46230 IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP)
46231
46232C...Add decay product to event record or to quark flavour list.
46233 KFPA=IABS(KFP)
46234 KQP=KCHG(KCP,2)
46235 IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
46236 NQ=NQ+1
46237 KFLO(NQ)=KFP
46238C...set rndmflav popcorn system pointer
46239 IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ
46240 MSTJ(93)=2
46241 PSQ=PSQ+PYMASS(KFLO(NQ))
46242 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
46243 & MOD(NQ,2).EQ.1) THEN
46244 NQ=NQ-1
46245 PS=PS-P(I,5)
46246 K(I,1)=1
46247 KFI=K(I,2)
46248 CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2))
46249 IF(K(I,2).EQ.0) GOTO 260
46250 MSTJ(93)=1
46251 P(I,5)=PYMASS(K(I,2))
46252 PS=PS+P(I,5)
46253 ELSE
46254 I=I+1
46255 NP=NP+1
46256 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
46257 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
46258 K(I,1)=1+MOD(NQ,2)
46259 IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
46260 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
46261 K(I,2)=KFP
46262 K(I,3)=IP
46263 K(I,4)=0
46264 K(I,5)=0
46265 P(I,5)=PYMASS(KFP)
46266 PS=PS+P(I,5)
46267 ENDIF
46268 280 CONTINUE
46269
46270C...Check masses for resonance decays.
46271 IF(MHADDY.EQ.0) THEN
46272 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
46273 ENDIF
46274
46275C...Choose decay multiplicity in phase space model.
46276 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
46277 PSP=PS
46278 CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0))
46279 IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
46280 300 NTRY=NTRY+1
46281C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
46282 IF(IRNDMO.EQ.0) THEN
46283 MSTU(121)=0
46284 JTMO=0
46285 ELSEIF(IRNDMO.EQ.1) THEN
46286 IRNDMO=2
46287 ELSE
46288 GOTO 260
46289 ENDIF
46290 IF(NTRY.GT.1000) THEN
46291 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
46292 IF(MSTU(21).GE.1) RETURN
46293 ENDIF
46294 IF(MMAT.LE.20) THEN
46295 GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))*
46296 & SIN(PARU(2)*PYR(0))
46297 ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS
46298 IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
46299 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
46300 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
46301 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
46302 ELSE
46303 ND=MMAT-20
46304 ENDIF
46305C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
46306 MSTU(125)=ND-NQ/2
46307 IF(MSTU(121).GT.MSTU(125)) GOTO 300
46308
46309C...Form hadrons from flavour content.
46310 DO 310 JT=1,NQ
46311 KFL1(JT)=KFLO(JT)
46312 310 CONTINUE
46313 IF(ND.EQ.NP+NQ/2) GOTO 330
46314 DO 320 I=N+NP+1,N+ND-NQ/2
46315C.. Stick to started popcorn system, else pick side at random
46316 JT=JTMO
46317 IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0))
46318 CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2))
46319 IF(K(I,2).EQ.0) GOTO 300
46320 MSTU(125)=MSTU(125)-1
46321 JTMO=0
46322 IF(MSTU(121).GT.0) JTMO=JT
46323 KFL1(JT)=-KFL2
46324 320 CONTINUE
46325 330 JT=2
46326 JT2=3
46327 JT3=4
46328 IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4
46329 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
46330 & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
46331 IF(JT.EQ.3) JT2=2
46332 IF(JT.EQ.4) JT3=2
46333 CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
46334 IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
46335 IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
46336 IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
46337
46338C...Check that sum of decay product masses not too large.
46339 PS=PSP
46340 DO 340 I=N+NP+1,N+ND
46341 K(I,1)=1
46342 K(I,3)=IP
46343 K(I,4)=0
46344 K(I,5)=0
46345 P(I,5)=PYMASS(K(I,2))
46346 PS=PS+P(I,5)
46347 340 CONTINUE
46348 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
46349
46350C...Rescale energy to subtract off spectator quark mass.
46351 ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44)
46352 & .AND.NP.GE.3) THEN
46353 PS=PS-P(N+NP,5)
46354 PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
46355 DO 350 J=1,5
46356 P(N+NP,J)=PQT*PV(1,J)
46357 PV(1,J)=(1D0-PQT)*PV(1,J)
46358 350 CONTINUE
46359 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
46360 ND=NP-1
46361 MREM=1
46362
46363C...Fully specified final state: check mass broadening effects.
46364 ELSE
46365 IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
46366 ND=NP
46367 ENDIF
46368
46369C...Determine position of grandmother, number of sisters.
46370 NM=0
46371 KFAS=0
46372 MSGN=0
46373 IF(MMAT.EQ.3) THEN
46374 IM=K(IP,3)
46375 IF(IM.LT.0.OR.IM.GE.IP) IM=0
46376 IF(IM.NE.0) KFAM=IABS(K(IM,2))
46377 IF(IM.NE.0) THEN
46378 DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
46379 IF(K(IL,3).EQ.IM) NM=NM+1
46380 IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
46381 360 CONTINUE
46382 IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
46383 & MOD(KFAM/1000,10).NE.0) NM=0
46384 IF(NM.EQ.2) THEN
46385 KFAS=IABS(K(ISIS,2))
46386 IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
46387 & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
46388 ENDIF
46389 ENDIF
46390 ENDIF
46391
46392C...Kinematics of one-particle decays.
46393 IF(ND.EQ.1) THEN
46394 DO 370 J=1,4
46395 P(N+1,J)=P(IP,J)
46396 370 CONTINUE
46397 GOTO 630
46398 ENDIF
46399
46400C...Calculate maximum weight ND-particle decay.
46401 PV(ND,5)=P(N+ND,5)
46402 IF(ND.GE.3) THEN
46403 WTMAX=1D0/WTCOR(ND-2)
46404 PMAX=PV(1,5)-PS+P(N+ND,5)
46405 PMIN=0D0
46406 DO 380 IL=ND-1,1,-1
46407 PMAX=PMAX+P(N+IL,5)
46408 PMIN=PMIN+P(N+IL+1,5)
46409 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
46410 380 CONTINUE
46411 ENDIF
46412
46413C...Find virtual gamma mass in Dalitz decay.
46414 390 IF(ND.EQ.2) THEN
46415 ELSEIF(MMAT.EQ.2) THEN
46416 PMES=4D0*PMAS(11,1)**2
46417 PMRHO2=PMAS(131,1)**2
46418 PGRHO2=PMAS(131,2)**2
46419 400 PMST=PMES*(P(IP,5)**2/PMES)**PYR(0)
46420 WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))*
46421 & (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/
46422 & ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
46423 IF(WT.LT.PYR(0)) GOTO 400
46424 PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST))
46425
46426C...M-generator gives weight. If rejected, try again.
46427 ELSE
46428 410 RORD(1)=1D0
46429 DO 440 IL1=2,ND-1
46430 RSAV=PYR(0)
46431 DO 420 IL2=IL1-1,1,-1
46432 IF(RSAV.LE.RORD(IL2)) GOTO 430
46433 RORD(IL2+1)=RORD(IL2)
46434 420 CONTINUE
46435 430 RORD(IL2+1)=RSAV
46436 440 CONTINUE
46437 RORD(ND)=0D0
46438 WT=1D0
46439 DO 450 IL=ND-1,1,-1
46440 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
46441 & (PV(1,5)-PS)
46442 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
46443 450 CONTINUE
46444 IF(WT.LT.PYR(0)*WTMAX) GOTO 410
46445 ENDIF
46446
46447C...Perform two-particle decays in respective CM frame.
46448 460 DO 480 IL=1,ND-1
46449 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
46450 UE(3)=2D0*PYR(0)-1D0
46451 PHI=PARU(2)*PYR(0)
46452 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
46453 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
46454 DO 470 J=1,3
46455 P(N+IL,J)=PA*UE(J)
46456 PV(IL+1,J)=-PA*UE(J)
46457 470 CONTINUE
46458 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
46459 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
46460 480 CONTINUE
46461
46462C...Lorentz transform decay products to lab frame.
46463 DO 490 J=1,4
46464 P(N+ND,J)=PV(ND,J)
46465 490 CONTINUE
46466 DO 530 IL=ND-1,1,-1
46467 DO 500 J=1,3
46468 BE(J)=PV(IL,J)/PV(IL,4)
46469 500 CONTINUE
46470 GA=PV(IL,4)/PV(IL,5)
46471 DO 520 I=N+IL,N+ND
46472 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
46473 DO 510 J=1,3
46474 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
46475 510 CONTINUE
46476 P(I,4)=GA*(P(I,4)+BEP)
46477 520 CONTINUE
46478 530 CONTINUE
46479
46480C...Check that no infinite loop in matrix element weight.
46481 NTRY=NTRY+1
46482 IF(NTRY.GT.800) GOTO 560
46483
46484C...Matrix elements for omega and phi decays.
46485 IF(MMAT.EQ.1) THEN
46486 WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
46487 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
46488 & +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
46489 IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390
46490
46491C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
46492 ELSEIF(MMAT.EQ.2) THEN
46493 FOUR12=FOUR(N+1,N+2)
46494 FOUR13=FOUR(N+1,N+3)
46495 WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+
46496 & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
46497 IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460
46498
46499C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
46500C...V vector), of form cos**2(theta02) in V1 rest frame, and for
46501C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
46502 ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
46503 FOUR10=FOUR(IP,IM)
46504 FOUR12=FOUR(IP,N+1)
46505 FOUR02=FOUR(IM,N+1)
46506 PMS1=P(IP,5)**2
46507 PMS0=P(IM,5)**2
46508 PMS2=P(N+1,5)**2
46509 IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
46510 IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02-
46511 & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
46512 HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM)
46513 HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
46514 IF(HNUM.LT.PYR(0)*HDEN) GOTO 460
46515
46516C...Matrix element for "onium" -> g + g + g or gamma + g + g.
46517 ELSEIF(MMAT.EQ.4) THEN
46518 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
46519 HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2
46520 HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2
46521 WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+
46522 & ((1D0-HX3)/(HX1*HX2))**2
46523 IF(WT.LT.2D0*PYR(0)) GOTO 390
46524 IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2)
46525 & GOTO 390
46526
46527C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
46528 ELSEIF(MMAT.EQ.41) THEN
46529 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
46530 HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5)))
46531 IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390
46532
46533C...Matrix elements for weak decays (only semileptonic for c and b)
46534 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
46535 & .AND.ND.EQ.3) THEN
46536 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
46537 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
46538 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
46539 ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN
46540 DO 550 J=1,4
46541 P(N+NP+1,J)=0D0
46542 DO 540 IS=N+3,N+NP
46543 P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
46544 540 CONTINUE
46545 550 CONTINUE
46546 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
46547 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
46548 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
46549 ENDIF
46550
46551C...Scale back energy and reattach spectator.
46552 560 IF(MREM.EQ.1) THEN
46553 DO 570 J=1,5
46554 PV(1,J)=PV(1,J)/(1D0-PQT)
46555 570 CONTINUE
46556 ND=ND+1
46557 MREM=0
46558 ENDIF
46559
46560C...Low invariant mass for system with spectator quark gives particle,
46561C...not two jets. Readjust momenta accordingly.
46562 IF(MMAT.EQ.31.AND.ND.EQ.3) THEN
46563 MSTJ(93)=1
46564 PM2=PYMASS(K(N+2,2))
46565 MSTJ(93)=1
46566 PM3=PYMASS(K(N+3,2))
46567 IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE.
46568 & (PARJ(32)+PM2+PM3)**2) GOTO 630
46569 K(N+2,1)=1
46570 KFTEMP=K(N+2,2)
46571 CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
46572 IF(K(N+2,2).EQ.0) GOTO 260
46573 P(N+2,5)=PYMASS(K(N+2,2))
46574 PS=P(N+1,5)+P(N+2,5)
46575 PV(2,5)=P(N+2,5)
46576 MMAT=0
46577 ND=2
46578 GOTO 460
46579 ELSEIF(MMAT.EQ.44) THEN
46580 MSTJ(93)=1
46581 PM3=PYMASS(K(N+3,2))
46582 MSTJ(93)=1
46583 PM4=PYMASS(K(N+4,2))
46584 IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE.
46585 & (PARJ(32)+PM3+PM4)**2) GOTO 600
46586 K(N+3,1)=1
46587 KFTEMP=K(N+3,2)
46588 CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
46589 IF(K(N+3,2).EQ.0) GOTO 260
46590 P(N+3,5)=PYMASS(K(N+3,2))
46591 DO 580 J=1,3
46592 P(N+3,J)=P(N+3,J)+P(N+4,J)
46593 580 CONTINUE
46594 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)
46595 HA=P(N+1,4)**2-P(N+2,4)**2
46596 HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
46597 HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
46598 & (P(N+1,3)-P(N+2,3))**2
46599 HD=(PV(1,4)-P(N+3,4))**2
46600 HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
46601 HF=HD*HC-HB**2
46602 HG=HD*HC-HA*HB
46603 HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF)
46604 DO 590 J=1,3
46605 PCOR=HH*(P(N+1,J)-P(N+2,J))
46606 P(N+1,J)=P(N+1,J)+PCOR
46607 P(N+2,J)=P(N+2,J)-PCOR
46608 590 CONTINUE
46609 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)
46610 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)
46611 ND=ND-1
46612 ENDIF
46613
46614C...Check invariant mass of W jets. May give one particle or start over.
46615 600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
46616 &.AND.IABS(K(N+1,2)).LT.10) THEN
46617 PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2)))
46618 MSTJ(93)=1
46619 PM1=PYMASS(K(N+1,2))
46620 MSTJ(93)=1
46621 PM2=PYMASS(K(N+2,2))
46622 IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610
46623 KFLDUM=INT(1.5D0+PYR(0))
46624 CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
46625 CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
46626 IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260
46627 PSM=PYMASS(KF1)+PYMASS(KF2)
46628 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610
46629 IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610
46630 IF(MMAT.EQ.48) GOTO 390
46631 IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260
46632 K(N+1,1)=1
46633 KFTEMP=K(N+1,2)
46634 CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
46635 IF(K(N+1,2).EQ.0) GOTO 260
46636 P(N+1,5)=PYMASS(K(N+1,2))
46637 K(N+2,2)=K(N+3,2)
46638 P(N+2,5)=P(N+3,5)
46639 PS=P(N+1,5)+P(N+2,5)
46640 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
46641 PV(2,5)=P(N+3,5)
46642 MMAT=0
46643 ND=2
46644 GOTO 460
46645 ENDIF
46646
46647C...Phase space decay of partons from W decay.
46648 610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN
46649 KFLO(1)=K(N+1,2)
46650 KFLO(2)=K(N+2,2)
46651 K(N+1,1)=K(N+3,1)
46652 K(N+1,2)=K(N+3,2)
46653 DO 620 J=1,5
46654 PV(1,J)=P(N+1,J)+P(N+2,J)
46655 P(N+1,J)=P(N+3,J)
46656 620 CONTINUE
46657 PV(1,5)=PMR
46658 N=N+1
46659 NP=0
46660 NQ=2
46661 PS=0D0
46662 MSTJ(93)=2
46663 PSQ=PYMASS(KFLO(1))
46664 MSTJ(93)=2
46665 PSQ=PSQ+PYMASS(KFLO(2))
46666 MMAT=11
46667 GOTO 290
46668 ENDIF
46669
46670C...Boost back for rapidly moving particle.
46671 630 N=N+ND
46672 IF(MBST.EQ.1) THEN
46673 DO 640 J=1,3
46674 BE(J)=P(IP,J)/P(IP,4)
46675 640 CONTINUE
46676 GA=P(IP,4)/P(IP,5)
46677 DO 660 I=NSAV+1,N
46678 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
46679 DO 650 J=1,3
46680 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
46681 650 CONTINUE
46682 P(I,4)=GA*(P(I,4)+BEP)
46683 660 CONTINUE
46684 ENDIF
46685
46686C...Fill in position of decay vertex.
46687 DO 680 I=NSAV+1,N
46688 DO 670 J=1,4
46689 V(I,J)=VDCY(J)
46690 670 CONTINUE
46691 V(I,5)=0D0
46692 680 CONTINUE
46693
46694C...Set up for parton shower evolution from jets.
46695 IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
46696 K(NSAV+1,1)=3
46697 K(NSAV+2,1)=3
46698 K(NSAV+3,1)=3
46699 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
46700 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
46701 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
46702 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
46703 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
46704 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
46705 MSTJ(92)=-(NSAV+1)
46706 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
46707 K(NSAV+2,1)=3
46708 K(NSAV+3,1)=3
46709 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
46710 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
46711 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
46712 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
46713 MSTJ(92)=NSAV+2
46714 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
46715 & IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
46716 K(NSAV+1,1)=3
46717 K(NSAV+2,1)=3
46718 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
46719 K(NSAV+1,5)=MSTU(5)*(NSAV+2)
46720 K(NSAV+2,4)=MSTU(5)*(NSAV+1)
46721 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
46722 MSTJ(92)=NSAV+1
46723 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
46724 & IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
46725 MSTJ(92)=NSAV+1
46726 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
46727 & THEN
46728 K(NSAV+1,1)=3
46729 K(NSAV+2,1)=3
46730 K(NSAV+3,1)=3
46731 KCP=PYCOMP(K(NSAV+1,2))
46732 KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
46733 JCON=4
46734 IF(KQP.LT.0) JCON=5
46735 K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
46736 K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
46737 K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
46738 K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
46739 MSTJ(92)=NSAV+1
46740 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
46741 K(NSAV+1,1)=3
46742 K(NSAV+3,1)=3
46743 K(NSAV+1,4)=MSTU(5)*(NSAV+3)
46744 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
46745 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
46746 K(NSAV+3,5)=MSTU(5)*(NSAV+1)
46747 MSTJ(92)=NSAV+1
46748 ENDIF
46749
46750C...Mark decayed particle; special option for B-Bbar mixing.
46751 IF(K(IP,1).EQ.5) K(IP,1)=15
46752 IF(K(IP,1).LE.10) K(IP,1)=11
46753 IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
46754 K(IP,4)=NSAV+1
46755 K(IP,5)=N
46756
46757 RETURN
46758 END
46759
46760
46761C*********************************************************************
46762
46763C...PYDCYK
46764C...Handles flavour production in the decay of unstable particles
46765C...and small string clusters.
46766
46767 SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF)
46768
46769C...Double precision and integer declarations.
46770 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46771 IMPLICIT INTEGER(I-N)
46772 INTEGER PYK,PYCHGE,PYCOMP
46773C...Commonblocks.
46774 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46775 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46776 SAVE /PYDAT1/,/PYDAT2/
46777
46778
46779C.. Call PYKFDI directly if no popcorn option is on
46780 IF(MSTJ(12).LT.2) THEN
46781 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
46782 MSTU(124)=KFL3
46783 RETURN
46784 ENDIF
46785
46786 KFL3=0
46787 KF=0
46788 IF(KFL1.EQ.0) RETURN
46789 KF1A=IABS(KFL1)
46790 KF2A=IABS(KFL2)
46791
46792 NSTO=130
46793 NMAX=MIN(MSTU(125),10)
46794
46795C.. Identify rank 0 cluster qq
46796 IRANK=1
46797 IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0
46798
46799 IF(KF2A.GT.0)THEN
46800C.. Join jets: Fails if store not empty
46801 IF(MSTU(121).GT.0) THEN
46802 MSTU(121)=0
46803 RETURN
46804 ENDIF
46805 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
46806 ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN
46807C.. Pick popcorn meson from store, return same qq, decrease store
46808 KF=MSTU(NSTO+MSTU(121))
46809 KFL3=-KFL1
46810 MSTU(121)=MSTU(121)-1
46811 ELSE
46812C.. Generate new flavour. Then done if no diquark is generated
46813 100 CALL PYKFDI(KFL1,0,KFL3,KF)
46814 IF(MSTU(121).EQ.-1) GOTO 100
46815 MSTU(124)=KFL3
46816 IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN
46817
46818C.. Simple case if no dynamical popcorn suppressions are considered
46819 IF(MSTJ(12).LT.4) THEN
46820 IF(MSTU(121).EQ.0) RETURN
46821 NMES=1
46822 KFPREV=-KFL3
46823 CALL PYKFDI(KFPREV,0,KFL3,KFM)
46824C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
46825 IF(IABS(KFL3).LE.10)THEN
46826 KFL3=-KFPREV
46827 RETURN
46828 ENDIF
46829 GOTO 120
46830 ENDIF
46831
46832C test output qq against fake Gamma, then return if no popcorn.
46833 GB=2D0
46834 IF(IRANK.NE.0)THEN
46835 CALL PYZDIS(1,2103,5D0,Z)
46836 GB=5D0*(1D0-Z)/Z
46837 IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN
46838 MSTU(121)=0
46839 GOTO 100
46840 ENDIF
46841 ENDIF
46842 IF(MSTU(121).EQ.0) RETURN
46843
46844C..Set store size memory. Pick fake dynamical variables of qq.
46845 NMES=MSTU(121)
46846 CALL PYPTDI(1,PX3,PY3)
46847 X=1D0
46848 POPM=0D0
46849 G=GB
46850 POPG=GB
46851
46852C.. Pick next popcorn meson, test with fake dynamical variables
46853 110 KFPREV=-KFL3
46854 PX1=-PX3
46855 PY1=-PY3
46856 CALL PYKFDI(KFPREV,0,KFL3,KFM)
46857 IF(MSTU(121).EQ.-1) GOTO 100
46858 CALL PYPTDI(KFL3,PX3,PY3)
46859 PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2
46860 CALL PYZDIS(KFPREV,KFL3,PM,Z)
46861 G=(1D0-Z)*(G+PM/Z)
46862 X=(1D0-Z)*X
46863
46864 PTST=1D0
46865 GTST=1D0
46866 RTST=PYR(0)
46867 IF(MSTJ(12).GT.4)THEN
46868 POPMN=SQRT((1D0-X)*(G/X-GB))
46869 POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
46870 PTST=EXP((POPM-POPMN)*PARF(193))
46871 POPM=POPMN
46872 ENDIF
46873 IF(IRANK.NE.0)THEN
46874 POPGN=X*GB
46875 GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG)
46876 POPG=POPGN
46877 ENDIF
46878 IF(RTST.GT.PTST*GTST)THEN
46879 MSTU(121)=0
46880 IF(RTST.GT.PTST) MSTU(121)=-1
46881 GOTO 100
46882 ENDIF
46883
46884C.. Store meson
46885 120 IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM
46886 IF(MSTU(121).GT.0) GOTO 110
46887
46888C.. Test accepted system size. If OK set global popcorn size variable.
46889 IF(NMES.GT.NMAX)THEN
46890 KF=0
46891 KFL3=0
46892 RETURN
46893 ENDIF
46894 MSTU(121)=NMES
46895 ENDIF
46896
46897 RETURN
46898 END
46899
46900C********************************************************************
46901
46902C...PYKFDI
46903C...Generates a new flavour pair and combines off a hadron
46904
46905 SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF)
46906
46907C...Double precision and integer declarations.
46908 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46909 IMPLICIT INTEGER(I-N)
46910 INTEGER PYK,PYCHGE,PYCOMP
46911C...Commonblocks.
46912 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46913 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46914 SAVE /PYDAT1/,/PYDAT2/
46915C...Local arrays.
46916 DIMENSION PD(7)
46917
46918 IF(MSTU(123).EQ.0.AND.MSTJ(12).GT.0) CALL PYKFIN
46919
46920C...Default flavour values. Input consistency checks.
46921 KF1A=IABS(KFL1)
46922 KF2A=IABS(KFL2)
46923 KFL3=0
46924 KF=0
46925 IF(KF1A.EQ.0) RETURN
46926 IF(KF2A.NE.0)THEN
46927 IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
46928 IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
46929 IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
46930 ENDIF
46931
46932C...Check if tabulated flavour probabilities are to be used.
46933 IF(MSTJ(15).EQ.1) THEN
46934 IF(MSTJ(12).GE.5) CALL PYERRM(29,
46935 & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
46936 & ' together with MSTJ(12)>=5 modification')
46937 KTAB1=-1
46938 IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
46939 KFL1A=MOD(KF1A/1000,10)
46940 KFL1B=MOD(KF1A/100,10)
46941 KFL1S=MOD(KF1A,10)
46942 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
46943 & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
46944 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
46945 IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
46946 KTAB2=0
46947 IF(KF2A.NE.0) THEN
46948 KTAB2=-1
46949 IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
46950 KFL2A=MOD(KF2A/1000,10)
46951 KFL2B=MOD(KF2A/100,10)
46952 KFL2S=MOD(KF2A,10)
46953 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
46954 & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
46955 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
46956 ENDIF
46957 IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
46958 ENDIF
46959
46960C.. Recognize rank 0 diquark case
46961 100 IRANK=1
46962 KFDIQ=MAX(KF1A,KF2A)
46963 IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0
46964
46965C.. Join two flavours to meson or baryon. Test for popcorn.
46966 IF(KF2A.GT.0)THEN
46967 MBARY=0
46968 IF(KFDIQ.GT.10) THEN
46969 IF(IRANK.EQ.0.AND.MSTJ(12).LT.5)
46970 & CALL PYNMES(KFDIQ)
46971 IF(MSTU(121).NE.0) THEN
46972 MSTU(121)=0
46973 RETURN
46974 ENDIF
46975 MBARY=2
46976 ENDIF
46977 KFQOLD=KF1A
46978 KFQVER=KF2A
46979 GOTO 130
46980 ENDIF
46981
46982C.. Separate incoming flavours, curtain flavour consistency check
46983 KFIN=KFL1
46984 KFQOLD=KF1A
46985 KFQPOP=KF1A/10000
46986 IF(KF1A.GT.10)THEN
46987 KFIN=-KFL1
46988 KFL1A=MOD(KF1A/1000,10)
46989 KFL1B=MOD(KF1A/100,10)
46990 IF(IRANK.EQ.0)THEN
46991 QAWT=1D0
46992 IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4)
46993 IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4)
46994 KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0))
46995 ENDIF
46996 IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) THEN
46997 MSTU(121)=0
46998 RETURN
46999 ENDIF
47000 KFQOLD=KFL1A+KFL1B-KFQPOP
47001 ENDIF
47002
47003C...Meson/baryon choice. Set number of mesons if starting a popcorn
47004C...system.
47005 110 MBARY=0
47006 IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN
47007 IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN
47008 MBARY=1
47009 CALL PYNMES(0)
47010 ENDIF
47011 ELSEIF(KF1A.GT.10)THEN
47012 MBARY=2
47013 IF(IRANK.EQ.0) CALL PYNMES(KF1A)
47014 IF(MSTU(121).GT.0) MBARY=-1
47015 ENDIF
47016
47017C..x->H+q: Choose single vertex quark. Jump to form hadron.
47018 IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN
47019 KFQVER=1+INT((2D0+PARJ(2))*PYR(0))
47020 KFL3=ISIGN(KFQVER,-KFIN)
47021 GOTO 130
47022 ENDIF
47023
47024C..x->H+qq: (IDW=proper PARF position for diquark weights)
47025 IDW=160
47026 IF(MBARY.EQ.1)THEN
47027 IF(MSTU(121).EQ.0) IDW=150
47028 SQWT=PARF(IDW+1)
47029 IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121)
47030 KFQPOP=1+INT((2D0+SQWT)*PYR(0))
47031C.. Shift to s-curtain parameters if needed
47032 IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN
47033 PARF(194)=PARF(138)*PARF(139)
47034 PARF(193)=PARJ(8)+PARJ(9)
47035 ENDIF
47036 ENDIF
47037
47038C.. x->H+qq: Get vertex quark
47039 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
47040 IDW=MSTU(122)
47041 MSTU(121)=MSTU(121)-1
47042 IF(IDW.EQ.170) THEN
47043 IF(MSTU(121).EQ.0)THEN
47044 IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2)
47045 ELSE
47046 IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
47047 ENDIF
47048 ELSE
47049 IF(MSTU(121).EQ.0)THEN
47050 IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
47051 ELSE
47052 IPOS=3*5+5*4+MIN(KFQOLD-1,4)
47053 ENDIF
47054 ENDIF
47055 IPOS=200+30*IPOS+1
47056
47057 IMES=-1
47058 RMES=PYR(0)*PARF(194)
47059 120 IMES=IMES+1
47060 RMES=RMES-PARF(IPOS+IMES)
47061 IF(IMES.EQ.30) THEN
47062 MSTU(121)=-1
47063 KF=-111
47064 RETURN
47065 ENDIF
47066 IF(RMES.GT.0D0) GOTO 120
47067 KMUL=IMES/5
47068 KFJ=2*KMUL+1
47069 IF(KMUL.EQ.2) KFJ=10003
47070 IF(KMUL.EQ.3) KFJ=10001
47071 IF(KMUL.EQ.4) KFJ=20003
47072 IF(KMUL.EQ.5) KFJ=5
47073 IDIAG=0
47074 KFQVER=MOD(IMES,5)+1
47075 IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1
47076 IF(KFQVER.GT.3)THEN
47077 IDIAG=KFQVER-3
47078 KFQVER=KFQOLD
47079 ENDIF
47080 ELSE
47081 IF(MBARY.EQ.-1) IDW=170
47082 SQWT=PARF(IDW+2)
47083 IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3)
47084 IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0
47085 KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0)))
47086 IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN
47087 KFQVER=KFQPOP
47088 IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP
47089 ENDIF
47090 ENDIF
47091
47092C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
47093 KFLDS=3
47094 IF(KFQPOP.NE.KFQVER)THEN
47095 SWT=PARF(IDW+7)
47096 IF(KFQVER.EQ.3) SWT=PARF(IDW+6)
47097 IF(KFQPOP.GE.3) SWT=PARF(IDW+5)
47098 IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1
47099 ENDIF
47100 KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS
47101 & +10000*KFQPOP
47102 KFL3=ISIGN(KFDIQ,KFIN)
47103
47104C..x->M+y: flavour for meson.
47105 130 IF(MBARY.LE.0)THEN
47106 KFLA=MAX(KFQOLD,KFQVER)
47107 KFLB=MIN(KFQOLD,KFQVER)
47108 KFS=ISIGN(1,KFL1)
47109 IF(KFLA.NE.KFQOLD) KFS=-KFS
47110C... Form meson, with spin and flavour mixing for diagonal states.
47111 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
47112 IF(IDIAG.GT.0) KF=110*IDIAG+KFJ
47113 IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA
47114 RETURN
47115 ENDIF
47116 IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0))
47117 IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0))
47118 IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0))
47119 IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN
47120 IF(PYR(0).LT.PARJ(14)) KMUL=2
47121 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN
47122 RMUL=PYR(0)
47123 IF(RMUL.LT.PARJ(15)) KMUL=3
47124 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
47125 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
47126 ENDIF
47127 KFLS=3
47128 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
47129 IF(KMUL.EQ.5) KFLS=5
47130 IF(KFLA.NE.KFLB)THEN
47131 KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
47132 ELSE
47133 RMIX=PYR(0)
47134 IMIX=2*KFLA+10*KMUL
47135 IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
47136 & INT(RMIX+PARF(IMIX)))+KFLS
47137 IF(KFLA.GE.4) KF=110*KFLA+KFLS
47138 ENDIF
47139 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
47140 IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
47141
47142C..Optional extra suppression of eta and eta'.
47143C..Allow shift to qq->B+q in old version (set IRANK to 0)
47144 IF(KF.EQ.221.OR.KF.EQ.331)THEN
47145 IF(PYR(0).GT.PARJ(25+KF/300))THEN
47146 IF(KF2A.GT.0) GOTO 130
47147 IF(MSTJ(12).LT.4) IRANK=0
47148 GOTO 110
47149 ENDIF
47150 ENDIF
47151 MSTU(121)=0
47152
47153C.. x->B+y: Flavour for baryon
47154 ELSE
47155 KFLA=KFQVER
47156 IF(KF1A.LE.10) KFLA=KFQOLD
47157 KFLB=MOD(KFDIQ/1000,10)
47158 KFLC=MOD(KFDIQ/100,10)
47159 KFLDS=MOD(KFDIQ,10)
47160 KFLD=MAX(KFLA,KFLB,KFLC)
47161 KFLF=MIN(KFLA,KFLB,KFLC)
47162 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
47163
47164C... SU(6) factors for formation of baryon.
47165 KBARY=3
47166 KDMAX=5
47167 KFLG=KFLB
47168 IF(KFLB.NE.KFLC)THEN
47169 KBARY=2*KFLDS-1
47170 KDMAX=1+KFLDS/2
47171 IF(KFLB.GT.2) KDMAX=KDMAX+2
47172 ENDIF
47173 IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN
47174 KBARY=KBARY+1
47175 KFLG=KFLA
47176 ENDIF
47177
47178 SU6MAX=PARF(140+KDMAX)
47179 SU6DEC=PARJ(18)
47180 SU6S =PARF(146)
47181 IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN
47182 SU6MAX=1D0
47183 SU6DEC=1D0
47184 SU6S =1D0
47185 ENDIF
47186 SU6OCT=PARF(60+KBARY)
47187 IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN
47188 SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1)
47189 IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1)
47190 ELSE
47191 IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1)
47192 ENDIF
47193 SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY)
47194
47195C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
47196 IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN
47197 MSTU(121)=0
47198 IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1
47199 GOTO 110
47200 ENDIF
47201
47202C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
47203 KSIG=1
47204 KFLS=2
47205 IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4
47206 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN
47207 KSIG=KFLDS/3
47208 IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0))
47209 ENDIF
47210 KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
47211 IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
47212 ENDIF
47213 RETURN
47214
47215C...Use tabulated probabilities to select new flavour and hadron.
47216 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
47217 KT3L=1
47218 KT3U=6
47219 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
47220 KT3L=1
47221 KT3U=6
47222 ELSEIF(KTAB2.EQ.0) THEN
47223 KT3L=1
47224 KT3U=22
47225 ELSE
47226 KT3L=KTAB2
47227 KT3U=KTAB2
47228 ENDIF
47229 RFL=0D0
47230 DO 160 KTS=0,2
47231 DO 150 KT3=KT3L,KT3U
47232 RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
47233 150 CONTINUE
47234 160 CONTINUE
47235 RFL=PYR(0)*RFL
47236 DO 180 KTS=0,2
47237 KTABS=KTS
47238 DO 170 KT3=KT3L,KT3U
47239 KTAB3=KT3
47240 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
47241 IF(RFL.LE.0D0) GOTO 190
47242 170 CONTINUE
47243 180 CONTINUE
47244 190 CONTINUE
47245
47246C...Reconstruct flavour of produced quark/diquark.
47247 IF(KTAB3.LE.6) THEN
47248 KFL3A=KTAB3
47249 KFL3B=0
47250 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
47251 ELSE
47252 KFL3A=1
47253 IF(KTAB3.GE.8) KFL3A=2
47254 IF(KTAB3.GE.11) KFL3A=3
47255 IF(KTAB3.GE.16) KFL3A=4
47256 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
47257 KFL3=1000*KFL3A+100*KFL3B+1
47258 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
47259 & KFL3+2
47260 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
47261 ENDIF
47262
47263C...Reconstruct meson code.
47264 IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
47265 &KFL3B.NE.0)) THEN
47266 RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
47267 & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
47268 KF=110+2*KTABS+1
47269 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
47270 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
47271 & 25*KTABS)) KF=330+2*KTABS+1
47272 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
47273 KFLA=MAX(KTAB1,KTAB3)
47274 KFLB=MIN(KTAB1,KTAB3)
47275 KFS=ISIGN(1,KFL1)
47276 IF(KFLA.NE.KF1A) KFS=-KFS
47277 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
47278 ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
47279 KFS=ISIGN(1,KFL1)
47280 IF(KFL1A.EQ.KFL3A) THEN
47281 KFLA=MAX(KFL1B,KFL3B)
47282 KFLB=MIN(KFL1B,KFL3B)
47283 IF(KFLA.NE.KFL1B) KFS=-KFS
47284 ELSEIF(KFL1A.EQ.KFL3B) THEN
47285 KFLA=KFL3A
47286 KFLB=KFL1B
47287 KFS=-KFS
47288 ELSEIF(KFL1B.EQ.KFL3A) THEN
47289 KFLA=KFL1A
47290 KFLB=KFL3B
47291 ELSEIF(KFL1B.EQ.KFL3B) THEN
47292 KFLA=MAX(KFL1A,KFL3A)
47293 KFLB=MIN(KFL1A,KFL3A)
47294 IF(KFLA.NE.KFL1A) KFS=-KFS
47295 ELSE
47296 CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq')
47297 GOTO 100
47298 ENDIF
47299 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
47300
47301C...Reconstruct baryon code.
47302 ELSE
47303 IF(KTAB1.GE.7) THEN
47304 KFLA=KFL3A
47305 KFLB=KFL1A
47306 KFLC=KFL1B
47307 ELSE
47308 KFLA=KFL1A
47309 KFLB=KFL3A
47310 KFLC=KFL3B
47311 ENDIF
47312 KFLD=MAX(KFLA,KFLB,KFLC)
47313 KFLF=MIN(KFLA,KFLB,KFLC)
47314 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
47315 IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
47316 IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
47317 ENDIF
47318
47319C...Check that constructed flavour code is an allowed one.
47320 IF(KFL2.NE.0) KFL3=0
47321 KC=PYCOMP(KF)
47322 IF(KC.EQ.0) THEN
47323 CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '//
47324 & 'failed')
47325 GOTO 100
47326 ENDIF
47327
47328 RETURN
47329 END
47330
47331C*********************************************************************
47332
47333C...PYNMES
47334C...Generates number of popcorn mesons and stores some relevant
47335C...parameters.
47336
47337 SUBROUTINE PYNMES(KFDIQ)
47338
47339C...Double precision and integer declarations.
47340 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47341 IMPLICIT INTEGER(I-N)
47342 INTEGER PYK,PYCHGE,PYCOMP
47343C...Commonblocks.
47344 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47345 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47346 SAVE /PYDAT1/,/PYDAT2/
47347
47348 MSTU(121)=0
47349 IF(MSTJ(12).LT.2) RETURN
47350
47351C..Old version: Get 1 or 0 popcorn mesons
47352 IF(MSTJ(12).LT.5)THEN
47353 POPWT=PARF(131)
47354 IF(KFDIQ.NE.0) THEN
47355 KFDIQA=IABS(KFDIQ)
47356 KFA=MOD(KFDIQA/1000,10)
47357 KFB=MOD(KFDIQA/100,10)
47358 KFS=MOD(KFDIQA,10)
47359 POPWT=PARF(132)
47360 IF(KFA.EQ.3) POPWT=PARF(133)
47361 IF(KFB.EQ.3) POPWT=PARF(134)
47362 IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4))
47363 ENDIF
47364 MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0))
47365 RETURN
47366 ENDIF
47367
47368C..New version: Store popcorn- or rank 0 diquark parameters
47369 MSTU(122)=170
47370 PARF(193)=PARJ(8)
47371 PARF(194)=PARF(139)
47372 IF(KFDIQ.NE.0) THEN
47373 MSTU(122)=180
47374 PARF(193)=PARJ(10)
47375 PARF(194)=PARF(140)
47376 ENDIF
47377 IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN
47378 IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9,
47379 & '(PYNMES:) Neglecting too large popcorn possibility')
47380 RETURN
47381 ENDIF
47382
47383C..New version: Get number of popcorn mesons
47384 100 RTST=PYR(0)
47385 MSTU(121)=-1
47386 110 MSTU(121)=MSTU(121)+1
47387 RTST=RTST/PARF(194)
47388 IF(RTST.LT.1D0) GOTO 110
47389 IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)*PARF(161)).GT.
47390 & (2D0+PARF(135)*PARF(161)*PARF(138)**MSTU(121))) GOTO 100
47391 RETURN
47392 END
47393
47394C***************************************************************
47395
47396C...PYKFIN
47397C...Precalculates a set of diquark and popcorn weights.
47398
47399 SUBROUTINE PYKFIN
47400
47401C...Double precision and integer declarations.
47402 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47403 IMPLICIT INTEGER(I-N)
47404 INTEGER PYK,PYCHGE,PYCOMP
47405C...Commonblocks.
47406 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47407 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47408 SAVE /PYDAT1/,/PYDAT2/
47409
47410 DIMENSION SU6(12),SU6M(7),QBB(7),QBM(7),DMB(14)
47411
47412
47413 MSTU(123)=1
47414C..Diquark indices for dimensional variables
47415 IUD1=1
47416 IUU1=2
47417 IUS0=3
47418 ISU0=4
47419 IUS1=5
47420 ISU1=6
47421 ISS1=7
47422
47423C.. *** SU(6) factors **
47424C..Modify with decuplet- (and Sigma/Lambda-) suppression.
47425 PARF(146)=1D0
47426 IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0)
47427 IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9,
47428 & '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
47429 DO 100 I=1,6
47430 SU6(I)=PARF(60+I)
47431 SU6(6+I)=SU6(I)*4*PARF(146)/(3*PARF(146)+1)
47432 100 CONTINUE
47433 SU6(8)=SU6(2)*4/(3*PARF(146)+1)
47434 SU6(6)=SU6(6)*(3+PARF(146))/(3*PARF(146)+1)
47435 DO 110 I=1,6
47436 SU6(I)=SU6(I)+PARJ(18)*PARF(70+I)
47437 SU6(6+I)=SU6(6+I)+PARJ(18)*PARF(70+I)
47438 110 CONTINUE
47439
47440C..SU(6)max q q' s,c,b
47441 SU6MUD =MAX(SU6(1) , SU6(8) )
47442 SU6M(IUD1)=MAX(SU6(5) , SU6(12))
47443 SU6M(ISU0)=MAX(SU6(7) ,SU6(2),SU6MUD )
47444 SU6M(IUU1)=MAX(SU6(3) ,SU6(4),SU6(10))
47445 SU6M(ISU1)=MAX(SU6(11),SU6(6),SU6M(IUD1))
47446 SU6M(IUS0)=SU6M(ISU0)
47447 SU6M(ISS1)=SU6M(IUU1)
47448 SU6M(IUS1)=SU6M(ISU1)
47449
47450C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
47451 PARF(141)=SU6MUD
47452 PARF(142)=SU6M(IUD1)
47453 PARF(143)=SU6M(ISU0)
47454 PARF(144)=SU6M(ISU1)
47455 PARF(145)=SU6M(ISS1)
47456
47457C..diquark SU(6) survival =
47458C..sum over quark (quark tunnel weight)*(SU(6)).
47459 PUD0=(2D0*SU6(1)+PARJ(2)*SU6(8))
47460 DMB(ISU0)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
47461 DMB(IUS0)=DMB(ISU0)
47462 DMB(ISS1)=(2D0*SU6(4)+PARJ(2)*SU6(3))/PUD0
47463 DMB(IUU1)=(SU6(3)+SU6(4)+PARJ(2)*SU6(10))/PUD0
47464 DMB(ISU1)=(SU6(11)+SU6(6)+PARJ(2)*SU6(5))/PUD0
47465 DMB(IUS1)=DMB(ISU1)
47466 DMB(IUD1)=(2D0*SU6(5)+PARJ(2)*SU6(12))/PUD0
47467
47468C.. *** Tunneling factors for Diquark production***
47469C.. T: half a curtain pair = sqrt(curtain pair factor)
47470 IF(MSTJ(12).GE.5) THEN
47471 PMUD0=PYMASS(2101)
47472 PMUD1=PYMASS(2103)-PMUD0
47473 PMUS0=PYMASS(3201)-PMUD0
47474 PMUS1=PYMASS(3203)-PMUS0-PMUD0
47475 PMSS1=PYMASS(3303)-PMUS0-PMUD0
47476 QBB(ISU0)=EXP(-(PARJ(9)+PARJ(8))*PMUS0-PARJ(9)*PARF(191))
47477 QBB(IUS0)=EXP(-PARJ(8)*PMUS0)
47478 QBB(ISS1)=EXP(-(PARJ(9)+PARJ(8))*PMSS1)*QBB(ISU0)
47479 QBB(IUU1)=EXP(-PARJ(8)*PMUD1)
47480 QBB(ISU1)=EXP(-(PARJ(9)+PARJ(8))*PMUS1)*QBB(ISU0)
47481 QBB(IUS1)=EXP(-PARJ(8)*PMUS1)*QBB(IUS0)
47482 QBB(IUD1)=QBB(IUU1)
47483 ELSE
47484 PAR2M=SQRT(PARJ(2))
47485 PAR3M=SQRT(PARJ(3))
47486 PAR4M=SQRT(PARJ(4))
47487 QBB(ISU0)=PAR2M*PAR3M
47488 QBB(IUS0)=PAR3M
47489 QBB(ISS1)=PAR2M*PARJ(3)*PAR4M
47490 QBB(IUU1)=PAR4M
47491 QBB(ISU1)=PAR4M*QBB(ISU0)
47492 QBB(IUS1)=PAR4M*QBB(IUS0)
47493 QBB(IUD1)=PAR4M
47494 ENDIF
47495
47496C.. tau: spin*(vertex factor)*(T = half-curtain factor)
47497 QBM(ISU0)=QBB(ISU0)
47498 QBM(IUS0)=PARJ(2)*QBB(IUS0)
47499 QBM(ISS1)=PARJ(2)*6D0*QBB(ISS1)
47500 QBM(IUU1)=6D0*QBB(IUU1)
47501 QBM(ISU1)=3D0*QBB(ISU1)
47502 QBM(IUS1)=PARJ(2)*3D0*QBB(IUS1)
47503 QBM(IUD1)=3D0*QBB(IUD1)
47504
47505C.. Combine T and tau to diquark weight for q-> B+B+..
47506 DO 120 I=1,7
47507 QBB(I)=QBB(I)*QBM(I)
47508 120 CONTINUE
47509
47510 IF(MSTJ(12).GE.5)THEN
47511C..New version: tau for rank 0 diquark.
47512 DMB(7+ISU0)=EXP(-PARJ(10)*PMUS0)
47513 DMB(7+IUS0)=PARJ(2)*DMB(7+ISU0)
47514 DMB(7+ISS1)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*DMB(7+ISU0)
47515 DMB(7+IUU1)=6D0*EXP(-PARJ(10)*PMUD1)
47516 DMB(7+ISU1)=3D0*EXP(-PARJ(10)*PMUS1)*DMB(7+ISU0)
47517 DMB(7+IUS1)=PARJ(2)*DMB(7+ISU1)
47518 DMB(7+IUD1)=DMB(7+IUU1)/2D0
47519
47520C..New version: curtain flavour ratios.
47521C.. s/u for q->B+M+...
47522C.. s/u for rank 0 diquark: su -> ...M+B+...
47523C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
47524 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
47525 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
47526 WU=1D0+DMB(7+IUD1)+DMB(7+IUS0)+DMB(7+IUS1)+DMB(7+IUU1)
47527 PARF(136)=(2D0*(DMB(7+ISU0)+DMB(7+ISU1))+DMB(7+ISS1))/WU
47528 PARF(137)=(DMB(7+ISU0)+DMB(7+ISU1))*
47529 & (2D0+DMB(7+ISS1)/(2D0*DMB(7+ISU1)))/WU
47530 ELSE
47531C..Old version: reset unused rank 0 diquark weights and
47532C.. unused diquark SU(6) survival weights
47533 DO 130 I=1,7
47534 IF(MSTJ(12).LT.3) DMB(I)=1D0
47535 DMB(7+I)=1D0
47536 130 CONTINUE
47537
47538C..Old version: Shuffle PARJ(7) into tau
47539 QBM(IUS0)=QBM(IUS0)*PARJ(7)
47540 QBM(ISS1)=QBM(ISS1)*PARJ(7)
47541 QBM(IUS1)=QBM(IUS1)*PARJ(7)
47542
47543C..Old version: curtain flavour ratios.
47544C.. s/u for q->B+M+...
47545C.. s/u for rank 0 diquark: su -> ...M+B+...
47546C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
47547 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
47548 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
47549 PARF(136)=PARF(135)*PARJ(6)*QBM(ISU0)/QBM(IUS0)
47550 PARF(137)=(1D0+QBM(IUD1))*(2D0+QBM(IUS0))/WU
47551 ENDIF
47552
47553C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for:
47554C.. rank0 D->M+B+..; D->M+B+..; q->B+M+..; q->B+B..
47555 DO 140 I=1,7
47556 DMB(7+I)=DMB(7+I)*DMB(I)
47557 DMB(I)=DMB(I)*QBM(I)
47558 QBM(I)=QBM(I)*SU6M(I)/SU6MUD
47559 QBB(I)=QBB(I)*SU6M(I)/SU6MUD
47560 140 CONTINUE
47561
47562C.. *** Popcorn factors ***
47563
47564 IF(MSTJ(12).LT.5)THEN
47565C.. Old version: Resulting popcorn weights.
47566 PARF(138)=PARJ(6)
47567 WS=PARF(135)*PARF(138)
47568 WQ=WU*PARJ(5)/3D0
47569 PARF(132)=WQ*QBM(IUD1)/QBB(IUD1)
47570 PARF(133)=WQ*
47571 & (QBM(IUS1)/QBB(IUS1)+WS*QBM(ISU1)/QBB(ISU1))/2D0
47572 PARF(134)=WQ*WS*QBM(ISS1)/QBB(ISS1)
47573 PARF(131)=WQ*(1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1)+
47574 & WS*(QBM(ISU0)+QBM(ISU1)+QBM(ISS1)/2D0))/
47575 & (1D0+QBB(IUD1)+QBB(IUU1)+
47576 & 2D0*(QBB(IUS0)+QBB(IUS1))+QBB(ISS1)/2D0)
47577 ELSE
47578C..New version: Store weights for popcorn mesons,
47579C..get prel. popcorn weights.
47580 DO 150 IPOS=201,1400
47581 PARF(IPOS)=0D0
47582 150 CONTINUE
47583 DO 160 I=138,140
47584 PARF(I)=0D0
47585 160 CONTINUE
47586 IPOS=200
47587 PARF(193)=PARJ(8)
47588 DO 240 MR=0,7,7
47589 IF(MR.EQ.7) PARF(193)=PARJ(10)
47590 SQWT=2D0*(DMB(MR+IUS0)+DMB(MR+IUS1))/
47591 & (1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
47592 QQWT=DMB(MR+IUU1)/(1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
47593 DO 230 NMES=0,1
47594 IF(NMES.EQ.1) SQWT=PARJ(2)
47595 DO 220 KFQPOP=1,4
47596 IF(MR.EQ.0.AND.KFQPOP.GT.3) GOTO 220
47597 IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN
47598 SQWT=DMB(MR+ISS1)/(DMB(MR+ISU0)+DMB(MR+ISU1))
47599 QQWT=0.5D0
47600 IF(MR.EQ.0) PARF(193)=PARJ(8)+PARJ(9)
47601 IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/DMB(7+ISU1)+1D0)/2D0
47602 ENDIF
47603 DO 210 KFQOLD =1,5
47604 IF(MR.EQ.0.AND.KFQOLD.GT.3) GOTO 210
47605 IF(NMES.EQ.1) THEN
47606 IF(MR.EQ.0.AND.KFQPOP.EQ.1) GOTO 210
47607 IF(MR.EQ.7.AND.KFQPOP.NE.1) GOTO 210
47608 ENDIF
47609 WTTOT=0D0
47610 WTFAIL=0D0
47611 DO 190 KMUL=0,5
47612 PJWT=PARJ(12+KMUL)
47613 IF(KMUL.EQ.0) PJWT=1D0-PARJ(14)
47614 IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17)
47615 IF(PJWT.LE.0D0) GOTO 190
47616 IF(PJWT.GT.1D0) PJWT=1D0
47617 IMES=5*KMUL
47618 IMIX=2*KFQOLD+10*KMUL
47619 KFJ=2*KMUL+1
47620 IF(KMUL.EQ.2) KFJ=10003
47621 IF(KMUL.EQ.3) KFJ=10001
47622 IF(KMUL.EQ.4) KFJ=20003
47623 IF(KMUL.EQ.5) KFJ=5
47624 DO 180 KFQVER =1,3
47625 KFLA=MAX(KFQOLD,KFQVER)
47626 KFLB=MIN(KFQOLD,KFQVER)
47627 SWT=PARJ(11+KFLA/3+KFLA/4)
47628 IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT
47629 SWT=SWT*PJWT
47630 QWT=SQWT/(2D0+SQWT)
47631 IF(KFQVER.LT.3)THEN
47632 IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT
47633 IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT)
47634 ENDIF
47635 IF(KFQVER.NE.KFQOLD)THEN
47636 IMES=IMES+1
47637 KFM=100*KFLA+10*KFLB+KFJ
47638 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
47639 PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM)
47640 WTTOT=WTTOT+PARF(IPOS+IMES)
47641 ELSE
47642 DO 170 ID=3,5
47643 IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1)
47644 IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX)
47645 IF(ID.EQ.5) DWT=PARF(IMIX)
47646 KFM=110*(ID-2)+KFJ
47647 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
47648 PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM)
47649 IF(KMUL.EQ.0.AND.ID.GT.3) THEN
47650 WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID))
47651 PARF(IPOS+5*KMUL+ID)=
47652 & PARF(IPOS+5*KMUL+ID)*PARJ(21+ID)
47653 ENDIF
47654 WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID)
47655 170 CONTINUE
47656 ENDIF
47657 180 CONTINUE
47658 190 CONTINUE
47659 DO 200 IMES=1,30
47660 PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL)
47661 200 CONTINUE
47662 IF(MR.EQ.7) PARF(140)=
47663 & MAX(PARF(140),WTTOT/(1D0-WTFAIL))
47664 IF(MR.EQ.0) PARF(139-KFQPOP/3)=
47665 & MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL))
47666 IPOS=IPOS+30
47667 210 CONTINUE
47668 220 CONTINUE
47669 230 CONTINUE
47670 240 CONTINUE
47671 IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139)
47672 MSTU(121)=0
47673
47674 ENDIF
47675
47676C..Recombine diquark weights to flavour and spin ratios
47677 PARF(151)=(2D0*(QBB(ISU0)+QBB(ISU1))+QBB(ISS1))/
47678 & (1D0+QBB(IUD1)+QBB(IUU1)+QBB(IUS0)+QBB(IUS1))
47679 PARF(152)=2D0*(QBB(IUS0)+QBB(IUS1))/(1D0+QBB(IUD1)+QBB(IUU1))
47680 PARF(153)=QBB(ISS1)/(QBB(ISU0)+QBB(ISU1))
47681 PARF(154)=QBB(IUU1)/(1D0+QBB(IUD1)+QBB(IUU1))
47682 PARF(155)=QBB(ISU1)/QBB(ISU0)
47683 PARF(156)=QBB(IUS1)/QBB(IUS0)
47684 PARF(157)=QBB(IUD1)
47685
47686 PARF(161)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/
47687 & (1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1))
47688 PARF(162)=2D0*(QBM(IUS0)+QBM(IUS1))/(1D0+QBM(IUD1)+QBM(IUU1))
47689 PARF(163)=QBM(ISS1)/(QBM(ISU0)+QBM(ISU1))
47690 PARF(164)=QBM(IUU1)/(1D0+QBM(IUD1)+QBM(IUU1))
47691 PARF(165)=QBM(ISU1)/QBM(ISU0)
47692 PARF(166)=QBM(IUS1)/QBM(IUS0)
47693 PARF(167)=QBM(IUD1)
47694
47695 PARF(171)=(2D0*(DMB(ISU0)+DMB(ISU1))+DMB(ISS1))/
47696 & (1D0+DMB(IUD1)+DMB(IUU1)+DMB(IUS0)+DMB(IUS1))
47697 PARF(172)=2D0*(DMB(IUS0)+DMB(IUS1))/(1D0+DMB(IUD1)+DMB(IUU1))
47698 PARF(173)=DMB(ISS1)/(DMB(ISU0)+DMB(ISU1))
47699 PARF(174)=DMB(IUU1)/(1D0+DMB(IUD1)+DMB(IUU1))
47700 PARF(175)=DMB(ISU1)/DMB(ISU0)
47701 PARF(176)=DMB(IUS1)/DMB(IUS0)
47702 PARF(177)=DMB(IUD1)
47703
47704 PARF(185)=DMB(7+ISU1)/DMB(7+ISU0)
47705 PARF(186)=DMB(7+IUS1)/DMB(7+IUS0)
47706 PARF(187)=DMB(7+IUD1)
47707
47708 RETURN
47709 END
47710
47711
47712C*********************************************************************
47713
47714C...PYPTDI
47715C...Generates transverse momentum according to a Gaussian.
47716
47717 SUBROUTINE PYPTDI(KFL,PX,PY)
47718
47719C...Double precision and integer declarations.
47720 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47721 IMPLICIT INTEGER(I-N)
47722 INTEGER PYK,PYCHGE,PYCOMP
47723C...Commonblocks.
47724 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47725 SAVE /PYDAT1/
47726
47727C...Generate p_T and azimuthal angle, gives p_x and p_y.
47728 KFLA=IABS(KFL)
47729 PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0))))
47730 IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT
47731 IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
47732 IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0
47733 PHI=PARU(2)*PYR(0)
47734 PX=PT*COS(PHI)
47735 PY=PT*SIN(PHI)
47736
47737 RETURN
47738 END
47739
47740C*********************************************************************
47741
47742C...PYZDIS
47743C...Generates the longitudinal splitting variable z.
47744
47745 SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z)
47746
47747C...Double precision and integer declarations.
47748 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47749 IMPLICIT INTEGER(I-N)
47750 INTEGER PYK,PYCHGE,PYCOMP
47751C...Commonblocks.
47752 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47753 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47754 SAVE /PYDAT1/,/PYDAT2/
47755
47756C...Check if heavy flavour fragmentation.
47757 KFLA=IABS(KFL1)
47758 KFLB=IABS(KFL2)
47759 KFLH=KFLA
47760 IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
47761
47762C...Lund symmetric scaling function: determine parameters of shape.
47763 IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
47764 &MSTJ(11).GE.4) THEN
47765 FA=PARJ(41)
47766 IF(MSTJ(91).EQ.1) FA=PARJ(43)
47767 IF(KFLB.GE.10) FA=FA+PARJ(45)
47768 FBB=PARJ(42)
47769 IF(MSTJ(91).EQ.1) FBB=PARJ(44)
47770 FB=FBB*PR
47771 FC=1D0
47772 IF(KFLA.GE.10) FC=FC-PARJ(45)
47773 IF(KFLB.GE.10) FC=FC+PARJ(45)
47774 IF(MSTJ(11).GE.4.AND.(KFLH.EQ.4.OR.KFLH.EQ.5)) THEN
47775 FRED=PARJ(46)
47776 IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
47777 FC=FC+FRED*FBB*PARF(100+KFLH)**2
47778 ENDIF
47779 MC=1
47780 IF(ABS(FC-1D0).GT.0.01D0) MC=2
47781
47782C...Determine position of maximum. Special cases for a = 0 or a = c.
47783 IF(FA.LT.0.02D0) THEN
47784 MA=1
47785 ZMAX=1D0
47786 IF(FC.GT.FB) ZMAX=FB/FC
47787 ELSEIF(ABS(FC-FA).LT.0.01D0) THEN
47788 MA=2
47789 ZMAX=FB/(FB+FC)
47790 ELSE
47791 MA=3
47792 ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA)
47793 IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB)
47794 ENDIF
47795
47796C...Subdivide z range if distribution very peaked near endpoint.
47797 MMAX=2
47798 IF(ZMAX.LT.0.1D0) THEN
47799 MMAX=1
47800 ZDIV=2.75D0*ZMAX
47801 IF(MC.EQ.1) THEN
47802 FINT=1D0-LOG(ZDIV)
47803 ELSE
47804 ZDIVC=ZDIV**(1D0-FC)
47805 FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0)
47806 ENDIF
47807 ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN
47808 MMAX=3
47809 FSCB=SQRT(4D0+(FC/FB)**2)
47810 ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB))
47811 IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX)
47812 ZDIV=MIN(ZMAX,MAX(0D0,ZDIV))
47813 FINT=1D0+FB*(1D0-ZDIV)
47814 ENDIF
47815
47816C...Choice of z, preweighted for peaks at low or high z.
47817 100 Z=PYR(0)
47818 FPRE=1D0
47819 IF(MMAX.EQ.1) THEN
47820 IF(FINT*PYR(0).LE.1D0) THEN
47821 Z=ZDIV*Z
47822 ELSEIF(MC.EQ.1) THEN
47823 Z=ZDIV**Z
47824 FPRE=ZDIV/Z
47825 ELSE
47826 Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC))
47827 FPRE=(ZDIV/Z)**FC
47828 ENDIF
47829 ELSEIF(MMAX.EQ.3) THEN
47830 IF(FINT*PYR(0).LE.1D0) THEN
47831 Z=ZDIV+LOG(Z)/FB
47832 FPRE=EXP(FB*(Z-ZDIV))
47833 ELSE
47834 Z=ZDIV+Z*(1D0-ZDIV)
47835 ENDIF
47836 ENDIF
47837
47838C...Weighting according to correct formula.
47839 IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100
47840 FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z)
47841 IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX))
47842 FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP)))
47843 IF(FVAL.LT.PYR(0)*FPRE) GOTO 100
47844
47845C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
47846 ELSE
47847 FC=PARJ(50+MAX(1,KFLH))
47848 IF(MSTJ(91).EQ.1) FC=PARJ(59)
47849 110 Z=PYR(0)
47850 IF(FC.GE.0D0.AND.FC.LE.1D0) THEN
47851 IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0)
47852 ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN
47853 IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2)
47854 & GOTO 110
47855 ELSE
47856 IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
47857 IF(FC.LT.0D0) Z=Z**(-1D0/FC)
47858 ENDIF
47859 ENDIF
47860
47861 RETURN
47862 END
47863
47864C*********************************************************************
47865
47866C...PYSHOW
47867C...Generates timelike parton showers from given partons.
47868
47869 SUBROUTINE PYSHOW(IP1,IP2,QMAX)
47870
47871C...Double precision and integer declarations.
47872 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47873 IMPLICIT INTEGER(I-N)
47874 INTEGER PYK,PYCHGE,PYCOMP
47875C...Parameter statement to help give large particle numbers.
47876 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
47877 &KEXCIT=4000000,KDIMEN=5000000)
47878C...Commonblocks.
47879 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
47880 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47881 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47882 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
47883C...Local arrays.
47884 DIMENSION PMTH(5,50),PS(5),PMA(19),PMSD(10),IEP(10),IPA(10),
47885 &KFLA(10),KFLD(10),KFL(10),ITRY(10),ISI(10),ISL(10),DP(10),
47886 &DPT(5,4),KSH(0:40),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),
47887 &PHIIIS(2,2),ISII(2),ISSET(3),ISCOL(0:40),ISCHG(0:40),
47888 &IREF(1000)
47889
47890C...Check that QMAX not too low.
47891 IF(MSTJ(41).LE.0) THEN
47892 RETURN
47893 ELSEIF(MSTJ(41).EQ.1) THEN
47894 IF(QMAX.LE.PARJ(82).AND.IP2.GT.-8) RETURN
47895 ELSE
47896 IF(QMAX.LE.MIN(PARJ(82),PARJ(83),PARJ(90)).AND.IP2.GT.-8)
47897 & RETURN
47898 ENDIF
47899
47900C...Initialization of cutoff masses etc.
47901 DO 100 IFL=0,40
47902 ISCOL(IFL)=0
47903 ISCHG(IFL)=0
47904 KSH(IFL)=0
47905 100 CONTINUE
47906 ISCOL(21)=1
47907 KSH(21)=1
47908 PMTH(1,21)=PYMASS(21)
47909 PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2)
47910 PMTH(3,21)=2D0*PMTH(2,21)
47911 PMTH(4,21)=PMTH(3,21)
47912 PMTH(5,21)=PMTH(3,21)
47913 PMTH(1,22)=PYMASS(22)
47914 PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2)
47915 PMTH(3,22)=2D0*PMTH(2,22)
47916 PMTH(4,22)=PMTH(3,22)
47917 PMTH(5,22)=PMTH(3,22)
47918 PMQTH1=PARJ(82)
47919 IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
47920 PMQT1E=MIN(PMQTH1,PARJ(90))
47921 PMQTH2=PMTH(2,21)
47922 IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
47923 PMQT2E=MIN(PMQTH2,0.5D0*PARJ(90))
47924 DO 110 IFL=1,5
47925 ISCOL(IFL)=1
47926 IF(MSTJ(41).GE.2) ISCHG(IFL)=1
47927 KSH(IFL)=1
47928 PMTH(1,IFL)=PYMASS(IFL)
47929 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2)
47930 PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
47931 PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
47932 PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
47933 110 CONTINUE
47934 DO 120 IFL=11,15,2
47935 IF(MSTJ(41).GE.2) ISCHG(IFL)=1
47936 IF(MSTJ(41).GE.2) KSH(IFL)=1
47937 PMTH(1,IFL)=PYMASS(IFL)
47938 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(90)**2)
47939 PMTH(3,IFL)=PMTH(2,IFL)+0.5D0*PARJ(90)
47940 PMTH(4,IFL)=PMTH(3,IFL)
47941 PMTH(5,IFL)=PMTH(3,IFL)
47942 120 CONTINUE
47943 PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2
47944 ALAMS=PARJ(81)**2
47945 ALFM=LOG(PT2MIN/ALAMS)
47946
47947C...Store positions of shower initiating partons.
47948 MPSPD=0
47949 IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
47950 NPA=1
47951 IPA(1)=IP1
47952 ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
47953 & MSTU(32))) THEN
47954 NPA=2
47955 IPA(1)=IP1
47956 IPA(2)=IP2
47957 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
47958 & .AND.IP2.GE.-7) THEN
47959 NPA=IABS(IP2)
47960 DO 130 I=1,NPA
47961 IPA(I)=IP1+I-1
47962 130 CONTINUE
47963 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.
47964 &IP2.EQ.-8) THEN
47965 MPSPD=1
47966 NPA=2
47967 IPA(1)=IP1+6
47968 IPA(2)=IP1+7
47969 ELSE
47970 CALL PYERRM(12,
47971 & '(PYSHOW:) failed to reconstruct showering system')
47972 IF(MSTU(21).GE.1) RETURN
47973 ENDIF
47974
47975C...Check on phase space available for emission.
47976 IREJ=0
47977 DO 140 J=1,5
47978 PS(J)=0D0
47979 140 CONTINUE
47980 PM=0D0
47981 DO 160 I=1,NPA
47982 KFLA(I)=IABS(K(IPA(I),2))
47983 PMA(I)=P(IPA(I),5)
47984C...Special cutoff masses for initial partons (may be a heavy quark,
47985C...squark, ..., and need not be on the mass shell).
47986 IR=30+I
47987 IF(NPA.LE.1) IREF(I)=IR
47988 IF(NPA.GE.2) IREF(I+1)=IR
47989 IF(KFLA(I).LE.8) THEN
47990 ISCOL(IR)=1
47991 IF(MSTJ(41).GE.2) ISCHG(IR)=1
47992 ELSEIF(KFLA(I).EQ.11.OR.KFLA(I).EQ.13.OR.KFLA(I).EQ.15.OR.
47993 & KFLA(I).EQ.17) THEN
47994 IF(MSTJ(41).GE.2) ISCHG(IR)=1
47995 ELSEIF(KFLA(I).EQ.21) THEN
47996 ISCOL(IR)=1
47997 ELSEIF((KFLA(I).GE.KSUSY1+1.AND.KFLA(I).LE.KSUSY1+8).OR.
47998 & (KFLA(I).GE.KSUSY2+1.AND.KFLA(I).LE.KSUSY2+8)) THEN
47999 ISCOL(IR)=1
48000 ELSEIF(KFLA(I).EQ.KSUSY1+21) THEN
48001 ISCOL(IR)=1
48002 ENDIF
48003 IF(ISCOL(IR).EQ.1.OR.ISCHG(IR).EQ.1) KSH(IR)=1
48004 PMTH(1,IR)=PMA(I)
48005 IF(ISCOL(IR).EQ.1.AND.ISCHG(IR).EQ.1) THEN
48006 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PMQTH1**2)
48007 PMTH(3,IR)=PMTH(2,IR)+PMQTH2
48008 PMTH(4,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
48009 PMTH(5,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
48010 ELSEIF(ISCOL(IR).EQ.1) THEN
48011 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)
48012 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(82)
48013 PMTH(4,IR)=PMTH(3,IR)
48014 PMTH(5,IR)=PMTH(3,IR)
48015 ELSEIF(ISCHG(IR).EQ.1) THEN
48016 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(90)**2)
48017 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(90)
48018 PMTH(4,IR)=PMTH(3,IR)
48019 PMTH(5,IR)=PMTH(3,IR)
48020 ENDIF
48021 IF(KSH(IR).EQ.1) PMA(I)=PMTH(3,IR)
48022 PM=PM+PMA(I)
48023 IF(KSH(IR).EQ.0.OR.PMA(I).GT.10D0*QMAX) IREJ=IREJ+1
48024 DO 150 J=1,4
48025 PS(J)=PS(J)+P(IPA(I),J)
48026 150 CONTINUE
48027 160 CONTINUE
48028 IF(IREJ.EQ.NPA.AND.IP2.GE.-7) RETURN
48029 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
48030 IF(NPA.EQ.1) PS(5)=PS(4)
48031 IF(PS(5).LE.PM+PMQT1E) RETURN
48032
48033C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
48034 KFSRCE=0
48035 IF(IP2.LE.0) THEN
48036 ELSEIF(K(IP1,3).EQ.K(IP2,3).AND.K(IP1,3).GT.0) THEN
48037 KFSRCE=IABS(K(K(IP1,3),2))
48038 ELSE
48039 IPAR1=MAX(1,K(IP1,3))
48040 IPAR2=MAX(1,K(IP2,3))
48041 IF(K(IPAR1,3).EQ.K(IPAR2,3).AND.K(IPAR1,3).GT.0)
48042 & KFSRCE=IABS(K(K(IPAR1,3),2))
48043 ENDIF
48044 ITYPES=0
48045 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
48046 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
48047 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
48048 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
48049 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
48050 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
48051 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
48052 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
48053
48054C...Identify two primary showerers.
48055 ITYPE1=0
48056 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8) ITYPE1=1
48057 IF(KFLA(1).GE.KSUSY1+1.AND.KFLA(1).LE.KSUSY1+8) ITYPE1=2
48058 IF(KFLA(1).GE.KSUSY2+1.AND.KFLA(1).LE.KSUSY2+8) ITYPE1=2
48059 IF(KFLA(1).GE.21.AND.KFLA(1).LE.24) ITYPE1=3
48060 IF(KFLA(1).GE.32.AND.KFLA(1).LE.34) ITYPE1=3
48061 IF(KFLA(1).EQ.25.OR.(KFLA(1).GE.35.AND.KFLA(1).LE.37)) ITYPE1=4
48062 IF(KFLA(1).GE.KSUSY1+22.AND.KFLA(1).LE.KSUSY1+37) ITYPE1=5
48063 IF(KFLA(1).EQ.KSUSY1+21) ITYPE1=6
48064 ITYPE2=0
48065 IF(KFLA(2).GE.1.AND.KFLA(2).LE.8) ITYPE2=1
48066 IF(KFLA(2).GE.KSUSY1+1.AND.KFLA(2).LE.KSUSY1+8) ITYPE2=2
48067 IF(KFLA(2).GE.KSUSY2+1.AND.KFLA(2).LE.KSUSY2+8) ITYPE2=2
48068 IF(KFLA(2).GE.21.AND.KFLA(2).LE.24) ITYPE2=3
48069 IF(KFLA(2).GE.32.AND.KFLA(2).LE.34) ITYPE2=3
48070 IF(KFLA(2).EQ.25.OR.(KFLA(2).GE.35.AND.KFLA(2).LE.37)) ITYPE2=4
48071 IF(KFLA(2).GE.KSUSY1+22.AND.KFLA(2).LE.KSUSY1+37) ITYPE2=5
48072 IF(KFLA(2).EQ.KSUSY1+21) ITYPE2=6
48073
48074C...Order of showerers. Presence of gluino.
48075 ITYPMN=MIN(ITYPE1,ITYPE2)
48076 ITYPMX=MAX(ITYPE1,ITYPE2)
48077 IORD=1
48078 IF(ITYPE1.GT.ITYPE2) IORD=2
48079 IGLUI=0
48080 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
48081
48082C...Check if 3-jet matrix elements to be used.
48083 M3JC=0
48084 ALPHA=0.5D0
48085 IF(NPA.EQ.2.AND.MSTJ(47).GE.1.AND.MPSPD.EQ.0) THEN
48086 IF(MSTJ(38).NE.0) THEN
48087 M3JC=MSTJ(38)
48088 ALPHA=PARJ(80)
48089 MSTJ(38)=0
48090 ELSEIF(MSTJ(47).GE.6) THEN
48091 M3JC=MSTJ(47)
48092 ELSE
48093 ICLASS=1
48094 ICOMBI=4
48095
48096C...Vector/axial vector -> q + qbar; q -> q + V.
48097 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
48098 & ITYPES.EQ.3)) THEN
48099 ICLASS=2
48100 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
48101 ICOMBI=1
48102 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
48103 & K(IP1,2)+K(IP2,2).EQ.0)) THEN
48104C...gamma*/Z0: assume e+e- initial state if unknown.
48105 EI=-1D0
48106 IF(KFSRCE.EQ.23) THEN
48107 IANNFL=K(K(IP1,3),3)
48108 IF(IANNFL.NE.0) THEN
48109 KANNFL=IABS(K(IANNFL,2))
48110 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
48111 ENDIF
48112 ENDIF
48113 AI=SIGN(1D0,EI+0.1D0)
48114 VI=AI-4D0*EI*PARU(102)
48115 EF=KCHG(KFLA(1),1)/3D0
48116 AF=SIGN(1D0,EF+0.1D0)
48117 VF=AF-4D0*EF*PARU(102)
48118 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
48119 SH=PS(5)**2
48120 SQMZ=PMAS(23,1)**2
48121 SQWZ=PS(5)*PMAS(23,2)
48122 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
48123 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
48124 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
48125 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
48126 ICOMBI=3
48127 ALPHA=VECT/(VECT+AXIV)
48128 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
48129 ICOMBI=4
48130 ENDIF
48131C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
48132 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
48133 ICLASS=2
48134 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
48135 & ITYPES.EQ.1)) THEN
48136 ICLASS=3
48137
48138C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
48139 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
48140 ICLASS=4
48141 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
48142 ICOMBI=1
48143 ELSEIF(KFSRCE.EQ.36) THEN
48144 ICOMBI=2
48145 ENDIF
48146 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
48147 & ITYPES.EQ.1)) THEN
48148 ICLASS=5
48149
48150C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
48151 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
48152 & ITYPES.EQ.3)) THEN
48153 ICLASS=6
48154 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
48155 & ITYPES.EQ.2)) THEN
48156 ICLASS=7
48157 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
48158 ICLASS=8
48159 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
48160 & ITYPES.EQ.2)) THEN
48161 ICLASS=9
48162
48163C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
48164 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
48165 & ITYPES.EQ.5)) THEN
48166 ICLASS=10
48167 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
48168 & ITYPES.EQ.2)) THEN
48169 ICLASS=11
48170 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
48171 & ITYPES.EQ.1)) THEN
48172 ICLASS=12
48173
48174C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
48175 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
48176 ICLASS=13
48177 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
48178 & ITYPES.EQ.2)) THEN
48179 ICLASS=14
48180 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
48181 & ITYPES.EQ.1)) THEN
48182 ICLASS=15
48183
48184C...g -> ~g + ~g (eikonal approximation).
48185 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
48186 ICLASS=16
48187 ENDIF
48188 M3JC=5*ICLASS+ICOMBI
48189 ENDIF
48190 ENDIF
48191
48192C...Find if interference with initial state partons.
48193 MIIS=0
48194 IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2.AND.MPSPD.EQ.0)
48195 &MIIS=MSTJ(50)
48196 IF(MIIS.NE.0) THEN
48197 DO 180 I=1,2
48198 KCII(I)=0
48199 KCA=PYCOMP(KFLA(I))
48200 IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
48201 NIIS(I)=0
48202 IF(KCII(I).NE.0) THEN
48203 DO 170 J=1,2
48204 ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5))
48205 IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND.
48206 & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN
48207 NIIS(I)=NIIS(I)+1
48208 IIIS(I,NIIS(I))=ICSI
48209 ENDIF
48210 170 CONTINUE
48211 ENDIF
48212 180 CONTINUE
48213 IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
48214 ENDIF
48215
48216C...Boost interfering initial partons to rest frame
48217C...and reconstruct their polar and azimuthal angles.
48218 IF(MIIS.NE.0) THEN
48219 DO 200 I=1,2
48220 DO 190 J=1,5
48221 K(N+I,J)=K(IPA(I),J)
48222 P(N+I,J)=P(IPA(I),J)
48223 V(N+I,J)=0D0
48224 190 CONTINUE
48225 200 CONTINUE
48226 DO 220 I=3,2+NIIS(1)
48227 DO 210 J=1,5
48228 K(N+I,J)=K(IIIS(1,I-2),J)
48229 P(N+I,J)=P(IIIS(1,I-2),J)
48230 V(N+I,J)=0D0
48231 210 CONTINUE
48232 220 CONTINUE
48233 DO 240 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
48234 DO 230 J=1,5
48235 K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J)
48236 P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J)
48237 V(N+I,J)=0D0
48238 230 CONTINUE
48239 240 CONTINUE
48240 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4),
48241 & -PS(2)/PS(4),-PS(3)/PS(4))
48242 PHI=PYANGL(P(N+1,1),P(N+1,2))
48243 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0)
48244 THE=PYANGL(P(N+1,3),P(N+1,1))
48245 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0)
48246 DO 250 I=3,2+NIIS(1)
48247 THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2))
48248 PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2))
48249 250 CONTINUE
48250 DO 260 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
48251 THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3),
48252 & SQRT(P(N+I,1)**2+P(N+I,2)**2))
48253 PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2))
48254 260 CONTINUE
48255 ENDIF
48256
48257C...Boost 3 or more partons to their rest frame.
48258 IF(NPA.GE.3) CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,-PS(1)/PS(4),
48259 &-PS(2)/PS(4),-PS(3)/PS(4))
48260
48261C...Define imagined single initiator of shower for parton system.
48262 NS=N
48263 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
48264 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
48265 IF(MSTU(21).GE.1) RETURN
48266 ENDIF
48267 270 N=NS
48268 IF(NPA.GE.2) THEN
48269 K(N+1,1)=11
48270 K(N+1,2)=21
48271 K(N+1,3)=0
48272 K(N+1,4)=0
48273 K(N+1,5)=0
48274 P(N+1,1)=0D0
48275 P(N+1,2)=0D0
48276 P(N+1,3)=0D0
48277 P(N+1,4)=PS(5)
48278 P(N+1,5)=PS(5)
48279 V(N+1,5)=PS(5)**2
48280 N=N+1
48281 IREF(1)=21
48282 ENDIF
48283
48284C...Loop over partons that may branch.
48285 NEP=NPA
48286 IM=NS
48287 IF(NPA.EQ.1) IM=NS-1
48288 280 IM=IM+1
48289 IF(N.GT.NS) THEN
48290 IF(IM.GT.N) GOTO 590
48291 KFLM=IABS(K(IM,2))
48292 IR=IREF(IM-NS)
48293 IF(KSH(IR).EQ.0) GOTO 280
48294 IF(P(IM,5).LT.PMTH(2,IR)) GOTO 280
48295 IGM=K(IM,3)
48296 ELSE
48297 IGM=-1
48298 ENDIF
48299 IF(N+NEP.GT.MSTU(4)-MSTU(32)-10) THEN
48300 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
48301 IF(MSTU(21).GE.1) RETURN
48302 ENDIF
48303
48304C...Position of aunt (sister to branching parton).
48305C...Origin and flavour of daughters.
48306 IAU=0
48307 IF(IGM.GT.0) THEN
48308 IF(K(IM-1,3).EQ.IGM) IAU=IM-1
48309 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
48310 ENDIF
48311 IF(IGM.GE.0) THEN
48312 K(IM,4)=N+1
48313 DO 290 I=1,NEP
48314 K(N+I,3)=IM
48315 290 CONTINUE
48316 ELSE
48317 K(N+1,3)=IPA(1)
48318 ENDIF
48319 IF(IGM.LE.0) THEN
48320 DO 300 I=1,NEP
48321 K(N+I,2)=K(IPA(I),2)
48322 300 CONTINUE
48323 ELSEIF(KFLM.NE.21) THEN
48324 K(N+1,2)=K(IM,2)
48325 K(N+2,2)=K(IM,5)
48326 IREF(N+1-NS)=IREF(IM-NS)
48327 IREF(N+2-NS)=IABS(K(N+2,2))
48328 ELSEIF(K(IM,5).EQ.21) THEN
48329 K(N+1,2)=21
48330 K(N+2,2)=21
48331 IREF(N+1-NS)=21
48332 IREF(N+2-NS)=21
48333 ELSE
48334 K(N+1,2)=K(IM,5)
48335 K(N+2,2)=-K(IM,5)
48336 IREF(N+1-NS)=IABS(K(N+1,2))
48337 IREF(N+2-NS)=IABS(K(N+2,2))
48338 ENDIF
48339
48340C...Reset flags on daughters and tries made.
48341 DO 310 IP=1,NEP
48342 K(N+IP,1)=3
48343 K(N+IP,4)=0
48344 K(N+IP,5)=0
48345 KFLD(IP)=IABS(K(N+IP,2))
48346 IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
48347 ITRY(IP)=0
48348 ISL(IP)=0
48349 ISI(IP)=0
48350 IF(KSH(IREF(N+IP-NS)).EQ.1) ISI(IP)=1
48351 310 CONTINUE
48352 ISLM=0
48353
48354C...Maximum virtuality of daughters.
48355 IF(IGM.LE.0) THEN
48356 DO 320 I=1,NPA
48357 IF(NPA.GE.3) P(N+I,4)=P(IPA(I),4)
48358 P(N+I,5)=MIN(QMAX,PS(5))
48359 IR=IREF(N+I-NS)
48360 IF(IP2.LE.-8) P(N+I,5)=MAX(P(N+I,5),2D0*PMTH(3,IR))
48361 IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
48362 320 CONTINUE
48363 ELSE
48364 IF(MSTJ(43).LE.2) PEM=V(IM,2)
48365 IF(MSTJ(43).GE.3) PEM=P(IM,4)
48366 P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
48367 P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM)
48368 IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
48369 ENDIF
48370 DO 330 I=1,NEP
48371 PMSD(I)=P(N+I,5)
48372 IF(ISI(I).EQ.1) THEN
48373 IR=IREF(N+I-NS)
48374 IF(P(N+I,5).LE.PMTH(3,IR)) P(N+I,5)=PMTH(1,IR)
48375 ENDIF
48376 V(N+I,5)=P(N+I,5)**2
48377 330 CONTINUE
48378
48379C...Choose one of the daughters for evolution.
48380 340 INUM=0
48381 IF(NEP.EQ.1) INUM=1
48382 DO 350 I=1,NEP
48383 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
48384 350 CONTINUE
48385 DO 360 I=1,NEP
48386 IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
48387 IR=IREF(N+I-NS)
48388 IF(P(N+I,5).GE.PMTH(2,IR)) INUM=I
48389 ENDIF
48390 360 CONTINUE
48391 IF(INUM.EQ.0) THEN
48392 RMAX=0D0
48393 DO 370 I=1,NEP
48394 IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQT2E) THEN
48395 RPM=P(N+I,5)/PMSD(I)
48396 IR=IREF(N+I-NS)
48397 IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IR)) THEN
48398 RMAX=RPM
48399 INUM=I
48400 ENDIF
48401 ENDIF
48402 370 CONTINUE
48403 ENDIF
48404
48405C...Cancel choice of predetermined daughter already treated.
48406 INUM=MAX(1,INUM)
48407 INUMT=INUM
48408 IF(MPSPD.EQ.1.AND.IGM.EQ.0.AND.ITRY(INUMT).GE.1) THEN
48409 IF(K(IP1-1+INUM,4).GT.0) INUM=3-INUM
48410 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2.AND.ITRY(INUMT).GE.1) THEN
48411 IF(KFLD(INUMT).NE.21.AND.K(IP1+2,4).GT.0) INUM=3-INUM
48412 IF(KFLD(INUMT).EQ.21.AND.K(IP1+3,4).GT.0) INUM=3-INUM
48413 ENDIF
48414
48415C...Store information on choice of evolving daughter.
48416 IEP(1)=N+INUM
48417 DO 380 I=2,NEP
48418 IEP(I)=IEP(I-1)+1
48419 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
48420 380 CONTINUE
48421 DO 390 I=1,NEP
48422 KFL(I)=IABS(K(IEP(I),2))
48423 390 CONTINUE
48424 ITRY(INUM)=ITRY(INUM)+1
48425 IF(ITRY(INUM).GT.200) THEN
48426 CALL PYERRM(14,'(PYSHOW:) caught in infinite loop')
48427 IF(MSTU(21).GE.1) RETURN
48428 ENDIF
48429 Z=0.5D0
48430 IR=IREF(IEP(1)-NS)
48431 IF(KSH(IR).EQ.0) GOTO 440
48432 IF(P(IEP(1),5).LT.PMTH(2,IR)) GOTO 440
48433
48434C...Check if evolution already predetermined for daughter.
48435 IPSPD=0
48436 IF(MPSPD.EQ.1.AND.IGM.EQ.0) THEN
48437 IF(K(IP1-1+INUM,4).GT.0) IPSPD=IP1-1+INUM
48438 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2) THEN
48439 IF(KFL(1).NE.21.AND.K(IP1+2,4).GT.0) IPSPD=IP1+2
48440 IF(KFL(1).EQ.21.AND.K(IP1+3,4).GT.0) IPSPD=IP1+3
48441 ENDIF
48442 ISSET(INUM)=0
48443 IF(IPSPD.NE.0) ISSET(INUM)=1
48444
48445C...Select side for interference with initial state partons.
48446 IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
48447 III=IEP(1)-NS-1
48448 ISII(III)=0
48449 IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
48450 ISII(III)=1
48451 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
48452 IF(PYR(0).GT.0.5D0) ISII(III)=1
48453 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
48454 ISII(III)=1
48455 IF(PYR(0).GT.0.5D0) ISII(III)=2
48456 ENDIF
48457 ENDIF
48458
48459C...Calculate allowed z range.
48460 IF(NEP.EQ.1) THEN
48461 PMED=PS(4)
48462 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
48463 PMED=P(IM,5)
48464 ELSE
48465 IF(INUM.EQ.1) PMED=V(IM,1)*PEM
48466 IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM
48467 ENDIF
48468 IF(MOD(MSTJ(43),2).EQ.1) THEN
48469 ZC=PMTH(2,21)/PMED
48470 ZCE=PMTH(2,22)/PMED
48471 IF(ISCOL(IR).EQ.0) ZCE=0.5D0*PARJ(90)/PMED
48472 ELSE
48473 ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2)))
48474 IF(ZC.LT.1D-6) ZC=(PMTH(2,21)/PMED)**2
48475 PMTMPE=PMTH(2,22)
48476 IF(ISCOL(IR).EQ.0) PMTMPE=0.5D0*PARJ(90)
48477 ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTMPE/PMED)**2)))
48478 IF(ZCE.LT.1D-6) ZCE=(PMTMPE/PMED)**2
48479 ENDIF
48480 ZC=MIN(ZC,0.491D0)
48481 ZCE=MIN(ZCE,0.49991D0)
48482 IF(((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND.
48483 &MIN(ZC,ZCE).GT.0.4999D0)).AND.IPSPD.EQ.0) THEN
48484 P(IEP(1),5)=PMTH(1,IR)
48485 V(IEP(1),5)=P(IEP(1),5)**2
48486 GOTO 440
48487 ENDIF
48488
48489C...Integral of Altarelli-Parisi z kernel for QCD.
48490C...(Includes squark and gluino; with factor N_C/C_F extra for latter).
48491 IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
48492 FBR=6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*0.5D0
48493 ELSEIF(MSTJ(49).EQ.0) THEN
48494 FBR=(8D0/3D0)*LOG((1D0-ZC)/ZC)
48495 IF(IGLUI.EQ.1.AND.IR.GE.31) FBR=FBR*(9D0/4D0)
48496
48497C...Integral of Altarelli-Parisi z kernel for scalar gluon.
48498 ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
48499 FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC)
48500 ELSEIF(MSTJ(49).EQ.1) THEN
48501 FBR=(1D0-2D0*ZC)/3D0
48502 IF(IGM.EQ.0.AND.M3JC.GE.1) FBR=4D0*FBR
48503
48504C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
48505 ELSEIF(KFL(1).EQ.21) THEN
48506 FBR=6D0*MSTJ(45)*(0.5D0-ZC)
48507 ELSE
48508 FBR=2D0*LOG((1D0-ZC)/ZC)
48509 ENDIF
48510
48511C...Reset QCD probability for colourless.
48512 IF(ISCOL(IR).EQ.0) FBR=0D0
48513
48514C...Integral of Altarelli-Parisi kernel for photon emission.
48515 FBRE=0D0
48516 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1) THEN
48517 IF(KFL(1).LE.18) THEN
48518 FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE)
48519 ENDIF
48520 IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE
48521 ENDIF
48522
48523C...Inner veto algorithm starts. Find maximum mass for evolution.
48524 400 PMS=V(IEP(1),5)
48525 IF(IGM.GE.0) THEN
48526 PM2=0D0
48527 DO 410 I=2,NEP
48528 PM=P(IEP(I),5)
48529 IRI=IREF(IEP(I)-NS)
48530 IF(KSH(IRI).EQ.1) PM=PMTH(2,IRI)
48531 PM2=PM2+PM
48532 410 CONTINUE
48533 PMS=MIN(PMS,(P(IM,5)-PM2)**2)
48534 ENDIF
48535
48536C...Select mass for daughter in QCD evolution.
48537 B0=27D0/6D0
48538 DO 420 IFF=4,MSTJ(45)
48539 IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0
48540 420 CONTINUE
48541C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
48542 PMSC=MAX(0.5D0*PARJ(82),PMS-PMTH(1,IR)**2)
48543C...Already predetermined choice.
48544 IF(IPSPD.NE.0) THEN
48545 PMSQCD=P(IPSPD,5)**2
48546 ELSEIF(FBR.LT.1D-3) THEN
48547 PMSQCD=0D0
48548 ELSEIF(MSTJ(44).LE.0) THEN
48549 PMSQCD=PMSC*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR)))
48550 ELSEIF(MSTJ(44).EQ.1) THEN
48551 PMSQCD=4D0*ALAMS*(0.25D0*PMSC/ALAMS)**(PYR(0)**(B0/FBR))
48552 ELSE
48553 PMSQCD=PMSC*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR))
48554 ENDIF
48555C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
48556 IF(IPSPD.EQ.0) PMSQCD=PMSQCD+PMTH(1,IR)**2
48557 IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IR)**2) PMSQCD=PMTH(2,IR)**2
48558 V(IEP(1),5)=PMSQCD
48559 MCE=1
48560
48561C...Select mass for daughter in QED evolution.
48562 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1.AND.IPSPD.EQ.0) THEN
48563C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
48564 PMSE=MAX(0.5D0*PARJ(83),PMS-PMTH(1,IR)**2)
48565 IF(FBRE.LT.1D-3) THEN
48566 PMSQED=0D0
48567 ELSE
48568 PMSQED=PMSE*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
48569 & (PARU(101)*FBRE)))
48570 ENDIF
48571C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
48572 PMSQED=PMSQED+PMTH(1,IR)**2
48573 IF(ZCE.GT.0.4999D0.OR.PMSQED.LE.PMTH(5,IR)**2) PMSQED=
48574 & PMTH(2,IR)**2
48575 IF(PMSQED.GT.PMSQCD) THEN
48576 V(IEP(1),5)=PMSQED
48577 MCE=2
48578 ENDIF
48579 ENDIF
48580
48581C...Check whether daughter mass below cutoff.
48582 P(IEP(1),5)=SQRT(V(IEP(1),5))
48583 IF(P(IEP(1),5).LE.PMTH(3,IR)) THEN
48584 P(IEP(1),5)=PMTH(1,IR)
48585 V(IEP(1),5)=P(IEP(1),5)**2
48586 GOTO 440
48587 ENDIF
48588
48589C...Already predetermined choice of z, and flavour in g -> qqbar.
48590 IF(IPSPD.NE.0) THEN
48591 IPSGD1=K(IPSPD,4)
48592 IPSGD2=K(IPSPD,5)
48593 PMSGD1=P(IPSGD1,5)**2
48594 PMSGD2=P(IPSGD2,5)**2
48595 ALAMPS=SQRT(MAX(1D-10,(PMSQCD-PMSGD1-PMSGD2)**2-
48596 & 4D0*PMSGD1*PMSGD2))
48597 Z=0.5D0*(PMSQCD*(2D0*P(IPSGD1,4)/P(IPSPD,4)-1D0)+ALAMPS-
48598 & PMSGD1+PMSGD2)/ALAMPS
48599 Z=MAX(0.00001D0,MIN(0.99999D0,Z))
48600 IF(KFL(1).NE.21) THEN
48601 K(IEP(1),5)=21
48602 ELSE
48603 K(IEP(1),5)=IABS(K(IPSGD1,2))
48604 ENDIF
48605
48606C...Select z value of branching: q -> qgamma.
48607 ELSEIF(MCE.EQ.2) THEN
48608 Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0)
48609 IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 400
48610 K(IEP(1),5)=22
48611
48612C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
48613 ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
48614 Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
48615C...Only do z weighting when no ME correction afterwards.
48616 IF(M3JC.EQ.0.AND.1D0+Z**2.LT.2D0*PYR(0)) GOTO 400
48617 K(IEP(1),5)=21
48618 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*0.5D0.LT.PYR(0)*FBR) THEN
48619 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
48620 IF(PYR(0).GT.0.5D0) Z=1D0-Z
48621 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 400
48622 K(IEP(1),5)=21
48623 ELSEIF(MSTJ(49).NE.1) THEN
48624 Z=PYR(0)
48625 IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 400
48626 KFLB=1+INT(MSTJ(45)*PYR(0))
48627 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
48628 IF(PMQ.GE.1D0) GOTO 400
48629 IF(MSTJ(44).LE.2.OR.MSTJ(44).EQ.4) THEN
48630 IF(Z.LT.ZC.OR.Z.GT.1D0-ZC) GOTO 400
48631 PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5)
48632 IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ)
48633 & .LT.PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 400
48634 ELSE
48635 IF((1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.PYR(0)) GOTO 400
48636 ENDIF
48637 K(IEP(1),5)=KFLB
48638
48639C...Ditto for scalar gluon model.
48640 ELSEIF(KFL(1).NE.21) THEN
48641 Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC))
48642 K(IEP(1),5)=21
48643 ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
48644 Z=ZC+(1D0-2D0*ZC)*PYR(0)
48645 K(IEP(1),5)=21
48646 ELSE
48647 Z=ZC+(1D0-2D0*ZC)*PYR(0)
48648 KFLB=1+INT(MSTJ(45)*PYR(0))
48649 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
48650 IF(PMQ.GE.1D0) GOTO 400
48651 K(IEP(1),5)=KFLB
48652 ENDIF
48653
48654C...Correct to alpha_s(pT^2) (optionally m^2/4 for g -> q qbar).
48655 IF(MCE.EQ.1.AND.MSTJ(44).GE.2.AND.IPSPD.EQ.0) THEN
48656 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
48657 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
48658 IF(ALFM/LOG(V(IEP(1),5)*0.25D0/ALAMS).LT.PYR(0)) GOTO 400
48659 ELSE
48660 PT2APP=Z*(1D0-Z)*V(IEP(1),5)
48661 IF(MSTJ(44).GE.4) PT2APP=PT2APP*
48662 & (1D0-PMTH(1,IR)**2/V(IEP(1),5))**2
48663 IF(PT2APP.LT.PT2MIN) GOTO 400
48664 IF(ALFM/LOG(PT2APP/ALAMS).LT.PYR(0)) GOTO 400
48665 ENDIF
48666 ENDIF
48667
48668C...Check if z consistent with chosen m.
48669 IF(KFL(1).EQ.21) THEN
48670 IRGD1=IABS(K(IEP(1),5))
48671 IRGD2=IRGD1
48672 ELSE
48673 IRGD1=IR
48674 IRGD2=IABS(K(IEP(1),5))
48675 ENDIF
48676 IF(NEP.EQ.1) THEN
48677 PED=PS(4)
48678 ELSEIF(NEP.GE.3) THEN
48679 PED=P(IEP(1),4)
48680 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
48681 PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
48682 ELSE
48683 IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
48684 IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM
48685 ENDIF
48686 IF(MOD(MSTJ(43),2).EQ.1) THEN
48687 PMQTH3=0.5D0*PARJ(82)
48688 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
48689 IF(IRGD2.EQ.22.AND.ISCOL(IR).EQ.0) PMQTH3=0.5D0*PARJ(90)
48690 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(IEP(1),5)
48691 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(IEP(1),5)
48692 ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
48693 & 4D0*PMQ1*PMQ2)))
48694 ZH=1D0+PMQ1-PMQ2
48695 ELSE
48696 ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2))
48697 ZH=1D0
48698 ENDIF
48699 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
48700 &(MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
48701 ELSEIF(IPSPD.NE.0) THEN
48702 ELSE
48703 ZL=0.5D0*(ZH-ZD)
48704 ZU=0.5D0*(ZH+ZD)
48705 IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 400
48706 ENDIF
48707 IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL*
48708 &(1D0-ZU)))
48709 IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
48710
48711C...Width suppression for q -> q + g.
48712 IF(MSTJ(40).NE.0.AND.KFL(1).NE.21.AND.IPSPD.EQ.0) THEN
48713 IF(IGM.EQ.0) THEN
48714 EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5))
48715 ELSE
48716 EGLU=PMED*(1D0-Z)
48717 ENDIF
48718 CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2)
48719 IF(MSTJ(40).EQ.1) THEN
48720 IF(CHI.LT.PYR(0)) GOTO 400
48721 ELSEIF(MSTJ(40).EQ.2) THEN
48722 IF(1D0-CHI.LT.PYR(0)) GOTO 400
48723 ENDIF
48724 ENDIF
48725
48726C...Three-jet matrix element correction.
48727 IF(M3JC.GE.1) THEN
48728 WME=1D0
48729 WSHOW=1D0
48730
48731C...QED matrix elements: only for massless case so far.
48732 IF(MCE.EQ.2.AND.IGM.EQ.0) THEN
48733 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
48734 X2=1D0-V(IEP(1),5)/V(NS+1,5)
48735 X3=(1D0-X1)+(1D0-X2)
48736 KI1=K(IPA(INUM),2)
48737 KI2=K(IPA(3-INUM),2)
48738 QF1=KCHG(PYCOMP(KI1),1)*ISIGN(1,KI1)/3D0
48739 QF2=KCHG(PYCOMP(KI2),1)*ISIGN(1,KI2)/3D0
48740 WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+
48741 & QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2)
48742 WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2)
48743 ELSEIF(MCE.EQ.2) THEN
48744
48745C...QCD matrix elements, including mass effects.
48746 ELSEIF(MSTJ(49).NE.1.AND.K(IEP(1),2).NE.21) THEN
48747 PS1ME=V(IEP(1),5)
48748 PM1ME=PMTH(1,IR)
48749 M3JCC=M3JC
48750 IF(IR.GE.31.AND.IGM.EQ.0) THEN
48751C...QCD ME: original parton, first branching.
48752 PM2ME=PMTH(1,63-IR)
48753 ECMME=PS(5)
48754 ELSEIF(IR.GE.31) THEN
48755C...QCD ME: original parton, subsequent branchings.
48756 PM2ME=PMTH(1,63-IR)
48757 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
48758 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
48759 ELSEIF(K(IM,2).EQ.21) THEN
48760C...QCD ME: secondary partons, first branching.
48761 PM2ME=PM1ME
48762 ZMME=V(IM,1)
48763 IF(IEP(1).GT.IEP(2)) ZMME=1D0-ZMME
48764 PMLME=SQRT(MAX(0D0,(V(IM,5)-PS1ME-PM2ME**2)**2-
48765 & 4D0*PS1ME*PM2ME**2))
48766 PEDME=PEM*(0.5D0*(V(IM,5)-PMLME+PS1ME-PM2ME**2)+PMLME*ZMME)/
48767 & V(IM,5)
48768 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
48769 M3JCC=66
48770 ELSE
48771C...QCD ME: secondary partons, subsequent branchings.
48772 PM2ME=PM1ME
48773 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
48774 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
48775 M3JCC=66
48776 ENDIF
48777C...Construct ME variables.
48778 R1ME=PM1ME/ECMME
48779 R2ME=PM2ME/ECMME
48780 X1=(1D0+PS1ME/ECMME**2-R2ME**2)*(Z+(1D0-Z)*PM1ME**2/PS1ME)
48781 X2=1D0+R2ME**2-PS1ME/ECMME**2
48782C...Call ME, with right order important for two inequivalent showerers.
48783 IF(IR.EQ.IORD+30) THEN
48784 WME=PYMAEL(M3JCC,X1,X2,R1ME,R2ME,ALPHA)
48785 ELSE
48786 WME=PYMAEL(M3JCC,X2,X1,R2ME,R1ME,ALPHA)
48787 ENDIF
48788C...Split up total ME when two radiating partons.
48789 ISPRAD=1
48790 IF((M3JCC.GE.16.AND.M3JCC.LE.19).OR.
48791 & (M3JCC.GE.26.AND.M3JCC.LE.29).OR.
48792 & (M3JCC.GE.36.AND.M3JCC.LE.39).OR.
48793 & (M3JCC.GE.46.AND.M3JCC.LE.49).OR.
48794 & (M3JCC.GE.56.AND.M3JCC.LE.64)) ISPRAD=0
48795 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
48796 & MAX(1D-10,2D0-X1-X2)
48797C...Evaluate shower rate to be compared with.
48798 WSHOW=2D0/(MAX(1D-10,2D0-X1-X2)*
48799 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
48800 IF(IGLUI.EQ.1.AND.IR.GE.31) WSHOW=(9D0/4D0)*WSHOW
48801 ELSEIF(MSTJ(49).NE.1) THEN
48802
48803C...Toy model scalar theory matrix elements; no mass effects.
48804 ELSE
48805 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
48806 X2=1D0-V(IEP(1),5)/V(NS+1,5)
48807 X3=(1D0-X1)+(1D0-X2)
48808 WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2)
48809 WME=X3**2
48810 IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*
48811 & PARJ(171)
48812 ENDIF
48813
48814 IF(WME.LT.PYR(0)*WSHOW) GOTO 400
48815 ENDIF
48816
48817C...Impose angular ordering by rejection of nonordered emission.
48818 IF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2.AND.IPSPD.EQ.0) THEN
48819 PEMAO=V(IM,1)*P(IM,4)
48820 IF(IEP(1).EQ.N+2) PEMAO=(1D0-V(IM,1))*P(IM,4)
48821 IF(IR.GE.31.AND.MSTJ(42).GE.5) THEN
48822 MAOD=0
48823 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.4
48824 & .OR.MSTJ(42).EQ.7)) THEN
48825 MAOD=0
48826 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.3
48827 & .OR.MSTJ(42).EQ.6)) THEN
48828 MAOD=1
48829 PMDAO=PMTH(2,K(IEP(1),5))
48830 THE2ID=Z*(1D0-Z)*PEMAO**2/(V(IEP(1),5)-4D0*PMDAO**2)
48831 ELSE
48832 MAOD=1
48833 THE2ID=Z*(1D0-Z)*PEMAO**2/V(IEP(1),5)
48834 IF(MSTJ(42).GE.3.AND.MSTJ(42).NE.5) THE2ID=THE2ID*
48835 & (1D0+PMTH(1,IR)**2*(1D0-Z)/(V(IEP(1),5)*Z))**2
48836 ENDIF
48837 MAOM=1
48838 IAOM=IM
48839 430 IF(K(IAOM,5).EQ.22) THEN
48840 IAOM=K(IAOM,3)
48841 IF(K(IAOM,3).LE.NS) MAOM=0
48842 IF(MAOM.EQ.1) GOTO 430
48843 ENDIF
48844 IF(MAOM.EQ.1.AND.MAOD.EQ.1) THEN
48845 THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
48846 IF(THE2ID.LT.THE2IM) GOTO 400
48847 ENDIF
48848 ENDIF
48849
48850C...Impose user-defined maximum angle at first branching.
48851 IF(MSTJ(48).EQ.1.AND.IPSPD.EQ.0) THEN
48852 IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
48853 THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5)
48854 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 400
48855 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
48856 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
48857 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 400
48858 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
48859 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
48860 IF(PARJ(86)**2*THE2ID.LT.1D0) GOTO 400
48861 ENDIF
48862 ENDIF
48863
48864C...Impose angular constraint in first branching from interference
48865C...with initial state partons.
48866 IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN
48867 THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2
48868 IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN
48869 IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 400
48870 ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN
48871 IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 400
48872 ENDIF
48873 ENDIF
48874
48875C...End of inner veto algorithm. Check if only one leg evolved so far.
48876 440 V(IEP(1),1)=Z
48877 ISL(1)=0
48878 ISL(2)=0
48879 IF(NEP.EQ.1) GOTO 480
48880 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 340
48881 DO 450 I=1,NEP
48882 IR=IREF(N+I-NS)
48883 IF(ITRY(I).EQ.0.AND.KSH(IR).EQ.1) THEN
48884 IF(P(N+I,5).GE.PMTH(2,IR)) GOTO 340
48885 ENDIF
48886 450 CONTINUE
48887
48888C...Check if chosen multiplet m1,m2,z1,z2 is physical.
48889 IF(NEP.GE.3) THEN
48890 PMSUM=0D0
48891 DO 460 I=1,NEP
48892 PMSUM=PMSUM+P(N+I,5)
48893 460 CONTINUE
48894 IF(PMSUM.GE.PS(5)) GOTO 340
48895 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
48896 DO 470 I1=N+1,N+2
48897 IRDA=IREF(I1-NS)
48898 IF(KSH(IRDA).EQ.0) GOTO 470
48899 IF(P(I1,5).LT.PMTH(2,IRDA)) GOTO 470
48900 IF(IRDA.EQ.21) THEN
48901 IRGD1=IABS(K(I1,5))
48902 IRGD2=IRGD1
48903 ELSE
48904 IRGD1=IRDA
48905 IRGD2=IABS(K(I1,5))
48906 ENDIF
48907 I2=2*N+3-I1
48908 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
48909 PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
48910 ELSE
48911 IF(I1.EQ.N+1) ZM=V(IM,1)
48912 IF(I1.EQ.N+2) ZM=1D0-V(IM,1)
48913 PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
48914 & 4D0*V(N+1,5)*V(N+2,5))
48915 PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/
48916 & V(IM,5)
48917 ENDIF
48918 IF(MOD(MSTJ(43),2).EQ.1) THEN
48919 PMQTH3=0.5D0*PARJ(82)
48920 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
48921 IF(IRGD2.EQ.22.AND.ISCOL(IRDA).EQ.0) PMQTH3=0.5D0*PARJ(90)
48922 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(I1,5)
48923 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(I1,5)
48924 ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
48925 & 4D0*PMQ1*PMQ2)))
48926 ZH=1D0+PMQ1-PMQ2
48927 ELSE
48928 ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2))
48929 ZH=1D0
48930 ENDIF
48931 IF(IRDA.EQ.21.AND.IRGD1.LT.10.AND.
48932 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
48933 ELSE
48934 ZL=0.5D0*(ZH-ZD)
48935 ZU=0.5D0*(ZH+ZD)
48936 IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
48937 & ISSET(1).EQ.0) THEN
48938 ISL(1)=1
48939 ELSEIF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
48940 & ISSET(2).EQ.0) THEN
48941 ISL(2)=1
48942 ENDIF
48943 ENDIF
48944 IF(IRDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20,
48945 & ZL*(1D0-ZU)))
48946 IF(IRDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
48947 470 CONTINUE
48948 IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
48949 ISL(3-ISLM)=0
48950 ISLM=3-ISLM
48951 ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
48952 ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0)
48953 ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0)
48954 IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0
48955 IF(ISL(1).EQ.1) ISL(2)=0
48956 IF(ISL(1).EQ.0) ISLM=1
48957 IF(ISL(2).EQ.0) ISLM=2
48958 ENDIF
48959 IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 340
48960 ENDIF
48961 IRD1=IREF(N+1-NS)
48962 IRD2=IREF(N+2-NS)
48963 IF(IGM.GT.0) THEN
48964 IF(MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
48965 & PMTH(2,IRD1).OR.P(N+2,5).GE.PMTH(2,IRD2))) THEN
48966 PMQ1=V(N+1,5)/V(IM,5)
48967 PMQ2=V(N+2,5)/V(IM,5)
48968 ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2-
48969 & 4D0*PMQ1*PMQ2)))
48970 ZH=1D0+PMQ1-PMQ2
48971 ZL=0.5D0*(ZH-ZD)
48972 ZU=0.5D0*(ZH+ZD)
48973 IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 340
48974 ENDIF
48975 ENDIF
48976
48977C...Accepted branch. Construct four-momentum for initial partons.
48978 480 MAZIP=0
48979 MAZIC=0
48980 IF(NEP.EQ.1) THEN
48981 P(N+1,1)=0D0
48982 P(N+1,2)=0D0
48983 P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
48984 & P(N+1,5))))
48985 P(N+1,4)=P(IPA(1),4)
48986 V(N+1,2)=P(N+1,4)
48987 ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
48988 PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
48989 P(N+1,1)=0D0
48990 P(N+1,2)=0D0
48991 P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
48992 P(N+1,4)=PED1
48993 P(N+2,1)=0D0
48994 P(N+2,2)=0D0
48995 P(N+2,3)=-P(N+1,3)
48996 P(N+2,4)=P(IM,5)-PED1
48997 V(N+1,2)=P(N+1,4)
48998 V(N+2,2)=P(N+2,4)
48999 ELSEIF(NEP.GE.3) THEN
49000C...Rescale all momenta for energy conservation.
49001 LOOP=0
49002 PES=0D0
49003 PQS=0D0
49004 DO 500 I=1,NEP
49005 DO 490 J=1,4
49006 P(N+I,J)=P(IPA(I),J)
49007 490 CONTINUE
49008 PES=PES+P(N+I,4)
49009 PQS=PQS+P(N+I,5)**2/P(N+I,4)
49010 500 CONTINUE
49011 510 LOOP=LOOP+1
49012 FAC=(PS(5)-PQS)/(PES-PQS)
49013 PES=0D0
49014 PQS=0D0
49015 DO 530 I=1,NEP
49016 DO 520 J=1,3
49017 P(N+I,J)=FAC*P(N+I,J)
49018 520 CONTINUE
49019 P(N+I,4)=SQRT(P(N+I,5)**2+P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
49020 V(N+I,2)=P(N+I,4)
49021 PES=PES+P(N+I,4)
49022 PQS=PQS+P(N+I,5)**2/P(N+I,4)
49023 530 CONTINUE
49024 IF(LOOP.LT.10.AND.ABS(PES-PS(5)).GT.1D-12*PS(5)) GOTO 510
49025
49026C...Construct transverse momentum for ordinary branching in shower.
49027 ELSE
49028 ZM=V(IM,1)
49029 LOOPPT=0
49030 540 LOOPPT=LOOPPT+1
49031 PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5))))
49032 PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5)
49033 IF(PZM.LE.0D0) THEN
49034 PTS=0D0
49035 ELSEIF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
49036 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
49037 PTS=PMLS*ZM*(1D0-ZM)/V(IM,5)
49038 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
49039 PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)-
49040 & ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2
49041 ELSE
49042 PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2
49043 ENDIF
49044 IF(PTS.LT.0D0.AND.LOOPPT.LT.10) THEN
49045 ZM=0.05D0+0.9D0*ZM
49046 GOTO 540
49047 ELSEIF(PTS.LT.0D0) THEN
49048 GOTO 270
49049 ENDIF
49050 PT=SQRT(MAX(0D0,PTS))
49051
49052C...Find coefficient of azimuthal asymmetry due to gluon polarization.
49053 HAZIP=0D0
49054 IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21
49055 & .AND.IAU.NE.0) THEN
49056 IF(K(IGM,3).NE.0) MAZIP=1
49057 ZAU=V(IGM,1)
49058 IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1)
49059 IF(MAZIP.EQ.0) ZAU=0D0
49060 IF(K(IGM,2).NE.21) THEN
49061 HAZIP=2D0*ZAU/(1D0+ZAU**2)
49062 ELSE
49063 HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2
49064 ENDIF
49065 IF(K(N+1,2).NE.21) THEN
49066 HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM))
49067 ELSE
49068 HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2
49069 ENDIF
49070 ENDIF
49071
49072C...Find coefficient of azimuthal asymmetry due to soft gluon
49073C...interference.
49074 HAZIC=0D0
49075 IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
49076 & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
49077 IF(K(IGM,3).NE.0) MAZIC=N+1
49078 IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
49079 IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
49080 & ZM.GT.0.5D0) MAZIC=N+2
49081 IF(K(IAU,2).EQ.22) MAZIC=0
49082 ZS=ZM
49083 IF(MAZIC.EQ.N+2) ZS=1D0-ZM
49084 ZGM=V(IGM,1)
49085 IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1)
49086 IF(MAZIC.EQ.0) ZGM=1D0
49087 IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))*
49088 & SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM))
49089 HAZIC=MIN(0.95D0,HAZIC)
49090 ENDIF
49091 ENDIF
49092
49093C...Construct energies for ordinary branching in shower.
49094 550 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
49095 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
49096 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
49097 P(N+1,4)=0.5D0*(PEM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
49098 & PZM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
49099 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
49100 P(N+1,4)=PEM*V(IM,1)
49101 ELSE
49102 P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
49103 & SQRT(PMLS)*ZM)/V(IM,5)
49104 ENDIF
49105
49106C...Already predetermined choice of phi angle or not
49107 PHI=PARU(2)*PYR(0)
49108 IF(MPSPD.EQ.1.AND.IGM.EQ.NS+1) THEN
49109 IPSPD=IP1+IM-NS-2
49110 IF(K(IPSPD,4).GT.0) THEN
49111 IPSGD1=K(IPSPD,4)
49112 IF(IM.EQ.NS+2) THEN
49113 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
49114 ELSE
49115 PHI=PYANGL(-P(IPSGD1,1),P(IPSGD1,2))
49116 ENDIF
49117 ENDIF
49118 ELSEIF(MPSPD.EQ.1.AND.IGM.EQ.NS+2) THEN
49119 IPSPD=IP1+IM-NS-2
49120 IF(K(IPSPD,4).GT.0) THEN
49121 IPSGD1=K(IPSPD,4)
49122 PHIPSM=PYANGL(P(IPSPD,1),P(IPSPD,2))
49123 THEPSM=PYANGL(P(IPSPD,3),SQRT(P(IPSPD,1)**2+P(IPSPD,2)**2))
49124 CALL PYROBO(IPSGD1,IPSGD1,0D0,-PHIPSM,0D0,0D0,0D0)
49125 CALL PYROBO(IPSGD1,IPSGD1,-THEPSM,0D0,0D0,0D0,0D0)
49126 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
49127 CALL PYROBO(IPSGD1,IPSGD1,THEPSM,PHIPSM,0D0,0D0,0D0)
49128 ENDIF
49129 ENDIF
49130
49131C...Construct momenta for ordinary branching in shower.
49132 P(N+1,1)=PT*COS(PHI)
49133 P(N+1,2)=PT*SIN(PHI)
49134 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
49135 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
49136 P(N+1,3)=0.5D0*(PZM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
49137 & PEM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
49138 ELSEIF(PZM.GT.0D0) THEN
49139 P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+
49140 & 2D0*PEM*P(N+1,4))/PZM
49141 ELSE
49142 P(N+1,3)=0D0
49143 ENDIF
49144 P(N+2,1)=-P(N+1,1)
49145 P(N+2,2)=-P(N+1,2)
49146 P(N+2,3)=PZM-P(N+1,3)
49147 P(N+2,4)=PEM-P(N+1,4)
49148 IF(MSTJ(43).LE.2) THEN
49149 V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
49150 V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
49151 ENDIF
49152 ENDIF
49153
49154C...Rotate and boost daughters.
49155 IF(IGM.GT.0) THEN
49156 IF(MSTJ(43).LE.2) THEN
49157 BEX=P(IGM,1)/P(IGM,4)
49158 BEY=P(IGM,2)/P(IGM,4)
49159 BEZ=P(IGM,3)/P(IGM,4)
49160 GA=P(IGM,4)/P(IGM,5)
49161 GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)-
49162 & P(IM,4))
49163 ELSE
49164 BEX=0D0
49165 BEY=0D0
49166 BEZ=0D0
49167 GA=1D0
49168 GABEP=0D0
49169 ENDIF
49170 PTIMB=SQRT((P(IM,1)+GABEP*BEX)**2+(P(IM,2)+GABEP*BEY)**2)
49171 THE=PYANGL(P(IM,3)+GABEP*BEZ,PTIMB)
49172 IF(PTIMB.GT.1D-4) THEN
49173 PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
49174 ELSE
49175 PHI=0D0
49176 ENDIF
49177 DO 560 I=N+1,N+2
49178 DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
49179 & SIN(THE)*COS(PHI)*P(I,3)
49180 DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
49181 & SIN(THE)*SIN(PHI)*P(I,3)
49182 DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
49183 DP(4)=P(I,4)
49184 DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
49185 DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
49186 P(I,1)=DP(1)+DGABP*BEX
49187 P(I,2)=DP(2)+DGABP*BEY
49188 P(I,3)=DP(3)+DGABP*BEZ
49189 P(I,4)=GA*(DP(4)+DBP)
49190 560 CONTINUE
49191 ENDIF
49192
49193C...Weight with azimuthal distribution, if required.
49194 IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
49195 DO 570 J=1,3
49196 DPT(1,J)=P(IM,J)
49197 DPT(2,J)=P(IAU,J)
49198 DPT(3,J)=P(N+1,J)
49199 570 CONTINUE
49200 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
49201 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
49202 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
49203 DO 580 J=1,3
49204 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
49205 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
49206 580 CONTINUE
49207 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
49208 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
49209 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
49210 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
49211 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
49212 IF(MAZIP.NE.0) THEN
49213 IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP)))
49214 & GOTO 550
49215 ENDIF
49216 IF(MAZIC.NE.0) THEN
49217 IF(MAZIC.EQ.N+2) CAD=-CAD
49218 IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD)
49219 & .LT.PYR(0)) GOTO 550
49220 ENDIF
49221 ENDIF
49222 ENDIF
49223
49224C...Azimuthal anisotropy due to interference with initial state partons.
49225 IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR.
49226 &K(N+2,2).EQ.21)) THEN
49227 III=IM-NS-1
49228 IF(ISII(III).GE.1) THEN
49229 IAZIID=N+1
49230 IF(K(N+1,2).NE.21) IAZIID=N+2
49231 IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
49232 & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2
49233 THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2))
49234 IF(III.EQ.2) THEIID=PARU(1)-THEIID
49235 PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2))
49236 HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III)))
49237 CAD=COS(PHIIID-PHIIIS(III,ISII(III)))
49238 PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III)))
49239 IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL
49240 IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD)
49241 & .LT.PYR(0)) GOTO 550
49242 ENDIF
49243 ENDIF
49244
49245C...Continue loop over partons that may branch, until none left.
49246 IF(IGM.GE.0) K(IM,1)=14
49247 N=N+NEP
49248 NEP=2
49249 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
49250 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
49251 IF(MSTU(21).GE.1) N=NS
49252 IF(MSTU(21).GE.1) RETURN
49253 ENDIF
49254 GOTO 280
49255
49256C...Set information on imagined shower initiator.
49257 590 IF(NPA.GE.2) THEN
49258 K(NS+1,1)=11
49259 K(NS+1,2)=94
49260 K(NS+1,3)=IP1
49261 IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
49262 K(NS+1,4)=NS+2
49263 K(NS+1,5)=NS+1+NPA
49264 IIM=1
49265 ELSE
49266 IIM=0
49267 ENDIF
49268
49269C...Reconstruct string drawing information.
49270 DO 600 I=NS+1+IIM,N
49271 KQ=KCHG(PYCOMP(K(I,2)),2)
49272 IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
49273 K(I,1)=1
49274 ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
49275 & IABS(K(I,2)).LE.18) THEN
49276 K(I,1)=1
49277 ELSEIF(K(I,1).LE.10) THEN
49278 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
49279 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
49280 ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
49281 ID1=MOD(K(I,4),MSTU(5))
49282 IF(KQ.EQ.1.AND.K(I,2).GT.0) ID1=MOD(K(I,4),MSTU(5))+1
49283 IF(KQ.EQ.2.AND.(K(ID1,2).EQ.21.OR.K(ID1+1,2).EQ.21).AND.
49284 & PYR(0).GT.0.5D0) ID1=MOD(K(I,4),MSTU(5))+1
49285 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
49286 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
49287 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
49288 K(ID1,4)=K(ID1,4)+MSTU(5)*I
49289 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
49290 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
49291 K(ID2,5)=K(ID2,5)+MSTU(5)*I
49292 ELSE
49293 ID1=MOD(K(I,4),MSTU(5))
49294 ID2=ID1+1
49295 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
49296 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
49297 IF(KQ.EQ.1.OR.K(ID1,1).GE.11) THEN
49298 K(ID1,4)=K(ID1,4)+MSTU(5)*I
49299 K(ID1,5)=K(ID1,5)+MSTU(5)*I
49300 ELSE
49301 K(ID1,4)=0
49302 K(ID1,5)=0
49303 ENDIF
49304 K(ID2,4)=0
49305 K(ID2,5)=0
49306 ENDIF
49307 600 CONTINUE
49308
49309C...Transformation from CM frame.
49310 IF(NPA.EQ.1) THEN
49311 THE=PYANGL(P(IPA(1),3),SQRT(P(IPA(1),1)**2+P(IPA(1),2)**2))
49312 PHI=PYANGL(P(IPA(1),1),P(IPA(1),2))
49313 MSTU(33)=1
49314 CALL PYROBO(NS+1,N,THE,PHI,0D0,0D0,0D0)
49315 ELSEIF(NPA.EQ.2) THEN
49316 BEX=PS(1)/PS(4)
49317 BEY=PS(2)/PS(4)
49318 BEZ=PS(3)/PS(4)
49319 GA=PS(4)/PS(5)
49320 GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
49321 & /(1D0+GA)-P(IPA(1),4))
49322 THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
49323 & +GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
49324 PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
49325 MSTU(33)=1
49326 CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ)
49327 ELSE
49328 CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),
49329 & PS(3)/PS(4))
49330 MSTU(33)=1
49331 CALL PYROBO(NS+1,N,0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),PS(3)/PS(4))
49332 ENDIF
49333
49334C...Decay vertex of shower.
49335 DO 620 I=NS+1,N
49336 DO 610 J=1,5
49337 V(I,J)=V(IP1,J)
49338 610 CONTINUE
49339 620 CONTINUE
49340
49341C...Delete trivial shower, else connect initiators.
49342 IF(N.LE.NS+NPA+IIM) THEN
49343 N=NS
49344 ELSE
49345 DO 630 IP=1,NPA
49346 K(IPA(IP),1)=14
49347 K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
49348 K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
49349 K(NS+IIM+IP,3)=IPA(IP)
49350 IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
49351 IF(K(NS+IIM+IP,1).NE.1) THEN
49352 K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
49353 K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
49354 ENDIF
49355 630 CONTINUE
49356 ENDIF
49357
49358 RETURN
49359 END
49360
49361C*********************************************************************
49362
49363C...PYMAEL
49364C...Auxiliary to PYSHOW.
49365C...Matrix elements for gluon (or photon) emission from
49366C...a two-body state; to be used by the parton shower routine.
49367C...Here X_i = 2 E_i/E_cm, R_i = m_i/E_cm and
49368C...1/sigma_0 d(sigma)/d(x_1)d(x_2) =
49369C... = (alpha-strong/2 pi) * CF * PYMAEL,
49370C...i.e. normalization is such that one recovers the familiar
49371C...(X1**2+X2**2)/((1-X1)*(1-X2)) for the massless case.
49372C...Coupling structure:
49373C...NI = 6- 9 : eikonal soft-gluon expression (spin-independent)
49374C... = 11-14 : V -> q qbar (V = vector/axial vector colour singlet)
49375C... = 16-19 : q -> q V
49376C... = 21-24 : S -> q qbar (S = scalar/pseudoscalar colour singlet)
49377C... = 26-29 : q -> q S
49378C... = 31-34 : V -> ~q ~qbar (~q = squark)
49379C... = 36-39 : ~q -> ~q V
49380C... = 41-44 : S -> ~q ~qbar
49381C... = 46-49 : ~q -> ~q S
49382C... = 51-54 : chi -> q ~qbar (chi = neutralino/chargino)
49383C... = 56-59 : ~q -> q chi
49384C... = 61-64 : q -> ~q chi
49385C... = 66-69 : ~g -> q ~qbar
49386C... = 71-74 : ~q -> q ~g
49387C... = 76-79 : q -> ~q ~g
49388C... = 81-84 : (9/4)*(eikonal) for gg -> ~g ~g
49389C...Note that the order of the decay products is important.
49390C...In each set of four, the variants are ordered as:
49391C...ICOMBI = 1 : pure non-gamma5, i.e. vector/scalar/...
49392C... = 2 : pure gamma5, i.e. axial vector/pseudoscalar/....
49393C... = 3 : mixture alpha*(ICOMBI=1) + (1-alpha)*(ICOMBI=2)
49394C... = 4 : mixture (ICOMBI=1) +- (ICOMBI=2)
49395
49396 FUNCTION PYMAEL(NI,X1,X2,R1,R2,ALPHA)
49397
49398C...Double precision and integer declarations.
49399 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49400 IMPLICIT INTEGER(I-N)
49401
49402C...Check input values. Return zero outside allowed phase space.
49403 PYMAEL=0D0
49404 IF(X1.LE.2D0*R1.OR.X1.GE.1D0+R1**2-R2**2) RETURN
49405 IF(X2.LE.2D0*R2.OR.X2.GE.1D0+R2**2-R1**2) RETURN
49406 IF(X1+X2.LE.1D0+(R1+R2)**2) RETURN
49407 IF((2D0-2D0*X1-2D0*X2+X1*X2+2D0*R1**2+2D0*R2**2)**2.GE.
49408 &(X1**2-4D0*R1**2)*(X2**2-4D0*R2**2)) RETURN
49409 ALPCOR=MAX(0D0,MIN(1D0,ALPHA))
49410
49411C...Initial values and flags.
49412 ICLASS=NI/5
49413 ICOMBI=NI-5*ICLASS
49414 ISSET1=0
49415 ISSET2=0
49416 ISSET4=0
49417
49418C... Phase space.
49419 PS=SQRT((1D0-(R1+R2)**2)*(1D0-(R1-R2)**2))
49420
49421C...Eikonal expression; also acts as default.
49422 IF(ICLASS.LE.1.OR.ICLASS.GE.17.OR.ICOMBI.EQ.0) THEN
49423 RLO=PS
49424 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
49425 ANUM=0D0
49426 ELSEIF(ICOMBI.EQ.2) THEN
49427 ANUM=(2D0-X1-X2)**2
49428 ELSEIF(ICOMBI.EQ.3) THEN
49429 ANUM=ALPCOR*(2D0-X1-X2)**2
49430 ELSE
49431 ANUM=0.5D0*(2D0-X1-X2)**2
49432 ENDIF
49433 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
49434 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
49435 & R1**2/(1D0+R2**2-R1**2-X2)**2-
49436 & R2**2/(1D0+R1**2-R2**2-X1)**2)
49437 ICOMBI=0
49438
49439C...V -> q qbar (V = gamma*/Z0/W+-/...).
49440 ELSEIF(ICLASS.EQ.2) THEN
49441 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
49442 RLO1=PS*(2-R1**2-R1**4+6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
49443 RFO1=-1.D0*(3+6*R1**2+R1**4-6*R1*R2+6*R1**3*R2-2*R2**2
49444 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-3*X1+6*R1*R2*X1
49445 & +2*R2**2*X1+X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)
49446 & +6*R1*R2*(2-X1-X2)-R2**2*(2-X1-X2)-2*X1*(2-X1-X2)
49447 & -5*R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
49448 & -3*(2-X1-X2)**2-3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2
49449 & +2*X1*(2-X1-X2)**2+(2-X1-X2)**3-X2)/
49450 & (-1+R1**2-R2**2+X2)**2
49451 RFO1=RFO1-2*(-3+R1**2-6*R1*R2+6*R1**3*R2+3*R2**2-4*R1**2*R2**2
49452 & +6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
49453 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)+3*R1*R2*(2-X1
49454 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
49455 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2+R1*R2*(2
49456 & -X1-X2)**2+X1*(2-X1-X2)**2)/
49457 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
49458 RFO1=RFO1-1.D0*(-1+2*R1**2+R1**4+6*R1*R2+6*R1**3*R2-2*R2**2
49459 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-X1-2*R1**2*X1-6*R1*R2*X1
49460 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2
49461 & -X1-X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*
49462 & (2-X1-X2)+X2)/(-1-R1**2+R2**2+X1)**2
49463 RFO1=RFO1/2.D0
49464 ISSET1=1
49465 ENDIF
49466 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
49467 RLO2=PS*(2-R1**2-R1**4-6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
49468 RFO2=-1*(3+6*R1**2+R1**4+6*R1*R2-6*R1**3*R2-2*R2**2
49469 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-3*X1-6*R1*R2*X1+2*R2**2*X1
49470 & +X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)-6*R1*R2*(2-X1-X2)
49471 & -R2**2*(2-X1-X2)-2*X1*(2-X1-X2)-5*R1**2*X1*(2-X1-X2)
49472 & +R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)-3*(2-X1-X2)**2
49473 & -3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2+2*X1*(2-X1-X2)**2
49474 & +(2-X1-X2)**3-X2)/(-1+R1**2-R2**2+X2)**2
49475 RFO2=RFO2-2*(-3+R1**2+6*R1*R2-6*R1**3*R2+3*R2**2-4*R1**2*R2**2
49476 & -6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
49477 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)-3*R1*R2*(2-X1
49478 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
49479 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2-R1*R2*(2
49480 & -X1-X2)**2+X1*(2-X1-X2)**2)/
49481 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
49482 RFO2=RFO2-1*(-1+2*R1**2+R1**4-6*R1*R2-6*R1**3*R2-2*R2**2
49483 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-X1-2*R1**2*X1+6*R1*R2*X1
49484 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2-X1
49485 & -X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
49486 & +X2)/(-1-R1**2+R2**2+X1)**2
49487 RFO2=RFO2/2.D0
49488 ISSET2=1
49489 ENDIF
49490 IF(ICOMBI.EQ.4) THEN
49491 RLO4=PS*(2D0-R1**2-R1**4-R2**2+2D0*R1**2*R2**2-R2**4)/2D0
49492 RFO4=(1-R1**4+6*R1**2*R2**2-R2**4+X1+3*R1**2*X1-9*R2**2*X1
49493 & -3*X1**2-R1**2*X1**2+3*R2**2*X1**2+X1**3-X2-R1**2*X2
49494 & +R2**2*X2-R1**2*X1*X2+R2**2*X1*X2+X1**2*X2)/
49495 & (-1-R1**2+R2**2+X1)**2
49496 RFO4=RFO4
49497 & -2*(1+R1**2+R2**2-4*R1**2*R2**2+R1**2*X1+2*R2**2*X1-X1**2
49498 & -R2**2*X1**2+2*R1**2*X2+R2**2*X2-3*X1*X2+X1**2*X2-X2**2
49499 & -R1**2*X2**2+X1*X2**2)/
49500 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
49501 RFO4=RFO4+(1-R1**4+6*R1**2*R2**2-R2**4-X1+R1**2*X1-R2**2*X1+X2
49502 & -9*R1**2*X2+3*R2**2*X2+R1**2*X1*X2-R2**2*X1*X2-3*X2**2
49503 & +3*R1**2*X2**2-R2**2*X2**2+X1*X2**2+X2**3)/
49504 & (-1+R1**2-R2**2+X2)**2
49505 RFO4=RFO4/2.D0
49506 ISSET4=1
49507 ENDIF
49508
49509C...q -> q V.
49510 ELSEIF(ICLASS.EQ.3) THEN
49511 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
49512 RLO1=PS*(1D0-2D0*R1**2+R1**4+R2**2-6D0*R1*R2**2
49513 & +R1**2*R2**2-2D0*R2**4)
49514 RFO1=2*(-1+R1-2*R1**2+2*R1**3-R1**4+R1**5-R2**2+R1*R2**2
49515 & -5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4+2*X1-2*R1*X1
49516 & +2*R1**2*X1-2*R1**3*X1+2*R2**2*X1+5*R1*R2**2*X1
49517 & +R1**2*R2**2*X1+2*R2**4*X1-X1**2+R1*X1**2-R2**2*X1**2+3*X2
49518 & +4*R1**2*X2+R1**4*X2+2*R2**2*X2+2*R1**2*R2**2*X2-4*X1*X2
49519 & -2*R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-2*X2**2
49520 & -2*R1**2*X2**2+X1*X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
49521 RFO1=RFO1+(2*R2**2+6*R1*R2**2-6*R1**2*R2**2+6*R1**3*R2**2
49522 & +2*R2**4+6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
49523 & -R1**4*X2-3*R2**2*X2-6*R1*R2**2*X2+9*R1**2*R2**2*X2
49524 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
49525 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
49526 RFO1=RFO1+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4
49527 & +9*X1+10*R1**2*X1+R1**4*X1-3*R2**2*X1+6*R1*R2**2*X1
49528 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
49529 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2+6*R1*R2**2*X2
49530 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
49531 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2
49532 & +2*R2**2*X2**2+X1*X2**2)/(-2+X1+X2)**2
49533 ISSET1=1
49534 ENDIF
49535 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
49536 RLO2=PS*(1D0-2D0*R1**2+R1**4+R2**2+6D0*R1*R2**2
49537 & +R1**2*R2**2-2D0*R2**4)
49538 RFO2=2*(1+R1+2*R1**2+2*R1**3+R1**4+R1**5+R2**2+R1*R2**2
49539 & +5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4-2*X1-2*R1*X1
49540 & -2*R1**2*X1-2*R1**3*X1-2*R2**2*X1+5*R1*R2**2*X1
49541 & -R1**2*R2**2*X1-2*R2**4*X1+X1**2+R1*X1**2+R2**2*X1**2-3*X2
49542 & -4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2+4*X1*X2
49543 & +2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2+2*R1**2*X2**2
49544 & -X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
49545 RFO2=RFO2+(2*R2**2-6*R1*R2**2-6*R1**2*R2**2-6*R1**3*R2**2
49546 & +2*R2**4-6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
49547 & -R1**4*X2-3*R2**2*X2+6*R1*R2**2*X2+9*R1**2*R2**2*X2
49548 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
49549 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
49550 RFO2=RFO2+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
49551 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1-6*R1*R2**2*X1
49552 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
49553 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2-6*R1*R2**2*X2
49554 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
49555 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
49556 & +X1*X2**2)/(-2+X1+X2)**2
49557 ISSET2=1
49558 ENDIF
49559 IF(ICOMBI.EQ.4) THEN
49560 RLO4=PS*(1.D0-2.D0*R1**2+R1**4+R2**2+R1**2*R2**2-2.D0*R2**4)
49561 RFO4=2*(1+2*R1**2+R1**4+R2**2+5*R1**2*R2**2-2*X1-2*R1**2*X1
49562 & -2*R2**2*X1-R1**2*R2**2*X1-2*R2**4*X1+X1**2+R2**2*X1**2
49563 & -3*X2-4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2
49564 & +4*X1*X2+2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2
49565 & +2*R1**2*X2**2-X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
49566 RFO4=RFO4+(2*R2**2-6*R1**2*R2**2+2*R2**4-R2**2*X1+R1**2*R2**2*X1
49567 & -R2**4*X1+X2-R1**4*X2-3*R2**2*X2+9*R1**2*R2**2*X2
49568 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
49569 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
49570 RFO4=RFO4+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
49571 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1+R1**2*R2**2*X1-2*R2**4*X1
49572 & -6*X1**2-2*R1**2*X1**2+X1**3+7*X2+8*R1**2*X2+R1**4*X2
49573 & -7*R2**2*X2+R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
49574 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
49575 & +X1*X2**2)/(2-X1-X2)**2
49576 ISSET4=1
49577 ENDIF
49578
49579C...S -> q qbar (S = h0/H0/A0/H+-/...).
49580 ELSEIF(ICLASS.EQ.4) THEN
49581 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
49582 RLO1=PS*(1D0-R1**2-R2**2-2D0*R1*R2)
49583 RFO1=-(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
49584 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
49585 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
49586 & -2*(R1**2+R1**4-2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3
49587 & +R2**4-R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2
49588 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
49589 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
49590 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
49591 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
49592 ISSET1=1
49593 ENDIF
49594 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
49595 RLO2=PS*(1D0-R1**2-R2**2+2D0*R1*R2)
49596 RFO2=-(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
49597 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
49598 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
49599 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
49600 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
49601 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
49602 & +2*(-R1**2-R1**4-2*R1**3*R2-R2**2+6*R1**2*R2**2
49603 & -2*R1*R2**3-R2**4+R1**2*X1+R1*R2*X1-2*R2**2*X1
49604 & -2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
49605 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
49606 ISSET2=1
49607 ENDIF
49608 IF(ICOMBI.EQ.4) THEN
49609 RLO4=PS*(1D0-R1**2-R2**2)
49610 RFO4=-(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
49611 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
49612 & -2*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
49613 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
49614 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
49615 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1
49616 & +X2+3*R1**2*X2-R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
49617 ISSET4=1
49618 ENDIF
49619
49620C...q -> q S.
49621 ELSEIF(ICLASS.EQ.5) THEN
49622 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
49623 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
49624 RFO1=(4-4*R1**2+4*R2**2-3*X1-2*R1*X1+R1**2*X1-R2**2*X1-5*X2
49625 & -2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
49626 & +2*(3-R1-5*R1**2-R1**3+3*R2**2+R1*R2**2-2*X1-R1*X1
49627 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
49628 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
49629 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
49630 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
49631 & (-1+R1**2-R2**2+X2)**2
49632 ISSET1=1
49633 ENDIF
49634 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
49635 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
49636 RFO2=(4-4*R1**2+4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2
49637 & +2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
49638 & +2*(3+R1-5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1
49639 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
49640 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
49641 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
49642 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
49643 & (-1+R1**2-R2**2+X2)**2
49644 ISSET2=1
49645 ENDIF
49646 IF(ICOMBI.EQ.4) THEN
49647 RLO4=PS*(1D0+R1**2-R2**2)
49648 RFO4=(4-4*R1**2+4*R2**2-3*X1+R1**2*X1-R2**2*X1-5*X2+R1**2*X2
49649 & -R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
49650 & +2*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2+2*R1**2*X2
49651 & -R2**2*X2+X1*X2+X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
49652 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
49653 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
49654 ISSET4=1
49655 ENDIF
49656
49657C...V -> ~q ~qbar (~q = squark).
49658 ELSEIF(ICLASS.EQ.6) THEN
49659 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
49660 RFO1=2D0*3D0+(1+R1**2+R2**2-X1)*(4*R1**2-X1**2)/
49661 & (-1-R1**2+R2**2+X1)**2
49662 & -2D0*(-1-3*R1**2-R2**2+X1+X1**2/2+X2-X1*X2/2)/
49663 & (-1-R1**2+R2**2+X1)
49664 & +(1+R1**2+R2**2-X2)*(4*R2**2-X2**2)
49665 & /(-1+R1**2-R2**2+X2)**2
49666 & -2D0*(-1-R1**2-3*R2**2+X1+X2-X1*X2/2+X2**2/2)/
49667 & (-1+R1**2-R2**2+X2)
49668 & -(-4*R1**2-4*R1**4-4*R2**2-8*R1**2*R2**2-4*R2**4+2*X1
49669 & +6*R1**2*X1+6*R2**2*X1-2*X1**2+2*X2+6*R1**2*X2+6*R2**2*X2
49670 & -4*X1*X2-2*R1**2*X1*X2-2*R2**2*X1*X2+X1**2*X2-2*X2**2
49671 & +X1*X2**2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
49672 ISSET1=1
49673
49674C...~q -> ~q V.
49675 ELSEIF(ICLASS.EQ.7) THEN
49676 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
49677 RFO1=16*R2**2+8*(4*R2**2+2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2
49678 & -2*X2**2)/(3*(-1+R1**2-R2**2+X2))+8*(1+R1**2+R2**2-X2)*
49679 & (4*R2**2-X2**2)/(3*(-1+R1**2-R2**2+X2)**2)+8*(X1+X2)*
49680 & (-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
49681 & +2*R1**2*X1+2*R2**2*X1-X1**2+2*X2+2*R1**2*X2+2*R2**2*X2
49682 & -2*X1*X2-X2**2)/(3*(-2+X1+X2)**2)+8*(-1-R1**2+R2**2-X1)*
49683 & (2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2-X2**2)/
49684 & (3*(-1+R1**2-R2**2+X2)*(-2+X1+X2))+8*(1+2*R1**2+R1**4
49685 & +2*R2**2-2*R1**2*R2**2+R2**4-2*X1-2*R1**2*X1-4*R2**2*X1
49686 & +X1**2-3*X2-3*R1**2*X2-3*R2**2*X2+3*X1*X2+2*X2**2)/
49687 & (3*(-2+X1+X2))
49688 RFO1=3D0*RFO1/8D0
49689 ISSET1=1
49690
49691C...S -> ~q ~qbar.
49692 ELSEIF(ICLASS.EQ.8) THEN
49693 RLO1=PS
49694 RFO1=(-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
49695 & +2*R1**2*X1+2*R2**2*X1-X1**2-R2**2*X1**2+2*X2+2*R1**2*X2
49696 & +2*R2**2*X2-3*X1*X2-R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-X2**2
49697 & -R1**2*X2**2+X1*X2**2)/
49698 & (1+R1**2-R2**2-X1)**2/(-1+R1**2-R2**2+X2)**2
49699 RFO1=2D0*RFO1
49700 ISSET1=1
49701
49702C...~q -> ~q S.
49703 ELSEIF(ICLASS.EQ.9) THEN
49704 RLO1=PS
49705 RFO1=(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
49706 & +(1+R1**2-R2**2+X1)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
49707 & -(X1+X2)/(-2+X1+X2)**2
49708 ISSET1=1
49709
49710C...chi -> q ~qbar (chi = neutralino/chargino).
49711 ELSEIF(ICLASS.EQ.10) THEN
49712 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
49713 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
49714 RFO1=(2*R1+X1)*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
49715 & +2*(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1
49716 & -R1**2*X1/2-R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
49717 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
49718 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
49719 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
49720 & (-1+R1**2-R2**2+X2)**2
49721 ISSET1=1
49722 ENDIF
49723 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
49724 RLO2=PS*(1D0-2D0*R1+R1**2-R2**2)
49725 RFO2=(2*R1-X1)*(1+R1**2+R2**2-X1)/(-1-R1**2+R2**2+X1)**2
49726 & +2*(-1-R1**2+2*R1**3-R2**2+2*R1*R2**2+3*X1/2-R1*X1
49727 & -R1**2*X1/2-R2**2*X1/2+X2-R1*X2+R1**2*X2-X1*X2/2)/
49728 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
49729 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
49730 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
49731 & (-1+R1**2-R2**2+X2)**2
49732 ISSET2=1
49733 ENDIF
49734 IF(ICOMBI.EQ.4) THEN
49735 RLO4=PS*(1+R1**2-R2**2)
49736 RFO4=X1*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
49737 & +2D0*(-1-R1**2-R2**2+3*X1/2-R1**2*X1/2-R2**2*X1/2
49738 & +X2+R1**2*X2-X1*X2/2)/
49739 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
49740 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
49741 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
49742 ISSET4=1
49743 ENDIF
49744
49745C...~q -> q chi.
49746 ELSEIF(ICLASS.EQ.11) THEN
49747 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
49748 RLO1=PS*(1D0-(R1+R2)**2)
49749 RFO1=(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
49750 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
49751 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
49752 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
49753 & +(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
49754 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
49755 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
49756 ISSET1=1
49757 ENDIF
49758 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
49759 RLO2=PS*(1D0-(R1-R2)**2)
49760 RFO2=(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/
49761 & (-2+X1+X2)**2
49762 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
49763 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
49764 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
49765 & +(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3+R2**4
49766 & +X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
49767 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
49768 ISSET2=1
49769 ENDIF
49770 IF(ICOMBI.EQ.4) THEN
49771 RLO4=PS*(1D0-R1**2-R2**2)
49772 RFO4=(1+R1**2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
49773 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2
49774 & +3*R1**2*X2-R2**2*X2-X1*X2)/
49775 & (-1+R1**2-R2**2+X2)**2
49776 & -(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
49777 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
49778 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
49779 ISSET4=1
49780 ENDIF
49781
49782C...q -> ~q chi.
49783 ELSEIF(ICLASS.EQ.12) THEN
49784 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
49785 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
49786 RFO1=(2*R2+X2)*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
49787 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1-2*R2*X1+R2**2*X1+X1**2
49788 & -3*X2-R1**2*X2-2*R2*X2+R2**2*X2+X1*X2)/
49789 & (-2+X1+X2)**2-2*(-1-R1**2+R2+R1**2*R2-R2**2-R2**3+X1
49790 & +R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
49791 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
49792 ISSET1=1
49793 END IF
49794 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
49795 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
49796 RFO2=(2*R2-X2)*(1+R1**2+R2**2-X2)/(-1+R1**2-R2**2+X2)**2
49797 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1+X1**2
49798 & -3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
49799 & (-2+X1+X2)**2-2*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
49800 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
49801 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
49802 ISSET2=1
49803 END IF
49804 IF(ICOMBI.EQ.4) THEN
49805 RLO4=PS*(1D0-R1**2+R2**2)
49806 RFO4=X2*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
49807 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2
49808 & -3*X2-R1**2*X2+R2**2*X2+X1*X2)/
49809 & (-2+X1+X2)**2-2*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2
49810 & +R1**2*X2-X1*X2/2-X2**2/2)/
49811 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
49812 ISSET4=1
49813 END IF
49814
49815C...~g -> q ~qbar.
49816 ELSEIF(ICLASS.EQ.13) THEN
49817 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
49818 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
49819 RFO1=4*(2*R1+X1)*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)
49820 & -(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1-R1**2*X1/2
49821 & -R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/(3*(-1-R1**2+R2**2
49822 & +X1)*(-1+R1**2-R2**2+X2))-3*(-1+R1-R1**2-R1**3-R2**2
49823 & +R1*R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
49824 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+3*(4-4*R1**2+4*R2**2-3*X1
49825 & -2*R1*X1+R1**2*X1-R2**2*X1-5*X2-2*R1*X2+R1**2*X2-R2**2*X2
49826 & +X1*X2+X2**2)/(-2+X1+X2)**2+3*(3-R1-5*R1**2-R1**3+3*R2**2
49827 & +R1*R2**2-2*X1-R1*X1+R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2
49828 & +X1*X2+X2**2)/((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2-2*R1
49829 & -6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1-R2**2*X1
49830 & -3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
49831 & (3*(-1+R1**2-R2**2+X2)**2)
49832 RFO1=3D0*RFO1/4D0
49833 ISSET1=1
49834 ENDIF
49835 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
49836 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
49837 RFO2=4*(2*R1-X1)*(1+R1**2+R2**2-X1)/(3*(-1-R1**2+R2**2+X1)**2)
49838 & -3*(-1-R1-R1**2+R1**3-R2**2-R1*R2**2+2*X1+R2**2*X1-X1**2/2
49839 & +X2-R1*X2+R1**2*X2-X1*X2/2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
49840 & +(2+2*R1**2-4*R1**3+2*R2**2-4*R1*R2**2-3*X1+2*R1*X1
49841 & +R1**2*X1+R2**2*X1-2*X2+2*R1*X2-2*R1**2*X2+X1*X2)/
49842 & (6*(-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+3*(4-4*R1**2
49843 & +4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2+2*R1*X2
49844 & +R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2+3*(3+R1
49845 & -5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1+R1**2*X1-4*X2
49846 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
49847 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2+2*R1-6*R1**2+2*R1**3
49848 & +2*R2**2+2*R1*R2**2-X1+R1**2*X1-R2**2*X1-3*X2-2*R1*X2
49849 & +3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
49850 & (3*(-1+R1**2-R2**2+X2)**2)
49851 RFO2=3D0*RFO2/4D0
49852 ISSET2=1
49853 ENDIF
49854 IF(ICOMBI.EQ.4) THEN
49855 RLO4=PS*(1D0+R1**2-R2**2)
49856 RFO4=8*X1*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)-6*(-1
49857 & -R1**2-R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1**2*X2-X1*X2/2)/
49858 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+(2+2*R1**2+2*R2**2-3*X1
49859 & +R1**2*X1+R2**2*X1-2*X2-2*R1**2*X2+X1*X2)/(3*(-1-R1**2
49860 & +R2**2+X1)*(-1+R1**2-R2**2+X2))+6*(4-4*R1**2+4*R2**2-3*X1
49861 & +R1**2*X1-R2**2*X1-5*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/
49862 & (-2+X1+X2)**2+6*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2
49863 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
49864 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+8*(2-6*R1**2+2*R2**2-X1
49865 & +R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
49866 & (3*(-1+R1**2-R2**2+X2)**2)
49867 RFO4=3D0*RFO4/8D0
49868 ISSET4=1
49869 ENDIF
49870
49871C...~q -> q ~g.
49872 ELSEIF(ICLASS.EQ.14) THEN
49873 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
49874 RLO1=PS*(1-R1**2-R2**2-2D0*R1*R2)
49875 RFO1=64*(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
49876 & -16*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
49877 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
49878 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-16*(R1**2+R1**4
49879 & -2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3+R2**4
49880 & -R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2-R2**2*X2
49881 & -X1*X2)/((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
49882 & -64*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
49883 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
49884 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
49885 & +8*(-1+R1**4-2*R1*R2+2*R1**3*R2-2*R2**2-2*R1*R2**3-R2**4
49886 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2-2*R1*R2*X2
49887 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
49888 RFO1=RFO1
49889 & +8*(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
49890 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
49891 & +X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
49892 RFO1=9D0*RFO1/64D0
49893 ISSET1=1
49894 ENDIF
49895 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
49896 RLO2=PS*(1-R1**2-R2**2+2D0*R1*R2)
49897 RFO2=64*(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
49898 & -16*(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
49899 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
49900 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-64*(-1+R1**4
49901 & +2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3+R2**4+X1
49902 & -R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2-R2**2*X2
49903 & -X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)+16*(-R1**2-R1**4
49904 & -2*R1**3*R2-R2**2+6*R1**2*R2**2-2*R1*R2**3-R2**4+R1**2*X1
49905 & +R1*R2*X1-2*R2**2*X1-2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
49906 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
49907 RFO2=RFO2
49908 & +8*(-1+R1**4+2*R1*R2-2*R1**3*R2-2*R2**2+2*R1*R2**3-R2**4
49909 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2+2*R1*R2*X2
49910 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
49911 & +8*(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3
49912 & +R2**4+X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2
49913 & -2*R2**2*X2+X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
49914 RFO2=9D0*RFO2/64D0
49915 ISSET2=1
49916 ENDIF
49917 IF(ICOMBI.EQ.4) THEN
49918 RLO4=PS*(1-R1**2-R2**2)
49919 RFO4=128*(1+R1**2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)-32*(-1
49920 & +R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
49921 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
49922 & -32*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
49923 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
49924 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))-128*(-1+R1**4
49925 & -6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2
49926 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
49927 & +16*(-1+R1**4-2*R2**2-R2**4-2*R1**2*X1+2*R2**2*X1+X1**2
49928 & +X2-3*R1**2*X2+R2**2*X2+X1*X2)/
49929 & ((-1-R1**2+R2**2+X1)*(-2+X1+ X2))
49930 RFO4=RFO4+16*(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
49931 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
49932 & (9*(1-R1**2+R2**2-X2)*(-2+X1+X2))
49933 RFO4=9D0*RFO4/128D0
49934 ISSET4=1
49935 ENDIF
49936
49937C...q -> ~q ~g.
49938 ELSEIF(ICLASS.EQ.15) THEN
49939 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
49940 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
49941 RFO1=32*(2*R2+X2)*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
49942 & +8*(-1-R1**2-2*R1**2*R2-R2**2-2*R2**3+X1+R2*X1+R2**2*X1
49943 & +3*X2/2-R1**2*X2/2+R2*X2-R2**2*X2/2-X1*X2/2)/
49944 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2-2*R2
49945 & -2*R1**2*R2-6*R2**2-2*R2**3-3*X1-R1**2*X1+2*R2*X1
49946 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
49947 & (-1-R1**2+R2**2+X1)**2+32*(4+4*R1**2-4*R2**2-5*X1
49948 & -R1**2*X1-2*R2*X1+R2**2*X1+X1**2-3*X2-R1**2*X2-2*R2*X2
49949 & +R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
49950 RFO1=RFO1+8*(3+3*R1**2-R2+R1**2*R2-5*R2**2-R2**3-4*X1-R1**2*X1
49951 & +2*R2**2*X1+X1**2-2*X2-R2*X2+R2**2*X2+X1*X2)/
49952 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+8*(-1-R1**2+R2+R1**2*R2
49953 & -R2**2-R2**3+X1+R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
49954 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
49955 RFO1=9D0*RFO1/32D0
49956 ISSET1=1
49957 END IF
49958 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
49959 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
49960 RFO2=32*(2*R2-X2)*(1+R1**2+R2**2-X2)/(9*(-1+R1**2-R2**2+X2)**2)
49961 & +8*(-1-R1**2+2*R1**2*R2-R2**2+2*R2**3+X1-R2*X1+R2**2*X1
49962 & +3*X2/2-R1**2*X2/2-R2*X2-R2**2*X2/2-X1*X2/2)/
49963 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2+2*R2
49964 & +2*R1**2*R2-6*R2**2+2*R2**3-3*X1-R1**2*X1-2*R2*X1
49965 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
49966 & (-1-R1**2+R2**2+X1)**2+8*(3+3*R1**2+R2-R1**2*R2-5*R2**2
49967 & +R2**3-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2*X2+R2**2*X2
49968 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
49969 RFO2=RFO2+32*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1
49970 & +X1**2-3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
49971 & (9*(-2+X1+X2)**2)+8*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
49972 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
49973 & (9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
49974 RFO2=9D0*RFO2/32D0
49975 ISSET2=1
49976 END IF
49977 IF(ICOMBI.EQ.4) THEN
49978 RLO4=PS*(1D0-R1**2+R2**2)
49979 RFO4=64*X2*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
49980 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+3*X2/2-R1**2*X2/2
49981 & -R2**2*X2/2-X1*X2/2)/
49982 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+16*(3+3*R1**2
49983 & -5*R2**2-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2**2*X2
49984 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
49985 & +64*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2-3*X2
49986 & -R1**2*X2+R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
49987 RFO4=RFO4+16*(2+2*R1**2-6*R2**2-3*X1-R1**2*X1+3*R2**2*X1+X1**2
49988 & -X2-R1**2*X2+R2**2*X2+X1*X2)/(-1-R1**2+R2**2+X1)**2
49989 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
49990 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
49991 RFO4=9D0*RFO4/64D0
49992 ISSET4=1
49993 END IF
49994
49995C...g -> ~g ~g. Use (9/4)*eikonal. May be changed in the future.
49996 ELSEIF(ICLASS.EQ.16) THEN
49997 RLO=PS
49998 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
49999 ANUM=0D0
50000 ELSEIF(ICOMBI.EQ.2) THEN
50001 ANUM=(2D0-X1-X2)**2
50002 ELSEIF(ICOMBI.EQ.3) THEN
50003 ANUM=ALPCOR*(2D0-X1-X2)**2
50004 ELSE
50005 ANUM=0.5D0*(2D0-X1-X2)**2
50006 ENDIF
50007 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
50008 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
50009 & R1**2/(1D0+R2**2-R1**2-X2)**2-
50010 & R2**2/(1D0+R1**2-R2**2-X1)**2)
50011 RFO=9D0*RFO/4D0
50012 ICOMBI=0
50013 ENDIF
50014
50015C...Find relevant LO and FO expression.
50016 IF(ICOMBI.EQ.0) THEN
50017 ELSEIF(ICOMBI.EQ.1.AND.ISSET1.EQ.1) THEN
50018 RLO=RLO1
50019 RFO=RFO1
50020 ELSEIF(ICOMBI.EQ.2.AND.ISSET2.EQ.1) THEN
50021 RLO=RLO2
50022 RFO=RFO2
50023 ELSEIF(ICOMBI.EQ.3.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
50024 RLO=ALPCOR*RLO1+(1D0-ALPCOR)*RLO2
50025 RFO=ALPCOR*RFO1+(1D0-ALPCOR)*RFO2
50026 ELSEIF(ISSET4.EQ.1) THEN
50027 RLO=RLO4
50028 RFO=RFO4
50029 ELSEIF(ICOMBI.EQ.4.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
50030 RLO=0.5D0*(RLO1+RLO2)
50031 RFO=0.5D0*(RFO1+RFO2)
50032 ELSEIF(ISSET1.EQ.1) THEN
50033 RLO=RLO1
50034 RFO=RFO1
50035 ELSE
50036 CALL PYERRM(16,'(PYMAEL:) not implemented ME code')
50037 RLO=1D0
50038 RFO=0D0
50039 ENDIF
50040
50041C...Output.
50042 PYMAEL=RFO/RLO
50043
50044 RETURN
50045 END
50046
50047C*********************************************************************
50048
50049C...PYBOEI
50050C...Modifies an event so as to approximately take into account
50051C...Bose-Einstein effects according to a simple phenomenological
50052C...parametrization.
50053
50054 SUBROUTINE PYBOEI(NSAV)
50055
50056C...Double precision and integer declarations.
50057 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50058 IMPLICIT INTEGER(I-N)
50059 INTEGER PYK,PYCHGE,PYCOMP
50060C...Parameter statement to help give large particle numbers.
50061 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50062 &KEXCIT=4000000,KDIMEN=5000000)
50063C...Commonblocks.
50064 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
50065 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50066 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50067 COMMON/PYINT1/MINT(400),VINT(400)
50068 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/
50069C...Local arrays and data.
50070 DIMENSION DPS(4),KFBE(9),NBE(0:10),BEI(100),BEI3(100),
50071 &BEIW(100),BEI3W(100)
50072 DATA KFBE/211,-211,111,321,-321,130,310,221,331/
50073C...Statement function: squared invariant mass.
50074 SDIP(I,J)=((P(I,4)+P(J,4))**2-(P(I,3)+P(J,3))**2-
50075 &(P(I,2)+P(J,2))**2-(P(I,1)+P(J,1))**2)
50076
50077C...Boost event to overall CM frame. Calculate CM energy.
50078 IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
50079 DO 100 J=1,4
50080 DPS(J)=0D0
50081 100 CONTINUE
50082 DO 120 I=1,N
50083 KFA=IABS(K(I,2))
50084 IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22)
50085 & .AND.K(I,3).GT.0) THEN
50086 KFMA=IABS(K(K(I,3),2))
50087 IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
50088 ENDIF
50089 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
50090 DO 110 J=1,4
50091 DPS(J)=DPS(J)+P(I,J)
50092 110 CONTINUE
50093 120 CONTINUE
50094 CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
50095 &-DPS(3)/DPS(4))
50096 PECM=0D0
50097 DO 130 I=1,N
50098 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
50099 130 CONTINUE
50100
50101C...Check if we have separated strings
50102
50103C...Reserve copy of particles by species at end of record.
50104 IWP=0
50105 IWN=0
50106 NBE(0)=N+MSTU(3)
50107 NMAX=NBE(0)
50108 SMMIN=PECM
50109 DO 190 IBE=1,MIN(10,MSTJ(52)+1)
50110 NBE(IBE)=NBE(IBE-1)
50111 DO 180 I=NSAV+1,N
50112 IF(IBE.EQ.MIN(10,MSTJ(52)+1)) THEN
50113 DO 140 IIBE=1,IBE-1
50114 IF(K(I,2).EQ.KFBE(IIBE)) GOTO 180
50115 140 CONTINUE
50116 ELSE
50117 IF(K(I,2).NE.KFBE(IBE)) GOTO 180
50118 ENDIF
50119 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 180
50120 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
50121 CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS')
50122 RETURN
50123 ENDIF
50124 NBE(IBE)=NBE(IBE)+1
50125 NMAX=NBE(IBE)
50126 K(NBE(IBE),1)=I
50127 K(NBE(IBE),2)=0
50128 K(NBE(IBE),3)=0
50129 K(NBE(IBE),4)=0
50130 K(NBE(IBE),5)=0
50131 P(NBE(IBE),1)=0.0D0
50132 P(NBE(IBE),2)=0.0D0
50133 P(NBE(IBE),3)=0.0D0
50134 P(NBE(IBE),4)=0.0D0
50135 P(NBE(IBE),5)=0.0D0
50136 SMMIN=MIN(SMMIN,P(I,5))
50137C...Check if particles comes from different W's or Z's
50138 IF((MSTJ(53).NE.0.OR.MSTJ(56).GT.0).AND.MINT(32).EQ.0) THEN
50139 IM=I
50140 150 IF(K(IM,3).GT.0) THEN
50141 IM=K(IM,3)
50142 IF(ABS(K(IM,2)).NE.24.AND.K(IM,2).NE.23) GOTO 150
50143 K(NBE(IBE),5)=IM
50144 IF(IWP.EQ.0.AND.K(IM,2).EQ.24) IWP=IM
50145 IF(IWN.EQ.0.AND.K(IM,2).EQ.-24) IWN=IM
50146 IF(IWP.EQ.0.AND.K(IM,2).EQ.23) IWP=IM
50147 IF(IWN.EQ.0.AND.K(IM,2).EQ.23.AND.IM.NE.IWP) IWN=IM
50148 ENDIF
50149 ENDIF
50150C...Check if particles comes from different strings.
50151 IF(PARJ(94).GT.0.0D0) THEN
50152 IM=I
50153 160 IF(K(IM,3).GT.0) THEN
50154 IM=K(IM,3)
50155 IF(K(IM,2).NE.92.AND.K(IM,2).NE.91) GOTO 160
50156 K(NBE(IBE),5)=IM
50157 ENDIF
50158 ENDIF
50159 DO 170 J=1,3
50160 P(NBE(IBE),J)=0D0
50161 V(NBE(IBE),J)=0D0
50162 170 CONTINUE
50163 P(NBE(IBE),5)=-1.0D0
50164 180 CONTINUE
50165 190 CONTINUE
50166 IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 510
50167
50168C...Calculate separation between W+ and W- or between two Z0's.
50169C...No separation if there has been re-connections.
50170 SIGW=PARJ(93)
50171 IF(IWP.GT.0.AND.IWN.GT.0.AND.MSTJ(56).GT.0.AND.MINT(32).EQ.0) THEN
50172 IF(K(IWP,2).EQ.23) THEN
50173 DMW=PMAS(23,1)
50174 DGW=PMAS(23,2)
50175 ELSE
50176 DMW=PMAS(24,1)
50177 DGW=PMAS(24,2)
50178 ENDIF
50179 DMP=P(IWP,5)
50180 DMN=P(IWN,5)
50181 TAUPD=DMP/SQRT((DMP**2-DMW**2)**2+(DGW*(DMP**2)/DMW)**2)
50182 TAUND=DMN/SQRT((DMN**2-DMW**2)**2+(DGW*(DMN**2)/DMW)**2)
50183 TAUP=-TAUPD*LOG(PYR(IDUM))
50184 TAUN=-TAUND*LOG(PYR(IDUM))
50185 DXP=TAUP*PYP(IWP,8)/DMP
50186 DXN=TAUN*PYP(IWN,8)/DMN
50187 DX=DXP+DXN
50188 SIGW=1.0D0/(1.0D0/PARJ(93)+REAL(MSTJ(56))*DX)
50189 IF(PARJ(94).LT.0.0D0) SIGW=1.0D0/(1.0D0/SIGW-1.0D0/PARJ(94))
50190 ENDIF
50191
50192C...Add separation between strings.
50193 IF(PARJ(94).GT.0.0D0) THEN
50194 SIGW=1.0D0/(1.0D0/SIGW+1.0D0/PARJ(94))
50195 IWP=-1
50196 IWN=-1
50197 ENDIF
50198
50199 IF(MSTJ(57).EQ.1.AND.MSTJ(54).LT.0) THEN
50200 DO 220 IBE=1,MIN(9,MSTJ(52))
50201 DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)
50202 Q2MIN=PECM**2
50203 I1=K(I1M,1)
50204 DO 200 I2M=NBE(IBE-1)+1,NBE(IBE)
50205 IF(I2M.EQ.I1M) GOTO 200
50206 I2=K(I2M,1)
50207 Q2=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-
50208 & (P(I1,2)+P(I2,2))**2-(P(I1,3)+P(I2,3))**2-
50209 & (P(I1,5)+P(I2,5))**2
50210 IF(Q2.GT.0.0D0.AND.Q2.LT.Q2MIN) THEN
50211 Q2MIN=Q2
50212 ENDIF
50213 200 CONTINUE
50214 P(I1M,5)=Q2MIN
50215 210 CONTINUE
50216 220 CONTINUE
50217 ENDIF
50218
50219C...Tabulate integral for subsequent momentum shift.
50220 DO 400 IBE=1,MIN(9,MSTJ(52))
50221 IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 270
50222 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
50223 & .LE.1) GOTO 270
50224 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
50225 & NBE(7)-NBE(6)).LE.1) GOTO 270
50226 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 270
50227 IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211)
50228 IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321)
50229 IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221)
50230 IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331)
50231 QDEL=0.1D0*MIN(PMHQ,PARJ(93))
50232 QDEL3=0.1D0*MIN(PMHQ,PARJ(93)*3.0D0)
50233 QDELW=0.1D0*MIN(PMHQ,SIGW)
50234 QDEL3W=0.1D0*MIN(PMHQ,SIGW*3.0D0)
50235 IF(MSTJ(51).EQ.1) THEN
50236 NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL))
50237 NBIN3=MIN(100,NINT(27D0*PARJ(93)/QDEL3))
50238 NBINW=MIN(100,NINT(9D0*SIGW/QDELW))
50239 NBIN3W=MIN(100,NINT(27D0*SIGW/QDEL3W))
50240 BEEX=EXP(0.5D0*QDEL/PARJ(93))
50241 BEEX3=EXP(0.5D0*QDEL3/(3.0D0*PARJ(93)))
50242 BEEXW=EXP(0.5D0*QDELW/SIGW)
50243 BEEX3W=EXP(0.5D0*QDEL3W/(3.0D0*SIGW))
50244 BERT=EXP(-QDEL/PARJ(93))
50245 BERT3=EXP(-QDEL3/(3.0D0*PARJ(93)))
50246 BERTW=EXP(-QDELW/SIGW)
50247 BERT3W=EXP(-QDEL3W/(3.0D0*SIGW))
50248 ELSE
50249 NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL))
50250 NBIN3=MIN(100,NINT(9D0*PARJ(93)/QDEL3))
50251 NBINW=MIN(100,NINT(3D0*SIGW/QDELW))
50252 NBIN3W=MIN(100,NINT(9D0*SIGW/QDEL3W))
50253 ENDIF
50254 DO 230 IBIN=1,NBIN
50255 QBIN=QDEL*(IBIN-0.5D0)
50256 BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2)
50257 IF(MSTJ(51).EQ.1) THEN
50258 BEEX=BEEX*BERT
50259 BEI(IBIN)=BEI(IBIN)*BEEX
50260 ELSE
50261 BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
50262 ENDIF
50263 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
50264 230 CONTINUE
50265 DO 240 IBIN=1,NBIN3
50266 QBIN=QDEL3*(IBIN-0.5D0)
50267 BEI3(IBIN)=QDEL3*(QBIN**2+QDEL3**2/12D0)/SQRT(QBIN**2+PMHQ**2)
50268 IF(MSTJ(51).EQ.1) THEN
50269 BEEX3=BEEX3*BERT3
50270 BEI3(IBIN)=BEI3(IBIN)*BEEX3
50271 ELSE
50272 BEI3(IBIN)=BEI3(IBIN)*EXP(-(QBIN/(3.0D0*PARJ(93)))**2)
50273 ENDIF
50274 IF(IBIN.GE.2) BEI3(IBIN)=BEI3(IBIN)+BEI3(IBIN-1)
50275 240 CONTINUE
50276 DO 250 IBIN=1,NBINW
50277 QBIN=QDELW*(IBIN-0.5D0)
50278 BEIW(IBIN)=QDELW*(QBIN**2+QDELW**2/12D0)/SQRT(QBIN**2+PMHQ**2)
50279 IF(MSTJ(51).EQ.1) THEN
50280 BEEXW=BEEXW*BERTW
50281 BEIW(IBIN)=BEIW(IBIN)*BEEXW
50282 ELSE
50283 BEIW(IBIN)=BEIW(IBIN)*EXP(-(QBIN/SIGW)**2)
50284 ENDIF
50285 IF(IBIN.GE.2) BEIW(IBIN)=BEIW(IBIN)+BEIW(IBIN-1)
50286 250 CONTINUE
50287 DO 260 IBIN=1,NBIN3W
50288 QBIN=QDEL3W*(IBIN-0.5D0)
50289 BEI3W(IBIN)=QDEL3W*(QBIN**2+QDEL3W**2/12D0)/
50290 & SQRT(QBIN**2+PMHQ**2)
50291 IF(MSTJ(51).EQ.1) THEN
50292 BEEX3W=BEEX3W*BERT3W
50293 BEI3W(IBIN)=BEI3W(IBIN)*BEEX3W
50294 ELSE
50295 BEI3W(IBIN)=BEI3W(IBIN)*EXP(-(QBIN/(3.0D0*SIGW))**2)
50296 ENDIF
50297 IF(IBIN.GE.2) BEI3W(IBIN)=BEI3W(IBIN)+BEI3W(IBIN-1)
50298 260 CONTINUE
50299
50300C...Loop through particle pairs and find old relative momentum.
50301 270 DO 390 I1M=NBE(IBE-1)+1,NBE(IBE)-1
50302 I1=K(I1M,1)
50303 DO 380 I2M=I1M+1,NBE(IBE)
50304 IF(MSTJ(53).EQ.1.AND.K(I1M,5).NE.K(I2M,5)) GOTO 380
50305 IF(MSTJ(53).EQ.2.AND.K(I1M,5).EQ.K(I2M,5)) GOTO 380
50306 I2=K(I2M,1)
50307 Q2OLD=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
50308 & P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2
50309 IF(Q2OLD.LE.0.0D0) GOTO 380
50310 QOLD=SQRT(Q2OLD)
50311
50312C...Calculate new relative momentum.
50313 QMOV=0.0D0
50314 QMOV3=0.0D0
50315 QMOVW=0.0D0
50316 QMOV3W=0.0D0
50317 IF(QOLD.LT.1D-3*QDEL) THEN
50318 GOTO 280
50319 ELSEIF(QOLD.LE.QDEL) THEN
50320 QMOV=QOLD/3D0
50321 ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN
50322 RBIN=QOLD/QDEL
50323 IBIN=RBIN
50324 RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
50325 QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
50326 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
50327 ELSE
50328 QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
50329 ENDIF
50330 280 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0)
50331 IF(QOLD.LT.1D-3*QDEL3) THEN
50332 GOTO 290
50333 ELSEIF(QOLD.LE.QDEL3) THEN
50334 QMOV3=QOLD/3D0
50335 ELSEIF(QOLD.LT.(NBIN3-0.1D0)*QDEL3) THEN
50336 RBIN3=QOLD/QDEL3
50337 IBIN3=RBIN3
50338 RINP3=(RBIN3**3-IBIN3**3)/(3*IBIN3*(IBIN3+1)+1)
50339 QMOV3=(BEI3(IBIN3)+RINP3*(BEI3(IBIN3+1)-BEI3(IBIN3)))*
50340 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
50341 ELSE
50342 QMOV3=BEI3(NBIN3)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
50343 ENDIF
50344 290 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3))**(2D0/3D0)
50345 RSCALE=1.0D0
50346 IF(MSTJ(54).EQ.2)
50347 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*PARJ(93)))**2)
50348 IF((IWP.NE.-1.AND.MSTJ(56).LE.0).OR.IWP.EQ.0.OR.IWN.EQ.0.OR.
50349 & K(I1M,5).EQ.K(I2M,5)) GOTO 320
50350
50351 IF(QOLD.LT.1D-3*QDELW) THEN
50352 GOTO 300
50353 ELSEIF(QOLD.LE.QDELW) THEN
50354 QMOVW=QOLD/3D0
50355 ELSEIF(QOLD.LT.(NBINW-0.1D0)*QDELW) THEN
50356 RBINW=QOLD/QDELW
50357 IBINW=RBINW
50358 RINPW=(RBINW**3-IBINW**3)/(3*IBINW*(IBINW+1)+1)
50359 QMOVW=(BEIW(IBINW)+RINPW*(BEIW(IBINW+1)-BEIW(IBINW)))*
50360 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
50361 ELSE
50362 QMOVW=BEIW(NBINW)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
50363 ENDIF
50364 300 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOVW))**(2D0/3D0)
50365 IF(QOLD.LT.1D-3*QDEL3W) THEN
50366 GOTO 310
50367 ELSEIF(QOLD.LE.QDEL3W) THEN
50368 QMOV3W=QOLD/3D0
50369 ELSEIF(QOLD.LT.(NBIN3W-0.1D0)*QDEL3W) THEN
50370 RBIN3W=QOLD/QDEL3W
50371 IBIN3W=RBIN3W
50372 RINP3W=(RBIN3W**3-IBIN3W**3)/(3*IBIN3W*(IBIN3W+1)+1)
50373 QMOV3W=(BEI3W(IBIN3W)+RINP3W*(BEI3W(IBIN3W+1)-
50374 & BEI3W(IBIN3W)))*SQRT(Q2OLD+PMHQ**2)/Q2OLD
50375 ELSE
50376 QMOV3W=BEI3W(NBIN3W)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
50377 ENDIF
50378 310 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3W))**(2D0/3D0)
50379 IF(MSTJ(54).EQ.2)
50380 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*SIGW))**2)
50381
50382 320 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW)
50383 DO 330 J=1,3
50384 P(I1M,J)=P(I1M,J)+P(NMAX+1,J)
50385 P(I2M,J)=P(I2M,J)+P(NMAX+2,J)
50386 330 CONTINUE
50387 IF(MSTJ(54).GE.1) THEN
50388 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW3)
50389 DO 340 J=1,3
50390 V(I1M,J)=V(I1M,J)+P(NMAX+1,J)*RSCALE
50391 V(I2M,J)=V(I2M,J)+P(NMAX+2,J)*RSCALE
50392 340 CONTINUE
50393 ELSEIF(MSTJ(54).LE.-1) THEN
50394 EDEL=P(I1,4)+P(I2,4)-
50395 & SQRT(MAX(Q2NEW-Q2OLD+(P(I1,4)+P(I2,4))**2,0.0D0))
50396 A2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
50397 & (P(I1,3)-P(I2,3))**2
50398 WMAX=-1.0D20
50399 MI3=0
50400 MI4=0
50401 S12=SDIP(I1,I2)
50402 SM1=(P(I1,5)+SMMIN)**2
50403 DO 360 I3M=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
50404 IF(I3M.EQ.I1M.OR.I3M.EQ.I2M) GOTO 360
50405 IF(MSTJ(53).EQ.1.AND.K(I3M,5).NE.K(I1M,5)) GOTO 360
50406 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
50407 & K(I3M,5).NE.K(I1M,5)) GOTO 360
50408 I3=K(I3M,1)
50409 IF(K(I3,2).EQ.K(I1,2)) GOTO 360
50410 S13=SDIP(I1,I3)
50411 S23=SDIP(I2,I3)
50412 SM3=(P(I3,5)+SMMIN)**2
50413 IF(MSTJ(54).EQ.-2) THEN
50414 WI=(MIN(S12*SM3,S13*MIN(SM1,SM3),
50415 & S23*MIN(SM1,SM3))*SM1)
50416 ELSE
50417 WI=((P(I1,4)+P(I2,4)+P(I3,4))**2-
50418 & (P(I1,3)+P(I2,3)+P(I3,3))**2-
50419 & (P(I1,2)+P(I2,2)+P(I3,2))**2-
50420 & (P(I1,1)+P(I2,1)+P(I3,1))**2)
50421 ENDIF
50422 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0) THEN
50423 IF (WMAX*WI.GE.(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2))))
50424 & GOTO 360
50425 ELSE
50426 IF(WMAX*WI.GE.1.0) GOTO 360
50427 ENDIF
50428 DO 350 I4M=I3M+1,NBE(MIN(10,MSTJ(52)+1))
50429 IF(I4M.EQ.I1M.OR.I4M.EQ.I2M) GOTO 350
50430 IF(MSTJ(53).EQ.1.AND.K(I4M,5).NE.K(I1M,5)) GOTO 350
50431 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
50432 & K(I4M,5).NE.K(I1M,5)) GOTO 350
50433 I4=K(I4M,1)
50434 IF(K(I3,2).EQ.K(I4,2).OR.K(I4,2).EQ.K(I1,2))
50435 & GOTO 350
50436 IF((P(I3,4)+P(I4,4)+EDEL)**2.LT.
50437 & (P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
50438 & (P(I3,3)+P(I4,3))**2+(P(I3,5)+P(I4,5))**2)
50439 & GOTO 350
50440 IF(MSTJ(54).EQ.-2) THEN
50441 S14=SDIP(I1,I4)
50442 S24=SDIP(I2,I4)
50443 S34=SDIP(I3,I4)
50444 W=S12*MIN(MIN(S23,S24),MIN(S13,S14))*S34
50445 W=MIN(W,S13*MIN(MIN(S23,S34),S12)*S24)
50446 W=MIN(W,S14*MIN(MIN(S24,S34),S12)*S23)
50447 W=MIN(W,MIN(S23,S24)*S13*S14)
50448 W=1.0D0/W
50449 ELSE
50450C...weight=1-cos(theta)/mtot2
50451 S1234=(P(I1,4)+P(I2,4)+P(I3,4)+P(I4,4))**2-
50452 & (P(I1,3)+P(I2,3)+P(I3,3)+P(I4,3))**2-
50453 & (P(I1,2)+P(I2,2)+P(I3,2)+P(I4,2))**2-
50454 & (P(I1,1)+P(I2,1)+P(I3,1)+P(I4,1))**2
50455 W=1.0D0/S1234
50456 IF(W.LE.WMAX) GOTO 350
50457 ENDIF
50458 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0)
50459 & W=W*(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2)))
50460 IF(MSTJ(57).EQ.1.AND.P(I4M,5).GT.0)
50461 & W=W*(1.0D0-EXP(-P(I4M,5)/(PARJ(93)**2)))
50462 IF(W.LE.WMAX) GOTO 350
50463 MI3=I3M
50464 MI4=I4M
50465 WMAX=W
50466 350 CONTINUE
50467 360 CONTINUE
50468 IF(MI4.EQ.0) GOTO 380
50469 I3=K(MI3,1)
50470 I4=K(MI4,1)
50471 EOLD=P(I3,4)+P(I4,4)
50472 ENEW=EOLD+EDEL
50473 P2=(P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
50474 & (P(I3,3)+P(I4,3))**2
50475 Q2NEWP=MAX(0.0D0,ENEW**2-P2-(P(I3,5)+P(I4,5))**2)
50476 Q2OLDP=MAX(0.0D0,EOLD**2-P2-(P(I3,5)+P(I4,5))**2)
50477 CALL PYBESQ(I3,I4,NMAX,Q2OLDP,Q2NEWP)
50478 DO 370 J=1,3
50479 V(MI3,J)=V(MI3,J)+P(NMAX+1,J)
50480 V(MI4,J)=V(MI4,J)+P(NMAX+2,J)
50481 370 CONTINUE
50482 ENDIF
50483 380 CONTINUE
50484 390 CONTINUE
50485 400 CONTINUE
50486
50487C...Shift momenta and recalculate energies.
50488 ESUMP=0.0D0
50489 ESUM=0.0D0
50490 PROD=0.0D0
50491 DO 430 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
50492 I=K(IM,1)
50493 ESUMP=ESUMP+P(I,4)
50494 DO 410 J=1,3
50495 P(I,J)=P(I,J)+P(IM,J)
50496 410 CONTINUE
50497 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
50498 ESUM=ESUM+P(I,4)
50499 DO 420 J=1,3
50500 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
50501 420 CONTINUE
50502 430 CONTINUE
50503
50504 PARJ(96)=0.0D0
50505 IF(MSTJ(54).NE.0.AND.PROD.NE.0.0D0) THEN
50506 440 ALPHA=(ESUMP-ESUM)/PROD
50507 PARJ(96)=PARJ(96)+ALPHA
50508 PROD=0.0D0
50509 ESUM=0.0D0
50510 DO 470 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
50511 I=K(IM,1)
50512 DO 450 J=1,3
50513 P(I,J)=P(I,J)+ALPHA*V(IM,J)
50514 450 CONTINUE
50515 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
50516 ESUM=ESUM+P(I,4)
50517 DO 460 J=1,3
50518 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
50519 460 CONTINUE
50520 470 CONTINUE
50521 IF(PROD.NE.0.0D0.AND.ABS(ESUMP-ESUM)/PECM.GT.0.00001D0)
50522 & GOTO 440
50523 ENDIF
50524
50525C...Rescale all momenta for energy conservation.
50526 PES=0D0
50527 PQS=0D0
50528 DO 480 I=1,N
50529 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 480
50530 PES=PES+P(I,4)
50531 PQS=PQS+P(I,5)**2/P(I,4)
50532 480 CONTINUE
50533 PARJ(95)=PES-PECM
50534 FAC=(PECM-PQS)/(PES-PQS)
50535 DO 500 I=1,N
50536 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 500
50537 DO 490 J=1,3
50538 P(I,J)=FAC*P(I,J)
50539 490 CONTINUE
50540 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
50541 500 CONTINUE
50542
50543C...Boost back to correct reference frame.
50544 510 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
50545 DO 520 I=1,N
50546 IF(K(I,1).LT.0) K(I,1)=-K(I,1)
50547 520 CONTINUE
50548
50549 RETURN
50550 END
50551
50552C*********************************************************************
50553
50554C...PYBESQ
50555C...Calculates the momentum shift in a system of two particles assuming
50556C...the relative momentum squared should be shifted to Q2NEW. NI is the
50557C...last position occupied in /PYJETS/.
50558
50559 SUBROUTINE PYBESQ(I1,I2,NI,Q2OLD,Q2NEW)
50560
50561C...Double precision and integer declarations.
50562 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50563 IMPLICIT INTEGER(I-N)
50564 INTEGER PYK,PYCHGE,PYCOMP
50565C...Parameter statement to help give large particle numbers.
50566 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50567 &KEXCIT=4000000,KDIMEN=5000000)
50568C...Commonblocks.
50569 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
50570 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50571 SAVE /PYJETS/,/PYDAT1/
50572C...Local arrays and data.
50573 DIMENSION DP(5)
50574 SAVE HC1
50575
50576 IF(MSTJ(55).EQ.0) THEN
50577 DQ2=Q2NEW-Q2OLD
50578 DP2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
50579 & (P(I1,3)-P(I2,3))**2
50580 DP12=P(I1,1)**2+P(I1,2)**2+P(I1,3)**2
50581 & -P(I2,1)**2-P(I2,2)**2-P(I2,3)**2
50582 SE=P(I1,4)+P(I2,4)
50583 DE=P(I1,4)-P(I2,4)
50584 DQ2SE=DQ2+SE**2
50585 DA=SE*DE*DP12-DP2*DQ2SE
50586 DB=DP2*DQ2SE-DP12**2
50587 HA=(DA+SQRT(MAX(DA**2+DQ2*(DQ2+SE**2-DE**2)*DB,0D0)))/(2D0*DB)
50588 DO 100 J=1,3
50589 PD=HA*(P(I1,J)-P(I2,J))
50590 P(NI+1,J)=PD
50591 P(NI+2,J)=-PD
50592 100 CONTINUE
50593 RETURN
50594 ENDIF
50595
50596 K(NI+1,1)=1
50597 K(NI+2,1)=1
50598 DO 110 J=1,5
50599 P(NI+1,J)=P(I1,J)
50600 P(NI+2,J)=P(I2,J)
50601 DP(J)=P(I1,J)+P(I2,J)
50602 110 CONTINUE
50603
50604C...Boost to cms and rotate first particle to z-axis
50605 CALL PYROBO(NI+1,NI+2,0.0D0,0.0D0,
50606 &-DP(1)/DP(4),-DP(2)/DP(4),-DP(3)/DP(4))
50607 PHI=PYANGL(P(NI+1,1),P(NI+1,2))
50608 THE=PYANGL(P(NI+1,3),SQRT(P(NI+1,1)**2+P(NI+1,2)**2))
50609 S=Q2NEW+(P(I1,5)+P(I2,5))**2
50610 PZ=0.5D0*SQRT(Q2NEW*(S-(P(I1,5)-P(I2,5))**2)/S)
50611 P(NI+1,1)=0.0D0
50612 P(NI+1,2)=0.0D0
50613 P(NI+1,3)=PZ
50614 P(NI+1,4)=SQRT(PZ**2+P(I1,5)**2)
50615 P(NI+2,1)=0.0D0
50616 P(NI+2,2)=0.0D0
50617 P(NI+2,3)=-PZ
50618 P(NI+2,4)=SQRT(PZ**2+P(I2,5)**2)
50619 DP(4)=SQRT(DP(1)**2+DP(2)**2+DP(3)**2+S)
50620 CALL PYROBO(NI+1,NI+2,THE,PHI,
50621 &DP(1)/DP(4),DP(2)/DP(4),DP(3)/DP(4))
50622
50623 DO 120 J=1,3
50624 P(NI+1,J)=P(NI+1,J)-P(I1,J)
50625 P(NI+2,J)=P(NI+2,J)-P(I2,J)
50626 120 CONTINUE
50627
50628 RETURN
50629 END
50630
50631C*********************************************************************
50632
50633C...PYMASS
50634C...Gives the mass of a particle/parton.
50635
50636 FUNCTION PYMASS(KF)
50637
50638C...Double precision and integer declarations.
50639 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50640 IMPLICIT INTEGER(I-N)
50641 INTEGER PYK,PYCHGE,PYCOMP
50642C...Commonblocks.
50643 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50644 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50645 SAVE /PYDAT1/,/PYDAT2/
50646
50647C...Reset variables. Compressed code. Special case for popcorn diquarks.
50648 PYMASS=0D0
50649 KFA=IABS(KF)
50650 KC=PYCOMP(KF)
50651 IF(KC.EQ.0) THEN
50652 MSTJ(93)=0
50653 RETURN
50654 ENDIF
50655
50656C...Guarantee use of constituent masses for internal checks.
50657 IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.
50658 &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN
50659 IF(KFA.LE.5) THEN
50660 PYMASS=PARF(100+KFA)
50661 IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121))
50662 ELSEIF(KFA.LE.10) THEN
50663 PYMASS=PMAS(KFA,1)
50664 ELSEIF(MSTJ(93).EQ.1) THEN
50665 PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10))
50666 ELSE
50667 PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0)
50668 ENDIF
50669
50670C...Other masses can be read directly off table.
50671 ELSE
50672 PYMASS=PMAS(KC,1)
50673 ENDIF
50674
50675C...Optional mass broadening according to truncated Breit-Wigner
50676C...(either in m or in m^2).
50677 IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN
50678 IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
50679 PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)*
50680 & ATAN(2D0*PMAS(KC,3)/PMAS(KC,2)))
50681 ELSE
50682 PM0=PYMASS
50683 PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/
50684 & (PM0*PMAS(KC,2)))
50685 PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
50686 PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
50687 & (PMUPP-PMLOW)*PYR(0))))
50688 ENDIF
50689 ENDIF
50690 MSTJ(93)=0
50691
50692 RETURN
50693 END
50694
50695C*********************************************************************
50696
50697C...PYMRUN
50698C...Gives the running, current-algebra mass of a d, u, s, c or b quark,
50699C...for Higgs couplings. Everything else sent on to PYMASS.
50700
50701 FUNCTION PYMRUN(KF,Q2)
50702
50703C...Double precision and integer declarations.
50704 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50705 IMPLICIT INTEGER(I-N)
50706 INTEGER PYK,PYCHGE,PYCOMP
50707C...Commonblocks.
50708 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50709 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50710 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
50711 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/
50712
50713C...Most masses not handled here.
50714 KFA=IABS(KF)
50715 IF(KFA.EQ.0.OR.KFA.GT.6) THEN
50716 PYMRUN=PYMASS(KF)
50717
50718C...Current-algebra masses, but no Q2 dependence.
50719 ELSEIF(MSTP(37).NE.1.OR.MSTP(2).LE.0) THEN
50720 PYMRUN=PARF(90+KFA)
50721
50722C...Running current-algebra masses.
50723 ELSE
50724 AS=PYALPS(Q2)
50725 PYMRUN=PARF(90+KFA)*
50726 & (LOG(MAX(4D0,PARP(37)**2*PARF(90+KFA)**2/PARU(117)**2))/
50727 & LOG(MAX(4D0,Q2/PARU(117)**2)))**(12D0/(33D0-2D0*MSTU(118)))
50728 ENDIF
50729
50730 RETURN
50731 END
50732
50733C*********************************************************************
50734
50735C...PYNAME
50736C...Gives the particle/parton name as a character string.
50737
50738 SUBROUTINE PYNAME(KF,CHAU)
50739
50740C...Double precision and integer declarations.
50741 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50742 IMPLICIT INTEGER(I-N)
50743 INTEGER PYK,PYCHGE,PYCOMP
50744C...Commonblocks.
50745 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50746 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50747 COMMON/PYDAT4/CHAF(500,2)
50748 CHARACTER CHAF*16
50749 SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/
50750C...Local character variable.
50751 CHARACTER CHAU*16
50752
50753C...Read out code with distinction particle/antiparticle.
50754 CHAU=' '
50755 KC=PYCOMP(KF)
50756 IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2)
50757
50758
50759 RETURN
50760 END
50761
50762C*********************************************************************
50763
50764C...PYCHGE
50765C...Gives three times the charge for a particle/parton.
50766
50767 FUNCTION PYCHGE(KF)
50768
50769C...Double precision and integer declarations.
50770 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50771 IMPLICIT INTEGER(I-N)
50772 INTEGER PYK,PYCHGE,PYCOMP
50773C...Commonblocks.
50774 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50775 SAVE /PYDAT2/
50776
50777C...Read out charge and change sign for antiparticle.
50778 PYCHGE=0
50779 KC=PYCOMP(KF)
50780 IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF)
50781
50782 RETURN
50783 END
50784
50785C*********************************************************************
50786
50787C...PYCOMP
50788C...Compress the standard KF codes for use in mass and decay arrays;
50789C...also checks whether a given code actually is defined.
50790
50791 FUNCTION PYCOMP(KF)
50792
50793C...Double precision and integer declarations.
50794 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50795 IMPLICIT INTEGER(I-N)
50796 INTEGER PYK,PYCHGE,PYCOMP
50797C...Commonblocks.
50798 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50799 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50800 SAVE /PYDAT1/,/PYDAT2/
50801C...Local arrays and saved data.
50802 DIMENSION KFORD(100:500),KCORD(101:500)
50803 SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST
50804
50805C...Whenever necessary reorder codes for faster search.
50806 IF(MSTU(20).EQ.0) THEN
50807 NFORD=100
50808 KFORD(100)=0
50809 DO 120 I=101,500
50810 KFA=KCHG(I,4)
50811 IF(KFA.LE.100) GOTO 120
50812 NFORD=NFORD+1
50813 DO 100 I1=NFORD-1,0,-1
50814 IF(KFA.GE.KFORD(I1)) GOTO 110
50815 KFORD(I1+1)=KFORD(I1)
50816 KCORD(I1+1)=KCORD(I1)
50817 100 CONTINUE
50818 110 KFORD(I1+1)=KFA
50819 KCORD(I1+1)=I
50820 120 CONTINUE
50821 MSTU(20)=1
50822 KFLAST=0
50823 KCLAST=0
50824 ENDIF
50825
50826C...Fast action if same code as in latest call.
50827 IF(KF.EQ.KFLAST) THEN
50828 PYCOMP=KCLAST
50829 RETURN
50830 ENDIF
50831
50832C...Starting values. Remove internal diquark flags.
50833 PYCOMP=0
50834 KFA=IABS(KF)
50835 IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000
50836 & .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000)
50837
50838C...Simple cases: direct translation.
50839 IF(KFA.GT.KFORD(NFORD)) THEN
50840 ELSEIF(KFA.LE.100) THEN
50841 PYCOMP=KFA
50842
50843C...Else binary search.
50844 ELSE
50845 IMIN=100
50846 IMAX=NFORD+1
50847 130 IAVG=(IMIN+IMAX)/2
50848 IF(KFORD(IAVG).GT.KFA) THEN
50849 IMAX=IAVG
50850 IF(IMAX.GT.IMIN+1) GOTO 130
50851 ELSEIF(KFORD(IAVG).LT.KFA) THEN
50852 IMIN=IAVG
50853 IF(IMAX.GT.IMIN+1) GOTO 130
50854 ELSE
50855 PYCOMP=KCORD(IAVG)
50856 ENDIF
50857 ENDIF
50858
50859C...Check if antiparticle allowed.
50860 IF(PYCOMP.NE.0.AND.KF.LT.0) THEN
50861 IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0
50862 ENDIF
50863
50864C...Save codes for possible future fast action.
50865 KFLAST=KF
50866 KCLAST=PYCOMP
50867
50868 RETURN
50869 END
50870
50871C*********************************************************************
50872
50873C...PYERRM
50874C...Informs user of errors in program execution.
50875
50876 SUBROUTINE PYERRM(MERR,CHMESS)
50877
50878C...Double precision and integer declarations.
50879 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50880 IMPLICIT INTEGER(I-N)
50881 INTEGER PYK,PYCHGE,PYCOMP
50882C...Commonblocks.
50883 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
50884 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50885 SAVE /PYJETS/,/PYDAT1/
50886C...Local character variable.
50887 CHARACTER CHMESS*(*)
50888
50889C...Write first few warnings, then be silent.
50890 IF(MERR.LE.10) THEN
50891 MSTU(27)=MSTU(27)+1
50892 MSTU(28)=MERR
50893 IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
50894 & MERR,MSTU(31),CHMESS
50895
50896C...Write first few errors, then be silent or stop program.
50897 ELSEIF(MERR.LE.20) THEN
50898 MSTU(23)=MSTU(23)+1
50899 MSTU(24)=MERR-10
50900 IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
50901 & MERR-10,MSTU(31),CHMESS
50902 IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
50903 WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
50904 WRITE(MSTU(11),5200)
50905 IF(MERR.NE.17) CALL PYLIST(2)
50906 STOP
50907 ENDIF
50908
50909C...Stop program in case of irreparable error.
50910 ELSE
50911 WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
50912 STOP
50913 ENDIF
50914
50915C...Formats for output.
50916 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9,
50917 &' PYEXEC calls:'/5X,A)
50918 5100 FORMAT(/5X,'Error type',I2,' has occured after',I9,
50919 &' PYEXEC calls:'/5X,A)
50920 5200 FORMAT(5X,'Execution will be stopped after listing of last ',
50921 &'event!')
50922 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9,
50923 &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
50924
50925 RETURN
50926 END
50927
50928C*********************************************************************
50929
50930C...PYALEM
50931C...Calculates the running alpha_electromagnetic.
50932
50933 FUNCTION PYALEM(Q2)
50934
50935C...Double precision and integer declarations.
50936 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50937 IMPLICIT INTEGER(I-N)
50938 INTEGER PYK,PYCHGE,PYCOMP
50939C...Commonblocks.
50940 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50941 SAVE /PYDAT1/
50942
50943C...Calculate real part of photon vacuum polarization.
50944C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
50945C...For hadrons use parametrization of H. Burkhardt et al.
50946C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
50947 AEMPI=PARU(101)/(3D0*PARU(1))
50948 IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
50949 RPIGG=0D0
50950 ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
50951 RPIGG=0D0
50952 ELSEIF(MSTU(101).EQ.2) THEN
50953 RPIGG=1D0-PARU(101)/PARU(103)
50954 ELSEIF(Q2.LT.0.09D0) THEN
50955 RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2)
50956 ELSEIF(Q2.LT.9D0) THEN
50957 RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+
50958 & 0.00238D0*LOG(1D0+3.927D0*Q2)
50959 ELSEIF(Q2.LT.1D4) THEN
50960 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+
50961 & 0.00299D0*LOG(1D0+Q2)
50962 ELSE
50963 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+
50964 & 0.00293D0*LOG(1D0+Q2)
50965 ENDIF
50966
50967C...Calculate running alpha_em.
50968 PYALEM=PARU(101)/(1D0-RPIGG)
50969 PARU(108)=PYALEM
50970
50971 RETURN
50972 END
50973
50974C*********************************************************************
50975
50976C...PYALPS
50977C...Gives the value of alpha_strong.
50978
50979 FUNCTION PYALPS(Q2)
50980
50981C...Double precision and integer declarations.
50982 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50983 IMPLICIT INTEGER(I-N)
50984 INTEGER PYK,PYCHGE,PYCOMP
50985C...Commonblocks.
50986 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50987 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50988 SAVE /PYDAT1/,/PYDAT2/
50989
50990C...Constant alpha_strong trivial. Pick artificial Lambda.
50991 IF(MSTU(111).LE.0) THEN
50992 PYALPS=PARU(111)
50993 MSTU(118)=MSTU(112)
50994 PARU(117)=0.2D0
50995 IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/
50996 & ((33D0-2D0*MSTU(112))*PARU(111)))
50997 PARU(118)=PARU(111)
50998 RETURN
50999 ENDIF
51000
51001C...Find effective Q2, number of flavours and Lambda.
51002 Q2EFF=Q2
51003 IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
51004 NF=MSTU(112)
51005 ALAM2=PARU(112)**2
51006 100 IF(NF.GT.MAX(2,MSTU(113))) THEN
51007 Q2THR=PARU(113)*PMAS(NF,1)**2
51008 IF(Q2EFF.LT.Q2THR) THEN
51009 NF=NF-1
51010 ALAM2=ALAM2*(Q2THR/ALAM2)**(2D0/(33D0-2D0*NF))
51011 GOTO 100
51012 ENDIF
51013 ENDIF
51014 110 IF(NF.LT.MIN(8,MSTU(114))) THEN
51015 Q2THR=PARU(113)*PMAS(NF+1,1)**2
51016 IF(Q2EFF.GT.Q2THR) THEN
51017 NF=NF+1
51018 ALAM2=ALAM2*(ALAM2/Q2THR)**(2D0/(33D0-2D0*NF))
51019 GOTO 110
51020 ENDIF
51021 ENDIF
51022 IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
51023 PARU(117)=SQRT(ALAM2)
51024
51025C...Evaluate first or second order alpha_strong.
51026 B0=(33D0-2D0*NF)/6D0
51027 ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2))
51028 IF(MSTU(111).EQ.1) THEN
51029 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
51030 ELSE
51031 B1=(153D0-19D0*NF)/6D0
51032 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/
51033 & (B0**2*ALGQ)))
51034 ENDIF
51035 MSTU(118)=NF
51036 PARU(118)=PYALPS
51037
51038 RETURN
51039 END
51040
51041C*********************************************************************
51042
51043C...PYANGL
51044C...Reconstructs an angle from given x and y coordinates.
51045
51046 FUNCTION PYANGL(X,Y)
51047
51048C...Double precision and integer declarations.
51049 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51050 IMPLICIT INTEGER(I-N)
51051 INTEGER PYK,PYCHGE,PYCOMP
51052C...Commonblocks.
51053 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51054 SAVE /PYDAT1/
51055
51056 PYANGL=0D0
51057 R=SQRT(X**2+Y**2)
51058 IF(R.LT.1D-20) RETURN
51059 IF(ABS(X)/R.LT.0.8D0) THEN
51060 PYANGL=SIGN(ACOS(X/R),Y)
51061 ELSE
51062 PYANGL=ASIN(Y/R)
51063 IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN
51064 PYANGL=PARU(1)-PYANGL
51065 ELSEIF(X.LT.0D0) THEN
51066 PYANGL=-PARU(1)-PYANGL
51067 ENDIF
51068 ENDIF
51069
51070 RETURN
51071 END
51072
51073C*********************************************************************
51074
51075C...PYR
51076C...Generates random numbers uniformly distributed between
51077C...0 and 1, excluding the endpoints.
51078
51079 FUNCTION PYR(IDUMMY)
51080
51081C...Double precision and integer declarations.
51082 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51083 IMPLICIT INTEGER(I-N)
51084 INTEGER PYK,PYCHGE,PYCOMP
51085C...Commonblocks.
51086 COMMON/PYDATR/MRPY(6),RRPY(100)
51087 SAVE /PYDATR/
51088C...Equivalence between commonblock and local variables.
51089 EQUIVALENCE (MRPY1,MRPY(1)),(MRPY2,MRPY(2)),(MRPY3,MRPY(3)),
51090 &(MRPY4,MRPY(4)),(MRPY5,MRPY(5)),(MRPY6,MRPY(6)),
51091 &(RRPY98,RRPY(98)),(RRPY99,RRPY(99)),(RRPY00,RRPY(100))
51092
51093C...Initialize generation from given seed.
51094 IF(MRPY2.EQ.0) THEN
51095 IJ=MOD(MRPY1/30082,31329)
51096 KL=MOD(MRPY1,30082)
51097 I=MOD(IJ/177,177)+2
51098 J=MOD(IJ,177)+2
51099 K=MOD(KL/169,178)+1
51100 L=MOD(KL,169)
51101 DO 110 II=1,97
51102 S=0D0
51103 T=0.5D0
51104 DO 100 JJ=1,48
51105 M=MOD(MOD(I*J,179)*K,179)
51106 I=J
51107 J=K
51108 K=M
51109 L=MOD(53*L+1,169)
51110 IF(MOD(L*M,64).GE.32) S=S+T
51111 T=0.5D0*T
51112 100 CONTINUE
51113 RRPY(II)=S
51114 110 CONTINUE
51115 TWOM24=1D0
51116 DO 120 I24=1,24
51117 TWOM24=0.5D0*TWOM24
51118 120 CONTINUE
51119 RRPY98=362436D0*TWOM24
51120 RRPY99=7654321D0*TWOM24
51121 RRPY00=16777213D0*TWOM24
51122 MRPY2=1
51123 MRPY3=0
51124 MRPY4=97
51125 MRPY5=33
51126 ENDIF
51127
51128C...Generate next random number.
51129 130 RUNI=RRPY(MRPY4)-RRPY(MRPY5)
51130 IF(RUNI.LT.0D0) RUNI=RUNI+1D0
51131 RRPY(MRPY4)=RUNI
51132 MRPY4=MRPY4-1
51133 IF(MRPY4.EQ.0) MRPY4=97
51134 MRPY5=MRPY5-1
51135 IF(MRPY5.EQ.0) MRPY5=97
51136 RRPY98=RRPY98-RRPY99
51137 IF(RRPY98.LT.0D0) RRPY98=RRPY98+RRPY00
51138 RUNI=RUNI-RRPY98
51139 IF(RUNI.LT.0D0) RUNI=RUNI+1D0
51140 IF(RUNI.LE.0D0.OR.RUNI.GE.1D0) GOTO 130
51141
51142C...Update counters. Random number to output.
51143 MRPY3=MRPY3+1
51144 IF(MRPY3.EQ.1000000000) THEN
51145 MRPY2=MRPY2+1
51146 MRPY3=0
51147 ENDIF
51148 PYR=RUNI
51149
51150 RETURN
51151 END
51152
51153C*********************************************************************
51154
51155C...PYRGET
51156C...Dumps the state of the random number generator on a file
51157C...for subsequent startup from this state onwards.
51158
51159 SUBROUTINE PYRGET(LFN,MOVE)
51160
51161C...Double precision and integer declarations.
51162 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51163 IMPLICIT INTEGER(I-N)
51164 INTEGER PYK,PYCHGE,PYCOMP
51165C...Commonblocks.
51166 COMMON/PYDATR/MRPY(6),RRPY(100)
51167 SAVE /PYDATR/
51168C...Local character variable.
51169 CHARACTER CHERR*8
51170
51171C...Backspace required number of records (or as many as there are).
51172 IF(MOVE.LT.0) THEN
51173 NBCK=MIN(MRPY(6),-MOVE)
51174 DO 100 IBCK=1,NBCK
51175 BACKSPACE(LFN,ERR=110,IOSTAT=IERR)
51176 100 CONTINUE
51177 MRPY(6)=MRPY(6)-NBCK
51178 ENDIF
51179
51180C...Unformatted write on unit LFN.
51181 WRITE(LFN,ERR=110,IOSTAT=IERR) (MRPY(I1),I1=1,5),
51182 &(RRPY(I2),I2=1,100)
51183 MRPY(6)=MRPY(6)+1
51184 RETURN
51185
51186C...Write error.
51187 110 WRITE(CHERR,'(I8)') IERR
51188 CALL PYERRM(18,'(PYRGET:) error when accessing file, IOSTAT ='//
51189 &CHERR)
51190
51191 RETURN
51192 END
51193
51194C*********************************************************************
51195
51196C...PYRSET
51197C...Reads a state of the random number generator from a file
51198C...for subsequent generation from this state onwards.
51199
51200 SUBROUTINE PYRSET(LFN,MOVE)
51201
51202C...Double precision and integer declarations.
51203 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51204 IMPLICIT INTEGER(I-N)
51205 INTEGER PYK,PYCHGE,PYCOMP
51206C...Commonblocks.
51207 COMMON/PYDATR/MRPY(6),RRPY(100)
51208 SAVE /PYDATR/
51209C...Local character variable.
51210 CHARACTER CHERR*8
51211
51212C...Backspace required number of records (or as many as there are).
51213 IF(MOVE.LT.0) THEN
51214 NBCK=MIN(MRPY(6),-MOVE)
51215 DO 100 IBCK=1,NBCK
51216 BACKSPACE(LFN,ERR=120,IOSTAT=IERR)
51217 100 CONTINUE
51218 MRPY(6)=MRPY(6)-NBCK
51219 ENDIF
51220
51221C...Unformatted read from unit LFN.
51222 NFOR=1+MAX(0,MOVE)
51223 DO 110 IFOR=1,NFOR
51224 READ(LFN,ERR=120,IOSTAT=IERR) (MRPY(I1),I1=1,5),
51225 & (RRPY(I2),I2=1,100)
51226 110 CONTINUE
51227 MRPY(6)=MRPY(6)+NFOR
51228 RETURN
51229
51230C...Write error.
51231 120 WRITE(CHERR,'(I8)') IERR
51232 CALL PYERRM(18,'(PYRSET:) error when accessing file, IOSTAT ='//
51233 &CHERR)
51234
51235 RETURN
51236 END
51237
51238C*********************************************************************
51239
51240C...PYROBO
51241C...Performs rotations and boosts.
51242
51243 SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
51244
51245C...Double precision and integer declarations.
51246 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51247 IMPLICIT INTEGER(I-N)
51248 INTEGER PYK,PYCHGE,PYCOMP
51249C...Commonblocks.
51250 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
51251 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51252 SAVE /PYJETS/,/PYDAT1/
51253C...Local arrays.
51254 DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
51255
51256C...Find and check range of rotation/boost.
51257 IMIN=IMI
51258 IF(IMIN.LE.0) IMIN=1
51259 IF(MSTU(1).GT.0) IMIN=MSTU(1)
51260 IMAX=IMA
51261 IF(IMAX.LE.0) IMAX=N
51262 IF(MSTU(2).GT.0) IMAX=MSTU(2)
51263 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
51264 CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory')
51265 RETURN
51266 ENDIF
51267
51268C...Optional resetting of V (when not set before.)
51269 IF(MSTU(33).NE.0) THEN
51270 DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
51271 DO 100 J=1,5
51272 V(I,J)=0D0
51273 100 CONTINUE
51274 110 CONTINUE
51275 MSTU(33)=0
51276 ENDIF
51277
51278C...Rotate, typically from z axis to direction (theta,phi).
51279 IF(THE**2+PHI**2.GT.1D-20) THEN
51280 ROT(1,1)=COS(THE)*COS(PHI)
51281 ROT(1,2)=-SIN(PHI)
51282 ROT(1,3)=SIN(THE)*COS(PHI)
51283 ROT(2,1)=COS(THE)*SIN(PHI)
51284 ROT(2,2)=COS(PHI)
51285 ROT(2,3)=SIN(THE)*SIN(PHI)
51286 ROT(3,1)=-SIN(THE)
51287 ROT(3,2)=0D0
51288 ROT(3,3)=COS(THE)
51289 DO 140 I=IMIN,IMAX
51290 IF(K(I,1).LE.0) GOTO 140
51291 DO 120 J=1,3
51292 PR(J)=P(I,J)
51293 VR(J)=V(I,J)
51294 120 CONTINUE
51295 DO 130 J=1,3
51296 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
51297 V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
51298 130 CONTINUE
51299 140 CONTINUE
51300 ENDIF
51301
51302C...Boost, typically from rest to momentum/energy=beta.
51303 IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN
51304 DBX=BEX
51305 DBY=BEY
51306 DBZ=BEZ
51307 DB=SQRT(DBX**2+DBY**2+DBZ**2)
51308 EPS1=1D0-1D-12
51309 IF(DB.GT.EPS1) THEN
51310C...Rescale boost vector if too close to unity.
51311 CALL PYERRM(3,'(PYROBO:) boost vector too large')
51312 DBX=DBX*(EPS1/DB)
51313 DBY=DBY*(EPS1/DB)
51314 DBZ=DBZ*(EPS1/DB)
51315 DB=EPS1
51316 ENDIF
51317 DGA=1D0/SQRT(1D0-DB**2)
51318 DO 160 I=IMIN,IMAX
51319 IF(K(I,1).LE.0) GOTO 160
51320 DO 150 J=1,4
51321 DP(J)=P(I,J)
51322 DV(J)=V(I,J)
51323 150 CONTINUE
51324 DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
51325 DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
51326 P(I,1)=DP(1)+DGABP*DBX
51327 P(I,2)=DP(2)+DGABP*DBY
51328 P(I,3)=DP(3)+DGABP*DBZ
51329 P(I,4)=DGA*(DP(4)+DBP)
51330 DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
51331 DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
51332 V(I,1)=DV(1)+DGABV*DBX
51333 V(I,2)=DV(2)+DGABV*DBY
51334 V(I,3)=DV(3)+DGABV*DBZ
51335 V(I,4)=DGA*(DV(4)+DBV)
51336 160 CONTINUE
51337 ENDIF
51338
51339 RETURN
51340 END
51341
51342C*********************************************************************
51343
51344C...PYEDIT
51345C...Performs global manipulations on the event record, in particular
51346C...to exclude unstable or undetectable partons/particles.
51347
51348 SUBROUTINE PYEDIT(MEDIT)
51349
51350C...Double precision and integer declarations.
51351 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51352 IMPLICIT INTEGER(I-N)
51353 INTEGER PYK,PYCHGE,PYCOMP
51354C...Commonblocks.
51355 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
51356 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51357 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51358 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
51359C...Local arrays.
51360 DIMENSION NS(2),PTS(2),PLS(2)
51361
51362C...Remove unwanted partons/particles.
51363 IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
51364 IMAX=N
51365 IF(MSTU(2).GT.0) IMAX=MSTU(2)
51366 I1=MAX(1,MSTU(1))-1
51367 DO 110 I=MAX(1,MSTU(1)),IMAX
51368 IF(K(I,1).EQ.0.OR.K(I,1).GT.20) GOTO 110
51369 IF(MEDIT.EQ.1) THEN
51370 IF(K(I,1).GT.10) GOTO 110
51371 ELSEIF(MEDIT.EQ.2) THEN
51372 IF(K(I,1).GT.10) GOTO 110
51373 KC=PYCOMP(K(I,2))
51374 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.KC.EQ.18)
51375 & GOTO 110
51376 ELSEIF(MEDIT.EQ.3) THEN
51377 IF(K(I,1).GT.10) GOTO 110
51378 KC=PYCOMP(K(I,2))
51379 IF(KC.EQ.0) GOTO 110
51380 IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110
51381 ELSEIF(MEDIT.EQ.5) THEN
51382 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) GOTO 110
51383 KC=PYCOMP(K(I,2))
51384 IF(KC.EQ.0) GOTO 110
51385 IF(K(I,1).GE.11.AND.KCHG(KC,2).EQ.0) GOTO 110
51386 ENDIF
51387
51388C...Pack remaining partons/particles. Origin no longer known.
51389 I1=I1+1
51390 DO 100 J=1,5
51391 K(I1,J)=K(I,J)
51392 P(I1,J)=P(I,J)
51393 V(I1,J)=V(I,J)
51394 100 CONTINUE
51395 K(I1,3)=0
51396 110 CONTINUE
51397 IF(I1.LT.N) MSTU(3)=0
51398 IF(I1.LT.N) MSTU(70)=0
51399 N=I1
51400
51401C...Selective removal of class of entries. New position of retained.
51402 ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
51403 I1=0
51404 DO 120 I=1,N
51405 K(I,3)=MOD(K(I,3),MSTU(5))
51406 IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
51407 IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
51408 IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
51409 & K(I,1).EQ.15).AND.K(I,2).NE.94) GOTO 120
51410 IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
51411 & K(I,2).EQ.94)) GOTO 120
51412 IF(MEDIT.EQ.15.AND.K(I,1).GE.21) GOTO 120
51413 I1=I1+1
51414 K(I,3)=K(I,3)+MSTU(5)*I1
51415 120 CONTINUE
51416
51417C...Find new event history information and replace old.
51418 DO 140 I=1,N
51419 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,3)/MSTU(5).EQ.0)
51420 & GOTO 140
51421 ID=I
51422 130 IM=MOD(K(ID,3),MSTU(5))
51423 IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
51424 IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15).AND.
51425 & K(IM,2).NE.94) THEN
51426 ID=IM
51427 GOTO 130
51428 ENDIF
51429 ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
51430 IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,2).EQ.94) THEN
51431 ID=IM
51432 GOTO 130
51433 ENDIF
51434 ENDIF
51435 K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
51436 IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
51437 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
51438 IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
51439 & K(K(I,4),3)/MSTU(5)
51440 IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
51441 & K(K(I,5),3)/MSTU(5)
51442 ELSE
51443 KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
51444 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
51445 KCD=MOD(K(I,4),MSTU(5))
51446 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
51447 K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
51448 KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
51449 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
51450 KCD=MOD(K(I,5),MSTU(5))
51451 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
51452 K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
51453 ENDIF
51454 140 CONTINUE
51455
51456C...Pack remaining entries.
51457 I1=0
51458 MSTU90=MSTU(90)
51459 MSTU(90)=0
51460 DO 170 I=1,N
51461 IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
51462 I1=I1+1
51463 DO 150 J=1,5
51464 K(I1,J)=K(I,J)
51465 P(I1,J)=P(I,J)
51466 V(I1,J)=V(I,J)
51467 150 CONTINUE
51468 K(I1,3)=MOD(K(I1,3),MSTU(5))
51469 DO 160 IZ=1,MSTU90
51470 IF(I.EQ.MSTU(90+IZ)) THEN
51471 MSTU(90)=MSTU(90)+1
51472 MSTU(90+MSTU(90))=I1
51473 PARU(90+MSTU(90))=PARU(90+IZ)
51474 ENDIF
51475 160 CONTINUE
51476 170 CONTINUE
51477 IF(I1.LT.N) MSTU(3)=0
51478 IF(I1.LT.N) MSTU(70)=0
51479 N=I1
51480
51481C...Fill in some missing daughter pointers (lost in colour flow).
51482 ELSEIF(MEDIT.EQ.16) THEN
51483 DO 220 I=1,N
51484 IF(K(I,1).LE.10.OR.K(I,1).GT.20) GOTO 220
51485 IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220
51486C...Find daughters who point to mother.
51487 DO 180 I1=I+1,N
51488 IF(K(I1,3).NE.I) THEN
51489 ELSEIF(K(I,4).EQ.0) THEN
51490 K(I,4)=I1
51491 ELSE
51492 K(I,5)=I1
51493 ENDIF
51494 180 CONTINUE
51495 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
51496 IF(K(I,4).NE.0) GOTO 220
51497C...Find daughters who point to documentation version of mother.
51498 IM=K(I,3)
51499 IF(IM.LE.0.OR.IM.GE.I) GOTO 220
51500 IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220
51501 IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220
51502 DO 190 I1=I+1,N
51503 IF(K(I1,3).NE.IM) THEN
51504 ELSEIF(K(I,4).EQ.0) THEN
51505 K(I,4)=I1
51506 ELSE
51507 K(I,5)=I1
51508 ENDIF
51509 190 CONTINUE
51510 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
51511 IF(K(I,4).NE.0) GOTO 220
51512C...Find daughters who point to documentation daughters who,
51513C...in their turn, point to documentation mother.
51514 ID1=IM
51515 ID2=IM
51516 DO 200 I1=IM+1,I-1
51517 IF(K(I1,3).EQ.IM.AND.K(I1,1).GT.20.AND.K(I1,1).LE.30) THEN
51518 ID2=I1
51519 IF(ID1.EQ.IM) ID1=I1
51520 ENDIF
51521 200 CONTINUE
51522 DO 210 I1=I+1,N
51523 IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
51524 ELSEIF(K(I,4).EQ.0) THEN
51525 K(I,4)=I1
51526 ELSE
51527 K(I,5)=I1
51528 ENDIF
51529 210 CONTINUE
51530 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
51531 220 CONTINUE
51532
51533C...Save top entries at bottom of PYJETS commonblock.
51534 ELSEIF(MEDIT.EQ.21) THEN
51535 IF(2*N.GE.MSTU(4)) THEN
51536 CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS')
51537 RETURN
51538 ENDIF
51539 DO 240 I=1,N
51540 DO 230 J=1,5
51541 K(MSTU(4)-I,J)=K(I,J)
51542 P(MSTU(4)-I,J)=P(I,J)
51543 V(MSTU(4)-I,J)=V(I,J)
51544 230 CONTINUE
51545 240 CONTINUE
51546 MSTU(32)=N
51547
51548C...Restore bottom entries of commonblock PYJETS to top.
51549 ELSEIF(MEDIT.EQ.22) THEN
51550 DO 260 I=1,MSTU(32)
51551 DO 250 J=1,5
51552 K(I,J)=K(MSTU(4)-I,J)
51553 P(I,J)=P(MSTU(4)-I,J)
51554 V(I,J)=V(MSTU(4)-I,J)
51555 250 CONTINUE
51556 260 CONTINUE
51557 N=MSTU(32)
51558
51559C...Mark primary entries at top of commonblock PYJETS as untreated.
51560 ELSEIF(MEDIT.EQ.23) THEN
51561 I1=0
51562 DO 270 I=1,N
51563 KH=K(I,3)
51564 IF(KH.GE.1) THEN
51565 IF(K(KH,1).GT.20) KH=0
51566 ENDIF
51567 IF(KH.NE.0) GOTO 280
51568 I1=I1+1
51569 IF(K(I,1).GT.10.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
51570 270 CONTINUE
51571 280 N=I1
51572
51573C...Place largest axis along z axis and second largest in xy plane.
51574 ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
51575 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1),
51576 & P(MSTU(61),2)),0D0,0D0,0D0)
51577 CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3),
51578 & P(MSTU(61),1)),0D0,0D0,0D0,0D0)
51579 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1),
51580 & P(MSTU(61)+1,2)),0D0,0D0,0D0)
51581 IF(MEDIT.EQ.31) RETURN
51582
51583C...Rotate to put slim jet along +z axis.
51584 DO 290 IS=1,2
51585 NS(IS)=0
51586 PTS(IS)=0D0
51587 PLS(IS)=0D0
51588 290 CONTINUE
51589 DO 300 I=1,N
51590 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300
51591 IF(MSTU(41).GE.2) THEN
51592 KC=PYCOMP(K(I,2))
51593 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
51594 & KC.EQ.18) GOTO 300
51595 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
51596 & .EQ.0) GOTO 300
51597 ENDIF
51598 IS=2D0-SIGN(0.5D0,P(I,3))
51599 NS(IS)=NS(IS)+1
51600 PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
51601 300 CONTINUE
51602 IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
51603 & CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0)
51604
51605C...Rotate to put second largest jet into -z,+x quadrant.
51606 DO 310 I=1,N
51607 IF(P(I,3).GE.0D0) GOTO 310
51608 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310
51609 IF(MSTU(41).GE.2) THEN
51610 KC=PYCOMP(K(I,2))
51611 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
51612 & KC.EQ.18) GOTO 310
51613 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
51614 & .EQ.0) GOTO 310
51615 ENDIF
51616 IS=2D0-SIGN(0.5D0,P(I,1))
51617 PLS(IS)=PLS(IS)-P(I,3)
51618 310 CONTINUE
51619 IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1),
51620 & 0D0,0D0,0D0)
51621 ENDIF
51622
51623 RETURN
51624 END
51625
51626C*********************************************************************
51627
51628C...PYLIST
51629C...Gives program heading, or lists an event, or particle
51630C...data, or current parameter values.
51631
51632 SUBROUTINE PYLIST(MLIST)
51633
51634C...Double precision and integer declarations.
51635 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51636 IMPLICIT INTEGER(I-N)
51637 INTEGER PYK,PYCHGE,PYCOMP
51638C...Parameter statement to help give large particle numbers.
51639 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
51640 &KEXCIT=4000000,KDIMEN=5000000)
51641
51642C...HEPEVT commonblock.
51643 PARAMETER (NMXHEP=4000)
51644 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
51645 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
51646 DOUBLE PRECISION PHEP,VHEP
51647 SAVE /HEPEVT/
51648
51649C...User process event common block.
51650 INTEGER MAXNUP
51651 PARAMETER (MAXNUP=500)
51652 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
51653 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
51654 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
51655 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
51656 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
51657 SAVE /HEPEUP/
51658
51659C...Commonblocks.
51660 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
51661 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51662 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51663 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
51664 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
51665C...Local arrays, character variables and data.
51666 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
51667 DIMENSION PS(6)
51668 DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/
51669
51670C...Initialization printout: version number and date of last change.
51671 IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
51672 CALL PYLOGO
51673 MSTU(12)=0
51674 IF(MLIST.EQ.0) RETURN
51675 ENDIF
51676
51677C...List event data, including additional lines after N.
51678 IF(MLIST.GE.1.AND.MLIST.LE.3) THEN
51679 IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
51680 IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
51681 IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
51682 LMX=12
51683 IF(MLIST.GE.2) LMX=16
51684 ISTR=0
51685 IMAX=N
51686 IF(MSTU(2).GT.0) IMAX=MSTU(2)
51687 DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
51688 IF(I.GT.IMAX.AND.I.LE.N) GOTO 120
51689 IF(MSTU(15).EQ.0.AND.K(I,1).LE.0) GOTO 120
51690 IF(MSTU(15).EQ.1.AND.K(I,1).LT.0) GOTO 120
51691
51692C...Get particle name, pad it and check it is not too long.
51693 CALL PYNAME(K(I,2),CHAP)
51694 LEN=0
51695 DO 100 LEM=1,16
51696 IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
51697 100 CONTINUE
51698 MDL=(K(I,1)+19)/10
51699 LDL=0
51700 IF(MDL.EQ.2.OR.MDL.GE.8) THEN
51701 CHAC=CHAP
51702 IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
51703 ELSE
51704 LDL=1
51705 IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
51706 IF(LEN.EQ.0) THEN
51707 CHAC=CHDL(MDL)(1:2*LDL)//' '
51708 ELSE
51709 CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
51710 & CHDL(MDL)(LDL+1:2*LDL)//' '
51711 IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
51712 ENDIF
51713 ENDIF
51714
51715C...Add information on string connection.
51716 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
51717 & THEN
51718 KC=PYCOMP(K(I,2))
51719 KCC=0
51720 IF(KC.NE.0) KCC=KCHG(KC,2)
51721 IF(IABS(K(I,2)).EQ.39) THEN
51722 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
51723 ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
51724 ISTR=1
51725 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
51726 ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
51727 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
51728 ELSEIF(KCC.NE.0) THEN
51729 ISTR=0
51730 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
51731 ENDIF
51732 ENDIF
51733
51734C...Write data for particle/jet.
51735 IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) THEN
51736 WRITE(MSTU(11),5400) I,CHAC(1:12),(K(I,J1),J1=1,3),
51737 & (P(I,J2),J2=1,5)
51738 ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999D0) THEN
51739 WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
51740 & (P(I,J2),J2=1,5)
51741 ELSEIF(MLIST.EQ.1) THEN
51742 WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
51743 & (P(I,J2),J2=1,5)
51744 ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
51745 & K(I,1).EQ.14)) THEN
51746 WRITE(MSTU(11),5700) I,CHAC,(K(I,J1),J1=1,3),
51747 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
51748 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
51749 & (P(I,J2),J2=1,5)
51750 ELSE
51751 WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,5),
51752 & (P(I,J2),J2=1,5)
51753 ENDIF
51754 IF(MLIST.EQ.3) WRITE(MSTU(11),5900) (V(I,J),J=1,5)
51755
51756C...Insert extra separator lines specified by user.
51757 IF(MSTU(70).GE.1) THEN
51758 ISEP=0
51759 DO 110 J=1,MIN(10,MSTU(70))
51760 IF(I.EQ.MSTU(70+J)) ISEP=1
51761 110 CONTINUE
51762 IF(ISEP.EQ.1.AND.MLIST.EQ.1) WRITE(MSTU(11),6000)
51763 IF(ISEP.EQ.1.AND.MLIST.GE.2) WRITE(MSTU(11),6100)
51764 ENDIF
51765 120 CONTINUE
51766
51767C...Sum of charges and momenta.
51768 DO 130 J=1,6
51769 PS(J)=PYP(0,J)
51770 130 CONTINUE
51771 IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999D0) THEN
51772 WRITE(MSTU(11),6200) PS(6),(PS(J),J=1,5)
51773 ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN
51774 WRITE(MSTU(11),6300) PS(6),(PS(J),J=1,5)
51775 ELSEIF(MLIST.EQ.1) THEN
51776 WRITE(MSTU(11),6400) PS(6),(PS(J),J=1,5)
51777 ELSE
51778 WRITE(MSTU(11),6500) PS(6),(PS(J),J=1,5)
51779 ENDIF
51780
51781C...Simple listing of HEPEVT entries (mainly for test purposes).
51782 ELSEIF(MLIST.EQ.5) THEN
51783 WRITE(MSTU(11),7500)
51784 DO 140 I=1,NHEP
51785 IF(ISTHEP(I).EQ.0) GOTO 140
51786 WRITE(MSTU(11),7600) I,ISTHEP(I),IDHEP(I),JMOHEP(1,I),
51787 & JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),(PHEP(J,I),J=1,5)
51788 140 CONTINUE
51789
51790
51791C...Simple listing of user-process entries (mainly for test purposes).
51792 ELSEIF(MLIST.EQ.7) THEN
51793 WRITE(MSTU(11),7300)
51794 DO 150 I=1,NUP
51795 WRITE(MSTU(11),7400) I,ISTUP(I),IDUP(I),MOTHUP(1,I),
51796 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5)
51797 150 CONTINUE
51798
51799C...Give simple list of KF codes defined in program.
51800 ELSEIF(MLIST.EQ.11) THEN
51801 WRITE(MSTU(11),6600)
51802 DO 160 KF=1,80
51803 CALL PYNAME(KF,CHAP)
51804 CALL PYNAME(-KF,CHAN)
51805 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
51806 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
51807 160 CONTINUE
51808 DO 190 KFLS=1,3,2
51809 DO 180 KFLA=1,5
51810 DO 170 KFLB=1,KFLA-(3-KFLS)/2
51811 KF=1000*KFLA+100*KFLB+KFLS
51812 CALL PYNAME(KF,CHAP)
51813 CALL PYNAME(-KF,CHAN)
51814 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
51815 170 CONTINUE
51816 180 CONTINUE
51817 190 CONTINUE
51818 DO 220 KMUL=0,5
51819 KFLS=3
51820 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
51821 IF(KMUL.EQ.5) KFLS=5
51822 KFLR=0
51823 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
51824 IF(KMUL.EQ.4) KFLR=2
51825 DO 210 KFLB=1,5
51826 DO 200 KFLC=1,KFLB-1
51827 KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
51828 CALL PYNAME(KF,CHAP)
51829 CALL PYNAME(-KF,CHAN)
51830 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
51831 IF(KF.EQ.311) THEN
51832 KFK=130
51833 CALL PYNAME(KFK,CHAP)
51834 WRITE(MSTU(11),6700) KFK,CHAP
51835 KFK=310
51836 CALL PYNAME(KFK,CHAP)
51837 WRITE(MSTU(11),6700) KFK,CHAP
51838 ENDIF
51839 200 CONTINUE
51840 KF=10000*KFLR+110*KFLB+KFLS
51841 CALL PYNAME(KF,CHAP)
51842 WRITE(MSTU(11),6700) KF,CHAP
51843 210 CONTINUE
51844 220 CONTINUE
51845 KF=100443
51846 CALL PYNAME(KF,CHAP)
51847 WRITE(MSTU(11),6700) KF,CHAP
51848 KF=100553
51849 CALL PYNAME(KF,CHAP)
51850 WRITE(MSTU(11),6700) KF,CHAP
51851 DO 260 KFLSP=1,3
51852 KFLS=2+2*(KFLSP/3)
51853 DO 250 KFLA=1,5
51854 DO 240 KFLB=1,KFLA
51855 DO 230 KFLC=1,KFLB
51856 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC))
51857 & GOTO 230
51858 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 230
51859 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
51860 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
51861 CALL PYNAME(KF,CHAP)
51862 CALL PYNAME(-KF,CHAN)
51863 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
51864 230 CONTINUE
51865 240 CONTINUE
51866 250 CONTINUE
51867 260 CONTINUE
51868 DO 270 KC=1,500
51869 KF=KCHG(KC,4)
51870 IF(KF.LT.1000000) GOTO 270
51871 CALL PYNAME(KF,CHAP)
51872 CALL PYNAME(-KF,CHAN)
51873 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
51874 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
51875 270 CONTINUE
51876
51877C...List parton/particle data table. Check whether to be listed.
51878 ELSEIF(MLIST.EQ.12) THEN
51879 WRITE(MSTU(11),6800)
51880 DO 300 KC=1,MSTU(6)
51881 KF=KCHG(KC,4)
51882 IF(KF.EQ.0) GOTO 300
51883 IF(KF.LT.MSTU(1).OR.(MSTU(2).GT.0.AND.KF.GT.MSTU(2)))
51884 & GOTO 300
51885
51886C...Find particle name and mass. Print information.
51887 CALL PYNAME(KF,CHAP)
51888 IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 300
51889 CALL PYNAME(-KF,CHAN)
51890 WRITE(MSTU(11),6900) KF,KC,CHAP,CHAN,(KCHG(KC,J1),J1=1,3),
51891 & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
51892
51893C...Particle decay: channel number, branching ratios, matrix element,
51894C...decay products.
51895 DO 290 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
51896 DO 280 J=1,5
51897 CALL PYNAME(KFDP(IDC,J),CHAD(J))
51898 280 CONTINUE
51899 WRITE(MSTU(11),7000) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
51900 & (CHAD(J),J=1,5)
51901 290 CONTINUE
51902 300 CONTINUE
51903
51904C...List parameter value table.
51905 ELSEIF(MLIST.EQ.13) THEN
51906 WRITE(MSTU(11),7100)
51907 DO 310 I=1,200
51908 WRITE(MSTU(11),7200) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
51909 310 CONTINUE
51910 ENDIF
51911
51912C...Format statements for output on unit MSTU(11) (by default 6).
51913 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
51914 &5X,'KF orig p_x p_y p_z E m'/)
51915 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet',
51916 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
51917 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
51918 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j',
51919 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
51920 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X,
51921 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
51922 5400 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3)
51923 5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2)
51924 5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1)
51925 5700 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5)
51926 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5)
51927 5900 FORMAT(66X,5(1X,F12.3))
51928 6000 FORMAT(1X,78('='))
51929 6100 FORMAT(1X,130('='))
51930 6200 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
51931 6300 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
51932 6400 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
51933 6500 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
51934 &5F13.5)
51935 6600 FORMAT(///20X,'List of KF codes in program'/)
51936 6700 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16)
51937 6800 FORMAT(///30X,'Particle/parton data table'//8X,'KF',5X,'KC',4X,
51938 &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X,
51939 &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
51940 &1X,'ME',3X,'Br.rat.',4X,'decay products')
51941 6900 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
51942 &1X,1P,E13.5,3X,I2)
51943 7000 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16)
51944 7100 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
51945 &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
51946 7200 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
51947 7300 FORMAT(/10X,'Event listing of user process at input (simplified)'
51948 &//' I IST ID Mothers Colours p_x p_y p_z',
51949 &' E m')
51950 7400 FORMAT(1X,I3,I3,I8,2I4,2I5,5F9.3)
51951 7500 FORMAT(/10X,'Event listing of HEPEVT common block (simplified)'
51952 &//' I IST ID Mothers Daughters p_x p_y p_z',
51953 &' E m')
51954 7600 FORMAT(1X,I4,I2,I8,4I5,5F9.3)
51955
51956 RETURN
51957 END
51958
51959C*********************************************************************
51960
51961C...PYLOGO
51962C...Writes a logo for the program.
51963
51964 SUBROUTINE PYLOGO
51965
51966C...Double precision and integer declarations.
51967 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51968 IMPLICIT INTEGER(I-N)
51969 INTEGER PYK,PYCHGE,PYCOMP
51970C...Parameter for length of information block.
51971 PARAMETER (IREFER=18)
51972C...Commonblocks.
51973 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51974 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
51975 SAVE /PYDAT1/,/PYPARS/
51976C...Local arrays and character variables.
51977 INTEGER IDATI(6)
51978 CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79,
51979 &VERS*1, SUBV*3, DATE*2, YEAR*4, HOUR*2, MINU*2, SECO*2
51980
51981C...Data on months, logo, titles, and references.
51982 DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
51983 &'Oct','Nov','Dec'/
51984 DATA (LOGO(J),J=1,19)/
51985 &' *......* ',
51986 &' *:::!!:::::::::::* ',
51987 &' *::::::!!::::::::::::::* ',
51988 &' *::::::::!!::::::::::::::::* ',
51989 &' *:::::::::!!:::::::::::::::::* ',
51990 &' *:::::::::!!:::::::::::::::::* ',
51991 &' *::::::::!!::::::::::::::::*! ',
51992 &' *::::::!!::::::::::::::* !! ',
51993 &' !! *:::!!:::::::::::* !! ',
51994 &' !! !* -><- * !! ',
51995 &' !! !! !! ',
51996 &' !! !! !! ',
51997 &' !! !! ',
51998 &' !! lh !! ',
51999 &' !! !! ',
52000 &' !! hh !! ',
52001 &' !! ll !! ',
52002 &' !! !! ',
52003 &' !! '/
52004 DATA (LOGO(J),J=20,38)/
52005 &'Welcome to the Lund Monte Carlo!',
52006 &' ',
52007 &'PPP Y Y TTTTT H H III A ',
52008 &'P P Y Y T H H I A A ',
52009 &'PPP Y T HHHHH I AAAAA',
52010 &'P Y T H H I A A',
52011 &'P Y T H H III A A',
52012 &' ',
52013 &'This is PYTHIA version x.xxx ',
52014 &'Last date of change: xx xxx 199x',
52015 &' ',
52016 &'Now is xx xxx 199x at xx:xx:xx ',
52017 &' ',
52018 &'Disclaimer: this program comes ',
52019 &'without any guarantees. Beware ',
52020 &'of errors and use common sense ',
52021 &'when interpreting results. ',
52022 &' ',
52023 &'Copyright T. Sjostrand (2001) '/
52024 DATA (REFER(J),J=1,18)/
52025 &'An archive of program versions and d',
52026 &'ocumentation is found on the web: ',
52027 &'http://www.thep.lu.se/~torbjorn/Pyth',
52028 &'ia.html ',
52029 &' ',
52030 &' ',
52031 &'When you cite this program, currentl',
52032 &'y the official reference is ',
52033 &'T. Sjostrand, P. Eden, C. Friberg, L',
52034 &'. Lonnblad, G. Miu, S. Mrenna and ',
52035 &'E. Norrbin, Computer Physics Commun.',
52036 &' 135 (2001) 238. ',
52037 &'The large manual is ',
52038 &' ',
52039 &'T. Sjostrand, L. Lonnblad and S. Mre',
52040 &'nna, LU TP 01-21 [hep-ph/0108264]. ',
52041 &'Also remember that the program, to a',
52042 &' large extent, represents original '/
52043 DATA (REFER(J),J=19,2*IREFER)/
52044 &'physics research. Other publications',
52045 &' of special relevance to your ',
52046 &'studies may therefore deserve separa',
52047 &'te mention. ',
52048 &' ',
52049 &' ',
52050 &'Main author: Torbjorn Sjostrand; Dep',
52051 &'artment of Theoretical Physics 2, ',
52052 &' Lund University, Solvegatan 14A, S',
52053 &'-223 62 Lund, Sweden; ',
52054 &' phone: + 46 - 46 - 222 48 16; e-ma',
52055 &'il: torbjorn@thep.lu.se ',
52056 &'SUSY author: Stephen Mrenna, Physics',
52057 &' Department, UC Davis, ',
52058 &' One Shields Avenue, Davis, CA 9561',
52059 &'6, USA; ',
52060 &' phone: + 1 - 530 - 752 - 2661; e-m',
52061 &'ail: mrenna@physics.ucdavis.edu '/
52062
52063C...Check that PYDATA linked.
52064 IF(MSTP(183)/10.NE.199.AND.MSTP(183)/10.NE.200) THEN
52065 WRITE(*,'(1X,A)')
52066 & 'Error: PYDATA has not been linked.'
52067 WRITE(*,'(1X,A)') 'Execution stopped!'
52068 STOP
52069
52070C...Write current version number and current date+time.
52071 ELSE
52072 WRITE(VERS,'(I1)') MSTP(181)
52073 LOGO(28)(24:24)=VERS
52074 WRITE(SUBV,'(I3)') MSTP(182)
52075 LOGO(28)(26:28)=SUBV
52076 IF(MSTP(182).LT.100) LOGO(28)(26:26)='0'
52077 WRITE(DATE,'(I2)') MSTP(185)
52078 LOGO(29)(22:23)=DATE
52079 LOGO(29)(25:27)=MONTH(MSTP(184))
52080 WRITE(YEAR,'(I4)') MSTP(183)
52081 LOGO(29)(29:32)=YEAR
52082 CALL PYTIME(IDATI)
52083 IF(IDATI(1).LE.0) THEN
52084 LOGO(31)=' '
52085 ELSE
52086 WRITE(DATE,'(I2)') IDATI(3)
52087 LOGO(31)(8:9)=DATE
52088 LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2))))
52089 WRITE(YEAR,'(I4)') IDATI(1)
52090 LOGO(31)(15:18)=YEAR
52091 WRITE(HOUR,'(I2)') IDATI(4)
52092 LOGO(31)(23:24)=HOUR
52093 WRITE(MINU,'(I2)') IDATI(5)
52094 LOGO(31)(26:27)=MINU
52095 IF(IDATI(5).LT.10) LOGO(31)(26:26)='0'
52096 WRITE(SECO,'(I2)') IDATI(6)
52097 LOGO(31)(29:30)=SECO
52098 IF(IDATI(6).LT.10) LOGO(31)(29:29)='0'
52099 ENDIF
52100 ENDIF
52101
52102C...Loop over lines in header. Define page feed and side borders.
52103 DO 100 ILIN=1,29+IREFER
52104 LINE=' '
52105 IF(ILIN.EQ.1) THEN
52106 LINE(1:1)='1'
52107 ELSE
52108 LINE(2:3)='**'
52109 LINE(78:79)='**'
52110 ENDIF
52111
52112C...Separator lines and logos.
52113 IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN
52114 LINE(4:77)='***********************************************'//
52115 & '***************************'
52116 ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN
52117 LINE(6:37)=LOGO(ILIN-5)
52118 LINE(44:75)=LOGO(ILIN+14)
52119 ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN
52120 LINE(5:40)=REFER(2*ILIN-51)
52121 LINE(41:76)=REFER(2*ILIN-50)
52122 ENDIF
52123
52124C...Write lines to appropriate unit.
52125 WRITE(MSTU(11),'(A79)') LINE
52126 100 CONTINUE
52127
52128 RETURN
52129 END
52130
52131C*********************************************************************
52132
52133C...PYUPDA
52134C...Facilitates the updating of particle and decay data
52135C...by allowing it to be done in an external file.
52136
52137 SUBROUTINE PYUPDA(MUPDA,LFN)
52138
52139C...Double precision and integer declarations.
52140 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52141 IMPLICIT INTEGER(I-N)
52142 INTEGER PYK,PYCHGE,PYCOMP
52143C...Commonblocks.
52144 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52145 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52146 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
52147 COMMON/PYDAT4/CHAF(500,2)
52148 CHARACTER CHAF*16
52149 COMMON/PYINT4/MWID(500),WIDS(500,5)
52150 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/
52151C...Local arrays, character variables and data.
52152 CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72,
52153 &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24
52154 DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
52155 &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
52156 &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
52157 &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
52158 &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
52159
52160C...Write header if not yet done.
52161 IF(MSTU(12).GE.1) CALL PYLIST(0)
52162
52163C...Write information on file for editing.
52164 IF(MUPDA.EQ.1) THEN
52165 DO 110 KC=1,500
52166 WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
52167 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
52168 & MWID(KC),MDCY(KC,1)
52169 DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
52170 WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
52171 & (KFDP(IDC,J),J=1,5)
52172 100 CONTINUE
52173 110 CONTINUE
52174
52175C...Read complete set of information from edited file or
52176C...read partial set of new or updated information from edited file.
52177 ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN
52178
52179C...Reset counters.
52180 KCC=100
52181 NDC=0
52182 CHKF=' '
52183 IF(MUPDA.EQ.2) THEN
52184 DO 120 I=1,MSTU(6)
52185 KCHG(I,4)=0
52186 120 CONTINUE
52187 ELSE
52188 DO 130 KC=1,MSTU(6)
52189 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
52190 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
52191 130 CONTINUE
52192 ENDIF
52193
52194C...Begin of loop: read new line; unknown whether particle or
52195C...decay data.
52196 140 READ(LFN,5200,END=190) CHINL
52197
52198C...Identify particle code and whether already defined (for MUPDA=3).
52199 IF(CHINL(2:10).NE.' ') THEN
52200 CHKF=CHINL(2:10)
52201 READ(CHKF,5300) KF
52202 IF(MUPDA.EQ.2) THEN
52203 IF(KF.LE.100) THEN
52204 KC=KF
52205 ELSE
52206 KCC=KCC+1
52207 KC=KCC
52208 ENDIF
52209 ELSE
52210 KCREP=0
52211 IF(KF.LE.100) THEN
52212 KCREP=KF
52213 ELSE
52214 DO 150 KCR=101,KCC
52215 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
52216 150 CONTINUE
52217 ENDIF
52218C...Remove duplicate old decay data.
52219 IF(KCREP.NE.0.AND.MDCY(KCREP,3).GT.0) THEN
52220 IDCREP=MDCY(KCREP,2)
52221 NDCREP=MDCY(KCREP,3)
52222 DO 160 I=1,KCC
52223 IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP
52224 160 CONTINUE
52225 DO 180 I=IDCREP,NDC-NDCREP
52226 MDME(I,1)=MDME(I+NDCREP,1)
52227 MDME(I,2)=MDME(I+NDCREP,2)
52228 BRAT(I)=BRAT(I+NDCREP)
52229 DO 170 J=1,5
52230 KFDP(I,J)=KFDP(I+NDCREP,J)
52231 170 CONTINUE
52232 180 CONTINUE
52233 NDC=NDC-NDCREP
52234 KC=KCREP
52235 ELSEIF(KCREP.NE.0) THEN
52236 KC=KCREP
52237 ELSE
52238 KCC=KCC+1
52239 KC=KCC
52240 ENDIF
52241 ENDIF
52242
52243C...Study line with particle data.
52244 IF(KC.GT.MSTU(6)) CALL PYERRM(27,
52245 & '(PYUPDA:) Particle arrays full by KF ='//CHKF)
52246 READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
52247 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
52248 & MWID(KC),MDCY(KC,1)
52249 MDCY(KC,2)=0
52250 MDCY(KC,3)=0
52251
52252C...Study line with decay data.
52253 ELSE
52254 NDC=NDC+1
52255 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
52256 & '(PYUPDA:) Decay data arrays full by KF ='//CHKF)
52257 IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC
52258 MDCY(KC,3)=MDCY(KC,3)+1
52259 READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC),
52260 & (KFDP(NDC,J),J=1,5)
52261 ENDIF
52262
52263C...End of loop; ensure that PYCOMP tables are updated.
52264 GOTO 140
52265 190 CONTINUE
52266 MSTU(20)=0
52267
52268C...Perform possible tests that new information is consistent.
52269 DO 220 KC=1,MSTU(6)
52270 KF=KCHG(KC,4)
52271 IF(KF.EQ.0) GOTO 220
52272 WRITE(CHKF,5300) KF
52273 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
52274 & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17,
52275 & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF)
52276 BRSUM=0D0
52277 DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
52278 IF(MDME(IDC,2).GT.80) GOTO 210
52279 KQ=KCHG(KC,1)
52280 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
52281 MERR=0
52282 DO 200 J=1,5
52283 KP=KFDP(IDC,J)
52284 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
52285 IF(KP.EQ.81) KQ=0
52286 ELSEIF(PYCOMP(KP).EQ.0) THEN
52287 MERR=3
52288 ELSE
52289 KQ=KQ-PYCHGE(KP)
52290 KPC=PYCOMP(KP)
52291 PMS=PMS-PMAS(KPC,1)
52292 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
52293 & PMAS(KPC,3))
52294 ENDIF
52295 200 CONTINUE
52296 IF(KQ.NE.0) MERR=MAX(2,MERR)
52297 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
52298 & MERR=MAX(1,MERR)
52299 IF(MERR.EQ.3) CALL PYERRM(17,
52300 & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF)
52301 IF(MERR.EQ.2) CALL PYERRM(17,
52302 & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF)
52303 IF(MERR.EQ.1) CALL PYERRM(7,
52304 & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF)
52305 BRSUM=BRSUM+BRAT(IDC)
52306 210 CONTINUE
52307 WRITE(CHTMP,5500) BRSUM
52308 IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0)
52309 & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '//
52310 & CHTMP(9:16)//' for KF ='//CHKF)
52311 220 CONTINUE
52312
52313C...Write DATA statements for inclusion in program.
52314 ELSEIF(MUPDA.EQ.4) THEN
52315
52316C...Find out how many codes and decay channels are actually used.
52317 KCC=0
52318 NDC=0
52319 DO 230 I=1,MSTU(6)
52320 IF(KCHG(I,4).NE.0) THEN
52321 KCC=I
52322 NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1)
52323 ENDIF
52324 230 CONTINUE
52325
52326C...Initialize writing of DATA statements for inclusion in program.
52327 DO 300 IVAR=1,22
52328 NDIM=MSTU(6)
52329 IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7)
52330 NLIN=1
52331 CHLIN=' '
52332 CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/'
52333 LLIN=35
52334 CHOLD='START'
52335
52336C...Loop through variables for conversion to characters.
52337 DO 280 IDIM=1,NDIM
52338 IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
52339 IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
52340 IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
52341 IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4)
52342 IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1)
52343 IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2)
52344 IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3)
52345 IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4)
52346 IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1)
52347 IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2)
52348 IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3)
52349 IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1)
52350 IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2)
52351 IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM)
52352 IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1)
52353 IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2)
52354 IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3)
52355 IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4)
52356 IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5)
52357 IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1)
52358 IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2)
52359 IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM)
52360
52361C...Replace variables beyond what is properly defined.
52362 IF(IVAR.LE.4) THEN
52363 IF(IDIM.GT.KCC) CHTMP=' 0'
52364 ELSEIF(IVAR.LE.8) THEN
52365 IF(IDIM.GT.KCC) CHTMP=' 0.0'
52366 ELSEIF(IVAR.LE.11) THEN
52367 IF(IDIM.GT.KCC) CHTMP=' 0'
52368 ELSEIF(IVAR.LE.13) THEN
52369 IF(IDIM.GT.NDC) CHTMP=' 0'
52370 ELSEIF(IVAR.LE.14) THEN
52371 IF(IDIM.GT.NDC) CHTMP=' 0.0'
52372 ELSEIF(IVAR.LE.19) THEN
52373 IF(IDIM.GT.NDC) CHTMP=' 0'
52374 ELSEIF(IVAR.LE.21) THEN
52375 IF(IDIM.GT.KCC) CHTMP=' '
52376 ELSE
52377 IF(IDIM.GT.KCC) CHTMP=' 0'
52378 ENDIF
52379
52380C...Length of variable, trailing decimal zeros, quotation marks.
52381 LLOW=1
52382 LHIG=1
52383 DO 240 LL=1,16
52384 IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL
52385 IF(CHTMP(LL:LL).NE.' ') LHIG=LL
52386 240 CONTINUE
52387 CHNEW=CHTMP(LLOW:LHIG)//' '
52388 LNEW=1+LHIG-LLOW
52389 IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN
52390 LNEW=LNEW+1
52391 250 LNEW=LNEW-1
52392 IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250
52393 IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1
52394 IF(LNEW.EQ.0) THEN
52395 CHNEW(1:3)='0D0'
52396 LNEW=3
52397 ELSE
52398 CHNEW(LNEW+1:LNEW+2)='D0'
52399 LNEW=LNEW+2
52400 ENDIF
52401 ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN
52402 DO 260 LL=LNEW,1,-1
52403 IF(CHNEW(LL:LL).EQ.'''') THEN
52404 CHTMP=CHNEW
52405 CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
52406 LNEW=LNEW+1
52407 ENDIF
52408 260 CONTINUE
52409 LNEW=MIN(14,LNEW)
52410 CHTMP=CHNEW
52411 CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
52412 LNEW=LNEW+2
52413 ENDIF
52414
52415C...Form composite character string, often including repetition counter.
52416 IF(CHNEW.NE.CHOLD) THEN
52417 NRPT=1
52418 CHOLD=CHNEW
52419 CHCOM=CHNEW
52420 LCOM=LNEW
52421 ELSE
52422 LRPT=LNEW+1
52423 IF(NRPT.GE.2) LRPT=LNEW+3
52424 IF(NRPT.GE.10) LRPT=LNEW+4
52425 IF(NRPT.GE.100) LRPT=LNEW+5
52426 IF(NRPT.GE.1000) LRPT=LNEW+6
52427 LLIN=LLIN-LRPT
52428 NRPT=NRPT+1
52429 WRITE(CHTMP,5400) NRPT
52430 LRPT=1
52431 IF(NRPT.GE.10) LRPT=2
52432 IF(NRPT.GE.100) LRPT=3
52433 IF(NRPT.GE.1000) LRPT=4
52434 CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW)
52435 LCOM=LRPT+1+LNEW
52436 ENDIF
52437
52438C...Add characters to end of line, to new line (after storing old line),
52439C...or to new block of lines (after writing old block).
52440 IF(LLIN+LCOM.LE.70) THEN
52441 CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
52442 LLIN=LLIN+LCOM+1
52443 ELSEIF(NLIN.LE.19) THEN
52444 CHLIN(LLIN+1:72)=' '
52445 CHBLK(NLIN)=CHLIN
52446 NLIN=NLIN+1
52447 CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
52448 LLIN=6+LCOM+1
52449 ELSE
52450 CHLIN(LLIN:72)='/'//' '
52451 CHBLK(NLIN)=CHLIN
52452 WRITE(CHTMP,5400) IDIM-NRPT
52453 CHBLK(1)(30:33)=CHTMP(13:16)
52454 DO 270 ILIN=1,NLIN
52455 WRITE(LFN,5700) CHBLK(ILIN)
52456 270 CONTINUE
52457 NLIN=1
52458 CHLIN=' '
52459 CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//
52460 & ',I= , )/'//CHCOM(1:LCOM)//','
52461 WRITE(CHTMP,5400) IDIM-NRPT+1
52462 CHLIN(25:28)=CHTMP(13:16)
52463 LLIN=35+LCOM+1
52464 ENDIF
52465 280 CONTINUE
52466
52467C...Write final block of lines.
52468 CHLIN(LLIN:72)='/'//' '
52469 CHBLK(NLIN)=CHLIN
52470 WRITE(CHTMP,5400) NDIM
52471 CHBLK(1)(30:33)=CHTMP(13:16)
52472 DO 290 ILIN=1,NLIN
52473 WRITE(LFN,5700) CHBLK(ILIN)
52474 290 CONTINUE
52475 300 CONTINUE
52476 ENDIF
52477
52478C...Formats for reading and writing particle data.
52479 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3)
52480 5100 FORMAT(10X,2I5,F12.6,5I10)
52481 5200 FORMAT(A120)
52482 5300 FORMAT(I9)
52483 5400 FORMAT(I16)
52484 5500 FORMAT(F16.5)
52485 5600 FORMAT(F16.6)
52486 5700 FORMAT(A72)
52487
52488 RETURN
52489 END
52490
52491C*********************************************************************
52492
52493C...PYK
52494C...Provides various integer-valued event related data.
52495
52496 FUNCTION PYK(I,J)
52497
52498C...Double precision and integer declarations.
52499 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52500 IMPLICIT INTEGER(I-N)
52501 INTEGER PYK,PYCHGE,PYCOMP
52502C...Commonblocks.
52503 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
52504 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52505 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52506 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
52507
52508C...Default value. For I=0 number of entries, number of stable entries
52509C...or 3 times total charge.
52510 PYK=0
52511 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
52512 ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
52513 PYK=N
52514 ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
52515 DO 100 I1=1,N
52516 IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1
52517 IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+
52518 & PYCHGE(K(I1,2))
52519 100 CONTINUE
52520 ELSEIF(I.EQ.0) THEN
52521
52522C...For I > 0 direct readout of K matrix or charge.
52523 ELSEIF(J.LE.5) THEN
52524 PYK=K(I,J)
52525 ELSEIF(J.EQ.6) THEN
52526 PYK=PYCHGE(K(I,2))
52527
52528C...Status (existing/fragmented/decayed), parton/hadron separation.
52529 ELSEIF(J.LE.8) THEN
52530 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1
52531 IF(J.EQ.8) PYK=PYK*K(I,2)
52532 ELSEIF(J.LE.12) THEN
52533 KFA=IABS(K(I,2))
52534 KC=PYCOMP(KFA)
52535 KQ=0
52536 IF(KC.NE.0) KQ=KCHG(KC,2)
52537 IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2)
52538 IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2)
52539 IF(J.EQ.11) PYK=KC
52540 IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2))
52541
52542C...Heaviest flavour in hadron/diquark.
52543 ELSEIF(J.EQ.13) THEN
52544 KFA=IABS(K(I,2))
52545 PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
52546 IF(KFA.LT.10) PYK=KFA
52547 IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10)
52548 PYK=PYK*ISIGN(1,K(I,2))
52549
52550C...Particle history: generation, ancestor, rank.
52551 ELSEIF(J.LE.15) THEN
52552 I2=I
52553 I1=I
52554 110 PYK=PYK+1
52555 I2=I1
52556 I1=K(I1,3)
52557 IF(I1.GT.0) THEN
52558 IF(K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
52559 ENDIF
52560 IF(J.EQ.15) PYK=I2
52561 ELSEIF(J.EQ.16) THEN
52562 KFA=IABS(K(I,2))
52563 IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
52564 & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
52565 I1=I
52566 120 I2=I1
52567 I1=K(I1,3)
52568 IF(I1.GT.0) THEN
52569 KFAM=IABS(K(I1,2))
52570 ILP=1
52571 IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
52572 IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
52573 & ILP=0
52574 IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
52575 IF(ILP.EQ.1) GOTO 120
52576 ENDIF
52577 IF(K(I1,1).EQ.12) THEN
52578 DO 130 I3=I1+1,I2
52579 IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
52580 & .AND.K(I3,2).NE.93) PYK=PYK+1
52581 130 CONTINUE
52582 ELSE
52583 I3=I2
52584 140 PYK=PYK+1
52585 I3=I3+1
52586 IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
52587 ENDIF
52588 ENDIF
52589
52590C...Particle coming from collapsing jet system or not.
52591 ELSEIF(J.EQ.17) THEN
52592 I1=I
52593 150 PYK=PYK+1
52594 I3=I1
52595 I1=K(I1,3)
52596 I0=MAX(1,I1)
52597 KC=PYCOMP(K(I0,2))
52598 IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
52599 IF(PYK.EQ.1) PYK=-1
52600 IF(PYK.GT.1) PYK=0
52601 RETURN
52602 ENDIF
52603 IF(KCHG(KC,2).EQ.0) GOTO 150
52604 IF(K(I1,1).NE.12) PYK=0
52605 IF(K(I1,1).NE.12) RETURN
52606 I2=I1
52607 160 I2=I2+1
52608 IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
52609 K3M=K(I3-1,3)
52610 IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0
52611 K3P=K(I3+1,3)
52612 IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0
52613
52614C...Number of decay products. Colour flow.
52615 ELSEIF(J.EQ.18) THEN
52616 IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1)
52617 IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0
52618 ELSEIF(J.LE.22) THEN
52619 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
52620 IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5))
52621 IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5))
52622 IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5))
52623 IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5))
52624 ELSE
52625 ENDIF
52626
52627 RETURN
52628 END
52629
52630C*********************************************************************
52631
52632C...PYP
52633C...Provides various real-valued event related data.
52634
52635 FUNCTION PYP(I,J)
52636
52637C...Double precision and integer declarations.
52638 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52639 IMPLICIT INTEGER(I-N)
52640 INTEGER PYK,PYCHGE,PYCOMP
52641C...Commonblocks.
52642 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
52643 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52644 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52645 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
52646C...Local array.
52647 DIMENSION PSUM(4)
52648
52649C...Set default value. For I = 0 sum of momenta or charges,
52650C...or invariant mass of system.
52651 PYP=0D0
52652 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
52653 ELSEIF(I.EQ.0.AND.J.LE.4) THEN
52654 DO 100 I1=1,N
52655 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J)
52656 100 CONTINUE
52657 ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
52658 DO 120 J1=1,4
52659 PSUM(J1)=0D0
52660 DO 110 I1=1,N
52661 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+
52662 & P(I1,J1)
52663 110 CONTINUE
52664 120 CONTINUE
52665 PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
52666 ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
52667 DO 130 I1=1,N
52668 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0
52669 130 CONTINUE
52670 ELSEIF(I.EQ.0) THEN
52671
52672C...Direct readout of P matrix.
52673 ELSEIF(J.LE.5) THEN
52674 PYP=P(I,J)
52675
52676C...Charge, total momentum, transverse momentum, transverse mass.
52677 ELSEIF(J.LE.12) THEN
52678 IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0
52679 IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2
52680 IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2
52681 IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2
52682 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP)
52683
52684C...Theta and phi angle in radians or degrees.
52685 ELSEIF(J.LE.16) THEN
52686 IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
52687 IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2))
52688 IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1)
52689
52690C...True rapidity, rapidity with pion mass, pseudorapidity.
52691 ELSEIF(J.LE.19) THEN
52692 PMR=0D0
52693 IF(J.EQ.17) PMR=P(I,5)
52694 IF(J.EQ.18) PMR=PYMASS(211)
52695 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
52696 PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
52697 & 1D20)),P(I,3))
52698
52699C...Energy and momentum fractions (only to be used in CM frame).
52700 ELSEIF(J.LE.25) THEN
52701 IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
52702 IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21)
52703 IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
52704 IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21)
52705 IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21)
52706 IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21)
52707 ENDIF
52708
52709 RETURN
52710 END
52711
52712C*********************************************************************
52713
52714C...PYSPHE
52715C...Performs sphericity tensor analysis to give sphericity,
52716C...aplanarity and the related event axes.
52717
52718 SUBROUTINE PYSPHE(SPH,APL)
52719
52720C...Double precision and integer declarations.
52721 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52722 IMPLICIT INTEGER(I-N)
52723 INTEGER PYK,PYCHGE,PYCOMP
52724C...Commonblocks.
52725 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
52726 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52727 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52728 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
52729C...Local arrays.
52730 DIMENSION SM(3,3),SV(3,3)
52731
52732C...Calculate matrix to be diagonalized.
52733 NP=0
52734 DO 110 J1=1,3
52735 DO 100 J2=J1,3
52736 SM(J1,J2)=0D0
52737 100 CONTINUE
52738 110 CONTINUE
52739 PS=0D0
52740 DO 140 I=1,N
52741 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
52742 IF(MSTU(41).GE.2) THEN
52743 KC=PYCOMP(K(I,2))
52744 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
52745 & KC.EQ.18) GOTO 140
52746 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
52747 & GOTO 140
52748 ENDIF
52749 NP=NP+1
52750 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
52751 PWT=1D0
52752 IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT=
52753 & MAX(1D-10,PA)**(PARU(41)-2D0)
52754 DO 130 J1=1,3
52755 DO 120 J2=J1,3
52756 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
52757 120 CONTINUE
52758 130 CONTINUE
52759 PS=PS+PWT*PA**2
52760 140 CONTINUE
52761
52762C...Very low multiplicities (0 or 1) not considered.
52763 IF(NP.LE.1) THEN
52764 CALL PYERRM(8,'(PYSPHE:) too few particles for analysis')
52765 SPH=-1D0
52766 APL=-1D0
52767 RETURN
52768 ENDIF
52769 DO 160 J1=1,3
52770 DO 150 J2=J1,3
52771 SM(J1,J2)=SM(J1,J2)/PS
52772 150 CONTINUE
52773 160 CONTINUE
52774
52775C...Find eigenvalues to matrix (third degree equation).
52776 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
52777 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
52778 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
52779 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
52780 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
52781 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
52782 P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
52783 P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP)
52784 P(N+2,4)=1D0-P(N+1,4)-P(N+3,4)
52785 IF(P(N+2,4).LT.1D-5) THEN
52786 CALL PYERRM(8,'(PYSPHE:) all particles back-to-back')
52787 SPH=-1D0
52788 APL=-1D0
52789 RETURN
52790 ENDIF
52791
52792C...Find first and last eigenvector by solving equation system.
52793 DO 240 I=1,3,2
52794 DO 180 J1=1,3
52795 SV(J1,J1)=SM(J1,J1)-P(N+I,4)
52796 DO 170 J2=J1+1,3
52797 SV(J1,J2)=SM(J1,J2)
52798 SV(J2,J1)=SM(J1,J2)
52799 170 CONTINUE
52800 180 CONTINUE
52801 SMAX=0D0
52802 DO 200 J1=1,3
52803 DO 190 J2=1,3
52804 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
52805 JA=J1
52806 JB=J2
52807 SMAX=ABS(SV(J1,J2))
52808 190 CONTINUE
52809 200 CONTINUE
52810 SMAX=0D0
52811 DO 220 J3=JA+1,JA+2
52812 J1=J3-3*((J3-1)/3)
52813 RL=SV(J1,JB)/SV(JA,JB)
52814 DO 210 J2=1,3
52815 SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
52816 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
52817 JC=J1
52818 SMAX=ABS(SV(J1,J2))
52819 210 CONTINUE
52820 220 CONTINUE
52821 JB1=JB+1-3*(JB/3)
52822 JB2=JB+2-3*((JB+1)/3)
52823 P(N+I,JB1)=-SV(JC,JB2)
52824 P(N+I,JB2)=SV(JC,JB1)
52825 P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
52826 & SV(JA,JB)
52827 PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
52828 SGN=(-1D0)**INT(PYR(0)+0.5D0)
52829 DO 230 J=1,3
52830 P(N+I,J)=SGN*P(N+I,J)/PA
52831 230 CONTINUE
52832 240 CONTINUE
52833
52834C...Middle axis orthogonal to other two. Fill other codes.
52835 SGN=(-1D0)**INT(PYR(0)+0.5D0)
52836 P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
52837 P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
52838 P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
52839 DO 260 I=1,3
52840 K(N+I,1)=31
52841 K(N+I,2)=95
52842 K(N+I,3)=I
52843 K(N+I,4)=0
52844 K(N+I,5)=0
52845 P(N+I,5)=0D0
52846 DO 250 J=1,5
52847 V(I,J)=0D0
52848 250 CONTINUE
52849 260 CONTINUE
52850
52851C...Calculate sphericity and aplanarity. Select storing option.
52852 SPH=1.5D0*(P(N+2,4)+P(N+3,4))
52853 APL=1.5D0*P(N+3,4)
52854 MSTU(61)=N+1
52855 MSTU(62)=NP
52856 IF(MSTU(43).LE.1) MSTU(3)=3
52857 IF(MSTU(43).GE.2) N=N+3
52858
52859 RETURN
52860 END
52861
52862C*********************************************************************
52863
52864C...PYTHRU
52865C...Performs thrust analysis to give thrust, oblateness
52866C...and the related event axes.
52867
52868 SUBROUTINE PYTHRU(THR,OBL)
52869
52870C...Double precision and integer declarations.
52871 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52872 IMPLICIT INTEGER(I-N)
52873 INTEGER PYK,PYCHGE,PYCOMP
52874C...Commonblocks.
52875 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
52876 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52877 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52878 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
52879C...Local arrays.
52880 DIMENSION TDI(3),TPR(3)
52881
52882C...Take copy of particles that are to be considered in thrust analysis.
52883 NP=0
52884 PS=0D0
52885 DO 100 I=1,N
52886 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
52887 IF(MSTU(41).GE.2) THEN
52888 KC=PYCOMP(K(I,2))
52889 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
52890 & KC.EQ.18) GOTO 100
52891 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
52892 & GOTO 100
52893 ENDIF
52894 IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
52895 CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS')
52896 THR=-2D0
52897 OBL=-2D0
52898 RETURN
52899 ENDIF
52900 NP=NP+1
52901 K(N+NP,1)=23
52902 P(N+NP,1)=P(I,1)
52903 P(N+NP,2)=P(I,2)
52904 P(N+NP,3)=P(I,3)
52905 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
52906 P(N+NP,5)=1D0
52907 IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)=
52908 & P(N+NP,4)**(PARU(42)-1D0)
52909 PS=PS+P(N+NP,4)*P(N+NP,5)
52910 100 CONTINUE
52911
52912C...Very low multiplicities (0 or 1) not considered.
52913 IF(NP.LE.1) THEN
52914 CALL PYERRM(8,'(PYTHRU:) too few particles for analysis')
52915 THR=-1D0
52916 OBL=-1D0
52917 RETURN
52918 ENDIF
52919
52920C...Loop over thrust and major. T axis along z direction in latter case.
52921 DO 320 ILD=1,2
52922 IF(ILD.EQ.2) THEN
52923 K(N+NP+1,1)=31
52924 PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2))
52925 MSTU(33)=1
52926 CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0)
52927 THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1))
52928 CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0)
52929 ENDIF
52930
52931C...Find and order particles with highest p (pT for major).
52932 DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
52933 P(ILF,4)=0D0
52934 110 CONTINUE
52935 DO 160 I=N+1,N+NP
52936 IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
52937 DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
52938 IF(P(I,4).LE.P(ILF,4)) GOTO 140
52939 DO 120 J=1,5
52940 P(ILF+1,J)=P(ILF,J)
52941 120 CONTINUE
52942 130 CONTINUE
52943 ILF=N+NP+3
52944 140 DO 150 J=1,5
52945 P(ILF+1,J)=P(I,J)
52946 150 CONTINUE
52947 160 CONTINUE
52948
52949C...Find and order initial axes with highest thrust (major).
52950 DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
52951 P(ILG,4)=0D0
52952 170 CONTINUE
52953 NC=2**(MIN(MSTU(44),NP)-1)
52954 DO 250 ILC=1,NC
52955 DO 180 J=1,3
52956 TDI(J)=0D0
52957 180 CONTINUE
52958 DO 200 ILF=1,MIN(MSTU(44),NP)
52959 SGN=P(N+NP+ILF+3,5)
52960 IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
52961 DO 190 J=1,4-ILD
52962 TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
52963 190 CONTINUE
52964 200 CONTINUE
52965 TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
52966 DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
52967 IF(TDS.LE.P(ILG,4)) GOTO 230
52968 DO 210 J=1,4
52969 P(ILG+1,J)=P(ILG,J)
52970 210 CONTINUE
52971 220 CONTINUE
52972 ILG=N+NP+MSTU(44)+4
52973 230 DO 240 J=1,3
52974 P(ILG+1,J)=TDI(J)
52975 240 CONTINUE
52976 P(ILG+1,4)=TDS
52977 250 CONTINUE
52978
52979C...Iterate direction of axis until stable maximum.
52980 P(N+NP+ILD,4)=0D0
52981 ILG=0
52982 260 ILG=ILG+1
52983 THP=0D0
52984 270 THPS=THP
52985 DO 280 J=1,3
52986 IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
52987 IF(THP.GT.1D-10) TDI(J)=TPR(J)
52988 TPR(J)=0D0
52989 280 CONTINUE
52990 DO 300 I=N+1,N+NP
52991 SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
52992 DO 290 J=1,4-ILD
52993 TPR(J)=TPR(J)+SGN*P(I,J)
52994 290 CONTINUE
52995 300 CONTINUE
52996 THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
52997 IF(THP.GE.THPS+PARU(48)) GOTO 270
52998
52999C...Save good axis. Try new initial axis until a number of tries agree.
53000 IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260
53001 IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
53002 IAGR=0
53003 SGN=(-1D0)**INT(PYR(0)+0.5D0)
53004 DO 310 J=1,3
53005 P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
53006 310 CONTINUE
53007 P(N+NP+ILD,4)=THP
53008 P(N+NP+ILD,5)=0D0
53009 ENDIF
53010 IAGR=IAGR+1
53011 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
53012 320 CONTINUE
53013
53014C...Find minor axis and value by orthogonality.
53015 SGN=(-1D0)**INT(PYR(0)+0.5D0)
53016 P(N+NP+3,1)=-SGN*P(N+NP+2,2)
53017 P(N+NP+3,2)=SGN*P(N+NP+2,1)
53018 P(N+NP+3,3)=0D0
53019 THP=0D0
53020 DO 330 I=N+1,N+NP
53021 THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
53022 330 CONTINUE
53023 P(N+NP+3,4)=THP/PS
53024 P(N+NP+3,5)=0D0
53025
53026C...Fill axis information. Rotate back to original coordinate system.
53027 DO 350 ILD=1,3
53028 K(N+ILD,1)=31
53029 K(N+ILD,2)=96
53030 K(N+ILD,3)=ILD
53031 K(N+ILD,4)=0
53032 K(N+ILD,5)=0
53033 DO 340 J=1,5
53034 P(N+ILD,J)=P(N+NP+ILD,J)
53035 V(N+ILD,J)=0D0
53036 340 CONTINUE
53037 350 CONTINUE
53038 CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0)
53039
53040C...Calculate thrust and oblateness. Select storing option.
53041 THR=P(N+1,4)
53042 OBL=P(N+2,4)-P(N+3,4)
53043 MSTU(61)=N+1
53044 MSTU(62)=NP
53045 IF(MSTU(43).LE.1) MSTU(3)=3
53046 IF(MSTU(43).GE.2) N=N+3
53047
53048 RETURN
53049 END
53050
53051C*********************************************************************
53052
53053C...PYCLUS
53054C...Subdivides the particle content of an event into jets/clusters.
53055
53056 SUBROUTINE PYCLUS(NJET)
53057
53058C...Double precision and integer declarations.
53059 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53060 IMPLICIT INTEGER(I-N)
53061 INTEGER PYK,PYCHGE,PYCOMP
53062C...Commonblocks.
53063 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
53064 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53065 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53066 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
53067C...Local arrays and saved variables.
53068 DIMENSION PS(5)
53069 SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
53070
53071C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
53072 R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
53073 &P(I1,3)*P(I2,3))*2D0*P(I1,5)*P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2
53074 R2M(I1,I2)=2D0*P(I1,4)*P(I2,4)*(1D0-(P(I1,1)*P(I2,1)+P(I1,2)*
53075 &P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
53076 R2D(I1,I2)=2D0*MIN(P(I1,4),P(I2,4))**2*(1D0-(P(I1,1)*P(I2,1)+
53077 &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
53078
53079C...If first time, reset. If reentering, skip preliminaries.
53080 IF(MSTU(48).LE.0) THEN
53081 NP=0
53082 DO 100 J=1,5
53083 PS(J)=0D0
53084 100 CONTINUE
53085 PSS=0D0
53086 PIMASS=PMAS(PYCOMP(211),1)
53087 ELSE
53088 NJET=NSAV
53089 IF(MSTU(43).GE.2) N=N-NJET
53090 DO 110 I=N+1,N+NJET
53091 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
53092 110 CONTINUE
53093 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
53094 R2ACC=PARU(44)**2
53095 ELSE
53096 R2ACC=PARU(45)*PS(5)**2
53097 ENDIF
53098 NLOOP=0
53099 GOTO 300
53100 ENDIF
53101
53102C...Find which particles are to be considered in cluster search.
53103 DO 140 I=1,N
53104 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
53105 IF(MSTU(41).GE.2) THEN
53106 KC=PYCOMP(K(I,2))
53107 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
53108 & KC.EQ.18) GOTO 140
53109 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
53110 & GOTO 140
53111 ENDIF
53112 IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
53113 CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS')
53114 NJET=-1
53115 RETURN
53116 ENDIF
53117
53118C...Take copy of these particles, with space left for jets later on.
53119 NP=NP+1
53120 K(N+NP,3)=I
53121 DO 120 J=1,5
53122 P(N+NP,J)=P(I,J)
53123 120 CONTINUE
53124 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
53125 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
53126 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
53127 P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
53128 DO 130 J=1,4
53129 PS(J)=PS(J)+P(N+NP,J)
53130 130 CONTINUE
53131 PSS=PSS+P(N+NP,5)
53132 140 CONTINUE
53133 DO 160 I=N+1,N+NP
53134 K(I+NP,3)=K(I,3)
53135 DO 150 J=1,5
53136 P(I+NP,J)=P(I,J)
53137 150 CONTINUE
53138 160 CONTINUE
53139 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
53140
53141C...Very low multiplicities not considered.
53142 IF(NP.LT.MSTU(47)) THEN
53143 CALL PYERRM(8,'(PYCLUS:) too few particles for analysis')
53144 NJET=-1
53145 RETURN
53146 ENDIF
53147
53148C...Find precluster configuration. If too few jets, make harder cuts.
53149 NLOOP=0
53150 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
53151 R2ACC=PARU(44)**2
53152 ELSE
53153 R2ACC=PARU(45)*PS(5)**2
53154 ENDIF
53155 RINIT=1.25D0*PARU(43)
53156 IF(NP.LE.MSTU(47)+2) RINIT=0D0
53157 170 RINIT=0.8D0*RINIT
53158 NPRE=0
53159 NREM=NP
53160 DO 180 I=N+NP+1,N+2*NP
53161 K(I,4)=0
53162 180 CONTINUE
53163
53164C...Sum up small momentum region. Jet if enough absolute momentum.
53165 IF(MSTU(46).LE.2) THEN
53166 DO 190 J=1,4
53167 P(N+1,J)=0D0
53168 190 CONTINUE
53169 DO 210 I=N+NP+1,N+2*NP
53170 IF(P(I,5).GT.2D0*RINIT) GOTO 210
53171 NREM=NREM-1
53172 K(I,4)=1
53173 DO 200 J=1,4
53174 P(N+1,J)=P(N+1,J)+P(I,J)
53175 200 CONTINUE
53176 210 CONTINUE
53177 P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
53178 IF(P(N+1,5).GT.2D0*RINIT) NPRE=1
53179 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
53180 IF(NREM.EQ.0) GOTO 170
53181 ENDIF
53182
53183C...Find fastest remaining particle.
53184 220 NPRE=NPRE+1
53185 PMAX=0D0
53186 DO 230 I=N+NP+1,N+2*NP
53187 IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230
53188 IMAX=I
53189 PMAX=P(I,5)
53190 230 CONTINUE
53191 DO 240 J=1,5
53192 P(N+NPRE,J)=P(IMAX,J)
53193 240 CONTINUE
53194 NREM=NREM-1
53195 K(IMAX,4)=NPRE
53196
53197C...Sum up precluster around it according to pT separation.
53198 IF(MSTU(46).LE.2) THEN
53199 DO 260 I=N+NP+1,N+2*NP
53200 IF(K(I,4).NE.0) GOTO 260
53201 R2=R2T(I,IMAX)
53202 IF(R2.GT.RINIT**2) GOTO 260
53203 NREM=NREM-1
53204 K(I,4)=NPRE
53205 DO 250 J=1,4
53206 P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
53207 250 CONTINUE
53208 260 CONTINUE
53209 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
53210
53211C...Sum up precluster around it according to mass or
53212C...Durham pT separation.
53213 ELSE
53214 270 IMIN=0
53215 R2MIN=RINIT**2
53216 DO 280 I=N+NP+1,N+2*NP
53217 IF(K(I,4).NE.0) GOTO 280
53218 IF(MSTU(46).LE.4) THEN
53219 R2=R2M(I,N+NPRE)
53220 ELSE
53221 R2=R2D(I,N+NPRE)
53222 ENDIF
53223 IF(R2.GE.R2MIN) GOTO 280
53224 IMIN=I
53225 R2MIN=R2
53226 280 CONTINUE
53227 IF(IMIN.NE.0) THEN
53228 DO 290 J=1,4
53229 P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
53230 290 CONTINUE
53231 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
53232 NREM=NREM-1
53233 K(IMIN,4)=NPRE
53234 GOTO 270
53235 ENDIF
53236 ENDIF
53237
53238C...Check if more preclusters to be found. Start over if too few.
53239 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
53240 IF(NREM.GT.0) GOTO 220
53241 NJET=NPRE
53242
53243C...Reassign all particles to nearest jet. Sum up new jet momenta.
53244 300 TSAV=0D0
53245 PSJT=0D0
53246 310 IF(MSTU(46).LE.1) THEN
53247 DO 330 I=N+1,N+NJET
53248 DO 320 J=1,4
53249 V(I,J)=0D0
53250 320 CONTINUE
53251 330 CONTINUE
53252 DO 360 I=N+NP+1,N+2*NP
53253 R2MIN=PSS**2
53254 DO 340 IJET=N+1,N+NJET
53255 IF(P(IJET,5).LT.RINIT) GOTO 340
53256 R2=R2T(I,IJET)
53257 IF(R2.GE.R2MIN) GOTO 340
53258 IMIN=IJET
53259 R2MIN=R2
53260 340 CONTINUE
53261 K(I,4)=IMIN-N
53262 DO 350 J=1,4
53263 V(IMIN,J)=V(IMIN,J)+P(I,J)
53264 350 CONTINUE
53265 360 CONTINUE
53266 PSJT=0D0
53267 DO 380 I=N+1,N+NJET
53268 DO 370 J=1,4
53269 P(I,J)=V(I,J)
53270 370 CONTINUE
53271 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
53272 PSJT=PSJT+P(I,5)
53273 380 CONTINUE
53274 ENDIF
53275
53276C...Find two closest jets.
53277 R2MIN=2D0*MAX(R2ACC,PS(5)**2)
53278 DO 400 ITRY1=N+1,N+NJET-1
53279 DO 390 ITRY2=ITRY1+1,N+NJET
53280 IF(MSTU(46).LE.2) THEN
53281 R2=R2T(ITRY1,ITRY2)
53282 ELSEIF(MSTU(46).LE.4) THEN
53283 R2=R2M(ITRY1,ITRY2)
53284 ELSE
53285 R2=R2D(ITRY1,ITRY2)
53286 ENDIF
53287 IF(R2.GE.R2MIN) GOTO 390
53288 IMIN1=ITRY1
53289 IMIN2=ITRY2
53290 R2MIN=R2
53291 390 CONTINUE
53292 400 CONTINUE
53293
53294C...If allowed, join two closest jets and start over.
53295 IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
53296 IREC=MIN(IMIN1,IMIN2)
53297 IDEL=MAX(IMIN1,IMIN2)
53298 DO 410 J=1,4
53299 P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
53300 410 CONTINUE
53301 P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
53302 DO 430 I=IDEL+1,N+NJET
53303 DO 420 J=1,5
53304 P(I-1,J)=P(I,J)
53305 420 CONTINUE
53306 430 CONTINUE
53307 IF(MSTU(46).GE.2) THEN
53308 DO 440 I=N+NP+1,N+2*NP
53309 IORI=N+K(I,4)
53310 IF(IORI.EQ.IDEL) K(I,4)=IREC-N
53311 IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
53312 440 CONTINUE
53313 ENDIF
53314 NJET=NJET-1
53315 GOTO 300
53316
53317C...Divide up broad jet if empty cluster in list of final ones.
53318 ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
53319 DO 450 I=N+1,N+NJET
53320 K(I,5)=0
53321 450 CONTINUE
53322 DO 460 I=N+NP+1,N+2*NP
53323 K(N+K(I,4),5)=K(N+K(I,4),5)+1
53324 460 CONTINUE
53325 IEMP=0
53326 DO 470 I=N+1,N+NJET
53327 IF(K(I,5).EQ.0) IEMP=I
53328 470 CONTINUE
53329 IF(IEMP.NE.0) THEN
53330 NLOOP=NLOOP+1
53331 ISPL=0
53332 R2MAX=0D0
53333 DO 480 I=N+NP+1,N+2*NP
53334 IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
53335 IJET=N+K(I,4)
53336 R2=R2T(I,IJET)
53337 IF(R2.LE.R2MAX) GOTO 480
53338 ISPL=I
53339 R2MAX=R2
53340 480 CONTINUE
53341 IF(ISPL.NE.0) THEN
53342 IJET=N+K(ISPL,4)
53343 DO 490 J=1,4
53344 P(IEMP,J)=P(ISPL,J)
53345 P(IJET,J)=P(IJET,J)-P(ISPL,J)
53346 490 CONTINUE
53347 P(IEMP,5)=P(ISPL,5)
53348 P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
53349 IF(NLOOP.LE.2) GOTO 300
53350 ENDIF
53351 ENDIF
53352 ENDIF
53353
53354C...If generalized thrust has not yet converged, continue iteration.
53355 IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
53356 &THEN
53357 TSAV=PSJT/PSS
53358 GOTO 310
53359 ENDIF
53360
53361C...Reorder jets according to energy.
53362 DO 510 I=N+1,N+NJET
53363 DO 500 J=1,5
53364 V(I,J)=P(I,J)
53365 500 CONTINUE
53366 510 CONTINUE
53367 DO 540 INEW=N+1,N+NJET
53368 PEMAX=0D0
53369 DO 520 ITRY=N+1,N+NJET
53370 IF(V(ITRY,4).LE.PEMAX) GOTO 520
53371 IMAX=ITRY
53372 PEMAX=V(ITRY,4)
53373 520 CONTINUE
53374 K(INEW,1)=31
53375 K(INEW,2)=97
53376 K(INEW,3)=INEW-N
53377 K(INEW,4)=0
53378 DO 530 J=1,5
53379 P(INEW,J)=V(IMAX,J)
53380 530 CONTINUE
53381 V(IMAX,4)=-1D0
53382 K(IMAX,5)=INEW
53383 540 CONTINUE
53384
53385C...Clean up particle-jet assignments and jet information.
53386 DO 550 I=N+NP+1,N+2*NP
53387 IORI=K(N+K(I,4),5)
53388 K(I,4)=IORI-N
53389 IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
53390 K(IORI,4)=K(IORI,4)+1
53391 550 CONTINUE
53392 IEMP=0
53393 PSJT=0D0
53394 DO 570 I=N+1,N+NJET
53395 K(I,5)=0
53396 PSJT=PSJT+P(I,5)
53397 P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0))
53398 DO 560 J=1,5
53399 V(I,J)=0D0
53400 560 CONTINUE
53401 IF(K(I,4).EQ.0) IEMP=I
53402 570 CONTINUE
53403
53404C...Select storing option. Output variables. Check for failure.
53405 MSTU(61)=N+1
53406 MSTU(62)=NP
53407 MSTU(63)=NPRE
53408 PARU(61)=PS(5)
53409 PARU(62)=PSJT/PSS
53410 PARU(63)=SQRT(R2MIN)
53411 IF(NJET.LE.1) PARU(63)=0D0
53412 IF(IEMP.NE.0) THEN
53413 CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested')
53414 NJET=-1
53415 RETURN
53416 ENDIF
53417 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
53418 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
53419 NSAV=NJET
53420
53421 RETURN
53422 END
53423
53424C*********************************************************************
53425
53426C...PYCELL
53427C...Provides a simple way of jet finding in eta-phi-ET coordinates,
53428C...as used for calorimeters at hadron colliders.
53429
53430 SUBROUTINE PYCELL(NJET)
53431
53432C...Double precision and integer declarations.
53433 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53434 IMPLICIT INTEGER(I-N)
53435 INTEGER PYK,PYCHGE,PYCOMP
53436C...Commonblocks.
53437 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
53438 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53439 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53440 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
53441
53442C...Loop over all particles. Find cell that was hit by given particle.
53443 PTLRAT=1D0/SINH(PARU(51))**2
53444 NP=0
53445 NC=N
53446 DO 110 I=1,N
53447 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
53448 IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
53449 IF(MSTU(41).GE.2) THEN
53450 KC=PYCOMP(K(I,2))
53451 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
53452 & KC.EQ.18) GOTO 110
53453 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
53454 & GOTO 110
53455 ENDIF
53456 NP=NP+1
53457 PT=SQRT(P(I,1)**2+P(I,2)**2)
53458 ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
53459 IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0*
53460 & (ETA/PARU(51)+1D0))))
53461 PHI=PYANGL(P(I,1),P(I,2))
53462 IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0*
53463 & (PHI/PARU(1)+1D0))))
53464 IETPH=MSTU(52)*IETA+IPHI
53465
53466C...Add to cell already hit, or book new cell.
53467 DO 100 IC=N+1,NC
53468 IF(IETPH.EQ.K(IC,3)) THEN
53469 K(IC,4)=K(IC,4)+1
53470 P(IC,5)=P(IC,5)+PT
53471 GOTO 110
53472 ENDIF
53473 100 CONTINUE
53474 IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
53475 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
53476 NJET=-2
53477 RETURN
53478 ENDIF
53479 NC=NC+1
53480 K(NC,3)=IETPH
53481 K(NC,4)=1
53482 K(NC,5)=2
53483 P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
53484 P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
53485 P(NC,5)=PT
53486 110 CONTINUE
53487
53488C...Smear true bin content by calorimeter resolution.
53489 IF(MSTU(53).GE.1) THEN
53490 DO 130 IC=N+1,NC
53491 PEI=P(IC,5)
53492 IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1))
53493 120 PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)*
53494 & COS(PARU(2)*PYR(0))
53495 IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120
53496 P(IC,5)=PEF
53497 IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
53498 130 CONTINUE
53499 ENDIF
53500
53501C...Remove cells below threshold.
53502 IF(PARU(58).GT.0D0) THEN
53503 NCC=NC
53504 NC=N
53505 DO 140 IC=N+1,NCC
53506 IF(P(IC,5).GT.PARU(58)) THEN
53507 NC=NC+1
53508 K(NC,3)=K(IC,3)
53509 K(NC,4)=K(IC,4)
53510 K(NC,5)=K(IC,5)
53511 P(NC,1)=P(IC,1)
53512 P(NC,2)=P(IC,2)
53513 P(NC,5)=P(IC,5)
53514 ENDIF
53515 140 CONTINUE
53516 ENDIF
53517
53518C...Find initiator cell: the one with highest pT of not yet used ones.
53519 NJ=NC
53520 150 ETMAX=0D0
53521 DO 160 IC=N+1,NC
53522 IF(K(IC,5).NE.2) GOTO 160
53523 IF(P(IC,5).LE.ETMAX) GOTO 160
53524 ICMAX=IC
53525 ETA=P(IC,1)
53526 PHI=P(IC,2)
53527 ETMAX=P(IC,5)
53528 160 CONTINUE
53529 IF(ETMAX.LT.PARU(52)) GOTO 220
53530 IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
53531 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
53532 NJET=-2
53533 RETURN
53534 ENDIF
53535 K(ICMAX,5)=1
53536 NJ=NJ+1
53537 K(NJ,4)=0
53538 K(NJ,5)=1
53539 P(NJ,1)=ETA
53540 P(NJ,2)=PHI
53541 P(NJ,3)=0D0
53542 P(NJ,4)=0D0
53543 P(NJ,5)=0D0
53544
53545C...Sum up unused cells within required distance of initiator.
53546 DO 170 IC=N+1,NC
53547 IF(K(IC,5).EQ.0) GOTO 170
53548 IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
53549 DPHIA=ABS(P(IC,2)-PHI)
53550 IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
53551 PHIC=P(IC,2)
53552 IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
53553 IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170
53554 K(IC,5)=-K(IC,5)
53555 K(NJ,4)=K(NJ,4)+K(IC,4)
53556 P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
53557 P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
53558 P(NJ,5)=P(NJ,5)+P(IC,5)
53559 170 CONTINUE
53560
53561C...Reject cluster below minimum ET, else accept.
53562 IF(P(NJ,5).LT.PARU(53)) THEN
53563 NJ=NJ-1
53564 DO 180 IC=N+1,NC
53565 IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
53566 180 CONTINUE
53567 ELSEIF(MSTU(54).LE.2) THEN
53568 P(NJ,3)=P(NJ,3)/P(NJ,5)
53569 P(NJ,4)=P(NJ,4)/P(NJ,5)
53570 IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
53571 & P(NJ,4))
53572 DO 190 IC=N+1,NC
53573 IF(K(IC,5).LT.0) K(IC,5)=0
53574 190 CONTINUE
53575 ELSE
53576 DO 200 J=1,4
53577 P(NJ,J)=0D0
53578 200 CONTINUE
53579 DO 210 IC=N+1,NC
53580 IF(K(IC,5).GE.0) GOTO 210
53581 P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
53582 P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
53583 P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
53584 P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
53585 K(IC,5)=0
53586 210 CONTINUE
53587 ENDIF
53588 GOTO 150
53589
53590C...Arrange clusters in falling ET sequence.
53591 220 DO 250 I=1,NJ-NC
53592 ETMAX=0D0
53593 DO 230 IJ=NC+1,NJ
53594 IF(K(IJ,5).EQ.0) GOTO 230
53595 IF(P(IJ,5).LT.ETMAX) GOTO 230
53596 IJMAX=IJ
53597 ETMAX=P(IJ,5)
53598 230 CONTINUE
53599 K(IJMAX,5)=0
53600 K(N+I,1)=31
53601 K(N+I,2)=98
53602 K(N+I,3)=I
53603 K(N+I,4)=K(IJMAX,4)
53604 K(N+I,5)=0
53605 DO 240 J=1,5
53606 P(N+I,J)=P(IJMAX,J)
53607 V(N+I,J)=0D0
53608 240 CONTINUE
53609 250 CONTINUE
53610 NJET=NJ-NC
53611
53612C...Convert to massless or massive four-vectors.
53613 IF(MSTU(54).EQ.2) THEN
53614 DO 260 I=N+1,N+NJET
53615 ETA=P(I,3)
53616 P(I,1)=P(I,5)*COS(P(I,4))
53617 P(I,2)=P(I,5)*SIN(P(I,4))
53618 P(I,3)=P(I,5)*SINH(ETA)
53619 P(I,4)=P(I,5)*COSH(ETA)
53620 P(I,5)=0D0
53621 260 CONTINUE
53622 ELSEIF(MSTU(54).GE.3) THEN
53623 DO 270 I=N+1,N+NJET
53624 P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
53625 270 CONTINUE
53626 ENDIF
53627
53628C...Information about storage.
53629 MSTU(61)=N+1
53630 MSTU(62)=NP
53631 MSTU(63)=NC-N
53632 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
53633 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
53634
53635 RETURN
53636 END
53637
53638C*********************************************************************
53639
53640C...PYJMAS
53641C...Determines, approximately, the two jet masses that minimize
53642C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
53643
53644 SUBROUTINE PYJMAS(PMH,PML)
53645
53646C...Double precision and integer declarations.
53647 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53648 IMPLICIT INTEGER(I-N)
53649 INTEGER PYK,PYCHGE,PYCOMP
53650C...Commonblocks.
53651 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
53652 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53653 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53654 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
53655C...Local arrays.
53656 DIMENSION SM(3,3),SAX(3),PS(3,5)
53657
53658C...Reset.
53659 NP=0
53660 DO 120 J1=1,3
53661 DO 100 J2=J1,3
53662 SM(J1,J2)=0D0
53663 100 CONTINUE
53664 DO 110 J2=1,4
53665 PS(J1,J2)=0D0
53666 110 CONTINUE
53667 120 CONTINUE
53668 PSS=0D0
53669 PIMASS=PMAS(PYCOMP(211),1)
53670
53671C...Take copy of particles that are to be considered in mass analysis.
53672 DO 170 I=1,N
53673 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
53674 IF(MSTU(41).GE.2) THEN
53675 KC=PYCOMP(K(I,2))
53676 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
53677 & KC.EQ.18) GOTO 170
53678 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
53679 & GOTO 170
53680 ENDIF
53681 IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
53682 CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS')
53683 PMH=-2D0
53684 PML=-2D0
53685 RETURN
53686 ENDIF
53687 NP=NP+1
53688 DO 130 J=1,5
53689 P(N+NP,J)=P(I,J)
53690 130 CONTINUE
53691 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
53692 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
53693 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
53694
53695C...Fill information in sphericity tensor and total momentum vector.
53696 DO 150 J1=1,3
53697 DO 140 J2=J1,3
53698 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
53699 140 CONTINUE
53700 150 CONTINUE
53701 PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
53702 DO 160 J=1,4
53703 PS(3,J)=PS(3,J)+P(N+NP,J)
53704 160 CONTINUE
53705 170 CONTINUE
53706
53707C...Very low multiplicities (0 or 1) not considered.
53708 IF(NP.LE.1) THEN
53709 CALL PYERRM(8,'(PYJMAS:) too few particles for analysis')
53710 PMH=-1D0
53711 PML=-1D0
53712 RETURN
53713 ENDIF
53714 PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-
53715 &PS(3,3)**2))
53716
53717C...Find largest eigenvalue to matrix (third degree equation).
53718 DO 190 J1=1,3
53719 DO 180 J2=J1,3
53720 SM(J1,J2)=SM(J1,J2)/PSS
53721 180 CONTINUE
53722 190 CONTINUE
53723 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
53724 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
53725 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
53726 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
53727 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
53728 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
53729 SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
53730
53731C...Find largest eigenvector by solving equation system.
53732 DO 210 J1=1,3
53733 SM(J1,J1)=SM(J1,J1)-SMA
53734 DO 200 J2=J1+1,3
53735 SM(J2,J1)=SM(J1,J2)
53736 200 CONTINUE
53737 210 CONTINUE
53738 SMAX=0D0
53739 DO 230 J1=1,3
53740 DO 220 J2=1,3
53741 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
53742 JA=J1
53743 JB=J2
53744 SMAX=ABS(SM(J1,J2))
53745 220 CONTINUE
53746 230 CONTINUE
53747 SMAX=0D0
53748 DO 250 J3=JA+1,JA+2
53749 J1=J3-3*((J3-1)/3)
53750 RL=SM(J1,JB)/SM(JA,JB)
53751 DO 240 J2=1,3
53752 SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
53753 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
53754 JC=J1
53755 SMAX=ABS(SM(J1,J2))
53756 240 CONTINUE
53757 250 CONTINUE
53758 JB1=JB+1-3*(JB/3)
53759 JB2=JB+2-3*((JB+1)/3)
53760 SAX(JB1)=-SM(JC,JB2)
53761 SAX(JB2)=SM(JC,JB1)
53762 SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
53763
53764C...Divide particles into two initial clusters by hemisphere.
53765 DO 270 I=N+1,N+NP
53766 PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
53767 IS=1
53768 IF(PSAX.LT.0D0) IS=2
53769 K(I,3)=IS
53770 DO 260 J=1,4
53771 PS(IS,J)=PS(IS,J)+P(I,J)
53772 260 CONTINUE
53773 270 CONTINUE
53774 PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
53775 &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
53776
53777C...Reassign one particle at a time; find maximum decrease of m^2 sum.
53778 280 PMD=0D0
53779 IM=0
53780 DO 290 J=1,4
53781 PS(3,J)=PS(1,J)-PS(2,J)
53782 290 CONTINUE
53783 DO 300 I=N+1,N+NP
53784 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)
53785 IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS)
53786 IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS)
53787 IF(PMDI.LT.PMD) THEN
53788 PMD=PMDI
53789 IM=I
53790 ENDIF
53791 300 CONTINUE
53792
53793C...Loop back if significant reduction in sum of m^2.
53794 IF(PMD.LT.-PARU(48)*PMS) THEN
53795 PMS=PMS+PMD
53796 IS=K(IM,3)
53797 DO 310 J=1,4
53798 PS(IS,J)=PS(IS,J)-P(IM,J)
53799 PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
53800 310 CONTINUE
53801 K(IM,3)=3-IS
53802 GOTO 280
53803 ENDIF
53804
53805C...Final masses and output.
53806 MSTU(61)=N+1
53807 MSTU(62)=NP
53808 PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
53809 PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
53810 PMH=MAX(PS(1,5),PS(2,5))
53811 PML=MIN(PS(1,5),PS(2,5))
53812
53813 RETURN
53814 END
53815
53816C*********************************************************************
53817
53818C...PYFOWO
53819C...Calculates the first few Fox-Wolfram moments.
53820
53821 SUBROUTINE PYFOWO(H10,H20,H30,H40)
53822
53823C...Double precision and integer declarations.
53824 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53825 IMPLICIT INTEGER(I-N)
53826 INTEGER PYK,PYCHGE,PYCOMP
53827C...Commonblocks.
53828 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
53829 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53830 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53831 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
53832
53833C...Copy momenta for particles and calculate H0.
53834 NP=0
53835 H0=0D0
53836 HD=0D0
53837 DO 110 I=1,N
53838 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
53839 IF(MSTU(41).GE.2) THEN
53840 KC=PYCOMP(K(I,2))
53841 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
53842 & KC.EQ.18) GOTO 110
53843 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
53844 & GOTO 110
53845 ENDIF
53846 IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
53847 CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS')
53848 H10=-1D0
53849 H20=-1D0
53850 H30=-1D0
53851 H40=-1D0
53852 RETURN
53853 ENDIF
53854 NP=NP+1
53855 DO 100 J=1,3
53856 P(N+NP,J)=P(I,J)
53857 100 CONTINUE
53858 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
53859 H0=H0+P(N+NP,4)
53860 HD=HD+P(N+NP,4)**2
53861 110 CONTINUE
53862 H0=H0**2
53863
53864C...Very low multiplicities (0 or 1) not considered.
53865 IF(NP.LE.1) THEN
53866 CALL PYERRM(8,'(PYFOWO:) too few particles for analysis')
53867 H10=-1D0
53868 H20=-1D0
53869 H30=-1D0
53870 H40=-1D0
53871 RETURN
53872 ENDIF
53873
53874C...Calculate H1 - H4.
53875 H10=0D0
53876 H20=0D0
53877 H30=0D0
53878 H40=0D0
53879 DO 130 I1=N+1,N+NP
53880 DO 120 I2=I1+1,N+NP
53881 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
53882 & (P(I1,4)*P(I2,4))
53883 H10=H10+P(I1,4)*P(I2,4)*CTHE
53884 H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0)
53885 H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE)
53886 H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+
53887 & 0.375D0)
53888 120 CONTINUE
53889 130 CONTINUE
53890
53891C...Calculate H1/H0 - H4/H0. Output.
53892 MSTU(61)=N+1
53893 MSTU(62)=NP
53894 H10=(HD+2D0*H10)/H0
53895 H20=(HD+2D0*H20)/H0
53896 H30=(HD+2D0*H30)/H0
53897 H40=(HD+2D0*H40)/H0
53898
53899 RETURN
53900 END
53901
53902C*********************************************************************
53903
53904C...PYTABU
53905C...Evaluates various properties of an event, with statistics
53906C...accumulated during the course of the run and
53907C...printed at the end.
53908
53909 SUBROUTINE PYTABU(MTABU)
53910
53911C...Double precision and integer declarations.
53912 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53913 IMPLICIT INTEGER(I-N)
53914 INTEGER PYK,PYCHGE,PYCOMP
53915C...Commonblocks.
53916 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
53917 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53918 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53919 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
53920 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
53921C...Local arrays, character variables, saved variables and data.
53922 DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
53923 &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
53924 &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
53925 &KFDM(8),KFDC(200,0:8),NPDC(200)
53926 SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
53927 &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
53928 &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
53929 CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
53930 DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
53931 &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/,
53932 &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/,
53933 &NEVDC/0/,NKFDC/0/,NREDC/0/
53934
53935C...Reset statistics on initial parton state.
53936 IF(MTABU.EQ.10) THEN
53937 NEVIS=0
53938 NKFIS=0
53939
53940C...Identify and order flavour content of initial state.
53941 ELSEIF(MTABU.EQ.11) THEN
53942 NEVIS=NEVIS+1
53943 KFM1=2*IABS(MSTU(161))
53944 IF(MSTU(161).GT.0) KFM1=KFM1-1
53945 KFM2=2*IABS(MSTU(162))
53946 IF(MSTU(162).GT.0) KFM2=KFM2-1
53947 KFMN=MIN(KFM1,KFM2)
53948 KFMX=MAX(KFM1,KFM2)
53949 DO 100 I=1,NKFIS
53950 IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
53951 IKFIS=-I
53952 GOTO 110
53953 ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
53954 & KFMX.LT.KFIS(I,2))) THEN
53955 IKFIS=I
53956 GOTO 110
53957 ENDIF
53958 100 CONTINUE
53959 IKFIS=NKFIS+1
53960 110 IF(IKFIS.LT.0) THEN
53961 IKFIS=-IKFIS
53962 ELSE
53963 IF(NKFIS.GE.100) RETURN
53964 DO 130 I=NKFIS,IKFIS,-1
53965 KFIS(I+1,1)=KFIS(I,1)
53966 KFIS(I+1,2)=KFIS(I,2)
53967 DO 120 J=0,10
53968 NPIS(I+1,J)=NPIS(I,J)
53969 120 CONTINUE
53970 130 CONTINUE
53971 NKFIS=NKFIS+1
53972 KFIS(IKFIS,1)=KFMN
53973 KFIS(IKFIS,2)=KFMX
53974 DO 140 J=0,10
53975 NPIS(IKFIS,J)=0
53976 140 CONTINUE
53977 ENDIF
53978 NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
53979
53980C...Count number of partons in initial state.
53981 NP=0
53982 DO 160 I=1,N
53983 IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
53984 ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
53985 ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
53986 & THEN
53987 ELSE
53988 IM=I
53989 150 IM=K(IM,3)
53990 IF(IM.LE.0.OR.IM.GT.N) THEN
53991 NP=NP+1
53992 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
53993 NP=NP+1
53994 ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
53995 ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10)
53996 & .NE.0) THEN
53997 ELSE
53998 GOTO 150
53999 ENDIF
54000 ENDIF
54001 160 CONTINUE
54002 NPCO=MAX(NP,1)
54003 IF(NP.GE.6) NPCO=6
54004 IF(NP.GE.8) NPCO=7
54005 IF(NP.GE.11) NPCO=8
54006 IF(NP.GE.16) NPCO=9
54007 IF(NP.GE.26) NPCO=10
54008 NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
54009 MSTU(62)=NP
54010
54011C...Write statistics on initial parton state.
54012 ELSEIF(MTABU.EQ.12) THEN
54013 FAC=1D0/MAX(1,NEVIS)
54014 WRITE(MSTU(11),5000) NEVIS
54015 DO 170 I=1,NKFIS
54016 KFMN=KFIS(I,1)
54017 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
54018 KFM1=(KFMN+1)/2
54019 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
54020 CALL PYNAME(KFM1,CHAU)
54021 CHIS(1)=CHAU(1:12)
54022 IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
54023 KFMX=KFIS(I,2)
54024 IF(KFIS(I,1).EQ.0) KFMX=0
54025 KFM2=(KFMX+1)/2
54026 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
54027 CALL PYNAME(KFM2,CHAU)
54028 CHIS(2)=CHAU(1:12)
54029 IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
54030 WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
54031 & (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10)
54032 170 CONTINUE
54033
54034C...Copy statistics on initial parton state into /PYJETS/.
54035 ELSEIF(MTABU.EQ.13) THEN
54036 FAC=1D0/MAX(1,NEVIS)
54037 DO 190 I=1,NKFIS
54038 KFMN=KFIS(I,1)
54039 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
54040 KFM1=(KFMN+1)/2
54041 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
54042 KFMX=KFIS(I,2)
54043 IF(KFIS(I,1).EQ.0) KFMX=0
54044 KFM2=(KFMX+1)/2
54045 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
54046 K(I,1)=32
54047 K(I,2)=99
54048 K(I,3)=KFM1
54049 K(I,4)=KFM2
54050 K(I,5)=NPIS(I,0)
54051 DO 180 J=1,5
54052 P(I,J)=FAC*NPIS(I,J)
54053 V(I,J)=FAC*NPIS(I,J+5)
54054 180 CONTINUE
54055 190 CONTINUE
54056 N=NKFIS
54057 DO 200 J=1,5
54058 K(N+1,J)=0
54059 P(N+1,J)=0D0
54060 V(N+1,J)=0D0
54061 200 CONTINUE
54062 K(N+1,1)=32
54063 K(N+1,2)=99
54064 K(N+1,5)=NEVIS
54065 MSTU(3)=1
54066
54067C...Reset statistics on number of particles/partons.
54068 ELSEIF(MTABU.EQ.20) THEN
54069 NEVFS=0
54070 NPRFS=0
54071 NFIFS=0
54072 NCHFS=0
54073 NKFFS=0
54074
54075C...Identify whether particle/parton is primary or not.
54076 ELSEIF(MTABU.EQ.21) THEN
54077 NEVFS=NEVFS+1
54078 MSTU(62)=0
54079 DO 260 I=1,N
54080 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260
54081 MSTU(62)=MSTU(62)+1
54082 KC=PYCOMP(K(I,2))
54083 MPRI=0
54084 IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
54085 MPRI=1
54086 ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
54087 MPRI=1
54088 ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
54089 MPRI=1
54090 ELSEIF(KC.EQ.0) THEN
54091 ELSEIF(K(K(I,3),1).EQ.13) THEN
54092 IM=K(K(I,3),3)
54093 IF(IM.LE.0.OR.IM.GT.N) THEN
54094 MPRI=1
54095 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
54096 MPRI=1
54097 ENDIF
54098 ELSEIF(KCHG(KC,2).EQ.0) THEN
54099 KCM=PYCOMP(K(K(I,3),2))
54100 IF(KCM.NE.0) THEN
54101 IF(KCHG(KCM,2).NE.0) MPRI=1
54102 ENDIF
54103 ENDIF
54104 IF(KC.NE.0.AND.MPRI.EQ.1) THEN
54105 IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
54106 ENDIF
54107 IF(K(I,1).LE.10) THEN
54108 NFIFS=NFIFS+1
54109 IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
54110 ENDIF
54111
54112C...Fill statistics on number of particles/partons in event.
54113 KFA=IABS(K(I,2))
54114 KFS=3-ISIGN(1,K(I,2))-MPRI
54115 DO 210 IP=1,NKFFS
54116 IF(KFA.EQ.KFFS(IP)) THEN
54117 IKFFS=-IP
54118 GOTO 220
54119 ELSEIF(KFA.LT.KFFS(IP)) THEN
54120 IKFFS=IP
54121 GOTO 220
54122 ENDIF
54123 210 CONTINUE
54124 IKFFS=NKFFS+1
54125 220 IF(IKFFS.LT.0) THEN
54126 IKFFS=-IKFFS
54127 ELSE
54128 IF(NKFFS.GE.400) RETURN
54129 DO 240 IP=NKFFS,IKFFS,-1
54130 KFFS(IP+1)=KFFS(IP)
54131 DO 230 J=1,4
54132 NPFS(IP+1,J)=NPFS(IP,J)
54133 230 CONTINUE
54134 240 CONTINUE
54135 NKFFS=NKFFS+1
54136 KFFS(IKFFS)=KFA
54137 DO 250 J=1,4
54138 NPFS(IKFFS,J)=0
54139 250 CONTINUE
54140 ENDIF
54141 NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
54142 260 CONTINUE
54143
54144C...Write statistics on particle/parton composition of events.
54145 ELSEIF(MTABU.EQ.22) THEN
54146 FAC=1D0/MAX(1,NEVFS)
54147 WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
54148 DO 270 I=1,NKFFS
54149 CALL PYNAME(KFFS(I),CHAU)
54150 KC=PYCOMP(KFFS(I))
54151 MDCYF=0
54152 IF(KC.NE.0) MDCYF=MDCY(KC,1)
54153 WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
54154 & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
54155 270 CONTINUE
54156
54157C...Copy particle/parton composition information into /PYJETS/.
54158 ELSEIF(MTABU.EQ.23) THEN
54159 FAC=1D0/MAX(1,NEVFS)
54160 DO 290 I=1,NKFFS
54161 K(I,1)=32
54162 K(I,2)=99
54163 K(I,3)=KFFS(I)
54164 K(I,4)=0
54165 K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
54166 DO 280 J=1,4
54167 P(I,J)=FAC*NPFS(I,J)
54168 V(I,J)=0D0
54169 280 CONTINUE
54170 P(I,5)=FAC*K(I,5)
54171 V(I,5)=0D0
54172 290 CONTINUE
54173 N=NKFFS
54174 DO 300 J=1,5
54175 K(N+1,J)=0
54176 P(N+1,J)=0D0
54177 V(N+1,J)=0D0
54178 300 CONTINUE
54179 K(N+1,1)=32
54180 K(N+1,2)=99
54181 K(N+1,5)=NEVFS
54182 P(N+1,1)=FAC*NPRFS
54183 P(N+1,2)=FAC*NFIFS
54184 P(N+1,3)=FAC*NCHFS
54185 MSTU(3)=1
54186
54187C...Reset factorial moments statistics.
54188 ELSEIF(MTABU.EQ.30) THEN
54189 NEVFM=0
54190 NMUFM=0
54191 DO 330 IM=1,3
54192 DO 320 IB=1,10
54193 DO 310 IP=1,4
54194 FM1FM(IM,IB,IP)=0D0
54195 FM2FM(IM,IB,IP)=0D0
54196 310 CONTINUE
54197 320 CONTINUE
54198 330 CONTINUE
54199
54200C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
54201 ELSEIF(MTABU.EQ.31) THEN
54202 NEVFM=NEVFM+1
54203 NLOW=N+MSTU(3)
54204 NUPP=NLOW
54205 DO 410 I=1,N
54206 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410
54207 IF(MSTU(41).GE.2) THEN
54208 KC=PYCOMP(K(I,2))
54209 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
54210 & KC.EQ.18) GOTO 410
54211 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
54212 & PYCHGE(K(I,2)).EQ.0) GOTO 410
54213 ENDIF
54214 PMR=0D0
54215 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
54216 IF(MSTU(42).GE.2) PMR=P(I,5)
54217 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
54218 YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
54219 & 1D20)),P(I,3))
54220 IF(ABS(YETA).GT.PARU(57)) GOTO 410
54221 PHI=PYANGL(P(I,1),P(I,2))
54222 IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57))
54223 IYETA=MAX(0,MIN(511,IYETA))
54224 IPHI=512D0*(PHI+PARU(1))/PARU(2)
54225 IPHI=MAX(0,MIN(511,IPHI))
54226 IYEP=0
54227 DO 340 IB=0,9
54228 IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
54229 340 CONTINUE
54230
54231C...Order particles in (pseudo)rapidity and/or azimuth.
54232 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
54233 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
54234 RETURN
54235 ENDIF
54236 NUPP=NUPP+1
54237 IF(NUPP.EQ.NLOW+1) THEN
54238 K(NUPP,1)=IYETA
54239 K(NUPP,2)=IPHI
54240 K(NUPP,3)=IYEP
54241 ELSE
54242 DO 350 I1=NUPP-1,NLOW+1,-1
54243 IF(IYETA.GE.K(I1,1)) GOTO 360
54244 K(I1+1,1)=K(I1,1)
54245 350 CONTINUE
54246 360 K(I1+1,1)=IYETA
54247 DO 370 I1=NUPP-1,NLOW+1,-1
54248 IF(IPHI.GE.K(I1,2)) GOTO 380
54249 K(I1+1,2)=K(I1,2)
54250 370 CONTINUE
54251 380 K(I1+1,2)=IPHI
54252 DO 390 I1=NUPP-1,NLOW+1,-1
54253 IF(IYEP.GE.K(I1,3)) GOTO 400
54254 K(I1+1,3)=K(I1,3)
54255 390 CONTINUE
54256 400 K(I1+1,3)=IYEP
54257 ENDIF
54258 410 CONTINUE
54259 K(NUPP+1,1)=2**10
54260 K(NUPP+1,2)=2**10
54261 K(NUPP+1,3)=4**10
54262
54263C...Calculate sum of factorial moments in event.
54264 DO 480 IM=1,3
54265 DO 430 IB=1,10
54266 DO 420 IP=1,4
54267 FEVFM(IB,IP)=0D0
54268 420 CONTINUE
54269 430 CONTINUE
54270 DO 450 IB=1,10
54271 IF(IM.LE.2) IBIN=2**(10-IB)
54272 IF(IM.EQ.3) IBIN=4**(10-IB)
54273 IAGR=K(NLOW+1,IM)/IBIN
54274 NAGR=1
54275 DO 440 I=NLOW+2,NUPP+1
54276 ICUT=K(I,IM)/IBIN
54277 IF(ICUT.EQ.IAGR) THEN
54278 NAGR=NAGR+1
54279 ELSE
54280 IF(NAGR.EQ.1) THEN
54281 ELSEIF(NAGR.EQ.2) THEN
54282 FEVFM(IB,1)=FEVFM(IB,1)+2D0
54283 ELSEIF(NAGR.EQ.3) THEN
54284 FEVFM(IB,1)=FEVFM(IB,1)+6D0
54285 FEVFM(IB,2)=FEVFM(IB,2)+6D0
54286 ELSEIF(NAGR.EQ.4) THEN
54287 FEVFM(IB,1)=FEVFM(IB,1)+12D0
54288 FEVFM(IB,2)=FEVFM(IB,2)+24D0
54289 FEVFM(IB,3)=FEVFM(IB,3)+24D0
54290 ELSE
54291 FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0)
54292 FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0)
54293 FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
54294 & (NAGR-3D0)
54295 FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
54296 & (NAGR-3D0)*(NAGR-4D0)
54297 ENDIF
54298 IAGR=ICUT
54299 NAGR=1
54300 ENDIF
54301 440 CONTINUE
54302 450 CONTINUE
54303
54304C...Add results to total statistics.
54305 DO 470 IB=10,1,-1
54306 DO 460 IP=1,4
54307 IF(FEVFM(1,IP).LT.0.5D0) THEN
54308 FEVFM(IB,IP)=0D0
54309 ELSEIF(IM.LE.2) THEN
54310 FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
54311 ELSE
54312 FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
54313 ENDIF
54314 FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
54315 FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
54316 460 CONTINUE
54317 470 CONTINUE
54318 480 CONTINUE
54319 NMUFM=NMUFM+(NUPP-NLOW)
54320 MSTU(62)=NUPP-NLOW
54321
54322C...Write accumulated statistics on factorial moments.
54323 ELSEIF(MTABU.EQ.32) THEN
54324 FAC=1D0/MAX(1,NEVFM)
54325 IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
54326 IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
54327 IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y '
54328 DO 510 IM=1,3
54329 WRITE(MSTU(11),5500)
54330 DO 500 IB=1,10
54331 BYETA=2D0*PARU(57)
54332 IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
54333 BPHI=PARU(2)
54334 IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
54335 IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1))
54336 IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1))
54337 DO 490 IP=1,4
54338 FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
54339 FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
54340 & FMOMA(IP)**2)))
54341 490 CONTINUE
54342 WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
54343 & IP=1,4)
54344 500 CONTINUE
54345 510 CONTINUE
54346
54347C...Copy statistics on factorial moments into /PYJETS/.
54348 ELSEIF(MTABU.EQ.33) THEN
54349 FAC=1D0/MAX(1,NEVFM)
54350 DO 540 IM=1,3
54351 DO 530 IB=1,10
54352 I=10*(IM-1)+IB
54353 K(I,1)=32
54354 K(I,2)=99
54355 K(I,3)=1
54356 IF(IM.NE.2) K(I,3)=2**(IB-1)
54357 K(I,4)=1
54358 IF(IM.NE.1) K(I,4)=2**(IB-1)
54359 K(I,5)=0
54360 P(I,1)=2D0*PARU(57)/K(I,3)
54361 V(I,1)=PARU(2)/K(I,4)
54362 DO 520 IP=1,4
54363 P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
54364 V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
54365 & P(I,IP+1)**2)))
54366 520 CONTINUE
54367 530 CONTINUE
54368 540 CONTINUE
54369 N=30
54370 DO 550 J=1,5
54371 K(N+1,J)=0
54372 P(N+1,J)=0D0
54373 V(N+1,J)=0D0
54374 550 CONTINUE
54375 K(N+1,1)=32
54376 K(N+1,2)=99
54377 K(N+1,5)=NEVFM
54378 MSTU(3)=1
54379
54380C...Reset statistics on Energy-Energy Correlation.
54381 ELSEIF(MTABU.EQ.40) THEN
54382 NEVEE=0
54383 DO 560 J=1,25
54384 FE1EC(J)=0D0
54385 FE2EC(J)=0D0
54386 FE1EC(51-J)=0D0
54387 FE2EC(51-J)=0D0
54388 FE1EA(J)=0D0
54389 FE2EA(J)=0D0
54390 560 CONTINUE
54391
54392C...Find particles to include, with proper assumed mass.
54393 ELSEIF(MTABU.EQ.41) THEN
54394 NEVEE=NEVEE+1
54395 NLOW=N+MSTU(3)
54396 NUPP=NLOW
54397 ECM=0D0
54398 DO 570 I=1,N
54399 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570
54400 IF(MSTU(41).GE.2) THEN
54401 KC=PYCOMP(K(I,2))
54402 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
54403 & KC.EQ.18) GOTO 570
54404 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
54405 & PYCHGE(K(I,2)).EQ.0) GOTO 570
54406 ENDIF
54407 PMR=0D0
54408 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
54409 IF(MSTU(42).GE.2) PMR=P(I,5)
54410 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
54411 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
54412 RETURN
54413 ENDIF
54414 NUPP=NUPP+1
54415 P(NUPP,1)=P(I,1)
54416 P(NUPP,2)=P(I,2)
54417 P(NUPP,3)=P(I,3)
54418 P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
54419 P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
54420 ECM=ECM+P(NUPP,4)
54421 570 CONTINUE
54422 IF(NUPP.EQ.NLOW) RETURN
54423
54424C...Analyze Energy-Energy Correlation in event.
54425 FAC=(2D0/ECM**2)*50D0/PARU(1)
54426 DO 580 J=1,50
54427 FEVEE(J)=0D0
54428 580 CONTINUE
54429 DO 600 I1=NLOW+2,NUPP
54430 DO 590 I2=NLOW+1,I1-1
54431 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
54432 & (P(I1,5)*P(I2,5))
54433 THE=ACOS(MAX(-1D0,MIN(1D0,CTHE)))
54434 ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1))))
54435 FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
54436 590 CONTINUE
54437 600 CONTINUE
54438 DO 610 J=1,25
54439 FE1EC(J)=FE1EC(J)+FEVEE(J)
54440 FE2EC(J)=FE2EC(J)+FEVEE(J)**2
54441 FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
54442 FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
54443 FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
54444 FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
54445 610 CONTINUE
54446 MSTU(62)=NUPP-NLOW
54447
54448C...Write statistics on Energy-Energy Correlation.
54449 ELSEIF(MTABU.EQ.42) THEN
54450 FAC=1D0/MAX(1,NEVEE)
54451 WRITE(MSTU(11),5700) NEVEE
54452 DO 620 J=1,25
54453 FEEC1=FAC*FE1EC(J)
54454 FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2)))
54455 FEEC2=FAC*FE1EC(51-J)
54456 FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
54457 FEECA=FAC*FE1EA(J)
54458 FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2)))
54459 WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1,
54460 & FEEC2,FEES2,FEECA,FEESA
54461 620 CONTINUE
54462
54463C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
54464 ELSEIF(MTABU.EQ.43) THEN
54465 FAC=1D0/MAX(1,NEVEE)
54466 DO 630 I=1,25
54467 K(I,1)=32
54468 K(I,2)=99
54469 K(I,3)=0
54470 K(I,4)=0
54471 K(I,5)=0
54472 P(I,1)=FAC*FE1EC(I)
54473 V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
54474 P(I,2)=FAC*FE1EC(51-I)
54475 V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
54476 P(I,3)=FAC*FE1EA(I)
54477 V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
54478 P(I,4)=PARU(1)*(I-1)/50D0
54479 P(I,5)=PARU(1)*I/50D0
54480 V(I,4)=3.6D0*(I-1)
54481 V(I,5)=3.6D0*I
54482 630 CONTINUE
54483 N=25
54484 DO 640 J=1,5
54485 K(N+1,J)=0
54486 P(N+1,J)=0D0
54487 V(N+1,J)=0D0
54488 640 CONTINUE
54489 K(N+1,1)=32
54490 K(N+1,2)=99
54491 K(N+1,5)=NEVEE
54492 MSTU(3)=1
54493
54494C...Reset statistics on decay channels.
54495 ELSEIF(MTABU.EQ.50) THEN
54496 NEVDC=0
54497 NKFDC=0
54498 NREDC=0
54499
54500C...Identify and order flavour content of final state.
54501 ELSEIF(MTABU.EQ.51) THEN
54502 NEVDC=NEVDC+1
54503 NDS=0
54504 DO 670 I=1,N
54505 IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
54506 NDS=NDS+1
54507 IF(NDS.GT.8) THEN
54508 NREDC=NREDC+1
54509 RETURN
54510 ENDIF
54511 KFM=2*IABS(K(I,2))
54512 IF(K(I,2).LT.0) KFM=KFM-1
54513 DO 650 IDS=NDS-1,1,-1
54514 IIN=IDS+1
54515 IF(KFM.LT.KFDM(IDS)) GOTO 660
54516 KFDM(IDS+1)=KFDM(IDS)
54517 650 CONTINUE
54518 IIN=1
54519 660 KFDM(IIN)=KFM
54520 670 CONTINUE
54521
54522C...Find whether old or new final state.
54523 DO 690 IDC=1,NKFDC
54524 IF(NDS.LT.KFDC(IDC,0)) THEN
54525 IKFDC=IDC
54526 GOTO 700
54527 ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
54528 DO 680 I=1,NDS
54529 IF(KFDM(I).LT.KFDC(IDC,I)) THEN
54530 IKFDC=IDC
54531 GOTO 700
54532 ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
54533 GOTO 690
54534 ENDIF
54535 680 CONTINUE
54536 IKFDC=-IDC
54537 GOTO 700
54538 ENDIF
54539 690 CONTINUE
54540 IKFDC=NKFDC+1
54541 700 IF(IKFDC.LT.0) THEN
54542 IKFDC=-IKFDC
54543 ELSEIF(NKFDC.GE.200) THEN
54544 NREDC=NREDC+1
54545 RETURN
54546 ELSE
54547 DO 720 IDC=NKFDC,IKFDC,-1
54548 NPDC(IDC+1)=NPDC(IDC)
54549 DO 710 I=0,8
54550 KFDC(IDC+1,I)=KFDC(IDC,I)
54551 710 CONTINUE
54552 720 CONTINUE
54553 NKFDC=NKFDC+1
54554 KFDC(IKFDC,0)=NDS
54555 DO 730 I=1,NDS
54556 KFDC(IKFDC,I)=KFDM(I)
54557 730 CONTINUE
54558 NPDC(IKFDC)=0
54559 ENDIF
54560 NPDC(IKFDC)=NPDC(IKFDC)+1
54561
54562C...Write statistics on decay channels.
54563 ELSEIF(MTABU.EQ.52) THEN
54564 FAC=1D0/MAX(1,NEVDC)
54565 WRITE(MSTU(11),5900) NEVDC
54566 DO 750 IDC=1,NKFDC
54567 DO 740 I=1,KFDC(IDC,0)
54568 KFM=KFDC(IDC,I)
54569 KF=(KFM+1)/2
54570 IF(2*KF.NE.KFM) KF=-KF
54571 CALL PYNAME(KF,CHAU)
54572 CHDC(I)=CHAU(1:12)
54573 IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
54574 740 CONTINUE
54575 WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
54576 750 CONTINUE
54577 IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
54578
54579C...Copy statistics on decay channels into /PYJETS/.
54580 ELSEIF(MTABU.EQ.53) THEN
54581 FAC=1D0/MAX(1,NEVDC)
54582 DO 780 IDC=1,NKFDC
54583 K(IDC,1)=32
54584 K(IDC,2)=99
54585 K(IDC,3)=0
54586 K(IDC,4)=0
54587 K(IDC,5)=KFDC(IDC,0)
54588 DO 760 J=1,5
54589 P(IDC,J)=0D0
54590 V(IDC,J)=0D0
54591 760 CONTINUE
54592 DO 770 I=1,KFDC(IDC,0)
54593 KFM=KFDC(IDC,I)
54594 KF=(KFM+1)/2
54595 IF(2*KF.NE.KFM) KF=-KF
54596 IF(I.LE.5) P(IDC,I)=KF
54597 IF(I.GE.6) V(IDC,I-5)=KF
54598 770 CONTINUE
54599 V(IDC,5)=FAC*NPDC(IDC)
54600 780 CONTINUE
54601 N=NKFDC
54602 DO 790 J=1,5
54603 K(N+1,J)=0
54604 P(N+1,J)=0D0
54605 V(N+1,J)=0D0
54606 790 CONTINUE
54607 K(N+1,1)=32
54608 K(N+1,2)=99
54609 K(N+1,5)=NEVDC
54610 V(N+1,5)=FAC*NREDC
54611 MSTU(3)=1
54612 ENDIF
54613
54614C...Format statements for output on unit MSTU(11) (default 6).
54615 5000 FORMAT(///20X,'Event statistics - initial state'/
54616 &20X,'based on an analysis of ',I6,' events'//
54617 &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
54618 &'according to fragmenting system multiplicity'/
54619 &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
54620 &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
54621 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
54622 5200 FORMAT(///20X,'Event statistics - final state'/
54623 &20X,'based on an analysis of ',I7,' events'//
54624 &5X,'Mean primary multiplicity =',F10.4/
54625 &5X,'Mean final multiplicity =',F10.4/
54626 &5X,'Mean charged multiplicity =',F10.4//
54627 &5X,'Number of particles produced per event (directly and via ',
54628 &'decays/branchings)'/
54629 &8X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles',
54630 &8X,'Total'/35X,'prim seco prim seco'/)
54631 5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6))
54632 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
54633 &20X,'based on an analysis of ',I6,' events'//
54634 &3X,'delta-',A3,' delta-phi <n>/bin',10X,'<F2>',18X,'<F3>',
54635 &18X,'<F4>',18X,'<F5>'/35X,4(' value error '))
54636 5500 FORMAT(10X)
54637 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
54638 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
54639 &20X,'based on an analysis of ',I6,' events'//
54640 &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
54641 &'EECA(theta)'/2X,'in degrees ',3(' value error')/)
54642 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
54643 5900 FORMAT(///20X,'Decay channel analysis - final state'/
54644 &20X,'based on an analysis of ',I6,' events'//
54645 &2X,'Probability',10X,'Complete final state'/)
54646 6000 FORMAT(2X,F9.5,5X,8(A12,1X))
54647 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
54648 &'or table overflow)')
54649
54650 RETURN
54651 END
54652
54653C*********************************************************************
54654
54655C...PYEEVT
54656C...Handles the generation of an e+e- annihilation jet event.
54657
54658 SUBROUTINE PYEEVT(KFL,ECM)
54659
54660C...Double precision and integer declarations.
54661 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54662 IMPLICIT INTEGER(I-N)
54663 INTEGER PYK,PYCHGE,PYCOMP
54664C...Commonblocks.
54665 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
54666 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54667 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54668 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
54669
54670C...Check input parameters.
54671 IF(MSTU(12).GE.1) CALL PYLIST(0)
54672 IF(KFL.LT.0.OR.KFL.GT.8) THEN
54673 CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code')
54674 IF(MSTU(21).GE.1) RETURN
54675 ENDIF
54676 IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL))
54677 IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1)
54678 IF(ECM.LT.ECMMIN) THEN
54679 CALL PYERRM(16,'(PYEEVT:) called with too small CM energy')
54680 IF(MSTU(21).GE.1) RETURN
54681 ENDIF
54682
54683C...Check consistency of MSTJ options set.
54684 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
54685 CALL PYERRM(6,
54686 & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
54687 MSTJ(110)=1
54688 ENDIF
54689 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
54690 CALL PYERRM(6,
54691 & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
54692 MSTJ(111)=0
54693 ENDIF
54694
54695C...Initialize alpha_strong and total cross-section.
54696 MSTU(111)=MSTJ(108)
54697 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
54698 &MSTU(111)=1
54699 PARU(112)=PARJ(121)
54700 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
54701 IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
54702 &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM,
54703 &XTOT)
54704 IF(MSTJ(116).GE.3) MSTJ(116)=1
54705 PARJ(171)=0D0
54706
54707C...Add initial e+e- to event record (documentation only).
54708 NTRY=0
54709 100 NTRY=NTRY+1
54710 IF(NTRY.GT.100) THEN
54711 CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop')
54712 RETURN
54713 ENDIF
54714 MSTU(24)=0
54715 NC=0
54716 IF(MSTJ(115).GE.2) THEN
54717 NC=NC+2
54718 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
54719 K(NC-1,1)=21
54720 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
54721 K(NC,1)=21
54722 ENDIF
54723
54724C...Radiative photon (in initial state).
54725 MK=0
54726 ECMC=ECM
54727 IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK,
54728 &THEK,PHIK,ALPK)
54729 IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2D0*PAK))
54730 IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
54731 NC=NC+1
54732 CALL PY1ENT(NC,22,PAK,THEK,PHIK)
54733 K(NC,3)=MIN(MSTJ(115)/2,1)
54734 ENDIF
54735
54736C...Virtual exchange boson (gamma or Z0).
54737 IF(MSTJ(115).GE.3) THEN
54738 NC=NC+1
54739 KF=22
54740 IF(MSTJ(102).EQ.2) KF=23
54741 MSTU10=MSTU(10)
54742 MSTU(10)=1
54743 P(NC,5)=ECMC
54744 CALL PY1ENT(NC,KF,ECMC,0D0,0D0)
54745 K(NC,1)=21
54746 K(NC,3)=1
54747 MSTU(10)=MSTU10
54748 ENDIF
54749
54750C...Choice of flavour and jet configuration.
54751 CALL PYXKFL(KFL,ECM,ECMC,KFLC)
54752 IF(KFLC.EQ.0) GOTO 100
54753 CALL PYXJET(ECMC,NJET,CUT)
54754 KFLN=21
54755 IF(NJET.EQ.4) CALL PYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
54756 &X12,X14)
54757 IF(NJET.EQ.3) CALL PYX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
54758 IF(NJET.EQ.2) MSTJ(120)=1
54759
54760C...Fill jet configuration and origin.
54761 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL PY2ENT(NC+1,KFLC,-KFLC,ECMC)
54762 IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL PY2ENT(-(NC+1),KFLC,-KFLC,
54763 &ECMC)
54764 IF(NJET.EQ.3) CALL PY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
54765 IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,
54766 &-KFLC,ECMC,X1,X2,X4,X12,X14)
54767 IF(NJET.EQ.4.AND.KFLN.NE.21) CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,
54768 &-KFLC,ECMC,X1,X2,X4,X12,X14)
54769 IF(MSTU(24).NE.0) GOTO 100
54770 DO 110 IP=NC+1,N
54771 K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
54772 110 CONTINUE
54773
54774C...Angular orientation according to matrix element.
54775 IF(MSTJ(106).EQ.1) THEN
54776 CALL PYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
54777 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
54778 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
54779 ENDIF
54780
54781C...Rotation and boost from radiative photon.
54782 IF(MK.EQ.1) THEN
54783 DBEK=-PAK/(ECM-PAK)
54784 NMIN=NC+1-MSTJ(115)/3
54785 CALL PYROBO(NMIN,N,0D0,-PHIK,0D0,0D0,0D0)
54786 CALL PYROBO(NMIN,N,ALPK,0D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
54787 CALL PYROBO(NMIN,N,0D0,PHIK,0D0,0D0,0D0)
54788 ENDIF
54789
54790C...Generate parton shower. Rearrange along strings and check.
54791 IF(MSTJ(101).EQ.5) THEN
54792 CALL PYSHOW(N-1,N,ECMC)
54793 MSTJ14=MSTJ(14)
54794 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
54795 IF(MSTJ(105).GE.0) MSTU(28)=0
54796 CALL PYPREP(0)
54797 MSTJ(14)=MSTJ14
54798 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
54799 ENDIF
54800
54801C...Fragmentation/decay generation. Information for PYTABU.
54802 IF(MSTJ(105).EQ.1) CALL PYEXEC
54803 MSTU(161)=KFLC
54804 MSTU(162)=-KFLC
54805
54806 RETURN
54807 END
54808
54809C*********************************************************************
54810
54811C...PYXTEE
54812C...Calculates total cross-section, including initial state
54813C...radiation effects.
54814
54815 SUBROUTINE PYXTEE(KFL,ECM,XTOT)
54816
54817C...Double precision and integer declarations.
54818 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54819 IMPLICIT INTEGER(I-N)
54820 INTEGER PYK,PYCHGE,PYCOMP
54821C...Commonblocks.
54822 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54823 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54824 SAVE /PYDAT1/,/PYDAT2/
54825
54826C...Status, (optimized) Q^2 scale, alpha_strong.
54827 PARJ(151)=ECM
54828 MSTJ(119)=10*MSTJ(102)+KFL
54829 IF(MSTJ(111).EQ.0) THEN
54830 Q2R=ECM**2
54831 ELSEIF(MSTU(111).EQ.0) THEN
54832 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
54833 & ((33D0-2D0*MSTU(112))*PARU(111)))))
54834 Q2R=PARJ(168)*ECM**2
54835 ELSE
54836 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
54837 & (2D0*PARU(112)/ECM)**2))
54838 Q2R=PARJ(168)*ECM**2
54839 ENDIF
54840 ALSPI=PYALPS(Q2R)/PARU(1)
54841
54842C...QCD corrections factor in R.
54843 IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
54844 RQCD=1D0
54845 ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
54846 RQCD=1D0+ALSPI
54847 ELSEIF(MSTJ(109).EQ.0) THEN
54848 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
54849 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0*
54850 & LOG(PARJ(168))*ALSPI**2)
54851 ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
54852 RQCD=1D0+(3D0/4D0)*ALSPI
54853 ELSE
54854 RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2
54855 ENDIF
54856
54857C...Calculate Z0 width if default value not acceptable.
54858 IF(MSTJ(102).GE.3) THEN
54859 RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+
54860 & (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2)
54861 DO 100 KFLC=5,6
54862 VQ=1D0
54863 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-
54864 & (2D0*PYMASS(KFLC)/ ECM)**2))
54865 IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0
54866 IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0
54867 RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3)
54868 100 CONTINUE
54869 PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)*
54870 & (1D0-PARU(102)))
54871 ENDIF
54872
54873C...Calculate propagator and related constants for QFD case.
54874 POLL=1D0-PARJ(131)*PARJ(132)
54875 IF(MSTJ(102).GE.2) THEN
54876 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
54877 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
54878 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
54879 VE=4D0*PARU(102)-1D0
54880 SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
54881 SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
54882 HF1I=SFI*SF1I
54883 HF1W=SFW*SF1W
54884 ENDIF
54885
54886C...Loop over different flavours: charge, velocity.
54887 RTOT=0D0
54888 RQQ=0D0
54889 RQV=0D0
54890 RVA=0D0
54891 DO 110 KFLC=1,MAX(MSTJ(104),KFL)
54892 IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
54893 MSTJ(93)=1
54894 PMQ=PYMASS(KFLC)
54895 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110
54896 QF=KCHG(KFLC,1)/3D0
54897 VQ=1D0
54898 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2)
54899
54900C...Calculate R and sum of charges for QED or QFD case.
54901 RQQ=RQQ+3D0*QF**2*POLL
54902 IF(MSTJ(102).LE.1) THEN
54903 RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL
54904 ELSE
54905 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
54906 RQV=RQV-6D0*QF*VF*SF1I
54907 RVA=RVA+3D0*(VF**2+1D0)*SF1W
54908 RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-
54909 & 2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W)
54910 ENDIF
54911 110 CONTINUE
54912 RSUM=RQQ
54913 IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
54914
54915C...Calculate cross-section, including QCD corrections.
54916 PARJ(141)=RQQ
54917 PARJ(142)=RTOT
54918 PARJ(143)=RTOT*RQCD
54919 PARJ(144)=PARJ(143)
54920 PARJ(145)=PARJ(141)*86.8D0/ECM**2
54921 PARJ(146)=PARJ(142)*86.8D0/ECM**2
54922 PARJ(147)=PARJ(143)*86.8D0/ECM**2
54923 PARJ(148)=PARJ(147)
54924 PARJ(157)=RSUM*RQCD
54925 PARJ(158)=0D0
54926 PARJ(159)=0D0
54927 XTOT=PARJ(147)
54928 IF(MSTJ(107).LE.0) RETURN
54929
54930C...Virtual cross-section.
54931 XKL=PARJ(135)
54932 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
54933 ALE=2D0*LOG(ECM/PYMASS(11))-1D0
54934 SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+
54935 &1.526D0*LOG(ECM**2/0.932D0)
54936
54937C...Soft and hard radiative cross-section in QED case.
54938 IF(MSTJ(102).LE.1) THEN
54939 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV
54940 SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL)
54941 SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL))
54942
54943C...Soft and hard radiative cross-section in QFD case.
54944 ELSE
54945 SZM=1D0-(PARJ(123)/ECM)**2
54946 SZW=PARJ(123)*PARJ(124)/ECM**2
54947 PARJ(161)=-RQQ/RSUM
54948 PARJ(162)=-(RQQ+RQV+RVA)/RSUM
54949 PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM
54950 PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2-
54951 & 4D0+3D0*SZM-SZM**2))/(SZW*RSUM)
54952 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/
54953 & RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0
54954 SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+
54955 & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
54956 & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
54957 SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/
54958 & (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)*
54959 & LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+
54960 & PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW)))
54961 ENDIF
54962
54963C...Total cross-section and fraction of hard photon events.
54964 PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
54965 PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
54966 PARJ(144)=PARJ(157)
54967 PARJ(148)=PARJ(144)*86.8D0/ECM**2
54968 XTOT=PARJ(148)
54969
54970 RETURN
54971 END
54972
54973C*********************************************************************
54974
54975C...PYRADK
54976C...Generates initial state photon radiation.
54977
54978 SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
54979
54980C...Double precision and integer declarations.
54981 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54982 IMPLICIT INTEGER(I-N)
54983 INTEGER PYK,PYCHGE,PYCOMP
54984C...Commonblocks.
54985 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54986 SAVE /PYDAT1/
54987
54988C...Function: cumulative hard photon spectrum in QFD case.
54989 FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+
54990 &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
54991
54992C...Determine whether radiative photon or not.
54993 MK=0
54994 PAK=0D0
54995 IF(PARJ(160).LT.PYR(0)) RETURN
54996 MK=1
54997
54998C...Photon energy range. Find photon momentum in QED case.
54999 XKL=PARJ(135)
55000 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
55001 IF(MSTJ(102).LE.1) THEN
55002 100 XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0))
55003 IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100
55004
55005C...Ditto in QFD case, by numerical inversion of integrated spectrum.
55006 ELSE
55007 SZM=1D0-(PARJ(123)/ECM)**2
55008 SZW=PARJ(123)*PARJ(124)/ECM**2
55009 FXKL=FXK(XKL)
55010 FXKU=FXK(XKU)
55011 FXKD=1D-4*(FXKU-FXKL)
55012 FXKR=FXKL+PYR(0)*(FXKU-FXKL)
55013 NXK=0
55014 110 NXK=NXK+1
55015 XK=0.5D0*(XKL+XKU)
55016 FXKV=FXK(XK)
55017 IF(FXKV.GT.FXKR) THEN
55018 XKU=XK
55019 FXKU=FXKV
55020 ELSE
55021 XKL=XK
55022 FXKL=FXKV
55023 ENDIF
55024 IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
55025 XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
55026 ENDIF
55027 PAK=0.5D0*ECM*XK
55028
55029C...Photon polar and azimuthal angle.
55030 PME=2D0*(PYMASS(11)/ECM)**2
55031 120 CTHM=PME*(2D0/PME)**PYR(0)
55032 IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME,
55033 &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120
55034 CTHE=1D0-CTHM
55035 IF(PYR(0).GT.0.5D0) CTHE=-CTHE
55036 STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM)))
55037 THEK=PYANGL(CTHE,STHE)
55038 PHIK=PARU(2)*PYR(0)
55039
55040C...Rotation angle for hadronic system.
55041 SGN=1D0
55042 IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT.
55043 &PYR(0)) SGN=-1D0
55044 ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/
55045 &(2D0-XK*(1D0-SGN*CTHE)))
55046
55047 RETURN
55048 END
55049
55050C*********************************************************************
55051
55052C...PYXKFL
55053C...Selects flavour for produced qqbar pair.
55054
55055 SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC)
55056
55057C...Double precision and integer declarations.
55058 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55059 IMPLICIT INTEGER(I-N)
55060 INTEGER PYK,PYCHGE,PYCOMP
55061C...Commonblocks.
55062 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55063 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55064 SAVE /PYDAT1/,/PYDAT2/
55065
55066C...Calculate maximum weight in QED or QFD case.
55067 IF(MSTJ(102).LE.1) THEN
55068 RFMAX=4D0/9D0
55069 ELSE
55070 POLL=1D0-PARJ(131)*PARJ(132)
55071 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
55072 SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
55073 SFI=SFW*(1D0-(PARJ(123)/ECMC)**2)
55074 VE=4D0*PARU(102)-1D0
55075 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
55076 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
55077 RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+
55078 & ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0*
55079 & (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+
55080 & 1D0)*HF1W)
55081 ENDIF
55082
55083C...Choose flavour. Gives charge and velocity.
55084 NTRY=0
55085 100 NTRY=NTRY+1
55086 IF(NTRY.GT.100) THEN
55087 CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop')
55088 KFLC=0
55089 RETURN
55090 ENDIF
55091 KFLC=KFL
55092 IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0))
55093 MSTJ(93)=1
55094 PMQ=PYMASS(KFLC)
55095 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100
55096 QF=KCHG(KFLC,1)/3D0
55097 VQ=1D0
55098 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2))
55099
55100C...Calculate weight in QED or QFD case.
55101 IF(MSTJ(102).LE.1) THEN
55102 RF=QF**2
55103 RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2
55104 ELSE
55105 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
55106 RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W
55107 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+
55108 & VQ**3*HF1W
55109 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
55110 ENDIF
55111
55112C...Weighting or new event (radiative photon). Cross-section update.
55113 IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100
55114 PARJ(158)=PARJ(158)+1D0
55115 IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0
55116 IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
55117 IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0
55118 PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
55119 PARJ(148)=PARJ(144)*86.8D0/ECM**2
55120
55121 RETURN
55122 END
55123
55124C*********************************************************************
55125
55126C...PYXJET
55127C...Selects number of jets in matrix element approach.
55128
55129 SUBROUTINE PYXJET(ECM,NJET,CUT)
55130
55131C...Double precision and integer declarations.
55132 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55133 IMPLICIT INTEGER(I-N)
55134 INTEGER PYK,PYCHGE,PYCOMP
55135C...Commonblocks.
55136 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55137 SAVE /PYDAT1/
55138C...Local array and data.
55139 DIMENSION ZHUT(5)
55140 DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/
55141
55142C...Trivial result for two-jets only, including parton shower.
55143 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
55144 CUT=0D0
55145
55146C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
55147 ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
55148 CF=4D0/3D0
55149 IF(MSTJ(109).EQ.2) CF=1D0
55150 IF(MSTJ(111).EQ.0) THEN
55151 Q2=ECM**2
55152 Q2R=ECM**2
55153 ELSEIF(MSTU(111).EQ.0) THEN
55154 PARJ(169)=MIN(1D0,PARJ(129))
55155 Q2=PARJ(169)*ECM**2
55156 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
55157 & ((33D0-2D0*MSTU(112))*PARU(111)))))
55158 Q2R=PARJ(168)*ECM**2
55159 ELSE
55160 PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2))
55161 Q2=PARJ(169)*ECM**2
55162 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
55163 & (2D0*PARU(112)/ECM)**2))
55164 Q2R=PARJ(168)*ECM**2
55165 ENDIF
55166
55167C...alpha_strong for R and R itself.
55168 ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1)
55169 IF(IABS(MSTJ(101)).EQ.1) THEN
55170 RQCD=1D0+ALSPI
55171 ELSEIF(MSTJ(109).EQ.0) THEN
55172 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
55173 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+
55174 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2)
55175 ELSE
55176 RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2
55177 ENDIF
55178
55179C...alpha_strong for jet rate. Initial value for y cut.
55180 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
55181 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2)
55182 IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
55183 & CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0)
55184 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
55185
55186C...Parametrization of first order three-jet cross-section.
55187 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN
55188 PARJ(152)=0D0
55189 ELSE
55190 PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))*
55191 & LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)*
55192 & (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0*
55193 & (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD
55194 IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
55195 & PARJ(152)=0D0
55196 ENDIF
55197
55198C...Parametrization of second order three-jet cross-section.
55199 IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
55200 & CUT.GE.0.25D0) THEN
55201 PARJ(153)=0D0
55202 ELSEIF(MSTJ(110).LE.1) THEN
55203 CT=LOG(1D0/CUT-2D0)
55204 PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2-
55205 & 0.2661D0*CT**3+0.01159D0*CT**4)/RQCD
55206
55207C...Interpolation in second/first order ratio for Zhu parametrization.
55208 ELSEIF(MSTJ(110).EQ.2) THEN
55209 IZA=0
55210 DO 110 IY=1,5
55211 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
55212 110 CONTINUE
55213 IF(IZA.NE.0) THEN
55214 ZHURAT=ZHUT(IZA)
55215 ELSE
55216 IZ=100D0*CUT
55217 ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
55218 ENDIF
55219 PARJ(153)=ALSPI*PARJ(152)*ZHURAT
55220 ENDIF
55221
55222C...Shift in second order three-jet cross-section with optimized Q^2.
55223 IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3
55224 & .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+
55225 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152)
55226
55227C...Parametrization of second order four-jet cross-section.
55228 IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN
55229 PARJ(154)=0D0
55230 ELSE
55231 CT=LOG(1D0/CUT-5D0)
55232 IF(CUT.LE.0.018D0) THEN
55233 XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2
55234 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+
55235 & 0.4059D0*CT**2)
55236 XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2)
55237 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
55238 ELSE
55239 XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3
55240 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+
55241 & 0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3)
55242 XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+
55243 & 0.002093D0*CT**3)
55244 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
55245 ENDIF
55246 PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
55247 PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
55248 ENDIF
55249
55250C...If negative three-jet rate, change y' optimization parameter.
55251 IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND.
55252 & PARJ(169).LT.0.99D0) THEN
55253 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
55254 Q2=PARJ(169)*ECM**2
55255 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
55256 GOTO 100
55257 ENDIF
55258
55259C...If too high cross-section, use harder cuts, or fail.
55260 IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
55261 IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND.
55262 & PARJ(169).LT.0.99D0) THEN
55263 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
55264 Q2=PARJ(169)*ECM**2
55265 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
55266 GOTO 100
55267 ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN
55268 CALL PYERRM(26,
55269 & '(PYXJET:) no allowed y cut value for Zhu parametrization')
55270 ENDIF
55271 CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+
55272 & PARJ(154))**(-1D0/3D0)
55273 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
55274 GOTO 100
55275 ENDIF
55276
55277C...Scalar gluon (first order only).
55278 ELSE
55279 ALSPI=PYALPS(ECM**2)/PARU(1)
55280 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI))
55281 PARJ(152)=0D0
55282 IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)*
55283 & LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0))
55284 PARJ(153)=0D0
55285 PARJ(154)=0D0
55286 ENDIF
55287
55288C...Select number of jets.
55289 PARJ(150)=CUT
55290 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
55291 NJET=2
55292 ELSEIF(MSTJ(101).LE.0) THEN
55293 NJET=MIN(4,2-MSTJ(101))
55294 ELSE
55295 RNJ=PYR(0)
55296 NJET=2
55297 IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
55298 IF(PARJ(154).GT.RNJ) NJET=4
55299 ENDIF
55300
55301 RETURN
55302 END
55303
55304C*********************************************************************
55305
55306C...PYX3JT
55307C...Selects the kinematical variables of three-jet events.
55308
55309 SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2)
55310
55311C...Double precision and integer declarations.
55312 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55313 IMPLICIT INTEGER(I-N)
55314 INTEGER PYK,PYCHGE,PYCOMP
55315C...Commonblocks.
55316 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55317 SAVE /PYDAT1/
55318C...Local array.
55319 DIMENSION ZHUP(5,12)
55320
55321C...Coefficients of Zhu second order parametrization.
55322 DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
55323 &18.29D0, 89.56D0, 4.541D0, -52.09D0, -109.8D0, 24.90D0,
55324 &11.63D0, 3.683D0, 17.50D0,0.002440D0, -1.362D0,-0.3537D0,
55325 &11.42D0, 6.299D0, -22.55D0, -8.915D0, 59.25D0, -5.855D0,
55326 &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0,
55327 &7.847D0, -3.964D0, -35.83D0, 1.178D0, 29.39D0, 0.2806D0,
55328 &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0,
55329 &5.441D0, -56.89D0, -50.27D0, 15.13D0, 114.3D0, -18.19D0,
55330 &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0,
55331 &-17.65D0, 51.44D0, -58.32D0, 70.95D0, -255.7D0, -78.99D0,
55332 &476.9D0, 29.65D0, -239.3D0, 0.4745D0, -1.174D0, 6.081D0/
55333
55334C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
55335 DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+
55336 &X**7/49D0
55337
55338C...Event type. Mass effect factors and other common constants.
55339 MSTJ(120)=2
55340 MSTJ(121)=0
55341 PMQ=PYMASS(KFL)
55342 QME=(2D0*PMQ/ECM)**2
55343 IF(MSTJ(109).NE.1) THEN
55344 CUTL=LOG(CUT)
55345 CUTD=LOG(1D0/CUT-2D0)
55346 IF(MSTJ(109).EQ.0) THEN
55347 CF=4D0/3D0
55348 CN=3D0
55349 TR=2D0
55350 WTMX=MIN(20D0,37D0-6D0*CUTD)
55351 IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT)
55352 ELSE
55353 CF=1D0
55354 CN=0D0
55355 TR=12D0
55356 WTMX=0D0
55357 ENDIF
55358
55359C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
55360 ALS2PI=PARU(118)/PARU(2)
55361 WTOPT=0D0
55362 IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0*
55363 & LOG(PARJ(169))*ALS2PI
55364 WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX)
55365
55366C...Choose three-jet events in allowed region.
55367 100 NJET=3
55368 110 Y13L=CUTL+CUTD*PYR(0)
55369 Y23L=CUTL+CUTD*PYR(0)
55370 Y13=EXP(Y13L)
55371 Y23=EXP(Y23L)
55372 Y12=1D0-Y13-Y23
55373 IF(Y12.LE.CUT) GOTO 110
55374 IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110
55375
55376C...Second order corrections.
55377 IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
55378 Y12L=LOG(Y12)
55379 Y13M=LOG(1D0-Y13)
55380 Y23M=LOG(1D0-Y23)
55381 Y12M=LOG(1D0-Y12)
55382 IF(Y13.LE.0.5D0) Y13I=DILOG(Y13)
55383 IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13)
55384 IF(Y23.LE.0.5D0) Y23I=DILOG(Y23)
55385 IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23)
55386 IF(Y12.LE.0.5D0) Y12I=DILOG(Y12)
55387 IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12)
55388 WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23)
55389 WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+
55390 & 2D0*(2D0*CUTL-Y12L)*CUT/Y12)+
55391 & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-
55392 & 11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+
55393 & (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+
55394 & TR*(2D0*CUTL/3D0-10D0/9D0)+
55395 & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
55396 & Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/
55397 & (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+
55398 & Y13*Y23)/(Y12+Y13)**2)/WT1+
55399 & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)*
55400 & ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
55401 & Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
55402 & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/
55403 & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
55404 & 2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1-
55405 & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I)
55406 IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1
55407 IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
55408 PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2)
55409
55410 ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
55411C...Second order corrections; Zhu parametrization of ERT.
55412 ZX=(Y23-Y13)**2
55413 ZY=1D0-Y12
55414 IZA=0
55415 DO 120 IY=1,5
55416 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
55417 120 CONTINUE
55418 IF(IZA.NE.0) THEN
55419 IZ=IZA
55420 WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
55421 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
55422 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
55423 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
55424 ELSE
55425 IZ=100D0*CUT
55426 WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
55427 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
55428 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
55429 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
55430 IZ=IZ+1
55431 WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
55432 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
55433 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
55434 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
55435 WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ)
55436 ENDIF
55437 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1
55438 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
55439 PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2)
55440 ENDIF
55441
55442C...Impose mass cuts (gives two jets). For fixed jet number new try.
55443 X1=1D0-Y23
55444 X2=1D0-Y13
55445 X3=1D0-Y12
55446 IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
55447 IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
55448 & 0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+
55449 & (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2
55450 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
55451
55452C...Scalar gluon model (first order only, no mass effects).
55453 ELSE
55454 130 NJET=3
55455 140 X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2))
55456 IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140
55457 YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0)
55458 X1=1D0-0.5D0*(X3+YD)
55459 X2=1D0-0.5D0*(X3-YD)
55460 IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2
55461 IF(MSTJ(102).GE.2) THEN
55462 IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT.
55463 & X3**2*PYR(0)) NJET=2
55464 ENDIF
55465 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
55466 ENDIF
55467
55468 RETURN
55469 END
55470
55471C*********************************************************************
55472
55473C...PYX4JT
55474C...Selects the kinematical variables of four-jet events.
55475
55476 SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
55477
55478C...Double precision and integer declarations.
55479 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55480 IMPLICIT INTEGER(I-N)
55481 INTEGER PYK,PYCHGE,PYCOMP
55482C...Commonblocks.
55483 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55484 SAVE /PYDAT1/
55485C...Local arrays.
55486 DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
55487
55488C...Common constants. Colour factors for QCD and Abelian gluon theory.
55489 PMQ=PYMASS(KFL)
55490 QME=(2D0*PMQ/ECM)**2
55491 CT=LOG(1D0/CUT-5D0)
55492 IF(MSTJ(109).EQ.0) THEN
55493 CF=4D0/3D0
55494 CN=3D0
55495 TR=2.5D0
55496 ELSE
55497 CF=1D0
55498 CN=0D0
55499 TR=15D0
55500 ENDIF
55501
55502C...Choice of process (qqbargg or qqbarqqbar).
55503 100 NJET=4
55504 IT=1
55505 IF(PARJ(155).GT.PYR(0)) IT=2
55506 IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
55507 IF(IT.EQ.1) WTMX=0.7D0/CUT**2
55508 IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2
55509 IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2
55510 ID=1
55511
55512C...Sample the five kinematical variables (for qqgg preweighted in y34).
55513 110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
55514 Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
55515 IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0))
55516 IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0)
55517 IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110
55518 VT=PYR(0)
55519 CP=COS(PARU(1)*PYR(0))
55520 Y14=(Y134-Y34)*VT
55521 Y13=Y134-Y14-Y34
55522 VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
55523 Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)*
55524 &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB))
55525 Y23=Y234-Y34-Y24
55526 Y12=1D0-Y134-Y23-Y24
55527 IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
55528 Y123=Y12+Y13+Y23
55529 Y124=Y12+Y14+Y24
55530
55531C...Calculate matrix elements for qqgg or qqqq process.
55532 IC=0
55533 WTTOT=0D0
55534 120 IC=IC+1
55535 IF(IT.EQ.1) THEN
55536 WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+
55537 & 3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24-
55538 & Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12*
55539 & Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+
55540 & 2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/
55541 & (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-
55542 & Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/
55543 & (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24)
55544 WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12*
55545 & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14*
55546 & Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+
55547 & Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24)
55548 WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+
55549 & 2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+
55550 & Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-
55551 & 3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-
55552 & 3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+
55553 & (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+
55554 & 3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+
55555 & 2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24-
55556 & 2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+
55557 & 3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+
55558 & 2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2-
55559 & 2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34)
55560 WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+
55561 & 4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34-
55562 & Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+
55563 & 4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+
55564 & 2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+
55565 & 4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/
55566 & (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34-
55567 & 2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+
55568 & 2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24-
55569 & 4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-
55570 & Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2-
55571 & 4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34-
55572 & 4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34-
55573 & 2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23-
55574 & 2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14-
55575 & Y12*Y13**2)/(4D0*Y34**2*Y134**2)
55576 WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+
55577 & CN*WTC(IC))/8D0
55578 ELSE
55579 WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12*
55580 & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
55581 & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
55582 & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
55583 & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
55584 & Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
55585 & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
55586 & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
55587 & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
55588 WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
55589 & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
55590 & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
55591 & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
55592 & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
55593 & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
55594 & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
55595 & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
55596 WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0
55597 ENDIF
55598
55599C...Permutations of momenta in matrix element. Weighting.
55600 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
55601 YSAV=Y13
55602 Y13=Y14
55603 Y14=YSAV
55604 YSAV=Y23
55605 Y23=Y24
55606 Y24=YSAV
55607 YSAV=Y123
55608 Y123=Y124
55609 Y124=YSAV
55610 ENDIF
55611 IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
55612 YSAV=Y13
55613 Y13=Y23
55614 Y23=YSAV
55615 YSAV=Y14
55616 Y14=Y24
55617 Y24=YSAV
55618 YSAV=Y134
55619 Y134=Y234
55620 Y234=YSAV
55621 ENDIF
55622 IF(IC.LE.3) GOTO 120
55623 IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110
55624 IC=5
55625
55626C...qqgg events: string configuration and event type.
55627 IF(IT.EQ.1) THEN
55628 IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
55629 PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+
55630 & WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT)
55631 IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+
55632 & WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
55633 IF(ID.EQ.2) GOTO 130
55634 ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
55635 PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT)
55636 IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
55637 IF(ID.EQ.2) GOTO 130
55638 ENDIF
55639 MSTJ(120)=3
55640 IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+
55641 & WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4
55642 KFLN=21
55643
55644C...Mass cuts. Kinematical variables out.
55645 IF(Y12.LE.CUT+QME) NJET=2
55646 IF(NJET.EQ.2) GOTO 150
55647 Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12))
55648 X1=1D0-(1D0-Q12)*Y234-Q12*Y134
55649 X4=1D0-(1D0-Q12)*Y134-Q12*Y234
55650 X2=1D0-Y124
55651 X12=(1D0-Q12)*Y13+Q12*Y23
55652 X14=Y12-0.5D0*QME
55653 IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
55654
55655C...qqbarqqbar events: string configuration, choose new flavour.
55656 ELSE
55657 IF(ID.EQ.1) THEN
55658 WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
55659 IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
55660 IF(WTR.LT.WTD(3)+WTD(4)) ID=3
55661 IF(WTR.LT.WTD(4)) ID=4
55662 IF(ID.GE.2) GOTO 130
55663 ENDIF
55664 MSTJ(120)=5
55665 PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT)
55666 140 KFLN=1+INT(5D0*PYR(0))
55667 IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140
55668 IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140
55669 IF(KFLN.GT.MSTJ(104)) NJET=2
55670 PMQN=PYMASS(KFLN)
55671 QMEN=(2D0*PMQN/ECM)**2
55672
55673C...Mass cuts. Kinematical variables out.
55674 IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2
55675 IF(NJET.EQ.2) GOTO 150
55676 Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24))
55677 Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13))
55678 X1=1D0-(1D0-Q24)*Y123-Q24*Y134
55679 X4=1D0-(1D0-Q24)*Y134-Q24*Y123
55680 X2=1D0-(1D0-Q13)*Y234-Q13*Y124
55681 X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+
55682 & Q13*Y23)
55683 X14=Y24-0.5D0*QME
55684 X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+
55685 & Q13*Y14)
55686 IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
55687 & (PARJ(127)+PMQ+PMQN)**2) NJET=2
55688 IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
55689 ENDIF
55690 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
55691
55692 RETURN
55693 END
55694
55695C*********************************************************************
55696
55697C...PYXDIF
55698C...Gives the angular orientation of events.
55699
55700 SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
55701
55702C...Double precision and integer declarations.
55703 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55704 IMPLICIT INTEGER(I-N)
55705 INTEGER PYK,PYCHGE,PYCOMP
55706C...Commonblocks.
55707 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
55708 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55709 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55710 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
55711
55712C...Charge. Factors depending on polarization for QED case.
55713 QF=KCHG(KFL,1)/3D0
55714 POLL=1D0-PARJ(131)*PARJ(132)
55715 POLD=PARJ(132)-PARJ(131)
55716 IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
55717 HF1=POLL
55718 HF2=0D0
55719 HF3=PARJ(133)**2
55720 HF4=0D0
55721
55722C...Factors depending on flavour, energy and polarization for QFD case.
55723 ELSE
55724 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
55725 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
55726 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
55727 AE=-1D0
55728 VE=4D0*PARU(102)-1D0
55729 AF=SIGN(1D0,QF)
55730 VF=AF-4D0*QF*PARU(102)
55731 HF1=QF**2*POLL-2D0*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
55732 & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2D0*VE*AE*POLD)
55733 HF2=-2D0*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2D0*VF*AF*SFW*SFF**2*
55734 & (2D0*VE*AE*POLL-(VE**2+AE**2)*POLD)
55735 HF3=PARJ(133)**2*(QF**2-2D0*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
55736 & SFW*SFF**2*(VE**2-AE**2))
55737 HF4=-PARJ(133)**2*2D0*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
55738 & SFF*AE
55739 ENDIF
55740
55741C...Mass factor. Differential cross-sections for two-jet events.
55742 SQ2=SQRT(2D0)
55743 QME=0D0
55744 IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
55745 &MSTJ(109).NE.1) QME=(2D0*PYMASS(KFL)/ECM)**2
55746 IF(NJET.EQ.2) THEN
55747 SIGU=4D0*SQRT(1D0-QME)
55748 SIGL=2D0*QME*SQRT(1D0-QME)
55749 SIGT=0D0
55750 SIGI=0D0
55751 SIGA=0D0
55752 SIGP=4D0
55753
55754C...Kinematical variables. Reduce four-jet event to three-jet one.
55755 ELSE
55756 IF(NJET.EQ.3) THEN
55757 X1=2D0*P(NC+1,4)/ECM
55758 X2=2D0*P(NC+3,4)/ECM
55759 ELSE
55760 ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
55761 & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
55762 X1=2D0*P(NC+1,4)/ECMR
55763 X2=2D0*P(NC+4,4)/ECMR
55764 ENDIF
55765
55766C...Differential cross-sections for three-jet (or reduced four-jet).
55767 XQ=(1D0-X1)/(1D0-X2)
55768 CT12=(X1*X2-2D0*X1-2D0*X2+2D0+QME)/SQRT((X1**2-QME)*(X2**2-QME))
55769 ST12=SQRT(1D0-CT12**2)
55770 IF(MSTJ(109).NE.1) THEN
55771 SIGU=2D0*X1**2+X2**2*(1D0+CT12**2)-QME*(3D0+CT12**2-X1-X2)-
55772 & QME*X1/XQ+0.5D0*QME*((X2**2-QME)*ST12**2-2D0*X2)*XQ
55773 SIGL=(X2*ST12)**2-QME*(3D0-CT12**2-2.5D0*(X1+X2)+X1*X2+QME)+
55774 & 0.5D0*QME*(X1**2-X1-QME)/XQ+0.5D0*QME*((X2**2-QME)*CT12**2-
55775 & X2)*XQ
55776 SIGT=0.5D0*(X2**2-QME-0.5D0*QME*(X2**2-QME)/XQ)*ST12**2
55777 SIGI=((1D0-0.5D0*QME*XQ)*(X2**2-QME)*ST12*CT12+
55778 & QME*(1D0-X1-X2+0.5D0*X1*X2+0.5D0*QME)*ST12/CT12)/SQ2
55779 SIGA=X2**2*ST12/SQ2
55780 SIGP=2D0*(X1**2-X2**2*CT12)
55781
55782C...Differential cross-sect for scalar gluons (no mass effects).
55783 ELSE
55784 X3=2D0-X1-X2
55785 XT=X2*ST12
55786 CT13=SQRT(MAX(0D0,1D0-(XT/X3)**2))
55787 SIGU=(1D0-PARJ(171))*(X3**2-0.5D0*XT**2)+
55788 & PARJ(171)*(X3**2-0.5D0*XT**2-4D0*(1D0-X1)*(1D0-X2)**2/X1)
55789 SIGL=(1D0-PARJ(171))*0.5D0*XT**2+
55790 & PARJ(171)*0.5D0*(1D0-X1)**2*XT**2
55791 SIGT=(1D0-PARJ(171))*0.25D0*XT**2+
55792 & PARJ(171)*0.25D0*XT**2*(1D0-2D0*X1)
55793 SIGI=-(0.5D0/SQ2)*((1D0-PARJ(171))*XT*X3*CT13+
55794 & PARJ(171)*XT*((1D0-2D0*X1)*X3*CT13-X1*(X1-X2)))
55795 SIGA=(0.25D0/SQ2)*XT*(2D0*(1D0-X1)-X1*X3)
55796 SIGP=X3**2-2D0*(1D0-X1)*(1D0-X2)/X1
55797 ENDIF
55798 ENDIF
55799
55800C...Upper bounds for differential cross-section.
55801 HF1A=ABS(HF1)
55802 HF2A=ABS(HF2)
55803 HF3A=ABS(HF3)
55804 HF4A=ABS(HF4)
55805 SIGMAX=(2D0*HF1A+HF3A+HF4A)*ABS(SIGU)+2D0*(HF1A+HF3A+HF4A)*
55806 &ABS(SIGL)+2D0*(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGT)+2D0*SQ2*
55807 &(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGI)+4D0*SQ2*HF2A*ABS(SIGA)+
55808 &2D0*HF2A*ABS(SIGP)
55809
55810C...Generate angular orientation according to differential cross-sect.
55811 100 CHI=PARU(2)*PYR(0)
55812 CTHE=2D0*PYR(0)-1D0
55813 PHI=PARU(2)*PYR(0)
55814 CCHI=COS(CHI)
55815 SCHI=SIN(CHI)
55816 C2CHI=COS(2D0*CHI)
55817 S2CHI=SIN(2D0*CHI)
55818 THE=ACOS(CTHE)
55819 STHE=SIN(THE)
55820 C2PHI=COS(2D0*(PHI-PARJ(134)))
55821 S2PHI=SIN(2D0*(PHI-PARJ(134)))
55822 SIG=((1D0+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
55823 &2D0*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
55824 &2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*C2CHI*C2PHI-2D0*CTHE*S2CHI*
55825 &S2PHI)*HF3-((1D0+CTHE**2)*C2CHI*S2PHI+2D0*CTHE*S2CHI*C2PHI)*HF4)*
55826 &SIGT-2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*(CTHE*CCHI*C2PHI-
55827 &SCHI*S2PHI)*HF3+2D0*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
55828 &4D0*SQ2*STHE*CCHI*HF2*SIGA+2D0*CTHE*HF2*SIGP
55829 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100
55830
55831 RETURN
55832 END
55833
55834C*********************************************************************
55835
55836C...PYONIA
55837C...Generates Upsilon and toponium decays into three gluons
55838C...or two gluons and a photon.
55839
55840 SUBROUTINE PYONIA(KFL,ECM)
55841
55842C...Double precision and integer declarations.
55843 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55844 IMPLICIT INTEGER(I-N)
55845 INTEGER PYK,PYCHGE,PYCOMP
55846C...Commonblocks.
55847 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
55848 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55849 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55850 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
55851
55852C...Printout. Check input parameters.
55853 IF(MSTU(12).GE.1) CALL PYLIST(0)
55854 IF(KFL.LT.0.OR.KFL.GT.8) THEN
55855 CALL PYERRM(16,'(PYONIA:) called with unknown flavour code')
55856 IF(MSTU(21).GE.1) RETURN
55857 ENDIF
55858 IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN
55859 CALL PYERRM(16,'(PYONIA:) called with too small CM energy')
55860 IF(MSTU(21).GE.1) RETURN
55861 ENDIF
55862
55863C...Initial e+e- and onium state (optional).
55864 NC=0
55865 IF(MSTJ(115).GE.2) THEN
55866 NC=NC+2
55867 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
55868 K(NC-1,1)=21
55869 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
55870 K(NC,1)=21
55871 ENDIF
55872 KFLC=IABS(KFL)
55873 IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
55874 NC=NC+1
55875 KF=110*KFLC+3
55876 MSTU10=MSTU(10)
55877 MSTU(10)=1
55878 P(NC,5)=ECM
55879 CALL PY1ENT(NC,KF,ECM,0D0,0D0)
55880 K(NC,1)=21
55881 K(NC,3)=1
55882 MSTU(10)=MSTU10
55883 ENDIF
55884
55885C...Choose x1 and x2 according to matrix element.
55886 NTRY=0
55887 100 X1=PYR(0)
55888 X2=PYR(0)
55889 X3=2D0-X1-X2
55890 IF(X3.GE.1D0.OR.((1D0-X1)/(X2*X3))**2+((1D0-X2)/(X1*X3))**2+
55891 &((1D0-X3)/(X1*X2))**2.LE.2D0*PYR(0)) GOTO 100
55892 NTRY=NTRY+1
55893 NJET=3
55894 IF(MSTJ(101).LE.4) CALL PY3ENT(NC+1,21,21,21,ECM,X1,X3)
55895 IF(MSTJ(101).GE.5) CALL PY3ENT(-(NC+1),21,21,21,ECM,X1,X3)
55896
55897C...Photon-gluon-gluon events. Small system modifications. Jet origin.
55898 MSTU(111)=MSTJ(108)
55899 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
55900 &MSTU(111)=1
55901 PARU(112)=PARJ(121)
55902 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
55903 QF=0D0
55904 IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3D0
55905 RGAM=7.2D0*QF**2*PARU(101)/PYALPS(ECM**2)
55906 MK=0
55907 ECMC=ECM
55908 IF(PYR(0).GT.RGAM/(1D0+RGAM)) THEN
55909 IF(1D0-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
55910 & NJET=2
55911 IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL PY2ENT(NC+1,21,21,ECM)
55912 IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL PY2ENT(-(NC+1),21,21,ECM)
55913 ELSE
55914 MK=1
55915 ECMC=SQRT(1D0-X1)*ECM
55916 IF(ECMC.LT.2D0*PARJ(127)) GOTO 100
55917 K(NC+1,1)=1
55918 K(NC+1,2)=22
55919 K(NC+1,4)=0
55920 K(NC+1,5)=0
55921 IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
55922 IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
55923 IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
55924 IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
55925 NJET=2
55926 IF(ECMC.LT.4D0*PARJ(127)) THEN
55927 MSTU10=MSTU(10)
55928 MSTU(10)=1
55929 P(NC+2,5)=ECMC
55930 CALL PY1ENT(NC+2,83,0.5D0*(X2+X3)*ECM,PARU(1),0D0)
55931 MSTU(10)=MSTU10
55932 NJET=0
55933 ENDIF
55934 ENDIF
55935 DO 110 IP=NC+1,N
55936 K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
55937 110 CONTINUE
55938
55939C...Differential cross-sections. Upper limit for cross-section.
55940 IF(MSTJ(106).EQ.1) THEN
55941 SQ2=SQRT(2D0)
55942 HF1=1D0-PARJ(131)*PARJ(132)
55943 HF3=PARJ(133)**2
55944 CT13=(X1*X3-2D0*X1-2D0*X3+2D0)/(X1*X3)
55945 ST13=SQRT(1D0-CT13**2)
55946 SIGL=0.5D0*X3**2*((1D0-X2)**2+(1D0-X3)**2)*ST13**2
55947 SIGU=(X1*(1D0-X1))**2+(X2*(1D0-X2))**2+(X3*(1D0-X3))**2-SIGL
55948 SIGT=0.5D0*SIGL
55949 SIGI=(SIGL*CT13/ST13+0.5D0*X1*X3*(1D0-X2)**2*ST13)/SQ2
55950 SIGMAX=(2D0*HF1+HF3)*ABS(SIGU)+2D0*(HF1+HF3)*ABS(SIGL)+2D0*(HF1+
55951 & 2D0*HF3)*ABS(SIGT)+2D0*SQ2*(HF1+2D0*HF3)*ABS(SIGI)
55952
55953C...Angular orientation of event.
55954 120 CHI=PARU(2)*PYR(0)
55955 CTHE=2D0*PYR(0)-1D0
55956 PHI=PARU(2)*PYR(0)
55957 CCHI=COS(CHI)
55958 SCHI=SIN(CHI)
55959 C2CHI=COS(2D0*CHI)
55960 S2CHI=SIN(2D0*CHI)
55961 THE=ACOS(CTHE)
55962 STHE=SIN(THE)
55963 C2PHI=COS(2D0*(PHI-PARJ(134)))
55964 S2PHI=SIN(2D0*(PHI-PARJ(134)))
55965 SIG=((1D0+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2D0*(STHE**2*HF1-
55966 & STHE**2*C2PHI*HF3)*SIGL+2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*
55967 & C2CHI*C2PHI-2D0*CTHE*S2CHI*S2PHI)*HF3)*SIGT-
55968 & 2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*
55969 & (CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
55970 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 120
55971 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
55972 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
55973 ENDIF
55974
55975C...Generate parton shower. Rearrange along strings and check.
55976 IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
55977 CALL PYSHOW(NC+MK+1,-NJET,ECMC)
55978 MSTJ14=MSTJ(14)
55979 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
55980 IF(MSTJ(105).GE.0) MSTU(28)=0
55981 CALL PYPREP(0)
55982 MSTJ(14)=MSTJ14
55983 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
55984 ENDIF
55985
55986C...Generate fragmentation. Information for PYTABU:
55987 IF(MSTJ(105).EQ.1) CALL PYEXEC
55988 MSTU(161)=110*KFLC+3
55989 MSTU(162)=0
55990
55991 RETURN
55992 END
55993
55994C*********************************************************************
55995
55996C...PYBOOK
55997C...Books a histogram.
55998
55999 SUBROUTINE PYBOOK(ID,TITLE,NX,XL,XU)
56000
56001C...Double precision declaration.
56002 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56003 IMPLICIT INTEGER(I-N)
56004C...Commonblock.
56005 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
56006 SAVE /PYBINS/
56007C...Local character variables.
56008 CHARACTER TITLE*(*), TITFX*60
56009
56010C...Check that input is sensible. Find initial address in memory.
56011 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
56012 &'(PYBOOK:) not allowed histogram number')
56013 IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28,
56014 &'(PYBOOK:) not allowed number of bins')
56015 IF(XL.GE.XU) CALL PYERRM(28,
56016 &'(PYBOOK:) x limits in wrong order')
56017 INDX(ID)=IHIST(4)
56018 IHIST(4)=IHIST(4)+28+NX
56019 IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28,
56020 &'(PYBOOK:) out of histogram space')
56021 IS=INDX(ID)
56022
56023C...Store histogram size and reset contents.
56024 BIN(IS+1)=NX
56025 BIN(IS+2)=XL
56026 BIN(IS+3)=XU
56027 BIN(IS+4)=(XU-XL)/NX
56028 CALL PYNULL(ID)
56029
56030C...Store title by conversion to integer to double precision.
56031 TITFX=TITLE//' '
56032 DO 100 IT=1,20
56033 BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+
56034 & 256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT))
56035 100 CONTINUE
56036
56037 RETURN
56038 END
56039
56040C*********************************************************************
56041
56042C...PYFILL
56043C...Fills entry in histogram.
56044
56045 SUBROUTINE PYFILL(ID,X,W)
56046
56047C...Double precision declaration.
56048 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56049 IMPLICIT INTEGER(I-N)
56050C...Commonblock.
56051 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
56052 SAVE /PYBINS/
56053
56054C...Find initial address in memory. Increase number of entries.
56055 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
56056 &'(PYFILL:) not allowed histogram number')
56057 IS=INDX(ID)
56058 IF(IS.EQ.0) CALL PYERRM(28,
56059 &'(PYFILL:) filling unbooked histogram')
56060 BIN(IS+5)=BIN(IS+5)+1D0
56061
56062C...Find bin in x, including under/overflow, and fill.
56063 IF(X.LT.BIN(IS+2)) THEN
56064 BIN(IS+6)=BIN(IS+6)+W
56065 ELSEIF(X.GE.BIN(IS+3)) THEN
56066 BIN(IS+8)=BIN(IS+8)+W
56067 ELSE
56068 BIN(IS+7)=BIN(IS+7)+W
56069 IX=(X-BIN(IS+2))/BIN(IS+4)
56070 IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX))
56071 BIN(IS+9+IX)=BIN(IS+9+IX)+W
56072 ENDIF
56073
56074 RETURN
56075 END
56076
56077C*********************************************************************
56078
56079C...PYFACT
56080C...Multiplies histogram contents by factor.
56081
56082 SUBROUTINE PYFACT(ID,F)
56083
56084C...Double precision declaration.
56085 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56086 IMPLICIT INTEGER(I-N)
56087C...Commonblock.
56088 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
56089 SAVE /PYBINS/
56090
56091C...Find initial address in memory. Multiply all contents bins.
56092 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
56093 &'(PYFACT:) not allowed histogram number')
56094 IS=INDX(ID)
56095 IF(IS.EQ.0) CALL PYERRM(28,
56096 &'(PYFACT:) scaling unbooked histogram')
56097 DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1))
56098 BIN(IX)=F*BIN(IX)
56099 100 CONTINUE
56100
56101 RETURN
56102 END
56103
56104C*********************************************************************
56105
56106C...PYOPER
56107C...Performs operations between histograms.
56108
56109 SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2)
56110
56111C...Double precision declaration.
56112 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56113 IMPLICIT INTEGER(I-N)
56114C...Commonblock.
56115 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
56116 SAVE /PYBINS/
56117C...Character variable.
56118 CHARACTER OPER*(*)
56119
56120C...Find initial addresses in memory, and histogram size.
56121 IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28,
56122 &'(PYFACT:) not allowed histogram number')
56123 IS1=INDX(ID1)
56124 IS2=INDX(MIN(IHIST(1),MAX(1,ID2)))
56125 IS3=INDX(MIN(IHIST(1),MAX(1,ID3)))
56126 NX=NINT(BIN(IS3+1))
56127 IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1))
56128
56129C...Update info on number of histogram entries.
56130 IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN
56131 BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5)
56132 ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN
56133 BIN(IS3+5)=BIN(IS1+5)
56134 ENDIF
56135
56136C...Operations on pair of histograms: addition, subtraction,
56137C...multiplication, division.
56138 IF(OPER.EQ.'+') THEN
56139 DO 100 IX=6,8+NX
56140 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX)
56141 100 CONTINUE
56142 ELSEIF(OPER.EQ.'-') THEN
56143 DO 110 IX=6,8+NX
56144 BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX)
56145 110 CONTINUE
56146 ELSEIF(OPER.EQ.'*') THEN
56147 DO 120 IX=6,8+NX
56148 BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX)
56149 120 CONTINUE
56150 ELSEIF(OPER.EQ.'/') THEN
56151 DO 130 IX=6,8+NX
56152 FA2=F2*BIN(IS2+IX)
56153 IF(ABS(FA2).LE.1D-20) THEN
56154 BIN(IS3+IX)=0D0
56155 ELSE
56156 BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2
56157 ENDIF
56158 130 CONTINUE
56159
56160C...Operations on single histogram: multiplication+addition,
56161C...square root+addition, logarithm+addition.
56162 ELSEIF(OPER.EQ.'A') THEN
56163 DO 140 IX=6,8+NX
56164 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2
56165 140 CONTINUE
56166 ELSEIF(OPER.EQ.'S') THEN
56167 DO 150 IX=6,8+NX
56168 BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2
56169 150 CONTINUE
56170 ELSEIF(OPER.EQ.'L') THEN
56171 ZMIN=1D20
56172 DO 160 IX=9,8+NX
56173 IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20)
56174 & ZMIN=0.8D0*BIN(IS1+IX)
56175 160 CONTINUE
56176 DO 170 IX=6,8+NX
56177 BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2
56178 170 CONTINUE
56179
56180C...Operation on two or three histograms: average and
56181C...standard deviation.
56182 ELSEIF(OPER.EQ.'M') THEN
56183 DO 180 IX=6,8+NX
56184 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
56185 BIN(IS2+IX)=0D0
56186 ELSE
56187 BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX)
56188 ENDIF
56189 IF(ID3.NE.0) THEN
56190 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
56191 BIN(IS3+IX)=0D0
56192 ELSE
56193 BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)-
56194 & BIN(IS2+IX)**2))
56195 ENDIF
56196 ENDIF
56197 BIN(IS1+IX)=F1*BIN(IS1+IX)
56198 180 CONTINUE
56199 ENDIF
56200
56201 RETURN
56202 END
56203
56204C*********************************************************************
56205
56206C...PYHIST
56207C...Prints and resets all histograms.
56208
56209 SUBROUTINE PYHIST
56210
56211C...Double precision declaration.
56212 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56213 IMPLICIT INTEGER(I-N)
56214C...Commonblock.
56215 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
56216 SAVE /PYBINS/
56217
56218C...Loop over histograms, print and reset used ones.
56219 DO 100 ID=1,IHIST(1)
56220 IS=INDX(ID)
56221 IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN
56222 CALL PYPLOT(ID)
56223 CALL PYNULL(ID)
56224 ENDIF
56225 100 CONTINUE
56226
56227 RETURN
56228 END
56229
56230C*********************************************************************
56231
56232C...PYPLOT
56233C...Prints a histogram (but does not reset it).
56234
56235 SUBROUTINE PYPLOT(ID)
56236
56237C...Double precision declaration.
56238 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56239 IMPLICIT INTEGER(I-N)
56240C...Commonblocks.
56241 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56242 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
56243 SAVE /PYDAT1/,/PYBINS/
56244C...Local arrays and character variables.
56245 DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10)
56246 CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
56247
56248C...Steps in histogram scale. Character sequence.
56249 DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
56250 DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/
56251
56252C...Find initial address in memory; skip if empty histogram.
56253 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
56254 IS=INDX(ID)
56255 IF(IS.EQ.0) RETURN
56256 IF(NINT(BIN(IS+5)).LE.0) THEN
56257 WRITE(MSTU(11),5000) ID
56258 RETURN
56259 ENDIF
56260
56261C...Number of histogram lines and x bins.
56262 LIN=IHIST(3)-18
56263 NX=NINT(BIN(IS+1))
56264
56265C...Extract title by conversion from double precision via integer.
56266 DO 100 IT=1,20
56267 IEQ=NINT(BIN(IS+8+NX+IT))
56268 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256)
56269 & //CHAR(MOD(IEQ,256))
56270 100 CONTINUE
56271
56272C...Find time; print title.
56273 CALL PYTIME(IDATI)
56274 IF(IDATI(1).GT.0) THEN
56275 WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5)
56276 ELSE
56277 WRITE(MSTU(11),5200) ID, TITLE
56278 ENDIF
56279
56280C...Find minimum and maximum bin content.
56281 YMIN=BIN(IS+9)
56282 YMAX=BIN(IS+9)
56283 DO 110 IX=IS+10,IS+8+NX
56284 IF(BIN(IX).LT.YMIN) YMIN=BIN(IX)
56285 IF(BIN(IX).GT.YMAX) YMAX=BIN(IX)
56286 110 CONTINUE
56287
56288C...Determine scale and step size for y axis.
56289 IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN
56290 IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0
56291 IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0
56292 IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10
56293 IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1
56294 IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1
56295 DELY=DYAC(1)
56296 DO 120 IDEL=1,9
56297 IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1)
56298 120 CONTINUE
56299 DY=DELY*10D0**IPOT
56300
56301C...Convert bin contents to integer form; fractional fill in top row.
56302 DO 130 IX=1,NX
56303 CTA=ABS(BIN(IS+8+IX))/DY
56304 IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX))
56305 IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0)))
56306 130 CONTINUE
56307 IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN)
56308 IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX)
56309
56310C...Print histogram row by row.
56311 DO 150 IR=IRMA,IRMI,-1
56312 IF(IR.EQ.0) GOTO 150
56313 OUT=' '
56314 DO 140 IX=1,NX
56315 IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX))
56316 IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10)
56317 140 CONTINUE
56318 WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT
56319 150 CONTINUE
56320
56321C...Print sign and value of bin contents.
56322 IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10
56323 OUT=' '
56324 DO 160 IX=1,NX
56325 IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11)
56326 IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX)))
56327 160 CONTINUE
56328 WRITE(MSTU(11),5400) OUT
56329 DO 180 IR=4,1,-1
56330 DO 170 IX=1,NX
56331 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
56332 170 CONTINUE
56333 WRITE(MSTU(11),5500) IPOT+IR-4, OUT
56334 180 CONTINUE
56335
56336C...Print sign and value of lower bin edge.
56337 IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+
56338 & 10.0001D0)-10
56339 OUT=' '
56340 DO 190 IX=1,NX
56341 IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3))
56342 & OUT(IX:IX)=CHA(11)
56343 IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4)))
56344 190 CONTINUE
56345 WRITE(MSTU(11),5600) OUT
56346 DO 210 IR=3,1,-1
56347 DO 200 IX=1,NX
56348 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
56349 200 CONTINUE
56350 WRITE(MSTU(11),5500) IPOT+IR-3, OUT
56351 210 CONTINUE
56352 ENDIF
56353
56354C...Calculate and print statistics.
56355 CSUM=0D0
56356 CXSUM=0D0
56357 CXXSUM=0D0
56358 DO 220 IX=1,NX
56359 CTA=ABS(BIN(IS+8+IX))
56360 X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4)
56361 CSUM=CSUM+CTA
56362 CXSUM=CXSUM+CTA*X
56363 CXXSUM=CXXSUM+CTA*X**2
56364 220 CONTINUE
56365 XMEAN=CXSUM/MAX(CSUM,1D-20)
56366 XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2))
56367 WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6),
56368 &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3)
56369
56370C...Formats for output.
56371 5000 FORMAT(/5X,'Histogram no',I5,' : no entries')
56372 5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X,
56373 &I2,':',I2/)
56374 5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/)
56375 5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100)
56376 5400 FORMAT(/8X,'Contents',3X,A100)
56377 5500 FORMAT(9X,'*10**',I2,3X,A100)
56378 5600 FORMAT(/8X,'Low edge',3X,A100)
56379 5700 FORMAT(/5X,'Entries =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow ='
56380 &,D12.4,6X,'Low edge =',D12.4/5X,'All chan =',D12.4,6X,
56381 &'Rms =',D12.4,6X,'Overflow =',D12.4,6X,'High edge =',D12.4)
56382
56383 RETURN
56384 END
56385
56386C*********************************************************************
56387
56388C...PYNULL
56389C...Resets bin contents of a histogram.
56390
56391 SUBROUTINE PYNULL(ID)
56392
56393C...Double precision declaration.
56394 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56395 IMPLICIT INTEGER(I-N)
56396C...Commonblock.
56397 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
56398 SAVE /PYBINS/
56399
56400 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
56401 IS=INDX(ID)
56402 IF(IS.EQ.0) RETURN
56403 DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1))
56404 BIN(IX)=0D0
56405 100 CONTINUE
56406
56407 RETURN
56408 END
56409
56410C*********************************************************************
56411
56412C...PYDUMP
56413C...Dumps histogram contents on file for reading by other program.
56414C...Can also read back own dump.
56415
56416 SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI)
56417
56418C...Double precision declaration.
56419 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56420 IMPLICIT INTEGER(I-N)
56421C...Commonblock.
56422 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
56423 SAVE /PYBINS/
56424C...Local arrays and character variables.
56425 DIMENSION IHI(*),ISS(100),VAL(5)
56426 CHARACTER TITLE*60,FORMAT*13
56427
56428C...Dump all histograms that have been booked,
56429C...including titles and ranges, one after the other.
56430 IF(MDUMP.EQ.1) THEN
56431
56432C...Loop over histograms and find which are wanted and booked.
56433 IF(NHI.LE.0) THEN
56434 NW=IHIST(1)
56435 ELSE
56436 NW=NHI
56437 ENDIF
56438 DO 130 IW=1,NW
56439 IF(NHI.EQ.0) THEN
56440 ID=IW
56441 ELSE
56442 ID=IHI(IW)
56443 ENDIF
56444 IS=INDX(ID)
56445 IF(IS.NE.0) THEN
56446
56447C...Write title, histogram size, filling statistics.
56448 NX=NINT(BIN(IS+1))
56449 DO 100 IT=1,20
56450 IEQ=NINT(BIN(IS+8+NX+IT))
56451 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//
56452 & CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256))
56453 100 CONTINUE
56454 WRITE(LFN,5100) ID,TITLE
56455 WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3)
56456 WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7),
56457 & BIN(IS+8)
56458
56459
56460C...Write histogram contents, in groups of five.
56461 DO 120 IXG=1,(NX+4)/5
56462 DO 110 IXV=1,5
56463 IX=5*IXG+IXV-5
56464 IF(IX.LE.NX) THEN
56465 VAL(IXV)=BIN(IS+8+IX)
56466 ELSE
56467 VAL(IXV)=0D0
56468 ENDIF
56469 110 CONTINUE
56470 WRITE(LFN,5400) (VAL(IXV),IXV=1,5)
56471 120 CONTINUE
56472
56473C...Go to next histogram; finish.
56474 ELSEIF(NHI.GT.0) THEN
56475 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
56476 ENDIF
56477 130 CONTINUE
56478
56479C...Read back in histograms dumped MDUMP=1.
56480 ELSEIF(MDUMP.EQ.2) THEN
56481
56482C...Read histogram number, title and range, and book.
56483 140 READ(LFN,5100,END=170) ID,TITLE
56484 READ(LFN,5200) NX,XL,XU
56485 CALL PYBOOK(ID,TITLE,NX,XL,XU)
56486 IS=INDX(ID)
56487
56488C...Read filling statistics.
56489 READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8)
56490 BIN(IS+5)=DBLE(NENTRY)
56491
56492C...Read histogram contents, in groups of five.
56493 DO 160 IXG=1,(NX+4)/5
56494 READ(LFN,5400) (VAL(IXV),IXV=1,5)
56495 DO 150 IXV=1,5
56496 IX=5*IXG+IXV-5
56497 IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV)
56498 150 CONTINUE
56499 160 CONTINUE
56500
56501C...Go to next histogram; finish.
56502 GOTO 140
56503 170 CONTINUE
56504
56505C...Write histogram contents in column format,
56506C...convenient e.g. for GNUPLOT input.
56507 ELSEIF(MDUMP.EQ.3) THEN
56508
56509C...Find addresses to wanted histograms.
56510 NSS=0
56511 IF(NHI.LE.0) THEN
56512 NW=IHIST(1)
56513 ELSE
56514 NW=NHI
56515 ENDIF
56516 DO 180 IW=1,NW
56517 IF(NHI.EQ.0) THEN
56518 ID=IW
56519 ELSE
56520 ID=IHI(IW)
56521 ENDIF
56522 IS=INDX(ID)
56523 IF(IS.NE.0.AND.NSS.LT.100) THEN
56524 NSS=NSS+1
56525 ISS(NSS)=IS
56526 ELSEIF(NSS.GE.100) THEN
56527 CALL PYERRM(8,'(PYDUMP:) too many histograms requested')
56528 ELSEIF(NHI.GT.0) THEN
56529 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
56530 ENDIF
56531 180 CONTINUE
56532
56533C...Check that they have common number of x bins. Fix format.
56534 NX=NINT(BIN(ISS(1)+1))
56535 DO 190 IW=2,NSS
56536 IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN
56537 CALL PYERRM(8,'(PYDUMP:) different number of bins')
56538 RETURN
56539 ENDIF
56540 190 CONTINUE
56541 FORMAT='(1P,000E12.4)'
56542 WRITE(FORMAT(5:7),'(I3)') NSS+1
56543
56544C...Write histogram contents; first column x values.
56545 DO 200 IX=1,NX
56546 X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4)
56547 WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS)
56548 200 CONTINUE
56549
56550 ENDIF
56551
56552C...Formats for output.
56553 5100 FORMAT(I5,5X,A60)
56554 5200 FORMAT(I5,1P,2D12.4)
56555 5300 FORMAT(I12,1P,3D12.4)
56556 5400 FORMAT(1P,5D12.4)
56557
56558 RETURN
56559 END
56560
56561C*********************************************************************
56562
56563C...PYKCUT
56564C...Dummy routine, which the user can replace in order to make cuts on
56565C...the kinematics on the parton level before the matrix elements are
56566C...evaluated and the event is generated. The cross-section estimates
56567C...will automatically take these cuts into account, so the given
56568C...values are for the allowed phase space region only. MCUT=0 means
56569C...that the event has passed the cuts, MCUT=1 that it has failed.
56570
56571 SUBROUTINE PYKCUT(MCUT)
56572
56573C...Double precision and integer declarations.
56574 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56575 IMPLICIT INTEGER(I-N)
56576 INTEGER PYK,PYCHGE,PYCOMP
56577C...Commonblocks.
56578 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56579 COMMON/PYINT1/MINT(400),VINT(400)
56580 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
56581 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
56582
56583C...Set default value (accepting event) for MCUT.
56584 MCUT=0
56585
56586C...Read out subprocess number.
56587 ISUB=MINT(1)
56588 ISTSB=ISET(ISUB)
56589
56590C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
56591 TAU=VINT(21)
56592 YST=VINT(22)
56593 CTH=0D0
56594 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
56595 TAUP=0D0
56596 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
56597
56598C...Calculate x_1, x_2, x_F.
56599 IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN
56600 X1=SQRT(TAU)*EXP(YST)
56601 X2=SQRT(TAU)*EXP(-YST)
56602 ELSE
56603 X1=SQRT(TAUP)*EXP(YST)
56604 X2=SQRT(TAUP)*EXP(-YST)
56605 ENDIF
56606 XF=X1-X2
56607
56608C...Calculate shat, that, uhat, p_T^2.
56609 SHAT=TAU*VINT(2)
56610 SQM3=VINT(63)
56611 SQM4=VINT(64)
56612 RM3=SQM3/SHAT
56613 RM4=SQM4/SHAT
56614 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
56615 RPTS=4D0*VINT(71)**2/SHAT
56616 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
56617 RM34=2D0*RM3*RM4
56618 RSQM=1D0+RM34
56619 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
56620 THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
56621 UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
56622 PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2))
56623
56624C...Decisions by user to be put here.
56625
56626C...Stop program if this routine is ever called.
56627C...You should not copy these lines to your own routine.
56628 WRITE(MSTU(11),5000)
56629 IF(PYR(0).LT.10D0) STOP
56630
56631C...Format for error printout.
56632 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ',
56633 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
56634 &1X,'Execution stopped!')
56635
56636 RETURN
56637 END
56638
56639C*********************************************************************
56640
56641C...PYEVWT
56642C...Dummy routine, which the user can replace in order to multiply the
56643C...standard PYTHIA differential cross-section by a process- and
56644C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
56645C...to generation of weighted events, with weight 1/WTXS, while for
56646C...MSTP(142)=2 it corresponds to a modification of the underlying
56647C...physics.
56648
56649 SUBROUTINE PYEVWT(WTXS)
56650
56651C...Double precision and integer declarations.
56652 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56653 IMPLICIT INTEGER(I-N)
56654 INTEGER PYK,PYCHGE,PYCOMP
56655C...Commonblocks.
56656 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56657 COMMON/PYINT1/MINT(400),VINT(400)
56658 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
56659 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
56660
56661C...Set default weight for WTXS.
56662 WTXS=1D0
56663
56664C...Read out subprocess number.
56665 ISUB=MINT(1)
56666 ISTSB=ISET(ISUB)
56667
56668C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
56669 TAU=VINT(21)
56670 YST=VINT(22)
56671 CTH=0D0
56672 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
56673 TAUP=0D0
56674 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
56675
56676C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
56677 X1=VINT(41)
56678 X2=VINT(42)
56679 XF=X1-X2
56680 SHAT=VINT(44)
56681 THAT=VINT(45)
56682 UHAT=VINT(46)
56683 PT2=VINT(48)
56684
56685C...Modifications by user to be put here.
56686
56687C...Stop program if this routine is ever called.
56688C...You should not copy these lines to your own routine.
56689 WRITE(MSTU(11),5000)
56690 IF(PYR(0).LT.10D0) STOP
56691
56692C...Format for error printout.
56693 5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ',
56694 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
56695 &1X,'Execution stopped!')
56696
56697 RETURN
56698 END
56699
56700C*********************************************************************
56701
56702C...UPINIT
56703C...Dummy routine, to be replaced by a user implementing external
56704C...processes. Is supposed to fill the HEPRUP commonblock with info
56705C...on incoming beams and allowed processes.
56706
56707 SUBROUTINE UPINIT
56708
56709C...Double precision and integer declarations.
56710 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56711 IMPLICIT INTEGER(I-N)
56712
56713C...User process initialization commonblock.
56714 INTEGER MAXPUP
56715 PARAMETER (MAXPUP=100)
56716 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
56717 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
56718 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
56719 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
56720 &LPRUP(MAXPUP)
56721 SAVE /HEPRUP/
56722
56723 RETURN
56724 END
56725
56726C*********************************************************************
56727
56728C...UPEVNT
56729C...Dummy routine, to be replaced by a user implementing external
56730C...processes. Depending on cross section model chosen, it either has
56731C...to generate a process of the type IDPRUP requested, or pick a type
56732C...itself and generate this event. The event is to be stored in the
56733C...HEPEUP commonblock, including (often) an event weight.
56734
56735 SUBROUTINE UPEVNT
56736
56737C...Double precision and integer declarations.
56738 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56739 IMPLICIT INTEGER(I-N)
56740
56741C...User process event common block.
56742 INTEGER MAXNUP
56743 PARAMETER (MAXNUP=500)
56744 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
56745 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
56746 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
56747 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
56748 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
56749 SAVE /HEPEUP/
56750
56751 RETURN
56752 END
56753
56754C*********************************************************************
56755
56756C...PYTAUD
56757C...Dummy routine, to be replaced by user, to handle the decay of a
56758C...polarized tau lepton.
56759C...Input:
56760C...ITAU is the position where the decaying tau is stored in /PYJETS/.
56761C...IORIG is the position where the mother of the tau is stored;
56762C... is 0 when the mother is not stored.
56763C...KFORIG is the flavour of the mother of the tau;
56764C... is 0 when the mother is not known.
56765C...Note that IORIG=0 does not necessarily imply KFORIG=0;
56766C... e.g. in B hadron semileptonic decays the W propagator
56767C... is not explicitly stored but the W code is still unambiguous.
56768C...Output:
56769C...NDECAY is the number of decay products in the current tau decay.
56770C...These decay products should be added to the /PYJETS/ common block,
56771C...in positions N+1 through N+NDECAY. For each product I you must
56772C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
56773C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
56774
56775 SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
56776
56777C...Double precision and integer declarations.
56778 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56779 IMPLICIT INTEGER(I-N)
56780 INTEGER PYK,PYCHGE,PYCOMP
56781C...Commonblocks.
56782 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56783 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56784 SAVE /PYJETS/,/PYDAT1/
56785
56786C...Stop program if this routine is ever called.
56787C...You should not copy these lines to your own routine.
56788 NDECAY=ITAU+IORIG+KFORIG
56789 WRITE(MSTU(11),5000)
56790 IF(PYR(0).LT.10D0) STOP
56791
56792C...Format for error printout.
56793 5000 FORMAT(1X,'Error: you did not link your PYTAUD routine ',
56794 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
56795 &1X,'Execution stopped!')
56796
56797 RETURN
56798 END
56799
56800C*********************************************************************
56801
56802C...PYTIME
56803C...Finds current date and time.
56804C...Since this task is not standardized in Fortran 77, the routine
56805C...is dummy, to be replaced by the user. Examples are given for
56806C...the Fortran 90 routine and DEC Fortran 77, and what to do if
56807C...you do not have access to suitable routines.
56808
56809 SUBROUTINE PYTIME(IDATI)
56810
56811C...Double precision and integer declarations.
56812 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56813 IMPLICIT INTEGER(I-N)
56814 INTEGER PYK,PYCHGE,PYCOMP
56815 CHARACTER*8 ATIME
56816C...Local array.
56817 INTEGER IDATI(6),IDTEMP(3)
56818
56819C...Example 0: if you do not have suitable routines.
56820 DO 100 J=1,6
56821 IDATI(J)=0
56822 100 CONTINUE
56823
56824C...Example 1: Fortran 90 routine.
56825C INTEGER IVAL(8)
56826C CALL DATE_AND_TIME(VALUES=IVAL)
56827C IDATI(1)=IVAL(1)
56828C IDATI(2)=IVAL(2)
56829C IDATI(3)=IVAL(3)
56830C IDATI(4)=IVAL(5)
56831C IDATI(5)=IVAL(6)
56832C IDATI(6)=IVAL(7)
56833
56834C...Example 2: DEC Fortran 77. AIX.
56835C CALL IDATE(IMON,IDAY,IYEAR)
56836C IDATI(1)=IYEAR
56837C IDATI(2)=IMON
56838C IDATI(3)=IDAY
56839C CALL ITIME(IHOUR,IMIN,ISEC)
56840C IDATI(4)=IHOUR
56841C IDATI(5)=IMIN
56842C IDATI(6)=ISEC
56843
56844C...Example 3: DEC Fortran, IRIX, IRIX64.
56845C CALL IDATE(IMON,IDAY,IYEAR)
56846C IDATI(1)=IYEAR
56847C IDATI(2)=IMON
56848C IDATI(3)=IDAY
56849C CALL TIME(ATIME)
56850C IHOUR=0
56851C IMIN=0
56852C ISEC=0
56853C READ(ATIME(1:2),'(I2)') IHOUR
56854C READ(ATIME(4:5),'(I2)') IMIN
56855C READ(ATIME(7:8),'(I2)') ISEC
56856C IDATI(4)=IHOUR
56857C IDATI(5)=IMIN
56858C IDATI(6)=ISEC
56859
56860C...Example 4: GNU LINUX libU77, SunOS.
56861c CALL IDATE(IDTEMP)
56862c IDATI(1)=IDTEMP(3)
56863c IDATI(2)=IDTEMP(2)
56864c IDATI(3)=IDTEMP(1)
56865c CALL ITIME(IDTEMP)
56866c IDATI(4)=IDTEMP(1)
56867c IDATI(5)=IDTEMP(2)
56868c IDATI(6)=IDTEMP(3)
56869
56870C...Common code to ensure right century.
56871 IDATI(1)=2000+MOD(IDATI(1),100)
56872
56873 RETURN
56874 END