]> git.uio.no Git - u/mrichter/AliRoot.git/blame - PYTHIA6/pythia6214.f
git://git.uio.no / u / mrichter / AliRoot.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Removing the flat makefiles
[u/mrichter/AliRoot.git] / PYTHIA6 / pythia6214.f
CommitLineData
2dfa57d1 1C*********************************************************************
2C*********************************************************************
3C* **
4C* January 2003 **
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* Computing Division, Simulations Group **
20C* Fermi National Accelerator Laboratory **
21C* MS 234, Batavia, IL 60510, USA **
22C* phone + 1 - 630 - 840 - 2556 **
23C* E-mail mrenna@fnal.gov **
24C* **
25C* Baryon and lepton number violation parts by **
26C* Peter Skands **
27C* Department of Theoretical Physics **
28C* Lund University **
29C* Solvegatan 14A, S-223 62 Lund, Sweden **
30C* phone +46 - 46 - 222 31 92 **
31C* E-mail zeiler@thep.lu.se **
32C* **
33C* PYTHIA 7 efforts coordinated by **
34C* Leif Lonnblad **
35C* Department of Theoretical Physics **
36C* Lund University **
37C* Solvegatan 14A, S-223 62 Lund, Sweden **
38C* phone +46 - 46 - 222 77 80 **
39C* E-mail leif@thep.lu.se **
40C* **
41C* Several parts are written by Hans-Uno Bengtsson **
42C* PYSHOW is written together with Mats Bengtsson **
43C* PYMAEL is written by Emanuel Norrbin **
44C* advanced popcorn baryon production written by Patrik Eden **
45C* code for virtual photons mainly written by Christer Friberg **
46C* code for low-mass strings mainly written by Emanuel Norrbin **
47C* Bose-Einstein code mainly written by Leif Lonnblad **
48C* CTEQ parton distributions are by the CTEQ collaboration **
49C* GRV 94 parton distributions are by Glueck, Reya and Vogt **
50C* SaS photon parton distributions together with Gerhard Schuler **
51C* g + g and q + qbar -> t + tbar + H code by Zoltan Kunszt **
52C* MSSM Higgs mass calculation code by M. Carena, **
53C* J.R. Espinosa, M. Quiros and C.E.M. Wagner **
54C* PYGAUS adapted from CERN library (K.S. Kolbig) **
55C* **
56C* The latest program version and documentation is found on WWW **
57C* http://www.thep.lu.se/~torbjorn/Pythia.html **
58C* **
59C* Copyright Torbjorn Sjostrand, Lund 2003 **
60C* **
61C*********************************************************************
62C*********************************************************************
63C *
64C List of subprograms in order of appearance, with main purpose *
65C (S = subroutine, F = function, B = block data) *
66C *
67C B PYDATA to contain all default values *
68C S PYTEST to test the proper functioning of the package *
69C S PYHEPC to convert between /PYJETS/ and /HEPEVT/ records *
70C *
71C S PYINIT to administer the initialization procedure *
72C S PYEVNT to administer the generation of an event *
73C S PYSTAT to print cross-section and other information *
74C S PYINRE to initialize treatment of resonances *
75C S PYINBM to read in beam, target and frame choices *
76C S PYINKI to initialize kinematics of incoming particles *
77C S PYINPR to set up the selection of included processes *
78C S PYXTOT to give total, elastic and diffractive cross-sect. *
79C S PYMAXI to find differential cross-section maxima *
80C S PYPILE to select multiplicity of pileup events *
81C S PYSAVE to save alternatives for gamma-p and gamma-gamma *
82C S PYGAGA to handle lepton -> lepton + gamma branchings *
83C S PYRAND to select subprocess and kinematics for event *
84C S PYSCAT to set up kinematics and colour flow of event *
85C S PYSSPA to simulate initial state spacelike showers *
86C S PYMEMX auxiliary to PYSSPA for ME correction maximum *
87C S PYMEWT auxiliary to PYSSPA for matrix element correction *
88C S PYADSH to administrate sequential final-state showers *
89C S PYRESD to perform resonance decays *
90C S PYMULT to generate multiple interactions *
91C S PYREMN to add on target remnants *
92C S PYDIFF to set up kinematics for diffractive events *
93C S PYDISG to set up kinematics, remnant and showers for DIS *
94C S PYDOCU to compute cross-sections and handle documentation *
95C S PYFRAM to perform boosts between different frames *
96C S PYWIDT to calculate full and partial widths of resonances *
97C S PYOFSH to calculate partial width into off-shell channels *
98C S PYRECO to handle colour reconnection in W+W- events *
99C S PYKLIM to calculate borders of allowed kinematical region *
100C S PYKMAP to construct value of kinematical variable *
101C S PYSIGH to calculate differential cross-sections *
102C S PYPDFU to evaluate parton distributions *
103C S PYPDFL to evaluate parton distributions at low x and Q^2 *
104C S PYPDEL to evaluate electron parton distributions *
105C S PYPDGA to evaluate photon parton distributions (generic) *
106C S PYGGAM to evaluate photon parton distributions (SaS sets) *
107C S PYGVMD to evaluate VMD part of photon parton distributions *
108C S PYGANO to evaluate anomalous part of photon pdf's *
109C S PYGBEH to evaluate Bethe-Heitler part of photon pdf's *
110C S PYGDIR to evaluate direct contribution to photon pdf's *
111C S PYPDPI to evaluate pion parton distributions *
112C S PYPDPR to evaluate proton parton distributions *
113C F PYCTEQ to evaluate the CTEQ 3 proton parton distributions *
114C S PYGRVL to evaluate the GRV 94L proton parton distributions *
115C S PYGRVM to evaluate the GRV 94M proton parton distributions *
116C S PYGRVD to evaluate the GRV 94D proton parton distributions *
117C F PYGRVV auxiliary to the PYGRV* routines *
118C F PYGRVW auxiliary to the PYGRV* routines *
119C F PYGRVS auxiliary to the PYGRV* routines *
120C F PYCT5L to evaluate the CTEQ 5L proton parton distributions *
121C F PYCT5M to evaluate the CTEQ 5M1 proton parton distributions *
122C S PYPDPO to evaluate old proton parton distributions *
123C F PYHFTH to evaluate threshold factor for heavy flavour *
124C S PYSPLI to find flavours left in hadron when one removed *
125C F PYGAMM to evaluate ordinary Gamma function Gamma(x) *
126C S PYWAUX to evaluate auxiliary functions W1(s) and W2(s) *
127C S PYI3AU to evaluate auxiliary function I3(s,t,u,v) *
128C F PYSPEN to evaluate Spence (dilogarithm) function Sp(x) *
129C S PYQQBH to evaluate matrix element for g + g -> Q + Qbar + H *
130C *
131C S PYMSIN to initialize the supersymmetry simulation *
132C S PYAPPS to determine MSSM parameters from SUGRA input *
133C S PYSUGI to determine MSSM parameters using ISASUSY *
134C F PYRNMQ to determine running squark masses *
135C S PYTHRG to calculate sfermion third-gen. mass eigenstates *
136C S PYINOM to calculate neutralino/chargino mass eigenstates *
137C F PYRNM3 to determine running M3, gluino mass *
138C S PYEIG4 to calculate eigenvalues and -vectors in 4*4 matrix *
139C S PYHGGM to determine Higgs mass spectrum *
140C S PYSUBH to determine Higgs masses in the MSSM *
141C S PYPOLE to determine Higgs masses in the MSSM *
142C S PYRGHM auxiliary to PYPOLE *
143C S PYGFXX auxiliary to PYRGHM *
144C F PYFINT auxiliary to PYPOLE *
145C F PYFISB auxiliary to PYFINT *
146C S PYSFDC to calculate sfermion decay partial widths *
147C S PYGLUI to calculate gluino decay partial widths *
148C S PYTBBN to calculate 3-body decay of gluino to neutralino *
149C S PYTBBC to calculate 3-body decay of gluino to chargino *
150C S PYNJDC to calculate neutralino decay partial widths *
151C S PYCJDC to calculate chargino decay partial widths *
152C F PYXXZ6 auxiliary for ino 3-body decays *
153C F PYXXGA auxiliary for ino -> ino + gamma decay *
154C F PYX2XG auxiliary for ino -> ino + gauge boson decay *
155C F PYX2XH auxiliary for ino -> ino + Higgs decay *
156C S PYHEXT to calculate non-SM Higgs decay partial widths *
157C F PYH2XX auxiliary for H -> ino + ino decay *
158C F PYGAUS to perform Gaussian integration *
159C F PYGAU2 copy of PYGAUS to allow two-dimensional integration *
160C F PYSIMP to perform Simpson integration *
161C F PYLAMF to evaluate the lambda kinematics function *
162C S PYTBDY to perform 3-body decay of gauginos *
163C S PYTECM to calculate techni_rho/omega masses *
164C S PYEICG to calculate eigenvalues of a 4*4 complex matrix *
165C S PYCMQR auxiliary to PYEICG *
166C S PYCMQ2 auxiliary to PYEICG *
167C S PYCDIV auxiliary to PYCMQR *
168C S PYCSRT auxiliary to PYCMQR *
169C S PYTHAG auxiliary to PYCMQR *
170C S PYCBAL auxiliary to PYEICG *
171C S PYCBA2 auxiliary to PYEICG *
172C S PYCRTH auxiliary to PYEICG *
173C S PYLDCM auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
174C S PYBKSB auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
175C S PYWIDX to calculate decay widths from within PYWIDT *
176C S PYRVSF to calculate R-violating sfermion decay widths *
177C S PYRVNE to calculate R-violating neutralino decay widths *
178C S PYRVCH to calculate R-violating chargino decay widths *
179C S PYRVGL to calculate R-violating gluino decay widths *
180C F PYRVSB auxiliary to PYRVSF *
181C S PYRVGW to calculate R-Violating 3-body widths *
182C F PYRVI1 auxiliary to PYRVGW, to do PS integration for res. *
183C F PYRVI2 auxiliary to PYRVGW, to do PS integration for LR-int.*
184C F PYRVI3 auxiliary to PYRVGW, to do PS X integral for int. *
185C F PYRVG1 auxiliary to PYRVI1, general matrix element, res. *
186C F PYRVG2 auxiliary to PYRVI2, general matrix element, LR-int. *
187C F PYRVG3 auxiliary to PYRVI3, to do PS Y integral for int. *
188C F PYRVG4 auxiliary to PYRVG3, general matrix element, int. *
189C F PYRVR auxiliary to PYRVG1, Breit-Wigner *
190C F PYRVS auxiliary to PYRVG2 & PYRVG4 *
191C *
192C S PY1ENT to fill one entry (= parton or particle) *
193C S PY2ENT to fill two entries *
194C S PY3ENT to fill three entries *
195C S PY4ENT to fill four entries *
196C S PY2FRM to interface to generic two-fermion generator *
197C S PY4FRM to interface to generic four-fermion generator *
198C S PY6FRM to interface to generic six-fermion generator *
199C S PY4JET to generate a shower from a given 4-parton config *
200C S PY4JTW to evaluate the weight od a shower history for above *
201C S PY4JTS to set up the parton configuration for above *
202C S PYJOIN to connect entries with colour flow information *
203C S PYGIVE to fill (or query) commonblock variables *
204C S PYEXEC to administrate fragmentation and decay chain *
205C S PYPREP to rearrange showered partons along strings *
206C S PYSTRF to do string fragmentation of jet system *
207C S PYJURF to find boost to string junction rest frame *
208C S PYINDF to do independent fragmentation of one or many jets *
209C S PYDECY to do the decay of a particle *
210C S PYDCYK to select parton and hadron flavours in decays *
211C S PYKFDI to select parton and hadron flavours in fragm *
212C S PYNMES to select number of popcorn mesons *
213C S PYKFIN to calculate falvour prod. ratios from input params. *
214C S PYPTDI to select transverse momenta in fragm *
215C S PYZDIS to select longitudinal scaling variable in fragm *
216C S PYSHOW to do timelike parton shower evolution *
217C F PYMAEL auxiliary to PYSHOW, with gluon emission ME's *
218C S PYBOEI to include Bose-Einstein effects (crudely) *
219C S PYBESQ auxiliary to PYBOEI *
220C F PYMASS to give the mass of a particle or parton *
221C F PYMRUN to give the running MSbar mass of a quark *
222C S PYNAME to give the name of a particle or parton *
223C F PYCHGE to give three times the electric charge *
224C F PYCOMP to compress standard KF flavour code to internal KC *
225C S PYERRM to write error messages and abort faulty run *
226C F PYALEM to give the alpha_electromagnetic value *
227C F PYALPS to give the alpha_strong value *
228C F PYANGL to give the angle from known x and y components *
229C F PYR to provide a random number generator *
230C S PYRGET to save the state of the random number generator *
231C S PYRSET to set the state of the random number generator *
232C S PYROBO to rotate and/or boost an event *
233C S PYEDIT to remove unwanted entries from record *
234C S PYLIST to list event record or particle data *
235C S PYLOGO to write a logo *
236C S PYUPDA to update particle data *
237C F PYK to provide integer-valued event information *
238C F PYP to provide real-valued event information *
239C S PYSPHE to perform sphericity analysis *
240C S PYTHRU to perform thrust analysis *
241C S PYCLUS to perform three-dimensional cluster analysis *
242C S PYCELL to perform cluster analysis in (eta, phi, E_T) *
243C S PYJMAS to give high and low jet mass of event *
244C S PYFOWO to give Fox-Wolfram moments *
245C S PYTABU to analyze events, with tabular output *
246C *
247C S PYEEVT to administrate the generation of an e+e- event *
248C S PYXTEE to give the total cross-section at given CM energy *
249C S PYRADK to generate initial state photon radiation *
250C S PYXKFL to select flavour of primary qqbar pair *
251C S PYXJET to select (matrix element) jet multiplicity *
252C S PYX3JT to select kinematics of three-jet event *
253C S PYX4JT to select kinematics of four-jet event *
254C S PYXDIF to select angular orientation of event *
255C S PYONIA to perform generation of onium decay to gluons *
256C *
257C S PYBOOK to book a histogram *
258C S PYFILL to fill an entry in a histogram *
259C S PYFACT to multiply histogram contents by a factor *
260C S PYOPER to perform operations between histograms *
261C S PYHIST to print and reset all histograms *
262C S PYPLOT to print a single histogram *
263C S PYNULL to reset contents of a single histogram *
264C S PYDUMP to dump histogram contents onto a file *
265C *
266C S PYKCUT dummy routine for user kinematical cuts *
267C S PYEVWT dummy routine for weighting events *
268C S UPINIT dummy routine to initialize user processes *
269C S UPEVNT dummy routine to generate a user process event *
270C S PDFSET dummy routine to be removed when using PDFLIB *
271C S STRUCTM dummy routine to be removed when using PDFLIB *
272C S STRUCTP dummy routine to be removed when using PDFLIB *
273C S SUGRA dummy routine to be removed when linking with ISAJET *
274C F VISAJE dummy functn. to be removed when linking with ISAJET *
275C S PYTAUD dummy routine for interface to tau decay libraries *
276C S PYTIME dummy routine for giving date and time *
277C *
278C*********************************************************************
279
280C...PYDATA
281C...Default values for switches and parameters,
282C...and particle, decay and process data.
283
284 BLOCK DATA PYDATA
285
286C...Double precision and integer declarations.
287 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
288 IMPLICIT INTEGER(I-N)
8285a88d 289C INTEGER PYK,PYCHGE,PYCOMP
2dfa57d1 290C...Commonblocks.
291 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
292 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
293 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
294 COMMON/PYDAT4/CHAF(500,2)
295 CHARACTER CHAF*16
296 COMMON/PYDATR/MRPY(6),RRPY(100)
297 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
298 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
299 COMMON/PYINT1/MINT(400),VINT(400)
300 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
301 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
302 COMMON/PYINT4/MWID(500),WIDS(500,5)
303 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
304 COMMON/PYINT6/PROC(0:500)
305 CHARACTER PROC*28
306 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
307 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
308 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
309 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
310 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
311 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
312 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
313 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,/PYSUBS/,
314 &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
315 &/PYINT6/,/PYINT7/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYTCSM/,/PYBINS/
316
317C...PYDAT1, containing status codes and most parameters.
318 DATA MSTU/
319 & 0, 0, 0, 4000,10000, 500, 8000, 0, 0, 2,
320 1 6, 1, 1, 0, 0, 1, 0, 0, 0, 0,
321 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
322 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
323 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
324 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
325 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
326 7 30*0,
327 1 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
328 2 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
329 & 80*0/
330 DATA (PARU(I),I=1,100)/
331 & 3.141592653589793D0, 6.283185307179586D0,
332 & 0.197327D0, 5.06773D0, 0.389380D0, 2.56819D0, 4*0D0,
333 1 0.001D0, 0.09D0, 0.01D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
334 2 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
335 3 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
336 4 2.0D0, 1.0D0, 0.25D0, 2.5D0, 0.05D0,
337 4 0D0, 0D0, 0.0001D0, 0D0, 0D0,
338 5 2.5D0,1.5D0,7.0D0,1.0D0,0.5D0,2.0D0,3.2D0, 0D0, 0D0, 0D0,
339 6 40*0D0/
340 DATA (PARU(I),I=101,200)/
341 & 0.00729735D0, 0.232D0, 0.007764D0, 1.0D0, 1.16639D-5,
342 & 0D0, 0D0, 0D0, 0D0, 0D0,
343 1 0.20D0, 0.25D0, 1.0D0, 4.0D0, 10D0, 0D0, 0D0, 0D0, 0D0, 0D0,
344 2 -0.693D0, -1.0D0, 0.387D0, 1.0D0, -0.08D0,
345 2 -1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,
346 3 1.0D0,-1.0D0, 1.0D0,-1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
347 4 5.0D0, 1.0D0, 1.0D0, 0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0,
348 5 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
349 6 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
350 7 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
351 8 1.0D0, 1.0D0, 1.0D0, 0.0D0, 0.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
352 9 0D0, 0D0, 0D0, 0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0/
353 DATA MSTJ/
354 & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
355 1 4, 2, 0, 1, 0, 2, 2, 10, 0, 0,
356 2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0,
357 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
358 4 2, 2, 4, 2, 5, 3, 3, 0, 0, 3,
359 5 0, 3, 0, 2, 0, 0, 1, 0, 0, 0,
360 6 40*0,
361 & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2,
362 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
363 2 80*0/
364 DATA PARJ/
365 & 0.10D0, 0.30D0, 0.40D0, 0.05D0, 0.50D0,
366 & 0.50D0, 0.50D0, 0.6D0, 1.2D0, 0.6D0,
367 1 0.50D0,0.60D0,0.75D0, 0D0, 0D0, 0D0, 0D0, 1.0D0, 1.0D0, 0D0,
368 2 0.36D0, 1.0D0,0.01D0, 2.0D0,1.0D0,0.4D0, 0D0, 0D0, 0D0, 0D0,
369 3 0.10D0, 1.0D0, 0.8D0, 1.5D0,0D0,2.0D0,0.2D0, 0D0,0.08D0,1D0,
370 4 0.3D0, 0.58D0, 0.5D0, 0.9D0,0.5D0,1.0D0,1.0D0,1.5D0,1D0,10D0,
371 5 0.77D0, 0.77D0, 0.77D0, -0.05D0, -0.005D0,
372 5 0D0, 0D0, 0D0, 1.0D0, 0D0,
373 6 4.5D0, 0.7D0, 0D0,0.003D0, 0.5D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
374 7 10D0, 1000D0, 100D0, 1000D0, 0D0, 0.7D0,10D0, 0D0,0D0,0.5D0,
375 8 0.29D0, 1.0D0, 1.0D0, 0D0, 10D0, 10D0, 0D0, 0D0, 0D0,1D-4,
376 9 0.02D0, 1.0D0, 0.2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
377 & 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
378 1 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
379 2 1.0D0, 0.25D0,91.187D0,2.489D0, 0.01D0,
380 2 2.0D0, 1.0D0, 0.25D0,0.002D0, 0D0,
381 3 0D0, 0D0, 0D0, 0D0, 0.01D0, 0.99D0, 0D0, 0D0, 0.2D0, 0D0,
382 4 10*0D0,
383 5 10*0D0,
384 6 10*0D0,
385 7 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, -0.693D0,
386 8 -1.0D0, 0.387D0, 1.0D0, -0.08D0, -1.0D0,
387 8 1.0D0, 1.0D0, -0.693D0, -1.0D0, 0.387D0,
388 9 1.0D0, -0.08D0, -1.0D0, 1.0D0, 1.0D0,
389 9 5*0D0/
390
391C...PYDAT2, with particle data and flavour treatment parameters.
392 DATA (KCHG(I,1),I= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
393 &-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,
394 &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,
395 &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,
396 &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,
397 &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,
398 &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,
399 &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,
400 &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,
401 &139*0/
402 DATA (KCHG(I,2),I= 1, 500)/8*1,12*0,2,20*0,1,107*0,-1,0,2*-1,
403 &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,
404 &-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,
405 &6*1,9*0,2,3*0,2,0,5*2,2*1,156*0/
406 DATA (KCHG(I,3),I= 1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,3*0,
407 &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,
408 &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,
409 &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/
410 DATA (KCHG(I,4),I= 1, 290)/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,
411 &16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,
412 &37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,
413 &58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,
414 &79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,
415 &100,110,111,113,115,130,211,213,215,221,223,225,310,311,313,315,
416 &321,323,325,331,333,335,411,413,415,421,423,425,431,433,435,441,
417 &443,445,511,513,515,521,523,525,531,533,535,541,543,545,551,553,
418 &555,990,1103,1114,2101,2103,2112,2114,2203,2212,2214,2224,3101,
419 &3103,3112,3114,3122,3201,3203,3212,3214,3222,3224,3303,3312,3314,
420 &3322,3324,3334,4101,4103,4112,4114,4122,4132,4201,4203,4212,4214,
421 &4222,4224,4232,4301,4303,4312,4314,4322,4324,4332,4334,4403,4412,
422 &4414,4422,4424,4432,4434,4444,5101,5103,5112,5114,5122,5132,5142,
423 &5201,5203,5212,5214,5222,5224,5232,5242,5301,5303,5312,5314,5322,
424 &5324,5332,5334,5342,5401,5403,5412,5414,5422,5424,5432,5434,5442,
425 &5444,5503,5512,5514,5522,5524,5532,5534,5542,5544,5554,10111,
426 &10113,10211,10213,10221,10223,10311,10313,10321,10323,10331,
427 &10333,10411,10413,10421,10423,10431,10433,10441,10443,10511,
428 &10513,10521,10523,10531,10533,10541,10543,10551,10553,20113,
429 &20213,20223,20313,20323,20333,20413,20423,20433,20443,20513/
430 DATA (KCHG(I,4),I= 291, 500)/20523,20533,20543,20553,100443,
431 &100553,1000001,1000002,1000003,1000004,1000005,1000006,1000011,
432 &1000012,1000013,1000014,1000015,1000016,1000021,1000022,1000023,
433 &1000024,1000025,1000035,1000037,1000039,2000001,2000002,2000003,
434 &2000004,2000005,2000006,2000011,2000012,2000013,2000014,2000015,
435 &2000016,3000111,3000211,3000221,3000331,3000113,3000213,3000223,
436 &3100021,3100111,3200111,3100113,3200113,3300113,3400113,4000001,
437 &4000002,4000011,4000012,5000039,9900012,9900014,9900016,9900023,
438 &9900024,9900041,9900042,9900110,9900210,9900220,9900330,9900440,
439 &9902110,9902210,139*0/
440 DATA (PMAS(I,1),I= 1, 217)/2*0.33D0,0.5D0,1.5D0,4.8D0,175D0,
441 &2*400D0,2*0D0,0.00051D0,0D0,0.10566D0,0D0,1.777D0,0D0,400D0,
442 &5*0D0,91.188D0,80.45D0,115D0,6*0D0,500D0,900D0,500D0,3*300D0,
443 &3*0D0,5000D0,200D0,40*0D0,1D0,2D0,5D0,16*0D0,0.13498D0,0.7685D0,
444 &1.318D0,0.49767D0,0.13957D0,0.7669D0,1.318D0,0.54745D0,0.78194D0,
445 &1.275D0,2*0.49767D0,0.8961D0,1.432D0,0.4936D0,0.8916D0,1.425D0,
446 &0.95777D0,1.0194D0,1.525D0,1.8693D0,2.01D0,2.46D0,1.8645D0,
447 &2.0067D0,2.46D0,1.9685D0,2.1124D0,2.5735D0,2.9798D0,3.09688D0,
448 &3.5562D0,5.2792D0,5.3248D0,5.83D0,5.2789D0,5.3248D0,5.83D0,
449 &5.3693D0,5.4163D0,6.07D0,6.594D0,6.602D0,7.35D0,9.4D0,9.4603D0,
450 &9.9132D0,0D0,0.77133D0,1.234D0,0.57933D0,0.77133D0,0.93957D0,
451 &1.233D0,0.77133D0,0.93827D0,1.232D0,1.231D0,0.80473D0,0.92953D0,
452 &1.19744D0,1.3872D0,1.11568D0,0.80473D0,0.92953D0,1.19255D0,
453 &1.3837D0,1.18937D0,1.3828D0,1.09361D0,1.3213D0,1.535D0,1.3149D0,
454 &1.5318D0,1.67245D0,1.96908D0,2.00808D0,2.4521D0,2.5D0,2.2849D0,
455 &2.4703D0,1.96908D0,2.00808D0,2.4535D0,2.5D0,2.4529D0,2.5D0,
456 &2.4656D0,2.15432D0,2.17967D0,2.55D0,2.63D0,2.55D0,2.63D0,2.704D0,
457 &2.8D0,3.27531D0,3.59798D0,3.65648D0,3.59798D0,3.65648D0,
458 &3.78663D0,3.82466D0,4.91594D0,5.38897D0,5.40145D0,5.8D0,5.81D0,
459 &5.641D0,5.84D0,7.00575D0,5.38897D0,5.40145D0,5.8D0,5.81D0,5.8D0/
460 DATA (PMAS(I,1),I= 218, 500)/5.81D0,5.84D0,7.00575D0,5.56725D0,
461 &5.57536D0,5.96D0,5.97D0,5.96D0,5.97D0,6.12D0,6.13D0,7.19099D0,
462 &6.67143D0,6.67397D0,7.03724D0,7.0485D0,7.03724D0,7.0485D0,
463 &7.21101D0,7.219D0,8.30945D0,8.31325D0,10.07354D0,10.42272D0,
464 &10.44144D0,10.42272D0,10.44144D0,10.60209D0,10.61426D0,
465 &11.70767D0,11.71147D0,15.11061D0,0.9835D0,1.231D0,0.9835D0,
466 &1.231D0,1D0,1.17D0,1.429D0,1.29D0,1.429D0,1.29D0,2*1.4D0,2.272D0,
467 &2.424D0,2.272D0,2.424D0,2.5D0,2.536D0,3.4151D0,3.46D0,5.68D0,
468 &5.73D0,5.68D0,5.73D0,5.92D0,5.97D0,7.25D0,7.3D0,9.8598D0,9.875D0,
469 &2*1.23D0,1.282D0,2*1.402D0,1.427D0,2*2.372D0,2.56D0,3.5106D0,
470 &2*5.78D0,6.02D0,7.3D0,9.8919D0,3.686D0,10.0233D0,32*500D0,
471 &3*110D0,350D0,3*210D0,500D0,125D0,250D0,400D0,2*350D0,300D0,
472 &4*400D0,1000D0,3*500D0,1200D0,750D0,2*200D0,7*0D0,139*0D0/
473 DATA (PMAS(I,2),I= 1, 500)/5*0D0,1.39816D0,16*0D0,2.47813D0,
474 &2.07115D0,0.00367D0,6*0D0,14.54029D0,0D0,16.66099D0,8.38842D0,
475 &3.3752D0,4.17669D0,3*0D0,417.29147D0,0.39162D0,60*0D0,0.151D0,
476 &0.107D0,2*0D0,0.149D0,0.107D0,0D0,0.00843D0,0.185D0,2*0D0,
477 &0.0505D0,0.109D0,0D0,0.0498D0,0.098D0,0.0002D0,0.00443D0,0.076D0,
478 &2*0D0,0.023D0,2*0D0,0.023D0,2*0D0,0.015D0,0.0013D0,0D0,0.002D0,
479 &2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,5*0D0,0.12D0,
480 &3*0D0,0.12D0,2*0D0,2*0.12D0,3*0D0,0.0394D0,4*0D0,0.036D0,0D0,
481 &0.0358D0,2*0D0,0.0099D0,0D0,0.0091D0,74*0D0,0.06D0,0.142D0,
482 &0.06D0,0.142D0,0D0,0.36D0,0.287D0,0.09D0,0.287D0,0.09D0,0.25D0,
483 &0.08D0,0.05D0,0.02D0,0.05D0,0.02D0,0.05D0,0D0,0.014D0,0.01D0,
484 &8*0.05D0,0D0,0.01D0,2*0.4D0,0.025D0,2*0.174D0,0.053D0,3*0.05D0,
485 &0.0009D0,4*0.05D0,3*0D0,19*1D0,0D0,7*1D0,0D0,1D0,0D0,1D0,0D0,
486 &0.02911D0,0.01741D0,0.04536D0,0.09511D0,0.8686D0,0.62395D0,
487 &0.19192D0,123.27638D0,0.02296D0,0.18886D0,23.26819D0,2.86306D0,
488 &0D0,3.45903D0,2.59359D0,2.59687D0,0.42896D0,0.41912D0,0.14153D0,
489 &2*0.00098D0,0.00097D0,26.7245D0,21.74916D0,0.88159D0,0.88001D0,
490 &7*0D0,139*0D0/
491 DATA (PMAS(I,3),I= 1, 500)/5*0D0,13.98156D0,16*0D0,24.78129D0,
492 &20.71149D0,0.03669D0,6*0D0,145.40294D0,0D0,166.60993D0,
493 &83.88423D0,33.75195D0,41.76694D0,3*0D0,4172.91467D0,3.91621D0,
494 &60*0D0,0.4D0,0.25D0,2*0D0,0.4D0,0.25D0,0D0,0.1D0,0.17D0,2*0D0,
495 &0.2D0,0.12D0,0D0,0.2D0,0.12D0,0.002D0,0.015D0,0.2D0,2*0D0,0.12D0,
496 &2*0D0,0.12D0,2*0D0,0.05D0,0.005D0,0D0,0.01D0,2*0D0,0.05D0,2*0D0,
497 &0.05D0,2*0D0,0.05D0,2*0D0,0.05D0,5*0D0,0.14D0,3*0D0,0.14D0,2*0D0,
498 &2*0.14D0,3*0D0,0.04D0,4*0D0,0.035D0,0D0,0.035D0,2*0D0,0.05D0,0D0,
499 &0.05D0,74*0D0,0.05D0,0.25D0,0.05D0,0.25D0,0D0,0.2D0,0.4D0,
500 &0.005D0,0.4D0,0.01D0,0.35D0,0.001D0,0.1D0,0.08D0,0.1D0,0.08D0,
501 &0.1D0,0D0,0.05D0,0.02D0,6*0.1D0,0.05D0,0.1D0,0D0,0.02D0,2*0.3D0,
502 &0.05D0,2*0.3D0,0.02D0,2*0.1D0,0.03D0,0.001D0,4*0.1D0,3*0D0,
503 &19*10D0,0.00001D0,7*10D0,0.00001D0,10D0,0.00001D0,10D0,0.00001D0,
504 &0.29108D0,0.17412D0,0.45362D0,0.95114D0,8.68604D0,6.23946D0,
505 &1.91923D0,450D0,0.22959D0,1.88863D0,232.68185D0,28.63059D0,0D0,
506 &34.59032D0,25.93594D0,25.96873D0,4.28961D0,4.19124D0,1.41528D0,
507 &0.00977D0,0.00976D0,0.00973D0,267.24501D0,217.49162D0,8.81592D0,
508 &8.80013D0,7*0D0,139*0D0/
509 DATA (PMAS(I,4),I= 1, 500)/12*0D0,658654D0,0D0,0.0872D0,68*0D0,
510 &0.1D0,0.387D0,16*0D0,0.00003D0,2*0D0,15500D0,7804.5D0,5*0D0,
511 &26.762D0,3*0D0,3709D0,5*0D0,0.317D0,2*0D0,0.1244D0,2*0D0,0.14D0,
512 &5*0D0,0.468D0,2*0D0,0.462D0,2*0D0,0.483D0,2*0D0,0.15D0,18*0D0,
513 &44.34D0,0D0,78.88D0,4*0D0,23.96D0,2*0D0,49.1D0,0D0,87.1D0,0D0,
514 &24.6D0,4*0D0,0.0618D0,0.029D0,6*0D0,0.106D0,6*0D0,0.019D0,2*0D0,
515 &7*0.1D0,4*0D0,0.342D0,2*0.387D0,6*0D0,2*0.387D0,6*0D0,0.387D0,
516 &0D0,0.387D0,2*0D0,8*0.387D0,0D0,9*0.387D0,112*0D0,139*0D0/
517 DATA PARF/
518 & 0.5D0,0.25D0, 0.5D0,0.25D0, 1D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
519 1 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
520 2 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
521 3 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
522 4 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
523 5 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
524 6 0.75D0, 0.5D0, 0D0,0.1667D0,0.0833D0,0.1667D0,0D0,0D0,0D0, 0D0,
525 7 0D0, 0D0, 1D0,0.3333D0,0.6667D0,0.3333D0,0D0,0D0,0D0, 0D0,
526 8 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
527 9 0.0099D0, 0.0056D0, 0.199D0, 1.23D0, 4.17D0, 165D0, 4*0D0,
528 & 0.325D0,0.325D0,0.5D0,1.6D0, 5.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
529 1 0D0,0.11D0,0.16D0,0.048D0,0.50D0,0.45D0,0.55D0,0.60D0,0D0,0D0,
530 2 0.2D0, 0.1D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
531 3 60*0D0,
532 4 0.2D0, 0.5D0, 8*0D0,
533 5 1800*0D0/
534 DATA ((VCKM(I,J),J=1,4),I=1,4)/
535 & 0.95113D0, 0.04884D0, 0.00003D0, 0.00000D0,
536 & 0.04884D0, 0.94940D0, 0.00176D0, 0.00000D0,
537 & 0.00003D0, 0.00176D0, 0.99821D0, 0.00000D0,
538 & 0.00000D0, 0.00000D0, 0.00000D0, 1.00000D0/
539
540C...PYDAT3, with particle decay parameters and data.
541 DATA (MDCY(I,1),I= 1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,
542 &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,
543 &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,
544 &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/
545 DATA (MDCY(I,2),I= 1, 351)/1,9,17,25,33,41,56,66,2*0,76,80,82,
546 &87,89,143,145,150,2*0,153,162,174,190,210,6*0,289,0,311,334,420,
547 &503,3*0,530,539,40*0,540,541,545,16*0,554,556,561,570,579,581,
548 &583,590,598,604,613,615,617,620,630,636,639,650,656,667,673,736,
549 &739,747,808,810,818,851,853,857,858,861,863,899,900,908,944,945,
550 &953,992,993,997,1028,1029,1033,1034,1043,2*0,1045,3*0,1046,2*0,
551 &1049,1052,2*0,1053,1055,1058,2*0,1062,1063,1066,1069,0,1072,1077,
552 &1079,1082,1084,2*0,1088,1089,1090,1166,2*0,1170,1171,1172,1173,
553 &1174,2*0,1178,1179,1181,1182,1184,1188,0,1189,1193,1197,1201,
554 &1205,1209,1213,2*0,1217,1218,1219,1236,1245,2*0,1254,1255,1256,
555 &1257,1258,1267,2*0,1276,1277,1278,1279,1280,1289,1290,2*0,1299,
556 &1308,1317,1326,1335,1344,1353,1362,0,1371,1380,1389,1398,1407,
557 &1416,1425,1434,1443,1452,1453,1454,1455,1456,1461,1464,1466,1471,
558 &1473,1478,1485,1489,1491,1493,1495,1497,1499,1501,1503,1504,1506,
559 &1508,1510,1512,1514,1516,1518,1520,1522,1523,1525,1527,1541,1543,
560 &1545,1549,1551,1553,1555,1557,1559,1561,1563,1565,1567,1578,1592,
561 &1637,1661,1706,1730,1775,1802,1833,1859,1891,1917,1949,1975,2162,
562 &2331,2595,2826,3106,3402,0,3657,3706,3734,3783,3811,3860,3888,0,
563 &3924,0,3960,0,3996,4004,4012,4020,4023,4047,4073,4097,4103,4110,
564 &4117,4124,4130,4136,4145,4149,4153,4156,4158,4178,4200,4222,4244/
565 DATA (MDCY(I,2),I= 352, 500)/4259,4271,4278,146*0/
566 DATA (MDCY(I,3),I= 1, 500)/5*8,15,2*10,2*0,4,2,5,2,54,2,5,3,
567 &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,
568 &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,
569 &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,
570 &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,
571 &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,
572 &5,3,2,5,2,5,7,4,7*2,1,9*2,1,2*2,14,2*2,4,9*2,11,14,45,24,45,24,
573 &45,27,31,26,32,26,32,26,187,169,264,231,280,296,255,0,49,28,49,
574 &28,49,28,36,0,36,0,36,0,3*8,3,24,26,24,6,3*7,2*6,9,2*4,3,2,20,
575 &3*22,15,12,2*7,146*0/
576 DATA (MDME(I,1),I= 1,8000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
577 &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,
578 &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,85*1,
579 &2*-1,6*1,8*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,4*-1,200*1,2*-1,2*1,-1,
580 &1249*1,2*-1,377*1,2*-1,1868*1,2*-1,6*1,2*-1,9*1,-1,3*1,-1,3*1,
581 &5*-1,3*1,-1,14*1,2*-1,6*1,2*-1,67*1,2*-1,6*1,2*-1,111*1,3716*0/
582 DATA (MDME(I,2),I= 1,8000)/43*102,4*0,102,0,6*53,3*102,4*0,102,
583 &2*0,3*102,4*0,102,2*0,6*102,42,6*102,2*42,2*0,8*41,2*0,36*41,
584 &8*102,0,102,0,102,2*0,21*102,8*32,8*0,16*32,4*0,8*32,9*0,62*53,
585 &8*32,14*0,16*32,7*0,8*32,16*0,62*53,8*32,13*0,62*53,4*32,5*0,
586 &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,
587 &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,
588 &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,
589 &14*42,16*0,48,3*13,2*42,9*0,14*42,16*0,48,3*13,2*42,9*0,14*42,
590 &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,
591 &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,
592 &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,
593 &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,
594 &17*0,2*32,33*0,12,9*0,32,2*0,12,11*0,4*32,2*4,5*0,2404*53,4*32,
595 &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,
596 &46*32,3*53,12*0,8*32,12*0,66*51,6*32,9*0,9*32,3733*0/
597 DATA (BRAT(I) ,I= 1, 346)/43*0D0,0.00003D0,0.001765D0,
598 &0.998205D0,35*0D0,1D0,6*0D0,0.1783D0,0.1735D0,0.1131D0,0.2494D0,
599 &0.003D0,0.09D0,0.0027D0,0.01D0,0.0014D0,0.0012D0,2*0.00025D0,
600 &0.0071D0,0.012D0,0.0004D0,0.00075D0,0.00006D0,2*0.00078D0,
601 &0.0034D0,0.08D0,0.011D0,0.0191D0,0.00006D0,0.005D0,0.0133D0,
602 &0.0067D0,0.0005D0,0.0035D0,0.0006D0,0.0015D0,0.00021D0,0.0002D0,
603 &0.00075D0,0.0001D0,0.0002D0,0.0011D0,3*0.0002D0,0.00022D0,
604 &0.0004D0,0.0001D0,2*0.00205D0,2*0.00069D0,0.00025D0,0.00051D0,
605 &0.00025D0,35*0D0,0.153995D0,0.11942D0,0.153984D0,0.119259D0,
606 &0.152272D0,3*0D0,0.033576D0,0.066806D0,0.033576D0,0.066806D0,
607 &0.0335D0,0.066806D0,2*0D0,0.321369D0,0.016494D0,2*0D0,0.016502D0,
608 &0.320615D0,2*0D0,0.00001D0,0.000591D0,6*0D0,2*0.108166D0,
609 &0.108087D0,0D0,0.000001D0,0D0,0.000349D0,0.048707D0,0.768308D0,
610 &4*0D0,0.000227D0,0.064048D0,0D0,0.040621D0,0.002043D0,0.000615D0,
611 &0.006981D0,0.068099D0,62*0D0,0.145835D0,0.113276D0,0.145835D0,
612 &0.113271D0,0.145781D0,0.049002D0,2*0D0,0.032025D0,0.063642D0,
613 &0.032025D0,0.063642D0,0.032022D0,0.063642D0,8*0D0,0.251225D0,
614 &0.0129D0,0.000006D0,0D0,0.0129D0,0.250764D0,0.00038D0,0D0,
615 &0.000008D0,0.000465D0,0.215418D0,5*0D0,2*0.085312D0,0.08531D0,
616 &7*0D0,0.000049D0,0.000774D0,5*0D0,0.000074D0,0D0,0.000417D0/
617 DATA (BRAT(I) ,I= 347, 651)/0.000015D0,0.000061D0,0.30671D0,
618 &0.689011D0,0D0,0.002889D0,69*0D0,0.000001D0,0.000121D0,
619 &0.001924D0,4*0D0,0.000001D0,0.000184D0,0D0,0.003106D0,0.000015D0,
620 &0.000003D0,2*0D0,0.994646D0,66*0D0,0.000021D0,0.090135D0,2*0D0,
621 &0.000013D0,0.003714D0,0D0,0.906117D0,18*0D0,3*0.215119D0,
622 &0.214724D0,2*0D0,0.06996D0,0.069959D0,0D0,2*1D0,2*0.08D0,0.76D0,
623 &0.08D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,
624 &0.005D0,0.988D0,0.012D0,0.998739D0,0.00079D0,0.00038D0,
625 &0.000046D0,0.000045D0,2*0.34725D0,0.144D0,0.104D0,0.0245D0,
626 &2*0.01225D0,0.0028D0,0.0057D0,0.2112D0,0.1256D0,2*0.1939D0,
627 &2*0.1359D0,0.002D0,0.001D0,0.0006D0,0.999877D0,0.000123D0,
628 &0.99955D0,0.00045D0,2*0.34725D0,0.144D0,0.104D0,0.049D0,0.0028D0,
629 &0.0057D0,0.3923D0,0.321D0,0.2317D0,0.0478D0,0.0049D0,0.0013D0,
630 &0.0003D0,0.0007D0,0.89D0,0.08693D0,0.0221D0,0.00083D0,
631 &2*0.00007D0,0.564D0,0.282D0,0.072D0,0.028D0,0.023D0,2*0.0115D0,
632 &0.005D0,0.003D0,0.6861D0,0.3139D0,2*0.5D0,0.665D0,0.333D0,
633 &0.002D0,0.333D0,0.166D0,0.168D0,0.084D0,0.087D0,0.043D0,0.059D0,
634 &2*0.029D0,0.002D0,0.6352D0,0.2116D0,0.0559D0,0.0173D0,0.0482D0,
635 &0.0318D0,0.666D0,0.333D0,0.001D0,0.332D0,0.166D0,0.168D0,0.084D0,
636 &0.086D0,0.043D0,0.059D0,2*0.029D0,2*0.002D0,0.437D0,0.208D0/
637 DATA (BRAT(I) ,I= 652, 823)/0.302D0,0.0302D0,0.0212D0,0.0016D0,
638 &0.48947D0,0.34D0,3*0.043D0,0.027D0,0.0126D0,0.0013D0,0.0003D0,
639 &0.00025D0,0.00008D0,0.444D0,2*0.222D0,0.104D0,2*0.004D0,0.07D0,
640 &0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,0.07D0,0.065D0,2*0.005D0,
641 &2*0.011D0,5*0.001D0,0.026D0,0.019D0,0.066D0,0.041D0,0.045D0,
642 &0.076D0,0.0073D0,2*0.0047D0,0.026D0,0.001D0,0.0006D0,0.0066D0,
643 &0.005D0,2*0.003D0,2*0.0006D0,2*0.001D0,0.006D0,0.005D0,0.012D0,
644 &0.0057D0,0.067D0,0.008D0,0.0022D0,0.027D0,0.004D0,0.019D0,
645 &0.012D0,0.002D0,0.009D0,0.0218D0,0.001D0,0.022D0,0.087D0,0.001D0,
646 &0.0019D0,0.0015D0,0.0028D0,0.683D0,0.306D0,0.011D0,0.3D0,0.15D0,
647 &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.034D0,0.027D0,
648 &2*0.002D0,2*0.004D0,2*0.002D0,0.034D0,0.027D0,2*0.002D0,
649 &2*0.004D0,2*0.002D0,0.0365D0,0.045D0,0.073D0,0.062D0,3*0.021D0,
650 &0.0061D0,0.015D0,0.025D0,0.0088D0,0.074D0,0.0109D0,0.0041D0,
651 &0.002D0,0.0035D0,0.0011D0,0.001D0,0.0027D0,2*0.0016D0,0.0018D0,
652 &0.011D0,0.0063D0,0.0052D0,0.018D0,0.016D0,0.0034D0,0.0036D0,
653 &0.0009D0,0.0006D0,0.015D0,0.0923D0,0.018D0,0.022D0,0.0077D0,
654 &0.009D0,0.0075D0,0.024D0,0.0085D0,0.067D0,0.0511D0,0.017D0,
655 &0.0004D0,0.0028D0,0.619D0,0.381D0,0.3D0,0.15D0,0.16D0,0.08D0,
656 &0.13D0,0.06D0,0.08D0,0.04D0,0.01D0,2*0.02D0,0.03D0,2*0.005D0/
657 DATA (BRAT(I) ,I= 824, 991)/2*0.02D0,0.03D0,2*0.005D0,0.015D0,
658 &0.037D0,0.028D0,0.079D0,0.095D0,0.052D0,0.0078D0,4*0.001D0,
659 &0.028D0,0.033D0,0.026D0,0.05D0,0.01D0,4*0.005D0,0.25D0,0.0952D0,
660 &0.94D0,0.06D0,2*0.4D0,2*0.1D0,1D0,0.0602D0,0.0601D0,0.8797D0,
661 &0.135D0,0.865D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.02D0,
662 &0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,
663 &0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,0.0135D0,
664 &0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,0.0019D0,0.0025D0,
665 &0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0,
666 &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.02D0,0.055D0,
667 &2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
668 &0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,
669 &0.018D0,0.015D0,0.0185D0,0.0135D0,0.025D0,0.0004D0,0.0007D0,
670 &0.0008D0,0.0014D0,0.0019D0,0.0025D0,0.4291D0,0.08D0,0.07D0,
671 &0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,
672 &0.06D0,0.08D0,0.04D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,
673 &0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,
674 &0.011D0,0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,
675 &0.0135D0,0.025D0,2*0.0002D0,0.0007D0,2*0.0004D0,0.0014D0,0.001D0,
676 &0.0009D0,0.0025D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0/
677 DATA (BRAT(I) ,I= 992,1183)/1D0,2*0.3D0,2*0.2D0,0.047D0,0.122D0,
678 &0.006D0,0.012D0,0.035D0,0.012D0,0.035D0,0.003D0,0.007D0,0.15D0,
679 &0.037D0,0.008D0,0.002D0,0.05D0,0.015D0,0.003D0,0.001D0,0.014D0,
680 &0.042D0,0.014D0,0.042D0,0.24D0,0.065D0,0.012D0,0.003D0,0.001D0,
681 &0.002D0,0.001D0,0.002D0,0.014D0,0.003D0,1D0,2*0.3D0,2*0.2D0,1D0,
682 &0.0252D0,0.0248D0,0.0267D0,0.015D0,0.045D0,0.015D0,0.045D0,
683 &0.7743D0,0.029D0,0.22D0,0.78D0,1D0,0.331D0,0.663D0,0.006D0,
684 &0.663D0,0.331D0,0.006D0,1D0,0.999D0,0.001D0,0.88D0,2*0.06D0,
685 &0.639D0,0.358D0,0.002D0,0.001D0,1D0,0.88D0,2*0.06D0,0.516D0,
686 &0.483D0,0.001D0,0.88D0,2*0.06D0,0.9988D0,0.0001D0,0.0006D0,
687 &0.0004D0,0.0001D0,0.667D0,0.333D0,0.9954D0,0.0011D0,0.0035D0,
688 &0.333D0,0.667D0,0.676D0,0.234D0,0.085D0,0.005D0,2*1D0,0.018D0,
689 &2*0.005D0,0.003D0,0.002D0,2*0.006D0,0.018D0,2*0.005D0,0.003D0,
690 &0.002D0,2*0.006D0,0.0066D0,0.025D0,0.016D0,0.0088D0,2*0.005D0,
691 &0.0058D0,0.005D0,0.0055D0,4*0.004D0,2*0.002D0,2*0.004D0,0.003D0,
692 &0.002D0,2*0.003D0,3*0.002D0,2*0.001D0,0.002D0,2*0.001D0,
693 &2*0.002D0,0.0013D0,0.0018D0,5*0.001D0,4*0.003D0,2*0.005D0,
694 &2*0.002D0,2*0.001D0,2*0.002D0,2*0.001D0,0.2432D0,0.057D0,
695 &2*0.035D0,0.15D0,2*0.075D0,0.03D0,2*0.015D0,2*0.08D0,0.76D0,
696 &0.08D0,4*1D0,2*0.08D0,0.76D0,0.08D0,1D0,2*0.5D0,1D0,2*0.5D0/
697 DATA (BRAT(I) ,I=1184,1377)/2*0.08D0,0.76D0,0.08D0,1D0,2*0.08D0,
698 &0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,
699 &0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,0.08D0,2*1D0,2*0.105D0,
700 &0.04D0,0.0077D0,0.02D0,0.0235D0,0.0285D0,0.0435D0,0.0011D0,
701 &0.0022D0,0.0044D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,
702 &2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,
703 &2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,
704 &4*1D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,
705 &0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,
706 &0.005D0,4*1D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
707 &0.015D0,0.005D0,1D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
708 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
709 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
710 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
711 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
712 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
713 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
714 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
715 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
716 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0/
717 DATA (BRAT(I) ,I=1378,1580)/0.015D0,0.005D0,2*0.105D0,0.04D0,
718 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
719 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
720 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
721 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
722 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
723 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
724 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
725 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,0.52D0,0.26D0,
726 &0.11D0,2*0.055D0,0.333D0,0.334D0,0.333D0,0.667D0,0.333D0,0.28D0,
727 &0.14D0,0.313D0,0.157D0,0.11D0,0.667D0,0.333D0,0.28D0,0.14D0,
728 &0.313D0,0.157D0,0.11D0,0.36D0,0.18D0,0.03D0,2*0.015D0,2*0.2D0,
729 &4*0.25D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,
730 &0.333D0,4*0.5D0,0.007D0,0.993D0,1D0,0.667D0,0.333D0,0.667D0,
731 &0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,8*0.5D0,0.02D0,0.98D0,
732 &1D0,4*0.5D0,3*0.146D0,3*0.05D0,0.15D0,2*0.05D0,4*0.024D0,0.066D0,
733 &0.667D0,0.333D0,0.667D0,0.333D0,4*0.25D0,0.667D0,0.333D0,0.667D0,
734 &0.333D0,2*0.5D0,0.273D0,0.727D0,0.667D0,0.333D0,0.667D0,0.333D0,
735 &4*0.5D0,0.35D0,0.65D0,2*0.0083D0,0.1866D0,0.324D0,0.184D0,
736 &0.027D0,0.001D0,0.093D0,0.087D0,0.078D0,0.0028D0,3*0.014D0/
737 DATA (BRAT(I) ,I=1581,4149)/0.008D0,0.024D0,0.008D0,0.024D0,
738 &0.425D0,0.02D0,0.185D0,0.088D0,0.043D0,0.067D0,0.066D0,2404*0D0,
739 &0.017431D0,0.054048D0,0.857694D0,2*0D0,0.00025D0,0.070578D0,0D0,
740 &0.022748D0,0.026576D0,0.359486D0,0.561581D0,2*0D0,0.000104D0,
741 &0.029504D0,0.011185D0,0.034681D0,0.550354D0,2*0D0,0.00016D0,
742 &0.045287D0,0.358333D0,0.445781D0,0D0,0.554219D0,0.144051D0,
743 &2*0.351902D0,0D0,0.082107D0,0.029566D0,0.001511D0,0.000726D0,
744 &0.004518D0,0.006522D0,0.004518D0,0.006522D0,0.004513D0,3*0D0,
745 &0.002908D0,0.000973D0,0.002908D0,0.000973D0,0.002908D0,
746 &0.000973D0,2*0D0,0.143982D0,0.489888D0,0.1951D0,0D0,0.114302D0,
747 &0.008426D0,0.014868D0,0.000763D0,2*0D0,0.000763D0,0.01484D0,
748 &0.000003D0,2*0D0,0.000027D0,0.001945D0,5*0D0,3*0.00503D0,0D0,
749 &0.133776D0,0.003284D0,0.37169D0,0.006838D0,2*0.030954D0,
750 &0.00163D0,0D0,0.047224D0,0.073737D0,0.047224D0,0.073732D0,
751 &0.047179D0,3*0D0,0.034761D0,0.009166D0,0.034761D0,0.009166D0,
752 &0.034759D0,0.009166D0,2*0D0,4*0.009069D0,0.510147D0,0.453576D0,
753 &6*0D0,1D0,6*0D0,1D0,4*0.001128D0,0.571047D0,0.382288D0,
754 &0.042153D0,4*0.016597D0,0.93361D0,0D0,4*0.016597D0,0.93361D0,0D0,
755 &4*0.05515D0,0.34469D0,0D0,0.228998D0,0.164208D0,0.041503D0,
756 &0.850973D0,0.005411D0,0.045025D0,0.098591D0,0.849898D0/
757 DATA (BRAT(I) ,I=4150,4280)/0.021617D0,0.030018D0,0.098466D0,
758 &0.294448D0,0.10945D0,0.596102D0,0.389906D0,0.610094D0,3*0.0633D0,
759 &0.063299D0,0.063295D0,0.056281D0,2*0D0,6*0.020495D0,2*0D0,
760 &0.327919D0,0.04099D0,0.045236D0,0.090112D0,0.19874D0,0.010204D0,
761 &0.000003D0,0.010205D0,0.198356D0,0.000151D0,0.000006D0,
762 &0.000367D0,0.081967D0,0.19874D0,0.010204D0,0.000003D0,0.010205D0,
763 &0.198356D0,0.000151D0,0.000006D0,0.000367D0,0.081967D0,4*0D0,
764 &0.198776D0,0.010206D0,0.000003D0,0.010207D0,0.19839D0,0.000151D0,
765 &0.000006D0,0.000367D0,0.081893D0,0.198776D0,0.010206D0,
766 &0.000003D0,0.010207D0,0.19839D0,0.000151D0,0.000006D0,0.000367D0,
767 &0.081893D0,4*0D0,0.199344D0,0.010234D0,0.000003D0,0.010236D0,
768 &0.198928D0,0.000149D0,0.000006D0,0.000368D0,0.080733D0,
769 &0.199344D0,0.010234D0,0.000003D0,0.010236D0,0.198928D0,
770 &0.000149D0,0.000006D0,0.000368D0,0.080733D0,4*0D0,0.184738D0,
771 &0.104588D0,0.184738D0,0.104587D0,0.184731D0,0.09582D0,0.022902D0,
772 &0.008429D0,0.015602D0,0.022902D0,0.008429D0,0.015602D0,
773 &0.022902D0,0.008429D0,0.015602D0,0.28959D0,0.01487D0,0.000008D0,
774 &0.01487D0,0.289061D0,0.000492D0,0.000009D0,0.000536D0,0.27911D0,
775 &2*0.037151D0,0.03715D0,0.090266D0,2*0.001805D0,0.090266D0,
776 &0.001805D0,0.812263D0,0.00179D0,0.090428D0,0.001809D0,0.001808D0/
777 DATA (BRAT(I) ,I=4281,8000)/0.090428D0,0.001808D0,0.81372D0,0D0,
778 &3716*0D0/
779 DATA (KFDP(I,1),I= 1, 377)/21,22,23,4*-24,25,21,22,23,4*24,25,
780 &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
781 &4*24,25,37,1000022,1000023,1000025,1000035,1000021,1000039,21,22,
782 &23,4*-24,25,2*-37,21,22,23,4*24,25,2*37,22,23,-24,25,23,24,-12,
783 &22,23,-24,25,23,24,-12,-14,48*16,22,23,-24,25,23,24,22,23,-24,25,
784 &-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,
785 &3,4,5,6,7,8,11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,-13,
786 &-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1000022,
787 &2*1000023,3*1000025,4*1000035,2*1000024,2*1000037,1000001,
788 &2000001,1000001,-1000001,1000002,2000002,1000002,-1000002,
789 &1000003,2000003,1000003,-1000003,1000004,2000004,1000004,
790 &-1000004,1000005,2000005,1000005,-1000005,1000006,2000006,
791 &1000006,-1000006,1000011,2000011,1000011,-1000011,1000012,
792 &2000012,1000012,-1000012,1000013,2000013,1000013,-1000013,
793 &1000014,2000014,1000014,-1000014,1000015,2000015,1000015,
794 &-1000015,1000016,2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,12,
795 &13,14,15,16,17,18,24,37,2*23,25,35,4*-1,4*-3,4*-5,4*-7,-11,-13,
796 &-15,-17,3*24,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,25,24,
797 &37,23,25,36,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
798 &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002/
799 DATA (KFDP(I,1),I= 378, 580)/1000002,-1000002,1000003,2000003,
800 &1000003,-1000003,1000004,2000004,1000004,-1000004,1000005,
801 &2000005,1000005,-1000005,1000006,2000006,1000006,-1000006,
802 &1000011,2000011,1000011,-1000011,1000012,2000012,1000012,
803 &-1000012,1000013,2000013,1000013,-1000013,1000014,2000014,
804 &1000014,-1000014,1000015,2000015,1000015,-1000015,1000016,
805 &2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,
806 &24,23,25,24,37,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
807 &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002,
808 &1000002,-1000002,1000003,2000003,1000003,-1000003,1000004,
809 &2000004,1000004,-1000004,1000005,2000005,1000005,-1000005,
810 &1000006,2000006,1000006,-1000006,1000011,2000011,1000011,
811 &-1000011,1000012,2000012,1000012,-1000012,1000013,2000013,
812 &1000013,-1000013,1000014,2000014,1000014,-1000014,1000015,
813 &2000015,1000015,-1000015,1000016,2000016,1000016,-1000016,-1,-3,
814 &-5,-7,-11,-13,-15,-17,24,2*1000022,2*1000023,2*1000025,2*1000035,
815 &1000006,2000006,1000006,2000006,-1000001,-1000003,-1000011,
816 &-1000013,-1000015,-2000015,1,2,3,4,5,6,11,13,15,2,82,-11,-13,2*2,
817 &-12,-14,-16,2*-2,2*-4,-2,-4,2*22,211,111,221,13,11,213,-213,221,
818 &223,321,130,310,111,331,111,211,-12,12,-14,14,211,111,22,-13,-11/
819 DATA (KFDP(I,1),I= 581, 992)/2*211,213,113,221,223,321,211,331,
820 &22,111,211,2*22,211,22,111,211,22,211,221,111,11,211,111,2*211,
821 &321,130,310,221,111,211,111,130,310,321,2*311,321,311,323,313,
822 &323,313,321,3*311,-13,3*211,12,14,311,2*321,311,321,313,323,313,
823 &323,311,4*321,211,111,3*22,111,321,130,-213,113,213,211,22,111,
824 &11,13,211,321,130,310,221,211,111,11*-11,11*-13,-311,-313,-311,
825 &-313,-20313,2*-311,-313,-311,-313,2*111,2*221,2*331,2*113,2*223,
826 &2*333,-311,-313,2*-321,211,-311,-321,333,-311,-313,-321,211,
827 &2*-321,2*-311,-321,211,113,421,2*411,421,411,423,413,423,413,421,
828 &411,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,-313,2*-311,
829 &-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,3*-321,-311,
830 &-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,-321,3*-311,
831 &211,113,321,2*421,411,421,413,423,413,423,411,421,-15,5*-11,
832 &5*-13,221,331,333,221,331,333,10221,211,213,211,213,321,323,321,
833 &323,2212,221,331,333,221,2*2,2*431,421,411,423,413,82,11,13,82,
834 &443,82,6*12,6*14,2*16,3*-411,3*-413,2*-411,2*-413,2*441,2*443,
835 &2*20443,2*2,2*4,2,4,511,521,511,523,513,523,513,521,511,6*12,
836 &6*14,2*16,3*-421,3*-423,2*-421,2*-423,2*441,2*443,2*20443,2*2,
837 &2*4,2,4,521,511,521,513,523,513,523,511,521,6*12,6*14,2*16,
838 &3*-431,3*-433,2*-431,2*-433,3*441,3*443,3*20443,2*2,2*4,2,4,531/
839 DATA (KFDP(I,1),I= 993,1402)/521,511,523,513,16,2*4,2*12,2*14,
840 &2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,2*-1,541,511,521,
841 &513,523,21,11,13,15,1,2,3,4,21,22,553,21,2112,2212,2*2112,2212,
842 &2112,2*2212,2112,-12,3122,3212,3112,2212,2*2112,-12,2*3122,3222,
843 &3112,2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,3322,
844 &3312,2*3122,3212,3322,3312,3122,3322,3312,-12,2*4122,7*-11,7*-13,
845 &2*2224,2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,
846 &3324,2*2224,7*2212,5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,
847 &2*3222,2*3224,4*2,3,2*2,1,2*2,-11,-13,2*2,4*4122,-11,-13,2*2,
848 &3*4132,3*4232,-11,-13,2*2,4332,-11,-13,2*2,-11,-13,2*2,-11,-13,
849 &2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,2*5122,-12,
850 &-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
851 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,4*5122,-12,-14,-16,2*-2,
852 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,2*5132,2*5232,-12,-14,-16,
853 &2*-2,2*-4,-2,-4,5332,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
854 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
855 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
856 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
857 &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
858 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2/
859 DATA (KFDP(I,1),I=1403,1713)/2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
860 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
861 &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,221,223,221,
862 &223,211,111,321,130,310,213,113,-213,321,311,321,311,323,313,
863 &2*311,321,311,321,313,323,321,211,111,321,130,310,2*211,313,-313,
864 &323,-323,421,411,423,413,411,421,413,423,411,421,423,413,443,
865 &2*82,521,511,523,513,511,521,513,523,521,511,523,513,511,521,513,
866 &523,553,2*21,213,-213,113,213,10211,10111,-10211,2*221,213,2*113,
867 &-213,2*321,2*311,113,323,2*313,323,313,-313,323,-323,423,2*413,
868 &2*423,413,443,82,523,2*513,2*523,2*513,523,553,21,11,13,82,4*443,
869 &10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,10551,20553,555,
870 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
871 &1000002,2000002,1000002,2000002,1000021,3*-12,3*-14,3*-16,12,11,
872 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,
873 &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000001,
874 &2000001,1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,
875 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
876 &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,
877 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,
878 &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000003/
879 DATA (KFDP(I,1),I=1714,1984)/2000003,1000003,2000003,1000021,
880 &3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,-1000037,1000022,
881 &1000023,1000025,1000035,1000006,2000006,1000006,2000006,1000021,
882 &3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,15,16,
883 &15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,1000022,1000023,
884 &1000025,1000035,1000005,2000005,1000005,2000005,1000021,1000022,
885 &1000016,-1000015,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,
886 &-1000037,1000022,1000023,1000025,1000035,1000012,2000012,1000012,
887 &2*12,2*14,2*16,3*-14,3*-16,3*-2,3*-4,3*-6,1000039,1000024,
888 &1000037,1000022,1000023,1000025,1000035,1000011,2000011,1000011,
889 &2000011,3*-13,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,
890 &1000022,1000023,1000025,1000035,1000014,2000014,1000014,2000014,
891 &2*12,2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,1000024,
892 &1000037,1000022,1000023,1000025,1000035,1000013,2000013,1000013,
893 &2000013,3*-11,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,
894 &1000022,1000023,1000025,1000035,1000016,2000016,1000016,2000016,
895 &2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,1000039,1000024,
896 &1000037,1000022,1000023,1000025,1000035,1000015,2000015,1000015,
897 &2000015,3*-11,3*-13,3*-1,3*-3,3*-5,1000039,1000001,-1000001,
898 &2000001,-2000001,1000002,-1000002,2000002,-2000002,1000003/
899 DATA (KFDP(I,1),I=1985,2321)/-1000003,2000003,-2000003,1000004,
900 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
901 &1000006,-1000006,2000006,-2000006,6*1000022,6*1000023,6*1000025,
902 &6*1000035,1000024,-1000024,1000024,-1000024,1000024,-1000024,
903 &1000037,-1000037,1000037,-1000037,1000037,-1000037,-12,12,-11,11,
904 &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,
905 &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,
906 &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,
907 &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,
908 &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,
909 &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,
910 &-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,4,1,-12,12,-12,12,-12,12,
911 &-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,14,-14,14,-14,14,
912 &-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,12,-11,11,-12,12,
913 &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,
914 &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,-14,14,
915 &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,
916 &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,-16,16,
917 &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,
918 &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,-4,4,-4/
919 DATA (KFDP(I,1),I=2322,2573)/4,-4,4,-6,6,-6,6,-6,6,5*1000039,
920 &16*1000022,1000024,-1000024,1000024,-1000024,1000024,-1000024,
921 &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000037,
922 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,
923 &1000037,-1000037,1000037,-1000037,1000024,-1000024,1000037,
924 &-1000037,1000001,-1000001,2000001,-2000001,1000002,-1000002,
925 &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,
926 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
927 &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011,
928 &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013,
929 &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015,
930 &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016,
931 &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,
932 &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,
933 &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
934 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,
935 &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
936 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,
937 &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
938 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16/
939 DATA (KFDP(I,1),I=2574,2892)/16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,
940 &-4,4,-6,6,-6,6,-6,6,2*1000039,6*1000022,6*1000023,6*1000025,
941 &6*1000035,1000022,1000023,1000025,1000035,1000002,2000002,
942 &-1000001,-2000001,1000004,2000004,-1000003,-2000003,1000006,
943 &2000006,-1000005,-2000005,1000012,2000012,-1000011,-2000011,
944 &1000014,2000014,-1000013,-2000013,1000016,2000016,-1000015,
945 &-2000015,2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,
946 &-12,12,-11,-12,12,-11,-14,-13,-14,-13,-14,-13,-14,14,-13,-14,14,
947 &-13,-14,14,-13,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,
948 &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,
949 &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-14,2*-13,14,
950 &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,
951 &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,2*-15,16,-16,2*-15,16,
952 &-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,
953 &-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,2,-1,3*2,-1,2*4,-3,
954 &3*4,-3,2*6,5*1000039,16*1000022,16*1000023,1000024,-1000024,
955 &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000024,
956 &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,
957 &1000037,-1000037,1000037,-1000037,1000037,-1000037,1000037,
958 &-1000037,1000024,-1000024,1000037,-1000037,1000001,-1000001/
959 DATA (KFDP(I,1),I=2893,3182)/2000001,-2000001,1000002,-1000002,
960 &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,
961 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
962 &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011,
963 &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013,
964 &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015,
965 &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016,
966 &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,
967 &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,
968 &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
969 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,
970 &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
971 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,
972 &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
973 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,
974 &16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,
975 &16*1000022,16*1000023,16*1000025,1000024,-1000024,1000024,
976 &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
977 &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037,
978 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037/
979 DATA (KFDP(I,1),I=3183,3459)/1000024,-1000024,1000037,-1000037,
980 &1000001,-1000001,2000001,-2000001,1000002,-1000002,2000002,
981 &-2000002,1000003,-1000003,2000003,-2000003,1000004,-1000004,
982 &2000004,-2000004,1000005,-1000005,2000005,-2000005,1000006,
983 &-1000006,2000006,-2000006,1000011,-1000011,2000011,-2000011,
984 &1000012,-1000012,2000012,-2000012,1000013,-1000013,2000013,
985 &-2000013,1000014,-1000014,2000014,-2000014,1000015,-1000015,
986 &2000015,-2000015,1000016,-1000016,2000016,-2000016,5*1000021,-12,
987 &12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,
988 &14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,
989 &12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
990 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,
991 &14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
992 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,
993 &16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
994 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,
995 &-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,2*1000039,15*1000024,
996 &6*1000022,6*1000023,6*1000025,6*1000035,1000022,1000023,1000025,
997 &1000035,1000002,2000002,-1000001,-2000001,1000004,2000004,
998 &-1000003,-2000003,1000006,2000006,-1000005,-2000005,1000012/
999 DATA (KFDP(I,1),I=3460,3782)/2000012,-1000011,-2000011,1000014,
1000 &2000014,-1000013,-2000013,1000016,2000016,-1000015,-2000015,
1001 &2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,
1002 &-12,12,-11,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,
1003 &-13,-14,14,-13,-16,16,-15,-16,16,-15,-16,16,-15,-16,16,-15,-16,
1004 &16,-15,-16,16,-15,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,
1005 &2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,
1006 &2*-11,12,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,
1007 &2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,
1008 &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,
1009 &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,
1010 &2,-1,3*2,-1,2*4,-3,3*4,-3,2*6,1000039,-1000024,-1000037,1000022,
1011 &1000023,1000025,1000035,4*1000001,1000002,2000002,1000002,
1012 &2000002,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,
1013 &14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,
1014 &1000022,1000023,1000025,1000035,4*1000002,1000001,2000001,
1015 &1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,
1016 &-1000024,-1000037,1000022,1000023,1000025,1000035,4*1000003,
1017 &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,
1018 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6/
1019 DATA (KFDP(I,1),I=3783,4127)/1000039,1000024,1000037,1000022,
1020 &1000023,1000025,1000035,4*1000004,1000003,2000003,1000003,
1021 &2000003,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,
1022 &-1000037,1000022,1000023,1000025,1000035,4*1000005,1000006,
1023 &2000006,1000006,2000006,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,
1024 &11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,
1025 &1000024,1000037,1000022,1000023,1000025,1000035,4*1000006,
1026 &1000005,2000005,1000005,2000005,1000021,3*-11,3*-13,3*-15,2*-1,
1027 &-3,1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
1028 &4*1000011,1000012,2000012,1000012,2000012,2*12,2*14,2*16,3*-14,
1029 &3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,1000022,1000023,
1030 &1000025,1000035,4*1000013,1000014,2000014,1000014,2000014,2*12,
1031 &2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,
1032 &1000022,1000023,1000025,1000035,4*1000015,1000016,2000016,
1033 &1000016,2000016,2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,3,4,5,
1034 &6,11,13,15,21,2*4,2,4,24,-11,-13,-15,3,4,5,6,11,13,15,21,5,6,21,
1035 &2*24,2*3000211,2*22,2*23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,
1036 &2*24,3*3000211,24,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,22,23,22,
1037 &23,24,3000211,24,3000211,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,
1038 &1,2,3,4,5,6,1,2,3,4,5,6,21,1,2,3,4,5,6,21,1,2,3,4,5,6,21,1,2,3,4/
1039 DATA (KFDP(I,1),I=4128,8000)/5,6,1,2,3,4,5,6,1,2,3,4,5,6,21,
1040 &3100111,3200111,21,22,23,-24,21,22,23,24,22,23,-24,23,24,1,2,3,4,
1041 &5,6,7,8,11,12,13,14,15,16,17,18,21,22,23,24,9*11,9*-11,2*11,
1042 &2*-11,9*13,9*-13,2*13,2*-13,9*15,9*-15,2*15,2*-15,1,2,3,4,5,6,11,
1043 &12,9900012,13,14,9900014,15,16,9900016,3*-1,3*-3,3*-5,-11,-13,
1044 &-15,3*-11,2*-13,-15,24,3*-11,2*-13,-15,9900024,3716*0/
1045 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,
1046 &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,
1047 &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,
1048 &13,11,13,-211,-213,-211,-213,-211,-213,-211,-213,2*-211,-321,
1049 &-323,-321,2*-323,3*-321,4*-211,-213,-211,-213,-211,-213,-211,
1050 &-213,-211,-213,3*-211,-213,4*-211,-323,-321,2*-211,2*-321,3*-211,
1051 &2*15,16,15,16,15,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,
1052 &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,
1053 &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,
1054 &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,
1055 &-24,2*1000022,1000023,1000022,1000023,1000025,1000022,1000023,
1056 &1000025,1000035,-1000024,-1000037,-1000024,-1000037,-1000001,
1057 &2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
1058 &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1059 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1060 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1061 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1062 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1063 &-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,22,25,2*36,2,4,6,8,
1064 &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/
1065 DATA (KFDP(I,2),I= 340, 533)/-7,-8,-11,-13,-15,-17,21,22,2*23,
1066 &-24,2*25,-37,-24,3*36,2*1000022,1000023,1000022,1000023,1000025,
1067 &1000022,1000023,1000025,1000035,-1000024,-1000037,-1000024,
1068 &-1000037,-1000001,2*-2000001,2000001,-1000002,2*-2000002,2000002,
1069 &-1000003,2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1070 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1071 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1072 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1073 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1074 &-7,-8,-11,-13,-15,-17,21,22,2*23,-24,2*25,-37,-24,2*1000022,
1075 &1000023,1000022,1000023,1000025,1000022,1000023,1000025,1000035,
1076 &-1000024,-1000037,-1000024,-1000037,-1000001,2*-2000001,2000001,
1077 &-1000002,2*-2000002,2000002,-1000003,2*-2000003,2000003,-1000004,
1078 &2*-2000004,2000004,-1000005,2*-2000005,2000005,-1000006,
1079 &2*-2000006,2000006,-1000011,2*-2000011,2000011,-1000012,
1080 &2*-2000012,2000012,-1000013,2*-2000013,2000013,-1000014,
1081 &2*-2000014,2000014,-1000015,2*-2000015,2000015,-1000016,
1082 &2*-2000016,2000016,2,4,6,8,12,14,16,18,25,1000024,1000037,
1083 &1000024,1000037,1000024,1000037,1000024,1000037,2*-1000005,
1084 &2*-2000005,1000002,1000004,1000012,1000014,2*1000016,-3,-4,-5,-6/
1085 DATA (KFDP(I,2),I= 534, 938)/-7,-8,-13,-15,-17,11,-82,12,14,-1,
1086 &-3,11,13,15,1,4,3,4,1,3,22,11,-211,2*22,-13,-11,-211,211,111,211,
1087 &-321,130,310,22,2*111,-211,11,-11,13,-13,-211,111,22,14,12,111,
1088 &22,111,3*211,-311,22,211,22,111,-211,211,11,-211,13,22,-211,111,
1089 &-211,22,111,-11,-211,111,2*-211,-321,130,310,221,111,-211,111,
1090 &2*0,-211,111,22,-211,111,-211,111,-211,211,-213,113,223,221,14,
1091 &111,211,111,-11,-13,211,111,22,211,111,211,111,2*211,213,113,223,
1092 &221,22,-211,111,113,223,22,111,-321,310,211,111,2*-211,221,22,
1093 &-11,-13,-211,-321,130,310,221,-211,111,11*12,11*14,2*211,2*213,
1094 &211,20213,2*321,2*323,211,213,211,213,211,213,211,213,211,213,
1095 &211,213,3*211,213,211,2*321,8*211,2*113,3*211,111,22,211,111,211,
1096 &111,4*211,8*12,8*14,2*211,2*213,2*111,221,2*113,223,333,20213,
1097 &211,2*321,323,2*311,313,-211,111,113,2*211,321,2*211,311,321,310,
1098 &211,-211,4*211,321,4*211,113,2*211,-321,111,22,-211,111,-211,111,
1099 &-211,211,-211,211,16,5*12,5*14,3*211,3*213,211,2*111,2*113,
1100 &2*-311,2*-313,-2112,3*321,323,2*-1,22,111,321,311,321,311,-82,
1101 &-11,-13,-82,22,-82,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,
1102 &431,433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,22,
1103 &-211,111,-211,111,-211,211,-211,211,6*-11,6*-13,2*-15,211,213,
1104 &20213,211,213,20213,431,433,431,433,321,323,321,323,321,323,-1/
1105 DATA (KFDP(I,2),I= 939,1352)/-4,-3,-4,-1,-3,22,211,111,211,111,
1106 &4*211,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,433,431,
1107 &433,221,331,333,221,331,333,221,331,333,-1,-4,-3,-4,-1,-3,22,
1108 &-321,-311,-321,-311,-15,-3,-1,2*-11,2*-13,2*-15,-1,-4,-3,-4,-3,
1109 &-4,-1,-4,2*12,2*14,2,3,2,3,2*12,2*14,2,1,22,411,421,411,421,21,
1110 &-11,-13,-15,-1,-2,-3,-4,2*21,22,21,2*-211,111,22,111,211,22,211,
1111 &-211,11,2*-211,111,-211,111,22,11,22,111,-211,211,111,211,22,211,
1112 &111,211,-211,22,11,13,11,-211,2*111,2*22,111,211,-321,-211,111,
1113 &11,2*-211,7*12,7*14,-321,-323,-311,-313,-311,-313,211,213,211,
1114 &213,211,213,111,221,331,113,223,111,221,113,223,321,323,321,-211,
1115 &-213,111,221,331,113,223,333,10221,111,221,331,113,223,211,213,
1116 &211,213,321,323,321,323,321,323,311,313,311,313,2*-1,-3,-1,2203,
1117 &3201,3203,2203,2101,2103,12,14,-1,-3,2*111,2*211,12,14,-1,-3,22,
1118 &111,2*22,111,22,12,14,-1,-3,22,12,14,-1,-3,12,14,-1,-3,12,14,-1,
1119 &-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,2*-211,11,13,
1120 &15,-211,-213,-20213,-431,-433,3*3122,1,4,3,4,1,3,11,13,15,1,4,3,
1121 &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,
1122 &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,
1123 &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,
1124 &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/
1125 DATA (KFDP(I,2),I=1353,1815)/11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,
1126 &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,
1127 &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,
1128 &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,
1129 &2*111,2*211,-211,111,-321,130,310,-211,111,211,-211,111,-213,113,
1130 &-211,111,223,211,111,213,113,211,111,223,-211,111,-321,130,310,
1131 &2*-211,-311,311,-321,321,211,111,211,111,-211,111,-211,111,311,
1132 &2*321,311,22,2*-82,-211,111,-211,111,211,111,211,111,-321,-311,
1133 &-321,-311,411,421,411,421,22,2*21,-211,2*211,111,-211,111,2*211,
1134 &111,-211,211,111,211,-321,2*-311,-321,22,-211,111,211,111,-311,
1135 &311,-321,321,211,111,-211,111,321,311,22,-82,-211,111,211,111,
1136 &-321,-311,411,421,22,21,-11,-13,-82,211,111,221,111,4*22,-11,-13,
1137 &-15,-1,-2,-3,-4,2*21,211,111,3*22,1,2*2,4*1,2*-24,2*-37,2*1,3,5,
1138 &1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,-3,-5,-3,-5,-3,
1139 &-5,2,2*1,4*2,2*24,2*37,2,1,3,5,1,3,5,1,3,5,-3,2*-5,3,2*4,4*3,
1140 &2*-24,2*-37,3,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,
1141 &5,6,-1,-5,-1,-5,-1,-5,4,2*3,4*4,2*24,2*37,4,1,3,5,1,3,5,1,3,5,-3,
1142 &2*-5,5,2*6,4*5,2*-24,2*-37,5,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,
1143 &4,5,6,1,2,3,4,5,6,-1,-3,-1,-3,-1,-3,6,2*5,4*6,2*24,2*37,6,4,-15,
1144 &16,1,3,5,1,3,5,1,3,5,-3,2*-5,11,2*12,4*11,2*-24,-37,13,15,11,15/
1145 DATA (KFDP(I,2),I=1816,2317)/11,13,11,13,15,11,13,15,1,3,5,1,3,5,
1146 &1,3,5,12,2*11,4*12,2*24,2*37,11,13,15,11,13,15,1,3,5,1,3,5,1,3,5,
1147 &13,2*14,4*13,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,
1148 &5,1,3,5,1,3,5,14,2*13,4*14,2*24,2*37,11,13,15,11,13,15,1,3,5,1,3,
1149 &5,1,3,5,15,2*16,4*15,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
1150 &13,15,1,3,5,1,3,5,1,3,5,16,2*15,4*16,2*24,2*37,11,13,15,11,13,15,
1151 &1,3,5,1,3,5,1,3,5,21,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,
1152 &5,-5,5,-6,6,-6,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6,
1153 &1,-1,3,-3,5,-5,1,-1,3,-3,5,-5,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,
1154 &-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,
1155 &-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,
1156 &-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,
1157 &-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3,3,-1,1,-1,1,
1158 &-3,3,-1,1,-1,1,-3,3,22,23,25,35,36,-1,-3,-13,13,-13,13,-13,13,
1159 &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,
1160 &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,
1161 &1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,
1162 &6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,
1163 &5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,
1164 &4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3/
1165 DATA (KFDP(I,2),I=2318,2770)/3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,22,
1166 &23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,
1167 &-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,
1168 &-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,
1169 &5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,
1170 &14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,
1171 &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,
1172 &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,
1173 &1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,
1174 &6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,
1175 &5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,
1176 &4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3,
1177 &3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,24,37,24,-11,-13,-15,-1,-3,24,
1178 &-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,
1179 &2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,2*14,2*-15,2*16,-1,
1180 &-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,16,2*-15,16,-15,
1181 &6*-11,-15,16,2*-15,16,2*-15,16,-15,6*-11,6*-13,-1,-2,-1,2,-1,-2,
1182 &-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,
1183 &-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,
1184 &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1/
1185 DATA (KFDP(I,2),I=2771,3221)/2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,
1186 &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,
1187 &2*4,-3,4,-3,3*6,-5,2*4,-3,3*6,-5,2*6,22,23,25,35,36,22,23,11,13,
1188 &15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,
1189 &25,35,36,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,
1190 &-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,
1191 &-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,
1192 &-13,13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,
1193 &13,-13,13,-13,13,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,
1194 &15,-15,15,-15,15,-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,
1195 &-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,
1196 &-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,
1197 &-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,
1198 &-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,
1199 &-6,6,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,22,23,25,35,36,
1200 &22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,
1201 &16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,
1202 &-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,
1203 &-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,
1204 &-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13/
1205 DATA (KFDP(I,2),I=3222,3669)/13,-14,14,-14,14,-15,15,-15,15,-16,
1206 &16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,-15,15,-15,15,-15,15,
1207 &-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,
1208 &-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,
1209 &3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,
1210 &2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,
1211 &5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,
1212 &4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,-1,
1213 &1,-1,1,-3,3,24,37,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,24,-11,
1214 &-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,
1215 &-13,-15,-1,-3,4*37,2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,
1216 &2*14,2*-15,2*16,-1,-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,
1217 &16,2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-15,16,2*-15,16,
1218 &2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-13,14,2*-13,14,2*-13,
1219 &14,-13,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,
1220 &-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,
1221 &-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,
1222 &6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,
1223 &-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,2*4,
1224 &-3,4,-3,3*6,-5,2*4,-3,3*6,-5,2*6,1,2*2,4*1,23,25,35,36,2*-24/
1225 DATA (KFDP(I,2),I=3670,4136)/2*-37,2*1,3,5,1,3,5,1,3,5,1,2,3,4,5,
1226 &6,1,2,3,4,5,6,1,2,3,4,5,6,-3,-5,-3,-5,-3,-5,2,2*1,4*2,23,25,35,
1227 &36,2*24,2*37,2,1,3,5,1,3,5,1,3,5,-3,2*-5,3,2*4,4*3,23,25,35,36,
1228 &2*-24,2*-37,3,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,
1229 &5,6,-1,-5,-1,-5,-1,-5,4,2*3,4*4,23,25,35,36,2*24,2*37,4,1,3,5,1,
1230 &3,5,1,3,5,-3,2*-5,5,2*6,4*5,23,25,35,36,2*-24,2*-37,5,1,3,5,1,3,
1231 &5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,-1,-3,-1,-3,-1,-3,6,
1232 &2*5,4*6,23,25,35,36,2*24,2*37,6,1,3,5,1,3,5,1,3,5,-3,2*-5,11,
1233 &2*12,4*11,23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
1234 &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,
1235 &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,
1236 &23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,
1237 &5,1,3,5,1,3,5,-3,-4,-5,-6,-11,-13,-15,21,-1,-3,2*-5,5,12,14,16,
1238 &-3,-4,-5,-6,-11,-13,-15,21,-5,-6,21,-24,-3000211,-24,-3000211,
1239 &3000111,3000221,3000111,3000221,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,
1240 &-13,-14,-15,-16,-17,-18,23,3000111,23,3000111,22,3000221,2,4,6,8,
1241 &2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,2*3000111,2*3000221,-3000211,
1242 &2*-24,-3000211,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,
1243 &-17,-18,-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,-4,-5,-6,
1244 &21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,-1/
1245 DATA (KFDP(I,2),I=4137,8000)/-2,-3,-4,-5,-6,3*21,3*1,4*2,1,2*11,
1246 &2*12,11,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,
1247 &21,22,23,-24,3*-1,3*-3,3*-5,3*1,3*3,3*5,2*-13,2*15,3*-1,3*-3,
1248 &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,
1249 &2*13,-1,-2,-3,-4,-5,-6,-11,-12,9900012,-13,-14,9900014,-15,-16,
1250 &9900016,2,4,6,2,4,6,2,4,6,9900012,9900014,9900016,-11,-13,-15,
1251 &-13,2*-15,24,-11,-13,-15,-13,2*-15,9900024,3716*0/
1252 DATA (KFDP(I,3),I= 1,1021)/81*0,14,6*0,2*16,2*0,6*111,310,130,
1253 &2*0,3*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,
1254 &2*113,221,2*113,2*213,-213,113,2*111,310,130,310,130,2*310,130,
1255 &402*0,4*3,4*4,1,4,3,2*2,0,-11,8*0,-211,5*0,2*111,211,-211,211,
1256 &-211,10*0,111,4*0,2*111,-211,-11,11,-13,22,111,3*0,22,3*0,111,
1257 &211,4*0,111,11*0,111,-211,6*0,-211,3*111,7*0,111,-211,5*0,2*221,
1258 &3*0,111,5*0,111,11*0,-311,-313,-311,-321,-313,-323,111,221,331,
1259 &113,223,-311,-313,-311,-321,-313,-323,111,221,331,113,223,22*0,
1260 &111,113,2*211,-211,-311,211,111,3*211,-211,7*211,7*0,111,-211,
1261 &111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,-323,-311,
1262 &-321,-313,-323,-211,-213,22*0,111,113,-311,2*-211,211,-211,310,
1263 &-211,2*111,211,2*-211,-321,-211,2*211,-211,111,-211,2*211,6*0,
1264 &111,-211,111,-211,0,221,331,333,321,311,221,331,333,321,311,20*0,
1265 &3,13*0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413,
1266 &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1267 &111,-211,-421,-423,-10423,-10421,-20423,-425,-421,-423,-10423,
1268 &-10421,-20423,-425,-421,-423,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1269 &111,-211,-431,-433,-10433,-10431,-20433,-435,-431,-433,-10433,
1270 &-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,-3,2*-2,8*0,441,443,
1271 &441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,533,531,533,3,2,3,2/
1272 DATA (KFDP(I,3),I=1022,2223)/511,513,511,513,1,2,13*0,2*21,11*0,
1273 &2112,6*0,2212,12*0,2*3122,3212,10*0,3322,2*0,3122,3212,3214,2112,
1274 &2114,2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,6*0,
1275 &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,
1276 &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,
1277 &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,
1278 &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,
1279 &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,
1280 &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,
1281 &3,2*2,31*0,211,111,45*0,-211,2*111,-211,3*111,-211,111,211,30*0,
1282 &-211,111,13*0,2*21,-211,111,199*0,2*5,210*0,-1,-3,-5,-2,-4,-6,-1,
1283 &-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-2,2,-4,4,-6,
1284 &6,-2,2,-4,4,-6,6,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,
1285 &-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
1286 &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,
1287 &-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,
1288 &-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,-3,3,
1289 &-5,5,-5,5,5*0,11,12,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,
1290 &-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,
1291 &-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3/
1292 DATA (KFDP(I,3),I=2224,2783)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
1293 &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,
1294 &-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,
1295 &-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,
1296 &-5,5,-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,
1297 &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
1298 &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,
1299 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1300 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,
1301 &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,
1302 &-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,
1303 &-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,
1304 &-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,
1305 &-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,3*0,12,14,16,2,4,0,12,14,16,2,
1306 &4,0,12,14,16,2,4,0,12,14,16,2,4,28*0,2,4,12,-11,11,14,-13,13,16,
1307 &-15,15,12,-11,11,14,-13,13,16,-15,15,12,11,14,13,16,15,12,-11,11,
1308 &14,-13,13,16,-15,15,12,11,14,13,16,15,12,11,14,13,16,15,2*2,1,-1,
1309 &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,
1310 &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,
1311 &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/
1312 DATA (KFDP(I,3),I=2784,3354)/2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,
1313 &2*6,5,-5,3,-3,5,-5,1,3,-3,5,-5,1,3,5,-5,1,5,-5,1,3,5,-5,1,3,7*0,
1314 &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,
1315 &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
1316 &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,
1317 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1318 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,
1319 &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,
1320 &-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,
1321 &-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,
1322 &-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,
1323 &-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,-16,
1324 &-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,
1325 &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,
1326 &-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,
1327 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1328 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,
1329 &-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,
1330 &-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,
1331 &-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3/
1332 DATA (KFDP(I,3),I=3355,8000)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
1333 &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,-5,5,-3,3,-5,5,
1334 &-5,5,-3,3,-5,5,-5,5,3*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,
1335 &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,
1336 &28*0,2,4,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,
1337 &-15,15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,
1338 &15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,15,
1339 &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,
1340 &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,
1341 &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,
1342 &2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,3,-3,5,-5,
1343 &1,3,-3,5,-5,1,3,5,-5,1,5,-5,1,3,5,-5,1,3,351*0,-5,169*0,2,4,6,2,
1344 &4,6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900014,2*9900016,2,4,6,2,
1345 &4,6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900016,2,4,6,2,
1346 &4,6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900014,3757*0/
1347 DATA (KFDP(I,4),I= 1,8000)/94*0,4*111,6*0,111,2*0,-211,0,-211,
1348 &3*0,111,2*-211,0,111,0,2*111,113,221,2*111,-213,-211,211,113,
1349 &6*111,310,2*130,402*0,13*81,41*0,-11,10*0,111,-211,4*0,111,62*0,
1350 &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,
1351 &-211,2*211,2*-211,13*0,-211,111,-211,111,4*0,-211,111,-211,111,
1352 &34*0,111,-211,3*111,3*-211,2*111,3*-211,14*0,-321,-311,3*0,-321,
1353 &-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,
1354 &2*-5,67*0,-211,111,5*0,-211,111,52*0,2101,2103,2*2101,6*0,4*81,
1355 &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,
1356 &162*81,31*0,-211,111,6516*0/
1357 DATA (KFDP(I,5),I= 1,8000)/96*0,2*111,17*0,111,7*0,2*111,0,
1358 &3*111,0,111,597*0,-211,2*111,-211,111,-211,111,65*0,111,-211,
1359 &3*111,-211,111,7193*0/
1360
1361C...PYDAT4, with particle names (character strings).
1362 DATA (CHAF(I,1),I= 1, 100)/'d','u','s','c','b','t','b''','t''',
1363 &2*' ','e-','nu_e','mu-','nu_mu','tau-','nu_tau','tau''-',
1364 &'nu''_tau',2*' ','g','gamma','Z0','W+','h0',6*' ','Z''0','Z"0',
1365 &'W''+','H0','A0','H+',' ','Graviton',' ','R0','LQ_ue',38*' ',
1366 &'specflav','rndmflav','phasespa','c-hadron','b-hadron',2*' ',
1367 &'junction',' ','system','cluster','string','indep.','CMshower',
1368 &'SPHEaxis','THRUaxis','CLUSjet','CELLjet','table',' '/
1369 DATA (CHAF(I,1),I= 101, 202)/'reggeon','pi0',
1370 &'rho0','a_20','K_L0','pi+','rho+','a_2+','eta','omega','f_2',
1371 &'K_S0','K0','K*0','K*_20','K+','K*+','K*_2+','eta''','phi',
1372 &'f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+','D*_s+',
1373 &'D*_2s+','eta_c','J/psi','chi_2c','B0','B*0','B*_20','B+','B*+',
1374 &'B*_2+','B_s0','B*_s0','B*_2s0','B_c+','B*_c+','B*_2c+','eta_b',
1375 &'Upsilon','chi_2b','pomeron','dd_1','Delta-','ud_0','ud_1','n0',
1376 &'Delta0','uu_1','p+','Delta+','Delta++','sd_0','sd_1','Sigma-',
1377 &'Sigma*-','Lambda0','su_0','su_1','Sigma0','Sigma*0','Sigma+',
1378 &'Sigma*+','ss_1','Xi-','Xi*-','Xi0','Xi*0','Omega-','cd_0',
1379 &'cd_1','Sigma_c0','Sigma*_c0','Lambda_c+','Xi_c0','cu_0','cu_1',
1380 &'Sigma_c+','Sigma*_c+','Sigma_c++','Sigma*_c++','Xi_c+','cs_0',
1381 &'cs_1','Xi''_c0','Xi*_c0','Xi''_c+','Xi*_c+','Omega_c0',
1382 &'Omega*_c0','cc_1','Xi_cc+','Xi*_cc+','Xi_cc++','Xi*_cc++'/
1383 DATA (CHAF(I,1),I= 203, 332)/'Omega_cc+','Omega*_cc+',
1384 &'Omega*_ccc++','bd_0','bd_1','Sigma_b-','Sigma*_b-','Lambda_b0',
1385 &'Xi_b-','Xi_bc0','bu_0','bu_1','Sigma_b0','Sigma*_b0','Sigma_b+',
1386 &'Sigma*_b+','Xi_b0','Xi_bc+','bs_0','bs_1','Xi''_b-','Xi*_b-',
1387 &'Xi''_b0','Xi*_b0','Omega_b-','Omega*_b-','Omega_bc0','bc_0',
1388 &'bc_1','Xi''_bc0','Xi*_bc0','Xi''_bc+','Xi*_bc+','Omega''_bc0',
1389 &'Omega*_bc0','Omega_bcc+','Omega*_bcc+','bb_1','Xi_bb-',
1390 &'Xi*_bb-','Xi_bb0','Xi*_bb0','Omega_bb-','Omega*_bb-',
1391 &'Omega_bbc0','Omega*_bbc0','Omega*_bbb-','a_00','b_10','a_0+',
1392 &'b_1+','f_0','h_1','K*_00','K_10','K*_0+','K_1+','f''_0','h''_1',
1393 &'D*_0+','D_1+','D*_00','D_10','D*_0s+','D_1s+','chi_0c','h_1c',
1394 &'B*_00','B_10','B*_0+','B_1+','B*_0s0','B_1s0','B*_0c+','B_1c+',
1395 &'chi_0b','h_1b','a_10','a_1+','f_1','K*_10','K*_1+','f''_1',
1396 &'D*_1+','D*_10','D*_1s+','chi_1c','B*_10','B*_1+','B*_1s0',
1397 &'B*_1c+','chi_1b','psi''','Upsilon''','~d_L','~u_L','~s_L',
1398 &'~c_L','~b_1','~t_1','~e_L-','~nu_eL','~mu_L-','~nu_muL',
1399 &'~tau_1-','~nu_tauL','~g','~chi_10','~chi_20','~chi_1+',
1400 &'~chi_30','~chi_40','~chi_2+','~Gravitino','~d_R','~u_R','~s_R',
1401 &'~c_R','~b_2','~t_2','~e_R-','~nu_eR','~mu_R-','~nu_muR',
1402 &'~tau_2-','~nu_tauR','pi_tc0','pi_tc+','pi''_tc0','eta_tc0'/
1403 DATA (CHAF(I,1),I= 333, 500)/'rho_tc0','rho_tc+','omega_tc',
1404 &'V8_tc','pi_22_1_tc','pi_22_8_tc','rho_11_tc','rho_12_tc',
1405 &'rho_21_tc','rho_22_tc','d*','u*','e*-','nu*_e0','Graviton*',
1406 &'nu_Re','nu_Rmu','nu_Rtau','Z_R0','W_R+','H_L++','H_R++',
1407 &'rho_diff0','pi_diffr+','omega_di','phi_diff','J/psi_di',
1408 &'n_diffr0','p_diffr+',139*' '/
1409 DATA (CHAF(I,2),I= 1, 205)/'dbar','ubar','sbar','cbar','bbar',
1410 &'tbar','b''bar','t''bar',2*' ','e+','nu_ebar','mu+','nu_mubar',
1411 &'tau+','nu_taubar','tau''+','nu''_taubar',5*' ','W-',9*' ',
1412 &'W''-',2*' ','H-',3*' ','Rbar0','LQ_uebar',39*' ','rndmflavbar',
1413 &' ','c-hadronbar','b-hadronbar',20*' ','pi-','rho-','a_2-',4*' ',
1414 &'Kbar0','K*bar0','K*_2bar0','K-','K*-','K*_2-',3*' ','D-','D*-',
1415 &'D*_2-','Dbar0','D*bar0','D*_2bar0','D_s-','D*_s-','D*_2s-',
1416 &3*' ','Bbar0','B*bar0','B*_2bar0','B-','B*-','B*_2-','B_sbar0',
1417 &'B*_sbar0','B*_2sbar0','B_c-','B*_c-','B*_2c-',4*' ','dd_1bar',
1418 &'Deltabar+','ud_0bar','ud_1bar','nbar0','Deltabar0','uu_1bar',
1419 &'pbar-','Deltabar-','Deltabar--','sd_0bar','sd_1bar','Sigmabar+',
1420 &'Sigma*bar+','Lambdabar0','su_0bar','su_1bar','Sigmabar0',
1421 &'Sigma*bar0','Sigmabar-','Sigma*bar-','ss_1bar','Xibar+',
1422 &'Xi*bar+','Xibar0','Xi*bar0','Omegabar+','cd_0bar','cd_1bar',
1423 &'Sigma_cbar0','Sigma*_cbar0','Lambda_cbar-','Xi_cbar0','cu_0bar',
1424 &'cu_1bar','Sigma_cbar-','Sigma*_cbar-','Sigma_cbar--',
1425 &'Sigma*_cbar--','Xi_cbar-','cs_0bar','cs_1bar','Xi''_cbar0',
1426 &'Xi*_cbar0','Xi''_cbar-','Xi*_cbar-','Omega_cbar0',
1427 &'Omega*_cbar0','cc_1bar','Xi_ccbar-','Xi*_ccbar-','Xi_ccbar--',
1428 &'Xi*_ccbar--','Omega_ccbar-','Omega*_ccbar-','Omega*_cccbar-'/
1429 DATA (CHAF(I,2),I= 206, 325)/'bd_0bar','bd_1bar','Sigma_bbar+',
1430 &'Sigma*_bbar+','Lambda_bbar0','Xi_bbar+','Xi_bcbar0','bu_0bar',
1431 &'bu_1bar','Sigma_bbar0','Sigma*_bbar0','Sigma_bbar-',
1432 &'Sigma*_bbar-','Xi_bbar0','Xi_bcbar-','bs_0bar','bs_1bar',
1433 &'Xi''_bbar+','Xi*_bbar+','Xi''_bbar0','Xi*_bbar0','Omega_bbar+',
1434 &'Omega*_bbar+','Omega_bcbar0','bc_0bar','bc_1bar','Xi''_bcbar0',
1435 &'Xi*_bcbar0','Xi''_bcbar-','Xi*_bcbar-','Omega''_bcba',
1436 &'Omega*_bcbar0','Omega_bccbar-','Omega*_bccbar-','bb_1bar',
1437 &'Xi_bbbar+','Xi*_bbbar+','Xi_bbbar0','Xi*_bbbar0','Omega_bbbar+',
1438 &'Omega*_bbbar+','Omega_bbcbar0','Omega*_bbcbar0',
1439 &'Omega*_bbbbar+',2*' ','a_0-','b_1-',2*' ','K*_0bar0','K_1bar0',
1440 &'K*_0-','K_1-',2*' ','D*_0-','D_1-','D*_0bar0','D_1bar0',
1441 &'D*_0s-','D_1s-',2*' ','B*_0bar0','B_1bar0','B*_0-','B_1-',
1442 &'B*_0sbar0','B_1sbar0','B*_0c-','B_1c-',3*' ','a_1-',' ',
1443 &'K*_1bar0','K*_1-',' ','D*_1-','D*_1bar0','D*_1s-',' ',
1444 &'B*_1bar0','B*_1-','B*_1sbar0','B*_1c-',3*' ','~d_Lbar',
1445 &'~u_Lbar','~s_Lbar','~c_Lbar','~b_1bar','~t_1bar','~e_L+',
1446 &'~nu_eLbar','~mu_L+','~nu_muLbar','~tau_1+','~nu_tauLbar',3*' ',
1447 &'~chi_1-',2*' ','~chi_2-',' ','~d_Rbar','~u_Rbar','~s_Rbar',
1448 &'~c_Rbar','~b_2bar','~t_2bar','~e_R+','~nu_eRbar','~mu_R+'/
1449 DATA (CHAF(I,2),I= 326, 500)/'~nu_muRbar','~tau_2+',
1450 &'~nu_tauRbar',' ','pi_tc-',3*' ','rho_tc-',8*' ','d*bar','u*bar',
1451 &'e*bar+','nu*_ebar0',5*' ','W_R-','H_L--','H_R--',' ',
1452 &'pi_diffr-',3*' ','n_diffrbar0','p_diffrbar-',139*' '/
1453
1454C...PYDATR, with initial values for the random number generator.
1455 DATA MRPY/19780503,0,0,97,33,0/
1456
1457C...Default values for allowed processes and kinematics constraints.
1458 DATA MSEL/1/
1459 DATA MSUB/500*0/
1460 DATA ((KFIN(I,J),J=-40,40),I=1,2)/16*0,4*1,4*0,6*1,5*0,5*1,0,
1461 &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,
1462 &6*1,4*0,4*1,16*0/
1463 DATA CKIN/
1464 & 2.0D0, -1.0D0, 0.0D0, -1.0D0, 1.0D0,
1465 & 1.0D0, -10D0, 10D0, -40D0, 40D0,
1466 1 -40D0, 40D0, -40D0, 40D0, -40D0,
1467 1 40D0, -1.0D0, 1.0D0, -1.0D0, 1.0D0,
1468 2 0.0D0, 1.0D0, 0.0D0, 1.0D0, -1.0D0,
1469 2 1.0D0, -1.0D0, 1.0D0, 0D0, 0D0,
1470 3 2.0D0, -1.0D0, 0D0, 0D0, 0.0D0,
1471 3 -1.0D0, 0.0D0, -1.0D0, 4.0D0, -1.0D0,
1472 4 12.0D0, -1.0D0, 12.0D0, -1.0D0, 12.0D0,
1473 4 -1.0D0, 12.0D0, -1.0D0, 0D0, 0D0,
1474 5 0.0D0, -1.0D0, 0.0D0, -1.0D0, 0.0D0,
1475 5 -1.0D0, 0D0, 0D0, 0D0, 0D0,
1476 6 0.0001D0, 0.99D0, 0.0001D0, 0.99D0, 0D0,
1477 6 -1D0, 0D0, -1D0, 0D0, -1D0,
1478 7 0D0, -1D0, 0.0001D0, 0.99D0, 0.0001D0,
1479 7 0.99D0, 2D0, -1D0, 0D0, 0D0,
1480 8 120*0D0/
1481
1482C...Default values for main switches and parameters. Reset information.
1483 DATA (MSTP(I),I=1,100)/
1484 & 3, 1, 2, 0, 0, 0, 0, 0, 0, 0,
1485 1 1, 0, 1, 30, 0, 1, 4, 3, 4, 3,
1486 2 1, 0, 1, 0, 0, 0, 0, 0, 0, 1,
1487 3 1, 8, 0, 1, 0, 2, 1, 5, 2, 0,
1488 4 2, 1, 3, 7, 3, 1, 1, 0, 1, 0,
1489 5 7, 1, 3, 1, 5, 1, 1, 5, 1, 7,
1490 6 2, 3, 2, 2, 1, 5, 2, 1, 0, 0,
1491 7 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1492 8 1, 1, 100, 0, 0, 2, 0, 0, 0, 0,
1493 9 1, 3, 1, 3, 0, 0, 0, 0, 0, 0/
1494 DATA (MSTP(I),I=101,200)/
1495 & 3, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1496 1 1, 1, 1, 0, 0, 0, 0, 0, 0, 0,
1497 2 0, 1, 2, 1, 1, 100, 0, 0, 10, 0,
1498 3 0, 4, 0, 1, 0, 0, 0, 0, 0, 0,
1499 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1500 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1501 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1502 7 0, 2, 0, 0, 0, 0, 0, 0, 0, 0,
1503 8 6, 214, 2003, 01, 22, 0, 0, 0, 0, 0,
1504 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1505 DATA (PARP(I),I=1,100)/
1506 & 0.25D0, 10D0, 8*0D0,
1507 1 0D0, 0D0, 1.0D0, 0.01D0, 0.5D0, 1.0D0, 1.0D0, 0.4D0, 2*0D0,
1508 2 10*0D0,
1509 3 1.5D0,2.0D0,0.075D0,1.0D0,0.2D0,0D0,1.0D0,0.70D0,0.006D0,0D0,
1510 4 0.02D0,2.0D0,0.10D0,1000D0,2054D0,123D0,246D0,50D0,0D0,0.054D0,
1511 5 10*0D0,
1512 6 0.25D0, 1.0D0,0.25D0, 1.0D0, 2.0D0,1D-3, 1.0D0,1D-3,2*0D0,
1513 7 4.0D0, 0.25D0, 8*0D0,
1514 8 1.90D0, 1.90D0, 0.5D0, 0.2D0, 0.33D0,
1515 8 0.66D0, 0.7D0, 0.5D0, 1000D0, 0.16D0,
1516 9 1.0D0,0.40D0,5.0D0,1.0D0,0D0,3.0D0,1.0D0,0.75D0,1.0D0,5.0D0/
1517 DATA (PARP(I),I=101,200)/
1518 & 0.5D0, 0.28D0, 1.0D0, 0.8D0, 0D0, 0D0, 0D0, 0D0, 0D0, 1D0,
1519 1 2.0D0, 3*0D0, 1.5D0, 0.5D0, 0.6D0, 2.5D0, 2.0D0, 1.0D0,
1520 2 1.0D0, 0.4D0, 8*0D0,
1521 3 0.01D0, 9*0D0,
1522 4 10*0D0,
1523 5 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
1524 6 2.20D0, 23.6D0, 18.4D0, 11.5D0, 0.5D0, 0D0, 0D0, 0D0, 2*0D0,
1525 7 0D0, 0D0, 0D0, 1.0D0, 6*0D0,
1526 8 0.1D0, 0.01D0, 0.01D0, 0.01D0, 0.1D0, 0.01D0, 0.01D0, 0.01D0,
1527 8 0.3D0, 0.64D0,
1528 9 0.64D0, 5.0D0, 8*0D0/
1529 DATA MSTI/200*0/
1530 DATA PARI/200*0D0/
1531 DATA MINT/400*0/
1532 DATA VINT/400*0D0/
1533
1534C...Constants for the generation of the various processes.
1535 DATA (ISET(I),I=1,100)/
1536 & 1, 1, 1, -1, 3, -1, -1, 3, -2, 2,
1537 1 2, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1538 2 -1, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1539 3 2, 2, 2, 2, 2, 2, -1, -1, -1, -1,
1540 4 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
1541 5 -1, -1, 2, 2, -1, -1, -1, 2, -1, -1,
1542 6 -1, -1, -1, -1, -1, -1, -1, 2, 2, 2,
1543 7 4, 4, 4, -1, -1, 4, 4, -1, -1, 2,
1544 8 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1545 9 0, 0, 0, 0, 0, 9, -2, -2, 8, -2/
1546 DATA (ISET(I),I=101,200)/
1547 & -1, 1, 1, 1, 1, 2, 2, 2, -2, 2,
1548 1 2, 2, 2, 2, 2, -1, -1, -1, -2, -2,
1549 2 5, 5, 5, 5, -2, -2, -2, -2, -2, -2,
1550 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1551 4 1, 1, 1, 1, 1, 1, 1, 1, 1, -2,
1552 5 1, 1, 1, -2, -2, 1, 1, 1, -2, -2,
1553 6 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1554 7 2, 2, 5, 5, -2, 2, 2, 5, 5, -2,
1555 8 5, 5, 2, 2, 2, 5, 5, 2, 2, 2,
1556 9 1, 1, 1, 2, 2, -2, -2, -2, -2, -2/
1557 DATA (ISET(I),I=201,300)/
1558 & 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1559 1 2, 2, 2, 2, -2, 2, 2, 2, 2, 2,
1560 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1561 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1562 4 2, 2, 2, 2, -1, 2, 2, 2, 2, 2,
1563 5 2, 2, 2, 2, -1, 2, -1, 2, 2, -2,
1564 6 2, 2, 2, 2, 2, -1, -1, -1, -1, -1,
1565 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1566 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1567 9 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
1568 DATA (ISET(I),I=301,500)/
1569 & 2, 39*-2,
1570 4 1, 1, 2, 2, 2, 2, 2, 2, 2, 2,
1571 5 5, 5, 1, 1, -1, -1, -1, -1, -1, -1,
1572 6 2, 2, 2, 2, 2, 2, 2, 2, -1, 2,
1573 7 2, 2, 2, 2, 2, 2, 2, -1, -1, -1,
1574 8 2, 2, 2, 2, 2, 2, 2, 2, -2, -2,
1575 9 1, 1, 2, 2, 2, 5*-2,
1576 & 100*-2/
1577 DATA ((KFPR(I,J),J=1,2),I=1,50)/
1578 & 23, 0, 24, 0, 25, 0, 24, 0, 25, 0,
1579 & 24, 0, 23, 0, 25, 0, 0, 0, 0, 0,
1580 1 0, 0, 0, 0, 21, 21, 21, 22, 21, 23,
1581 1 21, 24, 21, 25, 22, 22, 22, 23, 22, 24,
1582 2 22, 25, 23, 23, 23, 24, 23, 25, 24, 24,
1583 2 24, 25, 25, 25, 0, 21, 0, 22, 0, 23,
1584 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1585 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1586 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1587 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23/
1588 DATA ((KFPR(I,J),J=1,2),I=51,100)/
1589 5 0, 24, 0, 25, 0, 0, 0, 0, 0, 0,
1590 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1591 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1592 6 0, 0, 0, 0, 21, 21, 24, 24, 23, 24,
1593 7 23, 23, 24, 24, 23, 24, 23, 25, 22, 22,
1594 7 23, 23, 24, 24, 24, 25, 25, 25, 0, 211,
1595 8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1596 8 443, 21,10441, 21,20443, 21, 445, 21, 0, 0,
1597 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1598 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1599 DATA ((KFPR(I,J),J=1,2),I=101,150)/
1600 & 23, 0, 25, 0, 25, 0,10441, 0, 445, 0,
1601 & 443, 22, 443, 21, 443, 22, 0, 0, 22, 25,
1602 1 21, 25, 0, 25, 21, 25, 22, 22, 21, 22,
1603 1 22, 23, 23, 23, 24, 24, 0, 0, 0, 0,
1604 2 25, 6, 25, 6, 25, 0, 25, 0, 0, 0,
1605 2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1606 3 0, 21, 0, 21, 0, 22, 0, 22, 0, 0,
1607 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1608 4 32, 0, 34, 0, 37, 0, 41, 0, 42, 0,
1609 4 4000011, 0, 4000001, 0, 4000002, 0, 3000331, 0, 0, 0/
1610 DATA ((KFPR(I,J),J=1,2),I=151,200)/
1611 5 35, 0, 35, 0, 35, 0, 0, 0, 0, 0,
1612 5 36, 0, 36, 0, 36, 0, 0, 0, 0, 0,
1613 6 6, 37, 42, 0, 42, 42, 42, 42, 11, 0,
1614 6 11, 0, 0, 4000001, 0, 4000002, 0, 4000011, 0, 0,
1615 7 23, 35, 24, 35, 35, 0, 35, 0, 0, 0,
1616 7 23, 36, 24, 36, 36, 0, 36, 0, 0, 0,
1617 8 35, 6, 35, 6, 21, 35, 0, 35, 21, 35,
1618 8 36, 6, 36, 6, 21, 36, 0, 36, 21, 36,
1619 9 3000113, 0, 3000213, 0, 3000223, 0, 11, 0, 11, 0,
1620 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1621 DATA ((KFPR(I,J),J=1,2),I=201,240)/
1622 & 1000011, 1000011, 2000011, 2000011, 1000011,
1623 & 2000011, 1000013, 1000013, 2000013, 2000013,
1624 & 1000013, 2000013, 1000015, 1000015, 2000015,
1625 & 2000015, 1000015, 2000015, 1000011, 1000012,
1626 1 1000015, 1000016, 2000015, 1000016, 1000012,
1627 1 1000012, 1000016, 1000016, 0, 0,
1628 1 1000022, 1000022, 1000023, 1000023, 1000025,
1629 1 1000025, 1000035, 1000035, 1000022, 1000023,
1630 2 1000022, 1000025, 1000022, 1000035, 1000023,
1631 2 1000025, 1000023, 1000035, 1000025, 1000035,
1632 2 1000024, 1000024, 1000037, 1000037, 1000024,
1633 2 1000037, 1000022, 1000024, 1000023, 1000024,
1634 3 1000025, 1000024, 1000035, 1000024, 1000022,
1635 3 1000037, 1000023, 1000037, 1000025, 1000037,
1636 3 1000035, 1000037, 1000021, 1000022, 1000021,
1637 3 1000023, 1000021, 1000025, 1000021, 1000035/
1638 DATA ((KFPR(I,J),J=1,2),I=241,280)/
1639 4 1000021, 1000024, 1000021, 1000037, 1000021,
1640 4 1000021, 1000021, 1000021, 0, 0,
1641 4 1000002, 1000022, 2000002, 1000022, 1000002,
1642 4 1000023, 2000002, 1000023, 1000002, 1000025,
1643 5 2000002, 1000025, 1000002, 1000035, 2000002,
1644 5 1000035, 1000001, 1000024, 2000005, 1000024,
1645 5 1000001, 1000037, 2000005, 1000037, 1000002,
1646 5 1000021, 2000002, 1000021, 0, 0,
1647 6 1000006, 1000006, 2000006, 2000006, 1000006,
1648 6 2000006, 1000006, 1000006, 2000006, 2000006,
1649 6 0, 0, 0, 0, 0,
1650 6 0, 0, 0, 0, 0,
1651 7 1000002, 1000002, 2000002, 2000002, 1000002,
1652 7 2000002, 1000002, 1000002, 2000002, 2000002,
1653 7 1000002, 2000002, 1000002, 1000002, 2000002,
1654 7 2000002, 1000002, 1000002, 2000002, 2000002/
1655 DATA ((KFPR(I,J),J=1,2),I=281,350)/
1656 8 1000005, 1000002, 2000005, 2000002, 1000005,
1657 8 2000002, 1000005, 1000002, 2000005, 2000002,
1658 8 1000005, 2000002, 1000005, 1000005, 2000005,
1659 8 2000005, 1000005, 1000005, 2000005, 2000005,
1660 9 1000005, 1000005, 2000005, 2000005, 1000005,
1661 9 2000005, 1000005, 1000021, 2000005, 1000021,
1662 9 1000005, 2000005, 37, 25, 37,
1663 9 35, 36, 25, 36, 35,
1664 & 37, 37, 78*0,
1665 4 9900041, 0, 9900042, 0, 9900041,
1666 4 11, 9900042, 11, 9900041, 13,
1667 4 9900042, 13, 9900041, 15, 9900042,
1668 4 15, 9900041, 9900041, 9900042, 9900042/
1669 DATA ((KFPR(I,J),J=1,2),I=351,500)/
1670 5 9900041, 0, 9900042, 0, 9900023,
1671 5 0, 9900024, 0, 0, 0,
1672 5 0, 0, 0, 0, 0,
1673 5 0, 0, 0, 0, 0,
1674 6 24, 24, 24, 3000211, 3000211,
1675 6 3000211, 22, 3000111, 22, 3000221,
1676 6 23, 3000111, 23, 3000221, 24,
1677 6 3000211, 0, 0, 24, 23,
1678 7 24, 3000111, 3000211, 23, 3000211,
1679 7 3000111, 22, 3000211, 23, 3000211,
1680 7 24, 3000111, 24, 3000221, 0,
1681 7 0, 0, 0, 0, 0,
1682 8 0, 0, 0, 0, 21, 21, 0, 21, 0, 0,
1683 8 21, 21, 0, 0, 0, 0, 0, 0, 0, 0,
1684 9 5000039, 0, 5000039, 0, 21,
1685 9 5000039, 0, 5000039, 21, 5000039,
1686 9 10*0,
1687 & 200*0/
1688 DATA COEF/10000*0D0/
1689 DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/
1690 &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,
1691 &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,
1692 &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,
1693 &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,
1694 &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,
1695 &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,
1696 &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,
1697 &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,
1698 &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,
1699 &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/
1700
1701C...Treatment of resonances.
1702 DATA (MWID(I) ,I= 1, 500)/5*0,3*1,8*0,1,5*0,3*1,6*0,1,0,4*1,
1703 &3*0,2*1,254*0,19*2,0,7*2,0,2,0,2,0,26*1,146*0/
1704
1705C...Character constants: name of processes.
1706 DATA PROC(0)/ 'All included subprocesses '/
1707 DATA (PROC(I),I=1,20)/
1708 &'f + fbar -> gamma*/Z0 ', 'f + fbar'' -> W+/- ',
1709 &'f + fbar -> h0 ', 'gamma + W+/- -> W+/- ',
1710 &'Z0 + Z0 -> h0 ', 'Z0 + W+/- -> W+/- ',
1711 &' ', 'W+ + W- -> h0 ',
1712 &' ', 'f + f'' -> f + f'' (QFD) ',
1713 1'f + f'' -> f + f'' (QCD) ','f + fbar -> f'' + fbar'' ',
1714 1'f + fbar -> g + g ', 'f + fbar -> g + gamma ',
1715 1'f + fbar -> g + Z0 ', 'f + fbar'' -> g + W+/- ',
1716 1'f + fbar -> g + h0 ', 'f + fbar -> gamma + gamma ',
1717 1'f + fbar -> gamma + Z0 ', 'f + fbar'' -> gamma + W+/- '/
1718 DATA (PROC(I),I=21,40)/
1719 2'f + fbar -> gamma + h0 ', 'f + fbar -> Z0 + Z0 ',
1720 2'f + fbar'' -> Z0 + W+/- ', 'f + fbar -> Z0 + h0 ',
1721 2'f + fbar -> W+ + W- ', 'f + fbar'' -> W+/- + h0 ',
1722 2'f + fbar -> h0 + h0 ', 'f + g -> f + g ',
1723 2'f + g -> f + gamma ', 'f + g -> f + Z0 ',
1724 3'f + g -> f'' + W+/- ', 'f + g -> f + h0 ',
1725 3'f + gamma -> f + g ', 'f + gamma -> f + gamma ',
1726 3'f + gamma -> f + Z0 ', 'f + gamma -> f'' + W+/- ',
1727 3'f + gamma -> f + h0 ', 'f + Z0 -> f + g ',
1728 3'f + Z0 -> f + gamma ', 'f + Z0 -> f + Z0 '/
1729 DATA (PROC(I),I=41,60)/
1730 4'f + Z0 -> f'' + W+/- ', 'f + Z0 -> f + h0 ',
1731 4'f + W+/- -> f'' + g ', 'f + W+/- -> f'' + gamma ',
1732 4'f + W+/- -> f'' + Z0 ', 'f + W+/- -> f'' + W+/- ',
1733 4'f + W+/- -> f'' + h0 ', 'f + h0 -> f + g ',
1734 4'f + h0 -> f + gamma ', 'f + h0 -> f + Z0 ',
1735 5'f + h0 -> f'' + W+/- ', 'f + h0 -> f + h0 ',
1736 5'g + g -> f + fbar ', 'g + gamma -> f + fbar ',
1737 5'g + Z0 -> f + fbar ', 'g + W+/- -> f + fbar'' ',
1738 5'g + h0 -> f + fbar ', 'gamma + gamma -> f + fbar ',
1739 5'gamma + Z0 -> f + fbar ', 'gamma + W+/- -> f + fbar'' '/
1740 DATA (PROC(I),I=61,80)/
1741 6'gamma + h0 -> f + fbar ', 'Z0 + Z0 -> f + fbar ',
1742 6'Z0 + W+/- -> f + fbar'' ', 'Z0 + h0 -> f + fbar ',
1743 6'W+ + W- -> f + fbar ', 'W+/- + h0 -> f + fbar'' ',
1744 6'h0 + h0 -> f + fbar ', 'g + g -> g + g ',
1745 6'gamma + gamma -> W+ + W- ', 'gamma + W+/- -> Z0 + W+/- ',
1746 7'Z0 + Z0 -> Z0 + Z0 ', 'Z0 + Z0 -> W+ + W- ',
1747 7'Z0 + W+/- -> Z0 + W+/- ', 'Z0 + Z0 -> Z0 + h0 ',
1748 7'W+ + W- -> gamma + gamma ', 'W+ + W- -> Z0 + Z0 ',
1749 7'W+/- + W+/- -> W+/- + W+/- ', 'W+/- + h0 -> W+/- + h0 ',
1750 7'h0 + h0 -> h0 + h0 ', 'q + gamma -> q'' + pi+/- '/
1751 DATA (PROC(I),I=81,100)/
1752 8'q + qbar -> Q + Qbar, mass ', 'g + g -> Q + Qbar, massive ',
1753 8'f + q -> f'' + Q, massive ', 'g + gamma -> Q + Qbar, mass ',
1754 8'gamma + gamma -> F + Fbar, m', 'g + g -> J/Psi + g ',
1755 8'g + g -> chi_0c + g ', 'g + g -> chi_1c + g ',
1756 8'g + g -> chi_2c + g ', ' ',
1757 9'Elastic scattering ', 'Single diffractive (XB) ',
1758 9'Single diffractive (AX) ', 'Double diffractive ',
1759 9'Low-pT scattering ', 'Semihard QCD 2 -> 2 ',
1760 9' ', ' ',
1761 9'q + gamma* -> q ', ' '/
1762 DATA (PROC(I),I=101,120)/
1763 &'g + g -> gamma*/Z0 ', 'g + g -> h0 ',
1764 &'gamma + gamma -> h0 ', 'g + g -> chi_0c ',
1765 &'g + g -> chi_2c ', 'g + g -> J/Psi + gamma ',
1766 &'gamma + g -> J/Psi + g ', 'gamma+gamma -> J/Psi + gamma',
1767 &' ', 'f + fbar -> gamma + h0 ',
1768 1'q + qbar -> g + h0 ', 'q + g -> q + h0 ',
1769 1'g + g -> g + h0 ', 'g + g -> gamma + gamma ',
1770 1'g + g -> g + gamma ', 'g + g -> gamma + Z0 ',
1771 1'g + g -> Z0 + Z0 ', 'g + g -> W+ + W- ',
1772 1' ', ' '/
1773 DATA (PROC(I),I=121,140)/
1774 2'g + g -> Q + Qbar + h0 ', 'q + qbar -> Q + Qbar + h0 ',
1775 2'f + f'' -> f + f'' + h0 ',
1776 2'f + f'' -> f" + f"'' + h0 ',
1777 2' ', ' ',
1778 2' ', ' ',
1779 2' ', ' ',
1780 3'f + gamma*_T -> f + g ', 'f + gamma*_L -> f + g ',
1781 3'f + gamma*_T -> f + gamma ', 'f + gamma*_L -> f + gamma ',
1782 3'g + gamma*_T -> f + fbar ', 'g + gamma*_L -> f + fbar ',
1783 3'gamma*_T+gamma*_T -> f+fbar ', 'gamma*_T+gamma*_L -> f+fbar ',
1784 3'gamma*_L+gamma*_T -> f+fbar ', 'gamma*_L+gamma*_L -> f+fbar '/
1785 DATA (PROC(I),I=141,160)/
1786 4'f + fbar -> gamma*/Z0/Z''0 ', 'f + fbar'' -> W''+/- ',
1787 4'f + fbar'' -> H+/- ', 'f + fbar'' -> R ',
1788 4'q + l -> LQ ', 'e + gamma -> e* ',
1789 4'd + g -> d* ', 'u + g -> u* ',
1790 4'g + g -> eta_tc ', ' ',
1791 5'f + fbar -> H0 ', 'g + g -> H0 ',
1792 5'gamma + gamma -> H0 ', ' ',
1793 5' ', 'f + fbar -> A0 ',
1794 5'g + g -> A0 ', 'gamma + gamma -> A0 ',
1795 5' ', ' '/
1796 DATA (PROC(I),I=161,180)/
1797 6'f + g -> f'' + H+/- ', 'q + g -> LQ + lbar ',
1798 6'g + g -> LQ + LQbar ', 'q + qbar -> LQ + LQbar ',
1799 6'f + fbar -> f'' + fbar'' (g/Z)',
1800 6'f +fbar'' -> f" + fbar"'' (W) ',
1801 6'q + q'' -> q" + d* ', 'q + q'' -> q" + u* ',
1802 6'q + qbar -> e + e* ', ' ',
1803 7'f + fbar -> Z0 + H0 ', 'f + fbar'' -> W+/- + H0 ',
1804 7'f + f'' -> f + f'' + H0 ',
1805 7'f + f'' -> f" + f"'' + H0 ',
1806 7' ', 'f + fbar -> Z0 + A0 ',
1807 7'f + fbar'' -> W+/- + A0 ',
1808 7'f + f'' -> f + f'' + A0 ',
1809 7'f + f'' -> f" + f"'' + A0 ',
1810 7' '/
1811 DATA (PROC(I),I=181,200)/
1812 8'g + g -> Q + Qbar + H0 ', 'q + qbar -> Q + Qbar + H0 ',
1813 8'q + qbar -> g + H0 ', 'q + g -> q + H0 ',
1814 8'g + g -> g + H0 ', 'g + g -> Q + Qbar + A0 ',
1815 8'q + qbar -> Q + Qbar + A0 ', 'q + qbar -> g + A0 ',
1816 8'q + g -> q + A0 ', 'g + g -> g + A0 ',
1817 9'f + fbar -> rho_tc0 ', 'f + f'' -> rho_tc+/- ',
1818 9'f + fbar -> omega_tc0 ', 'f+fbar -> f''+fbar'' (ETC) ',
1819 9'f+fbar'' -> f"+fbar"'' (ETC)',' ',
1820 9' ', ' ',
1821 9' ', ' '/
1822 DATA (PROC(I),I=201,220)/
1823 &'f + fbar -> ~e_L + ~e_Lbar ', 'f + fbar -> ~e_R + ~e_Rbar ',
1824 &'f + fbar -> ~e_R + ~e_Lbar ', 'f + fbar -> ~mu_L + ~mu_Lbar',
1825 &'f + fbar -> ~mu_R + ~mu_Rbar', 'f + fbar -> ~mu_L + ~mu_Rbar',
1826 &'f+fbar -> ~tau_1 + ~tau_1bar', 'f+fbar -> ~tau_2 + ~tau_2bar',
1827 &'f+fbar -> ~tau_1 + ~tau_2bar', 'q + qbar'' -> ~l_L + ~nulbar ',
1828 1'q+qbar''-> ~tau_1 + ~nutaubar', 'q+qbar''-> ~tau_2 + ~nutaubar',
1829 1'f + fbar -> ~nul + ~nulbar ', 'f+fbar -> ~nutau + ~nutaubar',
1830 1' ', 'f + fbar -> ~chi1 + ~chi1 ',
1831 1'f + fbar -> ~chi2 + ~chi2 ', 'f + fbar -> ~chi3 + ~chi3 ',
1832 1'f + fbar -> ~chi4 + ~chi4 ', 'f + fbar -> ~chi1 + ~chi2 '/
1833 DATA (PROC(I),I=221,240)/
1834 2'f + fbar -> ~chi1 + ~chi3 ', 'f + fbar -> ~chi1 + ~chi4 ',
1835 2'f + fbar -> ~chi2 + ~chi3 ', 'f + fbar -> ~chi2 + ~chi4 ',
1836 2'f + fbar -> ~chi3 + ~chi4 ', 'f+fbar -> ~chi+-1 + ~chi-+1 ',
1837 2'f+fbar -> ~chi+-2 + ~chi-+2 ', 'f+fbar -> ~chi+-1 + ~chi-+2 ',
1838 2'q + qbar'' -> ~chi1 + ~chi+-1', 'q + qbar'' -> ~chi2 + ~chi+-1',
1839 3'q + qbar'' -> ~chi3 + ~chi+-1', 'q + qbar'' -> ~chi4 + ~chi+-1',
1840 3'q + qbar'' -> ~chi1 + ~chi+-2', 'q + qbar'' -> ~chi2 + ~chi+-2',
1841 3'q + qbar'' -> ~chi3 + ~chi+-2', 'q + qbar'' -> ~chi4 + ~chi+-2',
1842 3'q + qbar -> ~chi1 + ~g ', 'q + qbar -> ~chi2 + ~g ',
1843 3'q + qbar -> ~chi3 + ~g ', 'q + qbar -> ~chi4 + ~g '/
1844 DATA (PROC(I),I=241,260)/
1845 4'q + qbar'' -> ~chi+-1 + ~g ', 'q + qbar'' -> ~chi+-2 + ~g ',
1846 4'q + qbar -> ~g + ~g ', 'g + g -> ~g + ~g ',
1847 4' ', 'qj + g -> ~qj_L + ~chi1 ',
1848 4'qj + g -> ~qj_R + ~chi1 ', 'qj + g -> ~qj_L + ~chi2 ',
1849 4'qj + g -> ~qj_R + ~chi2 ', 'qj + g -> ~qj_L + ~chi3 ',
1850 5'qj + g -> ~qj_R + ~chi3 ', 'qj + g -> ~qj_L + ~chi4 ',
1851 5'qj + g -> ~qj_R + ~chi4 ', 'qj + g -> ~qk_L + ~chi+-1 ',
1852 5'qj + g -> ~qk_R + ~chi+-1 ', 'qj + g -> ~qk_L + ~chi+-2 ',
1853 5'qj + g -> ~qk_R + ~chi+-2 ', 'qj + g -> ~qj_L + ~g ',
1854 5'qj + g -> ~qj_R + ~g ', ' '/
1855 DATA (PROC(I),I=261,300)/
1856 6'f + fbar -> ~t_1 + ~t_1bar ', 'f + fbar -> ~t_2 + ~t_2bar ',
1857 6'f + fbar -> ~t_1 + ~t_2bar ', 'g + g -> ~t_1 + ~t_1bar ',
1858 6'g + g -> ~t_2 + ~t_2bar ', ' ',
1859 6' ', ' ',
1860 6' ', ' ',
1861 7'qi + qj -> ~qi_L + ~qj_L ', 'qi + qj -> ~qi_R + ~qj_R ',
1862 7'qi + qj -> ~qi_L + ~qj_R ', 'qi+qjbar -> ~qi_L + ~qj_Lbar',
1863 7'qi+qjbar -> ~qi_R + ~qj_Rbar', 'qi+qjbar -> ~qi_L + ~qj_Rbar',
1864 7'f + fbar -> ~qi_L + ~qi_Lbar', 'f + fbar -> ~qi_R + ~qi_Rbar',
1865 7'g + g -> ~qi_L + ~qi_Lbar ', 'g + g -> ~qi_R + ~qi_Rbar ',
1866 8'b + qj -> ~b_1 + ~qj_L ', 'b + qj -> ~b_2 + ~qj_R ',
1867 8'b + qj -> ~b_1 + ~qj_R ', 'b + qjbar -> ~b_1 + ~qj_Lbar',
1868 8'b + qjbar -> ~b_2 + ~qj_Rbar', 'b + qjbar -> ~b_1 + ~qj_Rbar',
1869 8'f + fbar -> ~b_1 + ~b_1bar ', 'f + fbar -> ~b_2 + ~b_2bar ',
1870 8'g + g -> ~b_1 + ~b_1bar ', 'g + g -> ~b_2 + ~b_2bar ',
1871 9'b + b -> ~b_1 + ~b_1 ', 'b + b -> ~b_2 + ~b_2 ',
1872 9'b + b -> ~b_1 + ~b_2 ', 'b + g -> ~b_1 + ~g ',
1873 9'b + g -> ~b_2 + ~g ', 'b + bbar -> ~b_1 + ~b_2bar ',
1874 9'f + fbar'' -> H+/- + h0 ', 'f + fbar -> H+/- + H0 ',
1875 9'f + fbar -> A0 + h0 ', 'f + fbar -> A0 + H0 '/
1876 DATA (PROC(I),I=301,340)/
1877 &'f + fbar -> H+ + H- ', 39*' '/
1878 DATA (PROC(I),I=341,380)/
1879 4'l + l -> H_L++/-- ', 'l + l -> H_R++/-- ',
1880 4'l + gamma -> H_L++/-- e-/+ ', 'l + gamma -> H_R++/-- e-/+ ',
1881 4'l + gamma -> H_L++/-- mu-/+ ', 'l + gamma -> H_R++/-- mu-/+ ',
1882 4'l + gamma -> H_L++/-- tau-/+', 'l + gamma -> H_R++/-- tau-/+',
1883 4'f + fbar -> H_L++ + H_L-- ', 'f + fbar -> H_R++ + H_R-- ',
1884 5'f + f -> f'' + f'' + H_L++/-- ',
1885 5'f + f -> f'' + f'' + H_R++/-- ','f + fbar -> Z_R0 ',
1886 5'f + fbar'' -> W_R+/- ',5*' ',
1887 6' ', 'f + fbar -> W_L+ W_L- ',
1888 6'f + fbar -> W_L+/- pi_T-/+ ', 'f + fbar -> pi_T+ pi_T- ',
1889 6'f + fbar -> gamma pi_T0 ', 'f + fbar -> gamma pi_T0'' ',
1890 6'f + fbar -> Z0 pi_T0 ', 'f + fbar -> Z0 pi_T0'' ',
1891 6'f + fbar -> W+/- pi_T-/+ ', ' ',
1892 7'f + fbar'' -> W_L+/- Z_L0 ', 'f + fbar'' -> W_L+/- pi_T0 ',
1893 7'f + fbar'' -> pi_T+/- Z_L0 ', 'f + fbar'' -> pi_T+/- pi_T0 ',
1894 7'f + fbar'' -> gamma pi_T+/- ', 'f + fbar'' -> Z0 pi_T+/- ',
1895 7'f + fbar'' -> W+/- pi_T0 ',
1896 7'f + fbar'' -> W+/- pi_T0'' ',
1897 7' ',' ',
1898 7' '/
1899 DATA (PROC(I),I=381,500)/
1900 8'f + f'' -> f + f'' (ETC) ','f + fbar -> f'' + fbar'' (ETC)',
1901 8'f + fbar -> g + g (ETC) ', 'f + g -> f + g (ETC) ',
1902 8'g + g -> f + fbar (ETC) ', 'g + g -> g + g (ETC) ',
1903 8'q + qbar -> Q + Qbar (ETC) ', 'g + g -> Q + Qbar (ETC) ',
1904 8' ', ' ',
1905 9'f + fbar -> G* ', 'g + g -> G* ',
1906 9'q + qbar -> g + G* ', 'q + g -> q + G* ',
1907 9'g + g -> g + G* ',' ',
1908 & 104*' '/
1909
1910C...Cross sections and slope offsets.
1911 DATA SIGT/294*0D0/
1912
1913C...Supersymmetry switches and parameters.
1914 DATA IMSS/0,
1915 & 0, 0, 0, 1, 0, 0, 0, 0, 0, 0,
1916 1 89*0/
1917 DATA RMSS/0D0,
1918 & 80D0,160D0,500D0,800D0,2D0,250D0,200D0,800D0,700D0,800D0,
1919 1 700D0,500D0,250D0,200D0,800D0,400D0,0D0,0.1D0,850D0,0.041D0,
1920 2 1D0,800D0,1D4,1D4,1D4,0D0,0D0,0D0,24D17,0D0,
1921 3 69*0D0/
1922C...Initial values for R-violating SUSY couplings.
1923C...Should not be changed here. See PYMSIN.
1924 DATA RVLAM/27*0D0/
1925 DATA RVLAMP/27*0D0/
1926 DATA RVLAMB/27*0D0/
1927
1928C...Technicolor switches and parameters
1929 DATA ITCM/0,
1930 & 4, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1931 1 89*0/
1932 DATA RTCM/0D0,
1933 & 82D0,1.333D0,.333D0,0.408D0,1D0,1D0,.0182D0,1D0,0D0,1.333D0,
1934 1 .05D0,200D0,200D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
1935 2 .283D0,.707D0,0D0,0D0,0D0,1.667D0,250D0,250D0,.707D0,0D0,
1936 3 .707D0,0D0,1D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
1937 4 1000D0, 1D0, 1D0, 1D0, 1D0, 0D0, 4*0D0,
1938 4 49*0D0/
1939
1940C...Data for histogramming routines.
1941 DATA IHIST/1000,20000,55,1/
1942 DATA INDX/1000*0/
1943
1944 END
1945
1946C*********************************************************************
1947
1948C...PYTEST
1949C...A simple program (disguised as subroutine) to run at installation
1950C...as a check that the program works as intended.
1951
1952 SUBROUTINE PYTEST(MTEST)
1953
1954C...Double precision and integer declarations.
1955 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
1956 IMPLICIT INTEGER(I-N)
1957 INTEGER PYK,PYCHGE,PYCOMP
1958C...Commonblocks.
1959 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
1960 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1961 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
1962 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
1963 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
1964 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
1965 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
1966C...Local arrays.
1967 DIMENSION PSUM(5),PINI(6),PFIN(6)
1968
1969C...Save defaults for values that are changed.
1970 MSTJ1=MSTJ(1)
1971 MSTJ3=MSTJ(3)
1972 MSTJ11=MSTJ(11)
1973 MSTJ42=MSTJ(42)
1974 MSTJ43=MSTJ(43)
1975 MSTJ44=MSTJ(44)
1976 PARJ17=PARJ(17)
1977 PARJ22=PARJ(22)
1978 PARJ43=PARJ(43)
1979 PARJ54=PARJ(54)
1980 MST101=MSTJ(101)
1981 MST104=MSTJ(104)
1982 MST105=MSTJ(105)
1983 MST107=MSTJ(107)
1984 MST116=MSTJ(116)
1985
1986C...First part: loop over simple events to be generated.
1987 IF(MTEST.GE.1) CALL PYTABU(20)
1988 NERR=0
1989 DO 180 IEV=1,500
1990
1991C...Reset parameter values. Switch on some nonstandard features.
1992 MSTJ(1)=1
1993 MSTJ(3)=0
1994 MSTJ(11)=1
1995 MSTJ(42)=2
1996 MSTJ(43)=4
1997 MSTJ(44)=2
1998 PARJ(17)=0.1D0
1999 PARJ(22)=1.5D0
2000 PARJ(43)=1D0
2001 PARJ(54)=-0.05D0
2002 MSTJ(101)=5
2003 MSTJ(104)=5
2004 MSTJ(105)=0
2005 MSTJ(107)=1
2006 IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3
2007
2008C...Ten events each for some single jets configurations.
2009 IF(IEV.LE.50) THEN
2010 ITY=(IEV+9)/10
2011 MSTJ(3)=-1
2012 IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2
2013 IF(ITY.EQ.1) CALL PY1ENT(1,1,15D0,0D0,0D0)
2014 IF(ITY.EQ.2) CALL PY1ENT(1,3101,15D0,0D0,0D0)
2015 IF(ITY.EQ.3) CALL PY1ENT(1,-2203,15D0,0D0,0D0)
2016 IF(ITY.EQ.4) CALL PY1ENT(1,-4,30D0,0D0,0D0)
2017 IF(ITY.EQ.5) CALL PY1ENT(1,21,15D0,0D0,0D0)
2018
2019C...Ten events each for some simple jet systems; string fragmentation.
2020 ELSEIF(IEV.LE.130) THEN
2021 ITY=(IEV-41)/10
2022 IF(ITY.EQ.1) CALL PY2ENT(1,1,-1,40D0)
2023 IF(ITY.EQ.2) CALL PY2ENT(1,4,-4,30D0)
2024 IF(ITY.EQ.3) CALL PY2ENT(1,2,2103,100D0)
2025 IF(ITY.EQ.4) CALL PY2ENT(1,21,21,40D0)
2026 IF(ITY.EQ.5) CALL PY3ENT(1,2101,21,-3203,30D0,0.6D0,0.8D0)
2027 IF(ITY.EQ.6) CALL PY3ENT(1,5,21,-5,40D0,0.9D0,0.8D0)
2028 IF(ITY.EQ.7) CALL PY3ENT(1,21,21,21,60D0,0.7D0,0.5D0)
2029 IF(ITY.EQ.8) CALL PY4ENT(1,2,21,21,-2,40D0,
2030 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2031
2032C...Seventy events with independent fragmentation and momentum cons.
2033 ELSEIF(IEV.LE.200) THEN
2034 ITY=1+(IEV-131)/16
2035 MSTJ(2)=1+MOD(IEV-131,4)
2036 MSTJ(3)=1+MOD((IEV-131)/4,4)
2037 IF(ITY.EQ.1) CALL PY2ENT(1,4,-5,40D0)
2038 IF(ITY.EQ.2) CALL PY3ENT(1,3,21,-3,40D0,0.9D0,0.4D0)
2039 IF(ITY.EQ.3) CALL PY4ENT(1,2,21,21,-2,40D0,
2040 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2041 IF(ITY.GE.4) CALL PY4ENT(1,2,-3,3,-2,40D0,
2042 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2043
2044C...A hundred events with random jets (check invariant mass).
2045 ELSEIF(IEV.LE.300) THEN
2046 100 DO 110 J=1,5
2047 PSUM(J)=0D0
2048 110 CONTINUE
2049 NJET=2D0+6D0*PYR(0)
2050 DO 130 I=1,NJET
2051 KFL=21
2052 IF(I.EQ.1) KFL=INT(1D0+4D0*PYR(0))
2053 IF(I.EQ.NJET) KFL=-INT(1D0+4D0*PYR(0))
2054 EJET=5D0+20D0*PYR(0)
2055 THETA=ACOS(2D0*PYR(0)-1D0)
2056 PHI=6.2832D0*PYR(0)
2057 IF(I.LT.NJET) CALL PY1ENT(-I,KFL,EJET,THETA,PHI)
2058 IF(I.EQ.NJET) CALL PY1ENT(I,KFL,EJET,THETA,PHI)
2059 IF(I.EQ.1.OR.I.EQ.NJET) MSTJ(93)=1
2060 IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+PYMASS(KFL)
2061 DO 120 J=1,4
2062 PSUM(J)=PSUM(J)+P(I,J)
2063 120 CONTINUE
2064 130 CONTINUE
2065 IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT.
2066 & (PSUM(5)+PARJ(32))**2) GOTO 100
2067
2068C...Fifty e+e- continuum events with matrix elements.
2069 ELSEIF(IEV.LE.350) THEN
2070 MSTJ(101)=2
2071 CALL PYEEVT(0,40D0)
2072
2073C...Fifty e+e- continuum event with varying shower options.
2074 ELSEIF(IEV.LE.400) THEN
2075 MSTJ(42)=1+MOD(IEV,2)
2076 MSTJ(43)=1+MOD(IEV/2,4)
2077 MSTJ(44)=MOD(IEV/8,3)
2078 CALL PYEEVT(0,90D0)
2079
2080C...Fifty e+e- continuum events with coherent shower.
2081 ELSEIF(IEV.LE.450) THEN
2082 CALL PYEEVT(0,500D0)
2083
2084C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
2085 ELSE
2086 CALL PYONIA(5,9.46D0)
2087 ENDIF
2088
2089C...Generate event. Find total momentum, energy and charge.
2090 DO 140 J=1,4
2091 PINI(J)=PYP(0,J)
2092 140 CONTINUE
2093 PINI(6)=PYP(0,6)
2094 CALL PYEXEC
2095 DO 150 J=1,4
2096 PFIN(J)=PYP(0,J)
2097 150 CONTINUE
2098 PFIN(6)=PYP(0,6)
2099
2100C...Check conservation of energy, momentum and charge;
2101C...usually exact, but only approximate for single jets.
2102 MERR=0
2103 IF(IEV.LE.50) THEN
2104 IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.10D0)
2105 & MERR=MERR+1
2106 EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)
2107 IF(EPZREM.LT.0D0.OR.EPZREM.GT.2D0*PARJ(31)) MERR=MERR+1
2108 IF(ABS(PFIN(6)-PINI(6)).GT.2.1D0) MERR=MERR+1
2109 ELSE
2110 DO 160 J=1,4
2111 IF(ABS(PFIN(J)-PINI(J)).GT.0.0001D0*PINI(4)) MERR=MERR+1
2112 160 CONTINUE
2113 IF(ABS(PFIN(6)-PINI(6)).GT.0.1D0) MERR=MERR+1
2114 ENDIF
2115 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
2116 & (PFIN(J),J=1,4),PFIN(6)
2117
2118C...Check that all KF codes are known ones, and that partons/particles
2119C...satisfy energy-momentum-mass relation. Store particle statistics.
2120 DO 170 I=1,N
2121 IF(K(I,1).GT.20) GOTO 170
2122 IF(PYCOMP(K(I,2)).EQ.0) THEN
2123 WRITE(MSTU(11),5100) I
2124 MERR=MERR+1
2125 ENDIF
2126 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
2127 IF(ABS(PD).GT.MAX(0.1D0,0.001D0*P(I,4)**2).OR.P(I,4).LT.0D0)
2128 & THEN
2129 WRITE(MSTU(11),5200) I
2130 MERR=MERR+1
2131 ENDIF
2132 170 CONTINUE
2133 IF(MTEST.GE.1) CALL PYTABU(21)
2134
2135C...List all erroneous events and some normal ones.
2136 IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN
2137 IF(MERR.GE.1) WRITE(MSTU(11),6400)
2138 CALL PYLIST(2)
2139 ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN
2140 CALL PYLIST(1)
2141 ENDIF
2142
2143C...Stop execution if too many errors.
2144 IF(MERR.NE.0) NERR=NERR+1
2145 IF(NERR.GE.10) THEN
2146 WRITE(MSTU(11),6300)
2147 CALL PYLIST(1)
2148 STOP
2149 ENDIF
2150 180 CONTINUE
2151
2152C...Summarize result of run.
2153 IF(MTEST.GE.1) CALL PYTABU(22)
2154
2155C...Reset commonblock variables changed during run.
2156 MSTJ(1)=MSTJ1
2157 MSTJ(3)=MSTJ3
2158 MSTJ(11)=MSTJ11
2159 MSTJ(42)=MSTJ42
2160 MSTJ(43)=MSTJ43
2161 MSTJ(44)=MSTJ44
2162 PARJ(17)=PARJ17
2163 PARJ(22)=PARJ22
2164 PARJ(43)=PARJ43
2165 PARJ(54)=PARJ54
2166 MSTJ(101)=MST101
2167 MSTJ(104)=MST104
2168 MSTJ(105)=MST105
2169 MSTJ(107)=MST107
2170 MSTJ(116)=MST116
2171
2172C...Second part: complete events of various kinds.
2173C...Common initial values. Loop over initiating conditions.
2174 MSTP(122)=MAX(0,MIN(2,MTEST))
2175 MDCY(PYCOMP(111),1)=0
2176 DO 230 IPROC=1,8
2177
2178C...Reset process type, kinematics cuts, and the flags used.
2179 MSEL=0
2180 DO 190 ISUB=1,500
2181 MSUB(ISUB)=0
2182 190 CONTINUE
2183 CKIN(1)=2D0
2184 CKIN(3)=0D0
2185 MSTP(2)=1
2186 MSTP(11)=0
2187 MSTP(33)=0
2188 MSTP(81)=1
2189 MSTP(82)=1
2190 MSTP(111)=1
2191 MSTP(131)=0
2192 MSTP(133)=0
2193 PARP(131)=0.01D0
2194
2195C...Prompt photon production at fixed target.
2196 IF(IPROC.EQ.1) THEN
2197 PZSUM=300D0
2198 PESUM=SQRT(PZSUM**2+PYMASS(211)**2)+PYMASS(2212)
2199 PQSUM=2D0
2200 MSEL=10
2201 CKIN(3)=5D0
2202 CALL PYINIT('FIXT','pi+','p',PZSUM)
2203
2204C...QCD processes at ISR energies.
2205 ELSEIF(IPROC.EQ.2) THEN
2206 PESUM=63D0
2207 PZSUM=0D0
2208 PQSUM=2D0
2209 MSEL=1
2210 CKIN(3)=5D0
2211 CALL PYINIT('CMS','p','p',PESUM)
2212
2213C...W production + multiple interactions at CERN Collider.
2214 ELSEIF(IPROC.EQ.3) THEN
2215 PESUM=630D0
2216 PZSUM=0D0
2217 PQSUM=0D0
2218 MSEL=12
2219 CKIN(1)=20D0
2220 MSTP(82)=4
2221 MSTP(2)=2
2222 MSTP(33)=3
2223 CALL PYINIT('CMS','p','pbar',PESUM)
2224
2225C...W/Z gauge boson pairs + pileup events at the Tevatron.
2226 ELSEIF(IPROC.EQ.4) THEN
2227 PESUM=1800D0
2228 PZSUM=0D0
2229 PQSUM=0D0
2230 MSUB(22)=1
2231 MSUB(23)=1
2232 MSUB(25)=1
2233 CKIN(1)=200D0
2234 MSTP(111)=0
2235 MSTP(131)=1
2236 MSTP(133)=2
2237 PARP(131)=0.04D0
2238 CALL PYINIT('CMS','p','pbar',PESUM)
2239
2240C...Higgs production at LHC.
2241 ELSEIF(IPROC.EQ.5) THEN
2242 PESUM=15400D0
2243 PZSUM=0D0
2244 PQSUM=2D0
2245 MSUB(3)=1
2246 MSUB(102)=1
2247 MSUB(123)=1
2248 MSUB(124)=1
2249 PMAS(25,1)=300D0
2250 CKIN(1)=200D0
2251 MSTP(81)=0
2252 MSTP(111)=0
2253 CALL PYINIT('CMS','p','p',PESUM)
2254
2255C...Z' production at SSC.
2256 ELSEIF(IPROC.EQ.6) THEN
2257 PESUM=40000D0
2258 PZSUM=0D0
2259 PQSUM=2D0
2260 MSEL=21
2261 PMAS(32,1)=600D0
2262 CKIN(1)=400D0
2263 MSTP(81)=0
2264 MSTP(111)=0
2265 CALL PYINIT('CMS','p','p',PESUM)
2266
2267C...W pair production at 1 TeV e+e- collider.
2268 ELSEIF(IPROC.EQ.7) THEN
2269 PESUM=1000D0
2270 PZSUM=0D0
2271 PQSUM=0D0
2272 MSUB(25)=1
2273 MSUB(69)=1
2274 MSTP(11)=1
2275 CALL PYINIT('CMS','e+','e-',PESUM)
2276
2277C...Deep inelastic scattering at a LEP+LHC ep collider.
2278 ELSEIF(IPROC.EQ.8) THEN
2279 P(1,1)=0D0
2280 P(1,2)=0D0
2281 P(1,3)=8000D0
2282 P(2,1)=0D0
2283 P(2,2)=0D0
2284 P(2,3)=-80D0
2285 PESUM=8080D0
2286 PZSUM=7920D0
2287 PQSUM=0D0
2288 MSUB(10)=1
2289 CKIN(3)=50D0
2290 MSTP(111)=0
2291 CALL PYINIT('3MOM','p','e-',PESUM)
2292 ENDIF
2293
2294C...Generate 20 events of each required type.
2295 DO 220 IEV=1,20
2296 CALL PYEVNT
2297 PESUMM=PESUM
2298 IF(IPROC.EQ.4) PESUMM=MSTI(41)*PESUM
2299
2300C...Check conservation of energy/momentum/flavour.
2301 PINI(1)=0D0
2302 PINI(2)=0D0
2303 PINI(3)=PZSUM
2304 PINI(4)=PESUMM
2305 PINI(6)=PQSUM
2306 DO 200 J=1,4
2307 PFIN(J)=PYP(0,J)
2308 200 CONTINUE
2309 PFIN(6)=PYP(0,6)
2310 MERR=0
2311 DEVE=ABS(PFIN(4)-PINI(4))+ABS(PFIN(3)-PINI(3))
2312 DEVT=ABS(PFIN(1)-PINI(1))+ABS(PFIN(2)-PINI(2))
2313 DEVQ=ABS(PFIN(6)-PINI(6))
2314 IF(DEVE.GT.2D-3*PESUM.OR.DEVT.GT.MAX(0.01D0,1D-4*PESUM).OR.
2315 & DEVQ.GT.0.1D0) MERR=1
2316 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
2317 & (PFIN(J),J=1,4),PFIN(6)
2318
2319C...Check that all KF codes are known ones, and that partons/particles
2320C...satisfy energy-momentum-mass relation.
2321 DO 210 I=1,N
2322 IF(K(I,1).GT.20) GOTO 210
2323 IF(PYCOMP(K(I,2)).EQ.0) THEN
2324 WRITE(MSTU(11),5100) I
2325 MERR=MERR+1
2326 ENDIF
2327 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2*
2328 & SIGN(1D0,P(I,5))
2329 IF(ABS(PD).GT.MAX(0.1D0,0.002D0*P(I,4)**2,0.002D0*P(I,5)**2)
2330 & .OR.(P(I,5).GE.0D0.AND.P(I,4).LT.0D0)) THEN
2331 WRITE(MSTU(11),5200) I
2332 MERR=MERR+1
2333 ENDIF
2334 210 CONTINUE
2335
2336C...Listing of erroneous events, and first event of each type.
2337 IF(MERR.GE.1) NERR=NERR+1
2338 IF(NERR.GE.10) THEN
2339 WRITE(MSTU(11),6300)
2340 CALL PYLIST(1)
2341 STOP
2342 ENDIF
2343 IF(MTEST.GE.1.AND.(MERR.GE.1.OR.IEV.EQ.1)) THEN
2344 IF(MERR.GE.1) WRITE(MSTU(11),6400)
2345 CALL PYLIST(1)
2346 ENDIF
2347 220 CONTINUE
2348
2349C...List statistics for each process type.
2350 IF(MTEST.GE.1) CALL PYSTAT(1)
2351 230 CONTINUE
2352
2353C...Summarize result of run.
2354 IF(NERR.EQ.0) WRITE(MSTU(11),6500)
2355 IF(NERR.GT.0) WRITE(MSTU(11),6600) NERR
2356
2357C...Format statements for output.
2358 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
2359 &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X,
2360 &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X,
2361 &4(1X,F12.5),1X,F8.2)
2362 5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
2363 5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
2364 &'kinematics')
2365 6300 FORMAT(/5X,'This is the tenth error experienced! Something is ',
2366 &'wrong.'/5X,'Execution will be stopped after listing of event.')
2367 6400 FORMAT(5X,'Faulty event follows:')
2368 6500 FORMAT(//5X,'End result of PYTEST: no errors detected.')
2369 6600 FORMAT(//5X,'End result of PYTEST:',I2,' errors detected.'/
2370 &5X,'This should not have happened!')
2371
2372 RETURN
2373 END
2374
2375C*********************************************************************
2376
2377C...PYHEPC
2378C...Converts PYTHIA event record contents to or from
2379C...the standard event record commonblock.
2380
2381 SUBROUTINE PYHEPC(MCONV)
2382
2383C...Double precision and integer declarations.
2384 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2385 IMPLICIT INTEGER(I-N)
2386 INTEGER PYK,PYCHGE,PYCOMP
2387C...Commonblocks.
2388 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2389 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2390 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2391 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
2392C...HEPEVT commonblock.
2393 PARAMETER (NMXHEP=4000)
2394 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
2395 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
2396 DOUBLE PRECISION PHEP,VHEP
2397 SAVE /HEPEVT/
2398
2399C...Conversion from PYTHIA to standard, the easy part.
2400 IF(MCONV.EQ.1) THEN
2401 NEVHEP=0
2402 IF(N.GT.NMXHEP) CALL PYERRM(8,
2403 & '(PYHEPC:) no more space in /HEPEVT/')
2404 NHEP=MIN(N,NMXHEP)
2405 DO 150 I=1,NHEP
2406 ISTHEP(I)=0
2407 IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1
2408 IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2
2409 IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3
2410 IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1)
2411 IDHEP(I)=K(I,2)
2412 JMOHEP(1,I)=K(I,3)
2413 JMOHEP(2,I)=0
2414 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
2415 JDAHEP(1,I)=K(I,4)
2416 JDAHEP(2,I)=K(I,5)
2417 ELSE
2418 JDAHEP(1,I)=0
2419 JDAHEP(2,I)=0
2420 ENDIF
2421 DO 100 J=1,5
2422 PHEP(J,I)=P(I,J)
2423 100 CONTINUE
2424 DO 110 J=1,4
2425 VHEP(J,I)=V(I,J)
2426 110 CONTINUE
2427
2428C...Check if new event (from pileup).
2429 IF(I.EQ.1) THEN
2430 INEW=1
2431 ELSE
2432 IF(K(I,1).EQ.21.AND.K(I-1,1).NE.21) INEW=I
2433 ENDIF
2434
2435C...Fill in missing mother information.
2436 IF(I.GE.INEW+2.AND.K(I,1).EQ.21.AND.K(I,3).EQ.0) THEN
2437 IMO1=I-2
2438 120 IF(IMO1.GT.INEW.AND.K(IMO1+1,1).EQ.21.AND.K(IMO1+1,3).EQ.0)
2439 & THEN
2440 IMO1=IMO1-1
2441 GOTO 120
2442 ENDIF
2443 JMOHEP(1,I)=IMO1
2444 JMOHEP(2,I)=IMO1+1
2445 ELSEIF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN
2446 I1=K(I,3)-1
2447 130 I1=I1+1
2448 IF(I1.GE.I) CALL PYERRM(8,
2449 & '(PYHEPC:) translation of inconsistent event history')
2450 IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 130
2451 KC=PYCOMP(K(I1,2))
2452 IF(I1.LT.I.AND.KC.EQ.0) GOTO 130
2453 IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 130
2454 JMOHEP(2,I)=I1
2455 ELSEIF(K(I,2).EQ.94) THEN
2456 NJET=2
2457 IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3
2458 IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4
2459 JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5))
2460 IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)=
2461 & MOD(K(I+1,4)/MSTU(5),MSTU(5))
2462 ENDIF
2463
2464C...Fill in missing daughter information.
2465 IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN
2466 DO 140 I1=JDAHEP(1,I),JDAHEP(2,I)
2467 I2=MOD(K(I1,4)/MSTU(5),MSTU(5))
2468 JDAHEP(1,I2)=I
2469 140 CONTINUE
2470 ENDIF
2471 IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 150
2472 I1=JMOHEP(1,I)
2473 IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 150
2474 IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 150
2475 IF(JDAHEP(1,I1).EQ.0) THEN
2476 JDAHEP(1,I1)=I
2477 ELSE
2478 JDAHEP(2,I1)=I
2479 ENDIF
2480 150 CONTINUE
2481 DO 160 I=1,NHEP
2482 IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 160
2483 IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I)
2484 160 CONTINUE
2485
2486C...Conversion from standard to PYTHIA, the easy part.
2487 ELSE
2488 IF(NHEP.GT.MSTU(4)) CALL PYERRM(8,
2489 & '(PYHEPC:) no more space in /PYJETS/')
2490 N=MIN(NHEP,MSTU(4))
2491 NKQ=0
2492 KQSUM=0
2493 DO 190 I=1,N
2494 K(I,1)=0
2495 IF(ISTHEP(I).EQ.1) K(I,1)=1
2496 IF(ISTHEP(I).EQ.2) K(I,1)=11
2497 IF(ISTHEP(I).EQ.3) K(I,1)=21
2498 K(I,2)=IDHEP(I)
2499 K(I,3)=JMOHEP(1,I)
2500 K(I,4)=JDAHEP(1,I)
2501 K(I,5)=JDAHEP(2,I)
2502 DO 170 J=1,5
2503 P(I,J)=PHEP(J,I)
2504 170 CONTINUE
2505 DO 180 J=1,4
2506 V(I,J)=VHEP(J,I)
2507 180 CONTINUE
2508 V(I,5)=0D0
2509 IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN
2510 I1=JDAHEP(1,I)
2511 IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))*
2512 & PHEP(5,I)/PHEP(4,I)
2513 ENDIF
2514
2515C...Fill in missing information on colour connection in jet systems.
2516 IF(ISTHEP(I).EQ.1) THEN
2517 KC=PYCOMP(K(I,2))
2518 KQ=0
2519 IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
2520 IF(KQ.NE.0) NKQ=NKQ+1
2521 IF(KQ.NE.2) KQSUM=KQSUM+KQ
2522 IF(KQ.NE.0.AND.KQSUM.NE.0) THEN
2523 K(I,1)=2
2524 ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN
2525 IF(K(I+1,2).EQ.21) K(I,1)=2
2526 ENDIF
2527 ENDIF
2528 190 CONTINUE
2529 IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL PYERRM(8,
2530 & '(PYHEPC:) input parton configuration not colour singlet')
2531 ENDIF
2532
2533 END
2534
2535C*********************************************************************
2536
2537C...PYINIT
2538C...Initializes the generation procedure; finds maxima of the
2539C...differential cross-sections to be used for weighting.
2540
2541 SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN)
2542
2543C...Double precision and integer declarations.
2544 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2545 IMPLICIT INTEGER(I-N)
2546 INTEGER PYK,PYCHGE,PYCOMP
2547C...Commonblocks.
2548 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2549 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2550 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2551 COMMON/PYDAT4/CHAF(500,2)
2552 CHARACTER CHAF*16
2553 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2554 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2555 COMMON/PYINT1/MINT(400),VINT(400)
2556 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2557 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2558 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
2559 &/PYINT1/,/PYINT2/,/PYINT5/
2560C...Local arrays and character variables.
2561 DIMENSION ALAMIN(20),NFIN(20)
2562 CHARACTER*(*) FRAME,BEAM,TARGET
2563 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHLH(2)*6
2564
2565C...Interface to PDFLIB.
81935ff8 2566 COMMON/LW50512/QCDL4,QCDL5
2567 SAVE /LW50512/
2dfa57d1 2568 DOUBLE PRECISION VALUE(20),QCDL4,QCDL5
2569 CHARACTER*20 PARM(20)
2570 DATA VALUE/20*0D0/,PARM/20*' '/
2571
2572C...Data:Lambda and n_f values for parton distributions..
2573 DATA ALAMIN/0.177D0,0.239D0,0.247D0,0.2322D0,0.248D0,0.248D0,
2574 &0.192D0,0.326D0,2*0.2D0,0.2D0,0.2D0,0.29D0,0.2D0,0.4D0,5*0.2D0/,
2575 &NFIN/20*4/
2576 DATA CHLH/'lepton','hadron'/
2577
2578C...Reset MINT and VINT arrays. Write headers.
2579 MSTI(53)=0
2580 DO 100 J=1,400
2581 MINT(J)=0
2582 VINT(J)=0D0
2583 100 CONTINUE
2584 IF(MSTU(12).GE.1) CALL PYLIST(0)
2585 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
2586
2587C...Call user process initialization routine.
2588 IF(FRAME(1:1).EQ.'u'.OR.FRAME(1:1).EQ.'U') THEN
2589 MSEL=0
2590 CALL UPINIT
2591 MSEL=0
2592 ENDIF
2593
2594C...Maximum 4 generations; set maximum number of allowed flavours.
2595 MSTP(1)=MIN(4,MSTP(1))
2596 MSTU(114)=MIN(MSTU(114),2*MSTP(1))
2597 MSTP(58)=MIN(MSTP(58),2*MSTP(1))
2598
2599C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
2600 DO 120 I=-20,20
2601 VINT(180+I)=0D0
2602 IA=IABS(I)
2603 IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN
2604 DO 110 J=1,MSTP(1)
2605 IB=2*J-1+MOD(IA,2)
2606 IF(IB.GE.6.AND.MSTP(9).EQ.0) GOTO 110
2607 IPM=(5-ISIGN(1,I))/2
2608 IDC=J+MDCY(IA,2)+2
2609 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)=
2610 & VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2)
2611 110 CONTINUE
2612 ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN
2613 VINT(180+I)=1D0
2614 ENDIF
2615 120 CONTINUE
2616
2617C...Initialize parton distributions: PDFLIB.
2618 IF(MSTP(52).EQ.2) THEN
2619 PARM(1)='NPTYPE'
2620 VALUE(1)=1
2621 PARM(2)='NGROUP'
2622 VALUE(2)=MSTP(51)/1000
2623 PARM(3)='NSET'
2624 VALUE(3)=MOD(MSTP(51),1000)
2625 PARM(4)='TMAS'
2626 VALUE(4)=PMAS(6,1)
2627 CALL PDFSET_ALICE(PARM,VALUE)
2628 MINT(93)=1000000+MSTP(51)
2629 ENDIF
2630
2631C...Choose Lambda value to use in alpha-strong.
2632 MSTU(111)=MSTP(2)
2633 IF(MSTP(3).GE.2) THEN
2634 ALAM=0.2D0
2635 NF=4
2636 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
2637 ALAM=ALAMIN(MSTP(51))
2638 NF=NFIN(MSTP(51))
2639 ELSEIF(MSTP(52).EQ.2) THEN
2640 ALAM=QCDL4
2641 NF=4
2642 ENDIF
2643 PARP(1)=ALAM
2644 PARP(61)=ALAM
2645 PARP(72)=ALAM
2646 PARU(112)=ALAM
2647 MSTU(112)=NF
2648 IF(MSTP(3).EQ.3) PARJ(81)=ALAM
2649 ENDIF
2650
2651C...Initialize the SUSY generation: couplings, masses,
2652C...decay modes, branching ratios, and so on.
2653 CALL PYMSIN
2654C...Initialize widths and partial widths for resonances.
2655 CALL PYINRE
2656C...Set Z0 mass and width for e+e- routines.
2657 PARJ(123)=PMAS(23,1)
2658 PARJ(124)=PMAS(23,2)
2659
2660C...Identify beam and target particles and frame of process.
2661 CHFRAM=FRAME//' '
2662 CHBEAM=BEAM//' '
2663 CHTARG=TARGET//' '
2664 CALL PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
2665 IF(MINT(65).EQ.1) GOTO 170
2666
2667C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
2668C...For e-gamma allow 2 alternatives.
2669 MINT(121)=1
2670 IF(MSTP(14).EQ.10.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2671 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2672 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
2673 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=6
2674 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2675 & (IABS(MINT(11)).EQ.11.OR.IABS(MINT(12)).EQ.11)) MINT(121)=2
2676 ELSEIF(MSTP(14).EQ.20.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2677 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2678 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
2679 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=9
2680 ELSEIF(MSTP(14).EQ.25.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2681 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2682 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=2
2683 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=4
2684 ELSEIF(MSTP(14).EQ.30.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2685 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2686 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=4
2687 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=13
2688 ENDIF
2689 MINT(123)=MSTP(14)
2690 IF((MSTP(14).EQ.10.OR.MSTP(14).EQ.20.OR.MSTP(14).EQ.25.OR.
2691 &MSTP(14).EQ.30).AND.MSEL.NE.1.AND.MSEL.NE.2) MINT(123)=0
2692 IF(MSTP(14).GE.11.AND.MSTP(14).LE.19) THEN
2693 IF(MSTP(14).EQ.11) MINT(123)=0
2694 IF(MSTP(14).EQ.12.OR.MSTP(14).EQ.14) MINT(123)=5
2695 IF(MSTP(14).EQ.13.OR.MSTP(14).EQ.17) MINT(123)=6
2696 IF(MSTP(14).EQ.15) MINT(123)=2
2697 IF(MSTP(14).EQ.16.OR.MSTP(14).EQ.18) MINT(123)=7
2698 IF(MSTP(14).EQ.19) MINT(123)=3
2699 ELSEIF(MSTP(14).GE.21.AND.MSTP(14).LE.24) THEN
2700 IF(MSTP(14).EQ.21) MINT(123)=0
2701 IF(MSTP(14).EQ.22.OR.MSTP(14).EQ.23) MINT(123)=4
2702 IF(MSTP(14).EQ.24) MINT(123)=1
2703 ELSEIF(MSTP(14).GE.26.AND.MSTP(14).LE.29) THEN
2704 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28) MINT(123)=8
2705 IF(MSTP(14).EQ.27.OR.MSTP(14).EQ.29) MINT(123)=9
2706 ENDIF
2707
2708C...Set up kinematics of process.
2709 CALL PYINKI(0)
2710
2711C...Set up kinematics for photons inside leptons.
2712 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(1,WTGAGA)
2713
2714C...Precalculate flavour selection weights.
2715 CALL PYKFIN
2716
2717C...Loop over gamma-p or gamma-gamma alternatives.
2718 CKIN3=CKIN(3)
2719 MSAV48=0
2720 DO 160 IGA=1,MINT(121)
2721 CKIN(3)=CKIN3
2722 MINT(122)=IGA
2723
2724C...Select partonic subprocesses to be included in the simulation.
2725 CALL PYINPR
2726 MINT(101)=1
2727 MINT(102)=1
2728 MINT(103)=MINT(11)
2729 MINT(104)=MINT(12)
2730
2731C...Count number of subprocesses on.
2732 MINT(48)=0
2733 DO 130 ISUB=1,500
2734 IF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
2735 & MSUB(ISUB).EQ.1.AND.MINT(121).GT.1) THEN
2736 MSUB(ISUB)=0
2737 ELSEIF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
2738 & MSUB(ISUB).EQ.1) THEN
2739 WRITE(MSTU(11),5200) ISUB,CHLH(MINT(41)),CHLH(MINT(42))
2740 STOP
2741 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
2742 WRITE(MSTU(11),5300) ISUB
2743 STOP
2744 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
2745 WRITE(MSTU(11),5400) ISUB
2746 STOP
2747 ELSEIF(MSUB(ISUB).EQ.1) THEN
2748 MINT(48)=MINT(48)+1
2749 ENDIF
2750 130 CONTINUE
2751
2752C...Stop or raise warning flag if no subprocesses on.
2753 IF(MINT(121).EQ.1.AND.MINT(48).EQ.0) THEN
2754 IF(MSTP(127).NE.1) THEN
2755 WRITE(MSTU(11),5500)
2756 STOP
2757 ELSE
2758 WRITE(MSTU(11),5700)
2759 MSTI(53)=1
2760 ENDIF
2761 ENDIF
2762 MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94)
2763 MSAV48=MSAV48+MINT(48)
2764
2765C...Reset variables for cross-section calculation.
2766 DO 150 I=0,500
2767 DO 140 J=1,3
2768 NGEN(I,J)=0
2769 XSEC(I,J)=0D0
2770 140 CONTINUE
2771 150 CONTINUE
2772
2773C...Find parametrized total cross-sections.
2774 CALL PYXTOT
2775 VINT(318)=VINT(317)
2776
2777C...Maxima of differential cross-sections.
2778 IF(MSTP(121).LE.1) CALL PYMAXI
2779
2780C...Initialize possibility of pileup events.
2781 IF(MINT(121).GT.1) MSTP(131)=0
2782 IF(MSTP(131).NE.0) CALL PYPILE(1)
2783
2784C...Initialize multiple interactions with variable impact parameter.
2785 IF(MINT(50).EQ.1) THEN
2786 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
2787 IF(MSTP(81).EQ.0.AND.CKIN(3).GT.PTMN) MSTP(82)=MIN(1,MSTP(82))
2788 IF((MINT(49).NE.0.OR.MSTP(131).NE.0).AND.MSTP(82).GE.2)
2789 & CALL PYMULT(1)
2790 ENDIF
2791
2792C...Save results for gamma-p and gamma-gamma alternatives.
2793 IF(MINT(121).GT.1) CALL PYSAVE(1,IGA)
2794 160 CONTINUE
2795
2796C...Initialization finished.
2797 IF(MSAV48.EQ.0) THEN
2798 IF(MSTP(127).NE.1) THEN
2799 WRITE(MSTU(11),5500)
2800 STOP
2801 ELSE
2802 WRITE(MSTU(11),5700)
2803 MSTI(53)=1
2804 ENDIF
2805 ENDIF
2806 170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600)
2807
2808C...Formats for initialization information.
2809 5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ',
2810 &'routines',1X,17('*'))
2811 5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,
2812 &'-',A6,' interactions.'/1X,'Execution stopped!')
2813 5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/
2814 &1X,'Execution stopped!')
2815 5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/
2816 &1X,'Execution stopped!')
2817 5500 FORMAT(1X,'Error: no subprocess switched on.'/
2818 &1X,'Execution stopped.')
2819 5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X,
2820 &22('*'))
2821 5700 FORMAT(1X,'Error: no subprocess switched on.'/
2822 &1X,'Execution will stop if you try to generate events.')
2823
2824 RETURN
2825 END
2826
2827C*********************************************************************
2828
2829C...PYEVNT
2830C...Administers the generation of a high-pT event via calls to
2831C...a number of subroutines.
2832
2833 SUBROUTINE PYEVNT
2834
2835C...Double precision and integer declarations.
2836 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2837 IMPLICIT INTEGER(I-N)
2838 INTEGER PYK,PYCHGE,PYCOMP
2839C...Commonblocks.
2840 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2841 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2842 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2843 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2844 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2845 COMMON/PYINT1/MINT(400),VINT(400)
2846 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2847 COMMON/PYINT4/MWID(500),WIDS(500,5)
2848 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2849 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,
2850 &/PYINT2/,/PYINT4/,/PYINT5/
2851C...Local array.
2852 DIMENSION VTX(4)
2853
2854C...Stop if no subprocesses on.
2855 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
2856 WRITE(MSTU(11),5100)
2857 STOP
2858 ENDIF
2dfa57d1 2859C...Initial values for some counters.
2860 N=0
2861 MINT(5)=MINT(5)+1
2862 MINT(7)=0
2863 MINT(8)=0
2864 MINT(83)=0
2865 MINT(84)=MSTP(126)
2866 MSTU(24)=0
2867 MSTU70=0
2868 MSTJ14=MSTJ(14)
2869
2870C...If variable energies: redo incoming kinematics and cross-section.
2871 MSTI(61)=0
2872 IF(MSTP(171).EQ.1) THEN
2873 CALL PYINKI(1)
2874 IF(MSTI(61).EQ.1) THEN
2875 MINT(5)=MINT(5)-1
2876 RETURN
2877 ENDIF
2878 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
2879 CALL PYXTOT
2880 ENDIF
2881
2882C...Loop over number of pileup events; check space left.
2883 IF(MSTP(131).LE.0) THEN
2884 NPILE=1
2885 ELSE
2886 CALL PYPILE(2)
2887 NPILE=MINT(81)
2888 ENDIF
2889 DO 250 IPILE=1,NPILE
2890 IF(MINT(84)+100.GE.MSTU(4)) THEN
2891 CALL PYERRM(11,
2892 & '(PYEVNT:) no more space in PYJETS for pileup events')
2893 IF(MSTU(21).GE.1) GOTO 260
2894 ENDIF
2895 MINT(82)=IPILE
2896
2897C...Generate variables of hard scattering.
2898 MINT(51)=0
2899 MSTI(52)=0
2900 100 CONTINUE
2901 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
2902 MINT(31)=0
2903 MINT(51)=0
2904 MINT(57)=0
2905 CALL PYRAND
2906 IF(MSTI(61).EQ.1) THEN
2907 MINT(5)=MINT(5)-1
2908 RETURN
2909 ENDIF
2910 IF(MINT(51).EQ.2) RETURN
2911 ISUB=MINT(1)
2912 IF(MSTP(111).EQ.-1) GOTO 240
2913
2914 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
2915C...Hard scattering (including low-pT):
2916C...reconstruct kinematics and colour flow of hard scattering.
2917 MINT31=MINT(31)
2918 110 MINT(31)=MINT31
2919 MINT(51)=0
2920 CALL PYSCAT
2921 IF(MINT(51).EQ.1) GOTO 100
2922 IPU1=MINT(84)+1
2923 IPU2=MINT(84)+2
2924 IF(ISUB.EQ.95) GOTO 120
2925
2926C...Showering of initial state partons (optional).
2927 NFIN=N
2928 ALAMSV=PARJ(81)
2929 PARJ(81)=PARP(72)
2930 IF(MSTP(61).GE.1.AND.MINT(47).GE.2) CALL PYSSPA(IPU1,IPU2)
2931 PARJ(81)=ALAMSV
2932 IF(MINT(51).EQ.1) GOTO 100
2933
2934C...Showering of final state partons (optional).
2935 ALAMSV=PARJ(81)
2936 PARJ(81)=PARP(72)
2937 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.2.AND.ISET(ISUB).LE.10)
2938 & THEN
2939 IPU3=MINT(84)+3
2940 IPU4=MINT(84)+4
2941 IF(ISET(ISUB).EQ.5) IPU4=-3
2942 QMAX=VINT(55)
2943 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
2944 CALL PYSHOW(IPU3,IPU4,QMAX)
2945 ELSEIF(ISET(ISUB).EQ.11) THEN
2946 CALL PYADSH(NFIN)
2947 ENDIF
2948 PARJ(81)=ALAMSV
2949
2950C...Decay of final state resonances.
2951 MINT(32)=0
2952 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) CALL PYRESD(0)
2953 IF(MINT(51).EQ.1) GOTO 100
2954 MINT(52)=N
2955
2956C...Multiple interactions.
2957 IF(MSTP(81).GE.1.AND.MINT(50).EQ.1) CALL PYMULT(6)
2958 MINT(53)=N
2959
2960C...Hadron remnants and primordial kT.
2961 120 CALL PYREMN(IPU1,IPU2)
2962 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO 110
2963 IF(MINT(51).EQ.1) GOTO 100
2964
2965 ELSEIF(ISUB.NE.99) THEN
2966C...Diffractive and elastic scattering.
2967 CALL PYDIFF
2968
2969 ELSE
2970C...DIS scattering (photon flux external).
2971 CALL PYDISG
2972 IF(MINT(51).EQ.1) GOTO 100
2973 ENDIF
2974
2975C...Check that no odd resonance left undecayed.
2976 IF(MSTP(111).GE.1) THEN
2977 NFIX=N
2978 DO 130 I=MINT(84)+1,NFIX
2979 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
2980 & K(I,2).NE.22) THEN
2981 KCA=PYCOMP(K(I,2))
2982 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
2983 CALL PYRESD(I)
2984 IF(MINT(51).EQ.1) GOTO 100
2985 ENDIF
2986 ENDIF
2987 130 CONTINUE
2988 ENDIF
2989
2990C...Boost hadronic subsystem to overall rest frame.
2991C..(Only relevant when photon inside lepton beam.)
2992 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
2993
2994C...Recalculate energies from momenta and masses (if desired).
2995 IF(MSTP(113).GE.1) THEN
2996 DO 140 I=MINT(83)+1,N
2997 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
2998 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
2999 140 CONTINUE
3000 NRECAL=N
3001 ENDIF
3002
3003C...Rearrange partons along strings, check invariant mass cuts.
3004 MSTU(28)=0
3005 IF(MSTP(111).LE.0) MSTJ(14)=-1
3006 CALL PYPREP(MINT(84)+1)
3007 MSTJ(14)=MSTJ14
3008 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
3009 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
3010 DO 170 I=MINT(84)+1,N
3011 IF(K(I,2).EQ.94) THEN
3012 DO 160 I1=I+1,MIN(N,I+10)
3013 IF(K(I1,3).EQ.I) THEN
3014 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
3015 IF(K(I1,3).EQ.0) THEN
3016 DO 150 II=MINT(84)+1,I-1
3017 IF(K(II,2).EQ.K(I1,2)) THEN
3018 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
3019 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
3020 ENDIF
3021 150 CONTINUE
3022 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
3023 ENDIF
3024 ENDIF
3025 160 CONTINUE
3026 ENDIF
3027 170 CONTINUE
3028 CALL PYEDIT(12)
3029 CALL PYEDIT(14)
3030 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
3031 IF(MSTP(125).EQ.0) MINT(4)=0
3032 DO 190 I=MINT(83)+1,N
3033 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
3034 DO 180 I1=I+1,N
3035 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
3036 IF(K(I1,3).EQ.I) K(I,5)=I1
3037 180 CONTINUE
3038 ENDIF
3039 190 CONTINUE
3040 ENDIF
3041
3042C...Introduce separators between sections in PYLIST event listing.
3043 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
3044 MSTU70=1
3045 MSTU(71)=N
3046 ELSEIF(IPILE.EQ.1) THEN
3047 MSTU70=3
3048 MSTU(71)=2
3049 MSTU(72)=MINT(4)
3050 MSTU(73)=N
3051 ENDIF
3052
3053C...Go back to lab frame (needed for vertices, also in fragmentation).
3054 CALL PYFRAM(1)
3055
3056C...Set nonvanishing production vertex (optional).
3057 IF(MSTP(151).EQ.1) THEN
3058 DO 200 J=1,4
3059 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
3060 & SIN(PARU(2)*PYR(0))
3061 200 CONTINUE
3062 DO 220 I=MINT(83)+1,N
3063 DO 210 J=1,4
3064 V(I,J)=V(I,J)+VTX(J)
3065 210 CONTINUE
3066 220 CONTINUE
3067 ENDIF
3068
3069C...Perform hadronization (if desired).
3070 IF(MSTP(111).GE.1) THEN
3071 CALL PYEXEC
3072 IF(MSTU(24).NE.0) GOTO 100
3073 ENDIF
3074 IF(MSTP(113).GE.1) THEN
3075 DO 230 I=NRECAL,N
3076 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3077 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3078 230 CONTINUE
3079 ENDIF
3080 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3081
3082C...Store event information and calculate Monte Carlo estimates of
3083C...subprocess cross-sections.
3084 240 IF(IPILE.EQ.1) CALL PYDOCU
3085
3086C...Set counters for current pileup event and loop to next one.
3087 MSTI(41)=IPILE
3088 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3089 IF(MSTU70.LT.10) THEN
3090 MSTU70=MSTU70+1
3091 MSTU(70+MSTU70)=N
3092 ENDIF
3093 MINT(83)=N
3094 MINT(84)=N+MSTP(126)
3095 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
3096 250 CONTINUE
3097
3098C...Generic information on pileup events. Reconstruct missing history.
3099 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
3100 PARI(91)=VINT(132)
3101 PARI(92)=VINT(133)
3102 PARI(93)=VINT(134)
3103 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
3104 ENDIF
3105 CALL PYEDIT(16)
3106
3107C...Transform to the desired coordinate frame.
3108 260 CALL PYFRAM(MSTP(124))
3109 MSTU(70)=MSTU70
3110 PARU(21)=VINT(1)
3111
3112C...Error messages
3113 5100 FORMAT(1X,'Error: no subprocess switched on.'/
3114 &1X,'Execution stopped.')
3115
3116 RETURN
3117 END
3118
3119C***********************************************************************
3120
3121C...PYSTAT
3122C...Prints out information about cross-sections, decay widths, branching
3123C...ratios, kinematical limits, status codes and parameter values.
3124
3125 SUBROUTINE PYSTAT(MSTAT)
3126
3127C...Double precision and integer declarations.
3128 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3129 IMPLICIT INTEGER(I-N)
3130 INTEGER PYK,PYCHGE,PYCOMP
3131C...Parameter statement to help give large particle numbers.
3132 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
3133 &KEXCIT=4000000,KDIMEN=5000000)
3134 PARAMETER (EPS=1D-3)
3135C...Commonblocks.
3136 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3137 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3138 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3139 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3140 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3141 COMMON/PYINT1/MINT(400),VINT(400)
3142 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3143 COMMON/PYINT4/MWID(500),WIDS(500,5)
3144 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3145 COMMON/PYINT6/PROC(0:500)
3146 CHARACTER PROC*28, CHTMP*16
3147 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
3148 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
3149 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
3150 &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/,/PYMSRV/
3151C...Local arrays, character variables and data.
3152 DIMENSION WDTP(0:400),WDTE(0:400,0:5),NMODES(0:20),PBRAT(10)
3153 CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16,
3154 &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28,
3155 &PROGG9(13)*28,PROGG4(4)*28,PROGG2(2)*28,PROGP4(4)*28
3156 CHARACTER*24 CHD0, CHDC(10)
3157 CHARACTER*6 DNAME(3)
3158 DATA PROGA/
3159 &'VMD/hadron * VMD ','VMD/hadron * direct ',
3160 &'VMD/hadron * anomalous ','direct * direct ',
3161 &'direct * anomalous ','anomalous * anomalous '/
3162 DATA DISGA/'e * VMD','e * anomalous'/
3163 DATA PROGG9/
3164 &'direct * direct ','direct * VMD ',
3165 &'direct * anomalous ','VMD * direct ',
3166 &'VMD * VMD ','VMD * anomalous ',
3167 &'anomalous * direct ','anomalous * VMD ',
3168 &'anomalous * anomalous ','DIS * VMD ',
3169 &'DIS * anomalous ','VMD * DIS ',
3170 &'anomalous * DIS '/
3171 DATA PROGG4/
3172 &'direct * direct ','direct * resolved ',
3173 &'resolved * direct ','resolved * resolved '/
3174 DATA PROGG2/
3175 &'direct * hadron ','resolved * hadron '/
3176 DATA PROGP4/
3177 &'VMD * hadron ','direct * hadron ',
3178 &'anomalous * hadron ','DIS * hadron '/
3179 DATA STATE/'----','off ','on ','on/+','on/-','on/1','on/2'/,
3180 &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
3181 &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ',
3182 &' y*_small ',' eta*_large ',' eta*_small ',
3183 &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ',
3184 &' x_2 ',' x_F ',' cos(theta_hard) ',
3185 &'m''_hard (GeV/c^2) ',' tau ',' y* ',
3186 &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ',
3187 &' tau'' '/
3188 DATA DNAME /'q ','lepton','nu '/
3189
3190C...Cross-sections.
3191 IF(MSTAT.LE.1) THEN
3192 IF(MINT(121).GT.1) CALL PYSAVE(5,0)
3193 WRITE(MSTU(11),5000)
3194 WRITE(MSTU(11),5100)
3195 WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)
3196 DO 100 I=1,500
3197 IF(MSUB(I).NE.1) GOTO 100
3198 WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)
3199 100 CONTINUE
3200 IF(MINT(121).GT.1) THEN
3201 WRITE(MSTU(11),5300)
3202 DO 110 IGA=1,MINT(121)
3203 CALL PYSAVE(3,IGA)
3204 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
3205 WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1),
3206 & XSEC(0,3)
3207 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
3208 WRITE(MSTU(11),5200) IGA,PROGG9(IGA),NGEN(0,3),NGEN(0,1),
3209 & XSEC(0,3)
3210 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.30) THEN
3211 WRITE(MSTU(11),5200) IGA,PROGP4(IGA),NGEN(0,3),NGEN(0,1),
3212 & XSEC(0,3)
3213 ELSEIF(MINT(121).EQ.4) THEN
3214 WRITE(MSTU(11),5200) IGA,PROGG4(IGA),NGEN(0,3),NGEN(0,1),
3215 & XSEC(0,3)
3216 ELSEIF(MINT(121).EQ.2) THEN
3217 WRITE(MSTU(11),5200) IGA,PROGG2(IGA),NGEN(0,3),NGEN(0,1),
3218 & XSEC(0,3)
3219 ELSE
3220 WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1),
3221 & XSEC(0,3)
3222 ENDIF
3223 110 CONTINUE
3224 CALL PYSAVE(5,0)
3225 ENDIF
3226 WRITE(MSTU(11),5400) 1D0-DBLE(NGEN(0,3))/
3227 & MAX(1D0,DBLE(NGEN(0,2)))
3228
3229C...Decay widths and branching ratios.
3230 ELSEIF(MSTAT.EQ.2) THEN
3231 WRITE(MSTU(11),5500)
3232 WRITE(MSTU(11),5600)
3233 DO 140 KC=1,500
3234 KF=KCHG(KC,4)
3235 CALL PYNAME(KF,CHKF)
3236 IOFF=0
3237 IF(KC.LE.22) THEN
3238 IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140
3239 IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140
3240 IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1
3241 IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1
3242 IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1
3243 ELSE
3244 IF(MWID(KC).LE.0) GOTO 140
3245 IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR.
3246 & KF/KSUSY1.EQ.2)) GOTO 140
3247 ENDIF
3248C...Off-shell branchings.
3249 IF(IOFF.EQ.1) THEN
3250 NGP=0
3251 IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2
3252 IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10),
3253 & PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0
3254 DO 120 J=1,MDCY(KC,3)
3255 IDC=J+MDCY(KC,2)-1
3256 NGP1=0
3257 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
3258 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
3259 NGP2=0
3260 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
3261 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
3262 CALL PYNAME(KFDP(IDC,1),CHD1)
3263 CALL PYNAME(KFDP(IDC,2),CHD2)
3264 IF(KFDP(IDC,3).EQ.0) THEN
3265 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
3266 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10),
3267 & CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
3268 ELSE
3269 CALL PYNAME(KFDP(IDC,3),CHD3)
3270 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
3271 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10),
3272 & CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
3273 ENDIF
3274 120 CONTINUE
3275C...On-shell decays.
3276 ELSE
3277 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
3278 BRFIN=1D0
3279 IF(WDTE(0,0).LE.0D0) BRFIN=0D0
3280 WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0,
3281 & STATE(MDCY(KC,1)),BRFIN
3282 DO 130 J=1,MDCY(KC,3)
3283 IDC=J+MDCY(KC,2)-1
3284 NGP1=0
3285 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
3286 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
3287 NGP2=0
3288 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
3289 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
3290 BRFIN=0D0
3291 IF(WDTE(0,0).GT.0D0) BRFIN=WDTE(J,0)/WDTE(0,0)
3292 CALL PYNAME(KFDP(IDC,1),CHD1)
3293 CALL PYNAME(KFDP(IDC,2),CHD2)
3294 IF(KFDP(IDC,3).EQ.0) THEN
3295 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
3296 & WRITE(MSTU(11),5800) IDC,CHD1(1:10),
3297 & CHD2(1:10),WDTP(J),WDTP(J)/WDTP(0),
3298 & STATE(MDME(IDC,1)),BRFIN
3299 ELSE
3300 CALL PYNAME(KFDP(IDC,3),CHD3)
3301 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
3302 & WRITE(MSTU(11),5900) IDC,CHD1(1:10),
3303 & CHD2(1:10),CHD3(1:10),WDTP(J),WDTP(J)/WDTP(0),
3304 & STATE(MDME(IDC,1)),BRFIN
3305 ENDIF
3306 130 CONTINUE
3307 ENDIF
3308 140 CONTINUE
3309 WRITE(MSTU(11),6000)
3310
3311C...Allowed incoming partons/particles at hard interaction.
3312 ELSEIF(MSTAT.EQ.3) THEN
3313 WRITE(MSTU(11),6100)
3314 CALL PYNAME(MINT(11),CHAU)
3315 CHIN(1)=CHAU(1:12)
3316 CALL PYNAME(MINT(12),CHAU)
3317 CHIN(2)=CHAU(1:12)
3318 WRITE(MSTU(11),6200) CHIN(1),CHIN(2)
3319 DO 150 I=-20,22
3320 IF(I.EQ.0) GOTO 150
3321 IA=IABS(I)
3322 IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150
3323 IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150
3324 CALL PYNAME(I,CHAU)
3325 WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU,
3326 & STATE(KFIN(2,I))
3327 150 CONTINUE
3328 WRITE(MSTU(11),6400)
3329
3330C...User-defined limits on kinematical variables.
3331 ELSEIF(MSTAT.EQ.4) THEN
3332 WRITE(MSTU(11),6500)
3333 WRITE(MSTU(11),6600)
3334 SHRMAX=CKIN(2)
3335 IF(SHRMAX.LT.0D0) SHRMAX=VINT(1)
3336 WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX
3337 PTHMIN=MAX(CKIN(3),CKIN(5))
3338 PTHMAX=CKIN(4)
3339 IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX
3340 WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX
3341 WRITE(MSTU(11),6900) CHKIN(3),CKIN(6)
3342 DO 160 I=4,14
3343 WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I)
3344 160 CONTINUE
3345 SPRMAX=CKIN(32)
3346 IF(SPRMAX.LT.0D0) SPRMAX=VINT(1)
3347 WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX
3348 WRITE(MSTU(11),7000)
3349
3350C...Status codes and parameter values.
3351 ELSEIF(MSTAT.EQ.5) THEN
3352 WRITE(MSTU(11),7100)
3353 WRITE(MSTU(11),7200)
3354 DO 170 I=1,100
3355 WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
3356 & PARP(100+I)
3357 170 CONTINUE
3358
3359C...List of all processes implemented in the program.
3360 ELSEIF(MSTAT.EQ.6) THEN
3361 WRITE(MSTU(11),7400)
3362 WRITE(MSTU(11),7500)
3363 DO 180 I=1,500
3364 IF(ISET(I).LT.0) GOTO 180
3365 WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2)
3366 180 CONTINUE
3367 WRITE(MSTU(11),7700)
3368
3369 ELSEIF(MSTAT.EQ.7) THEN
3370 WRITE (MSTU(11),8000)
3371 NMODES(0)=0
3372 NMODES(10)=0
3373 NMODES(9)=0
3374 DO 290 ILR=1,2
3375 DO 280 KFSM=1,16
3376 KFSUSY=ILR*KSUSY1+KFSM
3377 NRVDC=0
3378C...SDOWN DECAYS
3379 IF (KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5) THEN
3380 NRVDC=3
3381 DO 190 I=1,NRVDC
3382 PBRAT(I)=0D0
3383 NMODES(I)=0
3384 190 CONTINUE
3385 CALL PYNAME(KFSUSY,CHTMP)
3386 CHD0=CHTMP//' '
3387 CHDC(1)=DNAME(3) // ' + ' // DNAME(1)
3388 CHDC(2)=DNAME(2) // ' + ' // DNAME(1)
3389 CHDC(3)=DNAME(1) // ' + ' // DNAME(1)
3390 KC=PYCOMP(KFSUSY)
3391 DO 200 J=1,MDCY(KC,3)
3392 IDC=J+MDCY(KC,2)-1
3393 ID1=IABS(KFDP(IDC,1))
3394 ID2=IABS(KFDP(IDC,2))
3395 IF (KFDP(IDC,3).EQ.0) THEN
3396 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
3397 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
3398 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3399 NMODES(1)=NMODES(1)+1
3400 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3401 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3402 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3403 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6)) THEN
3404 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3405 NMODES(2)=NMODES(2)+1
3406 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3407 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3408 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
3409 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
3410 PBRAT(3)=PBRAT(3)+BRAT(IDC)
3411 NMODES(3)=NMODES(3)+1
3412 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3413 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3414 ENDIF
3415 ENDIF
3416 200 CONTINUE
3417 ENDIF
3418C...SUP DECAYS
3419 IF (KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6) THEN
3420 NRVDC=2
3421 DO 210 I=1,NRVDC
3422 NMODES(I)=0
3423 PBRAT(I)=0D0
3424 210 CONTINUE
3425 CALL PYNAME(KFSUSY,CHTMP)
3426 CHD0=CHTMP//' '
3427 CHDC(1)=DNAME(2) // ' + ' // DNAME(1)
3428 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
3429 KC=PYCOMP(KFSUSY)
3430 DO 220 J=1,MDCY(KC,3)
3431 IDC=J+MDCY(KC,2)-1
3432 ID1=IABS(KFDP(IDC,1))
3433 ID2=IABS(KFDP(IDC,2))
3434 IF (KFDP(IDC,3).EQ.0) THEN
3435 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
3436 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
3437 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3438 NMODES(1)=NMODES(1)+1
3439 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3440 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3441 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
3442 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
3443 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3444 NMODES(2)=NMODES(2)+1
3445 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3446 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3447 ENDIF
3448 ENDIF
3449 220 CONTINUE
3450 ENDIF
3451C...SLEPTON DECAYS
3452 IF (KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15) THEN
3453 NRVDC=2
3454 DO 230 I=1,NRVDC
3455 PBRAT(I)=0D0
3456 NMODES(I)=0
3457 230 CONTINUE
3458 CALL PYNAME(KFSUSY,CHTMP)
3459 CHD0=CHTMP//' '
3460 CHDC(1)=DNAME(3) // ' + ' // DNAME(2)
3461 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
3462 KC=PYCOMP(KFSUSY)
3463 DO 240 J=1,MDCY(KC,3)
3464 IDC=J+MDCY(KC,2)-1
3465 ID1=IABS(KFDP(IDC,1))
3466 ID2=IABS(KFDP(IDC,2))
3467 IF (KFDP(IDC,3).EQ.0) THEN
3468 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
3469 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
3470 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3471 NMODES(1)=NMODES(1)+1
3472 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3473 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3474 ENDIF
3475 IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND.(ID2
3476 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
3477 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3478 NMODES(2)=NMODES(2)+1
3479 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3480 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3481 ENDIF
3482 ENDIF
3483 240 CONTINUE
3484 ENDIF
3485C...SNEUTRINO DECAYS
3486 IF ((KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16).AND.ILR.EQ.1)
3487 & THEN
3488 NRVDC=2
3489 DO 250 I=1,NRVDC
3490 PBRAT(I)=0D0
3491 NMODES(I)=0
3492 250 CONTINUE
3493 CALL PYNAME(KFSUSY,CHTMP)
3494 CHD0=CHTMP//' '
3495 CHDC(1)=DNAME(2) // ' + ' // DNAME(2)
3496 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
3497 KC=PYCOMP(KFSUSY)
3498 DO 260 J=1,MDCY(KC,3)
3499 IDC=J+MDCY(KC,2)-1
3500 ID1=IABS(KFDP(IDC,1))
3501 ID2=IABS(KFDP(IDC,2))
3502 IF (KFDP(IDC,3).EQ.0) THEN
3503 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
3504 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
3505 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3506 NMODES(1)=NMODES(1)+1
3507 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3508 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3509 ENDIF
3510 IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
3511 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
3512 NMODES(2)=NMODES(2)+1
3513 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3514 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3515 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3516 ENDIF
3517 ENDIF
3518 260 CONTINUE
3519 ENDIF
3520 IF (NRVDC.NE.0) THEN
3521 DO 270 I=1,NRVDC
3522 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
3523 NMODES(0)=NMODES(0)+NMODES(I)
3524 270 CONTINUE
3525 ENDIF
3526 280 CONTINUE
3527 290 CONTINUE
3528 DO 370 KFSM=21,37
3529 KFSUSY=KSUSY1+KFSM
3530 NRVDC=0
3531C...NEUTRALINO DECAYS
3532 IF (KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
3533 NRVDC=4
3534 DO 300 I=1,NRVDC
3535 PBRAT(I)=0D0
3536 NMODES(I)=0
3537 300 CONTINUE
3538 CALL PYNAME(KFSUSY,CHTMP)
3539 CHD0=CHTMP//' '
3540 CHDC(1)=DNAME(3) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
3541 CHDC(2)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3542 CHDC(3)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3543 CHDC(4)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3544 KC=PYCOMP(KFSUSY)
3545 DO 310 J=1,MDCY(KC,3)
3546 IDC=J+MDCY(KC,2)-1
3547 ID1=IABS(KFDP(IDC,1))
3548 ID2=IABS(KFDP(IDC,2))
3549 ID3=IABS(KFDP(IDC,3))
3550 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
3551 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.11.OR
3552 & .ID3.EQ.13.OR.ID3.EQ.15)) THEN
3553 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3554 NMODES(1)=NMODES(1)+1
3555 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3556 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3557 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
3558 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
3559 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3560 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3561 NMODES(2)=NMODES(2)+1
3562 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3563 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3564 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3565 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
3566 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3567 PBRAT(3)=PBRAT(3)+BRAT(IDC)
3568 NMODES(3)=NMODES(3)+1
3569 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3570 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3571 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
3572 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
3573 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3574 PBRAT(4)=PBRAT(4)+BRAT(IDC)
3575 NMODES(4)=NMODES(4)+1
3576 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3577 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3578 ENDIF
3579 310 CONTINUE
3580 ENDIF
3581C...CHARGINO DECAYS
3582 IF (KFSM.EQ.24.OR.KFSM.EQ.37) THEN
3583 NRVDC=5
3584 DO 320 I=1,NRVDC
3585 PBRAT(I)=0D0
3586 NMODES(I)=0
3587 320 CONTINUE
3588 CALL PYNAME(KFSUSY,CHTMP)
3589 CHD0=CHTMP//' '
3590 CHDC(1)=DNAME(3) // ' + ' // DNAME(3) // ' + ' // DNAME(2)
3591 CHDC(2)=DNAME(2) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
3592 CHDC(3)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3593 CHDC(4)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3594 CHDC(5)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3595 KC=PYCOMP(KFSUSY)
3596 DO 330 J=1,MDCY(KC,3)
3597 IDC=J+MDCY(KC,2)-1
3598 ID1=IABS(KFDP(IDC,1))
3599 ID2=IABS(KFDP(IDC,2))
3600 ID3=IABS(KFDP(IDC,3))
3601 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
3602 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.12.OR
3603 & .ID3.EQ.14.OR.ID3.EQ.16)) THEN
3604 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3605 NMODES(1)=NMODES(1)+1
3606 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3607 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3608 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
3609 & .(ID2.EQ.12.OR.ID2.EQ.14.OR.ID2.EQ.16).AND.(ID3.EQ
3610 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
3611 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3612 NMODES(1)=NMODES(1)+1
3613 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3614 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3615 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3616 & .(ID2.EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ
3617 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
3618 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3619 NMODES(2)=NMODES(2)+1
3620 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3621 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3622 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
3623 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
3624 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
3625 PBRAT(3)=PBRAT(3)+BRAT(IDC)
3626 NMODES(3)=NMODES(3)+1
3627 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3628 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3629 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
3630 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
3631 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3632 PBRAT(3)=PBRAT(3)+BRAT(IDC)
3633 NMODES(3)=NMODES(3)+1
3634 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3635 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3636 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3637 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
3638 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
3639 PBRAT(4)=PBRAT(4)+BRAT(IDC)
3640 NMODES(4)=NMODES(4)+1
3641 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3642 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3643 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3644 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
3645 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3646 PBRAT(4)=PBRAT(4)+BRAT(IDC)
3647 NMODES(4)=NMODES(4)+1
3648 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3649 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3650 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
3651 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
3652 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3653 PBRAT(5)=PBRAT(5)+BRAT(IDC)
3654 NMODES(5)=NMODES(5)+1
3655 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3656 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3657 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND
3658 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
3659 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3660 PBRAT(5)=PBRAT(5)+BRAT(IDC)
3661 NMODES(5)=NMODES(5)+1
3662 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3663 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3664 ENDIF
3665 330 CONTINUE
3666 ENDIF
3667C...GLUINO DECAYS
3668 IF (KFSM.EQ.21) THEN
3669 NRVDC=3
3670 DO 340 I=1,NRVDC
3671 PBRAT(I)=0D0
3672 NMODES(I)=0
3673 340 CONTINUE
3674 CALL PYNAME(KFSUSY,CHTMP)
3675 CHD0=CHTMP//' '
3676 CHDC(1)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3677 CHDC(2)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3678 CHDC(3)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3679 KC=PYCOMP(KFSUSY)
3680 DO 350 J=1,MDCY(KC,3)
3681 IDC=J+MDCY(KC,2)-1
3682 ID1=IABS(KFDP(IDC,1))
3683 ID2=IABS(KFDP(IDC,2))
3684 ID3=IABS(KFDP(IDC,3))
3685 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
3686 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1.OR
3687 & .ID3.EQ.3.OR.ID3.EQ.5)) THEN
3688 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3689 NMODES(1)=NMODES(1)+1
3690 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3691 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3692 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3693 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
3694 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3695 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3696 NMODES(2)=NMODES(2)+1
3697 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3698 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3699 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
3700 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
3701 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3702 PBRAT(3)=PBRAT(3)+BRAT(IDC)
3703 NMODES(3)=NMODES(3)+1
3704 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3705 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3706 ENDIF
3707 350 CONTINUE
3708 ENDIF
3709
3710 IF (NRVDC.NE.0) THEN
3711 DO 360 I=1,NRVDC
3712 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
3713 NMODES(0)=NMODES(0)+NMODES(I)
3714 360 CONTINUE
3715 ENDIF
3716 370 CONTINUE
3717 WRITE (MSTU(11),8100) NMODES(0), NMODES(10), NMODES(9)
3718
3719 IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
3720 WRITE (MSTU(11),8500)
3721 DO 400 IRV=1,3
3722 DO 390 JRV=1,3
3723 DO 380 KRV=1,3
3724 WRITE (MSTU(11),8700) IRV,JRV,KRV,RVLAM(IRV,JRV,KRV)
3725 & ,RVLAMP(IRV,JRV,KRV),RVLAMB(IRV,JRV,KRV)
3726 380 CONTINUE
3727 390 CONTINUE
3728 400 CONTINUE
3729 WRITE (MSTU(11),8600)
3730 ENDIF
3731 ENDIF
3732
3733C...Formats for printouts.
3734 5000 FORMAT('1',9('*'),1X,'PYSTAT: Statistics on Number of ',
3735 &'Events and Cross-sections',1X,9('*'))
3736 5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
3737 &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
3738 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
3739 &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
3740 &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
3741 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
3742 &'I',12X,'I')
3743 5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
3744 &D10.3,1X,'I')
3745 5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/
3746 &1X,'I',34X,'I',28X,'I',12X,'I')
3747 5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
3748 &1X,'********* Fraction of events that fail fragmentation ',
3749 &'cuts =',1X,F8.5,' *********'/)
3750 5500 FORMAT('1',27('*'),1X,'PYSTAT: Decay Widths and Branching ',
3751 &'Ratios',1X,27('*'))
3752 5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
3753 &1X,'I',5X,'Mother --> Branching/Decay Channel',8X,'I',1X,
3754 &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,
3755 &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
3756 &1X,98('='))
3757 5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
3758 &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X,
3759 &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I')
3760 5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X,
3761 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
3762 &1P,D10.3,0P,1X,'I')
3763 5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X,
3764 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
3765 &1P,D10.3,0P,1X,'I')
3766 6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('='))
3767 6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
3768 &'Particles at Hard Interaction',1X,7('*'))
3769 6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
3770 &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X,
3771 &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X,
3772 &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X,
3773 &78('=')/1X,'I',38X,'I',37X,'I')
3774 6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I')
3775 6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
3776 6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
3777 &'Kinematical Variables',1X,12('*'))
3778 6600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
3779 6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P,
3780 &16X,'I')
3781 6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A,
3782 &1X,'<',1X,1P,D10.3,0P,16X,'I')
3783 6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I')
3784 7000 FORMAT(1X,'I',76X,'I'/1X,78('='))
3785 7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
3786 &'Parameter Values',1X,12('*'))
3787 7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
3788 &'PARP(I)'/)
3789 7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3)
3790 7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes',
3791 &1X,13('*'))
3792 7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X,
3793 &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X,
3794 &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I')
3795 7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I')
3796 7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('='))
3797 8000 FORMAT(1X/ 1X/
3798 & 17X,'Sums over R-Violating branching ratios',1X/ 1X
3799 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I'/1X,'I',4X
3800 & ,'Mother --> Sum over final state flavours',4X,'I',2X
3801 & ,'BR(sum)',2X,'I',2X,'N',2X,'I'/1X,'I',50X,'I',11X,'I',5X,'I'
3802 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I')
3803 8100 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I'/1X,70('=')/1X,'I',1X
3804 & ,'Total number of R-Violating modes :',3X,I5,24X,'I'/
3805 & 1X,'I',1X,'Total number with non-vanishing BR :',2X,I5,24X
3806 & ,'I'/1X,'I',1X,'Total number with BR > 0.001 :',8X,I5,24X,'I'
3807 & /1X,70('='))
3808 8200 FORMAT(1X,'I',1X,A9,1X,'-->',1X,A24,11X,
3809 & 'I',2X,1P,D8.2,0P,1X,'I',2X,I2,1X,'I')
3810 8300 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I')
3811 8500 FORMAT(1X/ 1X/
3812 & 1X,'R-Violating couplings',1X/ 1X /
3813 & 1X,55('=')/
3814 & 1X,'I',1X,'IJK',1X,'I',2X,'LAMBDA(IJK)',2X,'I',2X
3815 & ,'LAMBDA''(IJK)',1X,'I',1X,"LAMBDA''(IJK)",1X,'I'/1X,'I',5X
3816 & ,'I',15X,'I',15X,'I',15X,'I')
3817 8600 FORMAT(1X,55('='))
3818 8700 FORMAT(1X,'I',1X,I1,I1,I1,1X,'I',1X,1P,D13.3,0P,1X,'I',1X,1P
3819 & ,D13.3,0P,1X,'I',1X,1P,D13.3,0P,1X,'I')
3820
3821 RETURN
3822 END
3823
3824C*********************************************************************
3825
3826C...PYINRE
3827C...Calculates full and effective widths of gauge bosons, stores
3828C...masses and widths, rescales coefficients to be used for
3829C...resonance production generation.
3830
3831 SUBROUTINE PYINRE
3832
3833C...Double precision and integer declarations.
3834 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3835 IMPLICIT INTEGER(I-N)
3836 INTEGER PYK,PYCHGE,PYCOMP
3837C...Parameter statement to help give large particle numbers.
3838 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
3839 &KEXCIT=4000000,KDIMEN=5000000)
3840C...Commonblocks.
3841 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3842 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3843 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3844 COMMON/PYDAT4/CHAF(500,2)
3845 CHARACTER CHAF*16
3846 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3847 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3848 COMMON/PYINT1/MINT(400),VINT(400)
3849 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3850 COMMON/PYINT4/MWID(500),WIDS(500,5)
3851 COMMON/PYINT6/PROC(0:500)
3852 CHARACTER PROC*28
3853 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
3854 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
3855 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/
3856C...Local arrays and data.
3857 DIMENSION WDTP(0:400),WDTE(0:400,0:5),WDTPM(0:400),
3858 &WDTEM(0:400,0:5),KCORD(500),PMORD(500)
3859
3860C...Born level couplings in MSSM Higgs doublet sector.
3861 XW=PARU(102)
3862 XWV=XW
3863 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
3864 XW1=1D0-XW
3865 IF(MSTP(4).EQ.2) THEN
3866 TANBE=PARU(141)
3867 RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2
3868 SQMZ=PMAS(23,1)**2
3869 SQMW=PMAS(24,1)**2
3870 SQMH=PMAS(25,1)**2
3871 SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH)
3872 SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE))
3873 SQMHC=SQMA+SQMW
3874 IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN
3875 WRITE(MSTU(11),5000)
3876 STOP
3877 ENDIF
3878 PMAS(35,1)=SQRT(SQMHP)
3879 PMAS(36,1)=SQRT(SQMA)
3880 PMAS(37,1)=SQRT(SQMHC)
3881 ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)*
3882 & (SQMA-SQMZ)))
3883 BESU=ATAN(TANBE)
3884 PARU(142)=1D0
3885 PARU(143)=1D0
3886 PARU(161)=-SIN(ALSU)/COS(BESU)
3887 PARU(162)=COS(ALSU)/SIN(BESU)
3888 PARU(163)=PARU(161)
3889 PARU(164)=SIN(BESU-ALSU)
3890 PARU(165)=PARU(164)
3891 PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW
3892 PARU(171)=COS(ALSU)/COS(BESU)
3893 PARU(172)=SIN(ALSU)/SIN(BESU)
3894 PARU(173)=PARU(171)
3895 PARU(174)=COS(BESU-ALSU)
3896 PARU(175)=PARU(174)
3897 PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)*
3898 & SIN(BESU+ALSU)
3899 PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU)
3900 PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW
3901 PARU(181)=TANBE
3902 PARU(182)=1D0/TANBE
3903 PARU(183)=PARU(181)
3904 PARU(184)=0D0
3905 PARU(185)=PARU(184)
3906 PARU(186)=COS(BESU-ALSU)
3907 PARU(187)=SIN(BESU-ALSU)
3908 PARU(188)=PARU(186)
3909 PARU(189)=PARU(187)
3910 PARU(190)=0D0
3911 PARU(195)=COS(BESU-ALSU)
3912 ENDIF
3913
3914C...Reset effective widths of gauge bosons.
3915 DO 110 I=1,500
3916 DO 100 J=1,5
3917 WIDS(I,J)=1D0
3918 100 CONTINUE
3919 110 CONTINUE
3920
3921C...Order resonances by increasing mass (except Z0 and W+/-).
3922 NRES=0
3923 DO 140 KC=1,500
3924 KF=KCHG(KC,4)
3925 IF(KF.EQ.0) GOTO 140
3926 IF(MWID(KC).EQ.0) GOTO 140
3927 IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN
3928 IF(MSTP(1).LE.3) GOTO 140
3929 ENDIF
3930 IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN
3931 IF(IMSS(1).LE.0) GOTO 140
3932 ENDIF
3933 NRES=NRES+1
3934 PMRES=PMAS(KC,1)
3935 IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0
3936 DO 120 I1=NRES-1,1,-1
3937 IF(PMRES.GE.PMORD(I1)) GOTO 130
3938 KCORD(I1+1)=KCORD(I1)
3939 PMORD(I1+1)=PMORD(I1)
3940 120 CONTINUE
3941 130 KCORD(I1+1)=KC
3942 PMORD(I1+1)=PMRES
3943 140 CONTINUE
3944
3945C...Loop over possible resonances.
3946 DO 180 I=1,NRES
3947 KC=KCORD(I)
3948 KF=KCHG(KC,4)
3949
3950C...Check that no fourth generation channels on by mistake.
3951 IF(MSTP(1).LE.3) THEN
3952 DO 150 J=1,MDCY(KC,3)
3953 IDC=J+MDCY(KC,2)-1
3954 KFA1=IABS(KFDP(IDC,1))
3955 KFA2=IABS(KFDP(IDC,2))
3956 IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR.
3957 & KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18)
3958 & MDME(IDC,1)=-1
3959 150 CONTINUE
3960 ENDIF
3961
3962C...Check that no supersymmetric channels on by mistake.
3963 IF(IMSS(1).LE.0) THEN
3964 DO 160 J=1,MDCY(KC,3)
3965 IDC=J+MDCY(KC,2)-1
3966 KFA1S=IABS(KFDP(IDC,1))/KSUSY1
3967 KFA2S=IABS(KFDP(IDC,2))/KSUSY1
3968 IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2)
3969 & MDME(IDC,1)=-1
3970 160 CONTINUE
3971 ENDIF
3972
3973C...Find mass and evaluate width.
3974 PMR=PMAS(KC,1)
3975 IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1
3976 IF(MWID(KC).EQ.3) MINT(63)=1
3977 CALL PYWIDT(KF,PMR**2,WDTP,WDTE)
3978 MINT(51)=0
3979
3980C...Evaluate suppression factors due to non-simulated channels.
ced15360 3981C...AM
3982C...Protection against division by 0 since rho_21_tc is causing problem here
3983 IF (WDTP(0) .GT. 0.) THEN
3984
3985 IF(KCHG(KC,3).EQ.0) THEN
3986 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+
3987 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
3988 & 2D0*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
3989 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
3990 WIDS(KC,3)=0D0
3991 WIDS(KC,4)=0D0
3992 WIDS(KC,5)=0D0
3993 ELSE
3994 IF(MWID(KC).EQ.3) MINT(63)=1
3995 CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM)
3996 MINT(51)=0
3997 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+
3998 & (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+
3999 & (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+
4000 & WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))/WDTP(0)**2
4001 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
4002 WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))/WDTP(0)
4003 WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+
4004 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
4005 & 2D0*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
4006 WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+
4007 & 2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+
4008 & 2D0*WDTEM(0,4)*WDTEM(0,5))/WDTP(0)**2
4009 ENDIF
4010
2dfa57d1 4011 ENDIF
2dfa57d1 4012C...Set resonance widths and branching ratios;
4013C...also on/off switch for decays.
4014 IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN
4015 PMAS(KC,2)=WDTP(0)
4016 PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2))
4017 IF(MSTP(41).EQ.0.OR.MSTP(41).EQ.1) MDCY(KC,1)=MSTP(41)
4018 DO 170 J=1,MDCY(KC,3)
4019 IDC=J+MDCY(KC,2)-1
4020 BRAT(IDC)=0D0
4021 IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0)
4022 170 CONTINUE
4023 ENDIF
4024 180 CONTINUE
4025
4026C...Flavours of leptoquark: redefine charge and name.
4027 KFLQQ=KFDP(MDCY(42,2),1)
4028 KFLQL=KFDP(MDCY(42,2),2)
4029 KCHG(42,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+
4030 &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL)
4031 LL=1
4032 IF(IABS(KFLQL).EQ.13) LL=2
4033 IF(IABS(KFLQL).EQ.15) LL=3
4034 CHAF(42,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)//
4035 &CHAF(IABS(KFLQL),1)(1:LL)//' '
4036 CHAF(42,2)=CHAF(42,2)(1:4+LL)//'bar '
4037
4038C...Special cases in treatment of gamma*/Z0: redefine process name.
4039 IF(MSTP(43).EQ.1) THEN
4040 PROC(1)='f + fbar -> gamma*'
4041 PROC(15)='f + fbar -> g + gamma*'
4042 PROC(19)='f + fbar -> gamma + gamma*'
4043 PROC(30)='f + g -> f + gamma*'
4044 PROC(35)='f + gamma -> f + gamma*'
4045 ELSEIF(MSTP(43).EQ.2) THEN
4046 PROC(1)='f + fbar -> Z0'
4047 PROC(15)='f + fbar -> g + Z0'
4048 PROC(19)='f + fbar -> gamma + Z0'
4049 PROC(30)='f + g -> f + Z0'
4050 PROC(35)='f + gamma -> f + Z0'
4051 ELSEIF(MSTP(43).EQ.3) THEN
4052 PROC(1)='f + fbar -> gamma*/Z0'
4053 PROC(15)='f + fbar -> g + gamma*/Z0'
4054 PROC(19)='f + fbar -> gamma + gamma*/Z0'
4055 PROC(30)='f + g -> f + gamma*/Z0'
4056 PROC(35)='f + gamma -> f + gamma*/Z0'
4057 ENDIF
4058
4059C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
4060 IF(MSTP(44).EQ.1) THEN
4061 PROC(141)='f + fbar -> gamma*'
4062 ELSEIF(MSTP(44).EQ.2) THEN
4063 PROC(141)='f + fbar -> Z0'
4064 ELSEIF(MSTP(44).EQ.3) THEN
4065 PROC(141)='f + fbar -> Z''0'
4066 ELSEIF(MSTP(44).EQ.4) THEN
4067 PROC(141)='f + fbar -> gamma*/Z0'
4068 ELSEIF(MSTP(44).EQ.5) THEN
4069 PROC(141)='f + fbar -> gamma*/Z''0'
4070 ELSEIF(MSTP(44).EQ.6) THEN
4071 PROC(141)='f + fbar -> Z0/Z''0'
4072 ELSEIF(MSTP(44).EQ.7) THEN
4073 PROC(141)='f + fbar -> gamma*/Z0/Z''0'
4074 ENDIF
4075
4076C...Special cases in treatment of WW -> WW: redefine process name.
4077 IF(MSTP(45).EQ.1) THEN
4078 PROC(77)='W+ + W+ -> W+ + W+'
4079 ELSEIF(MSTP(45).EQ.2) THEN
4080 PROC(77)='W+ + W- -> W+ + W-'
4081 ELSEIF(MSTP(45).EQ.3) THEN
4082 PROC(77)='W+/- + W+/- -> W+/- + W+/-'
4083 ENDIF
4084
4085C...Format for error information.
4086 5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ',
4087 &'combination'/1X,'Execution stopped!')
4088
4089 RETURN
4090 END
4091
4092C*********************************************************************
4093
4094C...PYINBM
4095C...Identifies the two incoming particles and the choice of frame.
4096
4097 SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
4098
4099C...Double precision and integer declarations.
4100 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4101 IMPLICIT INTEGER(I-N)
4102 INTEGER PYK,PYCHGE,PYCOMP
4103
4104C...User process initialization commonblock.
4105 INTEGER MAXPUP
4106 PARAMETER (MAXPUP=100)
4107 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
4108 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
4109 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
4110 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
4111 &LPRUP(MAXPUP)
4112 SAVE /HEPRUP/
4113
4114C...Commonblocks.
4115 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
4116 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4117 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4118 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4119 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4120 COMMON/PYINT1/MINT(400),VINT(400)
4121 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
4122
4123C...Local arrays, character variables and data.
4124 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26,
4125 &CHIDNT(3)*12,CHTEMP*12,CHCDE(39)*12,CHINIT*76,CHNAME*16
4126 DIMENSION LEN(3),KCDE(39),PM(2)
4127 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
4128 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
4129 DATA CHCDE/ 'e- ','e+ ','nu_e ',
4130 &'nu_ebar ','mu- ','mu+ ','nu_mu ',
4131 &'nu_mubar ','tau- ','tau+ ','nu_tau ',
4132 &'nu_taubar ','pi+ ','pi- ','n0 ',
4133 &'nbar0 ','p+ ','pbar- ','gamma ',
4134 &'lambda0 ','sigma- ','sigma0 ','sigma+ ',
4135 &'xi- ','xi0 ','omega- ','pi0 ',
4136 &'reggeon ','pomeron ','gamma/e- ','gamma/e+ ',
4137 &'gamma/mu- ','gamma/mu+ ','gamma/tau- ','gamma/tau+ ',
4138 &'k+ ','k- ','ks0 ','kl0 '/
4139 DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
4140 &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
4141 &3312,3322,3334,111,110,990,6*22,321,-321,310,130/
4142
4143C...Store initial energy. Default frame.
4144 VINT(290)=WIN
4145 MINT(111)=0
4146
4147C...Special user process initialization; convert to normal input.
4148 IF(CHFRAM(1:1).EQ.'u'.OR.CHFRAM(1:1).EQ.'U') THEN
4149 MINT(111)=11
4150 CALL PYNAME(IDBMUP(1),CHNAME)
4151 CHBEAM=CHNAME(1:12)
4152 CALL PYNAME(IDBMUP(2),CHNAME)
4153 CHTARG=CHNAME(1:12)
4154 ENDIF
4155
4156C...Convert character variables to lowercase and find their length.
4157 CHCOM(1)=CHFRAM
4158 CHCOM(2)=CHBEAM
4159 CHCOM(3)=CHTARG
4160 DO 130 I=1,3
4161 LEN(I)=12
4162 DO 110 LL=12,1,-1
4163 IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
4164 DO 100 LA=1,26
4165 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
4166 & CHALP(1)(LA:LA)
4167 100 CONTINUE
4168 110 CONTINUE
4169 CHIDNT(I)=CHCOM(I)
4170
4171C...Fix up bar, underscore and charge in particle name (if needed).
4172 DO 120 LL=1,10
4173 IF(CHIDNT(I)(LL:LL).EQ.'~') THEN
4174 CHTEMP=CHIDNT(I)
4175 CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:10)//' '
4176 ENDIF
4177 120 CONTINUE
4178 IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN
4179 CHTEMP=CHIDNT(I)
4180 CHIDNT(I)='nu_'//CHTEMP(3:7)
4181 ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN
4182 CHIDNT(I)(1:3)='n0 '
4183 ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN
4184 CHIDNT(I)(1:5)='nbar0'
4185 ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN
4186 CHIDNT(I)(1:3)='p+ '
4187 ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR.
4188 & CHIDNT(I)(1:2).EQ.'p-') THEN
4189 CHIDNT(I)(1:5)='pbar-'
4190 ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN
4191 CHIDNT(I)(7:7)='0'
4192 ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN
4193 CHIDNT(I)(1:7)='reggeon'
4194 ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN
4195 CHIDNT(I)(1:7)='pomeron'
4196 ENDIF
4197 130 CONTINUE
4198
4199C...Identify free initialization.
4200 IF(CHCOM(1)(1:2).EQ.'no') THEN
4201 MINT(65)=1
4202 RETURN
4203 ENDIF
4204
4205C...Identify incoming beam and target particles.
4206 DO 160 I=1,2
4207 DO 140 J=1,39
4208 IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J)
4209 140 CONTINUE
4210 PM(I)=PYMASS(MINT(10+I))
4211 VINT(2+I)=PM(I)
4212 MINT(140+I)=0
4213 IF(MINT(10+I).EQ.22.AND.CHIDNT(I+1)(6:6).EQ.'/') THEN
4214 CHTEMP=CHIDNT(I+1)(7:12)//' '
4215 DO 150 J=1,12
4216 IF(CHTEMP.EQ.CHCDE(J)) MINT(140+I)=KCDE(J)
4217 150 CONTINUE
4218 PM(I)=PYMASS(MINT(140+I))
4219 VINT(302+I)=PM(I)
4220 ENDIF
4221 160 CONTINUE
4222 IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2))
4223 IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3))
4224 IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) STOP
4225
4226C...Identify choice of frame and input energies.
4227 CHINIT=' '
4228
4229C...Events defined in the CM frame.
4230 IF(CHCOM(1)(1:2).EQ.'cm') THEN
4231 MINT(111)=1
4232 S=WIN**2
4233 IF(MSTP(122).GE.1) THEN
4234 IF(CHCOM(2)(1:1).NE.'e') THEN
4235 LOFFS=(31-(LEN(2)+LEN(3)))/2
4236 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
4237 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4238 & ' collider'//' '
4239 ELSE
4240 LOFFS=(30-(LEN(2)+LEN(3)))/2
4241 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
4242 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4243 & ' collider'//' '
4244 ENDIF
4245 WRITE(MSTU(11),5200) CHINIT
4246 WRITE(MSTU(11),5300) WIN
4247 ENDIF
4248
4249C...Events defined in fixed target frame.
4250 ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
4251 MINT(111)=2
4252 S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2)
4253 IF(MSTP(122).GE.1) THEN
4254 LOFFS=(29-(LEN(2)+LEN(3)))/2
4255 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4256 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4257 & ' fixed target'//' '
4258 WRITE(MSTU(11),5200) CHINIT
4259 WRITE(MSTU(11),5400) WIN
4260 WRITE(MSTU(11),5500) SQRT(S)
4261 ENDIF
4262
4263C...Frame defined by user three-vectors.
4264 ELSEIF(CHCOM(1)(1:1).EQ.'3') THEN
4265 MINT(111)=3
4266 P(1,5)=PM(1)
4267 P(2,5)=PM(2)
4268 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
4269 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
4270 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
4271 & (P(1,3)+P(2,3))**2
4272 IF(MSTP(122).GE.1) THEN
4273 LOFFS=(22-(LEN(2)+LEN(3)))/2
4274 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4275 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4276 & ' user configuration'//' '
4277 WRITE(MSTU(11),5200) CHINIT
4278 WRITE(MSTU(11),5600)
4279 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
4280 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
4281 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
4282 ENDIF
4283
4284C...Frame defined by user four-vectors.
4285 ELSEIF(CHCOM(1)(1:1).EQ.'4') THEN
4286 MINT(111)=4
4287 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
4288 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
4289 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
4290 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
4291 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
4292 & (P(1,3)+P(2,3))**2
4293 IF(MSTP(122).GE.1) THEN
4294 LOFFS=(22-(LEN(2)+LEN(3)))/2
4295 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4296 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4297 & ' user configuration'//' '
4298 WRITE(MSTU(11),5200) CHINIT
4299 WRITE(MSTU(11),5600)
4300 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
4301 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
4302 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
4303 ENDIF
4304
4305C...Frame defined by user five-vectors.
4306 ELSEIF(CHCOM(1)(1:1).EQ.'5') THEN
4307 MINT(111)=5
4308 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
4309 & (P(1,3)+P(2,3))**2
4310 IF(MSTP(122).GE.1) THEN
4311 LOFFS=(22-(LEN(2)+LEN(3)))/2
4312 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4313 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4314 & ' user configuration'//' '
4315 WRITE(MSTU(11),5200) CHINIT
4316 WRITE(MSTU(11),5600)
4317 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
4318 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
4319 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
4320 ENDIF
4321
4322C...Frame defined by HEPRUP common block.
4323 ELSEIF(MINT(111).EQ.11) THEN
4324 S=(EBMUP(1)+EBMUP(2))**2-(SQRT(MAX(0D0,EBMUP(1)**2-PM(1)**2))-
4325 & SQRT(MAX(0D0,EBMUP(2)**2-PM(2)**2)))**2
4326 IF(MSTP(122).GE.1) THEN
4327 LOFFS=(22-(LEN(2)+LEN(3)))/2
4328 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4329 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4330 & ' user configuration'//' '
4331 WRITE(MSTU(11),5200) CHINIT
4332 WRITE(MSTU(11),6000) EBMUP(1),EBMUP(2)
4333 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
4334 ENDIF
4335
4336C...Unknown frame. Error for too low CM energy.
4337 ELSE
4338 WRITE(MSTU(11),5800) CHFRAM(1:LEN(1))
4339 STOP
4340 ENDIF
4341 IF(S.LT.PARP(2)**2) THEN
4342 WRITE(MSTU(11),5900) SQRT(S)
4343 STOP
4344 ENDIF
4345
4346C...Formats for initialization and error information.
4347 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/
4348 &1X,'Execution stopped!')
4349 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/
4350 &1X,'Execution stopped!')
4351 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
4352 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
4353 &19X,'I'/1X,'I',76X,'I'/1X,78('='))
4354 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
4355 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
4356 &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
4357 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X,
4358 &'pz (GeV/c)',6X,'E (GeV)',9X,'I')
4359 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I')
4360 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/
4361 &1X,'Execution stopped!')
4362 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
4363 &'generation.'/1X,'Execution stopped!')
4364 6000 FORMAT(1X,'I',12X,'with',1X,F10.3,1X,'GeV on',1X,F10.3,1X,
4365 &'GeV beam energies',13X,'I')
4366
4367 RETURN
4368 END
4369
4370C*********************************************************************
4371
4372C...PYINKI
4373C...Sets up kinematics, including rotations and boosts to/from CM frame.
4374
4375 SUBROUTINE PYINKI(MODKI)
4376
4377C...Double precision and integer declarations.
4378 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4379 IMPLICIT INTEGER(I-N)
4380 INTEGER PYK,PYCHGE,PYCOMP
4381
4382C...User process initialization commonblock.
4383 INTEGER MAXPUP
4384 PARAMETER (MAXPUP=100)
4385 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
4386 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
4387 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
4388 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
4389 &LPRUP(MAXPUP)
4390 SAVE /HEPRUP/
4391
4392C...Commonblocks.
4393 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
4394 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4395 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4396 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4397 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4398 COMMON/PYINT1/MINT(400),VINT(400)
4399 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
4400
4401C...Set initial flavour state.
4402 N=2
4403 DO 100 I=1,2
4404 K(I,1)=1
4405 K(I,2)=MINT(10+I)
4406 IF(MINT(140+I).NE.0) K(I,2)=MINT(140+I)
4407 100 CONTINUE
4408
4409C...Reset boost. Do kinematics for various cases.
4410 DO 110 J=6,10
4411 VINT(J)=0D0
4412 110 CONTINUE
4413
4414C...Set up kinematics for events defined in CM frame.
4415 IF(MINT(111).EQ.1) THEN
4416 WIN=VINT(290)
4417 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
4418 S=WIN**2
4419 P(1,5)=VINT(3)
4420 P(2,5)=VINT(4)
4421 IF(MINT(141).NE.0) P(1,5)=VINT(303)
4422 IF(MINT(142).NE.0) P(2,5)=VINT(304)
4423 P(1,1)=0D0
4424 P(1,2)=0D0
4425 P(2,1)=0D0
4426 P(2,2)=0D0
4427 P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/
4428 & (4D0*S))
4429 P(2,3)=-P(1,3)
4430 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
4431 P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
4432
4433C...Set up kinematics for fixed target events.
4434 ELSEIF(MINT(111).EQ.2) THEN
4435 WIN=VINT(290)
4436 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
4437 P(1,5)=VINT(3)
4438 P(2,5)=VINT(4)
4439 IF(MINT(141).NE.0) P(1,5)=VINT(303)
4440 IF(MINT(142).NE.0) P(2,5)=VINT(304)
4441 P(1,1)=0D0
4442 P(1,2)=0D0
4443 P(2,1)=0D0
4444 P(2,2)=0D0
4445 P(1,3)=WIN
4446 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
4447 P(2,3)=0D0
4448 P(2,4)=P(2,5)
4449 S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4)
4450 VINT(10)=P(1,3)/(P(1,4)+P(2,4))
4451 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
4452
4453C...Set up kinematics for events in user-defined frame.
4454 ELSEIF(MINT(111).EQ.3) THEN
4455 P(1,5)=VINT(3)
4456 P(2,5)=VINT(4)
4457 IF(MINT(141).NE.0) P(1,5)=VINT(303)
4458 IF(MINT(142).NE.0) P(2,5)=VINT(304)
4459 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
4460 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
4461 DO 120 J=1,3
4462 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
4463 120 CONTINUE
4464 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
4465 VINT(7)=PYANGL(P(1,1),P(1,2))
4466 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
4467 VINT(6)=PYANGL(P(1,3),P(1,1))
4468 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
4469 S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
4470
4471C...Set up kinematics for events with user-defined four-vectors.
4472 ELSEIF(MINT(111).EQ.4) THEN
4473 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
4474 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
4475 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
4476 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
4477 DO 130 J=1,3
4478 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
4479 130 CONTINUE
4480 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
4481 VINT(7)=PYANGL(P(1,1),P(1,2))
4482 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
4483 VINT(6)=PYANGL(P(1,3),P(1,1))
4484 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
4485 S=(P(1,4)+P(2,4))**2
4486
4487C...Set up kinematics for events with user-defined five-vectors.
4488 ELSEIF(MINT(111).EQ.5) THEN
4489 DO 140 J=1,3
4490 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
4491 140 CONTINUE
4492 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
4493 VINT(7)=PYANGL(P(1,1),P(1,2))
4494 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
4495 VINT(6)=PYANGL(P(1,3),P(1,1))
4496 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
4497 S=(P(1,4)+P(2,4))**2
4498
4499C...Set up kinematics for events with external user processes.
4500 ELSEIF(MINT(111).EQ.11) THEN
4501 P(1,5)=VINT(3)
4502 P(2,5)=VINT(4)
4503 IF(MINT(141).NE.0) P(1,5)=VINT(303)
4504 IF(MINT(142).NE.0) P(2,5)=VINT(304)
4505 P(1,1)=0D0
4506 P(1,2)=0D0
4507 P(2,1)=0D0
4508 P(2,2)=0D0
4509 P(1,3)=SQRT(MAX(0D0,EBMUP(1)**2-P(1,5)**2))
4510 P(2,3)=-SQRT(MAX(0D0,EBMUP(2)**2-P(2,5)**2))
4511 P(1,4)=EBMUP(1)
4512 P(2,4)=EBMUP(2)
4513 VINT(10)=(P(1,3)+P(2,3))/(P(1,4)+P(2,4))
4514 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
4515 S=(P(1,4)+P(2,4))**2
4516 ENDIF
4517
4518C...Return or error for too low CM energy.
4519 IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN
4520 IF(MSTP(172).LE.1) THEN
4521 CALL PYERRM(23,
4522 & '(PYINKI:) too low invariant mass in this event')
4523 ELSE
4524 MSTI(61)=1
4525 RETURN
4526 ENDIF
4527 ENDIF
4528
4529C...Save information on incoming particles.
4530 VINT(1)=SQRT(S)
4531 VINT(2)=S
4532 IF(MINT(111).GE.4) THEN
4533 IF(MINT(141).EQ.0) THEN
4534 VINT(3)=P(1,5)
4535 IF(MINT(11).EQ.22.AND.P(1,5).LT.0) VINT(307)=P(1,5)**2
4536 ELSE
4537 VINT(303)=P(1,5)
4538 ENDIF
4539 IF(MINT(142).EQ.0) THEN
4540 VINT(4)=P(2,5)
4541 IF(MINT(12).EQ.22.AND.P(2,5).LT.0) VINT(308)=P(2,5)**2
4542 ELSE
4543 VINT(304)=P(2,5)
4544 ENDIF
4545 ENDIF
4546 VINT(5)=P(1,3)
4547 IF(MODKI.EQ.0) VINT(289)=S
4548 DO 150 J=1,5
4549 V(1,J)=0D0
4550 V(2,J)=0D0
4551 VINT(290+J)=P(1,J)
4552 VINT(295+J)=P(2,J)
4553 150 CONTINUE
4554
4555C...Store pT cut-off and related constants to be used in generation.
4556 IF(MODKI.EQ.0) VINT(285)=CKIN(3)
4557 IF(MSTP(82).LE.1) THEN
4558 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
4559 ELSE
4560 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
4561 ENDIF
4562 VINT(149)=4D0*PTMN**2/S
4563 VINT(154)=PTMN
4564
4565 RETURN
4566 END
4567
4568C*********************************************************************
4569
4570C...PYINPR
4571C...Selects partonic subprocesses to be included in the simulation.
4572
4573 SUBROUTINE PYINPR
4574
4575C...Double precision and integer declarations.
4576 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4577 IMPLICIT INTEGER(I-N)
4578 INTEGER PYK,PYCHGE,PYCOMP
4579
4580C...User process initialization commonblock.
4581 INTEGER MAXPUP
4582 PARAMETER (MAXPUP=100)
4583 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
4584 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
4585 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
4586 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
4587 &LPRUP(MAXPUP)
4588 SAVE /HEPRUP/
4589
4590C...Commonblocks and character variables.
4591 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4592 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
4593 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4594 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4595 COMMON/PYINT1/MINT(400),VINT(400)
4596 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4597 COMMON/PYINT6/PROC(0:500)
4598 CHARACTER PROC*28
4599 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
4600 &/PYINT6/
4601 CHARACTER CHIPR*10
4602
4603C...Reset processes to be included.
4604 IF(MSEL.NE.0) THEN
4605 DO 100 I=1,500
4606 MSUB(I)=0
4607 100 CONTINUE
4608 ENDIF
4609
4610C...Set running pTmin scale.
4611 IF(MSTP(82).LE.1) THEN
4612 PTMRUN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
4613 ELSE
4614 PTMRUN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
4615 ENDIF
4616
4617C...Begin by assuming incoming photon to enter subprocess.
4618 IF(MINT(11).EQ.22) MINT(15)=22
4619 IF(MINT(12).EQ.22) MINT(16)=22
4620
4621C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous.
4622 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
4623 MSUB(10)=1
4624 MINT(123)=MINT(122)+1
4625
4626C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30
4627C...allow mixture.
4628C...Here also set a few parameters otherwise normally not touched.
4629 ELSEIF(MINT(121).GT.1) THEN
4630
4631C...Parton distributions dampened at small Q2; go to low energies,
4632C...alpha_s <1; no minimum pT cut-off a priori.
4633 IF(MSTP(18).EQ.2) THEN
4634 MSTP(57)=3
4635 PARP(2)=2D0
4636 PARU(115)=1D0
4637 CKIN(5)=0.2D0
4638 CKIN(6)=0.2D0
4639 ENDIF
4640
4641C...Define pT cut-off parameters and whether run involves low-pT.
4642 PTMVMD=PTMRUN
4643 VINT(154)=PTMVMD
4644 PTMDIR=PTMVMD
4645 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
4646 PTMANO=PTMVMD
4647 IF(MSTP(15).EQ.5) PTMANO=0.60D0+
4648 & 0.125D0*LOG(1D0+0.10D0*VINT(1))**2
4649 IPTL=1
4650 IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0
4651 IF(MSEL.EQ.2) IPTL=1
4652
4653C...Set up for p/gamma * gamma; real or virtual photons.
4654 IF(MINT(121).EQ.3.OR.MINT(121).EQ.6.OR.(MINT(121).EQ.4.AND.
4655 & MSTP(14).EQ.30)) THEN
4656
4657C...Set up for p/VMD * VMD.
4658 IF(MINT(122).EQ.1) THEN
4659 MINT(123)=2
4660 MSUB(11)=1
4661 MSUB(12)=1
4662 MSUB(13)=1
4663 MSUB(28)=1
4664 MSUB(53)=1
4665 MSUB(68)=1
4666 IF(IPTL.EQ.1) MSUB(95)=1
4667 IF(MSEL.EQ.2) THEN
4668 MSUB(91)=1
4669 MSUB(92)=1
4670 MSUB(93)=1
4671 MSUB(94)=1
4672 ENDIF
4673 IF(IPTL.EQ.1) CKIN(3)=0D0
4674
4675C...Set up for p/VMD * direct gamma.
4676 ELSEIF(MINT(122).EQ.2) THEN
4677 MINT(123)=0
4678 IF(MINT(121).EQ.6) MINT(123)=5
4679 MSUB(131)=1
4680 MSUB(132)=1
4681 MSUB(135)=1
4682 MSUB(136)=1
4683 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4684
4685C...Set up for p/VMD * anomalous gamma.
4686 ELSEIF(MINT(122).EQ.3) THEN
4687 MINT(123)=3
4688 IF(MINT(121).EQ.6) MINT(123)=7
4689 MSUB(11)=1
4690 MSUB(12)=1
4691 MSUB(13)=1
4692 MSUB(28)=1
4693 MSUB(53)=1
4694 MSUB(68)=1
4695 IF(IPTL.EQ.1) MSUB(95)=1
4696 IF(MSEL.EQ.2) THEN
4697 MSUB(91)=1
4698 MSUB(92)=1
4699 MSUB(93)=1
4700 MSUB(94)=1
4701 ENDIF
4702 IF(IPTL.EQ.1) CKIN(3)=0D0
4703
4704C...Set up for DIS * p.
4705 ELSEIF(MINT(122).EQ.4.AND.(IABS(MINT(11)).GT.100.OR.
4706 & IABS(MINT(12)).GT.100)) THEN
4707 MINT(123)=8
4708 IF(IPTL.EQ.1) MSUB(99)=1
4709
4710C...Set up for direct * direct gamma (switch off leptons).
4711 ELSEIF(MINT(122).EQ.4) THEN
4712 MINT(123)=0
4713 MSUB(137)=1
4714 MSUB(138)=1
4715 MSUB(139)=1
4716 MSUB(140)=1
4717 DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
4718 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
4719 110 CONTINUE
4720 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4721
4722C...Set up for direct * anomalous gamma.
4723 ELSEIF(MINT(122).EQ.5) THEN
4724 MINT(123)=6
4725 MSUB(131)=1
4726 MSUB(132)=1
4727 MSUB(135)=1
4728 MSUB(136)=1
4729 IF(IPTL.EQ.1) CKIN(3)=PTMANO
4730
4731C...Set up for anomalous * anomalous gamma.
4732 ELSEIF(MINT(122).EQ.6) THEN
4733 MINT(123)=3
4734 MSUB(11)=1
4735 MSUB(12)=1
4736 MSUB(13)=1
4737 MSUB(28)=1
4738 MSUB(53)=1
4739 MSUB(68)=1
4740 IF(IPTL.EQ.1) MSUB(95)=1
4741 IF(MSEL.EQ.2) THEN
4742 MSUB(91)=1
4743 MSUB(92)=1
4744 MSUB(93)=1
4745 MSUB(94)=1
4746 ENDIF
4747 IF(IPTL.EQ.1) CKIN(3)=0D0
4748 ENDIF
4749
4750C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom.
4751 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
4752
4753C...Set up for direct * direct gamma (switch off leptons).
4754 IF(MINT(122).EQ.1) THEN
4755 MINT(123)=0
4756 MSUB(137)=1
4757 MSUB(138)=1
4758 MSUB(139)=1
4759 MSUB(140)=1
4760 DO 120 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
4761 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
4762 120 CONTINUE
4763 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4764
4765C...Set up for direct * VMD and VMD * direct gamma.
4766 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.4) THEN
4767 MINT(123)=5
4768 MSUB(131)=1
4769 MSUB(132)=1
4770 MSUB(135)=1
4771 MSUB(136)=1
4772 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4773
4774C...Set up for direct * anomalous and anomalous * direct gamma.
4775 ELSEIF(MINT(122).EQ.3.OR.MINT(122).EQ.7) THEN
4776 MINT(123)=6
4777 MSUB(131)=1
4778 MSUB(132)=1
4779 MSUB(135)=1
4780 MSUB(136)=1
4781 IF(IPTL.EQ.1) CKIN(3)=PTMANO
4782
4783C...Set up for VMD*VMD.
4784 ELSEIF(MINT(122).EQ.5) THEN
4785 MINT(123)=2
4786 MSUB(11)=1
4787 MSUB(12)=1
4788 MSUB(13)=1
4789 MSUB(28)=1
4790 MSUB(53)=1
4791 MSUB(68)=1
4792 IF(IPTL.EQ.1) MSUB(95)=1
4793 IF(MSEL.EQ.2) THEN
4794 MSUB(91)=1
4795 MSUB(92)=1
4796 MSUB(93)=1
4797 MSUB(94)=1
4798 ENDIF
4799 IF(IPTL.EQ.1) CKIN(3)=0D0
4800
4801C...Set up for VMD * anomalous and anomalous * VMD gamma.
4802 ELSEIF(MINT(122).EQ.6.OR.MINT(122).EQ.8) THEN
4803 MINT(123)=7
4804 MSUB(11)=1
4805 MSUB(12)=1
4806 MSUB(13)=1
4807 MSUB(28)=1
4808 MSUB(53)=1
4809 MSUB(68)=1
4810 IF(IPTL.EQ.1) MSUB(95)=1
4811 IF(MSEL.EQ.2) THEN
4812 MSUB(91)=1
4813 MSUB(92)=1
4814 MSUB(93)=1
4815 MSUB(94)=1
4816 ENDIF
4817 IF(IPTL.EQ.1) CKIN(3)=0D0
4818
4819C...Set up for anomalous * anomalous gamma.
4820 ELSEIF(MINT(122).EQ.9) THEN
4821 MINT(123)=3
4822 MSUB(11)=1
4823 MSUB(12)=1
4824 MSUB(13)=1
4825 MSUB(28)=1
4826 MSUB(53)=1
4827 MSUB(68)=1
4828 IF(IPTL.EQ.1) MSUB(95)=1
4829 IF(MSEL.EQ.2) THEN
4830 MSUB(91)=1
4831 MSUB(92)=1
4832 MSUB(93)=1
4833 MSUB(94)=1
4834 ENDIF
4835 IF(IPTL.EQ.1) CKIN(3)=0D0
4836
4837C...Set up for DIS * VMD and VMD * DIS gamma.
4838 ELSEIF(MINT(122).EQ.10.OR.MINT(122).EQ.12) THEN
4839 MINT(123)=8
4840 IF(IPTL.EQ.1) MSUB(99)=1
4841
4842C...Set up for DIS * anomalous and anomalous * DIS gamma.
4843 ELSEIF(MINT(122).EQ.11.OR.MINT(122).EQ.13) THEN
4844 MINT(123)=9
4845 IF(IPTL.EQ.1) MSUB(99)=1
4846 ENDIF
4847
4848C...Set up for gamma* * p; virtual photons = dir, res.
4849 ELSEIF(MINT(121).EQ.2) THEN
4850
4851C...Set up for direct * p.
4852 IF(MINT(122).EQ.1) THEN
4853 MINT(123)=0
4854 MSUB(131)=1
4855 MSUB(132)=1
4856 MSUB(135)=1
4857 MSUB(136)=1
4858 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4859
4860C...Set up for resolved * p.
4861 ELSEIF(MINT(122).EQ.2) THEN
4862 MINT(123)=1
4863 MSUB(11)=1
4864 MSUB(12)=1
4865 MSUB(13)=1
4866 MSUB(28)=1
4867 MSUB(53)=1
4868 MSUB(68)=1
4869 IF(IPTL.EQ.1) MSUB(95)=1
4870 IF(MSEL.EQ.2) THEN
4871 MSUB(91)=1
4872 MSUB(92)=1
4873 MSUB(93)=1
4874 MSUB(94)=1
4875 ENDIF
4876 IF(IPTL.EQ.1) CKIN(3)=0D0
4877 ENDIF
4878
4879C...Set up for gamma* * gamma*; virtual photons = dir, res.
4880 ELSEIF(MINT(121).EQ.4) THEN
4881
4882C...Set up for direct * direct gamma (switch off leptons).
4883 IF(MINT(122).EQ.1) THEN
4884 MINT(123)=0
4885 MSUB(137)=1
4886 MSUB(138)=1
4887 MSUB(139)=1
4888 MSUB(140)=1
4889 DO 130 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
4890 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
4891 130 CONTINUE
4892 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4893
4894C...Set up for direct * resolved and resolved * direct gamma.
4895 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.3) THEN
4896 MINT(123)=5
4897 MSUB(131)=1
4898 MSUB(132)=1
4899 MSUB(135)=1
4900 MSUB(136)=1
4901 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4902
4903C...Set up for resolved * resolved gamma.
4904 ELSEIF(MINT(122).EQ.4) THEN
4905 MINT(123)=2
4906 MSUB(11)=1
4907 MSUB(12)=1
4908 MSUB(13)=1
4909 MSUB(28)=1
4910 MSUB(53)=1
4911 MSUB(68)=1
4912 IF(IPTL.EQ.1) MSUB(95)=1
4913 IF(MSEL.EQ.2) THEN
4914 MSUB(91)=1
4915 MSUB(92)=1
4916 MSUB(93)=1
4917 MSUB(94)=1
4918 ENDIF
4919 IF(IPTL.EQ.1) CKIN(3)=0D0
4920 ENDIF
4921
4922C...End of special set up for gamma-p and gamma-gamma.
4923 ENDIF
4924 CKIN(1)=2D0*CKIN(3)
4925 ENDIF
4926
4927C...Flavour information for individual beams.
4928 DO 140 I=1,2
4929 MINT(40+I)=1
4930 IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2
4931 IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2
4932 MINT(44+I)=MINT(40+I)
4933 IF(MSTP(11).GE.1.AND.(IABS(MINT(10+I)).EQ.11.OR.
4934 & IABS(MINT(10+I)).EQ.13.OR.IABS(MINT(10+I)).EQ.15)) MINT(44+I)=3
4935 140 CONTINUE
4936
4937C...If two real gammas, whereof one direct, pick the first.
4938C...For two virtual photons, keep requested order.
4939 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
4940 IF(MSTP(14).LE.10.AND.MINT(123).GE.4.AND.MINT(123).LE.6) THEN
4941 MINT(41)=1
4942 MINT(45)=1
4943 ELSEIF(MSTP(14).EQ.12.OR.MSTP(14).EQ.13.OR.MSTP(14).EQ.22.OR.
4944 & MSTP(14).EQ.26.OR.MSTP(14).EQ.27) THEN
4945 MINT(41)=1
4946 MINT(45)=1
4947 ELSEIF(MSTP(14).EQ.14.OR.MSTP(14).EQ.17.OR.MSTP(14).EQ.23.OR.
4948 & MSTP(14).EQ.28.OR.MSTP(14).EQ.29) THEN
4949 MINT(42)=1
4950 MINT(46)=1
4951 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.2
4952 & .OR.MINT(122).EQ.3.OR.MINT(122).EQ.10.OR.MINT(122).EQ.11)) THEN
4953 MINT(41)=1
4954 MINT(45)=1
4955 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.4
4956 & .OR.MINT(122).EQ.7.OR.MINT(122).EQ.12.OR.MINT(122).EQ.13)) THEN
4957 MINT(42)=1
4958 MINT(46)=1
4959 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.2) THEN
4960 MINT(41)=1
4961 MINT(45)=1
4962 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.3) THEN
4963 MINT(42)=1
4964 MINT(46)=1
4965 ENDIF
4966 ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN
4967 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28.OR.MINT(122).EQ.4) THEN
4968 IF(MINT(11).EQ.22) THEN
4969 MINT(41)=1
4970 MINT(45)=1
4971 ELSE
4972 MINT(42)=1
4973 MINT(46)=1
4974 ENDIF
4975 ENDIF
4976 IF(MINT(123).GE.4.AND.MINT(123).LE.7) CALL PYERRM(26,
4977 & '(PYINPR:) unallowed MSTP(14) code for single photon')
4978 ENDIF
4979
4980C...Flavour information on combination of incoming particles.
4981 MINT(43)=2*MINT(41)+MINT(42)-2
4982 MINT(44)=MINT(43)
4983 IF(MINT(123).LE.0) THEN
4984 IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2
4985 IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1
4986 ELSEIF(MINT(123).LE.3) THEN
4987 IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2
4988 IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1
4989 ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
4990 MINT(43)=4
4991 MINT(44)=1
4992 ENDIF
4993 MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2
4994 IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5
4995 IF(MINT(45).EQ.1.AND.MINT(46).EQ.3) MINT(47)=6
4996 IF(MINT(45).EQ.3.AND.MINT(46).EQ.1) MINT(47)=7
4997 MINT(50)=0
4998 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) MINT(50)=1
4999 MINT(107)=0
5000 MINT(108)=0
5001 IF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
5002 IF((MINT(122).GE.4.AND.MINT(122).LE.6).OR.MINT(122).EQ.12)
5003 & MINT(107)=2
5004 IF((MINT(122).GE.7.AND.MINT(122).LE.9).OR.MINT(122).EQ.13)
5005 & MINT(107)=3
5006 IF(MINT(122).EQ.10.OR.MINT(122).EQ.11) MINT(107)=4
5007 IF(MINT(122).EQ.2.OR.MINT(122).EQ.5.OR.MINT(122).EQ.8.OR.
5008 & MINT(122).EQ.10) MINT(108)=2
5009 IF(MINT(122).EQ.3.OR.MINT(122).EQ.6.OR.MINT(122).EQ.9.OR.
5010 & MINT(122).EQ.11) MINT(108)=3
5011 IF(MINT(122).EQ.12.OR.MINT(122).EQ.13) MINT(108)=4
5012 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.25) THEN
5013 IF(MINT(122).GE.3) MINT(107)=1
5014 IF(MINT(122).EQ.2.OR.MINT(122).EQ.4) MINT(108)=1
5015 ELSEIF(MINT(121).EQ.2) THEN
5016 IF(MINT(122).EQ.2.AND.MINT(11).EQ.22) MINT(107)=1
5017 IF(MINT(122).EQ.2.AND.MINT(12).EQ.22) MINT(108)=1
5018 ELSE
5019 IF(MINT(11).EQ.22) THEN
5020 MINT(107)=MINT(123)
5021 IF(MINT(123).GE.4) MINT(107)=0
5022 IF(MINT(123).EQ.7) MINT(107)=2
5023 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.27) MINT(107)=4
5024 IF(MSTP(14).EQ.28) MINT(107)=2
5025 IF(MSTP(14).EQ.29) MINT(107)=3
5026 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
5027 & MINT(107)=4
5028 ENDIF
5029 IF(MINT(12).EQ.22) THEN
5030 MINT(108)=MINT(123)
5031 IF(MINT(123).GE.4) MINT(108)=MINT(123)-3
5032 IF(MINT(123).EQ.7) MINT(108)=3
5033 IF(MSTP(14).EQ.26) MINT(108)=2
5034 IF(MSTP(14).EQ.27) MINT(108)=3
5035 IF(MSTP(14).EQ.28.OR.MSTP(14).EQ.29) MINT(108)=4
5036 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
5037 & MINT(108)=4
5038 ENDIF
5039 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.(MSTP(14).EQ.14.OR.
5040 & MSTP(14).EQ.17.OR.MSTP(14).EQ.18.OR.MSTP(14).EQ.23)) THEN
5041 MINTTP=MINT(107)
5042 MINT(107)=MINT(108)
5043 MINT(108)=MINTTP
5044 ENDIF
5045 ENDIF
5046 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
5047 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
5048
5049C...Select default processes according to incoming beams
5050C...(already done for gamma-p and gamma-gamma with
5051C...MSTP(14) = 10, 20, 25 or 30).
5052 IF(MINT(121).GT.1) THEN
5053 ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN
5054
5055 IF(MINT(43).EQ.1) THEN
5056C...Lepton + lepton -> gamma/Z0 or W.
5057 IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
5058 IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
5059
5060 ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND.
5061 & (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN
5062C...Unresolved photon + lepton: Compton scattering.
5063 MSUB(133)=1
5064 MSUB(134)=1
5065
5066 ELSEIF((MINT(123).EQ.8.OR.MINT(123).EQ.9).AND.(MINT(11).EQ.22
5067 & .OR.MINT(12).EQ.22)) THEN
5068C...DIS as pure gamma* + f -> f process.
5069 MSUB(99)=1
5070
5071 ELSEIF(MINT(43).LE.3) THEN
5072C...Lepton + hadron: deep inelastic scattering.
5073 MSUB(10)=1
5074
5075 ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND.
5076 & MINT(12).EQ.22) THEN
5077C...Two unresolved photons: fermion pair production,
5078C...exclude lepton pairs.
5079 DO 150 ISUB=137,140
5080 MSUB(ISUB)=1
5081 150 CONTINUE
5082 DO 160 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
5083 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
5084 160 CONTINUE
5085 PTMDIR=PTMRUN
5086 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
5087 IF(CKIN(3).LT.PTMRUN.OR.MSEL.EQ.2) CKIN(3)=PTMDIR
5088 CKIN(1)=MAX(CKIN(1),2D0*CKIN(3))
5089
5090 ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22))
5091 & .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND.
5092 & MINT(12).EQ.22)) THEN
5093C...Unresolved photon + hadron: photon-parton scattering.
5094 DO 170 ISUB=131,136
5095 MSUB(ISUB)=1
5096 170 CONTINUE
5097
5098 ELSEIF(MSEL.EQ.1) THEN
5099C...High-pT QCD processes:
5100 MSUB(11)=1
5101 MSUB(12)=1
5102 MSUB(13)=1
5103 MSUB(28)=1
5104 MSUB(53)=1
5105 MSUB(68)=1
5106 PTMN=PTMRUN
5107 VINT(154)=PTMN
5108 IF(CKIN(3).LT.PTMN) MSUB(95)=1
5109 IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0
5110
5111 ELSE
5112C...All QCD processes:
5113 MSUB(11)=1
5114 MSUB(12)=1
5115 MSUB(13)=1
5116 MSUB(28)=1
5117 MSUB(53)=1
5118 MSUB(68)=1
5119 MSUB(91)=1
5120 MSUB(92)=1
5121 MSUB(93)=1
5122 MSUB(94)=1
5123 MSUB(95)=1
5124 ENDIF
5125
5126 ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
5127C...Heavy quark production.
5128 MSUB(81)=1
5129 MSUB(82)=1
5130 MSUB(84)=1
5131 DO 180 J=1,MIN(8,MDCY(21,3))
5132 MDME(MDCY(21,2)+J-1,1)=0
5133 180 CONTINUE
5134 MDME(MDCY(21,2)+MSEL-1,1)=1
5135 MSUB(85)=1
5136 DO 190 J=1,MIN(12,MDCY(22,3))
5137 MDME(MDCY(22,2)+J-1,1)=0
5138 190 CONTINUE
5139 MDME(MDCY(22,2)+MSEL-1,1)=1
5140
5141 ELSEIF(MSEL.EQ.10) THEN
5142C...Prompt photon production:
5143 MSUB(14)=1
5144 MSUB(18)=1
5145 MSUB(29)=1
5146
5147 ELSEIF(MSEL.EQ.11) THEN
5148C...Z0/gamma* production:
5149 MSUB(1)=1
5150
5151 ELSEIF(MSEL.EQ.12) THEN
5152C...W+/- production:
5153 MSUB(2)=1
5154
5155 ELSEIF(MSEL.EQ.13) THEN
5156C...Z0 + jet:
5157 MSUB(15)=1
5158 MSUB(30)=1
5159
5160 ELSEIF(MSEL.EQ.14) THEN
5161C...W+/- + jet:
5162 MSUB(16)=1
5163 MSUB(31)=1
5164
5165 ELSEIF(MSEL.EQ.15) THEN
5166C...Z0 & W+/- pair production:
5167 MSUB(19)=1
5168 MSUB(20)=1
5169 MSUB(22)=1
5170 MSUB(23)=1
5171 MSUB(25)=1
5172
5173 ELSEIF(MSEL.EQ.16) THEN
5174C...h0 production:
5175 MSUB(3)=1
5176 MSUB(102)=1
5177 MSUB(103)=1
5178 MSUB(123)=1
5179 MSUB(124)=1
5180
5181 ELSEIF(MSEL.EQ.17) THEN
5182C...h0 & Z0 or W+/- pair production:
5183 MSUB(24)=1
5184 MSUB(26)=1
5185
5186 ELSEIF(MSEL.EQ.18) THEN
5187C...h0 production; interesting processes in e+e-.
5188 MSUB(24)=1
5189 MSUB(103)=1
5190 MSUB(123)=1
5191 MSUB(124)=1
5192
5193 ELSEIF(MSEL.EQ.19) THEN
5194C...h0, H0 and A0 production; interesting processes in e+e-.
5195 MSUB(24)=1
5196 MSUB(103)=1
5197 MSUB(123)=1
5198 MSUB(124)=1
5199 MSUB(153)=1
5200 MSUB(171)=1
5201 MSUB(173)=1
5202 MSUB(174)=1
5203 MSUB(158)=1
5204 MSUB(176)=1
5205 MSUB(178)=1
5206 MSUB(179)=1
5207
5208 ELSEIF(MSEL.EQ.21) THEN
5209C...Z'0 production:
5210 MSUB(141)=1
5211
5212 ELSEIF(MSEL.EQ.22) THEN
5213C...W'+/- production:
5214 MSUB(142)=1
5215
5216 ELSEIF(MSEL.EQ.23) THEN
5217C...H+/- production:
5218 MSUB(143)=1
5219
5220 ELSEIF(MSEL.EQ.24) THEN
5221C...R production:
5222 MSUB(144)=1
5223
5224 ELSEIF(MSEL.EQ.25) THEN
5225C...LQ (leptoquark) production.
5226 MSUB(145)=1
5227 MSUB(162)=1
5228 MSUB(163)=1
5229 MSUB(164)=1
5230
5231 ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN
5232C...Production of one heavy quark (W exchange):
5233 MSUB(83)=1
5234 DO 200 J=1,MIN(8,MDCY(21,3))
5235 MDME(MDCY(21,2)+J-1,1)=0
5236 200 CONTINUE
5237 MDME(MDCY(21,2)+MSEL-31,1)=1
5238
5239CMRENNA++Define SUSY alternatives.
5240 ELSEIF(MSEL.EQ.39) THEN
5241C...Turn on all SUSY processes.
5242 IF(MINT(43).EQ.4) THEN
5243C...Hadron-hadron processes.
5244 DO 210 I=201,301
5245 IF(ISET(I).GE.0) MSUB(I)=1
5246 210 CONTINUE
5247 ELSEIF(MINT(43).EQ.1) THEN
5248C...Lepton-lepton processes: QED production of squarks.
5249 DO 220 I=201,214
5250 MSUB(I)=1
5251 220 CONTINUE
5252 MSUB(210)=0
5253 MSUB(211)=0
5254 MSUB(212)=0
5255 DO 230 I=216,228
5256 MSUB(I)=1
5257 230 CONTINUE
5258 DO 240 I=261,263
5259 MSUB(I)=1
5260 240 CONTINUE
5261 MSUB(277)=1
5262 MSUB(278)=1
5263 ENDIF
5264
5265 ELSEIF(MSEL.EQ.40) THEN
5266C...Gluinos and squarks.
5267 IF(MINT(43).EQ.4) THEN
5268 MSUB(243)=1
5269 MSUB(244)=1
5270 MSUB(258)=1
5271 MSUB(259)=1
5272 MSUB(261)=1
5273 MSUB(262)=1
5274 MSUB(264)=1
5275 MSUB(265)=1
5276 DO 250 I=271,296
5277 MSUB(I)=1
5278 250 CONTINUE
5279 ELSEIF(MINT(43).EQ.1) THEN
5280 MSUB(277)=1
5281 MSUB(278)=1
5282 ENDIF
5283
5284 ELSEIF(MSEL.EQ.41) THEN
5285C...Stop production.
5286 MSUB(261)=1
5287 MSUB(262)=1
5288 MSUB(263)=1
5289 IF(MINT(43).EQ.4) THEN
5290 MSUB(264)=1
5291 MSUB(265)=1
5292 ENDIF
5293
5294 ELSEIF(MSEL.EQ.42) THEN
5295C...Slepton production.
5296 DO 260 I=201,214
5297 MSUB(I)=1
5298 260 CONTINUE
5299 IF(MINT(43).NE.4) THEN
5300 MSUB(210)=0
5301 MSUB(211)=0
5302 MSUB(212)=0
5303 ENDIF
5304
5305 ELSEIF(MSEL.EQ.43) THEN
5306C...Neutralino/Chargino + Gluino/Squark.
5307 IF(MINT(43).EQ.4) THEN
5308 DO 270 I=237,242
5309 MSUB(I)=1
5310 270 CONTINUE
5311 DO 280 I=246,257
5312 MSUB(I)=1
5313 280 CONTINUE
5314 ENDIF
5315
5316 ELSEIF(MSEL.EQ.44) THEN
5317C...Neutralino/Chargino pair production.
5318 IF(MINT(43).EQ.4) THEN
5319 DO 290 I=216,236
5320 MSUB(I)=1
5321 290 CONTINUE
5322 ELSEIF(MINT(43).EQ.1) THEN
5323 DO 300 I=216,228
5324 MSUB(I)=1
5325 300 CONTINUE
5326 ENDIF
5327
5328 ELSEIF(MSEL.EQ.45) THEN
5329C...Sbottom production.
5330 MSUB(287)=1
5331 MSUB(288)=1
5332 IF(MINT(43).EQ.4) THEN
5333 DO 310 I=281,296
5334 MSUB(I)=1
5335 310 CONTINUE
5336 ENDIF
5337
5338 ELSEIF(MSEL.EQ.50) THEN
5339C...Pair production of technipions and gauge bosons.
5340 DO 320 I=361,368
5341 MSUB(I)=1
5342 320 CONTINUE
5343 IF(MINT(43).EQ.4) THEN
5344 DO 330 I=370,377
5345 MSUB(I)=1
5346 330 CONTINUE
5347 ENDIF
5348
5349 ELSEIF(MSEL.EQ.51) THEN
5350C...QCD 2 -> 2 processes with compositeness/technicolor modifications.
5351 DO 340 I=381,386
5352 MSUB(I)=1
5353 340 CONTINUE
5354 ENDIF
5355
5356C...Find heaviest new quark flavour allowed in processes 81-84.
5357 KFLQM=1
5358 DO 350 I=1,MIN(8,MDCY(21,3))
5359 IDC=I+MDCY(21,2)-1
5360 IF(MDME(IDC,1).LE.0) GOTO 350
5361 KFLQM=I
5362 350 CONTINUE
5363 IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9))
5364 &KFLQM=MSTP(7)
5365 MINT(55)=KFLQM
5366 KFPR(81,1)=KFLQM
5367 KFPR(81,2)=KFLQM
5368 KFPR(82,1)=KFLQM
5369 KFPR(82,2)=KFLQM
5370 KFPR(83,1)=KFLQM
5371 KFPR(84,1)=KFLQM
5372 KFPR(84,2)=KFLQM
5373
5374C...Find heaviest new fermion flavour allowed in process 85.
5375 KFLFM=1
5376 DO 360 I=1,MIN(12,MDCY(22,3))
5377 IDC=I+MDCY(22,2)-1
5378 IF(MDME(IDC,1).LE.0) GOTO 360
5379 KFLFM=KFDP(IDC,1)
5380 360 CONTINUE
5381 IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND.
5382 &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7)
5383 MINT(56)=KFLFM
5384 KFPR(85,1)=KFLFM
5385 KFPR(85,2)=KFLFM
5386
5387C...Import relevant information on external user processes.
5388 IF(MINT(111).EQ.11) THEN
5389 IPYPR=0
5390 DO 390 IUP=1,NPRUP
5391C...Find next empty PYTHIA process number slot and enable it.
5392 370 IPYPR=IPYPR+1
5393 IF(IPYPR.GT.500) CALL PYERRM(26,
5394 & '(PYINPR.) no more empty slots for user processes')
5395 IF(ISET(IPYPR).GE.0.AND.ISET(IPYPR).LE.9) GOTO 370
5396 IF(IPYPR.GE.91.AND.IPYPR.LE.100) GOTO 370
5397 ISET(IPYPR)=11
5398C...Overwrite KFPR with references back to process number and ID.
5399 KFPR(IPYPR,1)=IUP
5400 KFPR(IPYPR,2)=LPRUP(IUP)
5401C...Process title.
5402 WRITE(CHIPR,'(I10)') LPRUP(IUP)
5403 ICHIN=1
5404 DO 380 ICH=1,9
5405 IF(CHIPR(ICH:ICH).EQ.' ') ICHIN=ICH+1
5406 380 CONTINUE
5407 PROC(IPYPR)='User process '//CHIPR(ICHIN:10)//' '
5408C...Switch on process.
5409 MSUB(IPYPR)=1
5410 390 CONTINUE
5411 ENDIF
5412
5413 RETURN
5414 END
5415
5416C*********************************************************************
5417
5418C...PYXTOT
5419C...Parametrizes total, elastic and diffractive cross-sections
5420C...for different energies and beams. Donnachie-Landshoff for
5421C...total and Schuler-Sjostrand for elastic and diffractive.
5422C...Process code IPROC:
5423C...= 1 : p + p;
5424C...= 2 : pbar + p;
5425C...= 3 : pi+ + p;
5426C...= 4 : pi- + p;
5427C...= 5 : pi0 + p;
5428C...= 6 : phi + p;
5429C...= 7 : J/psi + p;
5430C...= 11 : rho + rho;
5431C...= 12 : rho + phi;
5432C...= 13 : rho + J/psi;
5433C...= 14 : phi + phi;
5434C...= 15 : phi + J/psi;
5435C...= 16 : J/psi + J/psi;
5436C...= 21 : gamma + p (DL);
5437C...= 22 : gamma + p (VDM).
5438C...= 23 : gamma + pi (DL);
5439C...= 24 : gamma + pi (VDM);
5440C...= 25 : gamma + gamma (DL);
5441C...= 26 : gamma + gamma (VDM).
5442
5443 SUBROUTINE PYXTOT
5444
5445C...Double precision and integer declarations.
5446 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5447 IMPLICIT INTEGER(I-N)
5448 INTEGER PYK,PYCHGE,PYCOMP
5449C...Commonblocks.
5450 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5451 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5452 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5453 COMMON/PYINT1/MINT(400),VINT(400)
5454 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5455 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
5456 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/
5457C...Local arrays.
5458 DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20),
5459 &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8),
5460 &CEFFD(10,9),SIGTMP(6,0:5)
5461
5462C...Common constants.
5463 DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/,
5464 &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/,
5465 &FACDD/0.0084D0/
5466
5467C...Number of multiple processes to be evaluated (= 0 : undefined).
5468 DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
5469C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
5470 DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0,
5471 &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0,
5472 &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/
5473 DATA YPAR/
5474 &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0,
5475 &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0,
5476 &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/
5477
5478C...Beam and target hadron class:
5479C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
5480 DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
5481 DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/
5482C...Characteristic class masses, slope parameters, beta = sqrt(X).
5483 DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/
5484 DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
5485 DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/
5486
5487C...Fitting constants used in parametrizations of diffractive results.
5488 DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
5489 DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
5490 DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/
5491 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0,
5492 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0,
5493 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0,
5494 &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0,
5495 &0.267D0, 0.0D0, -0.46D0, 75D0, 0.267D0, 0.0D0, -0.46D0, 75D0,
5496 &0.232D0, 0.0D0, -0.46D0, 85D0, 0.267D0, 0.0D0, -0.48D0, 100D0,
5497 &0.115D0, 0.0D0, -0.50D0, 90D0, 0.267D0, 6.0D0, -0.56D0, 420D0,
5498 &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0,
5499 &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0,
5500 &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/
5501 DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/
5502 &3.11D0, -7.34D0, 9.71D0, 0.068D0, -0.42D0, 1.31D0,
5503 &-1.37D0, 35.0D0, 118D0, 3.11D0, -7.10D0, 10.6D0,
5504 &0.073D0, -0.41D0, 1.17D0, -1.41D0, 31.6D0, 95D0,
5505 &3.12D0, -7.43D0, 9.21D0, 0.067D0, -0.44D0, 1.41D0,
5506 &-1.35D0, 36.5D0, 132D0, 3.13D0, -8.18D0, -4.20D0,
5507 &0.056D0, -0.71D0, 3.12D0, -1.12D0, 55.2D0, 1298D0,
5508 &3.11D0, -6.90D0, 11.4D0, 0.078D0, -0.40D0, 1.05D0,
5509 &-1.40D0, 28.4D0, 78D0, 3.11D0, -7.13D0, 10.0D0,
5510 &0.071D0, -0.41D0, 1.23D0, -1.34D0, 33.1D0, 105D0,
5511 &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0, 2.72D0,
5512 &-1.13D0, 53.1D0, 995D0, 3.11D0, -7.39D0, 8.22D0,
5513 &0.065D0, -0.44D0, 1.45D0, -1.36D0, 38.1D0, 148D0,
5514 &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0, 3.32D0,
5515 &-1.12D0, 55.6D0, 1472D0, 4.18D0, -29.2D0, 56.2D0,
5516 &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/
5517
5518C...Parameters. Combinations of the energy.
5519 AEM=PARU(101)
5520 PMTH=PARP(102)
5521 S=VINT(2)
5522 SRT=VINT(1)
5523 SEPS=S**EPS
5524 SETA=S**ETA
5525 SLOG=LOG(S)
5526
5527C...Ratio of gamma/pi (for rescaling in parton distributions).
5528 VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/
5529 &(XPAR(5)*SEPS+YPAR(5)*SETA)
5530 VINT(317)=1D0
5531 IF(MINT(50).NE.1) RETURN
5532
5533C...Order flavours of incoming particles: KF1 < KF2.
5534 IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN
5535 KF1=IABS(MINT(11))
5536 KF2=IABS(MINT(12))
5537 IORD=1
5538 ELSE
5539 KF1=IABS(MINT(12))
5540 KF2=IABS(MINT(11))
5541 IORD=2
5542 ENDIF
5543 ISGN12=ISIGN(1,MINT(11)*MINT(12))
5544
5545C...Find process number (for lookup tables).
5546 IF(KF1.GT.1000) THEN
5547 IPROC=1
5548 IF(ISGN12.LT.0) IPROC=2
5549 ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN
5550 IPROC=3
5551 IF(ISGN12.LT.0) IPROC=4
5552 IF(KF1.EQ.111) IPROC=5
5553 ELSEIF(KF1.GT.100) THEN
5554 IPROC=11
5555 ELSEIF(KF2.GT.1000) THEN
5556 IPROC=21
5557 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=22
5558 ELSEIF(KF2.GT.100) THEN
5559 IPROC=23
5560 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=24
5561 ELSE
5562 IPROC=25
5563 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7) IPROC=26
5564 ENDIF
5565
5566C... Number of multiple processes to be stored; beam/target side.
5567 NPR=NPROC(IPROC)
5568 MINT(101)=1
5569 MINT(102)=1
5570 IF(NPR.EQ.3) THEN
5571 MINT(100+IORD)=4
5572 ELSEIF(NPR.EQ.6) THEN
5573 MINT(101)=4
5574 MINT(102)=4
5575 ENDIF
5576 N1=0
5577 IF(MINT(101).EQ.4) N1=4
5578 N2=0
5579 IF(MINT(102).EQ.4) N2=4
5580
5581C...Do not do any more for user-set or undefined cross-sections.
5582 IF(MSTP(31).LE.0) RETURN
5583 IF(NPR.EQ.0) CALL PYERRM(26,
5584 &'(PYXTOT:) cross section for this process not yet implemented')
5585
5586C...Parameters. Combinations of the energy.
5587 AEM=PARU(101)
5588 PMTH=PARP(102)
5589 S=VINT(2)
5590 SRT=VINT(1)
5591 SEPS=S**EPS
5592 SETA=S**ETA
5593 SLOG=LOG(S)
5594
5595C...Loop over multiple processes (for VDM).
5596 DO 110 I=1,NPR
5597 IF(NPR.EQ.1) THEN
5598 IPR=IPROC
5599 ELSEIF(NPR.EQ.3) THEN
5600 IPR=I+4
5601 IF(KF2.LT.1000) IPR=I+10
5602 ELSEIF(NPR.EQ.6) THEN
5603 IPR=I+10
5604 ENDIF
5605
5606C...Evaluate hadron species, mass, slope contribution and fit number.
5607 IHA=IHADA(IPR)
5608 IHB=IHADB(IPR)
5609 PMA=PMHAD(IHA)
5610 PMB=PMHAD(IHB)
5611 BHA=BHAD(IHA)
5612 BHB=BHAD(IHB)
5613 ISD=IFITSD(IPR)
5614 IDD=IFITDD(IPR)
5615
5616C...Skip if energy too low relative to masses.
5617 DO 100 J=0,5
5618 SIGTMP(I,J)=0D0
5619 100 CONTINUE
5620 IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110
5621
5622C...Total cross-section. Elastic slope parameter and cross-section.
5623 SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA
5624 BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0
5625 SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL
5626
5627C...Diffractive scattering A + B -> X + B.
5628 BSD=2D0*BHB
5629 SQML=(PMA+PMTH)**2
5630 SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2)
5631 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
5632 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
5633 BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
5634 SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/
5635 & (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
5636 SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2)
5637
5638C...Diffractive scattering A + B -> A + X.
5639 BSD=2D0*BHA
5640 SQML=(PMB+PMTH)**2
5641 SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6)
5642 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
5643 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
5644 BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
5645 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/
5646 & (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
5647 SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2)
5648
5649C...Order single diffractive correctly.
5650 IF(IORD.EQ.2) THEN
5651 SIGSAV=SIGTMP(I,2)
5652 SIGTMP(I,2)=SIGTMP(I,3)
5653 SIGTMP(I,3)=SIGSAV
5654 ENDIF
5655
5656C...Double diffractive scattering A + B -> X1 + X2.
5657 YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2)
5658 DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2
5659 SUM1=DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0)/(2D0*ALP)
5660 IF(YEFF.LE.0) SUM1=0D0
5661 SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2)
5662 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC))))
5663 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC))))
5664 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/
5665 & (2D0*ALP)
5666 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC))))
5667 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC))))
5668 SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/
5669 & (2D0*ALP)
5670 BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S
5671 SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB*PMRC)))
5672 SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*
5673 & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX)
5674 SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4)
5675
5676C...Non-diffractive by unitarity.
5677 SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)-
5678 & SIGTMP(I,4)
5679 110 CONTINUE
5680
5681C...Put temporary results in output array: only one process.
5682 IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN
5683 DO 120 J=0,5
5684 SIGT(0,0,J)=SIGTMP(1,J)
5685 120 CONTINUE
5686
5687C...Beam multiple processes.
5688 ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN
5689 IF(MINT(107).EQ.2) THEN
5690 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
5691 ELSE
5692 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
5693 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
5694 ENDIF
5695 IF(MSTP(20).GT.0) THEN
5696 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)))**MSTP(20)
5697 ENDIF
5698 DO 140 I=1,4
5699 IF(MINT(107).EQ.2) THEN
5700 CONV=(AEM/PARP(160+I))*VINT(317)
5701 ELSEIF(VINT(154).GT.PARP(15)) THEN
5702 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
5703 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
5704 ELSE
5705 CONV=0D0
5706 ENDIF
5707 I1=MAX(1,I-1)
5708 DO 130 J=0,5
5709 SIGT(I,0,J)=CONV*SIGTMP(I1,J)
5710 130 CONTINUE
5711 140 CONTINUE
5712 DO 150 J=0,5
5713 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
5714 150 CONTINUE
5715
5716C...Target multiple processes.
5717 ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN
5718 IF(MINT(108).EQ.2) THEN
5719 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
5720 ELSE
5721 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
5722 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
5723 ENDIF
5724 IF(MSTP(20).GT.0) THEN
5725 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(308)))**MSTP(20)
5726 ENDIF
5727 DO 170 I=1,4
5728 IF(MINT(108).EQ.2) THEN
5729 CONV=(AEM/PARP(160+I))*VINT(317)
5730 ELSEIF(VINT(154).GT.PARP(15)) THEN
5731 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
5732 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
5733 ELSE
5734 CONV=0D0
5735 ENDIF
5736 IV=MAX(1,I-1)
5737 DO 160 J=0,5
5738 SIGT(0,I,J)=CONV*SIGTMP(IV,J)
5739 160 CONTINUE
5740 170 CONTINUE
5741 DO 180 J=0,5
5742 SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J)
5743 180 CONTINUE
5744
5745C...Both beam and target multiple processes.
5746 ELSE
5747 IF(MINT(107).EQ.2) THEN
5748 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
5749 ELSE
5750 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
5751 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
5752 ENDIF
5753 IF(MINT(108).EQ.2) THEN
5754 VINT(317)=VINT(317)*(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
5755 ELSE
5756 VINT(317)=VINT(317)*16D0*PARP(15)**2*VINT(154)**2/
5757 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
5758 ENDIF
5759 IF(MSTP(20).GT.0) THEN
5760 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)+
5761 & VINT(308)))**MSTP(20)
5762 ENDIF
5763 DO 210 I1=1,4
5764 DO 200 I2=1,4
5765 IF(MINT(107).EQ.2) THEN
5766 CONV=(AEM/PARP(160+I1))*VINT(317)
5767 ELSEIF(VINT(154).GT.PARP(15)) THEN
5768 CONV=(AEM/PARU(1))*(KCHG(I1,1)/3D0)**2*PARP(18)**2*
5769 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
5770 ELSE
5771 CONV=0D0
5772 ENDIF
5773 IF(MINT(108).EQ.2) THEN
5774 CONV=CONV*(AEM/PARP(160+I2))
5775 ELSEIF(VINT(154).GT.PARP(15)) THEN
5776 CONV=CONV*(AEM/PARU(1))*(KCHG(I2,1)/3D0)**2*PARP(18)**2*
5777 & (1D0/PARP(15)**2-1D0/VINT(154)**2)
5778 ELSE
5779 CONV=0D0
5780 ENDIF
5781 IF(I1.LE.2) THEN
5782 IV=MAX(1,I2-1)
5783 ELSEIF(I2.LE.2) THEN
5784 IV=MAX(1,I1-1)
5785 ELSEIF(I1.EQ.I2) THEN
5786 IV=2*I1-2
5787 ELSE
5788 IV=5
5789 ENDIF
5790 DO 190 J=0,5
5791 JV=J
5792 IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J
5793 SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV)
5794 190 CONTINUE
5795 200 CONTINUE
5796 210 CONTINUE
5797 DO 230 J=0,5
5798 DO 220 I=1,4
5799 SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J)
5800 SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J)
5801 220 CONTINUE
5802 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
5803 230 CONTINUE
5804 ENDIF
5805
5806C...Scale up uniformly for Donnachie-Landshoff parametrization.
5807 IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN
5808 RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0)
5809 DO 260 I1=0,N1
5810 DO 250 I2=0,N2
5811 DO 240 J=0,5
5812 SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J)
5813 240 CONTINUE
5814 250 CONTINUE
5815 260 CONTINUE
5816 ENDIF
5817
5818 RETURN
5819 END
5820
5821C*********************************************************************
5822
5823C...PYMAXI
5824C...Finds optimal set of coefficients for kinematical variable selection
5825C...and the maximum of the part of the differential cross-section used
5826C...in the event weighting.
5827
5828 SUBROUTINE PYMAXI
5829
5830C...Double precision and integer declarations.
5831 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5832 IMPLICIT INTEGER(I-N)
5833 INTEGER PYK,PYCHGE,PYCOMP
5834C...Parameter statement to help give large particle numbers.
5835 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
5836 &KEXCIT=4000000,KDIMEN=5000000)
5837
5838C...User process initialization commonblock.
5839 INTEGER MAXPUP
5840 PARAMETER (MAXPUP=100)
5841 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5842 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5843 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5844 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5845 &LPRUP(MAXPUP)
5846 SAVE /HEPRUP/
5847
5848C...Commonblocks.
5849 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5850 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5851 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
5852 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5853 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5854 COMMON/PYINT1/MINT(400),VINT(400)
5855 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5856 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
5857 COMMON/PYINT4/MWID(500),WIDS(500,5)
5858 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5859 COMMON/PYINT6/PROC(0:500)
5860 CHARACTER PROC*28
5861 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
5862 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
5863 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/
5864C...Local arrays, character variables and data.
5865 CHARACTER CVAR(4)*4
5866 DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500),
5867 &NAREL(7),WTREL(7),WTMAT(7,7),WTRELN(7),COEFU(7),COEFO(7),
5868 &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2)
5869 DATA CVAR/'tau ','tau''','y* ','cth '/
5870 DATA SIGSSM/3*0D0/
5871
5872C...Initial values and loop over subprocesses.
5873 NPOSI=0
5874 VINT(143)=1D0
5875 VINT(144)=1D0
5876 XSEC(0,1)=0D0
5877 DO 460 ISUB=1,500
5878 MINT(1)=ISUB
5879 MINT(51)=0
5880
5881C...Find maximum weight factors for photon flux.
5882 IF(MSUB(ISUB).EQ.1.OR.(ISUB.GE.91.AND.ISUB.LE.100)) THEN
5883 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(2,WTGAGA)
5884 ENDIF
5885
5886C...Select subprocess to study: skip cases not applicable.
5887 IF(ISET(ISUB).EQ.11) THEN
5888 IF(MSUB(ISUB).NE.1) GOTO 460
5889C...User process intialization: cross section model dependent.
5890 IF(IABS(IDWTUP).EQ.1) THEN
5891 IF(IDWTUP.GT.0.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
5892 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
5893 XSEC(ISUB,1)=1.00000001D-9*ABS(XMAXUP(KFPR(ISUB,1)))
5894 ELSE
5895 IF((IDWTUP.EQ.2.OR.IDWTUP.EQ.3).AND.
5896 & XSECUP(KFPR(ISUB,1)).LT.0D0) CALL
5897 & PYERRM(26,'(PYMAXI:) Negative XSECUP for user process')
5898 IF(IDWTUP.EQ.2.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
5899 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
5900 XSEC(ISUB,1)=1.00000001D-9*ABS(XSECUP(KFPR(ISUB,1)))
5901 ENDIF
5902 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
5903 & WTGAGA*XSEC(ISUB,1)
5904 NPOSI=NPOSI+1
5905 GOTO 450
5906 ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN
5907 CALL PYSIGH(NCHN,SIGS)
5908 XSEC(ISUB,1)=SIGS
5909 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
5910 & WTGAGA*XSEC(ISUB,1)
5911 IF(MSUB(ISUB).NE.1) GOTO 460
5912 NPOSI=NPOSI+1
5913 GOTO 450
5914 ELSEIF(ISUB.EQ.99.AND.MSUB(ISUB).EQ.1) THEN
5915 CALL PYSIGH(NCHN,SIGS)
5916 XSEC(ISUB,1)=SIGS
5917 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
5918 & WTGAGA*XSEC(ISUB,1)
5919 IF(XSEC(ISUB,1).EQ.0D0) THEN
5920 MSUB(ISUB)=0
5921 ELSE
5922 NPOSI=NPOSI+1
5923 ENDIF
5924 GOTO 450
5925 ELSEIF(ISUB.EQ.96) THEN
5926 IF(MINT(50).EQ.0) GOTO 460
5927 IF(MSUB(95).NE.1.AND.MSTP(81).LE.0.AND.MSTP(131).LE.0)
5928 & GOTO 460
5929 IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460
5930 ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
5931 & ISUB.EQ.53.OR.ISUB.EQ.68) THEN
5932 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
5933 ELSEIF(ISUB.GE.381.AND.ISUB.LE.386) THEN
5934 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
5935 ELSE
5936 IF(MSUB(ISUB).NE.1) GOTO 460
5937 ENDIF
5938 ISTSB=ISET(ISUB)
5939 IF(ISUB.EQ.96) ISTSB=2
5940 IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB
5941 MWTXS=0
5942 IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+
5943 & MSUB(94)+MSUB(95).EQ.0) MWTXS=1
5944
5945C...Find resonances (explicit or implicit in cross-section).
5946 MINT(72)=0
5947 KFR1=0
5948 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
5949 KFR1=KFPR(ISUB,1)
5950 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165
5951 & .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
5952 KFR1=23
5953 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172
5954 & .OR.ISUB.EQ.177) THEN
5955 KFR1=24
5956 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
5957 KFR1=25
5958 IF(MSTP(46).EQ.5) THEN
5959 KFR1=89
5960 PMAS(89,1)=PARP(45)
5961 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
5962 ENDIF
5963 ELSEIF(ISUB.EQ.194) THEN
5964 KFR1=KTECHN+113
5965 ELSEIF(ISUB.EQ.195) THEN
5966 KFR1=KTECHN+213
5967 ELSEIF(ISUB.GE.361.AND.ISUB.LE.368) THEN
5968 KFR1=KTECHN+113
5969 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
5970 KFR1=KTECHN+213
5971 ENDIF
5972 CKMX=CKIN(2)
5973 IF(CKMX.LE.0D0) CKMX=VINT(1)
5974 KCR1=PYCOMP(KFR1)
5975 IF(KFR1.NE.0) THEN
5976 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
5977 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
5978 ENDIF
5979 IF(KFR1.NE.0) THEN
5980 TAUR1=PMAS(KCR1,1)**2/VINT(2)
5981 IF(KFR1.EQ.KTECHN+113) THEN
5982 CALL PYTECM(S1,S2)
5983 TAUR1=S1/VINT(2)
5984 ENDIF
5985 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
5986 MINT(72)=1
5987 MINT(73)=KFR1
5988 VINT(73)=TAUR1
5989 VINT(74)=GAMR1
5990 ENDIF
5991 KFR2=0
5992 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.(ISUB.GE.364.AND.ISUB.LE.368))
5993 $ THEN
5994 KFR2=23
5995 IF(ISUB.EQ.194) THEN
5996 KFR2=KTECHN+223
5997 ELSEIF(ISUB.GE.364.AND.ISUB.LE.368) THEN
5998 KFR2=KTECHN+223
5999 ENDIF
6000 KCR2=PYCOMP(KFR2)
6001 TAUR2=PMAS(KCR2,1)**2/VINT(2)
6002 IF(KFR2.EQ.KTECHN+223) THEN
6003 CALL PYTECM(S1,S2)
6004 TAUR2=S2/VINT(2)
6005 ENDIF
6006 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
6007 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
6008 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
6009 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
6010 MINT(72)=2
6011 MINT(74)=KFR2
6012 VINT(75)=TAUR2
6013 VINT(76)=GAMR2
6014 ELSEIF(KFR2.NE.0) THEN
6015 KFR1=KFR2
6016 TAUR1=TAUR2
6017 GAMR1=GAMR2
6018 MINT(72)=1
6019 MINT(73)=KFR1
6020 VINT(73)=TAUR1
6021 VINT(74)=GAMR1
6022 KFR2=0
6023 ENDIF
6024 ENDIF
6025
6026C...Find product masses and minimum pT of process.
6027 SQM3=0D0
6028 SQM4=0D0
6029 MINT(71)=0
6030 VINT(71)=CKIN(3)
6031 VINT(80)=1D0
6032 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
6033 NBW=0
6034 DO 110 I=1,2
6035 PMMN(I)=0D0
6036 IF(KFPR(ISUB,I).EQ.0) THEN
6037 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
6038 & PARP(41)) THEN
6039 IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
6040 IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
6041 ELSE
6042 NBW=NBW+1
6043C...This prevents SUSY/t particles from becoming too light.
6044 KFLW=KFPR(ISUB,I)
6045 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
6046 KCW=PYCOMP(KFLW)
6047 PMMN(I)=PMAS(KCW,1)
6048 DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
6049 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
6050 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
6051 & PMAS(PYCOMP(KFDP(IDC,2)),1)
6052 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
6053 & PMAS(PYCOMP(KFDP(IDC,3)),1)
6054 PMMN(I)=MIN(PMMN(I),PMSUM)
6055 ENDIF
6056 100 CONTINUE
6057 ELSEIF(KFLW.EQ.6) THEN
6058 PMMN(I)=PMAS(24,1)+PMAS(5,1)
6059 ENDIF
6060 ENDIF
6061 110 CONTINUE
6062 IF(NBW.GE.1) THEN
6063 CKIN41=CKIN(41)
6064 CKIN43=CKIN(43)
6065 CKIN(41)=MAX(PMMN(1),CKIN(41))
6066 CKIN(43)=MAX(PMMN(2),CKIN(43))
6067 CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
6068 CKIN(41)=CKIN41
6069 CKIN(43)=CKIN43
6070 IF(MINT(51).EQ.1) THEN
6071 WRITE(MSTU(11),5100) ISUB
6072 MSUB(ISUB)=0
6073 GOTO 460
6074 ENDIF
6075 SQM3=PQM3**2
6076 SQM4=PQM4**2
6077 ENDIF
6078 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
6079 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
6080 IF(ISUB.EQ.96.AND.MSTP(82).LE.1) THEN
6081 VINT(71)=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
6082 ELSEIF(ISUB.EQ.96) THEN
6083 VINT(71)=0.08D0*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
6084 ENDIF
6085 ENDIF
6086 VINT(63)=SQM3
6087 VINT(64)=SQM4
6088
6089C...Prepare for additional variable choices in 2 -> 3.
6090 IF(ISTSB.EQ.5) THEN
6091 VINT(201)=0D0
6092 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
6093 VINT(206)=VINT(201)
6094 VINT(204)=PMAS(23,1)
6095 IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
6096 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
6097 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182
6098 & .OR.ISUB.EQ.186.OR.ISUB.EQ.187) VINT(204)=VINT(201)
6099 VINT(209)=VINT(204)
6100 ENDIF
6101
6102C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
6103 NPTS(1)=2+2*MINT(72)
6104 IF(MINT(47).EQ.1) THEN
6105 IF(ISTSB.EQ.1.OR.ISTSB.EQ.2) NPTS(1)=1
6106 ELSEIF(MINT(47).GE.5) THEN
6107 IF(ISTSB.LE.2.OR.ISTSB.GT.5) NPTS(1)=NPTS(1)+1
6108 ENDIF
6109 NPTS(2)=1
6110 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
6111 IF(MINT(47).GE.2) NPTS(2)=2
6112 IF(MINT(47).GE.5) NPTS(2)=3
6113 ENDIF
6114 NPTS(3)=1
6115 IF(MINT(47).EQ.4.OR.MINT(47).EQ.5) THEN
6116 NPTS(3)=3
6117 IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1
6118 IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1
6119 ENDIF
6120 NPTS(4)=1
6121 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
6122 NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
6123
6124C...Reset coefficients of cross-section weighting.
6125 DO 120 J=1,20
6126 COEF(ISUB,J)=0D0
6127 120 CONTINUE
6128 COEF(ISUB,1)=1D0
6129 COEF(ISUB,8)=0.5D0
6130 COEF(ISUB,9)=0.5D0
6131 COEF(ISUB,13)=1D0
6132 COEF(ISUB,18)=1D0
6133 MCTH=0
6134 MTAUP=0
6135 METAUP=0
6136 VINT(23)=0D0
6137 VINT(26)=0D0
6138 SIGSAM=0D0
6139
6140C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
6141C...in grid of phase space points.
6142 CALL PYKLIM(1)
6143 METAU=MINT(51)
6144 NACC=0
6145 DO 150 ITRY=1,NTRY
6146 MINT(51)=0
6147 IF(METAU.EQ.1) GOTO 150
6148 IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
6149 MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
6150 IF(MTAU.GT.2+2*MINT(72)) MTAU=7
6151 RTAU=0.5D0
6152C...Special case when both resonances have same mass,
6153C...as is often the case in process 194.
6154 IF(MINT(72).EQ.2) THEN
6155 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
6156 & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
6157 IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
6158 RTAU=0.4D0
6159 ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
6160 RTAU=0.6D0
6161 ENDIF
6162 ENDIF
6163 ENDIF
6164 CALL PYKMAP(1,MTAU,RTAU)
6165 IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4)
6166 METAUP=MINT(51)
6167 ENDIF
6168 IF(METAUP.EQ.1) GOTO 150
6169 IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4))
6170 & .EQ.0) THEN
6171 MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
6172 CALL PYKMAP(4,MTAUP,0.5D0)
6173 ENDIF
6174 IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN
6175 CALL PYKLIM(2)
6176 MEYST=MINT(51)
6177 ENDIF
6178 IF(MEYST.EQ.1) GOTO 150
6179 IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
6180 MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
6181 IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5
6182 CALL PYKMAP(2,MYST,0.5D0)
6183 CALL PYKLIM(3)
6184 MECTH=MINT(51)
6185 ENDIF
6186 IF(MECTH.EQ.1) GOTO 150
6187 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
6188 MCTH=1+MOD(ITRY-1,NPTS(4))
6189 CALL PYKMAP(3,MCTH,0.5D0)
6190 ENDIF
6191 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2)
6192
6193C...Store position and limits.
6194 MINT(51)=0
6195 CALL PYKLIM(0)
6196 IF(MINT(51).EQ.1) GOTO 150
6197 NACC=NACC+1
6198 MVARPT(NACC,1)=MTAU
6199 MVARPT(NACC,2)=MTAUP
6200 MVARPT(NACC,3)=MYST
6201 MVARPT(NACC,4)=MCTH
6202 DO 130 J=1,30
6203 VINTPT(NACC,J)=VINT(10+J)
6204 130 CONTINUE
6205
6206C...Normal case: calculate cross-section.
6207 IF(ISTSB.NE.5) THEN
6208 CALL PYSIGH(NCHN,SIGS)
6209 IF(MWTXS.EQ.1) THEN
6210 CALL PYEVWT(WTXS)
6211 SIGS=WTXS*SIGS
6212 ENDIF
6213
6214C..2 -> 3: find highest value out of a number of tries.
6215 ELSE
6216 SIGS=0D0
6217 DO 140 IKIN3=1,MSTP(129)
6218 CALL PYKMAP(5,0,0D0)
6219 IF(MINT(51).EQ.1) GOTO 140
6220 CALL PYSIGH(NCHN,SIGTMP)
6221 IF(MWTXS.EQ.1) THEN
6222 CALL PYEVWT(WTXS)
6223 SIGTMP=WTXS*SIGTMP
6224 ENDIF
6225 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
6226 140 CONTINUE
6227 ENDIF
6228
6229C...Store cross-section.
6230 SIGSPT(NACC)=SIGS
6231 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
6232 IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP,
6233 & VINT(21),VINT(22),VINT(23),VINT(26),SIGS
6234 150 CONTINUE
6235 IF(NACC.EQ.0) THEN
6236 WRITE(MSTU(11),5100) ISUB
6237 MSUB(ISUB)=0
6238 GOTO 460
6239 ELSEIF(SIGSAM.EQ.0D0) THEN
6240 WRITE(MSTU(11),5300) ISUB
6241 MSUB(ISUB)=0
6242 GOTO 460
6243 ENDIF
6244 IF(ISUB.NE.96) NPOSI=NPOSI+1
6245
6246C...Calculate integrals in tau over maximal phase space limits.
6247 TAUMIN=VINT(11)
6248 TAUMAX=VINT(31)
6249 ATAU1=LOG(TAUMAX/TAUMIN)
6250 IF(NPTS(1).GE.2) THEN
6251 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
6252 ENDIF
6253 IF(NPTS(1).GE.4) THEN
6254 ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
6255 ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
6256 & GAMR1
6257 ENDIF
6258 IF(NPTS(1).GE.6) THEN
6259 ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
6260 ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
6261 & GAMR2
6262 ENDIF
6263 IF(NPTS(1).GT.2+2*MINT(72)) THEN
6264 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
6265 ENDIF
6266
6267C...Reset. Sum up cross-sections in points calculated.
6268 DO 320 IVAR=1,4
6269 IF(NPTS(IVAR).EQ.1) GOTO 320
6270 IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320
6271 NBIN=NPTS(IVAR)
6272 DO 170 J1=1,NBIN
6273 NAREL(J1)=0
6274 WTREL(J1)=0D0
6275 COEFU(J1)=0D0
6276 DO 160 J2=1,NBIN
6277 WTMAT(J1,J2)=0D0
6278 160 CONTINUE
6279 170 CONTINUE
6280 DO 180 IACC=1,NACC
6281 IBIN=MVARPT(IACC,IVAR)
6282 IF(IVAR.EQ.1.AND.IBIN.EQ.7) IBIN=3+2*MINT(72)
6283 IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4
6284 NAREL(IBIN)=NAREL(IBIN)+1
6285 WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
6286
6287C...Sum up tau cross-section pieces in points used.
6288 IF(IVAR.EQ.1) THEN
6289 TAU=VINTPT(IACC,11)
6290 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
6291 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
6292 IF(NBIN.GE.4) THEN
6293 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
6294 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
6295 & ((TAU-TAUR1)**2+GAMR1**2)
6296 ENDIF
6297 IF(NBIN.GE.6) THEN
6298 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
6299 WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
6300 & ((TAU-TAUR2)**2+GAMR2**2)
6301 ENDIF
6302 IF(NBIN.GT.2+2*MINT(72)) THEN
6303 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(ATAU1/ATAU7)*
6304 & TAU/MAX(2D-10,1D0-TAU)
6305 ENDIF
6306
6307C...Sum up tau' cross-section pieces in points used.
6308 ELSEIF(IVAR.EQ.2) THEN
6309 TAU=VINTPT(IACC,11)
6310 TAUP=VINTPT(IACC,16)
6311 TAUPMN=VINTPT(IACC,6)
6312 TAUPMX=VINTPT(IACC,26)
6313 ATAUP1=LOG(TAUPMX/TAUPMN)
6314 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
6315 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
6316 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*
6317 & (1D0-TAU/TAUP)**3/TAUP
6318 IF(NBIN.GE.3) THEN
6319 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
6320 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)*
6321 & TAUP/MAX(2D-10,1D0-TAUP)
6322 ENDIF
6323
6324C...Sum up y* cross-section pieces in points used.
6325 ELSEIF(IVAR.EQ.3) THEN
6326 YST=VINTPT(IACC,12)
6327 YSTMIN=VINTPT(IACC,2)
6328 YSTMAX=VINTPT(IACC,22)
6329 AYST0=YSTMAX-YSTMIN
6330 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
6331 AYST2=AYST1
6332 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
6333 WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
6334 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST)
6335 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
6336 IF(MINT(45).EQ.3) THEN
6337 TAUE=VINTPT(IACC,11)
6338 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
6339 YST0=-0.5D0*LOG(TAUE)
6340 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
6341 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
6342 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/
6343 & MAX(1D-10,1D0-EXP(YST-YST0))
6344 ENDIF
6345 IF(MINT(46).EQ.3) THEN
6346 TAUE=VINTPT(IACC,11)
6347 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
6348 YST0=-0.5D0*LOG(TAUE)
6349 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
6350 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
6351 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/
6352 & MAX(1D-10,1D0-EXP(-YST-YST0))
6353 ENDIF
6354
6355C...Sum up cos(theta-hat) cross-section pieces in points used.
6356 ELSE
6357 RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2)
6358 RSQM=1D0+RM34
6359 CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2)))
6360 CTHMIN=-CTHMAX
6361 IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/
6362 & (TAUMAX*VINT(2)))
6363 ACTH1=CTHMAX-CTHMIN
6364 ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
6365 ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
6366 ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
6367 ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
6368 CTH=VINTPT(IACC,13)
6369 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
6370 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
6371 & MAX(RM34,RSQM-CTH)
6372 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
6373 & MAX(RM34,RSQM+CTH)
6374 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
6375 & MAX(RM34,RSQM-CTH)**2
6376 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
6377 & MAX(RM34,RSQM+CTH)**2
6378 ENDIF
6379 180 CONTINUE
6380
6381C...Check that equation system solvable.
6382 IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
6383 MSOLV=1
6384 WTRELS=0D0
6385 DO 190 IBIN=1,NBIN
6386 IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
6387 & IRED=1,NBIN),WTREL(IBIN)
6388 IF(NAREL(IBIN).EQ.0) MSOLV=0
6389 WTRELS=WTRELS+WTREL(IBIN)
6390 190 CONTINUE
6391 IF(ABS(WTRELS).LT.1D-20) MSOLV=0
6392
6393C...Solve to find relative importance of cross-section pieces.
6394 IF(MSOLV.EQ.1) THEN
6395 DO 200 IBIN=1,NBIN
6396 WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
6397 200 CONTINUE
6398 DO 230 IRED=1,NBIN-1
6399 DO 220 IBIN=IRED+1,NBIN
6400 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
6401 MSOLV=0
6402 GOTO 260
6403 ENDIF
6404 RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
6405 WTREL(IBIN)=WTREL(IBIN)-RQT*WTREL(IRED)
6406 DO 210 ICOE=IRED,NBIN
6407 WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-RQT*WTMAT(IRED,ICOE)
6408 210 CONTINUE
6409 220 CONTINUE
6410 230 CONTINUE
6411 DO 250 IRED=NBIN,1,-1
6412 DO 240 ICOE=IRED+1,NBIN
6413 WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
6414 240 CONTINUE
6415 COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
6416 250 CONTINUE
6417 ENDIF
6418
6419C...Share evenly if failure.
6420 260 IF(MSOLV.EQ.0) THEN
6421 DO 270 IBIN=1,NBIN
6422 COEFU(IBIN)=1D0
6423 WTRELN(IBIN)=0.1D0
6424 IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0,
6425 & WTREL(IBIN)/WTRELS)
6426 270 CONTINUE
6427 ENDIF
6428
6429C...Normalize coefficients, with piece shared democratically.
6430 COEFSU=0D0
6431 WTRELS=0D0
6432 DO 280 IBIN=1,NBIN
6433 COEFU(IBIN)=MAX(0D0,COEFU(IBIN))
6434 COEFSU=COEFSU+COEFU(IBIN)
6435 WTRELS=WTRELS+WTRELN(IBIN)
6436 280 CONTINUE
6437 IF(COEFSU.GT.0D0) THEN
6438 DO 290 IBIN=1,NBIN
6439 COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0*
6440 & (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS)
6441 290 CONTINUE
6442 ELSE
6443 DO 300 IBIN=1,NBIN
6444 COEFO(IBIN)=1D0/NBIN
6445 300 CONTINUE
6446 ENDIF
6447 IF(IVAR.EQ.1) IOFF=0
6448 IF(IVAR.EQ.2) IOFF=17
6449 IF(IVAR.EQ.3) IOFF=7
6450 IF(IVAR.EQ.4) IOFF=12
6451 DO 310 IBIN=1,NBIN
6452 ICOF=IOFF+IBIN
6453 IF(IVAR.EQ.1.AND.IBIN.GT.2+2*MINT(72)) ICOF=7
6454 IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
6455 COEF(ISUB,ICOF)=COEFO(IBIN)
6456 310 CONTINUE
6457 IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR),
6458 & (COEFO(IBIN),IBIN=1,NBIN)
6459 320 CONTINUE
6460
6461C...Find two most promising maxima among points previously determined.
6462 DO 330 J=1,4
6463 IACCMX(J)=0
6464 SIGSMX(J)=0D0
6465 330 CONTINUE
6466 NMAX=0
6467 DO 390 IACC=1,NACC
6468 DO 340 J=1,30
6469 VINT(10+J)=VINTPT(IACC,J)
6470 340 CONTINUE
6471 IF(ISTSB.NE.5) THEN
6472 CALL PYSIGH(NCHN,SIGS)
6473 IF(MWTXS.EQ.1) THEN
6474 CALL PYEVWT(WTXS)
6475 SIGS=WTXS*SIGS
6476 ENDIF
6477 ELSE
6478 SIGS=0D0
6479 DO 350 IKIN3=1,MSTP(129)
6480 CALL PYKMAP(5,0,0D0)
6481 IF(MINT(51).EQ.1) GOTO 350
6482 CALL PYSIGH(NCHN,SIGTMP)
6483 IF(MWTXS.EQ.1) THEN
6484 CALL PYEVWT(WTXS)
6485 SIGTMP=WTXS*SIGTMP
6486 ENDIF
6487 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
6488 350 CONTINUE
6489 ENDIF
6490 IEQ=0
6491 DO 360 IMV=1,NMAX
6492 IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
6493 360 CONTINUE
6494 IF(IEQ.EQ.0) THEN
6495 DO 370 IMV=NMAX,1,-1
6496 IIN=IMV+1
6497 IF(SIGS.LE.SIGSMX(IMV)) GOTO 380
6498 IACCMX(IMV+1)=IACCMX(IMV)
6499 SIGSMX(IMV+1)=SIGSMX(IMV)
6500 370 CONTINUE
6501 IIN=1
6502 380 IACCMX(IIN)=IACC
6503 SIGSMX(IIN)=SIGS
6504 IF(NMAX.LE.1) NMAX=NMAX+1
6505 ENDIF
6506 390 CONTINUE
6507
6508C...Read out starting position for search.
6509 IF(MSTP(122).GE.2) WRITE(MSTU(11),5700)
6510 SIGSAM=SIGSMX(1)
6511 DO 440 IMAX=1,NMAX
6512 IACC=IACCMX(IMAX)
6513 MTAU=MVARPT(IACC,1)
6514 MTAUP=MVARPT(IACC,2)
6515 MYST=MVARPT(IACC,3)
6516 MCTH=MVARPT(IACC,4)
6517 VTAU=0.5D0
6518 VYST=0.5D0
6519 VCTH=0.5D0
6520 VTAUP=0.5D0
6521
6522C...Starting point and step size in parameter space.
6523 DO 430 IRPT=1,2
6524 DO 420 IVAR=1,4
6525 IF(NPTS(IVAR).EQ.1) GOTO 420
6526 IF(IVAR.EQ.1) VVAR=VTAU
6527 IF(IVAR.EQ.2) VVAR=VTAUP
6528 IF(IVAR.EQ.3) VVAR=VYST
6529 IF(IVAR.EQ.4) VVAR=VCTH
6530 IF(IVAR.EQ.1) MVAR=MTAU
6531 IF(IVAR.EQ.2) MVAR=MTAUP
6532 IF(IVAR.EQ.3) MVAR=MYST
6533 IF(IVAR.EQ.4) MVAR=MCTH
6534 IF(IRPT.EQ.1) VDEL=0.1D0
6535 IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0,
6536 & 0.98D0-VVAR))
6537 IF(IRPT.EQ.1) VMAR=0.02D0
6538 IF(IRPT.EQ.2) VMAR=0.002D0
6539 IMOV0=1
6540 IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
6541 DO 410 IMOV=IMOV0,8
6542
6543C...Define new point in parameter space.
6544 IF(IMOV.EQ.0) THEN
6545 INEW=2
6546 VNEW=VVAR
6547 ELSEIF(IMOV.EQ.1) THEN
6548 INEW=3
6549 VNEW=VVAR+VDEL
6550 ELSEIF(IMOV.EQ.2) THEN
6551 INEW=1
6552 VNEW=VVAR-VDEL
6553 ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
6554 & VVAR+2D0*VDEL.LT.1D0-VMAR) THEN
6555 VVAR=VVAR+VDEL
6556 SIGSSM(1)=SIGSSM(2)
6557 SIGSSM(2)=SIGSSM(3)
6558 INEW=3
6559 VNEW=VVAR+VDEL
6560 ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
6561 & VVAR-2D0*VDEL.GT.VMAR) THEN
6562 VVAR=VVAR-VDEL
6563 SIGSSM(3)=SIGSSM(2)
6564 SIGSSM(2)=SIGSSM(1)
6565 INEW=1
6566 VNEW=VVAR-VDEL
6567 ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
6568 VDEL=0.5D0*VDEL
6569 VVAR=VVAR+VDEL
6570 SIGSSM(1)=SIGSSM(2)
6571 INEW=2
6572 VNEW=VVAR
6573 ELSE
6574 VDEL=0.5D0*VDEL
6575 VVAR=VVAR-VDEL
6576 SIGSSM(3)=SIGSSM(2)
6577 INEW=2
6578 VNEW=VVAR
6579 ENDIF
6580
6581C...Convert to relevant variables and find derived new limits.
6582 ILERR=0
6583 IF(IVAR.EQ.1) THEN
6584 VTAU=VNEW
6585 CALL PYKMAP(1,MTAU,VTAU)
6586 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
6587 CALL PYKLIM(4)
6588 IF(MINT(51).EQ.1) ILERR=1
6589 ENDIF
6590 ENDIF
6591 IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
6592 & ILERR.EQ.0) THEN
6593 IF(IVAR.EQ.2) VTAUP=VNEW
6594 CALL PYKMAP(4,MTAUP,VTAUP)
6595 ENDIF
6596 IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
6597 CALL PYKLIM(2)
6598 IF(MINT(51).EQ.1) ILERR=1
6599 ENDIF
6600 IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
6601 IF(IVAR.EQ.3) VYST=VNEW
6602 CALL PYKMAP(2,MYST,VYST)
6603 CALL PYKLIM(3)
6604 IF(MINT(51).EQ.1) ILERR=1
6605 ENDIF
6606 IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
6607 & ILERR.EQ.0) THEN
6608 IF(IVAR.EQ.4) VCTH=VNEW
6609 CALL PYKMAP(3,MCTH,VCTH)
6610 ENDIF
6611 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
6612
6613C...Evaluate cross-section. Save new maximum. Final maximum.
6614 IF(ILERR.NE.0) THEN
6615 SIGS=0.
6616 ELSEIF(ISTSB.NE.5) THEN
6617 CALL PYSIGH(NCHN,SIGS)
6618 IF(MWTXS.EQ.1) THEN
6619 CALL PYEVWT(WTXS)
6620 SIGS=WTXS*SIGS
6621 ENDIF
6622 ELSE
6623 SIGS=0D0
6624 DO 400 IKIN3=1,MSTP(129)
6625 CALL PYKMAP(5,0,0D0)
6626 IF(MINT(51).EQ.1) GOTO 400
6627 CALL PYSIGH(NCHN,SIGTMP)
6628 IF(MWTXS.EQ.1) THEN
6629 CALL PYEVWT(WTXS)
6630 SIGTMP=WTXS*SIGTMP
6631 ENDIF
6632 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
6633 400 CONTINUE
6634 ENDIF
6635 SIGSSM(INEW)=SIGS
6636 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
6637 IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
6638 & IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
6639 410 CONTINUE
6640 420 CONTINUE
6641 430 CONTINUE
6642 440 CONTINUE
6643 IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
6644 XSEC(ISUB,1)=1.05D0*SIGSAM
6645 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
6646 & WTGAGA*XSEC(ISUB,1)
6647 450 CONTINUE
6648 IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
6649 & PARP(174)*XSEC(ISUB,1)
6650 IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
6651 460 CONTINUE
6652 MINT(51)=0
6653
6654C...Print summary table.
6655 IF(MINT(121).EQ.1.AND.NPOSI.EQ.0) THEN
6656 IF(MSTP(127).NE.1) THEN
6657 WRITE(MSTU(11),5900)
6658 STOP
6659 ELSE
6660 WRITE(MSTU(11),6400)
6661 MSTI(53)=1
6662 ENDIF
6663 ENDIF
6664 IF(MSTP(122).GE.1) THEN
6665 WRITE(MSTU(11),6000)
6666 WRITE(MSTU(11),6100)
6667 DO 470 ISUB=1,500
6668 IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470
6669 IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470
6670 IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MSTP(81).LE.0) GOTO 470
6671 IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470
6672 IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13
6673 & .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470
6674 IF(MSUB(95).EQ.1.AND.ISUB.GE.381.AND.ISUB.LE.386) GOTO 470
6675 WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1)
6676 470 CONTINUE
6677 WRITE(MSTU(11),6300)
6678 ENDIF
6679
6680C...Format statements for maximization results.
6681 5000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
6682 &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X,
6683 &'cth',9X,'tau''',7X,'sigma')
6684 5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ',
6685 &'phase space.'/1X,'Process switched off!')
6686 5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4)
6687 5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ',
6688 &'cross-section.'/1X,'Process switched off!')
6689 5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
6690 5500 FORMAT(1X,1P,8D11.3)
6691 5600 FORMAT(1X,'Result for ',A4,':',7F9.4)
6692 5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
6693 &'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
6694 5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4)
6695 5900 FORMAT(1X,'Error: no requested process has non-vanishing ',
6696 &'cross-section.'/1X,'Execution stopped!')
6697 6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
6698 &'cross-section maximum search',1X,8('*'))
6699 6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ',
6700 &'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I',
6701 &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
6702 6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I')
6703 6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
6704 6400 FORMAT(1X,'Error: no requested process has non-vanishing ',
6705 &'cross-section.'/
6706 &1X,'Execution will stop if you try to generate events.')
6707
6708 RETURN
6709 END
6710
6711C*********************************************************************
6712
6713C...PYPILE
6714C...Initializes multiplicity distribution and selects mutliplicity
6715C...of pileup events, i.e. several events occuring at the same
6716C...beam crossing.
6717
6718 SUBROUTINE PYPILE(MPILE)
6719
6720C...Double precision and integer declarations.
6721 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6722 IMPLICIT INTEGER(I-N)
6723 INTEGER PYK,PYCHGE,PYCOMP
6724C...Commonblocks.
6725 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6726 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6727 COMMON/PYINT1/MINT(400),VINT(400)
6728 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
6729 SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
6730C...Local arrays and saved variables.
6731 DIMENSION WTI(0:200)
6732 SAVE IMIN,IMAX,WTI,WTS
6733
6734C...Sum of allowed cross-sections for pileup events.
6735 IF(MPILE.EQ.1) THEN
6736 VINT(131)=SIGT(0,0,5)
6737 IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
6738 IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
6739 IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
6740 IF(MSTP(133).LE.0) RETURN
6741
6742C...Initialize multiplicity distribution at maximum.
6743 XNAVE=VINT(131)*PARP(131)
6744 IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
6745 INAVE=MAX(1,MIN(200,NINT(XNAVE)))
6746 WTI(INAVE)=1D0
6747 WTS=WTI(INAVE)
6748 WTN=WTI(INAVE)*INAVE
6749
6750C...Find shape of multiplicity distribution below maximum.
6751 IMIN=INAVE
6752 DO 100 I=INAVE-1,1,-1
6753 IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
6754 IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
6755 IF(WTI(I).LT.1D-6) GOTO 110
6756 WTS=WTS+WTI(I)
6757 WTN=WTN+WTI(I)*I
6758 IMIN=I
6759 100 CONTINUE
6760
6761C...Find shape of multiplicity distribution above maximum.
6762 110 IMAX=INAVE
6763 DO 120 I=INAVE+1,200
6764 IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
6765 IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
6766 IF(WTI(I).LT.1D-6) GOTO 130
6767 WTS=WTS+WTI(I)
6768 WTN=WTN+WTI(I)*I
6769 IMAX=I
6770 120 CONTINUE
6771 130 VINT(132)=XNAVE
6772 VINT(133)=WTN/WTS
6773 IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
6774 & WTS/(WTS+WTI(1)/XNAVE)
6775 IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
6776 IF(MSTP(133).GE.2) VINT(134)=XNAVE
6777
6778C...Pick multiplicity of pileup events.
6779 ELSE
6780 IF(MSTP(133).LE.0) THEN
6781 MINT(81)=MAX(1,MSTP(134))
6782 ELSE
6783 WTR=WTS*PYR(0)
6784 DO 140 I=IMIN,IMAX
6785 MINT(81)=I
6786 WTR=WTR-WTI(I)
6787 IF(WTR.LE.0D0) GOTO 150
6788 140 CONTINUE
6789 150 CONTINUE
6790 ENDIF
6791 ENDIF
6792
6793C...Format statement for error message.
6794 5000 FORMAT(1X,'Warning: requested average number of events per bunch',
6795 &'crossing too large, ',1P,D12.4)
6796
6797 RETURN
6798 END
6799
6800C*********************************************************************
6801
6802C...PYSAVE
6803C...Saves and restores parameter and cross section values for the
6804C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alternatives.
6805C...Also makes random choice between alternatives.
6806
6807 SUBROUTINE PYSAVE(ISAVE,IGA)
6808
6809C...Double precision and integer declarations.
6810 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6811 IMPLICIT INTEGER(I-N)
6812 INTEGER PYK,PYCHGE,PYCOMP
6813C...Commonblocks.
6814 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
6815 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6816 COMMON/PYINT1/MINT(400),VINT(400)
6817 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
6818 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6819 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
6820 SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/,/PYINT7/
6821C...Local arrays and saved variables.
6822 DIMENSION NCP(15),NSUBCP(15,20),MSUBCP(15,20),COEFCP(15,20,20),
6823 &NGENCP(15,0:20,3),XSECCP(15,0:20,3),SIGTCP(15,0:6,0:6,0:5),
6824 &INTCP(15,20),RECP(15,20)
6825 SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,SIGTCP,INTCP,RECP
6826
6827C...Save list of subprocesses and cross-section information.
6828 IF(ISAVE.EQ.1) THEN
6829 ICP=0
6830 DO 120 I=1,500
6831 IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
6832 ICP=ICP+1
6833 NSUBCP(IGA,ICP)=I
6834 MSUBCP(IGA,ICP)=MSUB(I)
6835 DO 100 J=1,20
6836 COEFCP(IGA,ICP,J)=COEF(I,J)
6837 100 CONTINUE
6838 DO 110 J=1,3
6839 NGENCP(IGA,ICP,J)=NGEN(I,J)
6840 XSECCP(IGA,ICP,J)=XSEC(I,J)
6841 110 CONTINUE
6842 120 CONTINUE
6843 NCP(IGA)=ICP
6844 DO 130 J=1,3
6845 NGENCP(IGA,0,J)=NGEN(0,J)
6846 XSECCP(IGA,0,J)=XSEC(0,J)
6847 130 CONTINUE
6848 DO 160 I1=0,6
6849 DO 150 I2=0,6
6850 DO 140 J=0,5
6851 SIGTCP(IGA,I1,I2,J)=SIGT(I1,I2,J)
6852 140 CONTINUE
6853 150 CONTINUE
6854 160 CONTINUE
6855
6856C...Save various common process variables.
6857 DO 170 J=1,10
6858 INTCP(IGA,J)=MINT(40+J)
6859 170 CONTINUE
6860 INTCP(IGA,11)=MINT(101)
6861 INTCP(IGA,12)=MINT(102)
6862 INTCP(IGA,13)=MINT(107)
6863 INTCP(IGA,14)=MINT(108)
6864 INTCP(IGA,15)=MINT(123)
6865 RECP(IGA,1)=CKIN(3)
6866 RECP(IGA,2)=VINT(318)
6867
6868C...Save cross-section information only.
6869 ELSEIF(ISAVE.EQ.2) THEN
6870 DO 190 ICP=1,NCP(IGA)
6871 I=NSUBCP(IGA,ICP)
6872 DO 180 J=1,3
6873 NGENCP(IGA,ICP,J)=NGEN(I,J)
6874 XSECCP(IGA,ICP,J)=XSEC(I,J)
6875 180 CONTINUE
6876 190 CONTINUE
6877 DO 200 J=1,3
6878 NGENCP(IGA,0,J)=NGEN(0,J)
6879 XSECCP(IGA,0,J)=XSEC(0,J)
6880 200 CONTINUE
6881
6882C...Choose between allowed alternatives.
6883 ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
6884 IF(ISAVE.EQ.4) THEN
6885 XSUMCP=0D0
6886 DO 210 IG=1,MINT(121)
6887 XSUMCP=XSUMCP+XSECCP(IG,0,1)
6888 210 CONTINUE
6889 XSUMCP=XSUMCP*PYR(0)
6890 DO 220 IG=1,MINT(121)
6891 IGA=IG
6892 XSUMCP=XSUMCP-XSECCP(IG,0,1)
6893 IF(XSUMCP.LE.0D0) GOTO 230
6894 220 CONTINUE
6895 230 CONTINUE
6896 ENDIF
6897
6898C...Restore cross-section information.
6899 DO 240 I=1,500
6900 MSUB(I)=0
6901 240 CONTINUE
6902 DO 270 ICP=1,NCP(IGA)
6903 I=NSUBCP(IGA,ICP)
6904 MSUB(I)=MSUBCP(IGA,ICP)
6905 DO 250 J=1,20
6906 COEF(I,J)=COEFCP(IGA,ICP,J)
6907 250 CONTINUE
6908 DO 260 J=1,3
6909 NGEN(I,J)=NGENCP(IGA,ICP,J)
6910 XSEC(I,J)=XSECCP(IGA,ICP,J)
6911 260 CONTINUE
6912 270 CONTINUE
6913 DO 280 J=1,3
6914 NGEN(0,J)=NGENCP(IGA,0,J)
6915 XSEC(0,J)=XSECCP(IGA,0,J)
6916 280 CONTINUE
6917 DO 310 I1=0,6
6918 DO 300 I2=0,6
6919 DO 290 J=0,5
6920 SIGT(I1,I2,J)=SIGTCP(IGA,I1,I2,J)
6921 290 CONTINUE
6922 300 CONTINUE
6923 310 CONTINUE
6924
6925C...Restore various common process variables.
6926 DO 320 J=1,10
6927 MINT(40+J)=INTCP(IGA,J)
6928 320 CONTINUE
6929 MINT(101)=INTCP(IGA,11)
6930 MINT(102)=INTCP(IGA,12)
6931 MINT(107)=INTCP(IGA,13)
6932 MINT(108)=INTCP(IGA,14)
6933 MINT(123)=INTCP(IGA,15)
6934 CKIN(3)=RECP(IGA,1)
6935 CKIN(1)=2D0*CKIN(3)
6936 VINT(318)=RECP(IGA,2)
6937
6938C...Sum up cross-section info (for PYSTAT).
6939 ELSEIF(ISAVE.EQ.5) THEN
6940 DO 330 I=1,500
6941 MSUB(I)=0
6942 NGEN(I,1)=0
6943 NGEN(I,3)=0
6944 XSEC(I,3)=0D0
6945 330 CONTINUE
6946 NGEN(0,1)=0
6947 NGEN(0,2)=0
6948 NGEN(0,3)=0
6949 XSEC(0,3)=0
6950 DO 350 IG=1,MINT(121)
6951 DO 340 ICP=1,NCP(IG)
6952 I=NSUBCP(IG,ICP)
6953 IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1
6954 NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1)
6955 NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3)
6956 XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3)
6957 340 CONTINUE
6958 NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1)
6959 NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2)
6960 NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3)
6961 XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3)
6962 350 CONTINUE
6963 ENDIF
6964
6965 RETURN
6966 END
6967
6968C*********************************************************************
6969
6970C...PYGAGA
6971C...For lepton beams it gives photon-hadron or photon-photon systems
6972C...to be treated with the ordinary machinery and combines this with a
6973C...description of the lepton -> lepton + photon branching.
6974
6975 SUBROUTINE PYGAGA(IGAGA,WTGAGA)
6976
6977C...Double precision and integer declarations.
6978 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6979 IMPLICIT INTEGER(I-N)
6980 INTEGER PYK,PYCHGE,PYCOMP
6981C...Commonblocks.
6982 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
6983 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6984 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6985 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
6986 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6987 COMMON/PYINT1/MINT(400),VINT(400)
6988 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6989 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
6990 &/PYINT5/
6991C...Local variables and data statement.
6992 DIMENSION PMS(2),XMIN(2),XMAX(2),Q2MIN(2),Q2MAX(2),PMC(3),
6993 &X(2),Q2(2),Y(2),THETA(2),PHI(2),PT(2),BETA(3)
6994 SAVE PMS,XMIN,XMAX,Q2MIN,Q2MAX,PMC,X,Q2,THETA,PHI,PT,W2MIN
6995 DATA EPS/1D-4/
6996
6997C...Initialize generation of photons inside leptons.
6998 IF(IGAGA.EQ.1) THEN
6999
7000C...Save quantities on incoming lepton system.
7001 VINT(301)=VINT(1)
7002 VINT(302)=VINT(2)
7003 PMS(1)=VINT(303)**2
7004 IF(MINT(141).EQ.0) PMS(1)=SIGN(VINT(3)**2,VINT(3))
7005 PMS(2)=VINT(304)**2
7006 IF(MINT(142).EQ.0) PMS(2)=SIGN(VINT(4)**2,VINT(4))
7007 PMC(3)=VINT(302)-PMS(1)-PMS(2)
7008 W2MIN=MAX(CKIN(77),2D0*CKIN(3),2D0*CKIN(5))**2
7009
7010C...Calculate range of x and Q2 values allowed in generation.
7011 DO 100 I=1,2
7012 PMC(I)=VINT(302)+PMS(I)-PMS(3-I)
7013 IF(MINT(140+I).NE.0) THEN
7014 XMIN(I)=MAX(CKIN(59+2*I),EPS)
7015 XMAX(I)=MIN(CKIN(60+2*I),1D0-2D0*VINT(301)*SQRT(PMS(I))/
7016 & PMC(I),1D0-EPS)
7017 YMIN=MAX(CKIN(71+2*I),EPS)
7018 YMAX=MIN(CKIN(72+2*I),1D0-EPS)
7019 IF(CKIN(64+2*I).GT.0D0) XMIN(I)=MAX(XMIN(I),
7020 & (YMIN*PMC(3)-CKIN(64+2*I))/PMC(I))
7021 XMAX(I)=MIN(XMAX(I),(YMAX*PMC(3)-CKIN(63+2*I))/PMC(I))
7022 THEMIN=MAX(CKIN(67+2*I),0D0)
7023 THEMAX=MIN(CKIN(68+2*I),PARU(1))
7024 IF(CKIN(68+2*I).LT.0D0) THEMAX=PARU(1)
7025 Q2MIN(I)=MAX(CKIN(63+2*I),XMIN(I)**2*PMS(I)/(1D0-XMIN(I))+
7026 & ((1D0-XMAX(I))*(VINT(302)-2D0*PMS(3-I))-
7027 & 2D0*PMS(I)/(1D0-XMAX(I)))*SIN(THEMIN/2D0)**2,0D0)
7028 Q2MAX(I)=XMAX(I)**2*PMS(I)/(1D0-XMAX(I))+
7029 & ((1D0-XMIN(I))*(VINT(302)-2D0*PMS(3-I))-
7030 & 2D0*PMS(I)/(1D0-XMIN(I)))*SIN(THEMAX/2D0)**2
7031 IF(CKIN(64+2*I).GT.0D0) Q2MAX(I)=MIN(CKIN(64+2*I),Q2MAX(I))
7032C...W limits when lepton on one side only.
7033 IF(MINT(143-I).EQ.0) THEN
7034 XMIN(I)=MAX(XMIN(I),(W2MIN-PMS(3-I))/PMC(I))
7035 IF(CKIN(78).GT.0D0) XMAX(I)=MIN(XMAX(I),
7036 & (CKIN(78)**2-PMS(3-I))/PMC(I))
7037 ENDIF
7038 ENDIF
7039 100 CONTINUE
7040
7041C...W limits when lepton on both sides.
7042 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
7043 IF(CKIN(78).GT.0D0) XMAX(1)=MIN(XMAX(1),
7044 & (CKIN(78)**2+PMC(3)-PMC(2)*XMIN(2))/PMC(1))
7045 IF(CKIN(78).GT.0D0) XMAX(2)=MIN(XMAX(2),
7046 & (CKIN(78)**2+PMC(3)-PMC(1)*XMIN(1))/PMC(2))
7047 IF(IABS(MINT(141)).NE.IABS(MINT(142))) THEN
7048 XMIN(1)=MAX(XMIN(1),(PMS(1)-PMS(2)+VINT(302)*(W2MIN-
7049 & PMS(1)-PMS(2))/(PMC(2)*XMAX(2)+PMS(1)-PMS(2)))/PMC(1))
7050 XMIN(2)=MAX(XMIN(2),(PMS(2)-PMS(1)+VINT(302)*(W2MIN-
7051 & PMS(1)-PMS(2))/(PMC(1)*XMAX(1)+PMS(2)-PMS(1)))/PMC(2))
7052 ELSE
7053 XMIN(1)=MAX(XMIN(1),W2MIN/(VINT(302)*XMAX(2)))
7054 XMIN(2)=MAX(XMIN(2),W2MIN/(VINT(302)*XMAX(1)))
7055 ENDIF
7056 ENDIF
7057
7058C...Q2 and W values and photon flux weight factors for initialization.
7059 ELSEIF(IGAGA.EQ.2) THEN
7060 ISUB=MINT(1)
7061 MINT(15)=0
7062 MINT(16)=0
7063
7064C...W value for photon on one or both sides, and for processes
7065C...with gamma-gamma cross section peaked at small shat.
7066 IF(MINT(141).NE.0.AND.MINT(142).EQ.0) THEN
7067 VINT(2)=VINT(302)+PMS(1)-PMC(1)*(1D0-XMAX(1))
7068 ELSEIF(MINT(141).EQ.0.AND.MINT(142).NE.0) THEN
7069 VINT(2)=VINT(302)+PMS(2)-PMC(2)*(1D0-XMAX(2))
7070 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
7071 VINT(2)=MAX(CKIN(77)**2,12D0*MAX(CKIN(3),CKIN(5))**2)
7072 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
7073 ELSE
7074 VINT(2)=XMAX(1)*XMAX(2)*VINT(302)
7075 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
7076 ENDIF
7077 VINT(1)=SQRT(MAX(0D0,VINT(2)))
7078
7079C...Upper estimate of photon flux weight factor.
7080C...Initialization Q2 scale. Flag incoming unresolved photon.
7081 WTGAGA=1D0
7082 DO 110 I=1,2
7083 IF(MINT(140+I).NE.0) THEN
7084 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
7085 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
7086 IF(ISUB.EQ.99.AND.MINT(106+I).EQ.4.AND.MINT(109-I).EQ.3)
7087 & THEN
7088 Q2INIT=5D0+Q2MIN(3-I)
7089 ELSEIF(ISUB.EQ.99.AND.MINT(106+I).EQ.4) THEN
7090 Q2INIT=PMAS(PYCOMP(113),1)**2+Q2MIN(3-I)
7091 ELSEIF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
7092 Q2INIT=MAX(CKIN(1),2D0*CKIN(3),2D0*CKIN(5))**2/3D0
7093 ELSEIF((ISUB.EQ.138.AND.I.EQ.2).OR.
7094 & (ISUB.EQ.139.AND.I.EQ.1)) THEN
7095 Q2INIT=VINT(2)/3D0
7096 ELSEIF(ISUB.EQ.140) THEN
7097 Q2INIT=VINT(2)/2D0
7098 ELSE
7099 Q2INIT=Q2MIN(I)
7100 ENDIF
7101 VINT(2+I)=-SQRT(MAX(Q2MIN(I),MIN(Q2MAX(I),Q2INIT)))
7102 IF(MSTP(14).EQ.0.OR.(ISUB.GE.131.AND.ISUB.LE.140))
7103 & MINT(14+I)=22
7104 VINT(306+I)=VINT(2+I)**2
7105 ENDIF
7106 110 CONTINUE
7107 VINT(320)=WTGAGA
7108
7109C...Update pTmin and cross section information.
7110 IF(MSTP(82).LE.1) THEN
7111 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
7112 ELSE
7113 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
7114 ENDIF
7115 VINT(149)=4D0*PTMN**2/VINT(2)
7116 VINT(154)=PTMN
7117 CALL PYXTOT
7118 VINT(318)=VINT(317)
7119
7120C...Generate photons inside leptons and
7121C...calculate photon flux weight factors.
7122 ELSEIF(IGAGA.EQ.3) THEN
7123 ISUB=MINT(1)
7124 MINT(15)=0
7125 MINT(16)=0
7126
7127C...Generate phase space point and check against cuts.
7128 LOOP=0
7129 120 LOOP=LOOP+1
7130 DO 130 I=1,2
7131 IF(MINT(140+I).NE.0) THEN
7132C...Pick x and Q2
7133 X(I)=XMIN(I)*(XMAX(I)/XMIN(I))**PYR(0)
7134 Q2(I)=Q2MIN(I)*(Q2MAX(I)/Q2MIN(I))**PYR(0)
7135C...Cuts on internal consistency in x and Q2.
7136 IF(Q2(I).LT.X(I)**2*PMS(I)/(1D0-X(I))) GOTO 120
7137 IF(Q2(I).GT.(1D0-X(I))*(VINT(302)-2D0*PMS(3-I))-
7138 & (2D0-X(I)**2)*PMS(I)/(1D0-X(I))) GOTO 120
7139C...Cuts on y and theta.
7140 Y(I)=(PMC(I)*X(I)+Q2(I))/PMC(3)
7141 IF(Y(I).LT.CKIN(71+2*I).OR.Y(I).GT.CKIN(72+2*I)) GOTO 120
7142 RAT=((1D0-X(I))*Q2(I)-X(I)**2*PMS(I))/
7143 & ((1D0-X(I))**2*(VINT(302)-2D0*PMS(3-I)-2D0*PMS(I)))
7144 THETA(I)=2D0*ASIN(SQRT(MAX(0D0,MIN(1D0,RAT))))
7145 IF(THETA(I).LT.CKIN(67+2*I)) GOTO 120
7146 IF(CKIN(68+2*I).GT.0D0.AND.THETA(I).GT.CKIN(68+2*I))
7147 & GOTO 120
7148
7149C...Phi angle isotropic. Reconstruct pT.
7150 PHI(I)=PARU(2)*PYR(0)
7151 PT(I)=SQRT(((1D0-X(I))*PMC(I))**2/(4D0*VINT(302))-
7152 & PMS(I))*SIN(THETA(I))
7153
7154C...Store info on variables selected, for documentation purposes.
7155 VINT(2+I)=-SQRT(Q2(I))
7156 VINT(304+I)=X(I)
7157 VINT(306+I)=Q2(I)
7158 VINT(308+I)=Y(I)
7159 VINT(310+I)=THETA(I)
7160 VINT(312+I)=PHI(I)
7161 ELSE
7162 VINT(304+I)=1D0
7163 VINT(306+I)=0D0
7164 VINT(308+I)=1D0
7165 VINT(310+I)=0D0
7166 VINT(312+I)=0D0
7167 ENDIF
7168 130 CONTINUE
7169
7170C...Cut on W combines info from two sides.
7171 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
7172 W2=-Q2(1)-Q2(2)+0.5D0*X(1)*PMC(1)*X(2)*PMC(2)/VINT(302)-
7173 & 2D0*PT(1)*PT(2)*COS(PHI(1)-PHI(2))+2D0*
7174 & SQRT((0.5D0*X(1)*PMC(1)/VINT(301))**2+Q2(1)-PT(1)**2)*
7175 & SQRT((0.5D0*X(2)*PMC(2)/VINT(301))**2+Q2(2)-PT(2)**2)
7176 IF(W2.LT.W2MIN) GOTO 120
7177 IF(CKIN(78).GT.0D0.AND.W2.GT.CKIN(78)**2) GOTO 120
7178 PMS1=-Q2(1)
7179 PMS2=-Q2(2)
7180 ELSEIF(MINT(141).NE.0) THEN
7181 W2=(VINT(302)+PMS(1))*X(1)+PMS(2)*(1D0-X(1))
7182 PMS1=-Q2(1)
7183 PMS2=PMS(2)
7184 ELSEIF(MINT(142).NE.0) THEN
7185 W2=(VINT(302)+PMS(2))*X(2)+PMS(1)*(1D0-X(2))
7186 PMS1=PMS(1)
7187 PMS2=-Q2(2)
7188 ENDIF
7189
7190C...Store kinematics info for photon(s) in subsystem cm frame.
7191 VINT(2)=W2
7192 VINT(1)=SQRT(W2)
7193 VINT(291)=0D0
7194 VINT(292)=0D0
7195 VINT(293)=0.5D0*SQRT((W2-PMS1-PMS2)**2-4D0*PMS1*PMS2)/VINT(1)
7196 VINT(294)=0.5D0*(W2+PMS1-PMS2)/VINT(1)
7197 VINT(295)=SIGN(SQRT(ABS(PMS1)),PMS1)
7198 VINT(296)=0D0
7199 VINT(297)=0D0
7200 VINT(298)=-VINT(293)
7201 VINT(299)=0.5D0*(W2+PMS2-PMS1)/VINT(1)
7202 VINT(300)=SIGN(SQRT(ABS(PMS2)),PMS2)
7203
7204C...Assign weight for photon flux; different for transverse and
7205C...longitudinal photons. Flag incoming unresolved photon.
7206 WTGAGA=1D0
7207 DO 140 I=1,2
7208 IF(MINT(140+I).NE.0) THEN
7209 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
7210 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
7211 IF(MSTP(16).EQ.0) THEN
7212 XY=X(I)
7213 ELSE
7214 WTGAGA=WTGAGA*X(I)/Y(I)
7215 XY=Y(I)
7216 ENDIF
7217 IF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
7218 WTGAGA=WTGAGA*(1D0-XY)
7219 ELSEIF(I.EQ.1.AND.(ISUB.EQ.139.OR.ISUB.EQ.140)) THEN
7220 WTGAGA=WTGAGA*(1D0-XY)
7221 ELSEIF(I.EQ.2.AND.(ISUB.EQ.138.OR.ISUB.EQ.140)) THEN
7222 WTGAGA=WTGAGA*(1D0-XY)
7223 ELSE
7224 WTGAGA=WTGAGA*(0.5D0*(1D0+(1D0-XY)**2)-
7225 & PMS(I)*XY**2/Q2(I))
7226 ENDIF
7227 IF(MINT(106+I).EQ.0) MINT(14+I)=22
7228 ENDIF
7229 140 CONTINUE
7230 VINT(319)=WTGAGA
7231 MINT(143)=LOOP
7232
7233C...Update pTmin and cross section information.
7234 IF(MSTP(82).LE.1) THEN
7235 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
7236 ELSE
7237 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
7238 ENDIF
7239 VINT(149)=4D0*PTMN**2/VINT(2)
7240 VINT(154)=PTMN
7241 CALL PYXTOT
7242
7243C...Reconstruct kinematics of photons inside leptons.
7244 ELSEIF(IGAGA.EQ.4) THEN
7245
7246C...Make place for incoming particles and scattered leptons.
7247 MOVE=3
7248 IF(MINT(141).NE.0.AND.MINT(142).NE.0) MOVE=4
7249 MINT(4)=MINT(4)+MOVE
7250 DO 160 I=MINT(84)-MOVE,MINT(83)+1,-1
7251 IF(K(I,1).EQ.21) THEN
7252 DO 150 J=1,5
7253 K(I+MOVE,J)=K(I,J)
7254 P(I+MOVE,J)=P(I,J)
7255 V(I+MOVE,J)=V(I,J)
7256 150 CONTINUE
7257 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
7258 & K(I+MOVE,3)=K(I,3)+MOVE
7259 IF(K(I,4).GT.MINT(83).AND.K(I,4).LE.MINT(84))
7260 & K(I+MOVE,4)=K(I,4)+MOVE
7261 IF(K(I,5).GT.MINT(83).AND.K(I,5).LE.MINT(84))
7262 & K(I+MOVE,5)=K(I,5)+MOVE
7263 ENDIF
7264 160 CONTINUE
7265 DO 170 I=MINT(84)+1,N
7266 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
7267 & K(I,3)=K(I,3)+MOVE
7268 170 CONTINUE
7269
7270C...Fill in incoming particles.
7271 DO 190 I=MINT(83)+1,MINT(83)+MOVE
7272 DO 180 J=1,5
7273 K(I,J)=0
7274 P(I,J)=0D0
7275 V(I,J)=0D0
7276 180 CONTINUE
7277 190 CONTINUE
7278 DO 200 I=1,2
7279 K(MINT(83)+I,1)=21
7280 IF(MINT(140+I).NE.0) THEN
7281 K(MINT(83)+I,2)=MINT(140+I)
7282 P(MINT(83)+I,5)=VINT(302+I)
7283 ELSE
7284 K(MINT(83)+I,2)=MINT(10+I)
7285 P(MINT(83)+I,5)=VINT(2+I)
7286 ENDIF
7287 P(MINT(83)+I,3)=0.5D0*SQRT((PMC(3)**2-4D0*PMS(1)*PMS(2))/
7288 & VINT(302))*(-1D0)**(I+1)
7289 P(MINT(83)+I,4)=0.5D0*PMC(I)/VINT(301)
7290 200 CONTINUE
7291
7292C...New mother-daughter relations in documentation section.
7293 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
7294 K(MINT(83)+1,4)=MINT(83)+3
7295 K(MINT(83)+1,5)=MINT(83)+5
7296 K(MINT(83)+2,4)=MINT(83)+4
7297 K(MINT(83)+2,5)=MINT(83)+6
7298 K(MINT(83)+3,3)=MINT(83)+1
7299 K(MINT(83)+5,3)=MINT(83)+1
7300 K(MINT(83)+4,3)=MINT(83)+2
7301 K(MINT(83)+6,3)=MINT(83)+2
7302 ELSEIF(MINT(141).NE.0) THEN
7303 K(MINT(83)+1,4)=MINT(83)+3
7304 K(MINT(83)+1,5)=MINT(83)+4
7305 K(MINT(83)+2,4)=MINT(83)+5
7306 K(MINT(83)+3,3)=MINT(83)+1
7307 K(MINT(83)+4,3)=MINT(83)+1
7308 K(MINT(83)+5,3)=MINT(83)+2
7309 ELSEIF(MINT(142).NE.0) THEN
7310 K(MINT(83)+1,4)=MINT(83)+4
7311 K(MINT(83)+2,4)=MINT(83)+3
7312 K(MINT(83)+2,5)=MINT(83)+5
7313 K(MINT(83)+3,3)=MINT(83)+2
7314 K(MINT(83)+4,3)=MINT(83)+1
7315 K(MINT(83)+5,3)=MINT(83)+2
7316 ENDIF
7317
7318C...Fill scattered lepton(s).
7319 DO 210 I=1,2
7320 IF(MINT(140+I).NE.0) THEN
7321 LSC=MINT(83)+MIN(I+2,MOVE)
7322 K(LSC,1)=21
7323 K(LSC,2)=MINT(140+I)
7324 P(LSC,1)=PT(I)*COS(PHI(I))
7325 P(LSC,2)=PT(I)*SIN(PHI(I))
7326 P(LSC,4)=(1D0-X(I))*P(MINT(83)+I,4)
7327 P(LSC,3)=SQRT(P(LSC,4)**2-PMS(I))*COS(THETA(I))*
7328 & (-1D0)**(I-1)
7329 P(LSC,5)=VINT(302+I)
7330 ENDIF
7331 210 CONTINUE
7332
7333C...Find incoming four-vectors to subprocess.
7334 K(N+1,1)=21
7335 IF(MINT(141).NE.0) THEN
7336 DO 220 J=1,4
7337 P(N+1,J)=P(MINT(83)+1,J)-P(MINT(83)+3,J)
7338 220 CONTINUE
7339 ELSE
7340 DO 230 J=1,4
7341 P(N+1,J)=P(MINT(83)+1,J)
7342 230 CONTINUE
7343 ENDIF
7344 K(N+2,1)=21
7345 IF(MINT(142).NE.0) THEN
7346 DO 240 J=1,4
7347 P(N+2,J)=P(MINT(83)+2,J)-P(MINT(83)+MOVE,J)
7348 240 CONTINUE
7349 ELSE
7350 DO 250 J=1,4
7351 P(N+2,J)=P(MINT(83)+2,J)
7352 250 CONTINUE
7353 ENDIF
7354
7355C...Define boost and rotation between hadronic subsystem and
7356C...collision rest frame; boost hadronic subsystem to this frame.
7357 DO 260 J=1,3
7358 BETA(J)=(P(N+1,J)+P(N+2,J))/(P(N+1,4)+P(N+2,4))
7359 260 CONTINUE
7360 CALL PYROBO(N+1,N+2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
7361 BPHI=PYANGL(P(N+1,1),P(N+1,2))
7362 CALL PYROBO(N+1,N+2,0D0,-BPHI,0D0,0D0,0D0)
7363 BTHETA=PYANGL(P(N+1,3),P(N+1,1))
7364 CALL PYROBO(MINT(83)+MOVE+1,N,BTHETA,BPHI,BETA(1),BETA(2),
7365 & BETA(3))
7366
7367C...Add on scattered leptons to final state.
7368 DO 280 I=1,2
7369 IF(MINT(140+I).NE.0) THEN
7370 LSC=MINT(83)+MIN(I+2,MOVE)
7371 N=N+1
7372 DO 270 J=1,5
7373 K(N,J)=K(LSC,J)
7374 P(N,J)=P(LSC,J)
7375 V(N,J)=V(LSC,J)
7376 270 CONTINUE
7377 K(N,1)=1
7378 K(N,3)=LSC
7379 ENDIF
7380 280 CONTINUE
7381 ENDIF
7382
7383 RETURN
7384 END
7385
7386C*********************************************************************
7387
7388C...PYRAND
7389C...Generates quantities characterizing the high-pT scattering at the
7390C...parton level according to the matrix elements. Chooses incoming,
7391C...reacting partons, their momentum fractions and one of the possible
7392C...subprocesses.
7393
7394 SUBROUTINE PYRAND
7395
7396C...Double precision and integer declarations.
7397 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
7398 IMPLICIT INTEGER(I-N)
7399 INTEGER PYK,PYCHGE,PYCOMP
7400C...Parameter statement to help give large particle numbers.
7401 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
7402 &KEXCIT=4000000,KDIMEN=5000000)
7403
7404C...User process initialization and event commonblocks.
7405 INTEGER MAXPUP
7406 PARAMETER (MAXPUP=100)
7407 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
7408 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
7409 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
7410 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
7411 &LPRUP(MAXPUP)
7412 INTEGER MAXNUP
7413 PARAMETER (MAXNUP=500)
7414 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
7415 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
7416 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
7417 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
7418 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
7419 SAVE /HEPRUP/,/HEPEUP/
7420
7421C...Commonblocks.
7422 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7423 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
7424 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
7425 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
7426 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
7427 COMMON/PYINT1/MINT(400),VINT(400)
7428 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
7429 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
7430 COMMON/PYINT4/MWID(500),WIDS(500,5)
7431 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
7432 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
7433 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
7434 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
7435 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYMSSM/
7436C...Local arrays.
7437 DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2)
7438
7439C...Parameters and data used in elastic/diffractive treatment.
7440 DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/,
7441 &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
7442
7443C...Initial values, specifically for (first) semihard interaction.
7444 MINT(10)=0
7445 MINT(17)=0
7446 MINT(18)=0
7447 VINT(97)=1D0
7448 VINT(143)=1D0
7449 VINT(144)=1D0
7450 VINT(157)=0D0
7451 VINT(158)=0D0
7452 MFAIL=0
7453 IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1
7454 ISUB=0
7455 ISTSB=0
7456 LOOP=0
7457 100 LOOP=LOOP+1
7458 MINT(51)=0
7459 MINT(143)=1
7460
7461C...Start by assuming incoming photon is entering subprocess.
7462 IF(MINT(11).EQ.22) THEN
7463 MINT(15)=22
7464 VINT(307)=VINT(3)**2
7465 ENDIF
7466 IF(MINT(12).EQ.22) THEN
7467 MINT(16)=22
7468 VINT(308)=VINT(4)**2
7469 ENDIF
7470 MINT(103)=MINT(11)
7471 MINT(104)=MINT(12)
7472
7473C...Choice of process type - first event of pileup.
7474 INMULT=0
7475 IF(MINT(82).EQ.1.AND.ISUB.GE.91.AND.ISUB.LE.96) THEN
7476 ELSEIF(MINT(82).EQ.1) THEN
7477
7478C...For gamma-p or gamma-gamma first pick between alternatives.
7479 IGA=0
7480 IF(MINT(121).GT.1) CALL PYSAVE(4,IGA)
7481 MINT(122)=IGA
7482
7483C...For real gamma + gamma with different nature, flip at random.
7484 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
7485 & MSTP(14).LE.10.AND.PYR(0).GT.0.5D0) THEN
7486 MINTSV=MINT(41)
7487 MINT(41)=MINT(42)
7488 MINT(42)=MINTSV
7489 MINTSV=MINT(45)
7490 MINT(45)=MINT(46)
7491 MINT(46)=MINTSV
7492 MINTSV=MINT(107)
7493 MINT(107)=MINT(108)
7494 MINT(108)=MINTSV
7495 IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47)
7496 ENDIF
7497
7498C...Pick process type, possibly by user process machinery.
7499C...(If the latter, also event will be picked here.)
7500 IF(MINT(111).EQ.11.AND.IABS(IDWTUP).EQ.2.AND.LOOP.GE.2) THEN
7501 CALL UPEVNT
7502 ELSEIF(MINT(111).EQ.11.AND.IABS(IDWTUP).GE.3) THEN
7503 CALL UPEVNT
7504 ISUB=0
7505 110 ISUB=ISUB+1
7506 IF((ISET(ISUB).NE.11.OR.KFPR(ISUB,2).NE.IDPRUP).AND.
7507 & ISUB.LT.500) GOTO 110
7508 ELSE
7509 RSUB=XSEC(0,1)*PYR(0)
7510 DO 120 I=1,500
7511 IF(MSUB(I).NE.1) GOTO 120
7512 ISUB=I
7513 RSUB=RSUB-XSEC(I,1)
7514 IF(RSUB.LE.0D0) GOTO 130
7515 120 CONTINUE
7516 130 IF(ISUB.EQ.95) ISUB=96
7517 IF(ISUB.EQ.96) INMULT=1
7518 IF(ISET(ISUB).EQ.11) THEN
7519 IDPRUP=KFPR(ISUB,2)
7520 CALL UPEVNT
7521 ENDIF
7522 ENDIF
7523
7524C...Choice of inclusive process type - pileup events.
7525 ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
7526 RSUB=VINT(131)*PYR(0)
7527 ISUB=96
7528 IF(RSUB.GT.SIGT(0,0,5)) ISUB=94
7529 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93
7530 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92
7531 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2))
7532 & ISUB=91
7533 IF(ISUB.EQ.96) INMULT=1
7534 ENDIF
7535
7536C...Choice of photon energy and flux factor inside lepton.
7537 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
7538 CALL PYGAGA(3,WTGAGA)
7539 IF(ISUB.GE.131.AND.ISUB.LE.140) THEN
7540 CKIN(3)=MAX(VINT(285),VINT(154))
7541 CKIN(1)=2D0*CKIN(3)
7542 ENDIF
7543C...When necessary set direct/resolved photon by hand.
7544 ELSEIF(MINT(15).EQ.22.OR.MINT(16).EQ.22) THEN
7545 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
7546 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
7547 ENDIF
7548
7549C...Restrict direct*resolved processes to pTmin >= Q,
7550C...to avoid doublecounting with DIS.
7551 IF(MSTP(18).EQ.3.AND.ISUB.GE.131.AND.ISUB.LE.136) THEN
7552 IF(MINT(15).EQ.22) THEN
7553 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(3)))
7554 ELSE
7555 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(4)))
7556 ENDIF
7557 CKIN(1)=2D0*CKIN(3)
7558 ENDIF
7559
7560C...Set up for multiple interactions.
7561 IF(INMULT.EQ.1) CALL PYMULT(2)
7562
7563C...Loopback point for minimum bias in photon physics.
7564 LOOP2=0
7565 140 LOOP2=LOOP2+1
7566 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+MINT(143)
7567 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+MINT(143)
7568 IF(ISUB.EQ.96.AND.LOOP2.EQ.1.AND.MINT(82).EQ.1)
7569 &NGEN(97,1)=NGEN(97,1)+MINT(143)
7570 MINT(1)=ISUB
7571 ISTSB=ISET(ISUB)
7572
7573C...Random choice of flavour for some SUSY processes.
7574 IF(ISUB.GE.201.AND.ISUB.LE.301) THEN
7575C...~e_L ~nu_e or ~mu_L ~nu_mu.
7576 IF(ISUB.EQ.210) THEN
7577 KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0))
7578 KFPR(ISUB,2)=KFPR(ISUB,1)+1
7579C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
7580 ELSEIF(ISUB.EQ.213) THEN
7581 KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0))
7582 KFPR(ISUB,2)=KFPR(ISUB,1)
7583C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
7584 ELSEIF(ISUB.GE.246.AND.ISUB.LE.259) THEN
7585 IF(ISUB.GE.258) THEN
7586 RKF=4D0
7587 ELSE
7588 RKF=5D0
7589 ENDIF
7590 IF(MOD(ISUB,2).EQ.0) THEN
7591 KFPR(ISUB,1)=KSUSY1+1+INT(RKF*PYR(0))
7592 ELSE
7593 KFPR(ISUB,1)=KSUSY2+1+INT(RKF*PYR(0))
7594 ENDIF
7595C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
7596 ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN
7597 IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN
7598 KSU1=KSUSY1
7599 KSU2=KSUSY1
7600 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN
7601 KSU1=KSUSY2
7602 KSU2=KSUSY2
7603 ELSEIF(PYR(0).LT.0.5D0) THEN
7604 KSU1=KSUSY1
7605 KSU2=KSUSY2
7606 ELSE
7607 KSU1=KSUSY2
7608 KSU2=KSUSY1
7609 ENDIF
7610 KFPR(ISUB,1)=KSU1+1+INT(4D0*PYR(0))
7611 KFPR(ISUB,2)=KSU2+1+INT(4D0*PYR(0))
7612C...~q ~q(bar); ~q = ~d, ~u, ~s, or ~c.
7613 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN
7614 KFPR(ISUB,1)=KSUSY1+1+INT(4D0*PYR(0))
7615 KFPR(ISUB,2)=KFPR(ISUB,1)
7616 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN
7617 KFPR(ISUB,1)=KSUSY2+1+INT(4D0*PYR(0))
7618 KFPR(ISUB,2)=KFPR(ISUB,1)
7619C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
7620 ELSEIF(ISUB.GE.281.AND.ISUB.LE.286) THEN
7621 IF(ISUB.EQ.281.OR.ISUB.EQ.284) THEN
7622 KSU1=KSUSY1
7623 KSU2=KSUSY1
7624 ELSEIF(ISUB.EQ.282.OR.ISUB.EQ.285) THEN
7625 KSU1=KSUSY2
7626 KSU2=KSUSY2
7627 ELSEIF(PYR(0).LT.0.5D0) THEN
7628 KSU1=KSUSY1
7629 KSU2=KSUSY2
7630 ELSE
7631 KSU1=KSUSY2
7632 KSU2=KSUSY1
7633 ENDIF
7634 IF(ISUB.EQ.281.OR.ISUB.LE.283) THEN
7635 RKF=5D0
7636 ELSE
7637 RKF=4D0
7638 ENDIF
7639 KFPR(ISUB,2)=KSU2+1+INT(RKF*PYR(0))
7640 ENDIF
7641 ENDIF
7642
7643C...Find resonances (explicit or implicit in cross-section).
7644 MINT(72)=0
7645 KFR1=0
7646 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
7647 KFR1=KFPR(ISUB,1)
7648 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR.
7649 & ISUB.EQ.171.OR.ISUB.EQ.176) THEN
7650 KFR1=23
7651 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR.
7652 & ISUB.EQ.177) THEN
7653 KFR1=24
7654 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
7655 KFR1=25
7656 IF(MSTP(46).EQ.5) THEN
7657 KFR1=89
7658 PMAS(89,1)=PARP(45)
7659 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
7660 ENDIF
7661 ELSEIF(ISUB.EQ.194) THEN
7662 KFR1=KTECHN+113
7663 ELSEIF(ISUB.EQ.195) THEN
7664 KFR1=KTECHN+213
7665 ELSEIF(ISUB.GE.361.AND.ISUB.LE.368) THEN
7666 KFR1=KTECHN+113
7667 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
7668 KFR1=KTECHN+213
7669 ENDIF
7670 CKMX=CKIN(2)
7671 IF(CKMX.LE.0D0) CKMX=VINT(1)
7672 KCR1=PYCOMP(KFR1)
7673 IF(KFR1.NE.0) THEN
7674 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
7675 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
7676 ENDIF
7677 IF(KFR1.NE.0) THEN
7678 TAUR1=PMAS(KCR1,1)**2/VINT(2)
7679 IF(KFR1.EQ.KTECHN+113) THEN
7680 CALL PYTECM(S1,S2)
7681 TAUR1=S1/VINT(2)
7682 ENDIF
7683 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
7684 MINT(72)=1
7685 MINT(73)=KFR1
7686 VINT(73)=TAUR1
7687 VINT(74)=GAMR1
7688 ENDIF
7689 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.(ISUB.GE.364.AND.ISUB.LE.368))
7690 $THEN
7691 KFR2=23
7692 IF(ISUB.EQ.194) THEN
7693 KFR2=KTECHN+223
7694 ELSEIF(ISUB.GE.364.AND.ISUB.LE.368) THEN
7695 KFR2=KTECHN+223
7696 ENDIF
7697 KCR2=PYCOMP(KFR2)
7698 TAUR2=PMAS(KCR2,1)**2/VINT(2)
7699 IF(KFR2.EQ.KTECHN+223) THEN
7700 CALL PYTECM(S1,S2)
7701 TAUR2=S2/VINT(2)
7702 ENDIF
7703 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
7704 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
7705 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
7706 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
7707 MINT(72)=2
7708 MINT(74)=KFR2
7709 VINT(75)=TAUR2
7710 VINT(76)=GAMR2
7711 ELSEIF(KFR2.NE.0) THEN
7712 KFR1=KFR2
7713 TAUR1=TAUR2
7714 GAMR1=GAMR2
7715 MINT(72)=1
7716 MINT(73)=KFR1
7717 VINT(73)=TAUR1
7718 VINT(74)=GAMR1
7719 ENDIF
7720 ENDIF
7721
7722C...Find product masses and minimum pT of process,
7723C...optionally with broadening according to a truncated Breit-Wigner.
7724 VINT(63)=0D0
7725 VINT(64)=0D0
7726 MINT(71)=0
7727 VINT(71)=CKIN(3)
7728 IF(MINT(82).GE.2) VINT(71)=0D0
7729 VINT(80)=1D0
7730 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7731 NBW=0
7732 DO 160 I=1,2
7733 PMMN(I)=0D0
7734 IF(KFPR(ISUB,I).EQ.0) THEN
7735 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
7736 & PARP(41)) THEN
7737 VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7738 ELSE
7739 NBW=NBW+1
7740C...This prevents SUSY/t particles from becoming too light.
7741 KFLW=KFPR(ISUB,I)
7742 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
7743 KCW=PYCOMP(KFLW)
7744 PMMN(I)=PMAS(KCW,1)
7745 DO 150 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
7746 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
7747 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
7748 & PMAS(PYCOMP(KFDP(IDC,2)),1)
7749 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
7750 & PMAS(PYCOMP(KFDP(IDC,3)),1)
7751 PMMN(I)=MIN(PMMN(I),PMSUM)
7752 ENDIF
7753 150 CONTINUE
7754 ELSEIF(KFLW.EQ.6) THEN
7755 PMMN(I)=PMAS(24,1)+PMAS(5,1)
7756 ENDIF
7757 ENDIF
7758 160 CONTINUE
7759 IF(NBW.GE.1) THEN
7760 CKIN41=CKIN(41)
7761 CKIN43=CKIN(43)
7762 CKIN(41)=MAX(PMMN(1),CKIN(41))
7763 CKIN(43)=MAX(PMMN(2),CKIN(43))
7764 CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
7765 CKIN(41)=CKIN41
7766 CKIN(43)=CKIN43
7767 IF(MINT(51).EQ.1) THEN
7768 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7769 IF(MFAIL.EQ.1) THEN
7770 MSTI(61)=1
7771 RETURN
7772 ENDIF
7773 GOTO 100
7774 ENDIF
7775 VINT(63)=PQM3**2
7776 VINT(64)=PQM4**2
7777 ENDIF
7778 IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
7779 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
7780 ENDIF
7781
7782C...Prepare for additional variable choices in 2 -> 3.
7783 IF(ISTSB.EQ.5) THEN
7784 VINT(201)=0D0
7785 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
7786 VINT(206)=VINT(201)
7787 VINT(204)=PMAS(23,1)
7788 IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
7789 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
7790 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
7791 & ISUB.EQ.186.OR.ISUB.EQ.187) VINT(204)=VINT(201)
7792 VINT(209)=VINT(204)
7793 ENDIF
7794
7795C...Select incoming VDM particle (rho/omega/phi/J/psi).
7796 IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND.
7797 &(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7)) THEN
7798 VRN=PYR(0)*SIGT(0,0,5)
7799 IF(MINT(101).LE.1) THEN
7800 I1MN=0
7801 I1MX=0
7802 ELSE
7803 I1MN=1
7804 I1MX=MINT(101)
7805 ENDIF
7806 IF(MINT(102).LE.1) THEN
7807 I2MN=0
7808 I2MX=0
7809 ELSE
7810 I2MN=1
7811 I2MX=MINT(102)
7812 ENDIF
7813 DO 180 I1=I1MN,I1MX
7814 KFV1=110*I1+3
7815 DO 170 I2=I2MN,I2MX
7816 KFV2=110*I2+3
7817 VRN=VRN-SIGT(I1,I2,5)
7818 IF(VRN.LE.0D0) GOTO 190
7819 170 CONTINUE
7820 180 CONTINUE
7821 190 IF(MINT(101).GE.2) MINT(103)=KFV1
7822 IF(MINT(102).GE.2) MINT(104)=KFV2
7823 ENDIF
7824
7825 IF(ISTSB.EQ.0) THEN
7826C...Elastic scattering or single or double diffractive scattering.
7827
7828C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
7829 MINT(103)=MINT(11)
7830 MINT(104)=MINT(12)
7831 PMM(1)=VINT(3)
7832 PMM(2)=VINT(4)
7833 IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN
7834 JJ=ISUB-90
7835 VRN=PYR(0)*SIGT(0,0,JJ)
7836 IF(MINT(101).LE.1) THEN
7837 I1MN=0
7838 I1MX=0
7839 ELSE
7840 I1MN=1
7841 I1MX=MINT(101)
7842 ENDIF
7843 IF(MINT(102).LE.1) THEN
7844 I2MN=0
7845 I2MX=0
7846 ELSE
7847 I2MN=1
7848 I2MX=MINT(102)
7849 ENDIF
7850 DO 210 I1=I1MN,I1MX
7851 KFV1=110*I1+3
7852 DO 200 I2=I2MN,I2MX
7853 KFV2=110*I2+3
7854 VRN=VRN-SIGT(I1,I2,JJ)
7855 IF(VRN.LE.0D0) GOTO 220
7856 200 CONTINUE
7857 210 CONTINUE
7858 220 IF(MINT(101).GE.2) THEN
7859 MINT(103)=KFV1
7860 PMM(1)=PYMASS(KFV1)
7861 ENDIF
7862 IF(MINT(102).GE.2) THEN
7863 MINT(104)=KFV2
7864 PMM(2)=PYMASS(KFV2)
7865 ENDIF
7866 ENDIF
7867 VINT(67)=PMM(1)
7868 VINT(68)=PMM(2)
7869
7870C...Select mass for GVMD states (rejecting previous assignment).
7871 Q0S=4D0*PARP(15)**2
7872 Q1S=4D0*VINT(154)**2
7873 LOOP3=0
7874 230 LOOP3=LOOP3+1
7875 DO 240 JT=1,2
7876 IF(MINT(106+JT).EQ.3) THEN
7877 PS=VINT(2+JT)**2
7878 PMM(JT)=(Q0S+PS)*(Q1S+PS)/
7879 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
7880 IF(MINT(102+JT).GE.333) PMM(JT)=PMM(JT)-
7881 & PMAS(PYCOMP(113),1)+PMAS(PYCOMP(MINT(102+JT)),1)
7882 ENDIF
7883 240 CONTINUE
7884 IF(PMM(1)+PMM(2)+PARP(104).GE.VINT(1)) THEN
7885 IF(LOOP3.LT.100.AND.(MINT(107).EQ.3.OR.MINT(108).EQ.3))
7886 & GOTO 230
7887 GOTO 100
7888 ENDIF
7889
7890C...Side/sides of diffractive system.
7891 MINT(17)=0
7892 MINT(18)=0
7893 IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1
7894 IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1
7895
7896C...Find masses of particles and minimal masses of diffractive states.
7897 DO 250 JT=1,2
7898 PDIF(JT)=PMM(JT)
7899 VINT(68+JT)=PDIF(JT)
7900 IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102)
7901 250 CONTINUE
7902 SH=VINT(2)
7903 SQM1=PMM(1)**2
7904 SQM2=PMM(2)**2
7905 SQM3=PDIF(1)**2
7906 SQM4=PDIF(2)**2
7907 SMRES1=(PMM(1)+PMRC)**2
7908 SMRES2=(PMM(2)+PMRC)**2
7909
7910C...Find elastic slope and lower limit diffractive slope.
7911 IHA=MAX(2,IABS(MINT(103))/110)
7912 IF(IHA.GE.5) IHA=1
7913 IHB=MAX(2,IABS(MINT(104))/110)
7914 IF(IHB.GE.5) IHB=1
7915 IF(ISUB.EQ.91) THEN
7916 BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0
7917 ELSEIF(ISUB.EQ.92) THEN
7918 BMN=MAX(2D0,2D0*BHAD(IHB))
7919 ELSEIF(ISUB.EQ.93) THEN
7920 BMN=MAX(2D0,2D0*BHAD(IHA))
7921 ELSEIF(ISUB.EQ.94) THEN
7922 BMN=2D0*ALP*4D0
7923 ENDIF
7924
7925C...Determine maximum possible t range and coefficient of generation.
7926 SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2
7927 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
7928 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
7929 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
7930 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
7931 & (SQM1*SQM4-SQM2*SQM3)/SH
7932 THL=-0.5D0*(THA+THB)
7933 THU=THC/THL
7934 THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0
7935
7936C...Select diffractive mass/masses according to dm^2/m^2.
7937 LOOP3=0
7938 260 LOOP3=LOOP3+1
7939 DO 270 JT=1,2
7940 IF(MINT(16+JT).EQ.0) THEN
7941 PDIF(2+JT)=PDIF(JT)
7942 ELSE
7943 PMMIN=PDIF(JT)
7944 PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT))
7945 PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0)
7946 ENDIF
7947 270 CONTINUE
7948 SQM3=PDIF(3)**2
7949 SQM4=PDIF(4)**2
7950
7951C..Additional mass factors, including resonance enhancement.
7952 IF(PDIF(3)+PDIF(4).GE.VINT(1)) THEN
7953 IF(LOOP3.LT.100) GOTO 260
7954 GOTO 100
7955 ENDIF
7956 IF(ISUB.EQ.92) THEN
7957 FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3))
7958 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
7959 ELSEIF(ISUB.EQ.93) THEN
7960 FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4))
7961 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
7962 ELSEIF(ISUB.EQ.94) THEN
7963 FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/
7964 & (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))*
7965 & (1D0+CRES*SMRES2/(SMRES2+SQM4))
7966 IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 260
7967 ENDIF
7968
7969C...Select t according to exp(Bmn*t) and correct to right slope.
7970 TH=THU+LOG(1D0+THRND*PYR(0))/BMN
7971 IF(ISUB.GE.92) THEN
7972 IF(ISUB.EQ.92) THEN
7973 BADD=2D0*ALP*LOG(SH/SQM3)
7974 IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
7975 ELSEIF(ISUB.EQ.93) THEN
7976 BADD=2D0*ALP*LOG(SH/SQM4)
7977 IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
7978 ELSEIF(ISUB.EQ.94) THEN
7979 BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0)
7980 ENDIF
7981 IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 260
7982 ENDIF
7983
7984C...Check whether m^2 and t choices are consistent.
7985 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
7986 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
7987 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
7988 IF(THB.LE.1D-8) GOTO 260
7989 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
7990 & (SQM1*SQM4-SQM2*SQM3)/SH
7991 THLM=-0.5D0*(THA+THB)
7992 THUM=THC/THLM
7993 IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 260
7994
7995C...Information to output.
7996 VINT(21)=1D0
7997 VINT(22)=0D0
7998 VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB))
7999 VINT(45)=TH
8000 VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB
8001 VINT(63)=PDIF(3)**2
8002 VINT(64)=PDIF(4)**2
8003 VINT(283)=PMM(1)**2/4D0
8004 VINT(284)=PMM(2)**2/4D0
8005
8006C...Note: in the following, by In is meant the integral over the
8007C...quantity multiplying coefficient cn.
8008C...Choose tau according to h1(tau)/tau, where
8009C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
8010C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
8011C...I1/I5*c5*1/(tau+tau_R') +
8012C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
8013C...I1/I7*c7*tau/(1.-tau), and
8014C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
8015 ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN
8016 CALL PYKLIM(1)
8017 IF(MINT(51).NE.0) THEN
8018 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8019 IF(MFAIL.EQ.1) THEN
8020 MSTI(61)=1
8021 RETURN
8022 ENDIF
8023 GOTO 100
8024 ENDIF
8025 RTAU=PYR(0)
8026 MTAU=1
8027 IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
8028 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
8029 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
8030 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
8031 & MTAU=5
8032 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
8033 & COEF(ISUB,5)) MTAU=6
8034 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
8035 & COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7
8036 CALL PYKMAP(1,MTAU,PYR(0))
8037
8038C...2 -> 3, 4 processes:
8039C...Choose tau' according to h4(tau,tau')/tau', where
8040C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
8041C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
8042 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
8043 CALL PYKLIM(4)
8044 IF(MINT(51).NE.0) THEN
8045 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8046 IF(MFAIL.EQ.1) THEN
8047 MSTI(61)=1
8048 RETURN
8049 ENDIF
8050 GOTO 100
8051 ENDIF
8052 RTAUP=PYR(0)
8053 MTAUP=1
8054 IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2
8055 IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3
8056 CALL PYKMAP(4,MTAUP,PYR(0))
8057 ENDIF
8058
8059C...Choose y* according to h2(y*), where
8060C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
8061C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
8062C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
8063C...and c1 + c2 + c3 + c4 + c5 = 1.
8064 CALL PYKLIM(2)
8065 IF(MINT(51).NE.0) THEN
8066 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8067 IF(MFAIL.EQ.1) THEN
8068 MSTI(61)=1
8069 RETURN
8070 ENDIF
8071 GOTO 100
8072 ENDIF
8073 RYST=PYR(0)
8074 MYST=1
8075 IF(RYST.GT.COEF(ISUB,8)) MYST=2
8076 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
8077 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4
8078 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+
8079 & COEF(ISUB,11)) MYST=5
8080 CALL PYKMAP(2,MYST,PYR(0))
8081
8082C...2 -> 2 processes:
8083C...Choose cos(theta-hat) (cth) according to h3(cth), where
8084C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
8085C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
8086C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
8087C...and c0 + c1 + c2 + c3 + c4 = 1.
8088 CALL PYKLIM(3)
8089 IF(MINT(51).NE.0) THEN
8090 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8091 IF(MFAIL.EQ.1) THEN
8092 MSTI(61)=1
8093 RETURN
8094 ENDIF
8095 GOTO 100
8096 ENDIF
8097 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
8098 RCTH=PYR(0)
8099 MCTH=1
8100 IF(RCTH.GT.COEF(ISUB,13)) MCTH=2
8101 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3
8102 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4
8103 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+
8104 & COEF(ISUB,16)) MCTH=5
8105 CALL PYKMAP(3,MCTH,PYR(0))
8106 ENDIF
8107
8108C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
8109 IF(ISTSB.EQ.5) THEN
8110 CALL PYKMAP(5,0,0D0)
8111 IF(MINT(51).NE.0) THEN
8112 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8113 IF(MFAIL.EQ.1) THEN
8114 MSTI(61)=1
8115 RETURN
8116 ENDIF
8117 GOTO 100
8118 ENDIF
8119 ENDIF
8120
8121C...DIS as f + gamma* -> f process: set dummy values.
8122 ELSEIF(ISTSB.EQ.8) THEN
8123 VINT(21)=0.9D0
8124 VINT(22)=0D0
8125 VINT(23)=0D0
8126 VINT(47)=0D0
8127 VINT(48)=0D0
8128
8129C...Low-pT or multiple interactions (first semihard interaction).
8130 ELSEIF(ISTSB.EQ.9) THEN
8131 CALL PYMULT(3)
8132 ISUB=MINT(1)
8133
8134C...Study user-defined process: kinematics plus weight.
8135 ELSEIF(ISTSB.EQ.11) THEN
8136 IF(IDWTUP.GT.0.AND.XWGTUP.LT.0D0) CALL
8137 & PYERRM(26,'(PYRAND:) Negative XWGTUP for user process')
8138 MSTI(51)=0
8139 IF(NUP.LE.0) THEN
8140 MINT(51)=2
8141 MSTI(51)=1
8142 IF(MINT(82).EQ.1) THEN
8143 NGEN(0,1)=NGEN(0,1)-1
8144 NGEN(ISUB,1)=NGEN(ISUB,1)-1
8145 ENDIF
8146 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8147 RETURN
8148 ENDIF
8149
8150C...Extract cross section event weight.
8151 IF(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.4) THEN
8152 SIGS=1D-9*XWGTUP
8153 ELSE
8154 SIGS=1D-9*XSECUP(KFPR(ISUB,1))
8155 ENDIF
8156 IF(IABS(IDWTUP).GE.1.AND.IABS(IDWTUP).LE.3) THEN
8157 VINT(97)=SIGN(1D0,XWGTUP)
8158 ELSE
8159 VINT(97)=1D-9*XWGTUP
8160 ENDIF
8161
8162C...Construct 'trivial' kinematical variables needed.
8163 KFL1=IDUP(1)
8164 KFL2=IDUP(2)
8165 VINT(41)=PUP(4,1)/EBMUP(1)
8166 VINT(42)=PUP(4,2)/EBMUP(2)
8167 VINT(21)=VINT(41)*VINT(42)
8168 VINT(22)=0.5D0*LOG(VINT(41)/VINT(42))
8169 VINT(44)=VINT(21)*VINT(2)
8170 VINT(43)=SQRT(MAX(0D0,VINT(44)))
8171 VINT(55)=SCALUP
8172 IF(SCALUP.LE.0D0) VINT(55)=VINT(43)
8173 VINT(56)=VINT(55)**2
8174 VINT(57)=AQEDUP
8175 VINT(58)=AQCDUP
8176
8177C...Construct other kinematical variables needed (approximately).
8178 VINT(23)=0D0
8179 VINT(26)=VINT(21)
8180 VINT(45)=-0.5D0*VINT(44)
8181 VINT(46)=-0.5D0*VINT(44)
8182 VINT(49)=VINT(43)
8183 VINT(50)=VINT(44)
8184 VINT(51)=VINT(55)
8185 VINT(52)=VINT(56)
8186 VINT(53)=VINT(55)
8187 VINT(54)=VINT(56)
8188 VINT(25)=0D0
8189 VINT(48)=0D0
8190 IF(ISTUP(1).NE.-1.OR.ISTUP(2).NE.-1) CALL PYERRM(26,
8191 & '(PYRAND:) unacceptable ISTUP code for incoming particles')
8192 DO 280 IUP=3,NUP
8193 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) CALL PYERRM(26,
8194 & '(PYRAND:) unacceptable ISTUP code for particles')
8195 IF(ISTUP(IUP).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(5,IUP)**2+
8196 & PUP(1,IUP)**2+PUP(2,IUP)**2)/VINT(2)
8197 IF(ISTUP(IUP).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(1,IUP)**2+
8198 & PUP(2,IUP)**2)
8199 280 CONTINUE
8200 VINT(47)=SQRT(VINT(48))
8201 ENDIF
8202
8203C...Choose azimuthal angle.
8204 VINT(24)=0D0
8205 IF(ISTSB.NE.11) VINT(24)=PARU(2)*PYR(0)
8206
8207C...Check against user cuts on kinematics at parton level.
8208 MINT(51)=0
8209 IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0)
8210 IF(MINT(51).NE.0) THEN
8211 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8212 IF(MFAIL.EQ.1) THEN
8213 MSTI(61)=1
8214 RETURN
8215 ENDIF
8216 GOTO 100
8217 ENDIF
8218 IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN
8219 MCUT=0
8220 IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
8221 & CALL PYKCUT(MCUT)
8222 IF(MCUT.NE.0) THEN
8223 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8224 IF(MFAIL.EQ.1) THEN
8225 MSTI(61)=1
8226 RETURN
8227 ENDIF
8228 GOTO 100
8229 ENDIF
8230 ENDIF
8231
8232C...Calculate differential cross-section for different subprocesses.
8233 IF(ISTSB.LE.10) CALL PYSIGH(NCHN,SIGS)
8234 SIGSOR=SIGS
8235 SIGLPT=SIGT(0,0,5)*VINT(315)*VINT(316)
8236
8237C...Multiply cross section by lepton -> photon flux factor.
8238 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
8239 SIGS=WTGAGA*SIGS
8240 DO 290 ICHN=1,NCHN
8241 SIGH(ICHN)=WTGAGA*SIGH(ICHN)
8242 290 CONTINUE
8243 SIGLPT=WTGAGA*SIGLPT
8244 ENDIF
8245
8246C...Multiply cross-section by user-defined weights.
8247 IF(MSTP(173).EQ.1) THEN
8248 SIGS=PARP(173)*SIGS
8249 DO 300 ICHN=1,NCHN
8250 SIGH(ICHN)=PARP(173)*SIGH(ICHN)
8251 300 CONTINUE
8252 SIGLPT=PARP(173)*SIGLPT
8253 ENDIF
8254 WTXS=1D0
8255 SIGSWT=SIGS
8256 VINT(99)=1D0
8257 VINT(100)=1D0
8258 IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN
8259 IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+
8260 & MSUB(95).EQ.0) CALL PYEVWT(WTXS)
8261 SIGSWT=WTXS*SIGS
8262 VINT(99)=WTXS
8263 IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS
8264 ENDIF
8265
8266C...Calculations for Monte Carlo estimate of all cross-sections.
8267 IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
8268 IF(MSTP(142).LE.1) THEN
8269 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
8270 ELSE
8271 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT
8272 ENDIF
8273 ELSEIF(MINT(82).EQ.1) THEN
8274 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
8275 ENDIF
8276 IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP2.EQ.1.AND.
8277 &MINT(82).EQ.1) XSEC(97,2)=XSEC(97,2)+SIGLPT
8278
8279C...Multiple interactions: store results of cross-section calculation.
8280 IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN
8281 VINT(153)=SIGSOR
8282 CALL PYMULT(4)
8283 ENDIF
8284
8285C...Ratio of actual to maximum cross section.
8286 IF(ISTSB.NE.11) THEN
8287 VIOL=SIGSWT/XSEC(ISUB,1)
8288 IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174)
8289 ELSEIF(IDWTUP.EQ.1.OR.IDWTUP.EQ.2) THEN
8290 VIOL=XWGTUP/XMAXUP(KFPR(ISUB,1))
8291 ELSEIF(IDWTUP.EQ.-1.OR.IDWTUP.EQ.-2) THEN
8292 VIOL=ABS(XWGTUP)/ABS(XMAXUP(KFPR(ISUB,1)))
8293 ELSE
8294 VIOL=1D0
8295 ENDIF
8296
8297C...Check that weight not negative.
8298 IF(MSTP(123).LE.0) THEN
8299 IF(VIOL.LT.-1D-3) THEN
8300 WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1
8301 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
8302 & VINT(22),VINT(23),VINT(26)
8303 STOP
8304 ENDIF
8305 ELSE
8306 IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN
8307 VINT(109)=VIOL
8308 WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1
8309 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
8310 & VINT(22),VINT(23),VINT(26)
8311 ENDIF
8312 ENDIF
8313
8314C...Weighting using estimate of maximum of differential cross-section.
8315 IF(MFAIL.EQ.0.AND.ISUB.NE.95.AND.ISUB.NE.96) THEN
8316 IF(VIOL.LT.PYR(0)) THEN
8317 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8318 IF(ISUB.GE.91.AND.ISUB.LE.94) ISUB=0
8319 GOTO 100
8320 ENDIF
8321 ELSEIF(MFAIL.EQ.0) THEN
8322 RATND=SIGLPT/XSEC(95,1)
8323 VIOL=VIOL/RATND
8324 IF(LOOP2.EQ.1.AND.RATND.LT.PYR(0)) THEN
8325 IF(VIOL.GT.PYR(0).AND.MINT(82).EQ.1.AND.MSUB(95).EQ.1.AND.
8326 & (ISUB.LE.90.OR.ISUB.GE.95)) NGEN(95,1)=NGEN(95,1)+MINT(143)
8327 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8328 ISUB=0
8329 GOTO 100
8330 ENDIF
8331 IF(VIOL.LT.PYR(0)) THEN
8332 GOTO 140
8333 ENDIF
8334 ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN
8335 IF(VIOL.LT.PYR(0)) THEN
8336 MSTI(61)=1
8337 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8338 RETURN
8339 ENDIF
8340 ELSE
8341 RATND=SIGLPT/XSEC(95,1)
8342 IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN
8343 MSTI(61)=1
8344 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8345 RETURN
8346 ENDIF
8347 VIOL=VIOL/RATND
8348 IF(VIOL.LT.PYR(0)) THEN
8349 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8350 GOTO 100
8351 ENDIF
8352 ENDIF
8353
8354C...Check for possible violation of estimated maximum of differential
8355C...cross-section used in weighting.
8356 IF(MSTP(123).LE.0) THEN
8357 IF(VIOL.GT.1D0) THEN
8358 WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1
8359 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
8360 & VINT(22),VINT(23),VINT(26)
8361 STOP
8362 ENDIF
8363 ELSEIF(MSTP(123).EQ.1) THEN
8364 IF(VIOL.GT.VINT(108)) THEN
8365 VINT(108)=VIOL
8366 IF(VIOL.GT.1.0001D0) THEN
8367 MINT(10)=1
8368 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
8369 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
8370 & VINT(22),VINT(23),VINT(26)
8371 ENDIF
8372 ENDIF
8373 ELSEIF(VIOL.GT.VINT(108)) THEN
8374 VINT(108)=VIOL
8375 IF(VIOL.GT.1D0) THEN
8376 MINT(10)=1
8377 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
8378 IF(ISTSB.EQ.11.AND.(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.2))
8379 & THEN
8380 XMAXUP(KFPR(ISUB,1))=VIOL*XMAXUP(KFPR(ISUB,1))
8381 IF(KFPR(ISUB,1).LE.9) THEN
8382 WRITE(MSTU(11),5800) KFPR(ISUB,1),XMAXUP(KFPR(ISUB,1))
8383 ELSEIF(KFPR(ISUB,1).LE.99) THEN
8384 WRITE(MSTU(11),5900) KFPR(ISUB,1),XMAXUP(KFPR(ISUB,1))
8385 ELSE
8386 WRITE(MSTU(11),6000) KFPR(ISUB,1),XMAXUP(KFPR(ISUB,1))
8387 ENDIF
8388 ENDIF
8389 IF(ISTSB.NE.11.OR.IABS(IDWTUP).EQ.1) THEN
8390 XDIF=XSEC(ISUB,1)*(VIOL-1D0)
8391 XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
8392 IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
8393 & XSEC(0,1)=XSEC(0,1)+XDIF
8394 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
8395 & VINT(22),VINT(23),VINT(26)
8396 IF(ISUB.LE.9) THEN
8397 WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1)
8398 ELSEIF(ISUB.LE.99) THEN
8399 WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1)
8400 ELSE
8401 WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1)
8402 ENDIF
8403 ENDIF
8404 VINT(108)=1D0
8405 ENDIF
8406 ENDIF
8407
8408C...Multiple interactions: choose impact parameter.
8409 VINT(148)=1D0
8410 IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.
8411 &MSTP(82).GE.3) THEN
8412 CALL PYMULT(5)
8413 IF(VINT(150).LT.PYR(0)) THEN
8414 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8415 IF(MFAIL.EQ.1) THEN
8416 MSTI(61)=1
8417 RETURN
8418 ENDIF
8419 GOTO 100
8420 ENDIF
8421 ENDIF
8422 IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1
8423 IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
8424 IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+MINT(143)
8425 IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
8426 ENDIF
8427 IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
8428
8429C...Choose flavour of reacting partons (and subprocess).
8430 IF(ISTSB.GE.11) GOTO 320
8431 RSIGS=SIGS*PYR(0)
8432 QT2=VINT(48)
8433 RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82)*
8434 &(VINT(1)/PARP(89))**PARP(90))**2))**2)
8435 IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
8436 &PYR(0).GT.RQQBAR)) THEN
8437 DO 310 ICHN=1,NCHN
8438 KFL1=ISIG(ICHN,1)
8439 KFL2=ISIG(ICHN,2)
8440 MINT(2)=ISIG(ICHN,3)
8441 RSIGS=RSIGS-SIGH(ICHN)
8442 IF(RSIGS.LE.0D0) GOTO 320
8443 310 CONTINUE
8444
8445C...Multiple interactions: choose qqbar preferentially at small pT.
8446 ELSEIF(ISUB.EQ.96) THEN
8447 MINT(105)=MINT(103)
8448 MINT(109)=MINT(107)
8449 CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
8450 MINT(105)=MINT(104)
8451 MINT(109)=MINT(108)
8452 CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
8453 MINT(1)=11
8454 MINT(2)=1
8455 IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2
8456
8457C...Low-pT: choose string drawing configuration.
8458 ELSE
8459 KFL1=21
8460 KFL2=21
8461 RSIGS=6D0*PYR(0)
8462 MINT(2)=1
8463 IF(RSIGS.GT.1D0) MINT(2)=2
8464 IF(RSIGS.GT.2D0) MINT(2)=3
8465 ENDIF
8466
8467C...Reassign QCD process. Partons before initial state radiation.
8468 320 IF(MINT(2).GT.10) THEN
8469 MINT(1)=MINT(2)/10
8470 MINT(2)=MOD(MINT(2),10)
8471 ENDIF
8472 IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)=
8473 &NGEN(MINT(1),2)+1
8474 MINT(15)=KFL1
8475 MINT(16)=KFL2
8476 MINT(13)=MINT(15)
8477 MINT(14)=MINT(16)
8478 VINT(141)=VINT(41)
8479 VINT(142)=VINT(42)
8480 VINT(151)=0D0
8481 VINT(152)=0D0
8482
8483C...Calculate x value of photon for parton inside photon inside e.
8484 DO 350 JT=1,2
8485 MINT(18+JT)=0
8486 VINT(154+JT)=0D0
8487 MSPLI=0
8488 IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1
8489 IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1
8490 IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1
8491 IF(MSPLI.EQ.2) THEN
8492 KFLH=MINT(14+JT)
8493 XHRD=VINT(140+JT)
8494 Q2HRD=VINT(54)
8495 MINT(105)=MINT(102+JT)
8496 MINT(109)=MINT(106+JT)
8497 VINT(120)=VINT(2+JT)
8498 IF(MSTP(57).LE.1) THEN
8499 CALL PYPDFU(22,XHRD,Q2HRD,XPQ)
8500 ELSE
8501 CALL PYPDFL(22,XHRD,Q2HRD,XPQ)
8502 ENDIF
8503 WTMX=4D0*XPQ(KFLH)
8504 IF(MSTP(13).EQ.2) THEN
8505 Q2PMS=Q2HRD/PMAS(11,1)**2
8506 WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2))
8507 ENDIF
8508 330 XE=XHRD**PYR(0)
8509 XG=MIN(1D0-1D-10,XHRD/XE)
8510 IF(MSTP(57).LE.1) THEN
8511 CALL PYPDFU(22,XG,Q2HRD,XPQ)
8512 ELSE
8513 CALL PYPDFL(22,XG,Q2HRD,XPQ)
8514 ENDIF
8515 WT=(1D0+(1D0-XE)**2)*XPQ(KFLH)
8516 IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2))
8517 IF(WT.LT.PYR(0)*WTMX) GOTO 330
8518 MINT(18+JT)=1
8519 VINT(154+JT)=XE
8520 DO 340 KFLS=-25,25
8521 XSFX(JT,KFLS)=XPQ(KFLS)
8522 340 CONTINUE
8523 ENDIF
8524 350 CONTINUE
8525
8526C...Pick scale where photon is resolved.
8527 Q0S=PARP(15)**2
8528 Q1S=VINT(154)**2
8529 VINT(283)=0D0
8530 IF(MINT(107).EQ.3) THEN
8531 IF(MSTP(66).EQ.1) THEN
8532 VINT(283)=Q0S*(VINT(54)/Q0S)**PYR(0)
8533 ELSEIF(MSTP(66).EQ.2) THEN
8534 PS=VINT(3)**2
8535 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
8536 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
8537 Q2INT=SQRT(Q0S*Q2EFF)
8538 VINT(283)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
8539 ELSEIF(MSTP(66).EQ.3) THEN
8540 VINT(283)=Q0S*(Q1S/Q0S)**PYR(0)
8541 ELSEIF(MSTP(66).GE.4) THEN
8542 PS=0.25D0*VINT(3)**2
8543 VINT(283)=(Q0S+PS)*(Q1S+PS)/
8544 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
8545 ENDIF
8546 ENDIF
8547 VINT(284)=0D0
8548 IF(MINT(108).EQ.3) THEN
8549 IF(MSTP(66).EQ.1) THEN
8550 VINT(284)=Q0S*(VINT(54)/Q0S)**PYR(0)
8551 ELSEIF(MSTP(66).EQ.2) THEN
8552 PS=VINT(4)**2
8553 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
8554 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
8555 Q2INT=SQRT(Q0S*Q2EFF)
8556 VINT(284)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
8557 ELSEIF(MSTP(66).EQ.3) THEN
8558 VINT(284)=Q0S*(Q1S/Q0S)**PYR(0)
8559 ELSEIF(MSTP(66).GE.4) THEN
8560 PS=0.25D0*VINT(4)**2
8561 VINT(284)=(Q0S+PS)*(Q1S+PS)/
8562 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
8563 ENDIF
8564 ENDIF
8565 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8566
8567C...Format statements for differential cross-section maximum violations.
8568 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
8569 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
8570 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
8571 &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
8572 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
8573 &'in event',1X,I7)
8574 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
8575 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
8576 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
8577 &'in event',1X,I7)
8578 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
8579 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
8580 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
8581 5800 FORMAT(1X,'XMAXUP(',I1,') increased to',1P,D11.3)
8582 5900 FORMAT(1X,'XMAXUP(',I2,') increased to',1P,D11.3)
8583 6000 FORMAT(1X,'XMAXUP(',I3,') increased to',1P,D11.3)
8584
8585 RETURN
8586 END
8587
8588C*********************************************************************
8589
8590C...PYSCAT
8591C...Finds outgoing flavours and event type; sets up the kinematics
8592C...and colour flow of the hard scattering
8593
8594 SUBROUTINE PYSCAT
8595
8596C...Double precision and integer declarations
8597 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8598 IMPLICIT INTEGER(I-N)
8599 INTEGER PYK,PYCHGE,PYCOMP
8600C...Parameter statement to help give large particle numbers.
8601 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
8602 &KEXCIT=4000000,KDIMEN=5000000)
8603
8604C...User process event common block.
8605 INTEGER MAXNUP
8606 PARAMETER (MAXNUP=500)
8607 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
8608 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
8609 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
8610 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
8611 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
8612 SAVE /HEPEUP/
8613
8614C...Commonblocks
8615 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
8616 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8617 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
8618 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
8619 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8620 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8621 COMMON/PYINT1/MINT(400),VINT(400)
8622 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
8623 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
8624 COMMON/PYINT4/MWID(500),WIDS(500,5)
8625 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8626 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
8627 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
8628 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
8629 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
8630 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYSSMT/,/PYTCSM/
8631C...Local arrays and saved variables
8632 DIMENSION WDTP(0:400),WDTE(0:400,0:5),PMQ(2),Z(2),CTHE(2),
8633 &PHI(2),KUPPO(100),VINTSV(41:66),ILAB(100)
8634 SAVE VINTSV
8635
8636C...Read out process
8637 ISUB=MINT(1)
8638 ISUBSV=ISUB
8639
8640C...Restore information for low-pT processes
8641 IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN
8642 DO 100 J=41,66
8643 100 VINT(J)=VINTSV(J)
8644 ENDIF
8645
8646C...Convert H' or A process into equivalent H one
8647 IHIGG=1
8648 KFHIGG=25
8649 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
8650 &ISUB.LE.190)) THEN
8651 IHIGG=2
8652 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
8653 KFHIGG=33+IHIGG
8654 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
8655 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
8656 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
8657 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
8658 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
8659 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
8660 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
8661 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
8662 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
8663 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
8664 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
8665 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
8666 ENDIF
8667
8668C...Choice of subprocess, number of documentation lines
8669 IDOC=6+ISET(ISUB)
8670 IF(ISUB.EQ.95) IDOC=8
8671 IF(ISET(ISUB).EQ.5) IDOC=9
8672 IF(ISET(ISUB).EQ.11) IDOC=4+NUP
8673 MINT(3)=IDOC-6
8674 IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2
8675 MINT(4)=IDOC
8676 IPU1=MINT(84)+1
8677 IPU2=MINT(84)+2
8678 IPU3=MINT(84)+3
8679 IPU4=MINT(84)+4
8680 IPU5=MINT(84)+5
8681 IPU6=MINT(84)+6
8682
8683C...Reset K, P and V vectors. Store incoming particles
8684 DO 120 JT=1,MSTP(126)+100
8685 I=MINT(83)+JT
8686 IF(I.GT.MSTU(4)) GOTO 120
8687 DO 110 J=1,5
8688 K(I,J)=0
8689 P(I,J)=0D0
8690 V(I,J)=0D0
8691 110 CONTINUE
8692 120 CONTINUE
8693 DO 140 JT=1,2
8694 I=MINT(83)+JT
8695 K(I,1)=21
8696 K(I,2)=MINT(10+JT)
8697 DO 130 J=1,5
8698 P(I,J)=VINT(285+5*JT+J)
8699 130 CONTINUE
8700 140 CONTINUE
8701 MINT(6)=2
8702 KFRES=0
8703
8704C...Store incoming partons in their CM-frame
8705 SH=VINT(44)
8706 SHR=SQRT(SH)
8707 SHP=VINT(26)*VINT(2)
8708 SHPR=SQRT(SHP)
8709 SHUSER=SHR
8710 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR
8711 DO 150 JT=1,2
8712 I=MINT(84)+JT
8713 K(I,1)=14
8714 K(I,2)=MINT(14+JT)
8715 K(I,3)=MINT(83)+2+JT
8716 P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1)
8717 P(I,4)=0.5D0*SHUSER
8718 150 CONTINUE
8719
8720C...Copy incoming partons to documentation lines
8721 DO 170 JT=1,2
8722 I1=MINT(83)+4+JT
8723 I2=MINT(84)+JT
8724 K(I1,1)=21
8725 K(I1,2)=K(I2,2)
8726 K(I1,3)=I1-2
8727 DO 160 J=1,5
8728 P(I1,J)=P(I2,J)
8729 160 CONTINUE
8730 170 CONTINUE
8731
8732C...Choose new quark/lepton flavour for relevant annihilation graphs
8733 IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58.OR.
8734 &(ISUB.GE.135.AND.ISUB.LE.140).OR.ISUB.EQ.382.OR.ISUB.EQ.385) THEN
8735 IGLGA=21
8736 IF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) IGLGA=22
8737 CALL PYWIDT(IGLGA,SH,WDTP,WDTE)
8738 180 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
8739 DO 190 I=1,MDCY(IGLGA,3)
8740 KFLF=KFDP(I+MDCY(IGLGA,2)-1,1)
8741 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
8742 IF(RKFL.LE.0D0) GOTO 200
8743 190 CONTINUE
8744 200 CONTINUE
8745 IF((ISUB.EQ.53.OR.ISUB.EQ.385).AND.MINT(2).LE.2) THEN
8746 IF(KFLF.GE.4) GOTO 180
8747 ELSEIF((ISUB.EQ.53.OR.ISUB.EQ.385).AND.MINT(2).LE.4) THEN
8748 KFLF=4
8749 MINT(2)=MINT(2)-2
8750 ELSEIF(ISUB.EQ.53.OR.ISUB.EQ.385) THEN
8751 KFLF=5
8752 MINT(2)=MINT(2)-4
8753 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.1.AND.IABS(MINT(15)).LE.2
8754 & .AND.IABS(KFLF).GE.3) THEN
8755 FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/
8756 & VINT(44)**2
8757 FACCIB=VINT(46)**2/RTCM(41)**4
8758 IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180
8759 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.2) THEN
8760 KFLF=5
8761 MINT(2)=1
8762 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.1) THEN
8763 IF(KFLF.EQ.5) GOTO 180
8764 ELSEIF(ISUB.EQ.54.OR.ISUB.EQ.135.OR.ISUB.EQ.136) THEN
8765 IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180
8766 ELSEIF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) THEN
8767 IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180
8768 ENDIF
8769 ENDIF
8770
8771C...Final state flavours and colour flow: default values
8772 JS=1
8773 MINT(21)=MINT(15)
8774 MINT(22)=MINT(16)
8775 MINT(23)=0
8776 MINT(24)=0
8777 KCC=20
8778 KCS=ISIGN(1,MINT(15))
8779
8780 IF(ISET(ISUB).EQ.11) THEN
8781C...User-defined processes: find products
8782 MINT(3)=0
8783 DO 210 IUP=3,NUP
8784 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) THEN
8785 ELSEIF(NUP.EQ.5.AND.IUP.GE.4.AND.MOTHUP(1,4).EQ.3) THEN
8786 MINT(21+IUP)=IDUP(IUP)
8787 ELSEIF(ISTUP(IUP).EQ.1.AND.(ISTUP(MOTHUP(1,IUP)).EQ.2.OR.
8788 & ISTUP(MOTHUP(1,IUP)).EQ.3).AND.IDUP(MOTHUP(1,IUP)).NE.0) THEN
8789 ELSEIF(IDUP(IUP).EQ.0) THEN
8790 ELSE
8791 MINT(3)=MINT(3)+1
8792 IF(MINT(3).LE.6) MINT(20+MINT(3))=IDUP(IUP)
8793 ENDIF
8794 210 CONTINUE
8795
8796 ELSEIF(ISUB.LE.10) THEN
8797 IF(ISUB.EQ.1) THEN
8798C...f + fbar -> gamma*/Z0
8799 KFRES=23
8800
8801 ELSEIF(ISUB.EQ.2) THEN
8802C...f + fbar' -> W+/-
8803 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8804 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8805 KFRES=ISIGN(24,KCH1+KCH2)
8806
8807 ELSEIF(ISUB.EQ.3) THEN
8808C...f + fbar -> h0 (or H0, or A0)
8809 KFRES=KFHIGG
8810
8811 ELSEIF(ISUB.EQ.4) THEN
8812C...gamma + W+/- -> W+/-
8813
8814 ELSEIF(ISUB.EQ.5) THEN
8815C...Z0 + Z0 -> h0
8816 XH=SH/SHP
8817 MINT(21)=MINT(15)
8818 MINT(22)=MINT(16)
8819 PMQ(1)=PYMASS(MINT(21))
8820 PMQ(2)=PYMASS(MINT(22))
8821 220 JT=INT(1.5D0+PYR(0))
8822 ZMIN=2D0*PMQ(JT)/SHPR
8823 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
8824 & (SHPR*(SHPR-PMQ(3-JT)))
8825 ZMAX=MIN(1D0-XH,ZMAX)
8826 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
8827 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
8828 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220
8829 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
8830 IF(SQC1.LT.1D-8) GOTO 220
8831 C1=SQRT(SQC1)
8832 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
8833 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8834 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
8835 Z(3-JT)=1D0-XH/(1D0-Z(JT))
8836 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
8837 IF(SQC1.LT.1D-8) GOTO 220
8838 C1=SQRT(SQC1)
8839 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
8840 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8841 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
8842 PHIR=PARU(2)*PYR(0)
8843 CPHI=COS(PHIR)
8844 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
8845 & SQRT(1D0-CTHE(2)**2)*CPHI
8846 Z1=2D0-Z(JT)
8847 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
8848 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
8849 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
8850 & PMQ(3-JT)**2/SHP))
8851 ZMIN=2D0*PMQ(3-JT)/SHPR
8852 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
8853 ZMAX=MIN(1D0-XH,ZMAX)
8854 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220
8855 KCC=22
8856 KFRES=25
8857
8858 ELSEIF(ISUB.EQ.6) THEN
8859C...Z0 + W+/- -> W+/-
8860
8861 ELSEIF(ISUB.EQ.7) THEN
8862C...W+ + W- -> Z0
8863
8864 ELSEIF(ISUB.EQ.8) THEN
8865C...W+ + W- -> h0
8866 XH=SH/SHP
8867 230 DO 260 JT=1,2
8868 I=MINT(14+JT)
8869 IA=IABS(I)
8870 IF(IA.LE.10) THEN
8871 RVCKM=VINT(180+I)*PYR(0)
8872 DO 240 J=1,MSTP(1)
8873 IB=2*J-1+MOD(IA,2)
8874 IPM=(5-ISIGN(1,I))/2
8875 IDC=J+MDCY(IA,2)+2
8876 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240
8877 MINT(20+JT)=ISIGN(IB,I)
8878 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8879 IF(RVCKM.LE.0D0) GOTO 250
8880 240 CONTINUE
8881 ELSE
8882 IB=2*((IA+1)/2)-1+MOD(IA,2)
8883 MINT(20+JT)=ISIGN(IB,I)
8884 ENDIF
8885 250 PMQ(JT)=PYMASS(MINT(20+JT))
8886 260 CONTINUE
8887 JT=INT(1.5D0+PYR(0))
8888 ZMIN=2D0*PMQ(JT)/SHPR
8889 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
8890 & (SHPR*(SHPR-PMQ(3-JT)))
8891 ZMAX=MIN(1D0-XH,ZMAX)
8892 IF(ZMIN.GE.ZMAX) GOTO 230
8893 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
8894 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
8895 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230
8896 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
8897 IF(SQC1.LT.1D-8) GOTO 230
8898 C1=SQRT(SQC1)
8899 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
8900 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8901 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
8902 Z(3-JT)=1D0-XH/(1D0-Z(JT))
8903 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
8904 IF(SQC1.LT.1D-8) GOTO 230
8905 C1=SQRT(SQC1)
8906 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
8907 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8908 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
8909 PHIR=PARU(2)*PYR(0)
8910 CPHI=COS(PHIR)
8911 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
8912 & SQRT(1D0-CTHE(2)**2)*CPHI
8913 Z1=2D0-Z(JT)
8914 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
8915 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
8916 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
8917 & PMQ(3-JT)**2/SHP))
8918 ZMIN=2D0*PMQ(3-JT)/SHPR
8919 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
8920 ZMAX=MIN(1D0-XH,ZMAX)
8921 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230
8922 KCC=22
8923 KFRES=25
8924
8925 ELSEIF(ISUB.EQ.10) THEN
8926C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
8927 IF(MINT(2).EQ.1) THEN
8928 KCC=22
8929 ELSE
8930C...W exchange: need to mix flavours according to CKM matrix
8931 DO 280 JT=1,2
8932 I=MINT(14+JT)
8933 IA=IABS(I)
8934 IF(IA.LE.10) THEN
8935 RVCKM=VINT(180+I)*PYR(0)
8936 DO 270 J=1,MSTP(1)
8937 IB=2*J-1+MOD(IA,2)
8938 IPM=(5-ISIGN(1,I))/2
8939 IDC=J+MDCY(IA,2)+2
8940 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
8941 MINT(20+JT)=ISIGN(IB,I)
8942 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8943 IF(RVCKM.LE.0D0) GOTO 280
8944 270 CONTINUE
8945 ELSE
8946 IB=2*((IA+1)/2)-1+MOD(IA,2)
8947 MINT(20+JT)=ISIGN(IB,I)
8948 ENDIF
8949 280 CONTINUE
8950 KCC=22
8951 ENDIF
8952 ENDIF
8953
8954 ELSEIF(ISUB.LE.20) THEN
8955 IF(ISUB.EQ.11) THEN
8956C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
8957 KCC=MINT(2)
8958 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8959
8960 ELSEIF(ISUB.EQ.12) THEN
8961C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
8962 MINT(21)=ISIGN(KFLF,MINT(15))
8963 MINT(22)=-MINT(21)
8964 KCC=4
8965
8966 ELSEIF(ISUB.EQ.13) THEN
8967C...f + fbar -> g + g; th arbitrary
8968 MINT(21)=21
8969 MINT(22)=21
8970 KCC=MINT(2)+4
8971
8972 ELSEIF(ISUB.EQ.14) THEN
8973C...f + fbar -> g + gamma; th arbitrary
8974 IF(PYR(0).GT.0.5D0) JS=2
8975 MINT(20+JS)=21
8976 MINT(23-JS)=22
8977 KCC=17+JS
8978
8979 ELSEIF(ISUB.EQ.15) THEN
8980C...f + fbar -> g + Z0; th arbitrary
8981 IF(PYR(0).GT.0.5D0) JS=2
8982 MINT(20+JS)=21
8983 MINT(23-JS)=23
8984 KCC=17+JS
8985
8986 ELSEIF(ISUB.EQ.16) THEN
8987C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
8988 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8989 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8990 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
8991 MINT(20+JS)=21
8992 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
8993 KCC=17+JS
8994
8995 ELSEIF(ISUB.EQ.17) THEN
8996C...f + fbar -> g + h0; th arbitrary
8997 IF(PYR(0).GT.0.5D0) JS=2
8998 MINT(20+JS)=21
8999 MINT(23-JS)=25
9000 KCC=17+JS
9001
9002 ELSEIF(ISUB.EQ.18) THEN
9003C...f + fbar -> gamma + gamma; th arbitrary
9004 MINT(21)=22
9005 MINT(22)=22
9006
9007 ELSEIF(ISUB.EQ.19) THEN
9008C...f + fbar -> gamma + Z0; th arbitrary
9009 IF(PYR(0).GT.0.5D0) JS=2
9010 MINT(20+JS)=22
9011 MINT(23-JS)=23
9012
9013 ELSEIF(ISUB.EQ.20) THEN
9014C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
9015C...(p(fbar')-p(W+))**2
9016 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9017 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9018 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
9019 MINT(20+JS)=22
9020 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
9021 ENDIF
9022
9023 ELSEIF(ISUB.LE.30) THEN
9024 IF(ISUB.EQ.21) THEN
9025C...f + fbar -> gamma + h0; th arbitrary
9026 IF(PYR(0).GT.0.5D0) JS=2
9027 MINT(20+JS)=22
9028 MINT(23-JS)=25
9029
9030 ELSEIF(ISUB.EQ.22) THEN
9031C...f + fbar -> Z0 + Z0; th arbitrary
9032 MINT(21)=23
9033 MINT(22)=23
9034
9035 ELSEIF(ISUB.EQ.23) THEN
9036C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
9037 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9038 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9039 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
9040 MINT(20+JS)=23
9041 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
9042
9043 ELSEIF(ISUB.EQ.24) THEN
9044C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
9045 IF(PYR(0).GT.0.5D0) JS=2
9046 MINT(20+JS)=23
9047 MINT(23-JS)=KFHIGG
9048
9049 ELSEIF(ISUB.EQ.25) THEN
9050C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
9051 MINT(21)=-ISIGN(24,MINT(15))
9052 MINT(22)=-MINT(21)
9053
9054 ELSEIF(ISUB.EQ.26) THEN
9055C...f + fbar' -> W+/- + h0 (or H0, or A0);
9056C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
9057 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9058 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9059 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
9060 MINT(20+JS)=ISIGN(24,KCH1+KCH2)
9061 MINT(23-JS)=KFHIGG
9062
9063 ELSEIF(ISUB.EQ.27) THEN
9064C...f + fbar -> h0 + h0
9065
9066 ELSEIF(ISUB.EQ.28) THEN
9067C...f + g -> f + g; th = (p(f)-p(f))**2
9068 IF(MINT(15).EQ.21) JS=2
9069 KCC=MINT(2)+6
9070 IF(MINT(15).EQ.21) KCC=KCC+2
9071 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
9072 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
9073
9074 ELSEIF(ISUB.EQ.29) THEN
9075C...f + g -> f + gamma; th = (p(f)-p(f))**2
9076 IF(MINT(15).EQ.21) JS=2
9077 MINT(23-JS)=22
9078 KCC=15+JS
9079 KCS=ISIGN(1,MINT(14+JS))
9080
9081 ELSEIF(ISUB.EQ.30) THEN
9082C...f + g -> f + Z0; th = (p(f)-p(f))**2
9083 IF(MINT(15).EQ.21) JS=2
9084 MINT(23-JS)=23
9085 KCC=15+JS
9086 KCS=ISIGN(1,MINT(14+JS))
9087 ENDIF
9088
9089 ELSEIF(ISUB.LE.40) THEN
9090 IF(ISUB.EQ.31) THEN
9091C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
9092 IF(MINT(15).EQ.21) JS=2
9093 I=MINT(14+JS)
9094 IA=IABS(I)
9095 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
9096 RVCKM=VINT(180+I)*PYR(0)
9097 DO 290 J=1,MSTP(1)
9098 IB=2*J-1+MOD(IA,2)
9099 IPM=(5-ISIGN(1,I))/2
9100 IDC=J+MDCY(IA,2)+2
9101 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290
9102 MINT(20+JS)=ISIGN(IB,I)
9103 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
9104 IF(RVCKM.LE.0D0) GOTO 300
9105 290 CONTINUE
9106 300 KCC=15+JS
9107 KCS=ISIGN(1,MINT(14+JS))
9108
9109 ELSEIF(ISUB.EQ.32) THEN
9110C...f + g -> f + h0; th = (p(f)-p(f))**2
9111 IF(MINT(15).EQ.21) JS=2
9112 MINT(23-JS)=25
9113 KCC=15+JS
9114 KCS=ISIGN(1,MINT(14+JS))
9115
9116 ELSEIF(ISUB.EQ.33) THEN
9117C...f + gamma -> f + g; th=(p(f)-p(f))**2
9118 IF(MINT(15).EQ.22) JS=2
9119 MINT(23-JS)=21
9120 KCC=24+JS
9121 KCS=ISIGN(1,MINT(14+JS))
9122
9123 ELSEIF(ISUB.EQ.34) THEN
9124C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
9125 IF(MINT(15).EQ.22) JS=2
9126 KCC=22
9127 KCS=ISIGN(1,MINT(14+JS))
9128
9129 ELSEIF(ISUB.EQ.35) THEN
9130C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
9131 IF(MINT(15).EQ.22) JS=2
9132 MINT(23-JS)=23
9133 KCC=22
9134
9135 ELSEIF(ISUB.EQ.36) THEN
9136C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
9137 IF(MINT(15).EQ.22) JS=2
9138 I=MINT(14+JS)
9139 IA=IABS(I)
9140 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
9141 IF(IA.LE.10) THEN
9142 RVCKM=VINT(180+I)*PYR(0)
9143 DO 310 J=1,MSTP(1)
9144 IB=2*J-1+MOD(IA,2)
9145 IPM=(5-ISIGN(1,I))/2
9146 IDC=J+MDCY(IA,2)+2
9147 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310
9148 MINT(20+JS)=ISIGN(IB,I)
9149 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
9150 IF(RVCKM.LE.0D0) GOTO 320
9151 310 CONTINUE
9152 ELSE
9153 IB=2*((IA+1)/2)-1+MOD(IA,2)
9154 MINT(20+JS)=ISIGN(IB,I)
9155 ENDIF
9156 320 KCC=22
9157
9158 ELSEIF(ISUB.EQ.37) THEN
9159C...f + gamma -> f + h0
9160
9161 ELSEIF(ISUB.EQ.38) THEN
9162C...f + Z0 -> f + g
9163
9164 ELSEIF(ISUB.EQ.39) THEN
9165C...f + Z0 -> f + gamma
9166
9167 ELSEIF(ISUB.EQ.40) THEN
9168C...f + Z0 -> f + Z0
9169 ENDIF
9170
9171 ELSEIF(ISUB.LE.50) THEN
9172 IF(ISUB.EQ.41) THEN
9173C...f + Z0 -> f' + W+/-
9174
9175 ELSEIF(ISUB.EQ.42) THEN
9176C...f + Z0 -> f + h0
9177
9178 ELSEIF(ISUB.EQ.43) THEN
9179C...f + W+/- -> f' + g
9180
9181 ELSEIF(ISUB.EQ.44) THEN
9182C...f + W+/- -> f' + gamma
9183
9184 ELSEIF(ISUB.EQ.45) THEN
9185C...f + W+/- -> f' + Z0
9186
9187 ELSEIF(ISUB.EQ.46) THEN
9188C...f + W+/- -> f' + W+/-
9189
9190 ELSEIF(ISUB.EQ.47) THEN
9191C...f + W+/- -> f' + h0
9192
9193 ELSEIF(ISUB.EQ.48) THEN
9194C...f + h0 -> f + g
9195
9196 ELSEIF(ISUB.EQ.49) THEN
9197C...f + h0 -> f + gamma
9198
9199 ELSEIF(ISUB.EQ.50) THEN
9200C...f + h0 -> f + Z0
9201 ENDIF
9202
9203 ELSEIF(ISUB.LE.60) THEN
9204 IF(ISUB.EQ.51) THEN
9205C...f + h0 -> f' + W+/-
9206
9207 ELSEIF(ISUB.EQ.52) THEN
9208C...f + h0 -> f + h0
9209
9210 ELSEIF(ISUB.EQ.53) THEN
9211C...g + g -> f + fbar; th arbitrary
9212 KCS=(-1)**INT(1.5D0+PYR(0))
9213 MINT(21)=ISIGN(KFLF,KCS)
9214 MINT(22)=-MINT(21)
9215 KCC=MINT(2)+10
9216
9217 ELSEIF(ISUB.EQ.54) THEN
9218C...g + gamma -> f + fbar; th arbitrary
9219 KCS=(-1)**INT(1.5D0+PYR(0))
9220 MINT(21)=ISIGN(KFLF,KCS)
9221 MINT(22)=-MINT(21)
9222 KCC=27
9223 IF(MINT(16).EQ.21) KCC=28
9224
9225 ELSEIF(ISUB.EQ.55) THEN
9226C...g + Z0 -> f + fbar
9227
9228 ELSEIF(ISUB.EQ.56) THEN
9229C...g + W+/- -> f + fbar'
9230
9231 ELSEIF(ISUB.EQ.57) THEN
9232C...g + h0 -> f + fbar
9233
9234 ELSEIF(ISUB.EQ.58) THEN
9235C...gamma + gamma -> f + fbar; th arbitrary
9236 KCS=(-1)**INT(1.5D0+PYR(0))
9237 MINT(21)=ISIGN(KFLF,KCS)
9238 MINT(22)=-MINT(21)
9239 KCC=21
9240
9241 ELSEIF(ISUB.EQ.59) THEN
9242C...gamma + Z0 -> f + fbar
9243
9244 ELSEIF(ISUB.EQ.60) THEN
9245C...gamma + W+/- -> f + fbar'
9246 ENDIF
9247
9248 ELSEIF(ISUB.LE.70) THEN
9249 IF(ISUB.EQ.61) THEN
9250C...gamma + h0 -> f + fbar
9251
9252 ELSEIF(ISUB.EQ.62) THEN
9253C...Z0 + Z0 -> f + fbar
9254
9255 ELSEIF(ISUB.EQ.63) THEN
9256C...Z0 + W+/- -> f + fbar'
9257
9258 ELSEIF(ISUB.EQ.64) THEN
9259C...Z0 + h0 -> f + fbar
9260
9261 ELSEIF(ISUB.EQ.65) THEN
9262C...W+ + W- -> f + fbar
9263
9264 ELSEIF(ISUB.EQ.66) THEN
9265C...W+/- + h0 -> f + fbar'
9266
9267 ELSEIF(ISUB.EQ.67) THEN
9268C...h0 + h0 -> f + fbar
9269
9270 ELSEIF(ISUB.EQ.68) THEN
9271C...g + g -> g + g; th arbitrary
9272 KCC=MINT(2)+12
9273 KCS=(-1)**INT(1.5D0+PYR(0))
9274
9275 ELSEIF(ISUB.EQ.69) THEN
9276C...gamma + gamma -> W+ + W-; th arbitrary
9277 MINT(21)=24
9278 MINT(22)=-24
9279 KCC=21
9280
9281 ELSEIF(ISUB.EQ.70) THEN
9282C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
9283 IF(MINT(15).EQ.22) MINT(21)=23
9284 IF(MINT(16).EQ.22) MINT(22)=23
9285 KCC=21
9286 ENDIF
9287
9288 ELSEIF(ISUB.LE.80) THEN
9289 IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
9290C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
9291 XH=SH/SHP
9292 MINT(21)=MINT(15)
9293 MINT(22)=MINT(16)
9294 PMQ(1)=PYMASS(MINT(21))
9295 PMQ(2)=PYMASS(MINT(22))
9296 330 JT=INT(1.5D0+PYR(0))
9297 ZMIN=2D0*PMQ(JT)/SHPR
9298 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
9299 & (SHPR*(SHPR-PMQ(3-JT)))
9300 ZMAX=MIN(1D0-XH,ZMAX)
9301 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
9302 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
9303 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330
9304 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
9305 IF(SQC1.LT.1D-8) GOTO 330
9306 C1=SQRT(SQC1)
9307 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
9308 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9309 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
9310 Z(3-JT)=1D0-XH/(1D0-Z(JT))
9311 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
9312 IF(SQC1.LT.1D-8) GOTO 330
9313 C1=SQRT(SQC1)
9314 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
9315 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9316 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
9317 PHIR=PARU(2)*PYR(0)
9318 CPHI=COS(PHIR)
9319 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
9320 & SQRT(1D0-CTHE(2)**2)*CPHI
9321 Z1=2D0-Z(JT)
9322 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
9323 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
9324 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
9325 & PMQ(3-JT)**2/SHP))
9326 ZMIN=2D0*PMQ(3-JT)/SHPR
9327 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
9328 ZMAX=MIN(1D0-XH,ZMAX)
9329 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330
9330 KCC=22
9331
9332 ELSEIF(ISUB.EQ.73) THEN
9333C...Z0 + W+/- -> Z0 + W+/-
9334 JS=MINT(2)
9335 XH=SH/SHP
9336 340 JT=3-MINT(2)
9337 I=MINT(14+JT)
9338 IA=IABS(I)
9339 IF(IA.LE.10) THEN
9340 RVCKM=VINT(180+I)*PYR(0)
9341 DO 350 J=1,MSTP(1)
9342 IB=2*J-1+MOD(IA,2)
9343 IPM=(5-ISIGN(1,I))/2
9344 IDC=J+MDCY(IA,2)+2
9345 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350
9346 MINT(20+JT)=ISIGN(IB,I)
9347 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
9348 IF(RVCKM.LE.0D0) GOTO 360
9349 350 CONTINUE
9350 ELSE
9351 IB=2*((IA+1)/2)-1+MOD(IA,2)
9352 MINT(20+JT)=ISIGN(IB,I)
9353 ENDIF
9354 360 PMQ(JT)=PYMASS(MINT(20+JT))
9355 MINT(23-JT)=MINT(17-JT)
9356 PMQ(3-JT)=PYMASS(MINT(23-JT))
9357 JT=INT(1.5D0+PYR(0))
9358 ZMIN=2D0*PMQ(JT)/SHPR
9359 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
9360 & (SHPR*(SHPR-PMQ(3-JT)))
9361 ZMAX=MIN(1D0-XH,ZMAX)
9362 IF(ZMIN.GE.ZMAX) GOTO 340
9363 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
9364 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
9365 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340
9366 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
9367 IF(SQC1.LT.1D-8) GOTO 340
9368 C1=SQRT(SQC1)
9369 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
9370 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9371 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
9372 Z(3-JT)=1D0-XH/(1D0-Z(JT))
9373 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
9374 IF(SQC1.LT.1D-8) GOTO 340
9375 C1=SQRT(SQC1)
9376 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
9377 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9378 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
9379 PHIR=PARU(2)*PYR(0)
9380 CPHI=COS(PHIR)
9381 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
9382 & SQRT(1D0-CTHE(2)**2)*CPHI
9383 Z1=2D0-Z(JT)
9384 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
9385 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
9386 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
9387 & PMQ(3-JT)**2/SHP))
9388 ZMIN=2D0*PMQ(3-JT)/SHPR
9389 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
9390 ZMAX=MIN(1D0-XH,ZMAX)
9391 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
9392 KCC=22
9393
9394 ELSEIF(ISUB.EQ.74) THEN
9395C...Z0 + h0 -> Z0 + h0
9396
9397 ELSEIF(ISUB.EQ.75) THEN
9398C...W+ + W- -> gamma + gamma
9399
9400 ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
9401C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
9402 XH=SH/SHP
9403 370 DO 400 JT=1,2
9404 I=MINT(14+JT)
9405 IA=IABS(I)
9406 IF(IA.LE.10) THEN
9407 RVCKM=VINT(180+I)*PYR(0)
9408 DO 380 J=1,MSTP(1)
9409 IB=2*J-1+MOD(IA,2)
9410 IPM=(5-ISIGN(1,I))/2
9411 IDC=J+MDCY(IA,2)+2
9412 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380
9413 MINT(20+JT)=ISIGN(IB,I)
9414 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
9415 IF(RVCKM.LE.0D0) GOTO 390
9416 380 CONTINUE
9417 ELSE
9418 IB=2*((IA+1)/2)-1+MOD(IA,2)
9419 MINT(20+JT)=ISIGN(IB,I)
9420 ENDIF
9421 390 PMQ(JT)=PYMASS(MINT(20+JT))
9422 400 CONTINUE
9423 JT=INT(1.5D0+PYR(0))
9424 ZMIN=2D0*PMQ(JT)/SHPR
9425 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
9426 & (SHPR*(SHPR-PMQ(3-JT)))
9427 ZMAX=MIN(1D0-XH,ZMAX)
9428 IF(ZMIN.GE.ZMAX) GOTO 370
9429 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
9430 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
9431 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370
9432 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
9433 IF(SQC1.LT.1D-8) GOTO 370
9434 C1=SQRT(SQC1)
9435 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
9436 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9437 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
9438 Z(3-JT)=1D0-XH/(1D0-Z(JT))
9439 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
9440 IF(SQC1.LT.1D-8) GOTO 370
9441 C1=SQRT(SQC1)
9442 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
9443 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9444 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
9445 PHIR=PARU(2)*PYR(0)
9446 CPHI=COS(PHIR)
9447 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
9448 & SQRT(1D0-CTHE(2)**2)*CPHI
9449 Z1=2D0-Z(JT)
9450 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
9451 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
9452 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
9453 & PMQ(3-JT)**2/SHP))
9454 ZMIN=2D0*PMQ(3-JT)/SHPR
9455 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
9456 ZMAX=MIN(1D0-XH,ZMAX)
9457 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370
9458 KCC=22
9459
9460 ELSEIF(ISUB.EQ.78) THEN
9461C...W+/- + h0 -> W+/- + h0
9462
9463 ELSEIF(ISUB.EQ.79) THEN
9464C...h0 + h0 -> h0 + h0
9465
9466 ELSEIF(ISUB.EQ.80) THEN
9467C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
9468 IF(MINT(15).EQ.22) JS=2
9469 I=MINT(14+JS)
9470 IA=IABS(I)
9471 MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I)
9472 IB=3-IA
9473 MINT(20+JS)=ISIGN(IB,I)
9474 KCC=22
9475 ENDIF
9476
9477 ELSEIF(ISUB.LE.90) THEN
9478 IF(ISUB.EQ.81) THEN
9479C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
9480 MINT(21)=ISIGN(MINT(55),MINT(15))
9481 MINT(22)=-MINT(21)
9482 KCC=4
9483
9484 ELSEIF(ISUB.EQ.82) THEN
9485C...g + g -> Q + Qbar; th arbitrary
9486 KCS=(-1)**INT(1.5D0+PYR(0))
9487 MINT(21)=ISIGN(MINT(55),KCS)
9488 MINT(22)=-MINT(21)
9489 KCC=MINT(2)+10
9490
9491 ELSEIF(ISUB.EQ.83) THEN
9492C...f + q -> f' + Q; th = (p(f) - p(f'))**2
9493 KFOLD=MINT(16)
9494 IF(MINT(2).EQ.2) KFOLD=MINT(15)
9495 KFAOLD=IABS(KFOLD)
9496 IF(KFAOLD.GT.10) THEN
9497 KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1
9498 ELSE
9499 RCKM=VINT(180+KFOLD)*PYR(0)
9500 IPM=(5-ISIGN(1,KFOLD))/2
9501 KFANEW=-MOD(KFAOLD+1,2)
9502 410 KFANEW=KFANEW+2
9503 IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2
9504 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN
9505 IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM-
9506 & VCKM(KFAOLD/2,(KFANEW+1)/2)
9507 IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM-
9508 & VCKM(KFANEW/2,(KFAOLD+1)/2)
9509 ENDIF
9510 IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410
9511 ENDIF
9512 IF(MINT(2).EQ.1) THEN
9513 MINT(21)=ISIGN(MINT(55),MINT(15))
9514 MINT(22)=ISIGN(KFANEW,MINT(16))
9515 ELSE
9516 MINT(21)=ISIGN(KFANEW,MINT(15))
9517 MINT(22)=ISIGN(MINT(55),MINT(16))
9518 JS=2
9519 ENDIF
9520 KCC=22
9521
9522 ELSEIF(ISUB.EQ.84) THEN
9523C...g + gamma -> Q + Qbar; th arbitary
9524 KCS=(-1)**INT(1.5D0+PYR(0))
9525 MINT(21)=ISIGN(MINT(55),KCS)
9526 MINT(22)=-MINT(21)
9527 KCC=27
9528 IF(MINT(16).EQ.21) KCC=28
9529
9530 ELSEIF(ISUB.EQ.85) THEN
9531C...gamma + gamma -> F + Fbar; th arbitary
9532 KCS=(-1)**INT(1.5D0+PYR(0))
9533 MINT(21)=ISIGN(MINT(56),KCS)
9534 MINT(22)=-MINT(21)
9535 KCC=21
9536
9537 ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN
9538C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
9539 MINT(21)=KFPR(ISUB,1)
9540 MINT(22)=KFPR(ISUB,2)
9541 KCC=24
9542 KCS=(-1)**INT(1.5D0+PYR(0))
9543 ENDIF
9544
9545 ELSEIF(ISUB.LE.100) THEN
9546 IF(ISUB.EQ.95) THEN
9547C...Low-pT ( = energyless g + g -> g + g)
9548 KCC=MINT(2)+12
9549 KCS=(-1)**INT(1.5D0+PYR(0))
9550
9551 ELSEIF(ISUB.EQ.96) THEN
9552C...Multiple interactions (should be reassigned to QCD process)
9553 ENDIF
9554
9555 ELSEIF(ISUB.LE.110) THEN
9556 IF(ISUB.EQ.101) THEN
9557C...g + g -> gamma*/Z0
9558 KCC=21
9559 KFRES=22
9560
9561 ELSEIF(ISUB.EQ.102) THEN
9562C...g + g -> h0 (or H0, or A0)
9563 KCC=21
9564 KFRES=KFHIGG
9565
9566 ELSEIF(ISUB.EQ.103) THEN
9567C...gamma + gamma -> h0 (or H0, or A0)
9568 KCC=21
9569 KFRES=KFHIGG
9570
9571 ELSEIF(ISUB.EQ.104.OR.ISUB.EQ.105) THEN
9572C...g + g -> chi_0c or chi_2c.
9573 KCC=21
9574 KFRES=KFPR(ISUB,1)
9575
9576 ELSEIF(ISUB.EQ.106) THEN
9577C...g + g -> J/Psi + gamma
9578 MINT(21)=KFPR(ISUB,1)
9579 MINT(22)=KFPR(ISUB,2)
9580 KCC=21
9581
9582 ELSEIF(ISUB.EQ.107) THEN
9583C...g + gamma -> J/Psi + g
9584 MINT(21)=KFPR(ISUB,1)
9585 MINT(22)=KFPR(ISUB,2)
9586 KCC=22
9587 IF(MINT(16).EQ.22) KCC=33
9588
9589 ELSEIF(ISUB.EQ.108) THEN
9590C...gamma + gamma -> J/Psi + gamma
9591 MINT(21)=KFPR(ISUB,1)
9592 MINT(22)=KFPR(ISUB,2)
9593
9594 ELSEIF(ISUB.EQ.110) THEN
9595C...f + fbar -> gamma + h0; th arbitrary
9596 IF(PYR(0).GT.0.5D0) JS=2
9597 MINT(20+JS)=22
9598 MINT(23-JS)=KFHIGG
9599 ENDIF
9600
9601 ELSEIF(ISUB.LE.120) THEN
9602 IF(ISUB.EQ.111) THEN
9603C...f + fbar -> g + h0; th arbitrary
9604 IF(PYR(0).GT.0.5D0) JS=2
9605 MINT(20+JS)=21
9606 MINT(23-JS)=KFHIGG
9607 KCC=17+JS
9608
9609 ELSEIF(ISUB.EQ.112) THEN
9610C...f + g -> f + h0; th = (p(f) - p(f))**2
9611 IF(MINT(15).EQ.21) JS=2
9612 MINT(23-JS)=KFHIGG
9613 KCC=15+JS
9614 KCS=ISIGN(1,MINT(14+JS))
9615
9616 ELSEIF(ISUB.EQ.113) THEN
9617C...g + g -> g + h0; th arbitrary
9618 IF(PYR(0).GT.0.5D0) JS=2
9619 MINT(23-JS)=KFHIGG
9620 KCC=22+JS
9621 KCS=(-1)**INT(1.5D0+PYR(0))
9622
9623 ELSEIF(ISUB.EQ.114) THEN
9624C...g + g -> gamma + gamma; th arbitrary
9625 IF(PYR(0).GT.0.5D0) JS=2
9626 MINT(21)=22
9627 MINT(22)=22
9628 KCC=21
9629
9630 ELSEIF(ISUB.EQ.115) THEN
9631C...g + g -> g + gamma; th arbitrary
9632 IF(PYR(0).GT.0.5D0) JS=2
9633 MINT(23-JS)=22
9634 KCC=22+JS
9635 KCS=(-1)**INT(1.5D0+PYR(0))
9636
9637 ELSEIF(ISUB.EQ.116) THEN
9638C...g + g -> gamma + Z0
9639
9640 ELSEIF(ISUB.EQ.117) THEN
9641C...g + g -> Z0 + Z0
9642
9643 ELSEIF(ISUB.EQ.118) THEN
9644C...g + g -> W+ + W-
9645 ENDIF
9646
9647 ELSEIF(ISUB.LE.140) THEN
9648 IF(ISUB.EQ.121) THEN
9649C...g + g -> Q + Qbar + h0
9650 KCS=(-1)**INT(1.5D0+PYR(0))
9651 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
9652 MINT(22)=-MINT(21)
9653 KCC=11+INT(0.5D0+PYR(0))
9654 KFRES=KFHIGG
9655
9656 ELSEIF(ISUB.EQ.122) THEN
9657C...q + qbar -> Q + Qbar + h0
9658 MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15))
9659 MINT(22)=-MINT(21)
9660 KCC=4
9661 KFRES=KFHIGG
9662
9663 ELSEIF(ISUB.EQ.123) THEN
9664C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
9665C...inner process)
9666 KCC=22
9667 KFRES=KFHIGG
9668
9669 ELSEIF(ISUB.EQ.124) THEN
9670C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
9671C...inner process)
9672 DO 430 JT=1,2
9673 I=MINT(14+JT)
9674 IA=IABS(I)
9675 IF(IA.LE.10) THEN
9676 RVCKM=VINT(180+I)*PYR(0)
9677 DO 420 J=1,MSTP(1)
9678 IB=2*J-1+MOD(IA,2)
9679 IPM=(5-ISIGN(1,I))/2
9680 IDC=J+MDCY(IA,2)+2
9681 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420
9682 MINT(20+JT)=ISIGN(IB,I)
9683 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
9684 IF(RVCKM.LE.0D0) GOTO 430
9685 420 CONTINUE
9686 ELSE
9687 IB=2*((IA+1)/2)-1+MOD(IA,2)
9688 MINT(20+JT)=ISIGN(IB,I)
9689 ENDIF
9690 430 CONTINUE
9691 KCC=22
9692 KFRES=KFHIGG
9693
9694 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
9695C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2
9696 IF(MINT(15).EQ.22) JS=2
9697 MINT(23-JS)=21
9698 KCC=24+JS
9699 KCS=ISIGN(1,MINT(14+JS))
9700
9701 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
9702C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2
9703 IF(MINT(15).EQ.22) JS=2
9704 KCC=22
9705 KCS=ISIGN(1,MINT(14+JS))
9706
9707 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
9708C...g + gamma*_(T,L) -> f + fbar; th arbitrary
9709 KCS=(-1)**INT(1.5D0+PYR(0))
9710 MINT(21)=ISIGN(KFLF,KCS)
9711 MINT(22)=-MINT(21)
9712 KCC=27
9713 IF(MINT(16).EQ.21) KCC=28
9714
9715 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
9716C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary
9717 KCS=(-1)**INT(1.5D0+PYR(0))
9718 MINT(21)=ISIGN(KFLF,KCS)
9719 MINT(22)=-MINT(21)
9720 KCC=21
9721
9722 ENDIF
9723
9724 ELSEIF(ISUB.LE.160) THEN
9725 IF(ISUB.EQ.141) THEN
9726C...f + fbar -> gamma*/Z0/Z'0
9727 KFRES=32
9728
9729 ELSEIF(ISUB.EQ.142) THEN
9730C...f + fbar' -> W'+/-
9731 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9732 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9733 KFRES=ISIGN(34,KCH1+KCH2)
9734
9735 ELSEIF(ISUB.EQ.143) THEN
9736C...f + fbar' -> H+/-
9737 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9738 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9739 KFRES=ISIGN(37,KCH1+KCH2)
9740
9741 ELSEIF(ISUB.EQ.144) THEN
9742C...f + fbar' -> R
9743 KFRES=ISIGN(41,MINT(15)+MINT(16))
9744
9745 ELSEIF(ISUB.EQ.145) THEN
9746C...q + l -> LQ (leptoquark)
9747 IF(IABS(MINT(16)).LE.8) JS=2
9748 KFRES=ISIGN(42,MINT(14+JS))
9749 KCC=28+JS
9750 KCS=ISIGN(1,MINT(14+JS))
9751
9752 ELSEIF(ISUB.EQ.146) THEN
9753C...e + gamma -> e* (excited lepton)
9754 IF(MINT(15).EQ.22) JS=2
9755 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
9756 KCC=22
9757
9758 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
9759C...q + g -> q* (excited quark)
9760 IF(MINT(15).EQ.21) JS=2
9761 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
9762 KCC=30+JS
9763 KCS=ISIGN(1,MINT(14+JS))
9764
9765 ELSEIF(ISUB.EQ.149) THEN
9766C...g + g -> eta_tc
9767 KFRES=KTECHN+331
9768 KCC=23
9769 KCS=(-1)**INT(1.5D0+PYR(0))
9770 ENDIF
9771
9772 ELSEIF(ISUB.LE.200) THEN
9773 IF(ISUB.EQ.161) THEN
9774C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
9775 IF(MINT(15).EQ.21) JS=2
9776 I=MINT(14+JS)
9777 IA=IABS(I)
9778 MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I)
9779 IB=IA+MOD(IA,2)-MOD(IA+1,2)
9780 MINT(20+JS)=ISIGN(IB,I)
9781 KCC=15+JS
9782 KCS=ISIGN(1,MINT(14+JS))
9783
9784 ELSEIF(ISUB.EQ.162) THEN
9785C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
9786 IF(MINT(15).EQ.21) JS=2
9787 MINT(20+JS)=ISIGN(42,MINT(14+JS))
9788 KFLQL=KFDP(MDCY(42,2),2)
9789 MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS))
9790 KCC=15+JS
9791 KCS=ISIGN(1,MINT(14+JS))
9792
9793 ELSEIF(ISUB.EQ.163) THEN
9794C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
9795 KCS=(-1)**INT(1.5D0+PYR(0))
9796 MINT(21)=ISIGN(42,KCS)
9797 MINT(22)=-MINT(21)
9798 KCC=MINT(2)+10
9799
9800 ELSEIF(ISUB.EQ.164) THEN
9801C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
9802 MINT(21)=ISIGN(42,MINT(15))
9803 MINT(22)=-MINT(21)
9804 KCC=4
9805
9806 ELSEIF(ISUB.EQ.165) THEN
9807C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
9808 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9809 MINT(22)=-MINT(21)
9810
9811 ELSEIF(ISUB.EQ.166) THEN
9812C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
9813 IF(MOD(MINT(15),2).EQ.0) THEN
9814 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
9815 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
9816 ELSE
9817 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9818 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
9819 ENDIF
9820
9821 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
9822C...q + q' -> q" + q* (excited quark)
9823 KFQSTR=KFPR(ISUB,2)
9824 KFQEXC=MOD(KFQSTR,KEXCIT)
9825 JS=MINT(2)
9826 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
9827 IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC)
9828 & MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
9829 KCC=22
9830 JS=3-JS
9831
9832 ELSEIF(ISUB.EQ.169) THEN
9833C...q + qbar -> e + e* (excited lepton)
9834 KFQSTR=KFPR(ISUB,2)
9835 KFQEXC=MOD(KFQSTR,KEXCIT)
9836 JS=MINT(2)
9837 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
9838 MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
9839 JS=3-JS
9840
9841 ELSEIF(ISUB.EQ.191) THEN
9842C...f + fbar -> rho_tc0.
9843 KFRES=KTECHN+113
9844
9845 ELSEIF(ISUB.EQ.192) THEN
9846C...f + fbar' -> rho_tc+/-
9847 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9848 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9849 KFRES=ISIGN(KTECHN+213,KCH1+KCH2)
9850
9851 ELSEIF(ISUB.EQ.193) THEN
9852C...f + fbar -> omega_tc0.
9853 KFRES=KTECHN+223
9854
9855 ELSEIF(ISUB.EQ.194) THEN
9856C...f + fbar -> f' + fbar' via mixture of s-channel
9857C...rho_tc and omega_tc; th=(p(f)-p(f'))**2
9858 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9859 MINT(22)=-MINT(21)
9860
9861 ELSEIF(ISUB.EQ.195) THEN
9862C...f + fbar' -> f'' + fbar''' via s-channel
9863C...rho_tc+ th=(p(f)-p(f'))**2
9864C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
9865 IF(MOD(MINT(15),2).EQ.0) THEN
9866 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
9867 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
9868 ELSE
9869 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9870 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
9871 ENDIF
9872 ENDIF
9873
9874CMRENNA++
9875 ELSEIF(ISUB.LE.215) THEN
9876 IF(ISUB.EQ.201) THEN
9877C...f + fbar -> ~e_L + ~e_Lbar
9878 MINT(21)=ISIGN(KSUSY1+11,KCS)
9879 MINT(22)=-MINT(21)
9880
9881 ELSEIF(ISUB.EQ.202) THEN
9882C...f + fbar -> ~e_R + ~e_Rbar
9883 MINT(21)=ISIGN(KSUSY2+11,KCS)
9884 MINT(22)=-MINT(21)
9885
9886 ELSEIF(ISUB.EQ.203) THEN
9887C...f + fbar -> ~e_L + ~e_Rbar
9888 IF(MINT(15).LT.0) JS=2
9889 IF(MINT(2).EQ.1) THEN
9890 MINT(20+JS)=KFPR(ISUB,1)
9891 MINT(23-JS)=-KFPR(ISUB,2)
9892 ELSE
9893 MINT(20+JS)=-KFPR(ISUB,1)
9894 MINT(23-JS)=KFPR(ISUB,2)
9895 ENDIF
9896
9897 ELSEIF(ISUB.EQ.204) THEN
9898C...f + fbar -> ~mu_L + ~mu_Lbar
9899 MINT(21)=ISIGN(KSUSY1+13,KCS)
9900 MINT(22)=-MINT(21)
9901
9902 ELSEIF(ISUB.EQ.205) THEN
9903C...f + fbar -> ~mu_R + ~mu_Rbar
9904 MINT(21)=ISIGN(KSUSY2+13,KCS)
9905 MINT(22)=-MINT(21)
9906
9907 ELSEIF(ISUB.EQ.206) THEN
9908C...f + fbar -> ~mu_L + ~mu_Rbar
9909 IF(MINT(15).LT.0) JS=2
9910 IF(MINT(2).EQ.1) THEN
9911 MINT(20+JS)=KFPR(ISUB,1)
9912 MINT(23-JS)=-KFPR(ISUB,2)
9913 ELSE
9914 MINT(20+JS)=-KFPR(ISUB,1)
9915 MINT(23-JS)=KFPR(ISUB,2)
9916 ENDIF
9917
9918 ELSEIF(ISUB.EQ.207) THEN
9919C...f + fbar -> ~tau_1 + ~tau_1bar
9920 MINT(21)=ISIGN(KSUSY1+15,KCS)
9921 MINT(22)=-MINT(21)
9922
9923 ELSEIF(ISUB.EQ.208) THEN
9924C...f + fbar -> ~tau_2 + ~tau_2bar
9925 MINT(21)=ISIGN(KSUSY2+15,KCS)
9926 MINT(22)=-MINT(21)
9927
9928 ELSEIF(ISUB.EQ.209) THEN
9929C...f + fbar -> ~tau_1 + ~tau_2bar
9930 IF(MINT(15).LT.0) JS=2
9931 IF(MINT(2).EQ.1) THEN
9932 MINT(20+JS)=KFPR(ISUB,1)
9933 MINT(23-JS)=-KFPR(ISUB,2)
9934 ELSE
9935 MINT(20+JS)=-KFPR(ISUB,1)
9936 MINT(23-JS)=KFPR(ISUB,2)
9937 ENDIF
9938
9939 ELSEIF(ISUB.EQ.210) THEN
9940C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
9941 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9942 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9943 MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2)
9944 MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2)
9945
9946 ELSEIF(ISUB.EQ.211) THEN
9947C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
9948 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9949 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9950 MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2)
9951 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
9952
9953 ELSEIF(ISUB.EQ.212) THEN
9954C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
9955 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9956 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9957 MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2)
9958 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
9959
9960 ELSEIF(ISUB.EQ.213) THEN
9961C...f + fbar -> ~nul + ~nulbar
9962 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
9963 MINT(22)=-MINT(21)
9964
9965 ELSEIF(ISUB.EQ.214) THEN
9966C...f + fbar -> ~nutau + ~nutaubar
9967 MINT(21)=ISIGN(KSUSY1+16,KCS)
9968 MINT(22)=-MINT(21)
9969 ENDIF
9970
9971 ELSEIF(ISUB.LE.225) THEN
9972 IF(ISUB.EQ.216) THEN
9973C...f + fbar -> ~chi01 + ~chi01
9974 MINT(21)=KSUSY1+22
9975 MINT(22)=KSUSY1+22
9976
9977 ELSEIF(ISUB.EQ.217) THEN
9978C...f + fbar -> ~chi02 + ~chi02
9979 MINT(21)=KSUSY1+23
9980 MINT(22)=KSUSY1+23
9981
9982 ELSEIF(ISUB.EQ.218 ) THEN
9983C...f + fbar -> ~chi03 + ~chi03
9984 MINT(21)=KSUSY1+25
9985 MINT(22)=KSUSY1+25
9986
9987 ELSEIF(ISUB.EQ.219 ) THEN
9988C...f + fbar -> ~chi04 + ~chi04
9989 MINT(21)=KSUSY1+35
9990 MINT(22)=KSUSY1+35
9991
9992 ELSEIF(ISUB.EQ.220 ) THEN
9993C...f + fbar -> ~chi01 + ~chi02
9994 IF(MINT(15).LT.0) JS=2
9995C IF(PYR(0).GT.0.5D0) JS=2
9996 MINT(20+JS)=KSUSY1+22
9997 MINT(23-JS)=KSUSY1+23
9998
9999 ELSEIF(ISUB.EQ.221 ) THEN
10000C...f + fbar -> ~chi01 + ~chi03
10001 IF(MINT(15).LT.0) JS=2
10002C IF(PYR(0).GT.0.5D0) JS=2
10003 MINT(20+JS)=KSUSY1+22
10004 MINT(23-JS)=KSUSY1+25
10005
10006 ELSEIF(ISUB.EQ.222) THEN
10007C...f + fbar -> ~chi01 + ~chi04
10008 IF(MINT(15).LT.0) JS=2
10009C IF(PYR(0).GT.0.5D0) JS=2
10010 MINT(20+JS)=KSUSY1+22
10011 MINT(23-JS)=KSUSY1+35
10012
10013 ELSEIF(ISUB.EQ.223) THEN
10014C...f + fbar -> ~chi02 + ~chi03
10015 IF(MINT(15).LT.0) JS=2
10016C IF(PYR(0).GT.0.5D0) JS=2
10017 MINT(20+JS)=KSUSY1+23
10018 MINT(23-JS)=KSUSY1+25
10019
10020 ELSEIF(ISUB.EQ.224) THEN
10021C...f + fbar -> ~chi02 + ~chi04
10022 IF(MINT(15).LT.0) JS=2
10023C IF(PYR(0).GT.0.5D0) JS=2
10024 MINT(20+JS)=KSUSY1+23
10025 MINT(23-JS)=KSUSY1+35
10026
10027 ELSEIF(ISUB.EQ.225) THEN
10028C...f + fbar -> ~chi03 + ~chi04
10029 IF(MINT(15).LT.0) JS=2
10030C IF(PYR(0).GT.0.5D0) JS=2
10031 MINT(20+JS)=KSUSY1+25
10032 MINT(23-JS)=KSUSY1+35
10033 ENDIF
10034
10035 ELSEIF(ISUB.LE.236) THEN
10036 IF(ISUB.EQ.226) THEN
10037C...f + fbar -> ~chi+-1 + ~chi-+1
10038C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
10039 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10040 MINT(21)=ISIGN(KSUSY1+24,KCH1)
10041 MINT(22)=-MINT(21)
10042
10043 ELSEIF(ISUB.EQ.227) THEN
10044C...f + fbar -> ~chi+-2 + ~chi-+2
10045 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10046 MINT(21)=ISIGN(KSUSY1+37,KCH1)
10047 MINT(22)=-MINT(21)
10048
10049 ELSEIF(ISUB.EQ.228) THEN
10050C...f + fbar -> ~chi+-1 + ~chi-+2
10051C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
10052C...js=1 if pyr<.5, js=2 if pyr>.5
10053C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
10054C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
10055C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
10056C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
10057 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10058 KCH2=INT(1-KCH1)/2
10059 IF(MINT(2).EQ.1) THEN
10060 MINT(21)= ISIGN(KSUSY1+24,KCH1)
10061 MINT(22)= -ISIGN(KSUSY1+37,KCH1)
10062c IF(KCH2.EQ.0) JS=2
10063 ELSE
10064 MINT(21)= ISIGN(KSUSY1+37,KCH1)
10065 MINT(22)= -ISIGN(KSUSY1+24,KCH1)
10066 JS=2
10067c IF(KCH2.EQ.1) JS=2
10068 ENDIF
10069
10070 ELSEIF(ISUB.EQ.229) THEN
10071C...q + qbar' -> ~chi01 + ~chi+-1
10072C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
10073 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10074 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10075C...CHECK THIS
10076 IF(MOD(MINT(15),2).EQ.0) JS=2
10077 MINT(20+JS)=KSUSY1+22
10078 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
10079
10080 ELSEIF(ISUB.EQ.230) THEN
10081C...q + qbar' -> ~chi02 + ~chi+-1
10082 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10083 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10084 IF(MOD(MINT(15),2).EQ.0) JS=2
10085 MINT(20+JS)=KSUSY1+23
10086 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
10087
10088 ELSEIF(ISUB.EQ.231) THEN
10089C...q + qbar' -> ~chi03 + ~chi+-1
10090 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10091 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10092 IF(MOD(MINT(15),2).EQ.0) JS=2
10093 MINT(20+JS)=KSUSY1+25
10094 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
10095
10096 ELSEIF(ISUB.EQ.232) THEN
10097C...q + qbar' -> ~chi04 + ~chi+-1
10098 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10099 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10100 IF(MOD(MINT(15),2).EQ.0) JS=2
10101 MINT(20+JS)=KSUSY1+35
10102 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
10103
10104 ELSEIF(ISUB.EQ.233) THEN
10105C...q + qbar' -> ~chi01 + ~chi+-2
10106 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10107 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10108 IF(MOD(MINT(15),2).EQ.0) JS=2
10109 MINT(20+JS)=KSUSY1+22
10110 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
10111
10112 ELSEIF(ISUB.EQ.234) THEN
10113C...q + qbar' -> ~chi02 + ~chi+-2
10114 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10115 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10116 IF(MOD(MINT(15),2).EQ.0) JS=2
10117 MINT(20+JS)=KSUSY1+23
10118 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
10119
10120 ELSEIF(ISUB.EQ.235) THEN
10121C...q + qbar' -> ~chi03 + ~chi+-2
10122 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10123 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10124 IF(MOD(MINT(15),2).EQ.0) JS=2
10125 MINT(20+JS)=KSUSY1+25
10126 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
10127
10128 ELSEIF(ISUB.EQ.236) THEN
10129C...q + qbar' -> ~chi04 + ~chi+-2
10130 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10131 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10132 IF(MOD(MINT(15),2).EQ.0) JS=2
10133 MINT(20+JS)=KSUSY1+35
10134 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
10135 ENDIF
10136
10137 ELSEIF(ISUB.LE.245) THEN
10138 IF(ISUB.EQ.237) THEN
10139C...q + qbar -> ~chi01 + ~g
10140C...th arbitrary
10141 IF(PYR(0).GT.0.5D0) JS=2
10142 MINT(20+JS)=KSUSY1+21
10143 MINT(23-JS)=KSUSY1+22
10144 KCC=17+JS
10145
10146 ELSEIF(ISUB.EQ.238) THEN
10147C...q + qbar -> ~chi02 + ~g
10148C...th arbitrary
10149 IF(PYR(0).GT.0.5D0) JS=2
10150 MINT(20+JS)=KSUSY1+21
10151 MINT(23-JS)=KSUSY1+23
10152 KCC=17+JS
10153
10154 ELSEIF(ISUB.EQ.239) THEN
10155C...q + qbar -> ~chi03 + ~g
10156C...th arbitrary
10157 IF(PYR(0).GT.0.5D0) JS=2
10158 MINT(20+JS)=KSUSY1+21
10159 MINT(23-JS)=KSUSY1+25
10160 KCC=17+JS
10161
10162 ELSEIF(ISUB.EQ.240) THEN
10163C...q + qbar -> ~chi04 + ~g
10164C...th arbitrary
10165 IF(PYR(0).GT.0.5D0) JS=2
10166 MINT(20+JS)=KSUSY1+21
10167 MINT(23-JS)=KSUSY1+35
10168 KCC=17+JS
10169
10170 ELSEIF(ISUB.EQ.241) THEN
10171C...q + qbar' -> ~chi+-1 + ~g
10172C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
10173C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
10174C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
10175C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
10176C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
10177 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10178 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10179 JS=1
10180 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10181 MINT(20+JS)=KSUSY1+21
10182 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
10183 KCC=17+JS
10184
10185 ELSEIF(ISUB.EQ.242) THEN
10186C...q + qbar' -> ~chi+-2 + ~g
10187C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
10188C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
10189C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
10190C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
10191C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
10192 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10193 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10194 JS=1
10195 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10196 MINT(20+JS)=KSUSY1+21
10197 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
10198 KCC=17+JS
10199
10200 ELSEIF(ISUB.EQ.243) THEN
10201C...q + qbar -> ~g + ~g ; th arbitrary
10202 MINT(21)=KSUSY1+21
10203 MINT(22)=KSUSY1+21
10204 KCC=MINT(2)+4
10205
10206 ELSEIF(ISUB.EQ.244) THEN
10207C...g + g -> ~g + ~g ; th arbitrary
10208 KCC=MINT(2)+12
10209 KCS=(-1)**INT(1.5D0+PYR(0))
10210 MINT(21)=KSUSY1+21
10211 MINT(22)=KSUSY1+21
10212 ENDIF
10213
10214 ELSEIF(ISUB.LE.260) THEN
10215 IF(ISUB.EQ.246) THEN
10216C...qj + g -> ~qj_L + ~chi01
10217 IF(MINT(15).EQ.21) JS=2
10218 I=MINT(14+JS)
10219 IA=IABS(I)
10220 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10221 MINT(23-JS)=KSUSY1+22
10222 KCC=15+JS
10223 KCS=ISIGN(1,MINT(14+JS))
10224
10225 ELSEIF(ISUB.EQ.247) THEN
10226C...qj + g -> ~qj_R + ~chi01
10227 IF(MINT(15).EQ.21) JS=2
10228 I=MINT(14+JS)
10229 IA=IABS(I)
10230 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10231 MINT(23-JS)=KSUSY1+22
10232 KCC=15+JS
10233 KCS=ISIGN(1,MINT(14+JS))
10234
10235 ELSEIF(ISUB.EQ.248) THEN
10236C...qj + g -> ~qj_L + ~chi02
10237 IF(MINT(15).EQ.21) JS=2
10238 I=MINT(14+JS)
10239 IA=IABS(I)
10240 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10241 MINT(23-JS)=KSUSY1+23
10242 KCC=15+JS
10243 KCS=ISIGN(1,MINT(14+JS))
10244
10245 ELSEIF(ISUB.EQ.249) THEN
10246C...qj + g -> ~qj_R + ~chi02
10247 IF(MINT(15).EQ.21) JS=2
10248 I=MINT(14+JS)
10249 IA=IABS(I)
10250 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10251 MINT(23-JS)=KSUSY1+23
10252 KCC=15+JS
10253 KCS=ISIGN(1,MINT(14+JS))
10254
10255 ELSEIF(ISUB.EQ.250) THEN
10256C...qj + g -> ~qj_L + ~chi03
10257 IF(MINT(15).EQ.21) JS=2
10258 I=MINT(14+JS)
10259 IA=IABS(I)
10260 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10261 MINT(23-JS)=KSUSY1+25
10262 KCC=15+JS
10263 KCS=ISIGN(1,MINT(14+JS))
10264
10265 ELSEIF(ISUB.EQ.251) THEN
10266C...qj + g -> ~qj_R + ~chi03
10267 IF(MINT(15).EQ.21) JS=2
10268 I=MINT(14+JS)
10269 IA=IABS(I)
10270 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10271 MINT(23-JS)=KSUSY1+25
10272 KCC=15+JS
10273 KCS=ISIGN(1,MINT(14+JS))
10274
10275 ELSEIF(ISUB.EQ.252) THEN
10276C...qj + g -> ~qj_L + ~chi04
10277 IF(MINT(15).EQ.21) JS=2
10278 I=MINT(14+JS)
10279 IA=IABS(I)
10280 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10281 MINT(23-JS)=KSUSY1+35
10282 KCC=15+JS
10283 KCS=ISIGN(1,MINT(14+JS))
10284
10285 ELSEIF(ISUB.EQ.253) THEN
10286C...qj + g -> ~qj_R + ~chi04
10287 IF(MINT(15).EQ.21) JS=2
10288 I=MINT(14+JS)
10289 IA=IABS(I)
10290 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10291 MINT(23-JS)=KSUSY1+35
10292 KCC=15+JS
10293 KCS=ISIGN(1,MINT(14+JS))
10294
10295 ELSEIF(ISUB.EQ.254) THEN
10296C...qj + g -> ~qk_L + ~chi+-1
10297 IF(MINT(15).EQ.21) JS=2
10298 I=MINT(14+JS)
10299 IA=IABS(I)
10300 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
10301 IB=-IA+INT((IA+1)/2)*4-1
10302 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
10303 KCC=15+JS
10304 KCS=ISIGN(1,MINT(14+JS))
10305
10306 ELSEIF(ISUB.EQ.255) THEN
10307C...qj + g -> ~qk_L + ~chi+-1
10308 IF(MINT(15).EQ.21) JS=2
10309 I=MINT(14+JS)
10310 IA=IABS(I)
10311 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
10312 IB=-IA+INT((IA+1)/2)*4-1
10313 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
10314 KCC=15+JS
10315 KCS=ISIGN(1,MINT(14+JS))
10316
10317 ELSEIF(ISUB.EQ.256) THEN
10318C...qj + g -> ~qk_L + ~chi+-2
10319 IF(MINT(15).EQ.21) JS=2
10320 I=MINT(14+JS)
10321 IA=IABS(I)
10322 IB=-IA+INT((IA+1)/2)*4-1
10323 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
10324 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
10325 KCC=15+JS
10326 KCS=ISIGN(1,MINT(14+JS))
10327
10328 ELSEIF(ISUB.EQ.257) THEN
10329C...qj + g -> ~qk_R + ~chi+-2
10330 IF(MINT(15).EQ.21) JS=2
10331 I=MINT(14+JS)
10332 IA=IABS(I)
10333 IB=-IA+INT((IA+1)/2)*4-1
10334 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
10335 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
10336 KCC=15+JS
10337 KCS=ISIGN(1,MINT(14+JS))
10338
10339 ELSEIF(ISUB.EQ.258) THEN
10340C...qj + g -> ~qj_L + ~g
10341 IF(MINT(15).EQ.21) JS=2
10342 I=MINT(14+JS)
10343 IA=IABS(I)
10344 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10345 MINT(23-JS)=KSUSY1+21
10346 KCC=MINT(2)+6
10347 IF(JS.EQ.2) KCC=KCC+2
10348 KCS=ISIGN(1,I)
10349
10350 ELSEIF(ISUB.EQ.259) THEN
10351C...qj + g -> ~qj_R + ~g
10352 IF(MINT(15).EQ.21) JS=2
10353 I=MINT(14+JS)
10354 IA=IABS(I)
10355 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10356 MINT(23-JS)=KSUSY1+21
10357 KCC=MINT(2)+6
10358 IF(JS.EQ.2) KCC=KCC+2
10359 KCS=ISIGN(1,I)
10360 ENDIF
10361
10362 ELSEIF(ISUB.LE.270) THEN
10363 IF(ISUB.EQ.261) THEN
10364C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
10365 ISGN=1
10366 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
10367 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
10368 MINT(22)=-MINT(21)
10369C...Correct color combination
10370 IF(MINT(43).EQ.4) KCC=4
10371
10372 ELSEIF(ISUB.EQ.262) THEN
10373C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
10374 ISGN=1
10375 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
10376 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
10377 MINT(22)=-MINT(21)
10378C...Correct color combination
10379 IF(MINT(43).EQ.4) KCC=4
10380
10381 ELSEIF(ISUB.EQ.263) THEN
10382C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
10383 IF((KCS.GT.0.AND.MINT(2).EQ.1).OR.
10384 & (KCS.LT.0.AND.MINT(2).EQ.2)) THEN
10385 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10386 MINT(22)=-ISIGN(KFPR(ISUB,2),KCS)
10387 ELSE
10388 JS=2
10389 MINT(21)=ISIGN(KFPR(ISUB,2),KCS)
10390 MINT(22)=-ISIGN(KFPR(ISUB,1),KCS)
10391 ENDIF
10392C...Correct color combination
10393 IF(MINT(43).EQ.4) KCC=4
10394
10395 ELSEIF(ISUB.EQ.264) THEN
10396C...g + g -> ~t_1 + ~t_1bar; th arbitrary
10397 KCS=(-1)**INT(1.5D0+PYR(0))
10398 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10399 MINT(22)=-MINT(21)
10400 KCC=MINT(2)+10
10401
10402 ELSEIF(ISUB.EQ.265) THEN
10403C...g + g -> ~t_2 + ~t_2bar; th arbitrary
10404 KCS=(-1)**INT(1.5D0+PYR(0))
10405 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10406 MINT(22)=-MINT(21)
10407 KCC=MINT(2)+10
10408 ENDIF
10409
10410 ELSEIF(ISUB.LE.296) THEN
10411 IF(ISUB.EQ.271.OR.ISUB.EQ.281.OR.ISUB.EQ.291) THEN
10412C...qi + qj -> ~qi_L + ~qj_L
10413 KCC=MINT(2)
10414 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10415 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
10416 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
10417
10418 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.282.OR.ISUB.EQ.292) THEN
10419C...qi + qj -> ~qi_R + ~qj_R
10420 KCC=MINT(2)
10421 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10422 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
10423 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
10424
10425 ELSEIF(ISUB.EQ.273.OR.ISUB.EQ.283.OR.ISUB.EQ.293) THEN
10426C...qi + qj -> ~qi_L + ~qj_R
10427 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
10428 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
10429 KCC=MINT(2)
10430 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10431
10432 ELSEIF(ISUB.EQ.274.OR.ISUB.EQ.284) THEN
10433C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
10434 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
10435 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
10436 KCC=MINT(2)
10437 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10438
10439 ELSEIF(ISUB.EQ.275.OR.ISUB.EQ.285) THEN
10440C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
10441 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
10442 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
10443 KCC=MINT(2)
10444 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10445
10446 ELSEIF(ISUB.EQ.276.OR.ISUB.EQ.286.OR.ISUB.EQ.296) THEN
10447C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
10448 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
10449 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
10450 KCC=MINT(2)
10451 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10452
10453 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.287) THEN
10454C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
10455 ISGN=1
10456 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
10457 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
10458 MINT(22)=-MINT(21)
10459 IF(MINT(43).EQ.4) KCC=4
10460
10461 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.288) THEN
10462C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
10463 ISGN=1
10464 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
10465 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
10466 MINT(22)=-MINT(21)
10467 IF(MINT(43).EQ.4) KCC=4
10468
10469 ELSEIF(ISUB.EQ.279.OR.ISUB.EQ.289) THEN
10470C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
10471C...pure LL + RR
10472 KCS=(-1)**INT(1.5D0+PYR(0))
10473 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10474 MINT(22)=-MINT(21)
10475 KCC=MINT(2)+10
10476
10477 ELSEIF(ISUB.EQ.280.OR.ISUB.EQ.290) THEN
10478C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
10479 KCS=(-1)**INT(1.5D0+PYR(0))
10480 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10481 MINT(22)=-MINT(21)
10482 KCC=MINT(2)+10
10483
10484 ELSEIF(ISUB.EQ.294) THEN
10485C...qj + g -> ~qj_L + ~g
10486 IF(MINT(15).EQ.21) JS=2
10487 I=MINT(14+JS)
10488 IA=IABS(I)
10489 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10490 MINT(23-JS)=KSUSY1+21
10491 KCC=MINT(2)+6
10492 IF(JS.EQ.2) KCC=KCC+2
10493 KCS=ISIGN(1,I)
10494
10495 ELSEIF(ISUB.EQ.295) THEN
10496C...qj + g -> ~qj_R + ~g
10497 IF(MINT(15).EQ.21) JS=2
10498 I=MINT(14+JS)
10499 IA=IABS(I)
10500 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10501 MINT(23-JS)=KSUSY1+21
10502 KCC=MINT(2)+6
10503 IF(JS.EQ.2) KCC=KCC+2
10504 KCS=ISIGN(1,I)
10505 ENDIF
10506
10507 ELSEIF(ISUB.LE.340) THEN
10508
10509 IF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
10510C...q + qbar' -> H+ + H0
10511 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10512 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10513 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10514 MINT(20+JS)=ISIGN(37,KCH1+KCH2)
10515 MINT(23-JS)=KFPR(ISUB,2)
10516 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
10517C...f + fbar -> A0 + H0; th arbitrary
10518 IF(PYR(0).GT.0.5D0) JS=2
10519 MINT(20+JS)=KFPR(ISUB,1)
10520 MINT(23-JS)=KFPR(ISUB,2)
10521 ELSEIF(ISUB.EQ.301) THEN
10522C...f + fbar -> H+ H-
10523 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10524 MINT(22)=-MINT(21)
10525 ENDIF
10526CMRENNA--
10527
10528 ELSEIF(ISUB.LE.360) THEN
10529
10530 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
10531C...l + l -> H_L++/--, H_R++/--
10532 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10533 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10534 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
10535
10536 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
10537C...l + gamma -> l' + H++/--; th=(p(l)-p(H))**2
10538 IF(MINT(15).EQ.22) JS=2
10539 MINT(20+JS)=ISIGN(KFPR(ISUB,1),-MINT(14+JS))
10540 MINT(23-JS)=ISIGN(KFPR(ISUB,2),-MINT(14+JS))
10541 KCC=22
10542
10543 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
10544C...f + fbar -> H++ + H--; th = (p(f)-p(H--))**2
10545 MINT(21)=-ISIGN(KFPR(ISUB,1),MINT(15))
10546 MINT(22)=-MINT(21)
10547
10548 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
10549C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/--
10550C...as inner process).
10551 DO 450 JT=1,2
10552 I=MINT(14+JT)
10553 IA=IABS(I)
10554 IF(IA.LE.10) THEN
10555 RVCKM=VINT(180+I)*PYR(0)
10556 DO 440 J=1,MSTP(1)
10557 IB=2*J-1+MOD(IA,2)
10558 IPM=(5-ISIGN(1,I))/2
10559 IDC=J+MDCY(IA,2)+2
10560 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 440
10561 MINT(20+JT)=ISIGN(IB,I)
10562 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10563 IF(RVCKM.LE.0D0) GOTO 450
10564 440 CONTINUE
10565 ELSE
10566 IB=2*((IA+1)/2)-1+MOD(IA,2)
10567 MINT(20+JT)=ISIGN(IB,I)
10568 ENDIF
10569 450 CONTINUE
10570 KCC=22
10571 KFRES=ISIGN(KFPR(ISUB,1),MINT(15))
10572 IF(MOD(MINT(15),2).EQ.1) KFRES=-KFRES
10573
10574 ELSEIF(ISUB.EQ.353) THEN
10575C...f + fbar -> Z_R0
10576 KFRES=KFPR(ISUB,1)
10577
10578 ELSEIF(ISUB.EQ.354) THEN
10579C...f + fbar' -> W+/-
10580 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10581 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10582 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
10583
10584 ENDIF
10585
10586 ELSEIF(ISUB.LE.380) THEN
10587
10588 IF(ISUB.LE.363.OR.ISUB.EQ.368) THEN
10589C...f + fbar -> charged+ charged- technicolor
10590 KSW=(-1)**INT(1.5D0+PYR(0))
10591 MINT(21)=ISIGN(KFPR(ISUB,1),KSW)
10592 MINT(22)=-ISIGN(KFPR(ISUB,2),KSW)
10593
10594 ELSEIF(ISUB.LE.367) THEN
10595C...f + fbar -> neutral neutral technicolor
10596 MINT(21)=KFPR(ISUB,1)
10597 MINT(22)=KFPR(ISUB,2)
10598
10599 ELSEIF(ISUB.EQ.374.OR.ISUB.EQ.375) THEN
10600C...f + fbar' -> neutral charged technicolor
10601 IN=1
10602 IC=2
10603 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10604 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10605 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10606 MINT(23-JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
10607 MINT(20+JS)=KFPR(ISUB,IN)
10608
10609 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
10610C...f + fbar' -> charged neutral technicolor
10611 IN=2
10612 IC=1
10613 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10614 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10615 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10616 MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
10617 MINT(23-JS)=KFPR(ISUB,IN)
10618 ENDIF
10619
10620 ELSEIF(ISUB.LE.400) THEN
10621 IF(ISUB.EQ.381) THEN
10622C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2, TC extensions
10623 KCC=MINT(2)
10624 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10625
10626 ELSEIF(ISUB.EQ.382) THEN
10627C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2, TC extensions
10628 MINT(21)=ISIGN(KFLF,MINT(15))
10629 MINT(22)=-MINT(21)
10630 KCC=4
10631
10632 ELSEIF(ISUB.EQ.383) THEN
10633C...f + fbar -> g + g; th arbitrary, TC extensions
10634 MINT(21)=21
10635 MINT(22)=21
10636 KCC=MINT(2)+4
10637
10638 ELSEIF(ISUB.EQ.384) THEN
10639C...f + g -> f + g; th = (p(f)-p(f))**2, TC extensions
10640 IF(MINT(15).EQ.21) JS=2
10641 KCC=MINT(2)+6
10642 IF(MINT(15).EQ.21) KCC=KCC+2
10643 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
10644 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
10645
10646 ELSEIF(ISUB.EQ.385) THEN
10647C...g + g -> f + fbar; th arbitrary, TC extensions
10648 KCS=(-1)**INT(1.5D0+PYR(0))
10649 MINT(21)=ISIGN(KFLF,KCS)
10650 MINT(22)=-MINT(21)
10651 KCC=MINT(2)+10
10652
10653 ELSEIF(ISUB.EQ.386) THEN
10654C...g + g -> g + g; th arbitrary, TC extensions
10655 KCC=MINT(2)+12
10656 KCS=(-1)**INT(1.5D0+PYR(0))
10657
10658 ELSEIF(ISUB.EQ.387) THEN
10659C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2, TC extensions
10660 MINT(21)=ISIGN(MINT(55),MINT(15))
10661 MINT(22)=-MINT(21)
10662 KCC=4
10663
10664 ELSEIF(ISUB.EQ.388) THEN
10665C...g + g -> Q + Qbar; th arbitrary, TC extensions
10666 KCS=(-1)**INT(1.5D0+PYR(0))
10667 MINT(21)=ISIGN(MINT(55),KCS)
10668 MINT(22)=-MINT(21)
10669 KCC=MINT(2)+10
10670
10671 ELSEIF(ISUB.EQ.391) THEN
10672C...f + fbar -> G*.
10673 KFRES=KFPR(ISUB,1)
10674
10675 ELSEIF(ISUB.EQ.392) THEN
10676C...g + g -> G*.
10677 KCC=21
10678 KFRES=KFPR(ISUB,1)
10679
10680 ELSEIF(ISUB.EQ.393) THEN
10681C...q + qbar -> g + G*; th arbitrary.
10682 IF(PYR(0).GT.0.5D0) JS=2
10683 MINT(20+JS)=KFPR(ISUB,1)
10684 MINT(23-JS)=KFPR(ISUB,2)
10685 KCC=17+JS
10686
10687 ELSEIF(ISUB.EQ.394) THEN
10688C...q + g -> q + G*; th = (p(f) - p(f))**2
10689 IF(MINT(15).EQ.21) JS=2
10690 MINT(23-JS)=KFPR(ISUB,2)
10691 KCC=15+JS
10692 KCS=ISIGN(1,MINT(14+JS))
10693
10694 ELSEIF(ISUB.EQ.395) THEN
10695C...g + g -> G* + g; th arbitrary.
10696 IF(PYR(0).GT.0.5D0) JS=2
10697 MINT(23-JS)=KFPR(ISUB,2)
10698 KCC=22+JS
10699 ENDIF
10700 ENDIF
10701
10702 IF(ISET(ISUB).EQ.11) THEN
10703C...Store documentation for user-defined processes
10704 BEZUP=(PUP(3,1)+PUP(3,2))/(PUP(4,1)+PUP(4,2))
10705 KUPPO(1)=MINT(83)+5
10706 KUPPO(2)=MINT(83)+6
10707 I=MINT(83)+6
10708 DO 470 IUP=3,NUP
10709 KUPPO(IUP)=0
10710 IF(MSTP(128).GE.2.AND.MOTHUP(1,IUP).GE.3) THEN
10711 IDOC=IDOC-1
10712 MINT(4)=MINT(4)-1
10713 GOTO 470
10714 ENDIF
10715 I=I+1
10716 KUPPO(IUP)=I
10717 K(I,1)=21
10718 K(I,2)=IDUP(IUP)
10719 IF(IDUP(IUP).EQ.0) K(I,2)=90
10720 K(I,3)=0
10721 IF(MOTHUP(1,IUP).GE.3) K(I,3)=KUPPO(MOTHUP(1,IUP))
10722 K(I,4)=0
10723 K(I,5)=0
10724 DO 460 J=1,5
10725 P(I,J)=PUP(J,IUP)
10726 460 CONTINUE
10727 V(I,5)=VTIMUP(IUP)
10728 470 CONTINUE
10729 CALL PYROBO(MINT(83)+7,MINT(83)+4+NUP,0D0,VINT(24),0D0,0D0,
10730 & -BEZUP)
10731
10732C...Store final state partons for user-defined processes
10733 N=IPU2
10734 DO 490 IUP=3,NUP
10735 N=N+1
10736 K(N,1)=1
10737 IF(ISTUP(IUP).EQ.2.OR.ISTUP(IUP).EQ.3) K(N,1)=11
10738 K(N,2)=IDUP(IUP)
10739 IF(IDUP(IUP).EQ.0) K(N,2)=90
10740 IF(MSTP(128).LE.0.OR.MOTHUP(1,IUP).EQ.0) THEN
10741 K(N,3)=KUPPO(IUP)
10742 ELSE
10743 K(N,3)=MINT(84)+MOTHUP(1,IUP)
10744 ENDIF
10745 K(N,4)=0
10746 K(N,5)=0
10747 DO 480 J=1,5
10748 P(N,J)=PUP(J,IUP)
10749 480 CONTINUE
10750 V(N,5)=VTIMUP(IUP)
10751 490 CONTINUE
10752 CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP)
10753
10754C...Arrange colour flow for user-defined processes
10755 NLBL=0
10756 DO 540 IUP1=1,NUP
10757 I1=MINT(84)+IUP1
10758 IF(KCHG(PYCOMP(K(I1,2)),2).EQ.0) GOTO 540
10759 IF(K(I1,1).EQ.1) K(I1,1)=3
10760 IF(K(I1,1).EQ.11) K(I1,1)=14
10761C...Find a not yet considered colour/anticolour line.
10762 DO 530 ISDE1=1,2
10763 IF(ICOLUP(ISDE1,IUP1).EQ.0) GOTO 530
10764 NMAT=0
10765 DO 500 ILBL=1,NLBL
10766 IF(ICOLUP(ISDE1,IUP1).EQ.ILAB(ILBL)) NMAT=1
10767 500 CONTINUE
10768 IF(NMAT.EQ.0) THEN
10769 NLBL=NLBL+1
10770 ILAB(NLBL)=ICOLUP(ISDE1,IUP1)
10771C...Find all others belonging to same line.
10772 I3=I1
10773 I4=0
10774 DO 520 IUP2=IUP1+1,NUP
10775 I2=MINT(84)+IUP2
10776 DO 510 ISDE2=1,2
10777 IF(ICOLUP(ISDE2,IUP2).EQ.ICOLUP(ISDE1,IUP1)) THEN
10778 IF(ISDE2.EQ.ISDE1) THEN
10779 K(I3,3+ISDE2)=K(I3,3+ISDE2)+I2
10780 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I3
10781 I3=I2
10782 ELSEIF(I4.NE.0) THEN
10783 K(I4,3+ISDE2)=K(I4,3+ISDE2)+I2
10784 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I4
10785 I4=I2
10786 ELSEIF(IUP2.LE.2) THEN
10787 K(I1,3+ISDE1)=K(I1,3+ISDE1)+I2
10788 K(I2,3+ISDE2)=K(I2,3+ISDE2)+I1
10789 I4=I2
10790 ELSE
10791 K(I1,3+ISDE1)=K(I1,3+ISDE1)+MSTU(5)*I2
10792 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I1
10793 I4=I2
10794 ENDIF
10795 ENDIF
10796 510 CONTINUE
10797 520 CONTINUE
10798 ENDIF
10799 530 CONTINUE
10800 540 CONTINUE
10801
10802 ELSEIF(IDOC.EQ.7) THEN
10803C...Resonance not decaying; store kinematics
10804 I=MINT(83)+7
10805 K(IPU3,1)=1
10806 K(IPU3,2)=KFRES
10807 K(IPU3,3)=I
10808 P(IPU3,4)=SHUSER
10809 P(IPU3,5)=SHUSER
10810 K(I,1)=21
10811 K(I,2)=KFRES
10812 P(I,4)=SHUSER
10813 P(I,5)=SHUSER
10814 N=IPU3
10815 MINT(21)=KFRES
10816 MINT(22)=0
10817
10818C...Special cases: colour flow in coloured resonances
10819 KCRES=PYCOMP(KFRES)
10820 IF(KCHG(KCRES,2).NE.0) THEN
10821 K(IPU3,1)=3
10822 DO 550 J=1,2
10823 JC=J
10824 IF(KCS.EQ.-1) JC=3-J
10825 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
10826 & MINT(84)+ICOL(KCC,1,JC)
10827 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
10828 & MINT(84)+ICOL(KCC,2,JC)
10829 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
10830 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
10831 550 CONTINUE
10832 ELSE
10833 K(IPU1,4)=IPU2
10834 K(IPU1,5)=IPU2
10835 K(IPU2,4)=IPU1
10836 K(IPU2,5)=IPU1
10837 ENDIF
10838
10839 ELSEIF(IDOC.EQ.8) THEN
10840C...2 -> 2 processes: store outgoing partons in their CM-frame
10841 DO 560 JT=1,2
10842 I=MINT(84)+2+JT
10843 KCA=PYCOMP(MINT(20+JT))
10844 K(I,1)=1
10845 IF(KCHG(KCA,2).NE.0) K(I,1)=3
10846 K(I,2)=MINT(20+JT)
10847 K(I,3)=MINT(83)+IDOC+JT-2
10848 KFAA=IABS(K(I,2))
10849 IF(KFPR(ISUBSV,1+MOD(JS+JT,2)).NE.0) THEN
10850 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
10851 ELSE
10852 P(I,5)=PYMASS(K(I,2))
10853 ENDIF
10854 IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND.
10855 & P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2))
10856 560 CONTINUE
10857 IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
10858 KFA1=IABS(MINT(21))
10859 KFA2=IABS(MINT(22))
10860 IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
10861 & THEN
10862 MINT(51)=1
10863 RETURN
10864 ENDIF
10865 P(IPU3,5)=0D0
10866 P(IPU4,5)=0D0
10867 ENDIF
10868 P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
10869 P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2))
10870 P(IPU4,4)=SHR-P(IPU3,4)
10871 P(IPU4,3)=-P(IPU3,3)
10872 N=IPU4
10873 MINT(7)=MINT(83)+7
10874 MINT(8)=MINT(83)+8
10875
10876C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
10877 CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
10878
10879 ELSEIF(IDOC.EQ.9) THEN
10880C...2 -> 3 processes: store outgoing partons in their CM frame
10881 DO 570 JT=1,2
10882 I=MINT(84)+2+JT
10883 KCA=PYCOMP(MINT(20+JT))
10884 K(I,1)=1
10885 IF(KCHG(KCA,2).NE.0) K(I,1)=3
10886 K(I,2)=MINT(20+JT)
10887 K(I,3)=MINT(83)+IDOC+JT-3
10888 IF(IABS(K(I,2)).LE.22) THEN
10889 P(I,5)=PYMASS(K(I,2))
10890 ELSE
10891 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
10892 ENDIF
10893 PT=SQRT(MAX(0D0,VINT(197+5*JT)-P(I,5)**2+VINT(196+5*JT)**2))
10894 P(I,1)=PT*COS(VINT(198+5*JT))
10895 P(I,2)=PT*SIN(VINT(198+5*JT))
10896 570 CONTINUE
10897 K(IPU5,1)=1
10898 K(IPU5,2)=KFRES
10899 K(IPU5,3)=MINT(83)+IDOC
10900 P(IPU5,5)=SHR
10901 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
10902 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
10903 PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
10904 PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2
10905 PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2
10906 PMT3=SQRT(PMS3)
10907 P(IPU5,3)=PMT3*SINH(VINT(211))
10908 P(IPU5,4)=PMT3*COSH(VINT(211))
10909 PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2
10910 SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2
10911 IF(SQL12.LE.0D0) THEN
10912 MINT(51)=1
10913 RETURN
10914 ENDIF
10915 P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+
10916 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
10917 P(IPU4,3)=-P(IPU3,3)-P(IPU5,3)
10918 P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2)
10919 P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2)
10920 MINT(23)=KFRES
10921 N=IPU5
10922 MINT(7)=MINT(83)+7
10923 MINT(8)=MINT(83)+8
10924
10925 ELSEIF(IDOC.EQ.11) THEN
10926C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
10927 PHI(1)=PARU(2)*PYR(0)
10928 PHI(2)=PHI(1)-PHIR
10929 DO 580 JT=1,2
10930 I=MINT(84)+2+JT
10931 K(I,1)=1
10932 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
10933 K(I,2)=MINT(20+JT)
10934 K(I,3)=MINT(83)+IDOC+JT-2
10935 P(I,5)=PYMASS(K(I,2))
10936 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN
10937 MINT(51)=1
10938 RETURN
10939 ENDIF
10940 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
10941 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
10942 P(I,1)=PTABS*COS(PHI(JT))
10943 P(I,2)=PTABS*SIN(PHI(JT))
10944 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
10945 P(I,4)=0.5D0*SHPR*Z(JT)
10946 IZW=MINT(83)+6+JT
10947 K(IZW,1)=21
10948 K(IZW,2)=23
10949 IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT)))
10950 K(IZW,3)=IZW-2
10951 P(IZW,1)=-P(I,1)
10952 P(IZW,2)=-P(I,2)
10953 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
10954 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
10955 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
10956 580 CONTINUE
10957 I=MINT(83)+9
10958 K(IPU5,1)=1
10959 K(IPU5,2)=KFRES
10960 K(IPU5,3)=I
10961 P(IPU5,5)=SHR
10962 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
10963 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
10964 P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
10965 P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
10966 K(I,1)=21
10967 K(I,2)=KFRES
10968 DO 590 J=1,5
10969 P(I,J)=P(IPU5,J)
10970 590 CONTINUE
10971 N=IPU5
10972 MINT(23)=KFRES
10973
10974 ELSEIF(IDOC.EQ.12) THEN
10975C...Z0 and W+/- scattering: store bosons and outgoing partons
10976 PHI(1)=PARU(2)*PYR(0)
10977 PHI(2)=PHI(1)-PHIR
10978 JTRAN=INT(1.5D0+PYR(0))
10979 DO 600 JT=1,2
10980 I=MINT(84)+2+JT
10981 K(I,1)=1
10982 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
10983 K(I,2)=MINT(20+JT)
10984 K(I,3)=MINT(83)+IDOC+JT-2
10985 P(I,5)=PYMASS(K(I,2))
10986 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0
10987 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
10988 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
10989 P(I,1)=PTABS*COS(PHI(JT))
10990 P(I,2)=PTABS*SIN(PHI(JT))
10991 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
10992 P(I,4)=0.5D0*SHPR*Z(JT)
10993 IZW=MINT(83)+6+JT
10994 K(IZW,1)=21
10995 IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
10996 K(IZW,2)=23
10997 ELSE
10998 K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT)))
10999 ENDIF
11000 K(IZW,3)=IZW-2
11001 P(IZW,1)=-P(I,1)
11002 P(IZW,2)=-P(I,2)
11003 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
11004 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
11005 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
11006 IPU=MINT(84)+4+JT
11007 K(IPU,1)=3
11008 K(IPU,2)=KFPR(ISUB,JT)
11009 IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2)
11010 IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2)
11011 K(IPU,3)=MINT(83)+8+JT
11012 IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
11013 P(IPU,5)=PYMASS(K(IPU,2))
11014 ELSE
11015 P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
11016 ENDIF
11017 MINT(22+JT)=K(IPU,2)
11018 600 CONTINUE
11019C...Find rotation and boost for hard scattering subsystem
11020 I1=MINT(83)+7
11021 I2=MINT(83)+8
11022 BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
11023 BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
11024 BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
11025 GAMCM=(P(I1,4)+P(I2,4))/SHR
11026 BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
11027 PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM
11028 PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM
11029 PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM
11030 THECM=PYANGL(PZ,SQRT(PX**2+PY**2))
11031 PHICM=PYANGL(PX,PY)
11032C...Store hard scattering subsystem. Rotate and boost it
11033 SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2*
11034 & P(IPU6,5)**2
11035 PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH)))
11036 CTHWZ=VINT(23)
11037 STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2))
11038 PHIWZ=VINT(24)-PHICM
11039 P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
11040 P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
11041 P(IPU5,3)=PABS*CTHWZ
11042 P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
11043 P(IPU6,1)=-P(IPU5,1)
11044 P(IPU6,2)=-P(IPU5,2)
11045 P(IPU6,3)=-P(IPU5,3)
11046 P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
11047 CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM)
11048 DO 620 JT=1,2
11049 I1=MINT(83)+8+JT
11050 I2=MINT(84)+4+JT
11051 K(I1,1)=21
11052 K(I1,2)=K(I2,2)
11053 DO 610 J=1,5
11054 P(I1,J)=P(I2,J)
11055 610 CONTINUE
11056 620 CONTINUE
11057 N=IPU6
11058 MINT(7)=MINT(83)+9
11059 MINT(8)=MINT(83)+10
11060 ENDIF
11061
11062 IF(ISET(ISUB).EQ.11) THEN
11063 ELSEIF(IDOC.GE.8) THEN
11064C...Store colour connection indices
11065 DO 630 J=1,2
11066 JC=J
11067 IF(KCS.EQ.-1) JC=3-J
11068 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
11069 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
11070 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
11071 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
11072 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
11073 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
11074 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
11075 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
11076 630 CONTINUE
11077
11078C...Copy outgoing partons to documentation lines
11079 IMAX=2
11080 IF(IDOC.EQ.9) IMAX=3
11081 DO 650 I=1,IMAX
11082 I1=MINT(83)+IDOC-IMAX+I
11083 I2=MINT(84)+2+I
11084 K(I1,1)=21
11085 K(I1,2)=K(I2,2)
11086 IF(IDOC.LE.9) K(I1,3)=0
11087 IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
11088 DO 640 J=1,5
11089 P(I1,J)=P(I2,J)
11090 640 CONTINUE
11091 650 CONTINUE
11092
11093 ELSEIF(IDOC.EQ.9) THEN
11094C...Store colour connection indices
11095 DO 660 J=1,2
11096 JC=J
11097 IF(KCS.EQ.-1) JC=3-J
11098 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
11099 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+
11100 & MAX(0,MIN(1,ICOL(KCC,1,JC)-2))
11101 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
11102 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+
11103 & MAX(0,MIN(1,ICOL(KCC,2,JC)-2))
11104 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
11105 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
11106 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)=
11107 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
11108 660 CONTINUE
11109
11110C...Copy outgoing partons to documentation lines
11111 DO 680 I=1,3
11112 I1=MINT(83)+IDOC-3+I
11113 I2=MINT(84)+2+I
11114 K(I1,1)=21
11115 K(I1,2)=K(I2,2)
11116 K(I1,3)=0
11117 DO 670 J=1,5
11118 P(I1,J)=P(I2,J)
11119 670 CONTINUE
11120 680 CONTINUE
11121 ENDIF
11122
11123C...Low-pT events: remove gluons used for string drawing purposes
11124 IF(ISUB.EQ.95) THEN
11125 K(IPU3,1)=K(IPU3,1)+10
11126 K(IPU4,1)=K(IPU4,1)+10
11127 DO 690 J=41,66
11128 VINTSV(J)=VINT(J)
11129 VINT(J)=0D0
11130 690 CONTINUE
11131 DO 710 I=MINT(83)+5,MINT(83)+8
11132 DO 700 J=1,5
11133 P(I,J)=0D0
11134 700 CONTINUE
11135 710 CONTINUE
11136 ENDIF
11137
11138 RETURN
11139 END
11140
11141C*********************************************************************
11142
11143C...PYSSPA
11144C...Generates spacelike parton showers.
11145
11146 SUBROUTINE PYSSPA(IPU1,IPU2)
11147
11148C...Double precision and integer declarations.
11149 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
11150 IMPLICIT INTEGER(I-N)
11151 INTEGER PYK,PYCHGE,PYCOMP
11152C...Commonblocks.
11153 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
11154 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11155 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
11156 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
11157 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
11158 COMMON/PYINT1/MINT(400),VINT(400)
11159 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
11160 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
11161 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
11162 &/PYINT2/,/PYINT3/
11163C...Local arrays and data.
11164 DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2),
11165 &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25),
11166 &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),
11167 &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2),
11168 &THEFIS(2,2),ISFI(2),DPHI(2),MCESV(2)
11169 DATA IS/2*0/
11170
11171C...Read out basic information; set global Q^2 scale.
11172 IPUS1=IPU1
11173 IPUS2=IPU2
11174 ISUB=MINT(1)
11175 Q2MX=VINT(56)
11176 IF(ISET(ISUB).EQ.2) Q2MX=MIN(VINT(2),PARP(67)*VINT(56))
11177 FCQ2MX=1D0
11178
11179C...Define which processes ME corrections have been implemented for.
11180 MECOR=0
11181 IF(MSTP(68).EQ.1) THEN
11182 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ.142.OR.
11183 & ISUB.EQ.144) MECOR=1
11184 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
11185 ENDIF
11186
11187C...Initialize QCD evolution and check phase space.
11188 Q2MNC=PARP(62)**2
11189 Q2MNCS(1)=Q2MNC
11190 Q2MNCS(2)=Q2MNC
11191 IF(MINT(107).EQ.2.AND.MSTP(66).EQ.2) THEN
11192 Q0S=PARP(15)**2
11193 PS=VINT(3)**2
11194 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
11195 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
11196 Q2INT=SQRT(Q0S*Q2EFF)
11197 Q2MNCS(1)=MAX(Q2MNC,Q2INT)
11198 ELSEIF(MINT(107).EQ.3.AND.MSTP(66).GE.1) THEN
11199 Q2MNCS(1)=MAX(Q2MNC,VINT(283))
11200 ENDIF
11201 IF(MINT(108).EQ.2.AND.MSTP(66).EQ.2) THEN
11202 Q0S=PARP(15)**2
11203 PS=VINT(4)**2
11204 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
11205 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
11206 Q2INT=SQRT(Q0S*Q2EFF)
11207 Q2MNCS(2)=MAX(Q2MNC,Q2INT)
11208 ELSEIF(MINT(108).EQ.3.AND.MSTP(66).GE.1) THEN
11209 Q2MNCS(2)=MAX(Q2MNC,VINT(284))
11210 ENDIF
11211 MCEV=0
11212 ALAMS=PARU(112)
11213 PARU(112)=PARP(61)
11214 FQ2C=1D0
11215 TCMX=0D0
11216 IF(MINT(47).GE.2.AND.(MINT(47).LT.5.OR.MSTP(12).GE.1)) THEN
11217 MCEV=1
11218 IF(MSTP(64).EQ.1) FQ2C=PARP(63)
11219 IF(MSTP(64).EQ.2) FQ2C=PARP(64)
11220 TCMX=LOG(FQ2C*Q2MX/PARP(61)**2)
11221 IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0)
11222 & MCEV=0
11223 ENDIF
11224
11225C...Initialize QED evolution and check phase space.
11226 MEEV=0
11227 XEE=1D-10
11228 SPME=PMAS(11,1)**2
11229 IF(IABS(MINT(11)).EQ.13.OR.IABS(MINT(12)).EQ.13)
11230 &SPME=PMAS(13,1)**2
11231 IF(IABS(MINT(11)).EQ.15.OR.IABS(MINT(12)).EQ.15)
11232 &SPME=PMAS(15,1)**2
11233 Q2MNE=MAX(PARP(68)**2,2D0*SPME)
11234 TEMX=0D0
11235 FWTE=10D0
11236 IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN
11237 MEEV=1
11238 TEMX=LOG(Q2MX/SPME)
11239 IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0
11240 ENDIF
11241 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0) THEN
11242 MEEV=2
11243 TEMX=TCMX
11244 FWTE=1D0
11245 ENDIF
11246 IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN
11247
11248C...Loopback point in case of failure to reconstruct kinematics.
11249 NS=N
11250 LOOP=0
11251 100 LOOP=LOOP+1
11252 IF(LOOP.GT.100) THEN
11253 MINT(51)=1
11254 RETURN
11255 ENDIF
11256 N=NS
11257
11258C...Initial values: flavours, momenta, virtualities.
11259 DO 120 JT=1,2
11260 MORE(JT)=1
11261 KFBEAM(JT)=MINT(10+JT)
11262 IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22
11263 KFLS(JT)=MINT(14+JT)
11264 KFLS(JT+2)=KFLS(JT)
11265 XS(JT)=VINT(40+JT)
11266 IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT)
11267 ZS(JT)=1D0
11268 Q2S(JT)=FCQ2MX*Q2MX
11269 DQ2(JT)=0D0
11270 TEVCSV(JT)=TCMX
11271 ALAM(JT)=PARP(61)
11272 THE2(JT)=1D0
11273 TEVESV(JT)=TEMX
11274 MCESV(JT)=0
11275C...Calculate initial parton distribution weights.
11276 MINT(105)=MINT(102+JT)
11277 MINT(109)=MINT(106+JT)
11278 VINT(120)=VINT(2+JT)
11279C.... ALICE
11280C.... Store side in MINT(124)
11281 MINT(124) = JT
11282C....
11283 IF(XS(JT).LT.1D0-XEE) THEN
11284 IF(MSTP(57).LE.1) THEN
11285 CALL PYPDFU(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
11286 ELSE
11287 CALL PYPDFL(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
11288 ENDIF
11289 ENDIF
11290 DO 110 KFL=-25,25
11291 XFS(JT,KFL)=XFB(KFL)
11292 110 CONTINUE
11293C...Special kinematics check for c/b quarks (that g -> c cbar or
11294C...b bbar kinematically possible).
11295 KFLCB=IABS(KFLS(JT))
11296 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
11297 IF(XS(JT).GT.0.9D0*Q2S(JT)/(PMAS(KFLCB,1)**2+Q2S(JT))) THEN
11298 MINT(51)=1
11299 RETURN
11300 ENDIF
11301 ENDIF
11302 120 CONTINUE
11303 DSH=VINT(44)
11304 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2)
11305
11306C...Find if interference with final state partons.
11307 MFIS=0
11308 IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67)
11309 IF(MFIS.NE.0) THEN
11310 DO 140 I=1,2
11311 KCFI(I)=0
11312 KCA=PYCOMP(IABS(KFLS(I)))
11313 IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I))
11314 NFIS(I)=0
11315 IF(KCFI(I).NE.0) THEN
11316 IF(I.EQ.1) IPFS=IPUS1
11317 IF(I.EQ.2) IPFS=IPUS2
11318 DO 130 J=1,2
11319 ICSI=MOD(K(IPFS,3+J),MSTU(5))
11320 IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND.
11321 & (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN
11322 NFIS(I)=NFIS(I)+1
11323 THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+
11324 & P(ICSI,2)**2))
11325 IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I))
11326 ENDIF
11327 130 CONTINUE
11328 ENDIF
11329 140 CONTINUE
11330 IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0
11331 ENDIF
11332
11333C...Pick up leg with highest virtuality.
11334 JTOLD=1
11335 150 N=N+1
11336 JT=1
11337 IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
11338 IF(N.EQ.NS+2.AND.JT.EQ.JTOLD) JT=3-JT
11339 IF(MORE(JT).EQ.0) JT=3-JT
11340 JTOLD=JT
11341 KFLB=KFLS(JT)
11342 XB=XS(JT)
11343 DO 160 KFL=-25,25
11344 XFB(KFL)=XFS(JT,KFL)
11345 160 CONTINUE
11346 DSHR=2D0*SQRT(DSH)
11347 DSHZ=DSH/ZS(JT)
11348
11349C...Check if allowed to branch.
11350 MCEV=0
11351 IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN
11352 MCEV=1
11353 XEC=MAX(PARP(65)*DSHR/VINT(2),XB*(1D0/(1D0-PARP(66))-1D0))
11354 IF(XB.GE.1D0-2D0*XEC) MCEV=0
11355 ENDIF
11356 MEEV=0
11357 IF(MINT(44+JT).EQ.3) THEN
11358 MEEV=1
11359 IF(XB.GE.1D0-2D0*XEE) MEEV=0
11360 IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC)
11361 & MEEV=0
11362C***Currently kill QED shower for resolved photoproduction.
11363 IF(MINT(18+JT).EQ.1) MEEV=0
11364C***Currently kill shower for W inside electron.
11365 IF(IABS(KFLB).EQ.24) THEN
11366 MCEV=0
11367 MEEV=0
11368 ENDIF
11369 ENDIF
11370 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0.AND.IABS(KFLB).LE.10)
11371 &MEEV=2
11372 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
11373 Q2B=0D0
11374 GOTO 260
11375 ENDIF
11376
11377C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
11378 Q2B=Q2S(JT)
11379 TEVCB=TEVCSV(JT)
11380 TEVEB=TEVESV(JT)
11381 IF(MSTP(62).LE.1) THEN
11382 IF(ZS(JT).GT.0.99999D0) THEN
11383 Q2B=Q2S(JT)
11384 ELSE
11385 Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)*
11386 & (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+
11387 & 8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT))))
11388 ENDIF
11389 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
11390 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
11391 ENDIF
11392 IF(MCEV.EQ.1) THEN
11393 ALSDUM=PYALPS(FQ2C*Q2B)
11394 TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117))
11395 ALAM(JT)=PARU(117)
11396 B0=(33D0-2D0*MSTU(118))/6D0
11397 ENDIF
11398 IF(MEEV.EQ.2) TEVEB=TEVCB
11399 TEVCBS=TEVCB
11400 TEVEBS=TEVEB
11401
11402C...Select side for interference with final state partons.
11403 IF(MFIS.GE.1.AND.N.LE.NS+2) THEN
11404 IFI=N-NS
11405 ISFI(IFI)=0
11406 IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN
11407 ISFI(IFI)=1
11408 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN
11409 IF(PYR(0).GT.0.5D0) ISFI(IFI)=1
11410 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN
11411 ISFI(IFI)=1
11412 IF(PYR(0).GT.0.5D0) ISFI(IFI)=2
11413 ENDIF
11414 ENDIF
11415
11416C...Calculate preweighting factor for ME-corrected processes.
11417 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
11418
11419C...Calculate Altarelli-Parisi weights.
11420 DO 170 KFL=-25,25
11421 WTAPC(KFL)=0D0
11422 WTAPE(KFL)=0D0
11423 WTSF(KFL)=0D0
11424 170 CONTINUE
11425C...q -> q (g or gamma emission), g -> q.
11426 IF(IABS(KFLB).LE.10) THEN
11427 WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC)))
11428 WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC))
11429 EQ2=1D0/9D0
11430 IF(MOD(IABS(KFLB),2).EQ.0) EQ2=4D0*EQ2
11431 IF(MEEV.EQ.2) WTAPE(KFLB)=2.*EQ2*LOG((1D0-XEC-XB)*(XB+XEC)/
11432 & (XEC*(1D0-XEC)))
11433 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11434 WTAPC(KFLB)=WTFF*WTAPC(KFLB)
11435 WTAPC(21)=WTGF*WTAPC(21)
11436 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
11437 ENDIF
11438C...f -> f, gamma -> f.
11439 ELSEIF(IABS(KFLB).LE.20) THEN
11440 WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE)))
11441 WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))
11442 WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2)
11443 IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE)
11444 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11445 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
11446 WTAPE(22)=WTGF*WTAPE(22)
11447 ENDIF
11448C...f -> g, g -> g.
11449 ELSEIF(KFLB.EQ.21) THEN
11450 WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB))
11451 DO 180 KFL=1,MSTP(58)
11452 WTAPC(KFL)=WTAPQ
11453 WTAPC(-KFL)=WTAPQ
11454 180 CONTINUE
11455 WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC)
11456 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11457 DO 190 KFL=1,MSTP(58)
11458 WTAPC(KFL)=WTFG*WTAPC(KFL)
11459 WTAPC(-KFL)=WTFG*WTAPC(-KFL)
11460 190 CONTINUE
11461 WTAPC(21)=WTGG*WTAPC(21)
11462 ENDIF
11463C...f -> gamma, W+, W-.
11464 ELSEIF(KFLB.EQ.22) THEN
11465 WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB
11466 WTAPE(11)=WTAPF
11467 WTAPE(-11)=WTAPF
11468 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11469 WTAPE(11)=WTFG*WTAPE(11)
11470 WTAPE(-11)=WTFG*WTAPE(-11)
11471 ENDIF
11472 ELSEIF(KFLB.EQ.24) THEN
11473 WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
11474 & (XEE*(XB+XEE)))/XB
11475 ELSEIF(KFLB.EQ.-24) THEN
11476 WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
11477 & (XEE*(XB+XEE)))/XB
11478 ENDIF
11479
11480C...Calculate parton distribution weights and sum.
11481 NTRY=0
11482 200 NTRY=NTRY+1
11483 IF(NTRY.GT.500) THEN
11484 MINT(51)=1
11485 RETURN
11486 ENDIF
11487 WTSUMC=0D0
11488 WTSUME=0D0
11489 XFBO=MAX(1D-10,XFB(KFLB))
11490 DO 210 KFL=-25,25
11491 WTSF(KFL)=XFB(KFL)/XFBO
11492 WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL)
11493 WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL)
11494 210 CONTINUE
11495 WTSUMC=MAX(0.0001D0,WTSUMC)
11496 WTSUME=MAX(0.0001D0/FWTE,WTSUME)
11497
11498C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
11499 NTRY2=0
11500 220 NTRY2=NTRY2+1
11501 IF(NTRY2.GT.500) THEN
11502 MINT(51)=1
11503 RETURN
11504 ENDIF
11505 IF(MCEV.EQ.1) THEN
11506 IF(MSTP(64).LE.0) THEN
11507 TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC)
11508 ELSEIF(MSTP(64).EQ.1) THEN
11509 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC))
11510 ELSE
11511 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC)))
11512 ENDIF
11513 ENDIF
11514 IF(MEEV.EQ.1) THEN
11515 TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
11516 & (PARU(101)*FWTE*WTSUME*TEMX)))
11517 ELSEIF(MEEV.EQ.2) THEN
11518 TEVEB=TEVEB+LOG(PYR(0))*PARU(2)/(PARU(101)*WTSUME)
11519 ENDIF
11520
11521C...Translate t into Q2 scale; choose between QCD and QED evolution.
11522 230 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C
11523 IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
11524 IF(MEEV.EQ.2) Q2EB=ALAM(JT)**2*EXP(MAX(-50D0,TEVEB))/FQ2C
11525C...Ensure that Q2 is above threshold for charm/bottom.
11526 KFLCB=IABS(KFLB)
11527 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
11528 &MCEV.EQ.1) THEN
11529 IF(Q2CB.LT.PMAS(KFLCB,1)**2) THEN
11530 Q2CB=1.1D0*PMAS(KFLCB,1)**2
11531 TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
11532 FCQ2MX=MIN(2D0,1.05D0*FCQ2MX)
11533 ENDIF
11534 ENDIF
11535 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
11536 &MEEV.EQ.2) THEN
11537 IF(Q2EB.LT.PMAS(KFLCB,1)**2) MEEV=0
11538 ENDIF
11539 MCE=0
11540 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
11541 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN
11542 IF(Q2CB.GT.Q2MNCS(JT)) MCE=1
11543 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN
11544 IF(Q2EB.GT.Q2MNE) MCE=2
11545 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.2) THEN
11546 IF(Q2EB.GT.Q2MNCS(JT)) MCE=2
11547 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.2) THEN
11548 IF(Q2CB.GT.Q2EB.AND.Q2CB.GT.Q2MNCS(JT)) MCE=1
11549 IF(Q2EB.GT.Q2CB.AND.Q2EB.GT.Q2MNCS(JT)) MCE=2
11550 ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN
11551 MCE=1
11552 IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2
11553 IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0
11554 ELSE
11555 MCE=2
11556 IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1
11557 IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0
11558 ENDIF
11559
11560C...Evolution possibly ended. Update t values.
11561 IF(MCE.EQ.0) THEN
11562 Q2B=0D0
11563 GOTO 260
11564 ELSEIF(MCE.EQ.1) THEN
11565 Q2B=Q2CB
11566 Q2REF=FQ2C*Q2B
11567 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
11568 IF(MEEV.EQ.2) TEVEB=LOG(FQ2C*Q2B/ALAM(JT)**2)
11569 ELSE
11570 Q2B=Q2EB
11571 Q2REF=Q2B
11572 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
11573 ENDIF
11574
11575C...Select flavour for branching parton.
11576 IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC
11577 IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME
11578 KFLA=-25
11579 240 KFLA=KFLA+1
11580 IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA)
11581 IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA)
11582 IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 240
11583 IF(KFLA.EQ.25) THEN
11584 Q2B=0D0
11585 GOTO 260
11586 ENDIF
11587
11588C...Choose z value and corrective weight.
11589 WTZ=0D0
11590C...q -> q + g or q -> q + gamma.
11591 IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN
11592 Z=1D0-((1D0-XB-XEC)/(1D0-XEC))*
11593 & (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0)
11594 WTZ=0.5D0*(1D0+Z**2)
11595C...q -> g + q.
11596 ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN
11597 Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2
11598 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
11599C...f -> f + gamma.
11600 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
11601 IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN
11602 Z=1D0-((1D0-XB-XEE)/(1D0-XEE))*
11603 & (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0)
11604 ELSE
11605 Z=XB+XB*(XEE/(1D0-XEE))*
11606 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
11607 ENDIF
11608 WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB)
11609C...f -> gamma + f.
11610 ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) THEN
11611 Z=XB+XB*(XEE/(1D0-XEE))*
11612 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
11613 WTZ=0.5D0*(1D0+(1D0-Z)**2)*XB*(Z-XB)/Z
11614C...f -> W+- + f.
11615 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) THEN
11616 Z=XB+XB*(XEE/(1D0-XEE))*
11617 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
11618 WTZ=0.5D0*(1D0+(1D0-Z)**2)*(XB*(Z-XB)/Z)*
11619 & (Q2B/(Q2B+PMAS(24,1)**2))
11620C...g -> q + qbar.
11621 ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN
11622 Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC))
11623 WTZ=1D0-2D0*Z*(1D0-Z)
11624C...g -> g + g.
11625 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
11626 Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0))
11627 WTZ=(1D0-Z*(1D0-Z))**2
11628C...gamma -> f + fbar.
11629 ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN
11630 Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE))
11631 WTZ=1D0-2D0*Z*(1D0-Z)
11632 ENDIF
11633 IF(MCE.EQ.2.AND.MEEV.EQ.1) WTZ=(WTZ/FWTE)*(TEVEB/TEMX)
11634
11635C...Option with resummation of soft gluon emission as effective z shift.
11636 IF(MCE.EQ.1) THEN
11637 IF(MSTP(65).GE.1) THEN
11638 RSOFT=6D0
11639 IF(KFLB.NE.21) RSOFT=8D0/3D0
11640 Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0))
11641 IF(Z.LE.XB) GOTO 220
11642 ENDIF
11643
11644C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
11645 IF(MSTP(64).GE.2) THEN
11646 IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 220
11647 ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z))
11648 IF(ALPRAT.LT.5D0*PYR(0)) GOTO 220
11649 IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0
11650 ENDIF
11651 ENDIF
11652
11653C...Remove kinematically impossible branchings.
11654 UHAT=Q2B-DSH*(1D0-Z)/Z
11655 IF(MSTP(68).GE.0.AND.UHAT.GT.0D0) GOTO 220
11656
11657C...Select phi angle of branching at random.
11658 PHIBR=PARU(2)*PYR(0)
11659
11660C...Matrix-element corrections for some processes.
11661 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11662 IF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
11663 CALL PYMEWT(MECOR,1,Q2B,Z,PHIBR,WTME)
11664 WTZ=WTZ*WTME/WTFF
11665 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.IABS(KFLB).LE.20) THEN
11666 CALL PYMEWT(MECOR,2,Q2B,Z,PHIBR,WTME)
11667 WTZ=WTZ*WTME/WTGF
11668 ELSEIF(IABS(KFLA).LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
11669 CALL PYMEWT(MECOR,3,Q2B,Z,PHIBR,WTME)
11670 WTZ=WTZ*WTME/WTFG
11671 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
11672 CALL PYMEWT(MECOR,4,Q2B,Z,PHIBR,WTME)
11673 WTZ=WTZ*WTME/WTGG
11674 ENDIF
11675 ENDIF
11676
11677C...Impose angular constraint in first branching from interference
11678C...with final state partons.
11679 IF(MCE.EQ.1) THEN
11680 IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN
11681 THE2D=(4D0*Q2B)/(DSH*(1D0-Z))
11682 IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN
11683 IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 220
11684 ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN
11685 IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 220
11686 ENDIF
11687 ENDIF
11688
11689C...Option with angular ordering requirement.
11690 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN
11691 THE2T=(4D0*Z**2*Q2B)/(4D0*Z**2*Q2B+(1D0-Z)*XB**2*VINT(2))
11692 IF(THE2T.GT.THE2(JT)) GOTO 220
11693 ENDIF
11694 ENDIF
11695
11696C...Weighting with new parton distributions.
11697 MINT(105)=MINT(102+JT)
11698 MINT(109)=MINT(106+JT)
11699 VINT(120)=VINT(2+JT)
11700C.... ALICE
11701C.... Store side in MINT(124)
11702 MINT(124)=JT
11703C....
11704 IF(MSTP(57).LE.1) THEN
11705 CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN)
11706 ELSE
11707 CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN)
11708 ENDIF
11709 XFBN=XFN(KFLB)
11710 IF(XFBN.LT.1D-20) THEN
11711 IF(KFLA.EQ.KFLB) THEN
11712 TEVCB=TEVCBS
11713 TEVEB=TEVEBS
11714 WTAPC(KFLB)=0D0
11715 WTAPE(KFLB)=0D0
11716 GOTO 200
11717 ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN
11718 TEVCB=0.5D0*(TEVCBS+TEVCB)
11719 GOTO 230
11720 ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN
11721 TEVEB=0.5D0*(TEVEBS+TEVEB)
11722 GOTO 230
11723 ELSE
11724 XFBN=1D-10
11725 XFN(KFLB)=XFBN
11726 ENDIF
11727 ENDIF
11728 DO 250 KFL=-25,25
11729 XFB(KFL)=XFN(KFL)
11730 250 CONTINUE
11731 XA=XB/Z
11732C.... ALICE
11733C.... Store side in MINT(124)
11734 MINT(124) = JT
11735C....
11736 IF(MSTP(57).LE.1) THEN
11737 CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA)
11738 ELSE
11739 CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA)
11740 ENDIF
11741 XFAN=XFA(KFLA)
11742 IF(XFAN.LT.1D-20) GOTO 200
11743 WTSFA=WTSF(KFLA)
11744 IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 200
11745
11746C...Define two hard scatterers in their CM-frame.
11747 260 IF(N.EQ.NS+2) THEN
11748 DQ2(JT)=Q2B
11749 DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
11750 DO 280 JR=1,2
11751 I=NS+JR
11752 IF(JR.EQ.1) IPO=IPUS1
11753 IF(JR.EQ.2) IPO=IPUS2
11754 DO 270 J=1,5
11755 K(I,J)=0
11756 P(I,J)=0D0
11757 V(I,J)=0D0
11758 270 CONTINUE
11759 K(I,1)=14
11760 K(I,2)=KFLS(JR+2)
11761 K(I,4)=IPO
11762 K(I,5)=IPO
11763 P(I,3)=DPLCM*(-1)**(JR+1)
11764 P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
11765 P(I,5)=-SQRT(DQ2(JR))
11766 K(IPO,1)=14
11767 K(IPO,3)=I
11768 K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
11769 K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
11770 280 CONTINUE
11771
11772C...Find maximum allowed mass of timelike parton.
11773 ELSEIF(N.GT.NS+2) THEN
11774 JR=3-JT
11775 DQ2(3)=Q2B
11776 DPC(1)=P(IS(1),4)
11777 DPC(2)=P(IS(2),4)
11778 DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
11779 DPD(1)=DSH+DQ2(JR)+DQ2(JT)
11780 DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
11781 DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
11782 DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
11783 IKIN=0
11784 IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE.
11785 & 1D-10*DPD(1)) IKIN=1
11786 IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))*
11787 & (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
11788 IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/
11789 & (2D0*DQ2(JR))-DQ2(JT)-DQ2(3)
11790
11791C...Generate timelike parton shower (if required).
11792 IT=N
11793 DO 290 J=1,5
11794 K(IT,J)=0
11795 P(IT,J)=0D0
11796 V(IT,J)=0D0
11797 290 CONTINUE
11798C...f -> f + g (gamma).
11799 IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN
11800 K(IT,2)=21
11801 IF(MCESV(JT).EQ.2.OR.IABS(KFLB).GE.11) K(IT,2)=22
11802C...f -> g (gamma, W+-) + f.
11803 ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN
11804 K(IT,2)=KFLB
11805 IF(KFLS(JT+2).EQ.24) THEN
11806 K(IT,2)=-12
11807 ELSEIF(KFLS(JT+2).EQ.-24) THEN
11808 K(IT,2)=12
11809 ENDIF
11810C...g (gamma) -> f + fbar, g + g.
11811 ELSE
11812 K(IT,2)=-KFLS(JT+2)
11813 IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2)
11814 ENDIF
11815 K(IT,1)=3
11816 IF((IABS(K(IT,2)).GE.11.AND.IABS(K(IT,2)).LE.18).OR.
11817 & IABS(K(IT,2)).EQ.22) K(IT,1)=1
11818 P(IT,5)=PYMASS(K(IT,2))
11819 IF(DMSMA.LE.P(IT,5)**2) GOTO 100
11820 IF(MSTP(63).GE.1.AND.MCESV(JT).EQ.1) THEN
11821 MSTJ48=MSTJ(48)
11822 PARJ85=PARJ(85)
11823 P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
11824 P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
11825 IF(MSTP(63).EQ.1) THEN
11826 Q2TIM=DMSMA
11827 ELSEIF(MSTP(63).EQ.2) THEN
11828 Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT))
11829 ELSE
11830 Q2TIM=DMSMA
11831 MSTJ(48)=1
11832 IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
11833 IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)*
11834 & DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2)
11835 PARJ(85)=SQRT(MAX(0D0,DPT2))*
11836 & (1D0/P(IT,4)+1D0/P(IS(JT),4))
11837 ENDIF
11838 CALL PYSHOW(IT,0,SQRT(Q2TIM))
11839 MSTJ(48)=MSTJ48
11840 PARJ(85)=PARJ85
11841 IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
11842 ENDIF
11843
11844C...Reconstruct kinematics of branching: timelike parton shower.
11845 DMS=P(IT,5)**2
11846 IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
11847 IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+
11848 & 0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/
11849 & (4D0*DSH*DPC(3)**2)
11850 IF(DPT2.LT.0D0) GOTO 100
11851 DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
11852 & DSHR)/DPC(3)-DPC(3)
11853 P(IT,1)=SQRT(DPT2)
11854 P(IT,3)=DPB(1)*(-1)**(JT+1)
11855 P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS)
11856 IF(N.GE.IT+1) THEN
11857 DPB(1)=SQRT(DPB(1)**2+DPT2)
11858 DPB(2)=SQRT(DPB(1)**2+DMS)
11859 DPB(3)=P(IT+1,3)
11860 DPB(4)=SQRT(DPB(3)**2+DMS)
11861 DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
11862 & DPB(1))
11863 CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ)
11864 THE=PYANGL(P(IT,3),P(IT,1))
11865 CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0)
11866 ENDIF
11867
11868C...Reconstruct kinematics of branching: spacelike parton.
11869 DO 300 J=1,5
11870 K(N+1,J)=0
11871 P(N+1,J)=0D0
11872 V(N+1,J)=0D0
11873 300 CONTINUE
11874 K(N+1,1)=14
11875 K(N+1,2)=KFLB
11876 P(N+1,1)=P(IT,1)
11877 P(N+1,3)=P(IT,3)+P(IS(JT),3)
11878 P(N+1,4)=P(IT,4)+P(IS(JT),4)
11879 P(N+1,5)=-SQRT(DQ2(3))
11880
11881C...Define colour flow of branching.
11882 K(IS(JT),3)=N+1
11883 K(IT,3)=N+1
11884 IM1=N+1
11885 IM2=N+1
11886C...f -> f + gamma (Z, W).
11887 IF(IABS(K(IT,2)).GE.22) THEN
11888 K(IT,1)=1
11889 ID1=IS(JT)
11890 ID2=IS(JT)
11891C...f -> gamma (Z, W) + f.
11892 ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN
11893 ID1=IT
11894 ID2=IT
11895C...gamma -> q + qbar, g + g.
11896 ELSEIF(K(N+1,2).EQ.22) THEN
11897 ID1=IS(JT)
11898 ID2=IT
11899 IM1=ID2
11900 IM2=ID1
11901C...q -> q + g.
11902 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN
11903 ID1=IT
11904 ID2=IS(JT)
11905C...q -> g + q.
11906 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN
11907 ID1=IS(JT)
11908 ID2=IT
11909C...qbar -> qbar + g.
11910 ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN
11911 ID1=IS(JT)
11912 ID2=IT
11913C...qbar -> g + qbar.
11914 ELSEIF(K(N+1,2).LT.0) THEN
11915 ID1=IT
11916 ID2=IS(JT)
11917C...g -> g + g; g -> q + qbar.
11918 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
11919 ID1=IS(JT)
11920 ID2=IT
11921 ELSE
11922 ID1=IT
11923 ID2=IS(JT)
11924 ENDIF
11925 IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1
11926 IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2
11927 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
11928 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
11929 IF(ID1.NE.ID2) THEN
11930 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
11931 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
11932 ENDIF
11933 N=N+1
11934 IF(K(IT,1).EQ.1) THEN
11935 K(IT,4)=0
11936 K(IT,5)=0
11937 ENDIF
11938
11939C...Boost to new CM-frame.
11940 DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4))
11941 DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4))
11942 IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100
11943 CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ)
11944 IR=N+(JT-1)*(IS(1)-N)
11945 CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),DPHI(JT),
11946 & 0D0,0D0,0D0)
11947 ENDIF
11948
11949C...Update kinematics variables.
11950 IS(JT)=N
11951 DQ2(JT)=Q2B
11952 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THE2(JT)=THE2T
11953 DSH=DSHZ
11954
11955C...Save quantities; loop back.
11956 Q2S(JT)=Q2B
11957 DPHI(JT)=PHIBR
11958 MCESV(JT)=MCE
11959 IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR.
11960 &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN
11961 KFLS(JT+2)=KFLS(JT)
11962 KFLS(JT)=KFLA
11963 XS(JT)=XA
11964 ZS(JT)=Z
11965 DO 310 KFL=-25,25
11966 XFS(JT,KFL)=XFA(KFL)
11967 310 CONTINUE
11968 TEVCSV(JT)=TEVCB
11969 TEVESV(JT)=TEVEB
11970 ELSE
11971 MORE(JT)=0
11972 IF(JT.EQ.1) IPU1=N
11973 IF(JT.EQ.2) IPU2=N
11974 ENDIF
11975 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
11976 CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS')
11977 IF(MSTU(21).GE.1) N=NS
11978 IF(MSTU(21).GE.1) RETURN
11979 ENDIF
11980 IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150
11981
11982C...Boost hard scattering partons to frame of shower initiators.
11983 DO 320 J=1,3
11984 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
11985 320 CONTINUE
11986 K(N+2,1)=1
11987 DO 330 J=1,5
11988 P(N+2,J)=P(NS+1,J)
11989 330 CONTINUE
11990 CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5))
11991 ROBO(2)=PYANGL(P(N+2,1),P(N+2,2))
11992 ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
11993 CALL PYROBO(MINT(83)+5,NS,0D0,-ROBO(2),0D0,0D0,0D0)
11994 CALL PYROBO(MINT(83)+5,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),
11995 &ROBO(5))
11996
11997C...Store user information. Reset Lambda value.
11998 K(IPU1,3)=MINT(83)+3
11999 K(IPU2,3)=MINT(83)+4
12000 DO 340 JT=1,2
12001 MINT(12+JT)=KFLS(JT)
12002 VINT(140+JT)=XS(JT)
12003 IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT)
12004 340 CONTINUE
12005 PARU(112)=ALAMS
12006
12007 RETURN
12008 END
12009
12010C*********************************************************************
12011
12012C...PYMEMX
12013C...Generates maximum ME weight in some initial-state showers.
12014C...Inparameter MECOR: kind of hard scattering process
12015C...Outparameter WTFF: maximum weight for fermion -> fermion
12016C... WTGF: maximum weight for gluon/photon -> fermion
12017C... WTFG: maximum weight for fermion -> gluon/photon
12018C... WTGG: maximum weight for gluon -> gluon
12019
12020 SUBROUTINE PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
12021
12022C...Double precision and integer declarations.
12023 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12024 IMPLICIT INTEGER(I-N)
12025 INTEGER PYK,PYCHGE,PYCOMP
12026C...Commonblocks.
12027 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12028 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12029 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12030 COMMON/PYINT1/MINT(400),VINT(400)
12031 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
12032 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
12033
12034C...Default maximum weight.
12035 WTFF=1D0
12036 WTGF=1D0
12037 WTFG=1D0
12038 WTGG=1D0
12039
12040C...Select maximum weight by process.
12041 IF(MECOR.EQ.1) THEN
12042 WTFF=1D0
12043 WTGF=3D0
12044 ELSEIF(MECOR.EQ.2) THEN
12045 WTFG=1D0
12046 WTGG=1D0
12047 ENDIF
12048
12049 RETURN
12050 END
12051
12052C*********************************************************************
12053
12054C...PYMEWT
12055C...Calculates actual ME weight in some initial-state showers.
12056C...Inparameter MECOR: kind of hard scattering process
12057C... IFLCB: flavour combination of branching,
12058C... 1 for fermion -> fermion,
12059C... 2 for gluon/photon -> fermion
12060C... 3 for fermion -> gluon/photon,
12061C... 4 for gluon -> gluon
12062C... Q2: Q2 value of shower branching
12063C... Z: Z value of branching
12064C...In+outparameter PHIBR: azimuthal angle of branching
12065C...Outparameter WTME: actual ME weight
12066
12067 SUBROUTINE PYMEWT(MECOR,IFLCB,Q2,Z,PHIBR,WTME)
12068
12069C...Double precision and integer declarations.
12070 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12071 IMPLICIT INTEGER(I-N)
12072 INTEGER PYK,PYCHGE,PYCOMP
12073C...Commonblocks.
12074 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12075 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12076 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12077 COMMON/PYINT1/MINT(400),VINT(400)
12078 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
12079 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
12080
12081C...Default output.
12082 WTME=1D0
12083
12084C...Define kinematics of shower branching in Mandelstam variables.
12085 SQM=VINT(44)
12086 SH=SQM/Z
12087 TH=-Q2
12088 UH=Q2-SQM*(1D0-Z)/Z
12089
12090C...Matrix-element corrections for f + fbar -> s-channel vector boson.
12091 IF(MECOR.EQ.1) THEN
12092 IF(IFLCB.EQ.1) THEN
12093 WTME=(TH**2+UH**2+2D0*SQM*SH)/(SH**2+SQM**2)
12094 ELSEIF(IFLCB.EQ.2) THEN
12095 WTME=(SH**2+UH**2+2D0*SQM*TH)/((SH-SQM)**2+SQM**2)
12096 ENDIF
12097
12098C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0).
12099 ELSEIF(MECOR.EQ.2) THEN
12100 IF(IFLCB.EQ.3) THEN
12101 WTME=(SH**2+UH**2)/(SH**2+(SH-SQM)**2)
12102 ELSEIF(IFLCB.EQ.4) THEN
12103 WTME=0.5D0*(SH**4+UH**4+TH**4+SQM**4)/(SH**2-SQM*(SH-SQM))**2
12104 ENDIF
12105 ENDIF
12106
12107 RETURN
12108 END
12109
12110C*********************************************************************
12111
12112C...PYADSH
12113C...Administers the generation of successive final-state showers
12114C...in external processes.
12115
12116 SUBROUTINE PYADSH(NFIN)
12117
12118C...Double precision and integer declarations.
12119 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12120 IMPLICIT INTEGER(I-N)
12121 INTEGER PYK,PYCHGE,PYCOMP
12122C...Commonblocks.
12123 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12124 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12125 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12126 COMMON/PYINT1/MINT(400),VINT(400)
12127 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
12128C...Local array.
12129 DIMENSION IBEG(100),KSAV(10,5),IORD(10),PSUM(4),BETA(3)
12130
12131C...Set primary vertex.
12132 DO 100 J=1,5
12133 V(MINT(83)+5,J)=0D0
12134 V(MINT(83)+6,J)=0D0
12135 V(MINT(84)+1,J)=0D0
12136 V(MINT(84)+2,J)=0D0
12137 100 CONTINUE
12138
12139C...Isolate systems of particles with the same mother.
12140 NSYS=0
12141 IMS=-1
12142 DO 140 I=MINT(84)+3,NFIN
12143 IM=K(I,3)
12144 IF(IM.GT.0.AND.IM.LE.MINT(84)) IM=K(IM,3)
12145 IF(IM.NE.IMS) THEN
12146 NSYS=NSYS+1
12147 IBEG(NSYS)=I
12148 IMS=IM
12149 ENDIF
12150
12151C...Set production vertices.
12152 IF(IM.LE.MINT(83)+6.OR.(IM.GT.MINT(84).AND.IM.LE.MINT(84)+2))
12153 & THEN
12154 DO 110 J=1,4
12155 V(I,J)=0D0
12156 110 CONTINUE
12157 ELSE
12158 DO 120 J=1,4
12159 V(I,J)=V(IM,J)+V(IM,5)*P(IM,J)/P(IM,5)
12160 120 CONTINUE
12161 ENDIF
12162 IF(MSTP(125).GE.1) THEN
12163 IDOC=I-MSTP(126)+4
12164 DO 130 J=1,5
12165 V(IDOC,J)=V(I,J)
12166 130 CONTINUE
12167 ENDIF
12168 140 CONTINUE
12169
12170C...End loop over systems. Return if no showers to be performed.
12171 IBEG(NSYS+1)=NFIN+1
12172 IF(MSTP(71).LE.0) RETURN
12173
12174C...Loop through systems of particles; check that sensible size.
12175 DO 260 ISYS=1,NSYS
12176 NSIZ=IBEG(ISYS+1)-IBEG(ISYS)
12177 IF(NSIZ.EQ.1.AND.ISYS.EQ.1) THEN
12178 ELSEIF(NSIZ.LE.1) THEN
12179 CALL PYERRM(2,'(PYADSH:) only one particle in system')
12180 ELSEIF(NSIZ.GT.7) THEN
12181 CALL PYERRM(2,'(PYADSH:) more than seven particles in system')
12182 ELSE
12183
12184C...Save status codes and daughters of showering pair; reset them.
12185 DO 150 J=1,4
12186 PSUM(J)=0D0
12187 150 CONTINUE
12188 DO 170 II=1,NSIZ
12189 I=IBEG(ISYS)-1+II
12190 KSAV(II,1)=K(I,1)
12191 IF(K(I,1).GT.10) THEN
12192 K(I,1)=1
12193 IF(KSAV(II,1).EQ.14) K(I,1)=3
12194 ENDIF
12195 IF(KSAV(II,1).LE.10) THEN
12196 ELSEIF(K(I,1).EQ.1) THEN
12197 KSAV(II,4)=K(I,4)
12198 KSAV(II,5)=K(I,5)
12199 K(I,4)=0
12200 K(I,5)=0
12201 ELSE
12202 KSAV(II,4)=MOD(K(I,4),MSTU(5))
12203 KSAV(II,5)=MOD(K(I,5),MSTU(5))
12204 K(I,4)=K(I,4)-KSAV(II,4)
12205 K(I,5)=K(I,5)-KSAV(II,5)
12206 ENDIF
12207 DO 160 J=1,4
12208 PSUM(J)=PSUM(J)+P(I,J)
12209 160 CONTINUE
12210 170 CONTINUE
12211
12212C...Perform shower.
12213 QMAX=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
12214 & PSUM(3)**2))
12215 IF(ISYS.EQ.1) QMAX=MIN(QMAX,SQRT(PARP(71))*VINT(55))
12216 NSAV=N
12217 IF(NSIZ.EQ.2) THEN
12218 CALL PYSHOW(IBEG(ISYS),IBEG(ISYS)+1,QMAX)
12219 ELSE
12220 CALL PYSHOW(IBEG(ISYS),-NSIZ,QMAX)
12221 ENDIF
12222
12223C...Look up showered copies of original showering particles.
12224 DO 250 II=1,NSIZ
12225 I=IBEG(ISYS)-1+II
12226 IMV=I
12227 IF(N.EQ.NSAV.OR.K(I,1).LE.10) THEN
12228 ELSEIF(K(I,1).EQ.11) THEN
12229 180 IMV=MOD(K(IMV,4),MSTU(5))
12230 IF(K(IMV,1).EQ.11) GOTO 180
12231 ELSE
12232 KDA1=MOD(K(I,4),MSTU(5))
12233 KDA2=MOD(K(I,5),MSTU(5))
12234 DO 190 I3=I+1,N
12235 IF(K(I3,2).EQ.K(I,2).AND.(I3.EQ.KDA1.OR.I3.EQ.KDA2))
12236 & THEN
12237 IMV=I3
12238 KDA1=MOD(K(I3,4),MSTU(5))
12239 KDA2=MOD(K(I3,5),MSTU(5))
12240 ENDIF
12241 190 CONTINUE
12242 ENDIF
12243
12244C...Restore daughter info of original partons to showered copies.
12245 IF(KSAV(II,1).GT.10) K(IMV,1)=KSAV(II,1)
12246 IF(KSAV(II,1).LE.10) THEN
12247 ELSEIF(K(I,1).EQ.1) THEN
12248 K(IMV,4)=KSAV(II,4)
12249 K(IMV,5)=KSAV(II,5)
12250 ELSE
12251 K(IMV,4)=K(IMV,4)+KSAV(II,4)
12252 K(IMV,5)=K(IMV,5)+KSAV(II,5)
12253 ENDIF
12254
12255C...Reset mother info of existing daughters to showered copies.
12256 DO 200 I3=IBEG(ISYS+1),NFIN
12257 IF(K(I3,3).EQ.I) K(I3,3)=IMV
12258 IF(K(I3,1).EQ.3.OR.K(I3,1).EQ.14) THEN
12259 IF(K(I3,4)/MSTU(5).EQ.I) K(I3,4)=K(I3,4)+MSTU(5)*(IMV-I)
12260 IF(K(I3,5)/MSTU(5).EQ.I) K(I3,5)=K(I3,5)+MSTU(5)*(IMV-I)
12261 ENDIF
12262 200 CONTINUE
12263
12264C...Boost all original daughters to new frame of showered copy.
12265 IF(IMV.NE.I) THEN
12266 DO 210 J=1,3
12267 BETA(J)=(P(IMV,J)-P(I,J))/(P(IMV,4)+P(I,4))
12268 210 CONTINUE
12269 FAC=2D0/(1D0+BETA(1)**2+BETA(2)**2+BETA(3)**2)
12270 DO 220 J=1,3
12271 BETA(J)=FAC*BETA(J)
12272 220 CONTINUE
12273 DO 240 I3=IBEG(ISYS+1),NFIN
12274 IMO=I3
12275 230 IMO=K(IMO,3)
12276 IF(MSTP(128).LE.0) THEN
12277 IF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) GOTO 230
12278 IF(IMO.EQ.I.OR.(K(I,3).LE.MINT(84).AND.IMO.EQ.K(I,3)))
12279 & CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
12280 ELSE
12281 IF(IMO.EQ.IMV) THEN
12282 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
12283 ELSEIF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) THEN
12284 GOTO 230
12285 ENDIF
12286 ENDIF
12287 240 CONTINUE
12288 ENDIF
12289 250 CONTINUE
12290
12291C...End of loop over showering systems
12292 ENDIF
12293 260 CONTINUE
12294
12295 RETURN
12296 END
12297
12298C*********************************************************************
12299
12300C...PYRESD
12301C...Allows resonances to decay (including parton showers for hadronic
12302C...channels).
12303
12304 SUBROUTINE PYRESD(IRES)
12305
12306C...Double precision and integer declarations.
12307 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12308 IMPLICIT INTEGER(I-N)
12309 INTEGER PYK,PYCHGE,PYCOMP
12310C...Parameter statement to help give large particle numbers.
12311 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
12312 &KEXCIT=4000000,KDIMEN=5000000)
12313C...Commonblocks.
12314 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12315 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12316 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
12317 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
12318 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
12319 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12320 COMMON/PYINT1/MINT(400),VINT(400)
12321 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
12322 COMMON/PYINT4/MWID(500),WIDS(500,5)
12323 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
12324 &/PYINT1/,/PYINT2/,/PYINT4/
12325C...Local arrays and complex and character variables.
12326 DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
12327 &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(3),ILIN(6),
12328 &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3),
12329 &PHI(3),WDTP(0:400),WDTE(0:400,0:5),DPMO(5),XM(5),VDCY(4),
12330 &ITJUNC(3),CTM2(3)
12331 COMPLEX FGK,HA(6,6),HC(6,6)
12332 REAL TIR,UIR
12333 CHARACTER CODE*9,MASS*9
12334
12335C...The F, Xi and Xj functions of Gunion and Kunszt
12336C...(Phys. Rev. D33, 665, plus errata from the authors).
12337 FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
12338 &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
12339 DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/
12340 &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34))
12341 DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU-
12342 &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+
12343 &2D0*(D34/D56+D56/D34))
12344
12345C...Some general constants.
12346 XW=PARU(102)
12347 XWV=XW
12348 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
12349 XW1=1D0-XW
12350 SQMZ=PMAS(23,1)**2
12351
12352 GMMZ=PMAS(23,1)*PMAS(23,2)
12353 SQMW=PMAS(24,1)**2
12354 GMMW=PMAS(24,1)*PMAS(24,2)
12355 SH=VINT(44)
12356
12357C...Boost and rotate to rest frame of incoming partons,
12358C...to get proper amount of smearing of decay angles.
12359 IBST=0
12360 IF(IRES.EQ.0) THEN
12361 IBST=1
12362 ETOTIN=P(MINT(84)+1,4)+P(MINT(84)+2,4)
12363 BEXIN=(P(MINT(84)+1,1)+P(MINT(84)+2,1))/ETOTIN
12364 BEYIN=(P(MINT(84)+1,2)+P(MINT(84)+2,2))/ETOTIN
12365 BEZIN=(P(MINT(84)+1,3)+P(MINT(84)+2,3))/ETOTIN
12366 CALL PYROBO(MINT(83)+7,N,0D0,0D0,-BEXIN,-BEYIN,-BEZIN)
12367 PHIIN=PYANGL(P(MINT(84)+1,1),P(MINT(84)+1,2))
12368 CALL PYROBO(MINT(83)+7,N,0D0,-PHIIN,0D0,0D0,0D0)
12369 THEIN=PYANGL(P(MINT(84)+1,3),P(MINT(84)+1,1))
12370 CALL PYROBO(MINT(83)+7,N,-THEIN,0D0,0D0,0D0,0D0)
12371 ENDIF
12372
12373C...Reset original resonance configuration.
12374 DO 100 JT=1,8
12375 IREF(1,JT)=0
12376 100 CONTINUE
12377
12378C...Define initial one, two or three objects for subprocess.
12379 IHDEC=0
12380 IF(IRES.EQ.0) THEN
12381 ISUB=MINT(1)
12382 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
12383 IREF(1,1)=MINT(84)+2+ISET(ISUB)
12384 IREF(1,4)=MINT(83)+6+ISET(ISUB)
12385 JTMAX=1
12386 ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
12387 IREF(1,1)=MINT(84)+1+ISET(ISUB)
12388 IREF(1,2)=MINT(84)+2+ISET(ISUB)
12389 IREF(1,4)=MINT(83)+5+ISET(ISUB)
12390 IREF(1,5)=MINT(83)+6+ISET(ISUB)
12391 JTMAX=2
12392 ELSEIF(ISET(ISUB).EQ.5) THEN
12393 IREF(1,1)=MINT(84)+3
12394 IREF(1,2)=MINT(84)+4
12395 IREF(1,3)=MINT(84)+5
12396 IREF(1,4)=MINT(83)+7
12397 IREF(1,5)=MINT(83)+8
12398 IREF(1,6)=MINT(83)+9
12399 JTMAX=3
12400 ENDIF
12401
12402C...Define original resonance for odd cases.
12403 ELSE
12404 ISUB=0
12405 IF(K(IRES,2).EQ.25.OR.K(IRES,2).EQ.35.OR.K(IRES,2).EQ.36)
12406 & IHDEC=1
12407 IF(IHDEC.EQ.1) ISUB=3
12408 IREF(1,1)=IRES
12409 IREF(1,4)=K(IRES,3)
12410 JTMAX=1
12411 ENDIF
12412
12413C...Check if initial resonance has been moved (in resonance + jet).
12414 DO 120 JT=1,3
12415 IF(IREF(1,JT).GT.0) THEN
12416 IF(K(IREF(1,JT),1).GT.10) THEN
12417 KFA=IABS(K(IREF(1,JT),2))
12418 IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN
12419 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
12420 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
12421 DO 110 I=IREF(1,JT)+1,N
12422 IF(K(I,2).EQ.K(IREF(1,JT),2).AND.(I.EQ.KDA1.OR.
12423 & I.EQ.KDA2)) THEN
12424 IREF(1,JT)=I
12425 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
12426 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
12427 ENDIF
12428 110 CONTINUE
12429 ELSE
12430 KDA=MOD(K(IREF(1,JT),4),MSTU(5))
12431 IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA
12432 ENDIF
12433 ENDIF
12434 ENDIF
12435 120 CONTINUE
12436
12437C.....Set decay vertex for initial resonances
12438 DO 140 JT=1,JTMAX
12439 DO 130 I=1,4
12440 V(IREF(1,JT),I)=0D0
12441 130 CONTINUE
12442 140 CONTINUE
12443
12444C...Loop over decay history.
12445 NP=1
12446 IP=0
12447 150 IP=IP+1
12448 NINH=0
12449 JTMAX=2
12450 IF(IREF(IP,2).EQ.0) JTMAX=1
12451 IF(IREF(IP,3).NE.0) JTMAX=3
12452 IT4=0
12453 NSAV=N
12454
12455C...Check for Higgs which appears as decay product of user-process.
12456 IF(ISUB.EQ.0) THEN
12457 IHDEC=0
12458 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
12459 & .EQ.36) IHDEC=1
12460 IF(IHDEC.EQ.1) ISUB=3
12461 ENDIF
12462
12463C...Start treatment of one, two or three resonances in parallel.
12464 160 N=NSAV
12465 DO 320 JT=1,JTMAX
12466 ID=IREF(IP,JT)
12467 KDCY(JT)=0
12468 KFL1(JT)=0
12469 KFL2(JT)=0
12470 KFL3(JT)=0
12471 KEQL(JT)=0
12472 NSD(JT)=ID
12473 ITJUNC(JT)=0
12474
12475C...Check whether particle can/is allowed to decay.
12476 IF(ID.EQ.0) GOTO 310
12477 KFA=IABS(K(ID,2))
12478 KCA=PYCOMP(KFA)
12479 IF(MWID(KCA).EQ.0) GOTO 310
12480 IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 310
12481 IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR.
12482 & KFA.EQ.18) IT4=IT4+1
12483 K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5))
12484 K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5))
12485
12486C...Choose lifetime and determine decay vertex.
12487 IF(K(ID,1).EQ.5) THEN
12488 V(ID,5)=0D0
12489 ELSEIF(K(ID,1).NE.4) THEN
12490 V(ID,5)=-PMAS(KCA,4)*LOG(PYR(0))
12491 ENDIF
12492 DO 170 J=1,4
12493 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
12494 170 CONTINUE
12495
12496C...Determine whether decay allowed or not.
12497 MOUT=0
12498 IF(MSTJ(22).EQ.2) THEN
12499 IF(PMAS(KCA,4).GT.PARJ(71)) MOUT=1
12500 ELSEIF(MSTJ(22).EQ.3) THEN
12501 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
12502 ELSEIF(MSTJ(22).EQ.4) THEN
12503 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
12504 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
12505 ENDIF
12506 IF(MOUT.EQ.1.AND.K(ID,1).NE.5) THEN
12507 K(ID,1)=4
12508 GOTO 310
12509 ENDIF
12510
12511C...Info for selection of decay channel: sign, pairings.
12512 IF(KCHG(KCA,3).EQ.0) THEN
12513 IPM=2
12514 ELSE
12515 IPM=(5-ISIGN(1,K(ID,2)))/2
12516 ENDIF
12517 KFB=0
12518 IF(JTMAX.EQ.2) THEN
12519 KFB=IABS(K(IREF(IP,3-JT),2))
12520 ELSEIF(JTMAX.EQ.3) THEN
12521 JT2=JT+1-3*(JT/3)
12522 KFB=IABS(K(IREF(IP,JT2),2))
12523 IF(KFB.NE.KFA) THEN
12524 JT2=JT+2-3*((JT+1)/3)
12525 KFB=IABS(K(IREF(IP,JT2),2))
12526 ENDIF
12527 ENDIF
12528
12529C...Select decay channel.
12530 IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.
12531 & ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1
12532 CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE)
12533 WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4)
12534 IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5)
12535 IF(WDTE0S.LE.0D0) GOTO 310
12536 RKFL=WDTE0S*PYR(0)
12537 IDL=0
12538 180 IDL=IDL+1
12539 IDC=IDL+MDCY(KCA,2)-1
12540 RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4))
12541 IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5)
12542 IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 180
12543
12544C...Read out flavours and colour charges of decay channel chosen.
12545 KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2))
12546 IF(KCQM(JT).EQ.-2) KCQM(JT)=2
12547 KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
12548 KFC1A=PYCOMP(IABS(KFL1(JT)))
12549 IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT))
12550 KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT))
12551 IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2
12552 KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
12553 KFC2A=PYCOMP(IABS(KFL2(JT)))
12554 IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT))
12555 KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT))
12556 IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2
12557 KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2))
12558 KCQ3(JT)=0
12559 IF(KFL3(JT).NE.0) THEN
12560 KFC3A=PYCOMP(IABS(KFL3(JT)))
12561 IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT))
12562 KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT))
12563 IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2
12564 ENDIF
12565
12566C...Set/save further info on channel.
12567 KDCY(JT)=1
12568 IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1)
12569 NSD(JT)=N
12570 HGZ(JT,1)=VINT(111)
12571 HGZ(JT,2)=VINT(112)
12572 HGZ(JT,3)=VINT(114)
12573 JTZ=JT
12574
12575C...Select masses; to begin with assume resonances narrow.
12576 DO 200 I=1,3
12577 P(N+I,5)=0D0
12578 PMMN(I)=0D0
12579 IF(I.EQ.1) THEN
12580 KFLW=IABS(KFL1(JT))
12581 KCW=KFC1A
12582 ELSEIF(I.EQ.2) THEN
12583 KFLW=IABS(KFL2(JT))
12584 KCW=KFC2A
12585 ELSEIF(I.EQ.3) THEN
12586 IF(KFL3(JT).EQ.0) GOTO 200
12587 KFLW=IABS(KFL3(JT))
12588 KCW=KFC3A
12589 ENDIF
12590 P(N+I,5)=PMAS(KCW,1)
12591CMRENNA++
12592C...This prevents SUSY/t particles from becoming too light.
12593 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
12594 PMMN(I)=PMAS(KCW,1)
12595 DO 190 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
12596 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
12597 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
12598 & PMAS(PYCOMP(KFDP(IDC,2)),1)
12599 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
12600 & PMAS(PYCOMP(KFDP(IDC,3)),1)
12601 PMMN(I)=MIN(PMMN(I),PMSUM)
12602 ENDIF
12603 190 CONTINUE
12604CMRENNA--
12605 ELSEIF(KFLW.EQ.6) THEN
12606 PMMN(I)=PMAS(24,1)+PMAS(5,1)
12607 ENDIF
12608 200 CONTINUE
12609
12610C...Check which two out of three are widest.
12611 IWID1=1
12612 IWID2=2
12613 PWID1=PMAS(KFC1A,2)
12614 PWID2=PMAS(KFC2A,2)
12615 KFLW1=IABS(KFL1(JT))
12616 KFLW2=IABS(KFL2(JT))
12617 IF(KFL3(JT).NE.0) THEN
12618 PWID3=PMAS(KFC3A,2)
12619 IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN
12620 IWID1=3
12621 PWID1=PWID3
12622 KFLW1=IABS(KFL3(JT))
12623 ELSEIF(PWID3.GT.PWID2) THEN
12624 IWID2=3
12625 PWID2=PWID3
12626 KFLW2=IABS(KFL3(JT))
12627 ENDIF
12628 ENDIF
12629
12630C...If all narrow then only check that masses consistent.
12631 IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND.
12632 & PWID2.LT.PARP(41))) THEN
12633CMRENNA++
12634C....Handle near degeneracy cases.
12635 IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN
12636 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
12637 P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0
12638 IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0
12639 ENDIF
12640 ENDIF
12641CMRENNA--
12642 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
12643 CALL PYERRM(13,'(PYRESD:) daughter masses too large')
12644 MINT(51)=1
12645 GOTO 700
12646 ELSEIF(P(N+1,5)+P(N+2,5)+P(N+3,5)+PARJ(64).GT.P(ID,5)) THEN
12647 CALL PYERRM(3,'(PYRESD:) daughter masses too large')
12648 MINT(51)=1
12649 GOTO 700
12650 ENDIF
12651
12652C...For three wide resonances select narrower of three
12653C...according to BW decoupled from rest.
12654 ELSE
12655 PMTOT=P(ID,5)
12656 IF(KFL3(JT).NE.0) THEN
12657 IWID3=6-IWID1-IWID2
12658 KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))-
12659 & KFLW1-KFLW2
12660 LOOP=0
12661 210 LOOP=LOOP+1
12662 P(N+IWID3,5)=PYMASS(KFLW3)
12663 IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 210
12664 PMTOT=PMTOT-P(N+IWID3,5)
12665 ENDIF
12666C...Select other two correlated within remaining phase space.
12667 IF(IP.EQ.1) THEN
12668 CKIN45=CKIN(45)
12669 CKIN47=CKIN(47)
12670 CKIN(45)=MAX(PMMN(IWID1),CKIN(45))
12671 CKIN(47)=MAX(PMMN(IWID2),CKIN(47))
12672 CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
12673 & P(N+IWID2,5))
12674 CKIN(45)=CKIN45
12675 CKIN(47)=CKIN47
12676 ELSE
12677 CKIN(49)=PMMN(IWID1)
12678 CKIN(50)=PMMN(IWID2)
12679 CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
12680 & P(N+IWID2,5))
12681 CKIN(49)=0D0
12682 CKIN(50)=0D0
12683 ENDIF
12684 IF(MINT(51).EQ.1) GOTO 700
12685 ENDIF
12686
12687C...Begin fill decay products, with colour flow for coloured objects.
12688 MSTU10=MSTU(10)
12689 MSTU(10)=1
12690 MSTU(19)=1
12691
12692CMRENNA++
12693C...1) Three-body decays of SUSY particles (plus special case top).
12694 IF(KFL3(JT).NE.0) THEN
12695 DO 230 I=N+1,N+3
12696 DO 220 J=1,5
12697 K(I,J)=0
12698 V(I,J)=0D0
12699 220 CONTINUE
12700 230 CONTINUE
12701 K(N+1,1)=1
12702 K(N+1,2)=KFL1(JT)
12703 K(N+2,1)=1
12704 K(N+2,2)=KFL2(JT)
12705 K(N+3,1)=1
12706 K(N+3,2)=KFL3(JT)
12707 IDIN=ID
12708 CALL PYTBDY(IDIN)
12709
12710C...Set colour flow for t -> W + b + Z.
12711 IF(KFA.EQ.6) THEN
12712 K(N+2,1)=3
12713 ISID=4
12714 IF(KCQM(JT).EQ.-1) ISID=5
12715 IDAU=N+2
12716 K(ID,ISID)=K(ID,ISID)+IDAU
12717 K(IDAU,ISID)=MSTU(5)*ID
12718
12719C...Set colour flow in three-body decays - programmed as special cases.
12720 ELSEIF(KFC2A.LE.6) THEN
12721 K(N+2,1)=3
12722 K(N+3,1)=3
12723 ISID=4
12724 IF(KFL2(JT).LT.0) ISID=5
12725 K(N+2,ISID)=MSTU(5)*(N+3)
12726 K(N+3,9-ISID)=MSTU(5)*(N+2)
12727 ENDIF
12728 IF(KFL1(JT).EQ.KSUSY1+21) THEN
12729 K(N+1,1)=3
12730 K(N+2,1)=3
12731 K(N+3,1)=3
12732 ISID=4
12733 IF(KFL2(JT).LT.0) ISID=5
12734 K(N+1,ISID)=MSTU(5)*(N+2)
12735 K(N+1,9-ISID)=MSTU(5)*(N+3)
12736 K(N+2,ISID)=MSTU(5)*(N+1)
12737 K(N+3,9-ISID)=MSTU(5)*(N+1)
12738 ENDIF
12739 IF(KFA.EQ.KSUSY1+21) THEN
12740 K(N+2,1)=3
12741 K(N+3,1)=3
12742 ISID=4
12743 IF(KFL2(JT).LT.0) ISID=5
12744 K(ID,ISID)=K(ID,ISID)+(N+2)
12745 K(ID,9-ISID)=K(ID,9-ISID)+(N+3)
12746 K(N+2,ISID)=MSTU(5)*ID
12747 K(N+3,9-ISID)=MSTU(5)*ID
12748 ENDIF
12749CMRENNA--
12750
12751 IF(KFA.GE.KSUSY1+22.AND.KFA.LE.KSUSY1+37.AND.
12752 & IABS(KCQ2(JT)).EQ.1) THEN
12753 K(N+2,1)=3
12754 K(N+3,1)=3
12755 ISID=4
12756 IF(KFL2(JT).LT.0) ISID=5
12757 K(N+2,ISID)=MSTU(5)*(N+3)
12758 K(N+3,9-ISID)=MSTU(5)*(N+2)
12759 ENDIF
12760
12761C...Set colour flow in three-body decays with baryon number violation.
12762C...Neutralino and chargino decays first.
12763 KCQSUM=KCQ1(JT)+KCQ2(JT)+KCQ3(JT)
12764 IF(KCQM(JT).EQ.0.AND.IABS(KCQSUM).EQ.3) THEN
12765 ITJUNC(JT)=(1+(1-KCQ1(JT))/2)
12766 K(N+4,4)=ITJUNC(JT)*MSTU(5)
12767C...Insert junction to keep track of colours.
12768 IF(KCQ1(JT).NE.0) K(N+1,1)=3
12769 IF(KCQ2(JT).NE.0) K(N+2,1)=3
12770 IF(KCQ3(JT).NE.0) K(N+3,1)=3
12771C...Set special junction codes:
12772 K(N+4,1)=42
12773 K(N+4,2)=88
12774
12775C...Order decay products by invariant mass. (will be used in PYSTRF).
12776 PM12=P(N+1,4)*P(N+2,4)-P(N+1,1)*P(N+2,1)-P(N+1,2)*P(N+2,2)-
12777 & P(N+1,3)*P(N+2,3)
12778 PM13=P(N+1,4)*P(N+3,4)-P(N+1,1)*P(N+3,1)-P(N+1,2)*P(N+3,2)-
12779 & P(N+1,3)*P(N+3,3)
12780 PM23=P(N+2,4)*P(N+3,4)-P(N+2,1)*P(N+3,1)-P(N+2,2)*P(N+3,2)-
12781 & P(N+2,3)*P(N+3,3)
12782 IF(PM12.LT.PM13.AND.PM12.LT.PM23) THEN
12783 K(N+4,4)=N+3+K(N+4,4)
12784 K(N+4,5)=N+1+MSTU(5)*(N+2)
12785 ELSEIF(PM13.LT.PM23) THEN
12786 K(N+4,4)=N+2+K(N+4,4)
12787 K(N+4,5)=N+1+MSTU(5)*(N+3)
12788 ELSE
12789 K(N+4,4)=N+1+K(N+4,4)
12790 K(N+4,5)=N+2+MSTU(5)*(N+3)
12791 ENDIF
12792 DO 240 J=1,5
12793 P(N+4,J)=0D0
12794 V(N+4,J)=0D0
12795 240 CONTINUE
12796C...Connect daughters to junction.
12797 DO 250 II=N+1,N+3
12798 K(II,4)=0
12799 K(II,5)=0
12800 K(II,ITJUNC(JT)+3)=MSTU(5)*(N+4)
12801 250 CONTINUE
12802C...Particle counter should be stepped up one extra for junction.
12803 N=N+1
12804
12805C...Gluino decays.
12806 ELSEIF (KCQM(JT).EQ.2.AND.IABS(KCQSUM).EQ.3) THEN
12807 ITJUNC(JT)=(5+(1-KCQ1(JT))/2)
12808 K(N+4,4)=ITJUNC(JT)*MSTU(5)
12809C...Insert junction to keep track of colours.
12810 IF(KCQ1(JT).NE.0) K(N+1,1)=3
12811 IF(KCQ2(JT).NE.0) K(N+2,1)=3
12812 IF(KCQ3(JT).NE.0) K(N+3,1)=3
12813 K(N+4,1)=42
12814 K(N+4,2)=88
12815 DO 260 J=1,5
12816 P(N+4,J)=0D0
12817 V(N+4,J)=0D0
12818 260 CONTINUE
12819 CTMSUM=0D0
12820 DO 270 II=N+1,N+3
12821 K(II,4)=0
12822 K(II,5)=0
12823C...Start by connecting all daughters to junction.
12824 K(II,ITJUNC(JT)-1)=MSTU(5)*(N+4)
12825C...Only consider colour topologies with off shell resonances.
12826 RMQ1=PMAS(PYCOMP(K(II,2)),1)
12827 RMRES=PMAS(PYCOMP(KSUSY1+IABS(K(II,2))),1)
12828 RMGLU=PMAS(PYCOMP(KSUSY1+21),1)
12829 IF (RMGLU-RMQ1.LT.RMRES) THEN
12830C...Calculate propagators for each colour topology.
12831 RM2Q23=RMGLU**2+RMQ1**2-2D0*(P(II,4)*P(ID,4)+P(II,1)
12832 & *P(ID,1)+P(II,2)*P(ID,2)+P(II,3)*P(ID,3))
12833 CTM2(II-N)=1D0/(RM2Q23-RMRES**2)**2
12834 ELSE
12835 CTM2(II-N)=0D0
12836 ENDIF
12837 CTMSUM=CTMSUM+CTM2(II-N)
12838 270 CONTINUE
12839 CTMSUM=PYR(0)*CTMSUM
12840C...Select colour topology J, with most off shell least likely.
12841 J=0
12842 280 J=J+1
12843 CTMSUM=CTMSUM-CTM2(J)
12844 IF (CTMSUM.GT.0D0) GOTO 280
12845C...The lucky winner gets its colour (anti-colour) directly from gluino.
12846 K(N+J,ITJUNC(JT)-1)=MSTU(5)*ID
12847 K(ID,ITJUNC(JT)-1)=N+J+(K(ID,ITJUNC(JT)-1)/MSTU(5))*MSTU(5)
12848C...The other gluino colour is connected to junction
12849 K(ID,10-ITJUNC(JT))=N+4+(K(ID,10-ITJUNC(JT))/MSTU(5))*
12850 & MSTU(5)
12851 K(N+4,4)=K(N+4,4)+ID
12852C...Lastly, connect junction to remaining daughters.
12853 K(N+4,5)=N+1+MOD(J,3)+MSTU(5)*(N+1+MOD(J+1,3))
12854C...Particle counter should be stepped up one extra for junction.
12855 N=N+1
12856 ENDIF
12857
12858C...Update particle counter.
12859 N=N+3
12860
12861C...2) Everything else two-body decay.
12862 ELSE
12863 CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
12864C...First set colour flow as if mother colour singlet.
12865 IF(KCQ1(JT).NE.0) THEN
12866 K(N-1,1)=3
12867 IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N
12868 IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N
12869 ENDIF
12870 IF(KCQ2(JT).NE.0) THEN
12871 K(N,1)=3
12872 IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1)
12873 IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1)
12874 ENDIF
12875C...Then redirect colour flow if mother (anti)triplet.
12876 IF(KCQM(JT).EQ.0) THEN
12877 ELSEIF(KCQM(JT).NE.2) THEN
12878 ISID=4
12879 IF(KCQM(JT).EQ.-1) ISID=5
12880 IDAU=N-1
12881 IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N
12882 K(ID,ISID)=K(ID,ISID)+IDAU
12883 K(IDAU,ISID)=MSTU(5)*ID
12884C...Then redirect colour flow if mother octet.
12885 ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN
12886 IDAU=N-1
12887 IF(KCQ1(JT).EQ.0) IDAU=N
12888 K(ID,4)=K(ID,4)+IDAU
12889 K(ID,5)=K(ID,5)+IDAU
12890 K(IDAU,4)=MSTU(5)*ID
12891 K(IDAU,5)=MSTU(5)*ID
12892 ELSE
12893 ISID=4
12894 IF(KCQ1(JT).EQ.-1) ISID=5
12895 IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0))
12896 K(ID,ISID)=K(ID,ISID)+(N-1)
12897 K(ID,9-ISID)=K(ID,9-ISID)+N
12898 K(N-1,ISID)=MSTU(5)*ID
12899 K(N,9-ISID)=MSTU(5)*ID
12900 ENDIF
12901
12902C...Insert junction
12903 IF(IABS(KCQ1(JT)+KCQ2(JT)-KCQM(JT)).EQ.3) THEN
12904 N=N+1
12905C...~q* mother: type 3 junction. ~q mother: type 4.
12906 ITJUNC(JT)=(7+KCQM(JT))/2
12907C...Specify junction KF and set colour flow from junction
12908 K(N,1)=42
12909 K(N,2)=88
12910 K(N,3)=ID
12911C...Junction type encoded together with mother:
12912 K(N,4)=ID+ITJUNC(JT)*MSTU(5)
12913 K(N,5)=N-1+MSTU(5)*(N-2)
12914C...Zero P and V for junction (V filled later)
12915 DO 290 J=1,5
12916 P(N,J)=0D0
12917 V(N,J)=0D0
12918 290 CONTINUE
12919C...Set colour flow from mother to junction
12920 K(ID,8-ITJUNC(JT))= N + MSTU(5)*(K(ID,8-ITJUNC(JT))/MSTU(5))
12921C...Set colour flow from daughters to junction
12922 DO 300 II=N-2,N-1
12923 K(II,4) = 0
12924 K(II,5) = 0
12925C...(Anti-)colour mother is junction.
12926 K(II,1+ITJUNC(JT)) = MSTU(5)*(N)
12927 300 CONTINUE
12928 ENDIF
12929 ENDIF
12930
12931C...End loop over resonances for daughter flavour and mass selection.
12932 MSTU(10)=MSTU10
12933 310 IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0))
12934 & NINH=NINH+1
12935 IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.MDCY(KCA,1).NE.0.AND.
12936 & KFL1(JT).EQ.0) THEN
12937 WRITE(CODE,'(I9)') K(ID,2)
12938 WRITE(MASS,'(F9.3)') P(ID,5)
12939 CALL PYERRM(3,'(PYRESD:) Failed to decay particle'//
12940 & CODE//' with mass'//MASS)
12941 MINT(51)=1
12942 GOTO 700
12943 ENDIF
12944 320 CONTINUE
12945
12946C...Check for allowed combinations. Skip if no decays.
12947 IF(JTMAX.EQ.1) THEN
12948 IF(KDCY(1).EQ.0) GOTO 690
12949 ELSEIF(JTMAX.EQ.2) THEN
12950 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 690
12951 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 160
12952 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 160
12953 ELSEIF(JTMAX.EQ.3) THEN
12954 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 690
12955 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 160
12956 IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 160
12957 IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 160
12958 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 160
12959 IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 160
12960 IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 160
12961 ENDIF
12962
12963C...Special case: matrix element option for Z0 decay to quarks.
12964 IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND.
12965 &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN
12966
12967C...Check consistency of MSTJ options set.
12968 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
12969 CALL PYERRM(6,
12970 & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
12971 MSTJ(110)=1
12972 ENDIF
12973 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
12974 CALL PYERRM(6,
12975 & '(PYRESD:) MSTJ(109) value requires MSTJ(111) = 0')
12976
12977 MSTJ(111)=0
12978 ENDIF
12979
12980C...Select alpha_strong behaviour.
12981 MST111=MSTU(111)
12982 PAR112=PARU(112)
12983 MSTU(111)=MSTJ(108)
12984 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
12985 & MSTU(111)=1
12986 PARU(112)=PARJ(121)
12987 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
12988
12989C...Find axial fraction in total cross section for scalar gluon model.
12990 PARJ(171)=0D0
12991 IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR.
12992 & (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN
12993 POLL=1D0-PARJ(131)*PARJ(132)
12994 SFF=1D0/(16D0*XW*XW1)
12995 SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+
12996 & (PARJ(123)*PARJ(124))**2)
12997 SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2)
12998 VE=4D0*XW-1D0
12999 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
13000 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*
13001 & (PARJ(132)-PARJ(131)))
13002 KFLC=IABS(KFL1(1))
13003 PMQ=PYMASS(KFLC)
13004 QF=KCHG(KFLC,1)/3D0
13005 VQ=1D0
13006 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,
13007 & 1D0-(2D0*PMQ/P(ID,5))**2))
13008 VF=SIGN(1D0,QF)-4D0*QF*XW
13009 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+
13010 & VF**2*HF1W)+VQ**3*HF1W
13011 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
13012 ENDIF
13013
13014C...Choice of jet configuration.
13015 CALL PYXJET(P(ID,5),NJET,CUT)
13016 KFLC=IABS(KFL1(1))
13017 KFLN=21
13018
13019 IF(NJET.EQ.4) THEN
13020 CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14)
13021 ELSEIF(NJET.EQ.3) THEN
13022 CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3)
13023 ELSE
13024 MSTJ(120)=1
13025 ENDIF
13026
13027C...Fill jet configuration; return if incorrect kinematics.
13028 NC=N-2
13029 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN
13030 CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5))
13031 ELSEIF(NJET.EQ.2) THEN
13032 CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5))
13033 ELSEIF(NJET.EQ.3) THEN
13034 CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3)
13035 ELSEIF(KFLN.EQ.21) THEN
13036 CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
13037 & X12,X14)
13038 ELSE
13039 CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
13040 & X12,X14)
13041 ENDIF
13042 IF(MSTU(24).NE.0) THEN
13043 MINT(51)=1
13044 MSTU(111)=MST111
13045 PARU(112)=PAR112
13046 GOTO 700
13047 ENDIF
13048
13049C...Angular orientation according to matrix element.
13050 IF(MSTJ(106).EQ.1) THEN
13051 CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHIZ,THEZ,PHIZ)
13052 IF(MINT(11).LT.0) THEZ=PARU(1)-THEZ
13053 CTHE(1)=COS(THEZ)
13054 CALL PYROBO(NC+1,N,0D0,CHIZ,0D0,0D0,0D0)
13055 CALL PYROBO(NC+1,N,THEZ,PHIZ,0D0,0D0,0D0)
13056 ENDIF
13057
13058C...Boost partons to Z0 rest frame.
13059 CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4),
13060 & P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
13061
13062C...Mark decayed resonance and add documentation lines,
13063 K(ID,1)=K(ID,1)+10
13064 IDOC=MINT(83)+MINT(4)
13065 DO 340 I=NC+1,N
13066 I1=MINT(83)+MINT(4)+1
13067 K(I,3)=I1
13068 IF(MSTP(128).GE.1) K(I,3)=ID
13069 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
13070 MINT(4)=MINT(4)+1
13071 K(I1,1)=21
13072 K(I1,2)=K(I,2)
13073 K(I1,3)=IREF(IP,4)
13074 DO 330 J=1,5
13075 P(I1,J)=P(I,J)
13076 330 CONTINUE
13077 ENDIF
13078 340 CONTINUE
13079
13080C...Generate parton shower.
13081 IF(MSTJ(101).EQ.5) CALL PYSHOW(N-1,N,P(ID,5))
13082
13083C... End special case for Z0: skip ahead.
13084 MSTU(111)=MST111
13085 PARU(112)=PAR112
13086 GOTO 680
13087 ENDIF
13088
13089C...Order incoming partons and outgoing resonances.
13090 IF(JTMAX.EQ.2.AND.ISUB.NE.0.AND.MSTP(47).GE.1.AND.
13091 &NINH.EQ.0) THEN
13092 ILIN(1)=MINT(84)+1
13093 IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
13094 IF(K(ILIN(1),2).EQ.21.OR.K(ILIN(1),2).EQ.22)
13095 & ILIN(1)=2*MINT(84)+3-ILIN(1)
13096 ILIN(2)=2*MINT(84)+3-ILIN(1)
13097 IMIN=1
13098 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
13099 & .EQ.36) IMIN=3
13100 IMAX=2
13101 IORD=1
13102 IF(K(IREF(IP,1),2).EQ.23) IORD=2
13103 IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
13104 IAKIPD=IABS(K(IREF(IP,IORD),2))
13105 IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD
13106 IF(KDCY(IORD).EQ.0) IORD=3-IORD
13107
13108C...Order decay products of resonances.
13109 DO 350 JT=IORD,3-IORD,3-2*IORD
13110 IF(KDCY(JT).EQ.0) THEN
13111 ILIN(IMAX+1)=NSD(JT)
13112 IMAX=IMAX+1
13113 ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
13114 ILIN(IMAX+1)=N+2*JT-1
13115 ILIN(IMAX+2)=N+2*JT
13116 IMAX=IMAX+2
13117 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
13118 K(N+2*JT,2)=K(NSD(JT)+2,2)
13119 ELSE
13120 ILIN(IMAX+1)=N+2*JT
13121
13122 ILIN(IMAX+2)=N+2*JT-1
13123 IMAX=IMAX+2
13124 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
13125 K(N+2*JT,2)=K(NSD(JT)+2,2)
13126 ENDIF
13127 350 CONTINUE
13128
13129C...Find charge, isospin, left- and righthanded couplings.
13130 DO 370 I=IMIN,IMAX
13131 DO 360 J=1,4
13132 COUP(I,J)=0D0
13133 360 CONTINUE
13134 KFA=IABS(K(ILIN(I),2))
13135 IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 370
13136 COUP(I,1)=KCHG(KFA,1)/3D0
13137 COUP(I,2)=(-1)**MOD(KFA,2)
13138 COUP(I,4)=-2D0*COUP(I,1)*XWV
13139 COUP(I,3)=COUP(I,2)+COUP(I,4)
13140 370 CONTINUE
13141
13142C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
13143 IF(ISUB.EQ.22) THEN
13144 DO 400 I=3,5,2
13145 I1=IORD
13146 IF(I.EQ.5) I1=3-IORD
13147 DO 390 J1=1,2
13148 DO 380 J2=1,2
13149 CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/
13150 & 16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)*
13151 & COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)*
13152 & COUP(I,J2+2)**2
13153 380 CONTINUE
13154 390 CONTINUE
13155 400 CONTINUE
13156 COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
13157 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2))
13158 COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))*
13159 & (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2))
13160
13161 IF(COWT12.LT.PYR(0)*COMX12) GOTO 160
13162 ENDIF
13163 ENDIF
13164
13165C...Select angular orientation type - Z'/W' only.
13166 MZPWP=0
13167 IF(ISUB.EQ.141) THEN
13168 IF(PYR(0).LT.PARU(130)) MZPWP=1
13169 IF(IP.EQ.2) THEN
13170 IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2
13171 IAKIR=IABS(K(IREF(2,2),2))
13172 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
13173 IF(IAKIR.LE.20) MZPWP=2
13174 ENDIF
13175 IF(IP.GE.3) MZPWP=2
13176 ELSEIF(ISUB.EQ.142) THEN
13177 IF(PYR(0).LT.PARU(136)) MZPWP=1
13178 IF(IP.EQ.2) THEN
13179 IAKIR=IABS(K(IREF(2,2),2))
13180 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
13181 IF(IAKIR.LE.20) MZPWP=2
13182 ENDIF
13183 IF(IP.GE.3) MZPWP=2
13184 ENDIF
13185
13186C...Select random angles (begin of weighting procedure).
13187 410 DO 420 JT=1,JTMAX
13188 IF(KDCY(JT).EQ.0) GOTO 420
13189 IF(JTMAX.EQ.1.AND.ISUB.NE.0.AND.IHDEC.EQ.0) THEN
13190 CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0)
13191 IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
13192 PHI(JT)=VINT(24)
13193 ELSE
13194 CTHE(JT)=2D0*PYR(0)-1D0
13195 PHI(JT)=PARU(2)*PYR(0)
13196 ENDIF
13197 420 CONTINUE
13198
13199 IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
13200C...Construct massless four-vectors.
13201 DO 440 I=N+1,N+4
13202 K(I,1)=1
13203 DO 430 J=1,5
13204 P(I,J)=0D0
13205 V(I,J)=0D0
13206 430 CONTINUE
13207 440 CONTINUE
13208 DO 450 JT=1,JTMAX
13209 IF(KDCY(JT).EQ.0) GOTO 450
13210 ID=IREF(IP,JT)
13211 P(N+2*JT-1,3)=0.5D0*P(ID,5)
13212 P(N+2*JT-1,4)=0.5D0*P(ID,5)
13213 P(N+2*JT,3)=-0.5D0*P(ID,5)
13214 P(N+2*JT,4)=0.5D0*P(ID,5)
13215 CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
13216 & P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
13217 450 CONTINUE
13218
13219C...Store incoming and outgoing momenta, with random rotation to
13220C...avoid accidental zeroes in HA expressions.
13221 IF(ISUB.NE.0) THEN
13222 DO 470 I=IMIN,IMAX
13223 K(N+4+I,1)=1
13224 P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+
13225 & P(ILIN(I),3)**2+P(ILIN(I),5)**2)
13226 P(N+4+I,5)=P(ILIN(I),5)
13227 DO 460 J=1,3
13228 P(N+4+I,J)=P(ILIN(I),J)
13229 460 CONTINUE
13230 470 CONTINUE
13231 480 THERR=ACOS(2D0*PYR(0)-1D0)
13232 PHIRR=PARU(2)*PYR(0)
13233 CALL PYROBO(N+4+IMIN,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
13234 DO 500 I=IMIN,IMAX
13235 IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*P(N+4+I,4)**2)
13236 & GOTO 480
13237 DO 490 J=1,4
13238 PK(I,J)=P(N+4+I,J)
13239 490 CONTINUE
13240 500 CONTINUE
13241 ENDIF
13242
13243C...Calculate internal products.
13244 IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR.
13245 & ISUB.EQ.142) THEN
13246 DO 520 I1=IMIN,IMAX-1
13247 DO 510 I2=I1+1,IMAX
13248 HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+
13249 & PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))*
13250 & CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))-
13251 & SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
13252 & (1D-20+PK(I2,1)**2+PK(I2,2)**2)))*
13253 & CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2)))
13254 HC(I1,I2)=CONJG(HA(I1,I2))
13255 IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
13256 IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
13257 HA(I2,I1)=-HA(I1,I2)
13258 HC(I2,I1)=-HC(I1,I2)
13259 510 CONTINUE
13260 520 CONTINUE
13261 ENDIF
13262
13263C...Calculate four-products.
13264 IF(ISUB.NE.0) THEN
13265 DO 540 I=1,2
13266 DO 530 J=1,4
13267 PK(I,J)=-PK(I,J)
13268 530 CONTINUE
13269 540 CONTINUE
13270 DO 560 I1=IMIN,IMAX-1
13271 DO 550 I2=I1+1,IMAX
13272 PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
13273 & PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
13274 PKK(I2,I1)=PKK(I1,I2)
13275 550 CONTINUE
13276 560 CONTINUE
13277 ENDIF
13278 ENDIF
13279
13280 KFAGM=IABS(IREF(IP,7))
13281 IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN
13282C...Isotropic decay selected by user.
13283 WT=1D0
13284 WTMAX=1D0
13285
13286 ELSEIF(JTMAX.EQ.3) THEN
13287C...Isotropic decay when three mother particles.
13288 WT=1D0
13289 WTMAX=1D0
13290
13291 ELSEIF(IT4.GE.1) THEN
13292C... Isotropic decay t -> b + W etc for 4th generation q and l.
13293 WT=1D0
13294 WTMAX=1D0
13295
13296 ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.
13297 & IREF(IP,7).EQ.36) THEN
13298C...Angular weight for h0/A0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
13299C...CP-odd case added by Kari Ertresvag Myklevoll.
13300 IF(IP.EQ.1) WTMAX=SH**2
13301 IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4
13302 KFA=IABS(K(IREF(IP,1),2))
13303 IF(KFA.EQ.23) THEN
13304 KFLF1A=IABS(KFL1(1))
13305 EF1=KCHG(KFLF1A,1)/3D0
13306 AF1=SIGN(1D0,EF1+0.1D0)
13307 VF1=AF1-4D0*EF1*XWV
13308 KFLF2A=IABS(KFL1(2))
13309 EF2=KCHG(KFLF2A,1)/3D0
13310 AF2=SIGN(1D0,EF2+0.1D0)
13311 VF2=AF2-4D0*EF2*XWV
13312 VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)
13313 & *(VF2**2+AF2**2))
13314 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
13315 & THEN
13316C...CP-even decay
13317 WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+
13318 & 8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5)
13319 ELSE
13320C...CP-odd decay
13321 WT=((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
13322 & -2*PKK(3,4)*PKK(5,6)
13323 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
13324 & (PKK(3,4)*PKK(5,6))
13325 & +VA12AS*(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
13326 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))/(1+VA12AS)
13327 ENDIF
13328 ELSEIF(KFA.EQ.24) THEN
13329 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
13330 & THEN
13331C...CP-even decay
13332 WT=16D0*PKK(3,5)*PKK(4,6)
13333 ELSE
13334C...CP-odd decay
13335 WT=0.5D0*((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
13336 & -2*PKK(3,4)*PKK(5,6)
13337 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
13338 & (PKK(3,4)*PKK(5,6))
13339 & +(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
13340 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))
13341 ENDIF
13342 ELSE
13343 WT=WTMAX
13344 ENDIF
13345
13346 ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR.
13347 & KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24)
13348 & THEN
13349C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
13350 I1=IREF(IP,8)
13351 IF(MOD(KFAGM,2).EQ.0) THEN
13352 I2=N+1
13353 I3=N+2
13354 ELSE
13355 I2=N+2
13356 I3=N+1
13357 ENDIF
13358 I4=IREF(IP,2)
13359 WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
13360 & P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)-
13361 & P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3))
13362 WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0
13363
13364 ELSEIF(ISUB.EQ.1) THEN
13365C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
13366 EI=KCHG(IABS(MINT(15)),1)/3D0
13367 AI=SIGN(1D0,EI+0.1D0)
13368 VI=AI-4D0*EI*XWV
13369 EF=KCHG(IABS(KFL1(1)),1)/3D0
13370 AF=SIGN(1D0,EF+0.1D0)
13371
13372 VF=AF-4D0*EF*XWV
13373 RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH)
13374 WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
13375 & (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2)
13376 WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
13377 & (VI**2+AI**2)*VINT(114)*VF**2)
13378 WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+
13379 & 4D0*VI*AI*VINT(114)*VF*AF)
13380 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
13381 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
13382 WTMAX=2D0*(WT1+ABS(WT3))
13383
13384 ELSEIF(ISUB.EQ.2) THEN
13385C...Angular weight for W+/- -> 2 quarks/leptons.
13386 RM3=PMAS(IABS(KFL1(1)),1)**2/SH
13387 RM4=PMAS(IABS(KFL2(1)),1)**2/SH
13388 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
13389 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
13390 WTMAX=4D0
13391
13392 ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
13393C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
13394C...-> gluon/gamma + 2 quarks/leptons.
13395 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13396 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
13397 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
13398 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13399 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
13400 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
13401 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13402 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
13403 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
13404 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13405 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
13406 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
13407 WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+
13408 & (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2)
13409 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
13410 & ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
13411
13412 ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
13413C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
13414C...-> gluon/gamma + 2 quarks/leptons.
13415 WT=PKK(1,3)**2+PKK(2,4)**2
13416 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
13417
13418 ELSEIF(ISUB.EQ.22) THEN
13419C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
13420 S34=P(IREF(IP,IORD),5)**2
13421 S56=P(IREF(IP,3-IORD),5)**2
13422 TI=PKK(1,3)+PKK(1,4)+S34
13423 UI=PKK(1,5)+PKK(1,6)+S56
13424 TIR=REAL(TI)
13425 UIR=REAL(UI)
13426 FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2
13427 FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2
13428 FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2
13429 FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2
13430 FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2
13431 FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2
13432 FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2
13433 FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2
13434
13435 WT=
13436 & CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+
13437 & CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+
13438 & CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+
13439 & CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264
13440 WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
13441 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56*
13442 & ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+
13443 & 1D0/UI**2))
13444
13445 ELSEIF(ISUB.EQ.23) THEN
13446C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
13447 D34=P(IREF(IP,IORD),5)**2
13448 D56=P(IREF(IP,3-IORD),5)**2
13449 DT=PKK(1,3)+PKK(1,4)+D34
13450 DU=PKK(1,5)+PKK(1,6)+D56
13451 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
13452 CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
13453 CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
13454 FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+
13455
13456 & REAL(CBWZ)*FGK(1,2,5,6,3,4))
13457 FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+
13458 & REAL(CBWZ)*FGK(1,2,6,5,3,4))
13459 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
13460 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
13461 & DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
13462
13463 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
13464C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
13465C...(or H0, or A0).
13466 WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
13467 & PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
13468 & COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
13469 WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
13470 & (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
13471
13472 ELSEIF(ISUB.EQ.25) THEN
13473C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
13474 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
13475 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
13476 D34=P(IREF(IP,IORD),5)**2
13477 D56=P(IREF(IP,3-IORD),5)**2
13478 DT=PKK(1,3)+PKK(1,4)+D34
13479 DU=PKK(1,5)+PKK(1,6)+D56
13480 FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2)
13481 CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH
13482 CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT
13483 CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU
13484 CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH
13485 FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)-
13486 & REAL(CBWW)*FGK(1,2,5,6,3,4))
13487 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
13488 IF(MSTP(50).LE.0) THEN
13489 WT=FGK135**2+(CCWW*FGK253)**2
13490 WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-
13491 & CAWW*CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-
13492 & DJGK(DT,DU)))
13493 ELSE
13494 WT=POLL*FGK135**2+POLR*(CCWW*FGK253)**2
13495 WTMAX=4D0*D34*D56*(POLL*(CAWW**2*DIGK(DT,DU)+
13496 & CBWW**2*DIGK(DU,DT)-CAWW*CBWW*DJGK(DT,DU))+
13497 & POLR*CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
13498 ENDIF
13499
13500 ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN
13501C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
13502C...(or H0, or A0).
13503 WT=PKK(1,3)*PKK(2,4)
13504 WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
13505
13506 ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN
13507C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
13508C...-> f + 2 quarks/leptons.
13509 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13510 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
13511 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
13512 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13513 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
13514 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
13515 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13516 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
13517 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
13518 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13519 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
13520 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
13521 IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+
13522 & PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2)
13523 IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+
13524 & PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2)
13525 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
13526 & ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
13527
13528 ELSEIF(ISUB.EQ.31.OR.ISUB.EQ.36) THEN
13529C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions.
13530 IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
13531 IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
13532 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
13533
13534 ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.
13535 & ISUB.EQ.77) THEN
13536C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
13537 WT=16D0*PKK(3,5)*PKK(4,6)
13538 WTMAX=SH**2
13539
13540 ELSEIF(ISUB.EQ.110) THEN
13541C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
13542 WT=1D0
13543 WTMAX=1D0
13544
13545 ELSEIF(ISUB.EQ.141) THEN
13546 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
13547C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
13548C...Couplings of incoming flavour.
13549 KFAI=IABS(MINT(15))
13550 EI=KCHG(KFAI,1)/3D0
13551 AI=SIGN(1D0,EI+0.1D0)
13552 VI=AI-4D0*EI*XWV
13553 KFAIC=1
13554 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
13555 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
13556 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
13557 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
13558 VPI=PARU(119+2*KFAIC)
13559 API=PARU(120+2*KFAIC)
13560 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
13561 VPI=PARJ(178+2*KFAIC)
13562 API=PARJ(179+2*KFAIC)
13563 ELSE
13564 VPI=PARJ(186+2*KFAIC)
13565 API=PARJ(187+2*KFAIC)
13566 ENDIF
13567C...Couplings of final flavour.
13568 KFAF=IABS(KFL1(1))
13569 EF=KCHG(KFAF,1)/3D0
13570 AF=SIGN(1D0,EF+0.1D0)
13571 VF=AF-4D0*EF*XWV
13572 KFAFC=1
13573 IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2
13574 IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3
13575 IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4
13576 IF(KFAF.LE.2.OR.KFAF.EQ.11.OR.KFAF.EQ.12) THEN
13577 VPF=PARU(119+2*KFAFC)
13578 APF=PARU(120+2*KFAFC)
13579 ELSEIF(KFAF.LE.4.OR.KFAF.EQ.13.OR.KFAF.EQ.14) THEN
13580 VPF=PARJ(178+2*KFAFC)
13581 APF=PARJ(179+2*KFAFC)
13582 ELSE
13583 VPF=PARJ(186+2*KFAFC)
13584 APF=PARJ(187+2*KFAFC)
13585 ENDIF
13586C...Asymmetry and weight.
13587 ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+
13588 & 4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)*
13589 & (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/
13590 & (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
13591 & EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
13592 & (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+
13593 & (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2))
13594 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
13595 WTMAX=2D0+ABS(ASYM)
13596 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN
13597C...Angular weight for f + fbar -> Z' -> W+ + W-.
13598 RM1=P(NSD(1)+1,5)**2/SH
13599 RM2=P(NSD(1)+2,5)**2/SH
13600 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
13601 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
13602 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
13603 & (RM2-RM1)**2)
13604 WT=CFLAT+CCOS2*CTHE(1)**2
13605 WTMAX=CFLAT+MAX(0D0,CCOS2)
13606 ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR.
13607 & IABS(KFL1(1)).EQ.37)) THEN
13608C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
13609 WT=1D0-CTHE(1)**2
13610 WTMAX=1D0
13611 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
13612C...Angular weight for f + fbar -> Z' -> Z0 + h0.
13613 RM1=P(NSD(1)+1,5)**2/SH
13614 RM2=P(NSD(1)+2,5)**2/SH
13615 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
13616 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
13617 WTMAX=1D0+FLAM2/(8D0*RM1)
13618 ELSEIF(MZPWP.EQ.0) THEN
13619C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
13620C...(W:s like if intermediate Z).
13621 D34=P(IREF(IP,IORD),5)**2
13622 D56=P(IREF(IP,3-IORD),5)**2
13623 DT=PKK(1,3)+PKK(1,4)+D34
13624 DU=PKK(1,5)+PKK(1,6)+D56
13625 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
13626 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
13627 WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2
13628 WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)*
13629 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
13630 ELSEIF(MZPWP.EQ.1) THEN
13631C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
13632C...(W:s approximately longitudinal, like if intermediate H).
13633 WT=16D0*PKK(3,5)*PKK(4,6)
13634 WTMAX=SH**2
13635 ELSE
13636C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
13637C...H0 + A0 -> 4 quarks/leptons, t + tbar -> b + W+ + bbar + W- .
13638 WT=1D0
13639 WTMAX=1D0
13640 ENDIF
13641
13642 ELSEIF(ISUB.EQ.142) THEN
13643 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
13644C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
13645 KFAI=IABS(MINT(15))
13646 KFAIC=1
13647 IF(KFAI.GT.10) KFAIC=2
13648 VI=PARU(129+2*KFAIC)
13649 AI=PARU(130+2*KFAIC)
13650 KFAF=IABS(KFL1(1))
13651 KFAFC=1
13652 IF(KFAF.GT.10) KFAFC=2
13653 VF=PARU(129+2*KFAFC)
13654 AF=PARU(130+2*KFAFC)
13655 ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2))
13656 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
13657 WTMAX=2D0+ABS(ASYM)
13658 ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN
13659C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
13660 RM1=P(NSD(1)+1,5)**2/SH
13661 RM2=P(NSD(1)+2,5)**2/SH
13662 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
13663 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
13664 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
13665 & (RM2-RM1)**2)
13666 WT=CFLAT+CCOS2*CTHE(1)**2
13667 WTMAX=CFLAT+MAX(0D0,CCOS2)
13668 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
13669C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
13670 RM1=P(NSD(1)+1,5)**2/SH
13671 RM2=P(NSD(1)+2,5)**2/SH
13672 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
13673 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
13674 WTMAX=1D0+FLAM2/(8D0*RM1)
13675 ELSEIF(MZPWP.EQ.0) THEN
13676C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
13677C...(W/Z like if intermediate W).
13678 D34=P(IREF(IP,IORD),5)**2
13679 D56=P(IREF(IP,3-IORD),5)**2
13680 DT=PKK(1,3)+PKK(1,4)+D34
13681 DU=PKK(1,5)+PKK(1,6)+D56
13682 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
13683 FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4))
13684 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
13685 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*
13686 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
13687 ELSEIF(MZPWP.EQ.1) THEN
13688C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
13689C...(W/Z approximately longitudinal, like if intermediate H).
13690 WT=16D0*PKK(3,5)*PKK(4,6)
13691 WTMAX=SH**2
13692 ELSE
13693C...Angular weight for f + fbar -> W' -> W + h0 -> whatever,
13694C...t + bbar -> t + W + bbar.
13695 WT=1D0
13696 WTMAX=1D0
13697 ENDIF
13698
13699 ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164)
13700 & THEN
13701C...Isotropic decay of leptoquarks (assumed spin 0).
13702 WT=1D0
13703 WTMAX=1D0
13704
13705 ELSEIF(ISUB.GE.146.AND.ISUB.LE.148) THEN
13706C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-).
13707 SIDE=1D0
13708 IF(MINT(16).EQ.21.OR.MINT(16).EQ.22) SIDE=-1D0
13709 IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN
13710 WT=1D0+SIDE*CTHE(1)
13711 WTMAX=2D0
13712 ELSEIF(IP.EQ.1) THEN
13713
13714 RM1=P(NSD(1)+1,5)**2/SH
13715 WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
13716 WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
13717 ELSE
13718C...W/Z decay assumed isotropic, since not known.
13719 WT=1D0
13720 WTMAX=1D0
13721 ENDIF
13722
13723 ELSEIF(ISUB.EQ.149) THEN
13724C...Isotropic decay of techni-eta.
13725 WT=1D0
13726 WTMAX=1D0
13727
13728 ELSEIF(ISUB.EQ.191) THEN
13729 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
13730C...Angular weight for f + fbar -> rho_tc0 -> W+ W-,
13731C...W+ pi_tc-, pi_tc+ W- or pi_tc+ pi_tc-.
13732 WT=1D0-CTHE(1)**2
13733 WTMAX=1D0
13734 ELSEIF(IP.EQ.1) THEN
13735C...Angular weight for f + fbar -> rho_tc0 -> f fbar.
13736 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
13737 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
13738 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
13739 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
13740 KFAI=IABS(MINT(15))
13741 EI=KCHG(KFAI,1)/3D0
13742 AI=SIGN(1D0,EI+0.1D0)
13743 VI=AI-4D0*EI*XWV
13744 VALI=0.5D0*(VI+AI)
13745 VARI=0.5D0*(VI-AI)
13746 ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2
13747 ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2
13748 KFAF=IABS(KFL1(1))
13749 EF=KCHG(KFAF,1)/3D0
13750 AF=SIGN(1D0,EF+0.1D0)
13751 VF=AF-4D0*EF*XWV
13752 VALF=0.5D0*(VF+AF)
13753 VARF=0.5D0*(VF-AF)
13754 ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2
13755 ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2
13756 ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF
13757 AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF
13758 WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2
13759 WTMAX=4D0*MAX(ASAME,AFLIP)
13760 ELSE
13761C...Isotropic decay of W/pi_tc produced in rho_tc decay.
13762 WT=1D0
13763 WTMAX=1D0
13764 ENDIF
13765
13766 ELSEIF(ISUB.EQ.192) THEN
13767 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
13768C...Angular weight for f + fbar' -> rho_tc+ -> W+ Z0,
13769C...W+ pi_tc0, pi_tc+ Z0 or pi_tc+ pi_tc0.
13770 WT=1D0-CTHE(1)**2
13771 WTMAX=1D0
13772 ELSEIF(IP.EQ.1) THEN
13773C...Angular weight for f + fbar' -> rho_tc+ -> f fbar'.
13774 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
13775 WT=(1D0+CTHESG)**2
13776 WTMAX=4D0
13777 ELSE
13778C...Isotropic decay of W/Z/pi_tc produced in rho_tc+ decay.
13779 WT=1D0
13780 WTMAX=1D0
13781 ENDIF
13782
13783 ELSEIF(ISUB.EQ.193) THEN
13784 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
13785C...Angular weight for f + fbar -> omega_tc0 ->
13786C...gamma pi_tc0 or Z0 pi_tc0.
13787 WT=1D0+CTHE(1)**2
13788 WTMAX=2D0
13789 ELSEIF(IP.EQ.1) THEN
13790C...Angular weight for f + fbar -> omega_tc0 -> f fbar.
13791 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
13792 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
13793 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
13794 KFAI=IABS(MINT(15))
13795 EI=KCHG(KFAI,1)/3D0
13796 AI=SIGN(1D0,EI+0.1D0)
13797 VI=AI-4D0*EI*XWV
13798 VALI=0.5D0*(VI+AI)
13799 VARI=0.5D0*(VI-AI)
13800 BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2
13801 BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2
13802 KFAF=IABS(KFL1(1))
13803 EF=KCHG(KFAF,1)/3D0
13804 AF=SIGN(1D0,EF+0.1D0)
13805 VF=AF-4D0*EF*XWV
13806 VALF=0.5D0*(VF+AF)
13807 VARF=0.5D0*(VF-AF)
13808 BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2
13809 BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2
13810 BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF
13811 BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF
13812 WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2
13813 WTMAX=4D0*MAX(BSAME,BFLIP)
13814 ELSE
13815C...Isotropic decay of Z/pi_tc produced in omega_tc decay.
13816 WT=1D0
13817 WTMAX=1D0
13818 ENDIF
13819
13820 ELSEIF(ISUB.EQ.353) THEN
13821C...Angular weight for Z_R0 -> 2 quarks/leptons.
13822 EI=KCHG(IABS(MINT(15)),1)/3D0
13823 AI=SIGN(1D0,EI+0.1D0)
13824 VI=AI-4D0*EI*XWV
13825 EF=KCHG(PYCOMP(KFL1(1)),1)/3D0
13826 AF=SIGN(1D0,EF+0.1D0)
13827 VF=AF-4D0*EF*XWV
13828 RMF=MIN(1D0,4D0*PMAS(PYCOMP(KFL1(1)),1)**2/SH)
13829 WT1=(VI**2+AI**2)*(VF**2+(1D0-RMF)*AF**2)
13830 WT2=RMF*(VI**2+AI**2)*VF**2
13831 WT3=SQRT(1D0-RMF)*4D0*VI*AI*VF*AF
13832 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
13833 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
13834 WTMAX=2D0*(WT1+ABS(WT3))
13835
13836 ELSEIF(ISUB.EQ.354) THEN
13837C...Angular weight for W_R+/- -> 2 quarks/leptons.
13838 RM3=PMAS(PYCOMP(KFL1(1)),1)**2/SH
13839 RM4=PMAS(PYCOMP(KFL2(1)),1)**2/SH
13840 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
13841 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
13842 WTMAX=4D0
13843
13844 ELSEIF(ISUB.EQ.391) THEN
13845C...Angular weight for f + fbar -> G* -> f + fbar
13846 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
13847 WT=1D0-3D0*CTHE(1)**2+4D0*CTHE(1)**4
13848 WTMAX=2D0
13849C...Other G* decays not yet implemented angular distributions.
13850 ELSE
13851 WT=1D0
13852 WTMAX=1D0
13853 ENDIF
13854
13855 ELSEIF(ISUB.EQ.392) THEN
13856C...Angular weight for g + g -> G* -> f + fbar
13857 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
13858 WT=1D0-CTHE(1)**4
13859 WTMAX=1D0
13860C...Other G* decays not yet implemented angular distributions.
13861 ELSE
13862 WT=1D0
13863 WTMAX=1D0
13864 ENDIF
13865
13866C...Obtain correct angular distribution by rejection techniques.
13867 ELSE
13868 WT=1D0
13869 WTMAX=1D0
13870 ENDIF
13871 IF(WT.LT.PYR(0)*WTMAX) GOTO 410
13872
13873C...Construct massive four-vectors using angles chosen.
13874 570 DO 670 JT=1,JTMAX
13875 IF(KDCY(JT).EQ.0) GOTO 670
13876 ID=IREF(IP,JT)
13877 DO 580 J=1,5
13878 DPMO(J)=P(ID,J)
13879 580 CONTINUE
13880 DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2)
13881CMRENNA++
13882 IF(KFL3(JT).EQ.0) THEN
13883 CALL PYROBO(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT),
13884 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
13885 N0=NSD(JT)+2
13886 ELSE
13887 CALL PYROBO(NSD(JT)+1,NSD(JT)+3,ACOS(CTHE(JT)),PHI(JT),
13888 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
13889 N0=NSD(JT)+3
13890 ENDIF
13891
13892 DO 590 J=1,4
13893 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
13894 590 CONTINUE
13895C...Fill in position of decay vertex.
13896 DO 610 I=NSD(JT)+1,N0
13897 DO 600 J=1,4
13898 V(I,J)=VDCY(J)
13899 600 CONTINUE
13900 V(I,5)=0D0
13901
13902 610 CONTINUE
13903CMRENNA--
13904
13905C...Mark decayed resonances; trace history.
13906 K(ID,1)=K(ID,1)+10
13907 KFA=IABS(K(ID,2))
13908 KCA=PYCOMP(KFA)
13909 IF(KCQM(JT).NE.0) THEN
13910C...Do not kill colour flow through coloured resonance!
13911 ELSE
13912 K(ID,4)=NSD(JT)+1
13913 K(ID,5)=NSD(JT)+2
13914C...If 3-body or 2-body with junction:
13915 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).NE.0) K(ID,5)=NSD(JT)+3
13916C...If 3-body with junction:
13917 IF(ITJUNC(JT).NE.0.AND.KFL3(JT).NE.0) K(ID,5)=NSD(JT)+4
13918 ENDIF
13919
13920C...Add documentation lines.
13921 ISUBRG=MAX(1,MIN(500,MINT(1)))
13922 IF(IRES.EQ.0.OR.ISET(ISUBRG).EQ.11) THEN
13923 IDOC=MINT(83)+MINT(4)
13924CMRENNA+++
13925 IHI=NSD(JT)+2
13926 IF(KFL3(JT).NE.0) IHI=IHI+1
13927 DO 630 I=NSD(JT)+1,IHI
13928CMRENNA---
13929 I1=MINT(83)+MINT(4)+1
13930 K(I,3)=I1
13931 IF(MSTP(128).GE.1) K(I,3)=ID
13932 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
13933 MINT(4)=MINT(4)+1
13934 K(I1,1)=21
13935 K(I1,2)=K(I,2)
13936 K(I1,3)=IREF(IP,JT+3)
13937 DO 620 J=1,5
13938 P(I1,J)=P(I,J)
13939 620 CONTINUE
13940 ENDIF
13941 630 CONTINUE
13942 ELSE
13943 K(NSD(JT)+1,3)=ID
13944 K(NSD(JT)+2,3)=ID
13945C...If 3-body or 2-body with junction:
13946 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).GT.0) K(NSD(JT)+3,3)=ID
13947C...If 3-body with junction:
13948 IF(KFL3(JT).NE.0.AND.ITJUNC(JT).GT.0) K(NSD(JT)+4,3)=ID
13949 ENDIF
13950
13951C...Do showering of two or three objects.
13952 NSHBEF=N
13953 IF(MSTP(71).GE.1) THEN
13954 IF(KFL3(JT).EQ.0) THEN
13955 CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
13956 ELSE
13957 CALL PYSHOW(NSD(JT)+1,-3,P(ID,5))
13958 ENDIF
13959 ENDIF
13960 NSHAFT=N
13961 IF(JT.EQ.1) NAFT1=N
13962
13963C...Check if decay products moved by shower.
13964 NSD1=NSD(JT)+1
13965 NSD2=NSD(JT)+2
13966 NSD3=NSD(JT)+3
13967 IF(NSHAFT.GT.NSHBEF) THEN
13968 IF(K(NSD1,1).GT.10) THEN
13969 DO 640 I=NSHBEF+1,NSHAFT
13970 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
13971 640 CONTINUE
13972 ENDIF
13973 IF(K(NSD2,1).GT.10) THEN
13974 DO 650 I=NSHBEF+1,NSHAFT
13975 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
13976 & I.NE.NSD1) NSD2=I
13977 650 CONTINUE
13978 ENDIF
13979 IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
13980 DO 660 I=NSHBEF+1,NSHAFT
13981 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND.
13982 & I.NE.NSD1.AND.I.NE.NSD2) NSD3=I
13983 660 CONTINUE
13984 ENDIF
13985 ENDIF
13986
13987C...Store decay products for further treatment.
13988 NP=NP+1
13989 IREF(NP,1)=NSD1
13990 IREF(NP,2)=NSD2
13991 IREF(NP,3)=0
13992 IF(KFL3(JT).NE.0) IREF(NP,3)=NSD3
13993 IREF(NP,4)=IDOC+1
13994 IREF(NP,5)=IDOC+2
13995 IREF(NP,6)=0
13996 IF(KFL3(JT).NE.0) IREF(NP,6)=IDOC+3
13997 IREF(NP,7)=K(IREF(IP,JT),2)
13998 IREF(NP,8)=IREF(IP,JT)
13999 670 CONTINUE
14000
14001C...Fill information for 2 -> 1 -> 2.
14002 680 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN
14003 MINT(7)=MINT(83)+6+2*ISET(ISUB)
14004 MINT(8)=MINT(83)+7+2*ISET(ISUB)
14005 MINT(25)=KFL1(1)
14006 MINT(26)=KFL2(1)
14007 VINT(23)=CTHE(1)
14008 RM3=P(N-1,5)**2/SH
14009 RM4=P(N,5)**2/SH
14010 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
14011 VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1))
14012 VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1))
14013 VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2)
14014 VINT(47)=SQRT(VINT(48))
14015 ENDIF
14016
14017C...Possibility of colour rearrangement in W+W- events.
14018 IF((ISUB.EQ.25.OR.ISUB.EQ.22).AND.MSTP(115).GE.1) THEN
14019 IAKF1=IABS(KFL1(1))
14020 IAKF2=IABS(KFL1(2))
14021 IAKF3=IABS(KFL2(1))
14022 IAKF4=IABS(KFL2(2))
14023 IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
14024 & MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
14025 & PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
14026 ENDIF
14027
14028C...Loop back if needed.
14029 690 IF(IP.LT.NP) GOTO 150
14030
14031C...Boost back to standard frame.
14032 700 IF(IBST.EQ.1) CALL PYROBO(MINT(83)+7,N,THEIN,PHIIN,BEXIN,BEYIN,
14033 &BEZIN)
14034
14035 RETURN
14036 END
14037
14038C*********************************************************************
14039
14040C...PYMULT
14041C...Initializes treatment of multiple interactions, selects kinematics
14042C...of hardest interaction if low-pT physics included in run, and
14043C...generates all non-hardest interactions.
14044
14045 SUBROUTINE PYMULT(MMUL)
14046
14047C...Double precision and integer declarations.
14048 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14049 IMPLICIT INTEGER(I-N)
14050 INTEGER PYK,PYCHGE,PYCOMP
14051C...Commonblocks.
14052 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14053 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14054 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14055 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
14056 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14057 COMMON/PYINT1/MINT(400),VINT(400)
14058 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
14059 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
14060 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
14061 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
14062 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
14063 &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
14064C...Local arrays and saved variables.
14065 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
14066 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM
14067
14068C...Initialization of multiple interaction treatment.
14069 IF(MMUL.EQ.1) THEN
14070 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
14071 ISUB=96
14072 MINT(1)=96
14073 VINT(63)=0D0
14074 VINT(64)=0D0
14075 VINT(143)=1D0
14076 VINT(144)=1D0
14077
14078C...Loop over phase space points: xT2 choice in 20 bins.
14079 100 SIGSUM=0D0
14080 DO 120 IXT2=1,20
14081 NMUL(IXT2)=MSTP(83)
14082 SIGM(IXT2)=0D0
14083 DO 110 ITRY=1,MSTP(83)
14084 RSCA=0.05D0*((21-IXT2)-PYR(0))
14085 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
14086 XT2=MAX(0.01D0*VINT(149),XT2)
14087 VINT(25)=XT2
14088
14089C...Choose tau and y*. Calculate cos(theta-hat).
14090 IF(PYR(0).LE.COEF(ISUB,1)) THEN
14091 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
14092 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
14093 ELSE
14094 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
14095 ENDIF
14096 VINT(21)=TAU
14097 CALL PYKLIM(2)
14098 RYST=PYR(0)
14099 MYST=1
14100 IF(RYST.GT.COEF(ISUB,8)) MYST=2
14101 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
14102 CALL PYKMAP(2,MYST,PYR(0))
14103 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
14104
14105C...Calculate differential cross-section.
14106 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
14107 CALL PYSIGH(NCHN,SIGS)
14108 SIGM(IXT2)=SIGM(IXT2)+SIGS
14109 110 CONTINUE
14110 SIGSUM=SIGSUM+SIGM(IXT2)
14111 120 CONTINUE
14112 SIGSUM=SIGSUM/(20D0*MSTP(83))
14113
14114C...Reject result if sigma(parton-parton) is smaller than hadronic one.
14115 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
14116 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
14117 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
14118 PARP(82)=0.9D0*PARP(82)
14119 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
14120 & VINT(2)
14121 GOTO 100
14122 ENDIF
14123 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
14124 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
14125
14126C...Start iteration to find k factor.
14127 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
14128 SO=0.5D0
14129 XI=0D0
14130 YI=0D0
14131 XF=0D0
14132 YF=0D0
14133 XK=0.5D0
14134 IIT=0
14135 130 IF(IIT.EQ.0) THEN
14136 XK=2D0*XK
14137 ELSEIF(IIT.EQ.1) THEN
14138 XK=0.5D0*XK
14139 ELSE
14140 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
14141 ENDIF
14142
14143C...Evaluate overlap integrals.
14144 IF(MSTP(82).EQ.2) THEN
14145 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
14146 SOP=SP/PARU(1)
14147 ELSE
14148 IF(MSTP(82).EQ.3) DELTAB=0.02D0
14149 IF(MSTP(82).EQ.4) DELTAB=MIN(0.01D0,0.05D0*PARP(84))
14150 SP=0D0
14151 SOP=0D0
14152 B=-0.5D0*DELTAB
14153 140 B=B+DELTAB
14154 IF(MSTP(82).EQ.3) THEN
14155 OV=EXP(-B**2)/PARU(2)
14156 ELSE
14157 CQ2=PARP(84)**2
14158 OV=((1D0-PARP(83))**2*EXP(-MIN(50D0,B**2))+
14159 & 2D0*PARP(83)*(1D0-PARP(83))*2D0/(1D0+CQ2)*
14160 & EXP(-MIN(50D0,B**2*2D0/(1D0+CQ2)))+
14161 & PARP(83)**2/CQ2*EXP(-MIN(50D0,B**2/CQ2)))/PARU(2)
14162 ENDIF
14163 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
14164 SP=SP+PARU(2)*B*DELTAB*PACC
14165 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
14166 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
14167 ENDIF
14168 YK=PARU(1)*XK*SO/SP
14169
14170C...Continue iteration until convergence.
14171 IF(YK.LT.YKE) THEN
14172 XI=XK
14173 YI=YK
14174 IF(IIT.EQ.1) IIT=2
14175 ELSE
14176 XF=XK
14177 YF=YK
14178 IF(IIT.EQ.0) IIT=1
14179 ENDIF
14180 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
14181
14182C...Store some results for subsequent use.
14183 VINT(145)=SIGSUM
14184 VINT(146)=SOP/SO
14185 VINT(147)=SOP/SP
14186
14187C...Initialize iteration in xT2 for hardest interaction.
14188 ELSEIF(MMUL.EQ.2) THEN
14189 IF(MSTP(82).LE.0) THEN
14190 ELSEIF(MSTP(82).EQ.1) THEN
14191 XT2=1D0
14192 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
14193 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
14194 & VINT(317)/(VINT(318)*VINT(320))
14195 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
14196 ELSEIF(MSTP(82).EQ.2) THEN
14197 XT2=1D0
14198 XT2FAC=VINT(146)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
14199 & VINT(149)*(1D0+VINT(149))
14200 ELSE
14201 XC2=4D0*CKIN(3)**2/VINT(2)
14202 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
14203 ENDIF
14204
14205 ELSEIF(MMUL.EQ.3) THEN
14206C...Low-pT or multiple interactions (first semihard interaction):
14207C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
14208C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
14209 ISUB=MINT(1)
14210 IF(MSTP(82).LE.0) THEN
14211 XT2=0D0
14212 ELSEIF(MSTP(82).EQ.1) THEN
14213 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
14214 ELSEIF(MSTP(82).EQ.2) THEN
14215 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
14216 & VINT(149)))).GT.PYR(0)) XT2=1D0
14217 IF(XT2.GE.1D0) THEN
14218 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
14219 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
14220 & VINT(149)
14221 ELSE
14222 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
14223 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
14224 & VINT(149)
14225 ENDIF
14226 XT2=MAX(0.01D0*VINT(149),XT2)
14227 ELSE
14228 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
14229 & PYR(0)*(1D0-XC2))-VINT(149)
14230 XT2=MAX(0.01D0*VINT(149),XT2)
14231 ENDIF
14232 VINT(25)=XT2
14233
14234C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
14235 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
14236 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
14237 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
14238 ISUB=95
14239 MINT(1)=ISUB
14240 VINT(21)=0.01D0*VINT(149)
14241 VINT(22)=0D0
14242 VINT(23)=0D0
14243 VINT(25)=0.01D0*VINT(149)
14244
14245 ELSE
14246C...Multiple interactions (first semihard interaction).
14247C...Choose tau and y*. Calculate cos(theta-hat).
14248 IF(PYR(0).LE.COEF(ISUB,1)) THEN
14249 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
14250 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
14251 ELSE
14252 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
14253 ENDIF
14254 VINT(21)=TAU
14255 CALL PYKLIM(2)
14256 RYST=PYR(0)
14257 MYST=1
14258 IF(RYST.GT.COEF(ISUB,8)) MYST=2
14259 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
14260 CALL PYKMAP(2,MYST,PYR(0))
14261 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
14262 ENDIF
14263 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
14264
14265C...Store results of cross-section calculation.
14266 ELSEIF(MMUL.EQ.4) THEN
14267 ISUB=MINT(1)
14268 XTS=VINT(25)
14269 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
14270 IF(ISET(ISUB).EQ.2)
14271 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
14272 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
14273 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
14274 & (XTS+VINT(149))))
14275 IRBIN=INT(1D0+20D0*RBIN)
14276 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
14277 NMUL(IRBIN)=NMUL(IRBIN)+1
14278 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
14279 ENDIF
14280
14281C...Choose impact parameter.
14282 ELSEIF(MMUL.EQ.5) THEN
14283 ISUB=MINT(1)
14284 150 IF(MSTP(82).EQ.3) THEN
14285 VINT(148)=PYR(0)/(PARU(2)*VINT(147))
14286 ELSE
14287 RTYPE=PYR(0)
14288 CQ2=PARP(84)**2
14289 IF(RTYPE.LT.(1D0-PARP(83))**2) THEN
14290 B2=-LOG(PYR(0))
14291 ELSEIF(RTYPE.LT.1D0-PARP(83)**2) THEN
14292 B2=-0.5D0*(1D0+CQ2)*LOG(PYR(0))
14293 ELSE
14294 B2=-CQ2*LOG(PYR(0))
14295 ENDIF
14296 VINT(148)=((1D0-PARP(83))**2*EXP(-MIN(50D0,B2))+2D0*PARP(83)*
14297 & (1D0-PARP(83))*2D0/(1D0+CQ2)*EXP(-MIN(50D0,B2*2D0/(1D0+CQ2)))+
14298 & PARP(83)**2/CQ2*EXP(-MIN(50D0,B2/CQ2)))/(PARU(2)*VINT(147))
14299 ENDIF
14300
14301C...Multiple interactions (variable impact parameter) : reject with
14302C...probability exp(-overlap*cross-section above pT/normalization).
14303 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
14304 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
14305 DO 160 IBIN=IRBIN+1,20
14306 RNCOR=RNCOR+NMUL(IBIN)
14307 SIGCOR=SIGCOR+SIGM(IBIN)
14308 160 CONTINUE
14309 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
14310 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
14311 VINT(150)=EXP(-MIN(50D0,VINT(146)*VINT(148)*
14312 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
14313 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
14314 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
14315 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
14316 IF(VINT(150).LT.PYR(0)) GOTO 150
14317 VINT(150)=1D0
14318 ENDIF
14319
14320C...Generate additional multiple semihard interactions.
14321 ELSEIF(MMUL.EQ.6) THEN
14322 ISUBSV=MINT(1)
14323 DO 170 J=11,80
14324 VINTSV(J)=VINT(J)
14325 170 CONTINUE
14326 ISUB=96
14327 MINT(1)=96
14328 VINT(151)=0D0
14329 VINT(152)=0D0
14330
14331C...Reconstruct strings in hard scattering.
14332 NMAX=MINT(84)+4
14333 IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2
14334 IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3)
14335 NSTR=0
14336 DO 190 I=MINT(84)+1,NMAX
14337 KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
14338 IF(KCS.EQ.0) GOTO 190
14339 DO 180 J=1,4
14340 IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 180
14341 IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 180
14342 IF(J.LE.2) THEN
14343 IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
14344 ELSE
14345 IST=MOD(K(I,J+1),MSTU(5))
14346 ENDIF
14347 IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 180
14348 IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 180
14349 NSTR=NSTR+1
14350 IF(J.EQ.1.OR.J.EQ.4) THEN
14351 KSTR(NSTR,1)=I
14352 KSTR(NSTR,2)=IST
14353 ELSE
14354 KSTR(NSTR,1)=IST
14355 KSTR(NSTR,2)=I
14356 ENDIF
14357 180 CONTINUE
14358 190 CONTINUE
14359
14360C...Set up starting values for iteration in xT2.
14361 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
14362 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
14363 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
14364 & ISUBSV.NE.96)) THEN
14365 XT2=(1D0-VINT(141))*(1D0-VINT(142))
14366 ELSE
14367 XT2=VINT(25)
14368 IF(ISET(ISUBSV).EQ.1) XT2=VINT(21)
14369 IF(ISET(ISUBSV).EQ.2)
14370 & XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
14371 IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26)
14372 ENDIF
14373 IF(MSTP(82).LE.1) THEN
14374 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
14375 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
14376 & VINT(317)/(VINT(318)*VINT(320))
14377 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
14378 ELSE
14379 XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/
14380 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
14381 ENDIF
14382 VINT(63)=0D0
14383 VINT(64)=0D0
14384 VINT(143)=1D0-VINT(141)
14385 VINT(144)=1D0-VINT(142)
14386
14387C...Iterate downwards in xT2.
14388 200 IF(MSTP(82).LE.1) THEN
14389 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
14390 IF(XT2.LT.VINT(149)) GOTO 250
14391 ELSE
14392 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 250
14393 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
14394 & LOG(PYR(0)))-VINT(149)
14395 IF(XT2.LE.0D0) GOTO 250
14396 XT2=MAX(0.01D0*VINT(149),XT2)
14397 ENDIF
14398 VINT(25)=XT2
14399
14400C...Choose tau and y*. Calculate cos(theta-hat).
14401 IF(PYR(0).LE.COEF(ISUB,1)) THEN
14402 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
14403 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
14404 ELSE
14405 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
14406 ENDIF
14407 VINT(21)=TAU
14408 CALL PYKLIM(2)
14409 RYST=PYR(0)
14410 MYST=1
14411 IF(RYST.GT.COEF(ISUB,8)) MYST=2
14412 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
14413 CALL PYKMAP(2,MYST,PYR(0))
14414 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
14415
14416C...Check that x not used up. Accept or reject kinematical variables.
14417 X1M=SQRT(TAU)*EXP(VINT(22))
14418 X2M=SQRT(TAU)*EXP(-VINT(22))
14419 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 200
14420 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
14421 CALL PYSIGH(NCHN,SIGS)
14422 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
14423 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 200
14424
14425C...Reset K, P and V vectors. Select some variables.
14426 DO 220 I=N+1,N+2
14427 DO 210 J=1,5
14428 K(I,J)=0
14429 P(I,J)=0D0
14430 V(I,J)=0D0
14431 210 CONTINUE
14432 220 CONTINUE
14433 RFLAV=PYR(0)
14434 PT=0.5D0*VINT(1)*SQRT(XT2)
14435 PHI=PARU(2)*PYR(0)
14436 CTH=VINT(23)
14437
14438C...Add first parton to event record.
14439 K(N+1,1)=3
14440 K(N+1,2)=21
14441 IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
14442 & 1+INT((2D0+PARJ(2))*PYR(0))
14443 P(N+1,1)=PT*COS(PHI)
14444 P(N+1,2)=PT*SIN(PHI)
14445 P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH))
14446 P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH))
14447 P(N+1,5)=0D0
14448
14449C...Add second parton to event record.
14450 K(N+2,1)=3
14451 K(N+2,2)=21
14452 IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
14453 P(N+2,1)=-P(N+1,1)
14454 P(N+2,2)=-P(N+1,2)
14455 P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH))
14456 P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH))
14457 P(N+2,5)=0D0
14458
14459 IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
14460C....Choose relevant string pieces to place gluons on.
14461 DO 240 I=N+1,N+2
14462 DMIN=1D8
14463 DO 230 ISTR=1,NSTR
14464 I1=KSTR(ISTR,1)
14465 I2=KSTR(ISTR,2)
14466 DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
14467 & P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
14468 & P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
14469 & P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
14470 IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
14471 DMIN=DIST
14472 IST1=I1
14473 IST2=I2
14474 ISTM=ISTR
14475 ENDIF
14476 230 CONTINUE
14477
14478C....Colour flow adjustments, new string pieces.
14479 IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
14480 & MOD(K(IST1,4),MSTU(5))
14481 IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
14482 & MSTU(5)*(K(IST1,5)/MSTU(5))+I
14483 K(I,5)=MSTU(5)*IST1
14484 K(I,4)=MSTU(5)*IST2
14485 IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
14486 & MOD(K(IST2,5),MSTU(5))
14487 IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
14488 & MSTU(5)*(K(IST2,4)/MSTU(5))+I
14489 KSTR(ISTM,2)=I
14490 KSTR(NSTR+1,1)=I
14491 KSTR(NSTR+1,2)=IST2
14492 NSTR=NSTR+1
14493 240 CONTINUE
14494
14495C...String drawing and colour flow for gluon loop.
14496 ELSEIF(K(N+1,2).EQ.21) THEN
14497 K(N+1,4)=MSTU(5)*(N+2)
14498 K(N+1,5)=MSTU(5)*(N+2)
14499 K(N+2,4)=MSTU(5)*(N+1)
14500 K(N+2,5)=MSTU(5)*(N+1)
14501 KSTR(NSTR+1,1)=N+1
14502 KSTR(NSTR+1,2)=N+2
14503 KSTR(NSTR+2,1)=N+2
14504 KSTR(NSTR+2,2)=N+1
14505 NSTR=NSTR+2
14506
14507C...String drawing and colour flow for qqbar pair.
14508 ELSE
14509 K(N+1,4)=MSTU(5)*(N+2)
14510 K(N+2,5)=MSTU(5)*(N+1)
14511 KSTR(NSTR+1,1)=N+1
14512 KSTR(NSTR+1,2)=N+2
14513 NSTR=NSTR+1
14514 ENDIF
14515
14516C...Update remaining energy; iterate.
14517 N=N+2
14518 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
14519 CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
14520 IF(MSTU(21).GE.1) RETURN
14521 ENDIF
14522 MINT(31)=MINT(31)+1
14523 VINT(151)=VINT(151)+VINT(41)
14524 VINT(152)=VINT(152)+VINT(42)
14525 VINT(143)=VINT(143)-VINT(41)
14526 VINT(144)=VINT(144)-VINT(42)
14527 IF(MINT(31).LT.240) GOTO 200
14528 250 CONTINUE
14529 MINT(1)=ISUBSV
14530 DO 260 J=11,80
14531 VINT(J)=VINTSV(J)
14532 260 CONTINUE
14533 ENDIF
14534
14535C...Format statements for printout.
14536 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
14537 &'actions for MSTP(82) =',I2,' ******')
14538 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
14539 &D9.2,' mb: rejected')
14540 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
14541 &D9.2,' mb: accepted')
14542
14543 RETURN
14544 END
14545
14546C*********************************************************************
14547
14548C...PYREMN
14549C...Adds on target remnants (one or two from each side) and
14550C...includes primordial kT for hadron beams.
14551
14552 SUBROUTINE PYREMN(IPU1,IPU2)
14553
14554C...Double precision and integer declarations.
14555 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14556 IMPLICIT INTEGER(I-N)
14557 INTEGER PYK,PYCHGE,PYCOMP
14558C...Commonblocks.
14559 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14560 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14561 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14562 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14563 COMMON/PYINT1/MINT(400),VINT(400)
14564 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
14565C...Local arrays.
14566 DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
14567 &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
14568
14569C...Find event type and remaining energy.
14570 ISUB=MINT(1)
14571 NS=N
14572 IF(MINT(50).EQ.0.OR.MSTP(81).LE.0) THEN
14573 VINT(143)=1D0-VINT(141)
14574 VINT(144)=1D0-VINT(142)
14575 ENDIF
14576
14577C...Define initial partons.
14578 NTRY=0
14579 100 NTRY=NTRY+1
14580 DO 130 JT=1,2
14581 I=MINT(83)+JT+2
14582 IF(JT.EQ.1) IPU=IPU1
14583 IF(JT.EQ.2) IPU=IPU2
14584 K(I,1)=21
14585 K(I,2)=K(IPU,2)
14586 K(I,3)=I-2
14587 PMS(JT)=0D0
14588 VINT(156+JT)=0D0
14589 VINT(158+JT)=0D0
14590 IF(MINT(47).EQ.1) THEN
14591 DO 110 J=1,5
14592 P(I,J)=P(I-2,J)
14593 110 CONTINUE
14594 ELSEIF(ISUB.EQ.95) THEN
14595 K(I,2)=21
14596 ELSE
14597 P(I,5)=P(IPU,5)
14598
14599C...No primordial kT, or chosen according to truncated Gaussian or
14600C...exponential, or (for photon) predetermined or power law.
14601 120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
14602 IF(MSTP(91).LE.0) THEN
14603 PT=0D0
14604 ELSEIF(MSTP(91).EQ.1) THEN
14605 PT=PARP(91)*SQRT(-LOG(PYR(0)))
14606 ELSE
14607 RPT1=PYR(0)
14608 RPT2=PYR(0)
14609 PT=-PARP(92)*LOG(RPT1*RPT2)
14610 ENDIF
14611 IF(PT.GT.PARP(93)) GOTO 120
14612 ELSEIF(MINT(106+JT).EQ.3) THEN
14613 PTA=SQRT(VINT(282+JT))
14614 PTB=0D0
14615 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
14616 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
14617 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
14618 RPT1=PYR(0)
14619 RPT2=PYR(0)
14620 PTB=-PARP(99)*LOG(RPT1*RPT2)
14621 ENDIF
14622 IF(PTB.GT.PARP(100)) GOTO 120
14623 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
14624 PT=PT*0.8D0**MINT(57)
14625 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
14626 ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN
14627 IF(MSTP(93).LE.0) THEN
14628 PT=0D0
14629 ELSEIF(MSTP(93).EQ.1) THEN
14630 PT=PARP(99)*SQRT(-LOG(PYR(0)))
14631 ELSEIF(MSTP(93).EQ.2) THEN
14632 RPT1=PYR(0)
14633 RPT2=PYR(0)
14634 PT=-PARP(99)*LOG(RPT1*RPT2)
14635 ELSEIF(MSTP(93).EQ.3) THEN
14636 HA=PARP(99)**2
14637 HB=PARP(100)**2
14638 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
14639 ELSE
14640 HA=PARP(99)**2
14641 HB=PARP(100)**2
14642 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
14643 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
14644 ENDIF
14645 IF(PT.GT.PARP(100)) GOTO 120
14646 ELSE
14647 PT=0D0
14648 ENDIF
14649 VINT(156+JT)=PT
14650 PHI=PARU(2)*PYR(0)
14651 P(I,1)=PT*COS(PHI)
14652 P(I,2)=PT*SIN(PHI)
14653 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
14654 ENDIF
14655 130 CONTINUE
14656 IF(MINT(47).EQ.1) RETURN
14657
14658C...Kinematics construction for initial partons.
14659 I1=MINT(83)+3
14660 I2=MINT(83)+4
14661 IF(ISUB.EQ.95) THEN
14662 SHS=0D0
14663 SHR=0D0
14664 ELSE
14665 SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+
14666 & (P(I1,2)+P(I2,2))**2
14667 SHR=SQRT(MAX(0D0,SHS))
14668 IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100
14669 P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR)
14670 P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1)))
14671 P(I2,4)=SHR-P(I1,4)
14672 P(I2,3)=-P(I1,3)
14673
14674C...Transform partons to overall CM-frame.
14675 ROBO(3)=(P(I1,1)+P(I2,1))/SHR
14676 ROBO(4)=(P(I1,2)+P(I2,2))/SHR
14677 CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0)
14678 ROBO(2)=PYANGL(P(I1,1),P(I1,2))
14679 CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0)
14680 ROBO(1)=PYANGL(P(I1,3),P(I1,1))
14681 CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0)
14682 CALL PYROBO(I2+1,MINT(52),0D0,-ROBO(2),0D0,0D0,0D0)
14683 CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0)
14684 ROBO(5)=(VINT(141)-VINT(142))/(VINT(141)+VINT(142))
14685 CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5))
14686 ENDIF
14687
14688C...Optionally fix up x and Q2 definitions for leptoproduction.
14689 IDISXQ=0
14690 IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND.
14691 &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1
14692 IF(IDISXQ.EQ.1) THEN
14693
14694C...Find where incoming and outgoing leptons/partons are sitting.
14695 LESD=1
14696 IF(MINT(42).EQ.1) LESD=2
14697 LPIN=MINT(83)+3-LESD
14698 LEIN=MINT(84)+LESD
14699 LQIN=MINT(84)+3-LESD
14700 LEOUT=MINT(84)+2+LESD
14701 LQOUT=MINT(84)+5-LESD
14702 IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3)
14703 IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3)
14704 LSCMS=0
14705 DO 140 I=MINT(84)+5,N
14706 IF(K(I,2).EQ.94) THEN
14707 LSCMS=I
14708 LEOUT=I+LESD
14709 LQOUT=I+3-LESD
14710 ENDIF
14711 140 CONTINUE
14712 LQBG=IPU1
14713 IF(LESD.EQ.1) LQBG=IPU2
14714
14715C...Calculate actual and wanted momentum transfer.
14716 XNOM=VINT(43-LESD)
14717 Q2NOM=-VINT(45)
14718 HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)-
14719 & P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))*
14720 & (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4))
14721 HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK)))
14722 FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2))
14723 P(N+1,1)=FAC*P(LEOUT,1)
14724 P(N+1,2)=FAC*P(LEOUT,2)
14725 P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)-
14726 & Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1)
14727 P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+
14728 & P(N+1,3)**2)
14729 DO 150 J=1,4
14730 QOLD(J)=P(LEIN,J)-P(LEOUT,J)
14731 QNEW(J)=P(LEIN,J)-P(N+1,J)
14732 150 CONTINUE
14733
14734C...Boost outgoing electron and daughters.
14735 IF(LSCMS.EQ.0) THEN
14736 DO 160 J=1,4
14737 P(LEOUT,J)=P(N+1,J)
14738 160 CONTINUE
14739 ELSE
14740 DO 170 J=1,3
14741 P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4))
14742 170 CONTINUE
14743 PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2)
14744 DO 180 J=1,3
14745 DBE(J)=PINV*P(N+2,J)
14746 180 CONTINUE
14747 DO 200 I=LSCMS+1,N
14748 IORIG=I
14749 190 IORIG=K(IORIG,3)
14750 IF(IORIG.GT.LEOUT) GOTO 190
14751 IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT)
14752 & CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3))
14753 200 CONTINUE
14754 ENDIF
14755
14756C...Copy shower initiator and all outgoing partons.
14757 NCOP=N+1
14758 K(NCOP,3)=LQBG
14759 DO 210 J=1,5
14760 P(NCOP,J)=P(LQBG,J)
14761 210 CONTINUE
14762 DO 240 I=MINT(84)+1,N
14763 ICOP=0
14764 IF(K(I,1).GT.10) GOTO 240
14765 IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN
14766 ICOP=I
14767 ELSE
14768 IORIG=I
14769 220 IORIG=K(IORIG,3)
14770 IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN
14771 ICOP=IORIG
14772 ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN
14773 GOTO 220
14774 ENDIF
14775 ENDIF
14776 IF(ICOP.NE.0) THEN
14777 NCOP=NCOP+1
14778 K(NCOP,3)=I
14779 DO 230 J=1,5
14780 P(NCOP,J)=P(I,J)
14781 230 CONTINUE
14782 ENDIF
14783 240 CONTINUE
14784
14785C...Calculate relative rescaling factors.
14786 SLC=3-2*LESD
14787 PLCSUM=0D0
14788 DO 250 I=N+2,NCOP
14789 PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3))
14790 250 CONTINUE
14791 DO 260 I=N+2,NCOP
14792 V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM
14793 260 CONTINUE
14794
14795C...Transfer extra three-momentum of current.
14796 DO 280 I=N+2,NCOP
14797 DO 270 J=1,3
14798 P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J))
14799 270 CONTINUE
14800 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
14801 280 CONTINUE
14802
14803C...Iterate change of initiator momentum to get energy right.
14804 ITER=0
14805 290 ITER=ITER+1
14806 PEEX=-P(N+1,4)-QNEW(4)
14807 PEMV=-P(N+1,3)/P(N+1,4)
14808 DO 300 I=N+2,NCOP
14809 PEEX=PEEX+P(I,4)
14810 PEMV=PEMV+V(I,1)*P(I,3)/P(I,4)
14811 300 CONTINUE
14812 IF(ABS(PEMV).LT.1D-10) THEN
14813 MINT(51)=1
14814 MINT(57)=MINT(57)+1
14815 RETURN
14816 ENDIF
14817 PZCH=-PEEX/PEMV
14818 P(N+1,3)=P(N+1,3)+PZCH
14819 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)
14820 DO 310 I=N+2,NCOP
14821 P(I,3)=P(I,3)+V(I,1)*PZCH
14822 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
14823 310 CONTINUE
14824 IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290
14825
14826C...Modify momenta in event record.
14827 HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/
14828 & ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2)
14829 IF(ABS(HBE).GE.1D0) THEN
14830 MINT(51)=1
14831 MINT(57)=MINT(57)+1
14832 RETURN
14833 ENDIF
14834 I=MINT(83)+5-LESD
14835 CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE)
14836 DO 330 I=N+1,NCOP
14837 ICOP=K(I,3)
14838 DO 320 J=1,4
14839 P(ICOP,J)=P(I,J)
14840 320 CONTINUE
14841 330 CONTINUE
14842 ENDIF
14843
14844C...Check minimum invariant mass of remnant system(s).
14845 PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152))
14846 PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152))
14847 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
14848 PMIN(0)=SQRT(PMS(0))
14849 DO 340 JT=1,2
14850 PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT)
14851 PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1)
14852 PMIN(JT)=0D0
14853 IF(MINT(44+JT).EQ.1) GOTO 340
14854 MINT(105)=MINT(102+JT)
14855 MINT(109)=MINT(106+JT)
14856 CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
14857 IF(MINT(51).NE.0) THEN
14858 MINT(57)=MINT(57)+1
14859 RETURN
14860 ENDIF
14861 IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT))
14862 IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT))
14863 IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111)
14864 PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+
14865 & P(MINT(83)+JT+2,2)**2)
14866 340 CONTINUE
14867 IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND.
14868 &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT.
14869 &PSYS(2,4))) THEN
14870 MINT(51)=1
14871 MINT(57)=MINT(57)+1
14872 RETURN
14873 ENDIF
14874
14875C...Loop over two remnants; skip if none there.
14876 I=NS
14877 DO 410 JT=1,2
14878 ISN(JT)=0
14879 IF(MINT(44+JT).EQ.1) GOTO 410
14880 IF(JT.EQ.1) IPU=IPU1
14881 IF(JT.EQ.2) IPU=IPU2
14882
14883C...Store first remnant parton.
14884 I=I+1
14885 IS(JT)=I
14886 ISN(JT)=1
14887 DO 350 J=1,5
14888 K(I,J)=0
14889 P(I,J)=0D0
14890 V(I,J)=0D0
14891 350 CONTINUE
14892 K(I,1)=1
14893 K(I,2)=KFLSP(JT)
14894 K(I,3)=MINT(83)+JT
14895 P(I,5)=PYMASS(K(I,2))
14896
14897C...First parton colour connections and kinematics.
14898 KCOL=KCHG(PYCOMP(KFLSP(JT)),2)
14899 IF(KCOL.EQ.2) THEN
14900 K(I,1)=3
14901 K(I,4)=MSTU(5)*IPU+IPU
14902 K(I,5)=MSTU(5)*IPU+IPU
14903 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
14904 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
14905 ELSEIF(KCOL.NE.0) THEN
14906 K(I,1)=3
14907 KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2
14908 K(I,KFLS+3)=IPU
14909 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
14910 ENDIF
14911 IF(KFLCH(JT).EQ.0) THEN
14912 P(I,1)=-P(MINT(83)+JT+2,1)
14913 P(I,2)=-P(MINT(83)+JT+2,2)
14914 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
14915 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
14916 P(I,3)=PSYS(JT,3)
14917 P(I,4)=PSYS(JT,4)
14918
14919C...When extra remnant parton or hadron: store extra remnant.
14920 ELSE
14921 I=I+1
14922 ISN(JT)=2
14923 DO 360 J=1,5
14924 K(I,J)=0
14925 P(I,J)=0D0
14926 V(I,J)=0D0
14927 360 CONTINUE
14928 K(I,1)=1
14929 K(I,2)=KFLCH(JT)
14930 K(I,3)=MINT(83)+JT
14931 P(I,5)=PYMASS(K(I,2))
14932
14933C...Find parton colour connections of extra remnant.
14934 KCOL=KCHG(PYCOMP(KFLCH(JT)),2)
14935 IF(KCOL.EQ.2) THEN
14936 K(I,1)=3
14937 K(I,4)=MSTU(5)*IPU+IPU
14938 K(I,5)=MSTU(5)*IPU+IPU
14939 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
14940 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
14941 ELSEIF(KCOL.NE.0) THEN
14942 K(I,1)=3
14943 KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2
14944 K(I,KFLS+3)=IPU
14945 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
14946 ENDIF
14947
14948C...Relative transverse momentum when two remnants.
14949 LOOP=0
14950 370 LOOP=LOOP+1
14951 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
14952 IF(IABS(MINT(10+JT)).LT.20) THEN
14953 P(I-1,1)=0D0
14954 P(I-1,2)=0D0
14955 ELSE
14956 P(I-1,1)=P(I-1,1)-0.5D0*P(MINT(83)+JT+2,1)
14957 P(I-1,2)=P(I-1,2)-0.5D0*P(MINT(83)+JT+2,2)
14958 ENDIF
14959 PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
14960 P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
14961 P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
14962 PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
14963
14964C...Meson or baryon; photon as meson. For splitup below.
14965 IMB=1
14966 IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
14967
14968C***Relative distribution for electron into two electrons. Temporary!
14969 IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT))
14970 & THEN
14971 CHI(JT)=PYR(0)
14972
14973C...Relative distribution of electron energy into electron plus parton.
14974 ELSEIF(IABS(MINT(10+JT)).LT.20) THEN
14975 XHRD=VINT(140+JT)
14976 XE=VINT(154+JT)
14977 CHI(JT)=(XE-XHRD)/(1D0-XHRD)
14978
14979C...Relative distribution of energy for particle into two jets.
14980 ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
14981 CHIK=PARP(92+2*IMB)
14982 IF(MSTP(92).LE.1) THEN
14983 IF(IMB.EQ.1) CHI(JT)=PYR(0)
14984 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
14985 ELSEIF(MSTP(92).EQ.2) THEN
14986 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK))
14987 ELSEIF(MSTP(92).EQ.3) THEN
14988 CUT=2D0*0.3D0/VINT(1)
14989 380 CHI(JT)=PYR(0)**2
14990 IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0*
14991 & (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380
14992 ELSEIF(MSTP(92).EQ.4) THEN
14993 CUT=2D0*0.3D0/VINT(1)
14994 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
14995 390 CHIR=CUT*CUTR**PYR(0)
14996 CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR)
14997 IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390
14998 ELSE
14999 CUT=2D0*0.3D0/VINT(1)
15000 CUTA=CUT**(1D0-PARP(98))
15001 CUTB=(1D0+CUT)**(1D0-PARP(98))
15002 400 CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
15003 IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))**
15004 & (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400
15005 ENDIF
15006
15007C...Relative distribution of energy for particle into jet plus particle.
15008 ELSE
15009 IF(MSTP(94).LE.1) THEN
15010 IF(IMB.EQ.1) CHI(JT)=PYR(0)
15011 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
15012 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
15013 ELSEIF(MSTP(94).EQ.2) THEN
15014 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
15015 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
15016 ELSEIF(MSTP(94).EQ.3) THEN
15017 CALL PYZDIS(1,0,PMS(JT+4),ZZ)
15018 CHI(JT)=ZZ
15019 ELSE
15020 CALL PYZDIS(1000,0,PMS(JT+4),ZZ)
15021 CHI(JT)=ZZ
15022 ENDIF
15023 ENDIF
15024
15025C...Construct total transverse mass; reject if too large.
15026 CHI(JT)=MAX(1D-8,MIN(1D0-1D-8,CHI(JT)))
15027 PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT))
15028 IF(PMS(JT).GT.PSYS(JT,4)**2) THEN
15029 IF(LOOP.LT.100) THEN
15030 GOTO 370
15031 ELSE
15032 MINT(51)=1
15033 MINT(57)=MINT(57)+1
15034 RETURN
15035 ENDIF
15036 ENDIF
15037 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
15038 VINT(158+JT)=CHI(JT)
15039
15040C...Subdivide longitudinal momentum according to value selected above.
15041 PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3)))
15042 P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1)
15043 P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
15044 P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4)
15045 P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3)
15046 ENDIF
15047 410 CONTINUE
15048 N=I
15049
15050C...Check if longitudinal boosts needed - if so pick two systems.
15051 PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+
15052 &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3))
15053 IF(PDEV.LE.1D-6*VINT(1)) RETURN
15054 IF(ISN(1).EQ.0) THEN
15055 IR=0
15056 IL=2
15057 ELSEIF(ISN(2).EQ.0) THEN
15058 IR=1
15059 IL=0
15060 ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN
15061 IR=1
15062 IL=2
15063 ELSEIF(VINT(143).GT.0.2D0) THEN
15064 IR=1
15065 IL=0
15066 ELSEIF(VINT(144).GT.0.2D0) THEN
15067 IR=0
15068 IL=2
15069 ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN
15070 IR=1
15071 IL=0
15072 ELSE
15073 IR=0
15074 IL=2
15075 ENDIF
15076 IG=3-IR-IL
15077
15078C...E+-pL wanted for system to be modified.
15079 IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN
15080 PPB=VINT(1)
15081 PNB=VINT(1)
15082 ELSE
15083 PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3))
15084 PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3))
15085 ENDIF
15086
15087C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
15088 IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN
15089 PPB=PPB-(PSYS(0,4)+PSYS(0,3))
15090 PNB=PNB-(PSYS(0,4)-PSYS(0,3))
15091 DO 420 J=1,4
15092 PSYS(0,J)=0D0
15093 420 CONTINUE
15094 DO 450 I=MINT(84)+1,NS
15095 IF(K(I,1).GT.10) GOTO 450
15096 INCL=0
15097 IORIG=I
15098 430 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
15099 IORIG=K(IORIG,3)
15100 IF(IORIG.GT.LPIN) GOTO 430
15101 IF(INCL.EQ.0) GOTO 450
15102 DO 440 J=1,4
15103 PSYS(0,J)=PSYS(0,J)+P(I,J)
15104 440 CONTINUE
15105 450 CONTINUE
15106 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
15107 PPB=PPB+(PSYS(0,4)+PSYS(0,3))
15108 PNB=PNB+(PSYS(0,4)-PSYS(0,3))
15109 ENDIF
15110
15111C...Construct longitudinal boosts.
15112 DPMTB=PPB*PNB
15113 DPMTR=PMS(IR)
15114 DPMTL=PMS(IL)
15115 DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL))
15116 IF(DSQLAM.LE.1D-6*DPMTB) THEN
15117 MINT(51)=1
15118 MINT(57)=MINT(57)+1
15119 RETURN
15120 ENDIF
15121 DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
15122 DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/
15123 &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB)
15124 DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/
15125 &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB)
15126 DBER=(DRKR**2-1D0)/(DRKR**2+1D0)
15127 DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0)
15128
15129C...Perform longitudinal boosts.
15130 IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN
15131 P(IS(1),3)=0D0
15132 P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2)
15133 ELSEIF(IR.EQ.1) THEN
15134 CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER)
15135 ELSEIF(IDISXQ.EQ.1) THEN
15136 DO 470 I=I1,NS
15137 INCL=0
15138 IORIG=I
15139 460 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
15140 IORIG=K(IORIG,3)
15141 IF(IORIG.GT.LPIN) GOTO 460
15142 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER)
15143 470 CONTINUE
15144 ELSE
15145 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER)
15146 ENDIF
15147 IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN
15148 P(IS(2),3)=0D0
15149 P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2)
15150 ELSEIF(IL.EQ.2) THEN
15151 CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL)
15152 ELSEIF(IDISXQ.EQ.1) THEN
15153 DO 490 I=I1,NS
15154 INCL=0
15155 IORIG=I
15156 480 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
15157 IORIG=K(IORIG,3)
15158 IF(IORIG.GT.LPIN) GOTO 480
15159 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL)
15160 490 CONTINUE
15161 ELSE
15162 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL)
15163 ENDIF
15164
15165C...Final check that energy-momentum conservation worked.
15166 PESUM=0D0
15167 PZSUM=0D0
15168 DO 500 I=MINT(84)+1,N
15169 IF(K(I,1).GT.10) GOTO 500
15170 PESUM=PESUM+P(I,4)
15171 PZSUM=PZSUM+P(I,3)
15172 500 CONTINUE
15173 PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM)
15174 IF(PDEV.GT.1D-4*VINT(1)) THEN
15175 MINT(51)=1
15176 MINT(57)=MINT(57)+1
15177 RETURN
15178 ENDIF
15179
15180C...Calculate rotation and boost from overall CM frame to
15181C...hadronic CM frame in leptoproduction.
15182 MINT(91)=0
15183 IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
15184 MINT(91)=1
15185 LESD=1
15186 IF(MINT(42).EQ.1) LESD=2
15187 LPIN=MINT(83)+3-LESD
15188
15189C...Sum upp momenta of everything not lepton or photon to define boost.
15190 DO 510 J=1,4
15191 PSUM(J)=0D0
15192 510 CONTINUE
15193 DO 530 I=1,N
15194 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
15195 IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
15196 IF(K(I,2).EQ.22) GOTO 530
15197 DO 520 J=1,4
15198 PSUM(J)=PSUM(J)+P(I,J)
15199 520 CONTINUE
15200 530 CONTINUE
15201 VINT(223)=-PSUM(1)/PSUM(4)
15202 VINT(224)=-PSUM(2)/PSUM(4)
15203 VINT(225)=-PSUM(3)/PSUM(4)
15204
15205C...Boost incoming hadron to hadronic CM frame to determine rotations.
15206 K(N+1,1)=1
15207 DO 540 J=1,5
15208 P(N+1,J)=P(LPIN,J)
15209 V(N+1,J)=V(LPIN,J)
15210 540 CONTINUE
15211 CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
15212 VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
15213 CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
15214 IF(LESD.EQ.2) THEN
15215 VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
15216 ELSE
15217 VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
15218 ENDIF
15219 ENDIF
15220
15221 RETURN
15222 END
15223
15224C*********************************************************************
15225
15226C...PYDIFF
15227C...Handles diffractive and elastic scattering.
15228
15229 SUBROUTINE PYDIFF
15230
15231C...Double precision and integer declarations.
15232 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15233 IMPLICIT INTEGER(I-N)
15234 INTEGER PYK,PYCHGE,PYCOMP
15235C...Commonblocks.
15236 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15237 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15238 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15239 COMMON/PYINT1/MINT(400),VINT(400)
15240 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
15241
15242C...Reset K, P and V vectors. Store incoming particles.
15243 DO 110 JT=1,MSTP(126)+10
15244 I=MINT(83)+JT
15245 DO 100 J=1,5
15246 K(I,J)=0
15247 P(I,J)=0D0
15248 V(I,J)=0D0
15249 100 CONTINUE
15250 110 CONTINUE
15251 N=MINT(84)
15252 MINT(3)=0
15253 MINT(21)=0
15254 MINT(22)=0
15255 MINT(23)=0
15256 MINT(24)=0
15257 MINT(4)=4
15258 DO 130 JT=1,2
15259 I=MINT(83)+JT
15260 K(I,1)=21
15261 K(I,2)=MINT(10+JT)
15262 DO 120 J=1,5
15263 P(I,J)=VINT(285+5*JT+J)
15264 120 CONTINUE
15265 130 CONTINUE
15266 MINT(6)=2
15267
15268C...Subprocess; kinematics.
15269 SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64)
15270 PZ=SQRT(SQLAM)/(2D0*VINT(1))
15271 DO 200 JT=1,2
15272 I=MINT(83)+JT
15273 PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1))
15274 KFH=MINT(102+JT)
15275
15276C...Elastically scattered particle. (Except elastic GVMD states.)
15277 IF(MINT(16+JT).LE.0.AND.(MINT(10+JT).NE.22.OR.
15278 & MINT(106+JT).NE.3)) THEN
15279 N=N+1
15280 K(N,1)=1
15281 K(N,2)=KFH
15282 K(N,3)=I+2
15283 P(N,3)=PZ*(-1)**(JT+1)
15284 P(N,4)=PE
15285 P(N,5)=SQRT(VINT(62+JT))
15286
15287C...Decay rho from elastic scattering of gamma with sin**2(theta)
15288C...distribution of decay products (in rho rest frame).
15289 IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN
15290 NSAV=N
15291 DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2)
15292 P(N,3)=0D0
15293 P(N,4)=P(N,5)
15294 CALL PYDECY(NSAV)
15295 IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN
15296 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
15297 CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0)
15298 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
15299 CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0)
15300 140 CTHE=2D0*PYR(0)-1D0
15301 IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140
15302 CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0)
15303 ENDIF
15304 CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ)
15305 ENDIF
15306
15307C...Diffracted particle: low-mass system to two particles.
15308 ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN
15309 N=N+2
15310 K(N-1,1)=1
15311 K(N,1)=1
15312 K(N-1,3)=I+2
15313 K(N,3)=I+2
15314 PMMAS=SQRT(VINT(62+JT))
15315 NTRY=0
15316 150 NTRY=NTRY+1
15317 IF(NTRY.LT.20) THEN
15318 MINT(105)=MINT(102+JT)
15319 MINT(109)=MINT(106+JT)
15320 CALL PYSPLI(KFH,21,KFL1,KFL2)
15321 CALL PYKFDI(KFL1,0,KFL3,KF1)
15322 IF(KF1.EQ.0) GOTO 150
15323 CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2)
15324 IF(KF2.EQ.0) GOTO 150
15325 ELSE
15326 KF1=KFH
15327 KF2=111
15328 ENDIF
15329 PM1=PYMASS(KF1)
15330 PM2=PYMASS(KF2)
15331 IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150
15332 K(N-1,2)=KF1
15333 K(N,2)=KF2
15334 P(N-1,5)=PM1
15335 P(N,5)=PM2
15336 PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2-
15337 & 4D0*PM1**2*PM2**2))/(2D0*PMMAS)
15338 P(N-1,3)=PZP
15339 P(N,3)=-PZP
15340 P(N-1,4)=SQRT(PM1**2+PZP**2)
15341 P(N,4)=SQRT(PM2**2+PZP**2)
15342 CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0),
15343 & 0D0,0D0,0D0)
15344 DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2)
15345 CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ)
15346
15347C...Diffracted particle: valence quark kicked out.
15348 ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT.
15349 & PARP(101))) THEN
15350 N=N+2
15351 K(N-1,1)=2
15352 K(N,1)=1
15353 K(N-1,3)=I+2
15354 K(N,3)=I+2
15355 MINT(105)=MINT(102+JT)
15356 MINT(109)=MINT(106+JT)
15357 CALL PYSPLI(KFH,21,K(N,2),K(N-1,2))
15358 P(N-1,5)=PYMASS(K(N-1,2))
15359 P(N,5)=PYMASS(K(N,2))
15360 SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
15361 & 4D0*P(N-1,5)**2*P(N,5)**2
15362 P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
15363 & P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1)
15364 P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
15365 P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
15366 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
15367
15368C...Diffracted particle: gluon kicked out.
15369 ELSE
15370 N=N+3
15371 K(N-2,1)=2
15372 K(N-1,1)=2
15373 K(N,1)=1
15374 K(N-2,3)=I+2
15375 K(N-1,3)=I+2
15376 K(N,3)=I+2
15377 MINT(105)=MINT(102+JT)
15378 MINT(109)=MINT(106+JT)
15379 CALL PYSPLI(KFH,21,K(N,2),K(N-2,2))
15380 K(N-1,2)=21
15381 P(N-2,5)=PYMASS(K(N-2,2))
15382 P(N-1,5)=0D0
15383 P(N,5)=PYMASS(K(N,2))
15384C...Energy distribution for particle into two jets.
15385 160 IMB=1
15386 IF(MOD(KFH/1000,10).NE.0) IMB=2
15387 CHIK=PARP(92+2*IMB)
15388 IF(MSTP(92).LE.1) THEN
15389 IF(IMB.EQ.1) CHI=PYR(0)
15390 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
15391 ELSEIF(MSTP(92).EQ.2) THEN
15392 CHI=1D0-PYR(0)**(1D0/(1D0+CHIK))
15393 ELSEIF(MSTP(92).EQ.3) THEN
15394 CUT=2D0*0.3D0/VINT(1)
15395 170 CHI=PYR(0)**2
15396 IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT.
15397 & PYR(0)) GOTO 170
15398 ELSEIF(MSTP(92).EQ.4) THEN
15399 CUT=2D0*0.3D0/VINT(1)
15400 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
15401 180 CHIR=CUT*CUTR**PYR(0)
15402 CHI=(CHIR**2-CUT**2)/(2D0*CHIR)
15403 IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180
15404 ELSE
15405 CUT=2D0*0.3D0/VINT(1)
15406 CUTA=CUT**(1D0-PARP(98))
15407 CUTB=(1D0+CUT)**(1D0-PARP(98))
15408 190 CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
15409 IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))**
15410 & (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
15411 ENDIF
15412 IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/
15413 & VINT(62+JT)) GOTO 160
15414 SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI
15415 PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
15416 & (2D0*VINT(62+JT))
15417 PEI=SQRT(PZI**2+SQM)
15418 PQQP=(1D0-CHI)*(PEI+PZI)
15419 P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
15420 P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
15421 P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
15422 P(N-1,3)=P(N-1,4)*(-1)**JT
15423 P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
15424 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
15425 ENDIF
15426
15427C...Documentation lines.
15428 K(I+2,1)=21
15429 IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
15430 IF(MINT(16+JT).NE.0.OR.(MINT(10+JT).EQ.22.AND.
15431 & MINT(106+JT).EQ.3)) K(I+2,2)=ISIGN(9900000,KFH)+10*(KFH/10)
15432 K(I+2,3)=I
15433 P(I+2,3)=PZ*(-1)**(JT+1)
15434 P(I+2,4)=PE
15435 P(I+2,5)=SQRT(VINT(62+JT))
15436 200 CONTINUE
15437
15438C...Rotate outgoing partons/particles using cos(theta).
15439 IF(VINT(23).LT.0.9D0) THEN
15440 CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
15441 ELSE
15442 CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
15443 ENDIF
15444
15445 RETURN
15446 END
15447
15448C*********************************************************************
15449
15450C...PYDISG
15451C...Set up a DIS process as gamma* + f -> f, with beam remnant
15452C...and showering added consecutively. Photon flux by the PYGAGA
15453C...routine (if at all).
15454
15455 SUBROUTINE PYDISG
15456
15457C...Double precision and integer declarations.
15458 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15459 IMPLICIT INTEGER(I-N)
15460 INTEGER PYK,PYCHGE,PYCOMP
15461C...Parameter statement to help give large particle numbers.
15462 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
15463 &KEXCIT=4000000,KDIMEN=5000000)
15464C...Commonblocks.
15465 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15466 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15467 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15468 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
15469 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15470 COMMON/PYINT1/MINT(400),VINT(400)
15471 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
15472C...Local arrays.
15473 DIMENSION PMS(4)
15474
15475C...Choice of subprocess, number of documentation lines
15476 IDOC=7
15477 MINT(3)=IDOC-6
15478 MINT(4)=IDOC
15479 IPU1=MINT(84)+1
15480 IPU2=MINT(84)+2
15481 IPU3=MINT(84)+3
15482 ISIDE=1
15483 IF(MINT(107).EQ.4) ISIDE=2
15484
15485C...Reset K, P and V vectors. Store incoming particles
15486 DO 110 JT=1,MSTP(126)+20
15487 I=MINT(83)+JT
15488 DO 100 J=1,5
15489 K(I,J)=0
15490 P(I,J)=0D0
15491 V(I,J)=0D0
15492 100 CONTINUE
15493 110 CONTINUE
15494 DO 130 JT=1,2
15495 I=MINT(83)+JT
15496 K(I,1)=21
15497 K(I,2)=MINT(10+JT)
15498 DO 120 J=1,5
15499 P(I,J)=VINT(285+5*JT+J)
15500 120 CONTINUE
15501 130 CONTINUE
15502 MINT(6)=2
15503
15504C...Store incoming partons in hadronic CM-frame
15505 DO 140 JT=1,2
15506 I=MINT(84)+JT
15507 K(I,1)=14
15508 K(I,2)=MINT(14+JT)
15509 K(I,3)=MINT(83)+2+JT
15510 140 CONTINUE
15511 IF(MINT(15).EQ.22) THEN
15512 P(MINT(84)+1,3)=0.5D0*(VINT(1)+VINT(307)/VINT(1))
15513 P(MINT(84)+1,4)=0.5D0*(VINT(1)-VINT(307)/VINT(1))
15514 P(MINT(84)+1,5)=-SQRT(VINT(307))
15515 P(MINT(84)+2,3)=-0.5D0*VINT(307)/VINT(1)
15516 P(MINT(84)+2,4)=0.5D0*VINT(307)/VINT(1)
15517 KFRES=MINT(16)
15518 ISIDE=2
15519 ELSE
15520 P(MINT(84)+1,3)=0.5D0*VINT(308)/VINT(1)
15521 P(MINT(84)+1,4)=0.5D0*VINT(308)/VINT(1)
15522 P(MINT(84)+2,3)=-0.5D0*(VINT(1)+VINT(308)/VINT(1))
15523 P(MINT(84)+2,4)=0.5D0*(VINT(1)-VINT(308)/VINT(1))
15524 P(MINT(84)+1,5)=-SQRT(VINT(308))
15525 KFRES=MINT(15)
15526 ISIDE=1
15527 ENDIF
15528 SIDESG=(-1D0)**(ISIDE-1)
15529
15530C...Copy incoming partons to documentation lines.
15531 DO 170 JT=1,2
15532 I1=MINT(83)+4+JT
15533 I2=MINT(84)+JT
15534 K(I1,1)=21
15535 K(I1,2)=K(I2,2)
15536 K(I1,3)=I1-2
15537 DO 150 J=1,5
15538 P(I1,J)=P(I2,J)
15539 150 CONTINUE
15540
15541C...Second copy for partons before ISR shower, since no such.
15542 I1=MINT(83)+2+JT
15543 K(I1,1)=21
15544 K(I1,2)=K(I2,2)
15545 K(I1,3)=I1-2
15546 DO 160 J=1,5
15547 P(I1,J)=P(I2,J)
15548 160 CONTINUE
15549 170 CONTINUE
15550
15551C...Define initial partons.
15552 NTRY=0
15553 180 NTRY=NTRY+1
15554 IF(NTRY.GT.100) THEN
15555 MINT(51)=1
15556 RETURN
15557 ENDIF
15558
15559C...Scattered quark in hadronic CM frame.
15560 I=MINT(83)+7
15561 K(IPU3,1)=3
15562 K(IPU3,2)=KFRES
15563 K(IPU3,3)=I
15564 P(IPU3,5)=PYMASS(KFRES)
15565 P(IPU3,3)=P(IPU1,3)+P(IPU2,3)
15566 P(IPU3,4)=P(IPU1,4)+P(IPU2,4)
15567 P(IPU3,5)=0D0
15568 K(I,1)=21
15569 K(I,2)=KFRES
15570 K(I,3)=MINT(83)+4+ISIDE
15571 P(I,3)=P(IPU3,3)
15572 P(I,4)=P(IPU3,4)
15573 P(I,5)=P(IPU3,5)
15574 N=IPU3
15575 MINT(21)=KFRES
15576 MINT(22)=0
15577
15578C...No primordial kT, or chosen according to truncated Gaussian or
15579C...exponential, or (for photon) predetermined or power law.
15580 190 IF(MINT(40+ISIDE).EQ.2.AND.MINT(10+ISIDE).NE.22) THEN
15581 IF(MSTP(91).LE.0) THEN
15582 PT=0D0
15583 ELSEIF(MSTP(91).EQ.1) THEN
15584 PT=PARP(91)*SQRT(-LOG(PYR(0)))
15585 ELSE
15586 RPT1=PYR(0)
15587 RPT2=PYR(0)
15588 PT=-PARP(92)*LOG(RPT1*RPT2)
15589 ENDIF
15590 IF(PT.GT.PARP(93)) GOTO 190
15591 ELSEIF(MINT(106+ISIDE).EQ.3) THEN
15592 PTA=SQRT(VINT(282+ISIDE))
15593 PTB=0D0
15594 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
15595 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
15596 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
15597 RPT1=PYR(0)
15598 RPT2=PYR(0)
15599 PTB=-PARP(99)*LOG(RPT1*RPT2)
15600 ENDIF
15601 IF(PTB.GT.PARP(100)) GOTO 190
15602 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
15603 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
15604 ELSEIF(IABS(MINT(14+ISIDE)).LE.8.OR.MINT(14+ISIDE).EQ.21) THEN
15605 IF(MSTP(93).LE.0) THEN
15606 PT=0D0
15607 ELSEIF(MSTP(93).EQ.1) THEN
15608 PT=PARP(99)*SQRT(-LOG(PYR(0)))
15609 ELSEIF(MSTP(93).EQ.2) THEN
15610 RPT1=PYR(0)
15611 RPT2=PYR(0)
15612 PT=-PARP(99)*LOG(RPT1*RPT2)
15613 ELSEIF(MSTP(93).EQ.3) THEN
15614 HA=PARP(99)**2
15615 HB=PARP(100)**2
15616 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
15617 ELSE
15618 HA=PARP(99)**2
15619 HB=PARP(100)**2
15620 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
15621 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
15622 ENDIF
15623 IF(PT.GT.PARP(100)) GOTO 190
15624 ELSE
15625 PT=0D0
15626 ENDIF
15627 VINT(156+ISIDE)=PT
15628 PHI=PARU(2)*PYR(0)
15629 P(IPU3,1)=PT*COS(PHI)
15630 P(IPU3,2)=PT*SIN(PHI)
15631 P(IPU3,4)=SQRT(P(IPU3,5)**2+PT**2+P(IPU3,3)**2)
15632 PMS(3-ISIDE)=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
15633 PCP=P(IPU3,4)+ABS(P(IPU3,3))
15634
15635C...Find one or two beam remnants.
15636 MINT(105)=MINT(102+ISIDE)
15637 MINT(109)=MINT(106+ISIDE)
15638 CALL PYSPLI(MINT(10+ISIDE),MINT(12+ISIDE),KFLCH,KFLSP)
15639 IF(MINT(51).NE.0) THEN
15640 MINT(51)=0
15641 GOTO 180
15642 ENDIF
15643
15644C...Store first remnant parton, with colour info and kinematics.
15645 I=N+1
15646 K(I,1)=1
15647 K(I,2)=KFLSP
15648 K(I,3)=MINT(83)+ISIDE
15649 P(I,5)=PYMASS(K(I,2))
15650 KCOL=KCHG(PYCOMP(KFLSP),2)
15651 IF(KCOL.NE.0) THEN
15652 K(I,1)=3
15653 KFLS=(3-KCOL*ISIGN(1,KFLSP))/2
15654 K(I,KFLS+3)=MSTU(5)*IPU3
15655 K(IPU3,6-KFLS)=MSTU(5)*I
15656 ICOLR=I
15657 ENDIF
15658 IF(KFLCH.EQ.0) THEN
15659 P(I,1)=-P(IPU3,1)
15660 P(I,2)=-P(IPU3,2)
15661 PMS(ISIDE)=P(I,5)**2+P(I,1)**2+P(I,2)**2
15662 P(I,3)=-P(IPU3,3)
15663 P(I,4)=SQRT(PMS(ISIDE)+P(I,3)**2)
15664 PRP=P(I,4)+ABS(P(I,3))
15665
15666C...When extra remnant parton or hadron: store extra remnant.
15667 ELSE
15668 I=I+1
15669 K(I,1)=1
15670 K(I,2)=KFLCH
15671 K(I,3)=MINT(83)+ISIDE
15672 P(I,5)=PYMASS(K(I,2))
15673 KCOL=KCHG(PYCOMP(KFLCH),2)
15674 IF(KCOL.NE.0) THEN
15675 K(I,1)=3
15676 KFLS=(3-KCOL*ISIGN(1,KFLCH))/2
15677 K(I,KFLS+3)=MSTU(5)*IPU3
15678 K(IPU3,6-KFLS)=MSTU(5)*I
15679 ICOLR=I
15680 ENDIF
15681
15682C...Relative transverse momentum when two remnants.
15683 LOOP=0
15684 200 LOOP=LOOP+1
15685 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
15686 P(I-1,1)=P(I-1,1)-0.5D0*P(IPU3,1)
15687 P(I-1,2)=P(I-1,2)-0.5D0*P(IPU3,2)
15688 PMS(3)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
15689 P(I,1)=-P(IPU3,1)-P(I-1,1)
15690 P(I,2)=-P(IPU3,2)-P(I-1,2)
15691 PMS(4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
15692
15693C...Relative distribution of energy for particle into jet plus particle.
15694 IMB=1
15695 IF(MOD(MINT(10+ISIDE)/1000,10).NE.0) IMB=2
15696 IF(MSTP(94).LE.1) THEN
15697 IF(IMB.EQ.1) CHI=PYR(0)
15698 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
15699 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
15700 ELSEIF(MSTP(94).EQ.2) THEN
15701 CHI=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
15702 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
15703 ELSEIF(MSTP(94).EQ.3) THEN
15704 CALL PYZDIS(1,0,PMS(4),ZZ)
15705 CHI=ZZ
15706 ELSE
15707 CALL PYZDIS(1000,0,PMS(4),ZZ)
15708 CHI=ZZ
15709 ENDIF
15710
15711C...Construct total transverse mass; reject if too large.
15712 CHI=MAX(1D-8,MIN(1D0-1D-8,CHI))
15713 PMS(ISIDE)=PMS(4)/CHI+PMS(3)/(1D0-CHI)
15714 IF(PMS(ISIDE).GT.P(IPU3,4)**2) THEN
15715 IF(LOOP.LT.10) GOTO 200
15716 GOTO 180
15717 ENDIF
15718 VINT(158+ISIDE)=CHI
15719
15720C...Subdivide longitudinal momentum according to value selected above.
15721 PRP=SQRT(PMS(ISIDE)+P(IPU3,3)**2)+ABS(P(IPU3,3))
15722 PW1=(1D0-CHI)*PRP
15723 P(I-1,4)=0.5D0*(PW1+PMS(3)/PW1)
15724 P(I-1,3)=0.5D0*(PW1-PMS(3)/PW1)*SIDESG
15725 PW2=CHI*PRP
15726 P(I,4)=0.5D0*(PW2+PMS(4)/PW2)
15727 P(I,3)=0.5D0*(PW2-PMS(4)/PW2)*SIDESG
15728 ENDIF
15729 N=I
15730
15731C...Boost current and remnant systems to correct frame.
15732 IF(SQRT(PMS(1))+SQRT(PMS(2)).GT.0.99D0*VINT(1)) GOTO 180
15733 DSQLAM=SQRT(MAX(0D0,(VINT(2)-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2)))
15734 DRKC=(VINT(2)+PMS(3-ISIDE)-PMS(ISIDE)+DSQLAM)/
15735 &(2D0*VINT(1)*PCP)
15736 DRKR=(VINT(2)+PMS(ISIDE)-PMS(3-ISIDE)+DSQLAM)/
15737 &(2D0*VINT(1)*PRP)
15738 DBEC=-SIDESG*(DRKC**2-1D0)/(DRKC**2+1D0)
15739 DBER=SIDESG*(DRKR**2-1D0)/(DRKR**2+1D0)
15740 CALL PYROBO(IPU3,IPU3,0D0,0D0,0D0,0D0,DBEC)
15741 CALL PYROBO(IPU3+1,N,0D0,0D0,0D0,0D0,DBER)
15742
15743C...Let current quark shower; recoil but no showering by colour partner.
15744 QMAX=2D0*SQRT(VINT(309-ISIDE))
15745 MSTJ48=MSTJ(48)
15746 MSTJ(48)=1
15747 PARJ86=PARJ(86)
15748 PARJ(86)=0D0
15749 IF(MSTP(71).EQ.1) CALL PYSHOW(IPU3,ICOLR,QMAX)
15750 MSTJ(48)=MSTJ48
15751 PARJ(86)=PARJ86
15752
15753 RETURN
15754 END
15755
15756C*********************************************************************
15757
15758C...PYDOCU
15759C...Handles the documentation of the process in MSTI and PARI,
15760C...and also computes cross-sections based on accumulated statistics.
15761
15762 SUBROUTINE PYDOCU
15763
15764C...Double precision and integer declarations.
15765 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15766 IMPLICIT INTEGER(I-N)
15767 INTEGER PYK,PYCHGE,PYCOMP
15768C...Commonblocks.
15769 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15770 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15771 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15772 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
15773 COMMON/PYINT1/MINT(400),VINT(400)
15774 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15775 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
15776 SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
15777 &/PYINT5/
15778
15779C...Calculate Monte Carlo estimates of cross-sections.
15780 ISUB=MINT(1)
15781 IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
15782 NGEN(0,3)=NGEN(0,3)+1
15783 XSEC(0,3)=0D0
15784 DO 100 I=1,500
15785 IF(I.EQ.96.OR.I.EQ.97) THEN
15786 XSEC(I,3)=0D0
15787 ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
15788 & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
15789 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
15790 & DBLE(NGEN(96,2)))
15791 ELSEIF(MSUB(95).EQ.1.AND.I.GE.381.AND.I.LE.386) THEN
15792 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
15793 & DBLE(NGEN(96,2)))
15794 ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
15795 XSEC(I,3)=0D0
15796 ELSEIF(NGEN(I,2).EQ.0) THEN
15797 XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))*
15798 & DBLE(NGEN(0,2)))
15799 ELSE
15800 XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))*
15801 & DBLE(NGEN(I,2)))
15802 ENDIF
15803 XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
15804 100 CONTINUE
15805
15806C...Rescale to known low-pT cross-section for standard QCD processes.
15807 IF(MSUB(95).EQ.1) THEN
15808 XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
15809 & XSEC(68,3)+XSEC(95,3)
15810 XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
15811 IF(XSECH.GT.1D-20.AND.XSECW.GT.1D-20) THEN
15812 FAC=XSECW/XSECH
15813 XSEC(11,3)=FAC*XSEC(11,3)
15814 XSEC(12,3)=FAC*XSEC(12,3)
15815 XSEC(13,3)=FAC*XSEC(13,3)
15816 XSEC(28,3)=FAC*XSEC(28,3)
15817 XSEC(53,3)=FAC*XSEC(53,3)
15818 XSEC(68,3)=FAC*XSEC(68,3)
15819 XSEC(95,3)=FAC*XSEC(95,3)
15820 XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
15821 ENDIF
15822 ENDIF
15823
15824C...Save information for gamma-p and gamma-gamma.
15825 IF(MINT(121).GT.1) THEN
15826 IGA=MINT(122)
15827 CALL PYSAVE(2,IGA)
15828 CALL PYSAVE(5,0)
15829 ENDIF
15830
15831C...Reset information on hard interaction.
15832 DO 110 J=1,200
15833 MSTI(J)=0
15834 PARI(J)=0D0
15835 110 CONTINUE
15836
15837C...Copy integer valued information from MINT into MSTI.
15838 DO 120 J=1,32
15839 MSTI(J)=MINT(J)
15840 120 CONTINUE
15841 IF(MINT(121).GT.1) MSTI(9)=MINT(122)
15842
15843C...Store cross-section variables in PARI.
15844 PARI(1)=XSEC(0,3)
15845 PARI(2)=XSEC(0,3)/MINT(5)
15846 PARI(7)=VINT(97)
15847 PARI(9)=VINT(99)
15848 PARI(10)=VINT(100)
15849 VINT(98)=VINT(98)+VINT(100)
15850 IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
15851
15852C...Store kinematics variables in PARI.
15853 PARI(11)=VINT(1)
15854 PARI(12)=VINT(2)
15855 IF(ISUB.NE.95) THEN
15856 DO 130 J=13,26
15857 PARI(J)=VINT(30+J)
15858 130 CONTINUE
15859 PARI(31)=VINT(141)
15860 PARI(32)=VINT(142)
15861 PARI(33)=VINT(41)
15862 PARI(34)=VINT(42)
15863 PARI(35)=PARI(33)-PARI(34)
15864 PARI(36)=VINT(21)
15865 PARI(37)=VINT(22)
15866 PARI(38)=VINT(26)
15867 PARI(39)=VINT(157)
15868 PARI(40)=VINT(158)
15869 PARI(41)=VINT(23)
15870 PARI(42)=2D0*VINT(47)/VINT(1)
15871 ENDIF
15872
15873C...Store information on scattered partons in PARI.
15874 IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
15875 DO 140 IS=7,8
15876 I=MINT(IS)
15877 PARI(36+IS)=P(I,3)/VINT(1)
15878 PARI(38+IS)=P(I,4)/VINT(1)
15879 PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
15880 PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
15881 & SQRT(PR),1D20)),P(I,3))
15882 PR=MAX(1D-20,P(I,1)**2+P(I,2)**2)
15883 PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
15884 & SQRT(PR),1D20)),P(I,3))
15885 PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2)
15886 PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
15887 PARI(48+IS)=PYANGL(P(I,1),P(I,2))
15888 140 CONTINUE
15889 ENDIF
15890
15891C...Store sum up transverse and longitudinal momenta.
15892 PARI(65)=2D0*PARI(17)
15893 IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
15894 DO 150 I=MSTP(126)+1,N
15895 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
15896 PT=SQRT(P(I,1)**2+P(I,2)**2)
15897 PARI(69)=PARI(69)+PT
15898 IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
15899 IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
15900 150 CONTINUE
15901 PARI(67)=PARI(68)
15902 PARI(71)=VINT(151)
15903 PARI(72)=VINT(152)
15904 PARI(73)=VINT(151)
15905 PARI(74)=VINT(152)
15906 ELSE
15907 PARI(66)=PARI(65)
15908 PARI(69)=PARI(65)
15909 ENDIF
15910
15911C...Store various other pieces of information into PARI.
15912 PARI(61)=VINT(148)
15913 PARI(75)=VINT(155)
15914 PARI(76)=VINT(156)
15915 PARI(77)=VINT(159)
15916 PARI(78)=VINT(160)
15917 PARI(81)=VINT(138)
15918
15919C...Store information on lepton -> lepton + gamma in PYGAGA.
15920 MSTI(71)=MINT(141)
15921 MSTI(72)=MINT(142)
15922 PARI(101)=VINT(301)
15923 PARI(102)=VINT(302)
15924 DO 160 I=103,114
15925 PARI(I)=VINT(I+202)
15926 160 CONTINUE
15927
15928C...Set information for PYTABU.
15929 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
15930 MSTU(161)=MINT(21)
15931 MSTU(162)=0
15932 ELSEIF(ISET(ISUB).EQ.5) THEN
15933 MSTU(161)=MINT(23)
15934 MSTU(162)=0
15935 ELSE
15936 MSTU(161)=MINT(21)
15937 MSTU(162)=MINT(22)
15938 ENDIF
15939
15940 RETURN
15941 END
15942
15943C*********************************************************************
15944
15945C...PYFRAM
15946C...Performs transformations between different coordinate frames.
15947
15948 SUBROUTINE PYFRAM(IFRAME)
15949
15950C...Double precision and integer declarations.
15951 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15952 IMPLICIT INTEGER(I-N)
15953 INTEGER PYK,PYCHGE,PYCOMP
15954C...Commonblocks.
15955 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15956 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15957 COMMON/PYINT1/MINT(400),VINT(400)
15958 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
15959
15960C...Check that transformation can and should be done.
15961 IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
15962 &MINT(91).EQ.1)) THEN
15963 IF(IFRAME.EQ.MINT(6)) RETURN
15964 ELSE
15965 WRITE(MSTU(11),5000) IFRAME,MINT(6)
15966 RETURN
15967 ENDIF
15968
15969 IF(MINT(6).EQ.1) THEN
15970C...Transform from fixed target or user specified frame to
15971C...overall CM frame.
15972 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
15973 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
15974 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
15975 ELSEIF(MINT(6).EQ.3) THEN
15976C...Transform from hadronic CM frame in DIS to overall CM frame.
15977 CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
15978 & -VINT(225))
15979 ENDIF
15980
15981 IF(IFRAME.EQ.1) THEN
15982C...Transform from overall CM frame to fixed target or user specified
15983C...frame.
15984 CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
15985 ELSEIF(IFRAME.EQ.3) THEN
15986C...Transform from overall CM frame to hadronic CM frame in DIS.
15987 CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
15988 CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
15989 CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
15990 ENDIF
15991
15992C...Set information about new frame.
15993 MINT(6)=IFRAME
15994 MSTI(6)=IFRAME
15995
15996 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
15997 &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
15998 &1X,I5)
15999
16000 RETURN
16001 END
16002
16003C*********************************************************************
16004
16005C...PYWIDT
16006C...Calculates full and partial widths of resonances.
16007
16008 SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
16009
16010C...Double precision and integer declarations.
16011 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16012 IMPLICIT INTEGER(I-N)
16013 INTEGER PYK,PYCHGE,PYCOMP
16014C...Parameter statement to help give large particle numbers.
16015 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
16016 &KEXCIT=4000000,KDIMEN=5000000)
16017C...Commonblocks.
16018 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16019 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
16020 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
16021 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
16022 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16023 COMMON/PYINT1/MINT(400),VINT(400)
16024 COMMON/PYINT4/MWID(500),WIDS(500,5)
16025 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
16026 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
16027 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
16028 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
16029 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
16030 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYTCSM/
16031C...Local arrays and saved variables.
16032 COMPLEX*16 ZMIXC(4,4),AL,BL,AR,BR,FL,FR
16033 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
16034 &WID2SV(3,2),WDTPP(0:400),WDTEP(0:400,0:5)
16035 SAVE MOFSV,WIDWSV,WID2SV
16036 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
16037
16038C...Compressed code and sign; mass.
16039 KFLA=IABS(KFLR)
16040 KFLS=ISIGN(1,KFLR)
16041 KC=PYCOMP(KFLA)
16042 SHR=SQRT(SH)
16043 PMR=PMAS(KC,1)
16044
16045C...Reset width information.
16046 DO 110 I=0,MDCY(KC,3)
16047 WDTP(I)=0D0
16048 DO 100 J=0,5
16049 WDTE(I,J)=0D0
16050 100 CONTINUE
16051 110 CONTINUE
16052
16053C...Allow for fudge factor to rescale resonance width.
16054 FUDGE=1D0
16055 IF(MSTP(110).NE.0.AND.(MWID(KC).EQ.1.OR.MWID(KC).EQ.2.OR.
16056 &(MWID(KC).EQ.3.AND.MINT(63).EQ.1))) THEN
16057 IF(MSTP(110).EQ.KFLA) THEN
16058 FUDGE=PARP(110)
16059 ELSEIF(MSTP(110).EQ.-1) THEN
16060 IF(KFLA.NE.6.AND.KFLA.NE.23.AND.KFLA.NE.24) FUDGE=PARP(110)
16061 ELSEIF(MSTP(110).EQ.-2) THEN
16062 FUDGE=PARP(110)
16063 ENDIF
16064 ENDIF
16065
16066C...Not to be treated as a resonance: return.
16067 IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND.
16068 &KFLA.NE.22) THEN
16069 WDTP(0)=1D0
16070 WDTE(0,0)=1D0
16071 MINT(61)=0
16072 MINT(62)=0
16073 MINT(63)=0
16074 RETURN
16075
16076C...Treatment as a resonance based on tabulated branching ratios.
16077 ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN
16078C...Loop over possible decay channels; skip irrelevant ones.
16079 DO 120 I=1,MDCY(KC,3)
16080 IDC=I+MDCY(KC,2)-1
16081 IF(MDME(IDC,1).LT.0) GOTO 120
16082
16083C...Read out decay products and nominal masses.
16084 KFD1=KFDP(IDC,1)
16085 KFC1=PYCOMP(KFD1)
16086 IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1
16087 PM1=PMAS(KFC1,1)
16088 KFD2=KFDP(IDC,2)
16089 KFC2=PYCOMP(KFD2)
16090 IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2
16091 PM2=PMAS(KFC2,1)
16092 KFD3=KFDP(IDC,3)
16093 PM3=0D0
16094 IF(KFD3.NE.0) THEN
16095 KFC3=PYCOMP(KFD3)
16096 IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3
16097 PM3=PMAS(KFC3,1)
16098 ENDIF
16099
16100C...Naive partial width and alternative threshold factors.
16101 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)
16102 IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND.
16103 & PM1+PM2+PM3.GE.SHR) THEN
16104 WDTP(I)=0D0
16105 ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN
16106 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2-
16107 & 4D0*PM1**2*PM2**2))/SH
16108 ELSEIF(MDME(IDC,2).EQ.52) THEN
16109 PMA=MAX(PM1,PM2,PM3)
16110 PMC=MIN(PM1,PM2,PM3)
16111 PMB=PM1+PM2+PM3-PMA-PMC
16112 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC)
16113 PMAN=PMA**2/SH
16114 PMBN=PMB**2/SH
16115 PMCN=PMC**2/SH
16116 PMBCN=PMBC**2/SH
16117 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,
16118 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
16119 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
16120 & ((SHR-PMA)**2-(PMB+PMC)**2)*
16121 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
16122 & ((1D0-PMBCN)*PMBCN*SH)
16123 ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
16124 WDTP(I)=WDTP(I)*SQRT(
16125 & MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/
16126 & MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2))
16127 ELSEIF(MDME(IDC,2).EQ.53) THEN
16128 PMA=MAX(PM1,PM2,PM3)
16129 PMC=MIN(PM1,PM2,PM3)
16130 PMB=PM1+PM2+PM3-PMA-PMC
16131 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC)
16132 PMAN=PMA**2/SH
16133 PMBN=PMB**2/SH
16134 PMCN=PMC**2/SH
16135 PMBCN=PMBC**2/SH
16136 FACACT=SQRT(MAX(0D0,
16137 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
16138 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
16139 & ((SHR-PMA)**2-(PMB+PMC)**2)*
16140 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
16141 & ((1D0-PMBCN)*PMBCN*SH)
16142 PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
16143 PMAN=PMA**2/PMR**2
16144 PMBN=PMB**2/PMR**2
16145 PMCN=PMC**2/PMR**2
16146 PMBCN=PMBC**2/PMR**2
16147 FACNOM=SQRT(MAX(0D0,
16148 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
16149 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
16150 & ((PMR-PMA)**2-(PMB+PMC)**2)*
16151 & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
16152 & ((1D0-PMBCN)*PMBCN*PMR**2)
16153 WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM)
16154 ENDIF
16155 WDTP(I)=FUDGE*WDTP(I)
16156 WDTP(0)=WDTP(0)+WDTP(I)
16157
16158C...Calculate secondary width (at most two identical/opposite).
16159 WID2=1D0
16160 IF(MDME(IDC,1).GT.0) THEN
16161 IF(KFD2.EQ.KFD1) THEN
16162 IF(KCHG(KFC1,3).EQ.0) THEN
16163 WID2=WIDS(KFC1,1)
16164 ELSEIF(KFD1.GT.0) THEN
16165 WID2=WIDS(KFC1,4)
16166 ELSE
16167 WID2=WIDS(KFC1,5)
16168 ENDIF
16169 IF(KFD3.GT.0) THEN
16170 WID2=WID2*WIDS(KFC3,2)
16171 ELSEIF(KFD3.LT.0) THEN
16172 WID2=WID2*WIDS(KFC3,3)
16173 ENDIF
16174 ELSEIF(KFD2.EQ.-KFD1) THEN
16175 WID2=WIDS(KFC1,1)
16176 IF(KFD3.GT.0) THEN
16177 WID2=WID2*WIDS(KFC3,2)
16178 ELSEIF(KFD3.LT.0) THEN
16179 WID2=WID2*WIDS(KFC3,3)
16180 ENDIF
16181 ELSEIF(KFD3.EQ.KFD1) THEN
16182 IF(KCHG(KFC1,3).EQ.0) THEN
16183 WID2=WIDS(KFC1,1)
16184 ELSEIF(KFD1.GT.0) THEN
16185 WID2=WIDS(KFC1,4)
16186 ELSE
16187 WID2=WIDS(KFC1,5)
16188 ENDIF
16189 IF(KFD2.GT.0) THEN
16190 WID2=WID2*WIDS(KFC2,2)
16191 ELSEIF(KFD2.LT.0) THEN
16192 WID2=WID2*WIDS(KFC2,3)
16193 ENDIF
16194 ELSEIF(KFD3.EQ.-KFD1) THEN
16195 WID2=WIDS(KFC1,1)
16196 IF(KFD2.GT.0) THEN
16197 WID2=WID2*WIDS(KFC2,2)
16198 ELSEIF(KFD2.LT.0) THEN
16199 WID2=WID2*WIDS(KFC2,3)
16200 ENDIF
16201 ELSEIF(KFD3.EQ.KFD2) THEN
16202 IF(KCHG(KFC2,3).EQ.0) THEN
16203 WID2=WIDS(KFC2,1)
16204 ELSEIF(KFD2.GT.0) THEN
16205 WID2=WIDS(KFC2,4)
16206 ELSE
16207 WID2=WIDS(KFC2,5)
16208 ENDIF
16209 IF(KFD1.GT.0) THEN
16210 WID2=WID2*WIDS(KFC1,2)
16211 ELSEIF(KFD1.LT.0) THEN
16212 WID2=WID2*WIDS(KFC1,3)
16213 ENDIF
16214 ELSEIF(KFD3.EQ.-KFD2) THEN
16215 WID2=WIDS(KFC2,1)
16216 IF(KFD1.GT.0) THEN
16217 WID2=WID2*WIDS(KFC1,2)
16218 ELSEIF(KFD1.LT.0) THEN
16219 WID2=WID2*WIDS(KFC1,3)
16220 ENDIF
16221 ELSE
16222 IF(KFD1.GT.0) THEN
16223 WID2=WIDS(KFC1,2)
16224 ELSE
16225 WID2=WIDS(KFC1,3)
16226 ENDIF
16227 IF(KFD2.GT.0) THEN
16228 WID2=WID2*WIDS(KFC2,2)
16229 ELSE
16230 WID2=WID2*WIDS(KFC2,3)
16231 ENDIF
16232 IF(KFD3.GT.0) THEN
16233 WID2=WID2*WIDS(KFC3,2)
16234 ELSEIF(KFD3.LT.0) THEN
16235 WID2=WID2*WIDS(KFC3,3)
16236 ENDIF
16237 ENDIF
16238
16239C...Store effective widths according to case.
16240 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16241 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16242 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16243 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16244 ENDIF
16245 120 CONTINUE
16246C...Return.
16247 MINT(61)=0
16248 MINT(62)=0
16249 MINT(63)=0
16250 RETURN
16251 ENDIF
16252
16253C...Here begins detailed dynamical calculation of resonance widths.
16254C...Shared treatment of Higgs states.
16255 KFHIGG=25
16256 IHIGG=1
16257 IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN
16258 KFHIGG=KFLA
16259 IHIGG=KFLA-33
16260 ENDIF
16261
16262C...Common electroweak and strong constants.
16263 XW=PARU(102)
16264 XWV=XW
16265 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
16266 XW1=1D0-XW
16267 AEM=PYALEM(SH)
16268 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
16269 AS=PYALPS(SH)
16270 RADC=1D0+AS/PARU(1)
16271
16272 IF(KFLA.EQ.6) THEN
16273C...t quark.
16274 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
16275 RADCT=1D0-2.5D0*AS/PARU(1)
16276 DO 140 I=1,MDCY(KC,3)
16277 IDC=I+MDCY(KC,2)-1
16278 IF(MDME(IDC,1).LT.0) GOTO 140
16279 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16280 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16281 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
16282 WID2=1D0
16283 IF(I.GE.4.AND.I.LE.7) THEN
16284C...t -> W + q; including approximate QCD correction factor.
16285 WDTP(I)=FAC*VCKM(3,I-3)*RADCT*
16286 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16287 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
16288 IF(KFLR.GT.0) THEN
16289 WID2=WIDS(24,2)
16290 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
16291 ELSE
16292 WID2=WIDS(24,3)
16293 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
16294 ENDIF
16295 ELSEIF(I.EQ.9) THEN
16296C...t -> H + b.
16297 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16298 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
16299 WID2=WIDS(37,2)
16300 IF(KFLR.LT.0) WID2=WIDS(37,3)
16301CMRENNA++
16302 ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN
16303C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
16304 BETA=ATAN(RMSS(5))
16305 SINB=SIN(BETA)
16306 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
16307 ET=KCHG(6,1)/3D0
16308 T3L=SIGN(0.5D0,ET)
16309 KFC1=PYCOMP(KFDP(IDC,1))
16310 KFC2=PYCOMP(KFDP(IDC,2))
16311 PMNCHI=PMAS(KFC1,1)
16312 PMSTOP=PMAS(KFC2,1)
16313 IF(SHR.GT.PMNCHI+PMSTOP) THEN
16314 IZ=I-9
16315 DO 130 IK=1,4
16316 ZMIXC(IZ,IK)=DCMPLX(ZMIX(IZ,IK),ZMIXI(IZ,IK))
16317 130 CONTINUE
16318 AL=SHR*DCONJG(ZMIXC(IZ,4))/(2.0D0*PMAS(24,1)*SINB)
16319 AR=-ET*ZMIXC(IZ,1)*TANW
16320 BL=T3L*(ZMIXC(IZ,2)-ZMIXC(IZ,1)*TANW)-AR
16321 BR=AL
16322 FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR
16323 FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR
16324 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
16325 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
16326 WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM*
16327 & ((ABS(FL)**2+ABS(FR)**2)*(SH+PMNCHI**2-PMSTOP**2)+
16328 & SMZ(IZ)*4D0*SHR*DBLE(FL*DCONJG(FR)))/SH
16329 IF(KFLR.GT.0) THEN
16330 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
16331 ELSE
16332 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
16333 ENDIF
16334 ENDIF
16335 ELSEIF(I.EQ.14.AND.IMSS(1).NE.0) THEN
16336C...t -> ~g + ~t
16337 KFC1=PYCOMP(KFDP(IDC,1))
16338 KFC2=PYCOMP(KFDP(IDC,2))
16339 PMNCHI=PMAS(KFC1,1)
16340 PMSTOP=PMAS(KFC2,1)
16341 IF(SHR.GT.PMNCHI+PMSTOP) THEN
16342 RL=SFMIX(6,1)
16343 RR=-SFMIX(6,2)
16344 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
16345 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
16346 WDTP(I)=4D0/3D0*0.5D0*PYALPS(SH)*PCM*((RL**2+RR**2)*
16347 & (SH+PMNCHI**2-PMSTOP**2)+PMNCHI*4D0*SHR*RL*RR)/SH
16348 IF(KFLR.GT.0) THEN
16349 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
16350 ELSE
16351 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
16352 ENDIF
16353 ENDIF
16354 ELSEIF(I.EQ.15.AND.IMSS(1).NE.0) THEN
16355C...t -> ~gravitino + ~t
16356 XMP2=RMSS(29)**2
16357 KFC1=PYCOMP(KFDP(IDC,1))
16358 XMGR2=PMAS(KFC1,1)**2
16359 WDTP(I)=SH**2*SHR/(96D0*PARU(1)*XMP2*XMGR2)*(1D0-RM2)**4
16360 KFC2=PYCOMP(KFDP(IDC,2))
16361 WID2=WIDS(KFC2,2)
16362 IF(KFLR.LT.0) WID2=WIDS(KFC2,3)
16363CMRENNA--
16364 ENDIF
16365 WDTP(I)=FUDGE*WDTP(I)
16366 WDTP(0)=WDTP(0)+WDTP(I)
16367 IF(MDME(IDC,1).GT.0) THEN
16368 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16369 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16370 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16371 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16372 ENDIF
16373 140 CONTINUE
16374
16375 ELSEIF(KFLA.EQ.7) THEN
16376C...b' quark.
16377 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
16378 DO 150 I=1,MDCY(KC,3)
16379 IDC=I+MDCY(KC,2)-1
16380 IF(MDME(IDC,1).LT.0) GOTO 150
16381 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16382 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16383 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150
16384 WID2=1D0
16385 IF(I.GE.4.AND.I.LE.7) THEN
16386C...b' -> W + q.
16387 WDTP(I)=FAC*VCKM(I-3,4)*
16388 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16389 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
16390 IF(KFLR.GT.0) THEN
16391 WID2=WIDS(24,3)
16392 IF(I.EQ.6) WID2=WID2*WIDS(6,2)
16393 IF(I.EQ.7) WID2=WID2*WIDS(8,2)
16394 ELSE
16395 WID2=WIDS(24,2)
16396 IF(I.EQ.6) WID2=WID2*WIDS(6,3)
16397 IF(I.EQ.7) WID2=WID2*WIDS(8,3)
16398 ENDIF
16399 WID2=WIDS(24,3)
16400 IF(KFLR.LT.0) WID2=WIDS(24,2)
16401 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
16402C...b' -> H + q.
16403 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16404 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
16405 IF(KFLR.GT.0) THEN
16406 WID2=WIDS(37,3)
16407 IF(I.EQ.10) WID2=WID2*WIDS(6,2)
16408 ELSE
16409 WID2=WIDS(37,2)
16410 IF(I.EQ.10) WID2=WID2*WIDS(6,3)
16411 ENDIF
16412 ENDIF
16413 WDTP(I)=FUDGE*WDTP(I)
16414 WDTP(0)=WDTP(0)+WDTP(I)
16415 IF(MDME(IDC,1).GT.0) THEN
16416 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16417 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16418 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16419 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16420 ENDIF
16421 150 CONTINUE
16422
16423 ELSEIF(KFLA.EQ.8) THEN
16424C...t' quark.
16425 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
16426 DO 160 I=1,MDCY(KC,3)
16427 IDC=I+MDCY(KC,2)-1
16428 IF(MDME(IDC,1).LT.0) GOTO 160
16429 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16430 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16431 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160
16432 WID2=1D0
16433 IF(I.GE.4.AND.I.LE.7) THEN
16434C...t' -> W + q.
16435 WDTP(I)=FAC*VCKM(4,I-3)*
16436 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16437 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
16438 IF(KFLR.GT.0) THEN
16439 WID2=WIDS(24,2)
16440 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
16441 ELSE
16442 WID2=WIDS(24,3)
16443 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
16444 ENDIF
16445 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
16446C...t' -> H + q.
16447 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16448 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
16449 IF(KFLR.GT.0) THEN
16450 WID2=WIDS(37,2)
16451 IF(I.EQ.10) WID2=WID2*WIDS(7,2)
16452 ELSE
16453 WID2=WIDS(37,3)
16454 IF(I.EQ.10) WID2=WID2*WIDS(7,3)
16455 ENDIF
16456 ENDIF
16457 WDTP(I)=FUDGE*WDTP(I)
16458 WDTP(0)=WDTP(0)+WDTP(I)
16459 IF(MDME(IDC,1).GT.0) THEN
16460 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16461 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16462 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16463 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16464 ENDIF
16465 160 CONTINUE
16466
16467 ELSEIF(KFLA.EQ.17) THEN
16468C...tau' lepton.
16469 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
16470 DO 170 I=1,MDCY(KC,3)
16471 IDC=I+MDCY(KC,2)-1
16472 IF(MDME(IDC,1).LT.0) GOTO 170
16473 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16474 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16475 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170
16476 WID2=1D0
16477 IF(I.EQ.3) THEN
16478C...tau' -> W + nu'_tau.
16479 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16480 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
16481 IF(KFLR.GT.0) THEN
16482 WID2=WIDS(24,3)
16483 WID2=WID2*WIDS(18,2)
16484 ELSE
16485 WID2=WIDS(24,2)
16486 WID2=WID2*WIDS(18,3)
16487 ENDIF
16488 ELSEIF(I.EQ.5) THEN
16489C...tau' -> H + nu'_tau.
16490 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16491 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
16492 IF(KFLR.GT.0) THEN
16493 WID2=WIDS(37,3)
16494 WID2=WID2*WIDS(18,2)
16495 ELSE
16496 WID2=WIDS(37,2)
16497 WID2=WID2*WIDS(18,3)
16498 ENDIF
16499 ENDIF
16500 WDTP(I)=FUDGE*WDTP(I)
16501 WDTP(0)=WDTP(0)+WDTP(I)
16502 IF(MDME(IDC,1).GT.0) THEN
16503 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16504 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16505 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16506 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16507 ENDIF
16508 170 CONTINUE
16509
16510 ELSEIF(KFLA.EQ.18) THEN
16511C...nu'_tau neutrino.
16512 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
16513 DO 180 I=1,MDCY(KC,3)
16514 IDC=I+MDCY(KC,2)-1
16515 IF(MDME(IDC,1).LT.0) GOTO 180
16516 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16517 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16518 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180
16519 WID2=1D0
16520 IF(I.EQ.2) THEN
16521C...nu'_tau -> W + tau'.
16522 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16523 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
16524 IF(KFLR.GT.0) THEN
16525 WID2=WIDS(24,2)
16526 WID2=WID2*WIDS(17,2)
16527 ELSE
16528 WID2=WIDS(24,3)
16529 WID2=WID2*WIDS(17,3)
16530 ENDIF
16531 ELSEIF(I.EQ.3) THEN
16532C...nu'_tau -> H + tau'.
16533 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16534 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
16535 IF(KFLR.GT.0) THEN
16536 WID2=WIDS(37,2)
16537 WID2=WID2*WIDS(17,2)
16538 ELSE
16539 WID2=WIDS(37,3)
16540 WID2=WID2*WIDS(17,3)
16541 ENDIF
16542 ENDIF
16543 WDTP(I)=FUDGE*WDTP(I)
16544 WDTP(0)=WDTP(0)+WDTP(I)
16545 IF(MDME(IDC,1).GT.0) THEN
16546 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16547 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16548 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16549 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16550 ENDIF
16551 180 CONTINUE
16552
16553 ELSEIF(KFLA.EQ.21) THEN
16554C...QCD:
16555C***Note that widths are not given in dimensional quantities here.
16556 DO 190 I=1,MDCY(KC,3)
16557 IDC=I+MDCY(KC,2)-1
16558 IF(MDME(IDC,1).LT.0) GOTO 190
16559 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16560 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16561 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190
16562 WID2=1D0
16563 IF(I.LE.8) THEN
16564C...QCD -> q + qbar
16565 WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
16566 IF(I.EQ.6) WID2=WIDS(6,1)
16567 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
16568 ENDIF
16569 WDTP(I)=FUDGE*WDTP(I)
16570 WDTP(0)=WDTP(0)+WDTP(I)
16571 IF(MDME(IDC,1).GT.0) THEN
16572 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16573 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16574 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16575 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16576 ENDIF
16577 190 CONTINUE
16578
16579 ELSEIF(KFLA.EQ.22) THEN
16580C...QED photon.
16581C***Note that widths are not given in dimensional quantities here.
16582 DO 200 I=1,MDCY(KC,3)
16583 IDC=I+MDCY(KC,2)-1
16584 IF(MDME(IDC,1).LT.0) GOTO 200
16585 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16586 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16587 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 200
16588 WID2=1D0
16589 IF(I.LE.8) THEN
16590C...QED -> q + qbar.
16591 EF=KCHG(I,1)/3D0
16592 FCOF=3D0*RADC
16593 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
16594 WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
16595 IF(I.EQ.6) WID2=WIDS(6,1)
16596 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
16597 ELSEIF(I.LE.12) THEN
16598C...QED -> l+ + l-.
16599 EF=KCHG(9+2*(I-8),1)/3D0
16600 WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
16601 IF(I.EQ.12) WID2=WIDS(17,1)
16602 ENDIF
16603 WDTP(I)=FUDGE*WDTP(I)
16604 WDTP(0)=WDTP(0)+WDTP(I)
16605 IF(MDME(IDC,1).GT.0) THEN
16606 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16607 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16608 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16609 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16610 ENDIF
16611 200 CONTINUE
16612
16613 ELSEIF(KFLA.EQ.23) THEN
16614C...Z0:
16615 ICASE=1
16616 XWC=1D0/(16D0*XW*XW1)
16617 FAC=(AEM*XWC/3D0)*SHR
16618 210 CONTINUE
16619 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
16620 VINT(111)=0D0
16621 VINT(112)=0D0
16622 VINT(114)=0D0
16623 ENDIF
16624 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
16625 KFI=IABS(MINT(15))
16626 IF(KFI.GT.20) KFI=IABS(MINT(16))
16627 EI=KCHG(KFI,1)/3D0
16628 AI=SIGN(1D0,EI)
16629 VI=AI-4D0*EI*XWV
16630 SQMZ=PMAS(23,1)**2
16631 HZ=SHR*WDTP(0)
16632 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0
16633 IF(MSTP(43).EQ.3) VINT(112)=
16634 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
16635 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
16636 & XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
16637 ENDIF
16638 DO 220 I=1,MDCY(KC,3)
16639 IDC=I+MDCY(KC,2)-1
16640 IF(MDME(IDC,1).LT.0) GOTO 220
16641 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16642 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16643 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220
16644 WID2=1D0
16645 IF(I.LE.8) THEN
16646C...Z0 -> q + qbar
16647 EF=KCHG(I,1)/3D0
16648 AF=SIGN(1D0,EF+0.1D0)
16649 VF=AF-4D0*EF*XWV
16650 FCOF=3D0*RADC
16651 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
16652 IF(I.EQ.6) WID2=WIDS(6,1)
16653 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
16654 ELSEIF(I.LE.16) THEN
16655C...Z0 -> l+ + l-, nu + nubar
16656 EF=KCHG(I+2,1)/3D0
16657 AF=SIGN(1D0,EF+0.1D0)
16658 VF=AF-4D0*EF*XWV
16659 FCOF=1D0
16660 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
16661 ENDIF
16662 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
16663 IF(ICASE.EQ.1) THEN
16664 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
16665 & BE34
16666 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
16667 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
16668 & EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+
16669 & (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34
16670 ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
16671 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
16672 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
16673 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
16674 ENDIF
16675 IF(ICASE.EQ.1) WDTP(I)=FUDGE*WDTP(I)
16676 IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I)
16677 IF(MDME(IDC,1).GT.0) THEN
16678 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
16679 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
16680 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16681 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
16682 & WDTE(I,MDME(IDC,1))
16683 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16684 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16685 ENDIF
16686 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
16687 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=
16688 & VINT(111)+FGGF*WID2
16689 IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2
16690 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
16691 & VINT(114)+FZZF*WID2
16692 ENDIF
16693 ENDIF
16694 220 CONTINUE
16695 IF(MINT(61).GE.1) ICASE=3-ICASE
16696 IF(ICASE.EQ.2) GOTO 210
16697
16698 ELSEIF(KFLA.EQ.24) THEN
16699C...W+/-:
16700 FAC=(AEM/(24D0*XW))*SHR
16701 DO 230 I=1,MDCY(KC,3)
16702 IDC=I+MDCY(KC,2)-1
16703 IF(MDME(IDC,1).LT.0) GOTO 230
16704 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16705 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16706 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 230
16707 WID2=1D0
16708 IF(I.LE.16) THEN
16709C...W+/- -> q + qbar'
16710 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
16711 IF(KFLR.GT.0) THEN
16712 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
16713 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
16714 IF(I.GE.13) WID2=WID2*WIDS(7,3)
16715 ELSE
16716 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
16717 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
16718 IF(I.GE.13) WID2=WID2*WIDS(7,2)
16719 ENDIF
16720 ELSEIF(I.LE.20) THEN
16721C...W+/- -> l+/- + nu
16722 FCOF=1D0
16723 IF(KFLR.GT.0) THEN
16724 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
16725 ELSE
16726 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
16727 ENDIF
16728 ENDIF
16729 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
16730 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
16731 WDTP(I)=FUDGE*WDTP(I)
16732 WDTP(0)=WDTP(0)+WDTP(I)
16733 IF(MDME(IDC,1).GT.0) THEN
16734 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16735 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16736 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16737 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16738 ENDIF
16739 230 CONTINUE
16740
16741 ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN
16742C...h0 (or H0, or A0):
16743 SHFS=SH
16744 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
16745 DO 270 I=1,MDCY(KFHIGG,3)
16746 IDC=I+MDCY(KFHIGG,2)-1
16747 IF(MDME(IDC,1).LT.0) GOTO 270
16748 KFC1=PYCOMP(KFDP(IDC,1))
16749 KFC2=PYCOMP(KFDP(IDC,2))
16750 RM1=PMAS(KFC1,1)**2/SH
16751 RM2=PMAS(KFC2,1)**2/SH
16752 IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0)
16753 & GOTO 270
16754 WID2=1D0
16755
16756 IF(I.LE.8) THEN
16757C...h0 -> q + qbar
16758 WDTP(I)=FAC*3D0*(PYMRUN(KFDP(IDC,1),SH)**2/SHFS)*
16759 & SQRT(MAX(0D0,1D0-4D0*RM1))*RADC
16760C...A0 behaves like beta, ho and H0 like beta**3.
16761 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
16762 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
16763 IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2
16764 IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2
16765 IF(IMSS(1).NE.0.AND.KFC1.EQ.5) THEN
16766 WDTP(I)=WDTP(I)/(1D0+RMSS(41))**2
16767 IF(IHIGG.NE.3) THEN
16768 WDTP(I)=WDTP(I)*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
16769 & PARU(151+10*IHIGG))**2
16770 ENDIF
16771 ENDIF
16772 ENDIF
16773 IF(I.EQ.6) WID2=WIDS(6,1)
16774 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
16775 ELSEIF(I.LE.12) THEN
16776C...h0 -> l+ + l-
16777 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))*(SH/SHFS)
16778C...A0 behaves like beta, ho and H0 like beta**3.
16779 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
16780 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
16781 & PARU(153+10*IHIGG)**2
16782 IF(I.EQ.12) WID2=WIDS(17,1)
16783
16784 ELSEIF(I.EQ.13) THEN
16785C...h0 -> g + g; quark loop contribution only
16786 ETARE=0D0
16787 ETAIM=0D0
16788 DO 240 J=1,2*MSTP(1)
16789 EPS=(2D0*PMAS(J,1))**2/SH
16790C...Loop integral; function of eps=4m^2/shat; different for A0.
16791 IF(EPS.LE.1D0) THEN
16792 IF(EPS.GT.1D-4) THEN
16793 ROOT=SQRT(1D0-EPS)
16794 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
16795 ELSE
16796 RLN=LOG(4D0/EPS-2D0)
16797 ENDIF
16798 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
16799 PHIIM=0.5D0*PARU(1)*RLN
16800 ELSE
16801 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
16802 PHIIM=0D0
16803 ENDIF
16804 IF(IHIGG.LE.2) THEN
16805 ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
16806 ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM
16807 ELSE
16808 ETAREJ=-0.5D0*EPS*PHIRE
16809 ETAIMJ=-0.5D0*EPS*PHIIM
16810 ENDIF
16811C...Couplings (=1 for standard model Higgs).
16812 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
16813 IF(MOD(J,2).EQ.1) THEN
16814 ETAREJ=ETAREJ*PARU(151+10*IHIGG)
16815 ETAIMJ=ETAIMJ*PARU(151+10*IHIGG)
16816 ELSE
16817 ETAREJ=ETAREJ*PARU(152+10*IHIGG)
16818 ETAIMJ=ETAIMJ*PARU(152+10*IHIGG)
16819 ENDIF
16820 ENDIF
16821 ETARE=ETARE+ETAREJ
16822 ETAIM=ETAIM+ETAIMJ
16823 240 CONTINUE
16824 ETA2=ETARE**2+ETAIM**2
16825 WDTP(I)=FAC*(AS/PARU(1))**2*ETA2
16826
16827 ELSEIF(I.EQ.14) THEN
16828C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
16829 ETARE=0D0
16830 ETAIM=0D0
16831 JMAX=3*MSTP(1)+1
16832 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
16833 DO 250 J=1,JMAX
16834 IF(J.LE.2*MSTP(1)) THEN
16835 EJ=KCHG(J,1)/3D0
16836 EPS=(2D0*PMAS(J,1))**2/SH
16837 ELSEIF(J.LE.3*MSTP(1)) THEN
16838 JL=2*(J-2*MSTP(1))-1
16839 EJ=KCHG(10+JL,1)/3D0
16840 EPS=(2D0*PMAS(10+JL,1))**2/SH
16841 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
16842 EPS=(2D0*PMAS(24,1))**2/SH
16843 ELSE
16844 EPS=(2D0*PMAS(37,1))**2/SH
16845 ENDIF
16846C...Loop integral; function of eps=4m^2/shat.
16847 IF(EPS.LE.1D0) THEN
16848 IF(EPS.GT.1D-4) THEN
16849 ROOT=SQRT(1D0-EPS)
16850 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
16851 ELSE
16852 RLN=LOG(4D0/EPS-2D0)
16853 ENDIF
16854 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
16855 PHIIM=0.5D0*PARU(1)*RLN
16856 ELSE
16857 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
16858 PHIIM=0D0
16859 ENDIF
16860 IF(J.LE.3*MSTP(1)) THEN
16861C...Fermion loops: loop integral different for A0; charges.
16862 IF(IHIGG.LE.2) THEN
16863 PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
16864 PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM
16865 ELSE
16866 PHIPRE=-0.5D0*EPS*PHIRE
16867 PHIPIM=-0.5D0*EPS*PHIIM
16868 ENDIF
16869 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
16870 EJC=3D0*EJ**2
16871 EJH=PARU(151+10*IHIGG)
16872 ELSEIF(J.LE.2*MSTP(1)) THEN
16873 EJC=3D0*EJ**2
16874 EJH=PARU(152+10*IHIGG)
16875 ELSE
16876 EJC=EJ**2
16877 EJH=PARU(153+10*IHIGG)
16878 ENDIF
16879 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
16880 ETAREJ=EJC*EJH*PHIPRE
16881 ETAIMJ=EJC*EJH*PHIPIM
16882 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
16883C...W loops: loop integral and charges.
16884 ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE)
16885 ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM
16886 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
16887 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
16888 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
16889 ENDIF
16890 ELSE
16891C...Charged H loops: loop integral and charges.
16892 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*
16893 & PARU(158+10*IHIGG+2*(IHIGG/3))
16894 ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH
16895 ETAIMJ=-EPS**2*PHIIM*FACHHH
16896 ENDIF
16897 ETARE=ETARE+ETAREJ
16898 ETAIM=ETAIM+ETAIMJ
16899 250 CONTINUE
16900 ETA2=ETARE**2+ETAIM**2
16901 WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2
16902
16903 ELSEIF(I.EQ.15) THEN
16904C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
16905 ETARE=0D0
16906 ETAIM=0D0
16907 JMAX=3*MSTP(1)+1
16908 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
16909 DO 260 J=1,JMAX
16910 IF(J.LE.2*MSTP(1)) THEN
16911 EJ=KCHG(J,1)/3D0
16912 AJ=SIGN(1D0,EJ+0.1D0)
16913 VJ=AJ-4D0*EJ*XWV
16914 EPS=(2D0*PMAS(J,1))**2/SH
16915 EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2
16916 ELSEIF(J.LE.3*MSTP(1)) THEN
16917 JL=2*(J-2*MSTP(1))-1
16918 EJ=KCHG(10+JL,1)/3D0
16919 AJ=SIGN(1D0,EJ+0.1D0)
16920 VJ=AJ-4D0*EJ*XWV
16921 EPS=(2D0*PMAS(10+JL,1))**2/SH
16922 EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2
16923 ELSE
16924 EPS=(2D0*PMAS(24,1))**2/SH
16925 EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2
16926 ENDIF
16927C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
16928 IF(EPS.LE.1D0) THEN
16929 ROOT=SQRT(1D0-EPS)
16930 IF(EPS.GT.1D-4) THEN
16931 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
16932 ELSE
16933 RLN=LOG(4D0/EPS-2D0)
16934 ENDIF
16935 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
16936 PHIIM=0.5D0*PARU(1)*RLN
16937 PSIRE=0.5D0*ROOT*RLN
16938 PSIIM=-0.5D0*ROOT*PARU(1)
16939 ELSE
16940 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
16941 PHIIM=0D0
16942 PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS))
16943 PSIIM=0D0
16944 ENDIF
16945 IF(EPSP.LE.1D0) THEN
16946 ROOT=SQRT(1D0-EPSP)
16947 IF(EPSP.GT.1D-4) THEN
16948 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
16949 ELSE
16950 RLN=LOG(4D0/EPSP-2D0)
16951 ENDIF
16952 PHIREP=-0.25D0*(RLN**2-PARU(1)**2)
16953 PHIIMP=0.5D0*PARU(1)*RLN
16954 PSIREP=0.5D0*ROOT*RLN
16955 PSIIMP=-0.5D0*ROOT*PARU(1)
16956 ELSE
16957 PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
16958 PHIIMP=0D0
16959 PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
16960 PSIIMP=0D0
16961 ENDIF
16962 FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)*
16963 & (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
16964 FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)*
16965 & (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP))
16966 F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP)
16967 F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP)
16968 IF(J.LE.3*MSTP(1)) THEN
16969C...Fermion loops: loop integral different for A0; charges.
16970 IF(IHIGG.EQ.3) FXYRE=0D0
16971 IF(IHIGG.EQ.3) FXYIM=0D0
16972 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
16973 EJC=-3D0*EJ*VJ
16974 EJH=PARU(151+10*IHIGG)
16975 ELSEIF(J.LE.2*MSTP(1)) THEN
16976 EJC=-3D0*EJ*VJ
16977 EJH=PARU(152+10*IHIGG)
16978 ELSE
16979 EJC=-EJ*VJ
16980 EJH=PARU(153+10*IHIGG)
16981 ENDIF
16982 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
16983 ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE)
16984 ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM)
16985 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
16986C...W loops: loop integral and charges.
16987 HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS)
16988 ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE)
16989 ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM)
16990 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
16991 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
16992 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
16993 ENDIF
16994 ELSE
16995C...Charged H loops: loop integral and charges.
16996 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)*
16997 & PARU(158+10*IHIGG+2*(IHIGG/3))
16998 ETAREJ=FACHHH*FXYRE
16999 ETAIMJ=FACHHH*FXYIM
17000 ENDIF
17001 ETARE=ETARE+ETAREJ
17002 ETAIM=ETAIM+ETAIMJ
17003 260 CONTINUE
17004 ETA2=(ETARE**2+ETAIM**2)/(XW*XW1)
17005 WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2
17006 WID2=WIDS(23,2)
17007
17008 ELSEIF(I.LE.17) THEN
17009C...h0 -> Z0 + Z0, W+ + W-
17010 PM1=PMAS(IABS(KFDP(IDC,1)),1)
17011 PG1=PMAS(IABS(KFDP(IDC,1)),2)
17012 IF(MINT(62).GE.1) THEN
17013 IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND.
17014 & CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND.
17015 & MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN
17016 MOFSV(IHIGG,I-15)=0
17017 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
17018 & 1D0-4D0*RM1))
17019 WID2=1D0
17020 ELSE
17021 MOFSV(IHIGG,I-15)=1
17022 RMAS=SQRT(MAX(0D0,SH))
17023 CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW,
17024 & WID2)
17025 WIDWSV(IHIGG,I-15)=WIDW
17026 WID2SV(IHIGG,I-15)=WID2
17027 ENDIF
17028 ELSE
17029 IF(MOFSV(IHIGG,I-15).EQ.0) THEN
17030 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
17031 & 1D0-4D0*RM1))
17032 WID2=1D0
17033 ELSE
17034 WIDW=WIDWSV(IHIGG,I-15)
17035 WID2=WID2SV(IHIGG,I-15)
17036 ENDIF
17037 ENDIF
17038 WDTP(I)=FAC*WIDW/(2D0*(18-I))
17039 IF(MSTP(49).NE.0) WDTP(I)=WDTP(I)*PMAS(KFHIGG,1)**2/SHFS
17040 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
17041 & PARU(138+I+10*IHIGG)**2
17042 WID2=WID2*WIDS(7+I,1)
17043
17044 ELSEIF(I.EQ.18.AND.IHIGG.GE.2) THEN
17045C...H0 -> Z0 + h0, A0-> Z0 + h0
17046 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
17047 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17048 IF(IHIGG.EQ.2) THEN
17049 WDTP(I)=WDTP(I)*PARU(179)**2
17050 ELSEIF(IHIGG.EQ.3) THEN
17051 WDTP(I)=WDTP(I)*PARU(186)**2
17052 ENDIF
17053 WID2=WIDS(23,2)*WIDS(25,2)
17054
17055 ELSEIF(I.EQ.19.AND.IHIGG.GE.2) THEN
17056C...H0 -> h0 + h0, A0-> h0 + h0
17057 WDTP(I)=FAC*0.25D0*
17058 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
17059 IF(IHIGG.EQ.2) THEN
17060 WDTP(I)=WDTP(I)*PARU(176)**2
17061 ELSEIF(IHIGG.EQ.3) THEN
17062 WDTP(I)=WDTP(I)*PARU(169)**2
17063 ENDIF
17064 WID2=WIDS(25,1)
17065 ELSEIF((I.EQ.20.OR.I.EQ.21).AND.IHIGG.GE.2) THEN
17066C...H0 -> W+/- + H-/+, A0 -> W+/- + H-/+
17067 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
17068 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17069 & *PARU(195+IHIGG)**2
17070 IF(I.EQ.20) THEN
17071 WID2=WIDS(24,2)*WIDS(37,3)
17072 ELSEIF(I.EQ.21) THEN
17073 WID2=WIDS(24,3)*WIDS(37,2)
17074 ENDIF
17075
17076 ELSEIF(I.EQ.22.AND.IHIGG.EQ.2) THEN
17077C...H0 -> Z0 + A0.
17078 WDTP(I)=FAC*0.5D0*PARU(187)**2*SQRT(MAX(0D0,
17079 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*0.0D0
17080 WID2=WIDS(36,2)*WIDS(23,2)
17081
17082 ELSEIF(I.EQ.23.AND.IHIGG.EQ.2) THEN
17083C...H0 -> h0 + A0.
17084 WDTP(I)=FAC*0.5D0*PARU(180)**2*
17085 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
17086 WID2=WIDS(25,2)*WIDS(36,2)
17087
17088 ELSEIF(I.EQ.24.AND.IHIGG.EQ.2) THEN
17089C...H0 -> A0 + A0
17090 WDTP(I)=FAC*0.25D0*PARU(177)**2*
17091 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
17092 WID2=WIDS(36,1)
17093
17094CMRENNA++
17095 ELSE
17096C...Add in SUSY decays (two-body) by rescaling by phase space factor.
17097 RM10=RM1*SH/PMR**2
17098 RM20=RM2*SH/PMR**2
17099 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
17100 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
17101 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
17102 WFAC=0D0
17103 ELSE
17104 WFAC=WFAC/WFAC0
17105 ENDIF
17106 WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
17107CMRENNA--
17108 IF(KFC2.EQ.KFC1) THEN
17109 WID2=WIDS(KFC1,1)
17110 ELSE
17111 KSGN1=2
17112 IF(KFDP(IDC,1).LT.0) KSGN1=3
17113 KSGN2=2
17114 IF(KFDP(IDC,2).LT.0) KSGN2=3
17115 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
17116 ENDIF
17117 ENDIF
17118 WDTP(I)=FUDGE*WDTP(I)
17119 WDTP(0)=WDTP(0)+WDTP(I)
17120 IF(MDME(IDC,1).GT.0) THEN
17121 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17122 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17123 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17124 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17125 ENDIF
17126 270 CONTINUE
17127
17128 ELSEIF(KFLA.EQ.32) THEN
17129C...Z'0:
17130 ICASE=1
17131 XWC=1D0/(16D0*XW*XW1)
17132 FAC=(AEM*XWC/3D0)*SHR
17133 VINT(117)=0D0
17134 280 CONTINUE
17135 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
17136 VINT(111)=0D0
17137 VINT(112)=0D0
17138 VINT(113)=0D0
17139 VINT(114)=0D0
17140 VINT(115)=0D0
17141 VINT(116)=0D0
17142 ENDIF
17143 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
17144 KFAI=IABS(MINT(15))
17145 EI=KCHG(KFAI,1)/3D0
17146 AI=SIGN(1D0,EI+0.1D0)
17147 VI=AI-4D0*EI*XWV
17148 KFAIC=1
17149 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
17150 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
17151 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
17152 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
17153 VPI=PARU(119+2*KFAIC)
17154 API=PARU(120+2*KFAIC)
17155 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
17156 VPI=PARJ(178+2*KFAIC)
17157 API=PARJ(179+2*KFAIC)
17158 ELSE
17159 VPI=PARJ(186+2*KFAIC)
17160 API=PARJ(187+2*KFAIC)
17161 ENDIF
17162 SQMZ=PMAS(23,1)**2
17163 HZ=SHR*VINT(117)
17164 SQMZP=PMAS(32,1)**2
17165 HZP=SHR*WDTP(0)
17166 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
17167 & MSTP(44).EQ.7) VINT(111)=1D0
17168 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=
17169 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
17170 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
17171 & 2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2)
17172 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
17173 & MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
17174 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
17175 & 2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/
17176 & (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2))
17177 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
17178 & MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2)
17179 ENDIF
17180 DO 290 I=1,MDCY(KC,3)
17181 IDC=I+MDCY(KC,2)-1
17182 IF(MDME(IDC,1).LT.0) GOTO 290
17183 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17184 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17185 IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 290
17186 WID2=1D0
17187 IF(I.LE.16) THEN
17188 IF(I.LE.8) THEN
17189C...Z'0 -> q + qbar
17190 EF=KCHG(I,1)/3D0
17191 AF=SIGN(1D0,EF+0.1D0)
17192 VF=AF-4D0*EF*XWV
17193 IF(I.LE.2) THEN
17194 VPF=PARU(123-2*MOD(I,2))
17195 APF=PARU(124-2*MOD(I,2))
17196 ELSEIF(I.LE.4) THEN
17197 VPF=PARJ(182-2*MOD(I,2))
17198 APF=PARJ(183-2*MOD(I,2))
17199 ELSE
17200 VPF=PARJ(190-2*MOD(I,2))
17201 APF=PARJ(191-2*MOD(I,2))
17202 ENDIF
17203 FCOF=3D0*RADC
17204 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
17205 & PYHFTH(SH,SH*RM1,1D0)
17206 IF(I.EQ.6) WID2=WIDS(6,1)
17207 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
17208 ELSEIF(I.LE.16) THEN
17209C...Z'0 -> l+ + l-, nu + nubar
17210 EF=KCHG(I+2,1)/3D0
17211 AF=SIGN(1D0,EF+0.1D0)
17212 VF=AF-4D0*EF*XWV
17213 IF(I.LE.10) THEN
17214 VPF=PARU(127-2*MOD(I,2))
17215 APF=PARU(128-2*MOD(I,2))
17216 ELSEIF(I.LE.12) THEN
17217 VPF=PARJ(186-2*MOD(I,2))
17218 APF=PARJ(187-2*MOD(I,2))
17219 ELSE
17220 VPF=PARJ(194-2*MOD(I,2))
17221 APF=PARJ(195-2*MOD(I,2))
17222 ENDIF
17223 FCOF=1D0
17224 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
17225 ENDIF
17226 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
17227 IF(ICASE.EQ.1) THEN
17228 WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
17229 WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+
17230 & APF**2*(1D0-4D0*RM1))*BE34
17231 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
17232 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
17233 & EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
17234 & VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)*
17235 & VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)*
17236 & AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)*
17237 & VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34
17238 ELSEIF(MINT(61).EQ.2) THEN
17239 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
17240 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
17241 FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34
17242 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
17243 FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))*
17244 & BE34
17245 FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))*
17246 & BE34
17247 ENDIF
17248 ELSEIF(I.EQ.17) THEN
17249C...Z'0 -> W+ + W-
17250 WDTPZP=PARU(129)**2*XW1**2*
17251 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17252 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
17253 IF(ICASE.EQ.1) THEN
17254 WDTPZ=0D0
17255 WDTP(I)=FAC*WDTPZP
17256 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
17257 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
17258 ELSEIF(MINT(61).EQ.2) THEN
17259 FGGF=0D0
17260 FGZF=0D0
17261 FGZPF=0D0
17262 FZZF=0D0
17263 FZZPF=0D0
17264 FZPZPF=WDTPZP
17265 ENDIF
17266 WID2=WIDS(24,1)
17267 ELSEIF(I.EQ.18) THEN
17268C...Z'0 -> H+ + H-
17269 CZC=2D0*(1D0-2D0*XW)
17270 BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
17271 IF(ICASE.EQ.1) THEN
17272 WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C
17273 WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C
17274 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
17275 WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI*
17276 & VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2*
17277 & (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)*
17278 & (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2*
17279 & (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C
17280 ELSEIF(MINT(61).EQ.2) THEN
17281 FGGF=0.25D0*BE34C
17282 FGZF=0.25D0*PARU(142)*CZC*BE34C
17283 FGZPF=0.25D0*PARU(143)*CZC*BE34C
17284 FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C
17285 FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C
17286 FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C
17287 ENDIF
17288 WID2=WIDS(37,1)
17289 ELSEIF(I.EQ.19) THEN
17290C...Z'0 -> Z0 + gamma.
17291 ELSEIF(I.EQ.20) THEN
17292C...Z'0 -> Z0 + h0
17293 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17294 WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)*
17295 & (3D0*RM1+0.25D0*FLAM**2)*FLAM
17296 IF(ICASE.EQ.1) THEN
17297 WDTPZ=0D0
17298 WDTP(I)=FAC*WDTPZP
17299 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
17300 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
17301 ELSEIF(MINT(61).EQ.2) THEN
17302 FGGF=0D0
17303 FGZF=0D0
17304 FGZPF=0D0
17305 FZZF=0D0
17306 FZZPF=0D0
17307 FZPZPF=WDTPZP
17308 ENDIF
17309 WID2=WIDS(23,2)*WIDS(25,2)
17310 ELSEIF(I.EQ.21.OR.I.EQ.22) THEN
17311C...Z' -> h0 + A0 or H0 + A0.
17312 BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17313 IF(I.EQ.21) THEN
17314 CZAH=PARU(186)
17315 CZPAH=PARU(188)
17316 ELSE
17317 CZAH=PARU(187)
17318 CZPAH=PARU(189)
17319 ENDIF
17320 IF(ICASE.EQ.1) THEN
17321 WDTPZ=CZAH**2*BE34C
17322 WDTP(I)=FAC*CZPAH**2*BE34C
17323 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
17324 WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH*
17325 & (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)*
17326 & VINT(116))*BE34C
17327 ELSEIF(MINT(61).EQ.2) THEN
17328 FGGF=0D0
17329 FGZF=0D0
17330 FGZPF=0D0
17331 FZZF=CZAH**2*BE34C
17332 FZZPF=CZAH*CZPAH*BE34C
17333 FZPZPF=CZPAH**2*BE34C
17334 ENDIF
17335 IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2)
17336 IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2)
17337 ENDIF
17338 IF(ICASE.EQ.1) THEN
17339 VINT(117)=VINT(117)+FAC*WDTPZ
17340 WDTP(I)=FUDGE*WDTP(I)
17341 WDTP(0)=WDTP(0)+WDTP(I)
17342 ENDIF
17343 IF(MDME(IDC,1).GT.0) THEN
17344 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
17345 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
17346 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17347 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
17348 & WDTE(I,MDME(IDC,1))
17349 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17350 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17351 ENDIF
17352 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
17353 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
17354 & MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2
17355 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+
17356 & FGZF*WID2
17357 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+
17358 & FGZPF*WID2
17359 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
17360 & MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2
17361 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+
17362 & FZZPF*WID2
17363 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
17364 & MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2
17365 ENDIF
17366 ENDIF
17367 290 CONTINUE
17368 IF(MINT(61).GE.1) ICASE=3-ICASE
17369 IF(ICASE.EQ.2) GOTO 280
17370
17371 ELSEIF(KFLA.EQ.34) THEN
17372C...W'+/-:
17373 FAC=(AEM/(24D0*XW))*SHR
17374 DO 300 I=1,MDCY(KC,3)
17375 IDC=I+MDCY(KC,2)-1
17376 IF(MDME(IDC,1).LT.0) GOTO 300
17377 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17378 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17379 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300
17380 WID2=1D0
17381 IF(I.LE.20) THEN
17382 IF(I.LE.16) THEN
17383C...W'+/- -> q + qbar'
17384 FCOF=3D0*RADC*(PARU(131)**2+PARU(132)**2)*
17385 & VCKM((I-1)/4+1,MOD(I-1,4)+1)
17386 IF(KFLR.GT.0) THEN
17387 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
17388 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
17389 IF(I.GE.13) WID2=WID2*WIDS(7,3)
17390 ELSE
17391 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
17392 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
17393 IF(I.GE.13) WID2=WID2*WIDS(7,2)
17394 ENDIF
17395 ELSEIF(I.LE.20) THEN
17396C...W'+/- -> l+/- + nu
17397 FCOF=PARU(133)**2+PARU(134)**2
17398 IF(KFLR.GT.0) THEN
17399 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
17400 ELSE
17401 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
17402 ENDIF
17403 ENDIF
17404 WDTP(I)=FAC*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)*
17405 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17406 ELSEIF(I.EQ.21) THEN
17407C...W'+/- -> W+/- + Z0
17408 WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)*
17409 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17410 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
17411 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2)
17412 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2)
17413 ELSEIF(I.EQ.23) THEN
17414C...W'+/- -> W+/- + h0
17415 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17416 WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM
17417 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
17418 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
17419 ENDIF
17420 WDTP(I)=FUDGE*WDTP(I)
17421 WDTP(0)=WDTP(0)+WDTP(I)
17422 IF(MDME(IDC,1).GT.0) THEN
17423 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17424 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17425 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17426 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17427 ENDIF
17428 300 CONTINUE
17429
17430 ELSEIF(KFLA.EQ.37) THEN
17431C...H+/-:
17432C IF(MSTP(49).EQ.0) THEN
17433 SHFS=SH
17434C ELSE
17435C SHFS=PMAS(37,1)**2
17436C ENDIF
17437 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
17438 DO 310 I=1,MDCY(KC,3)
17439 IDC=I+MDCY(KC,2)-1
17440 IF(MDME(IDC,1).LT.0) GOTO 310
17441 KFC1=PYCOMP(KFDP(IDC,1))
17442 KFC2=PYCOMP(KFDP(IDC,2))
17443 RM1=PMAS(KFC1,1)**2/SH
17444 RM2=PMAS(KFC2,1)**2/SH
17445 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310
17446 WID2=1D0
17447 IF(I.LE.4) THEN
17448C...H+/- -> q + qbar'
17449 RM1R=PYMRUN(KFDP(IDC,1),SH)**2/SH
17450 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
17451 WDTP(I)=FAC*3D0*RADC*MAX(0D0,(RM1R*PARU(141)**2+
17452 & RM2R/PARU(141)**2)*(1D0-RM1R-RM2R)-4D0*RM1R*RM2R)*
17453 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
17454 IF(KFLR.GT.0) THEN
17455 IF(I.EQ.3) WID2=WIDS(6,2)
17456 IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2)
17457 ELSE
17458 IF(I.EQ.3) WID2=WIDS(6,3)
17459 IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3)
17460 ENDIF
17461 ELSEIF(I.LE.8) THEN
17462C...H+/- -> l+/- + nu
17463 WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)*
17464 & (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0,
17465 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
17466 IF(KFLR.GT.0) THEN
17467 IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2)
17468 ELSE
17469 IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3)
17470 ENDIF
17471 ELSEIF(I.EQ.9) THEN
17472C...H+/- -> W+/- + h0.
17473 WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0,
17474 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17475 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
17476 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
17477
17478CMRENNA++
17479 ELSE
17480C...Add in SUSY decays (two-body) by rescaling by phase space factor.
17481 RM10=RM1*SH/PMR**2
17482 RM20=RM2*SH/PMR**2
17483 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
17484 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
17485 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
17486 WFAC=0D0
17487 ELSE
17488 WFAC=WFAC/WFAC0
17489 ENDIF
17490 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
17491CMRENNA--
17492 KSGN1=2
17493 IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3
17494 KSGN2=2
17495 IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3
17496 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
17497 ENDIF
17498 WDTP(I)=FUDGE*WDTP(I)
17499 WDTP(0)=WDTP(0)+WDTP(I)
17500 IF(MDME(IDC,1).GT.0) THEN
17501 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17502 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17503 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17504 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17505 ENDIF
17506 310 CONTINUE
17507
17508 ELSEIF(KFLA.EQ.41) THEN
17509C...R:
17510 FAC=(AEM/(12D0*XW))*SHR
17511 DO 320 I=1,MDCY(KC,3)
17512 IDC=I+MDCY(KC,2)-1
17513 IF(MDME(IDC,1).LT.0) GOTO 320
17514 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17515 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17516 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320
17517 WID2=1D0
17518 IF(I.LE.6) THEN
17519C...R -> q + qbar'
17520 FCOF=3D0*RADC
17521 ELSEIF(I.LE.9) THEN
17522C...R -> l+ + l'-
17523 FCOF=1D0
17524 ENDIF
17525 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
17526 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17527 IF(KFLR.GT.0) THEN
17528 IF(I.EQ.4) WID2=WIDS(6,3)
17529 IF(I.EQ.5) WID2=WIDS(7,3)
17530 IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3)
17531 IF(I.EQ.9) WID2=WIDS(17,3)
17532 ELSE
17533 IF(I.EQ.4) WID2=WIDS(6,2)
17534 IF(I.EQ.5) WID2=WIDS(7,2)
17535 IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2)
17536 IF(I.EQ.9) WID2=WIDS(17,2)
17537 ENDIF
17538 WDTP(I)=FUDGE*WDTP(I)
17539 WDTP(0)=WDTP(0)+WDTP(I)
17540 IF(MDME(IDC,1).GT.0) THEN
17541 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17542 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17543 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17544 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17545 ENDIF
17546 320 CONTINUE
17547
17548 ELSEIF(KFLA.EQ.42) THEN
17549C...LQ (leptoquark).
17550 FAC=(AEM/4D0)*PARU(151)*SHR
17551 DO 330 I=1,MDCY(KC,3)
17552 IDC=I+MDCY(KC,2)-1
17553 IF(MDME(IDC,1).LT.0) GOTO 330
17554 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17555 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17556 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330
17557 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17558 WID2=1D0
17559 ILQQ=KFDP(IDC,1)*ISIGN(1,KFLR)
17560 IF(ILQQ.GE.6) WID2=WIDS(ILQQ,2)
17561 IF(ILQQ.LE.-6) WID2=WIDS(-ILQQ,3)
17562 ILQL=KFDP(IDC,2)*ISIGN(1,KFLR)
17563 IF(ILQL.GE.17) WID2=WID2*WIDS(ILQL,2)
17564 IF(ILQL.LE.-17) WID2=WID2*WIDS(-ILQL,3)
17565 WDTP(I)=FUDGE*WDTP(I)
17566 WDTP(0)=WDTP(0)+WDTP(I)
17567 IF(MDME(IDC,1).GT.0) THEN
17568 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17569 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17570 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17571 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17572 ENDIF
17573 330 CONTINUE
17574
17575 ELSEIF(KFLA.EQ.KTECHN+111.OR.KFLA.EQ.KTECHN+221) THEN
17576C...Techni-pi0 and techni-pi0':
17577 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
17578 DO 340 I=1,MDCY(KC,3)
17579 IDC=I+MDCY(KC,2)-1
17580 IF(MDME(IDC,1).LT.0) GOTO 340
17581 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
17582 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
17583 RM1=PM1**2/SH
17584 RM2=PM2**2/SH
17585 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340
17586 WID2=1D0
17587C...pi_tc -> g + g
17588 IF(I.EQ.8) THEN
17589 FACP=(AS/(4D0*PARU(1))*ITCM(1)/RTCM(1))**2
17590 & /(8D0*PARU(1))*SH*SHR
17591 IF(KFLA.EQ.KTECHN+111) THEN
17592 FACP=FACP*RTCM(9)
17593 ELSE
17594 FACP=FACP*RTCM(10)
17595 ENDIF
17596 WDTP(I)=FACP
17597 ELSE
17598C...pi_tc -> f + fbar.
17599 FCOF=1D0
17600 IKA=IABS(KFDP(IDC,1))
17601 IF(IKA.LT.10) FCOF=3D0*RADC
17602 HM1=PM1
17603 HM2=PM2
17604 IF(IKA.GE.4.AND.IKA.LE.6) THEN
17605 FCOF=FCOF*RTCM(1+IKA)**2
17606 HM1=PYMRUN(KFDP(IDC,1),SH)
17607 HM2=PYMRUN(KFDP(IDC,2),SH)
17608 ELSEIF(IKA.EQ.15) THEN
17609 FCOF=FCOF*RTCM(8)**2
17610 ENDIF
17611 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
17612 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17613 ENDIF
17614 WDTP(I)=FUDGE*WDTP(I)
17615 WDTP(0)=WDTP(0)+WDTP(I)
17616 IF(MDME(IDC,1).GT.0) THEN
17617 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17618 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17619 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17620 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17621 ENDIF
17622 340 CONTINUE
17623
17624 ELSEIF(KFLA.EQ.KTECHN+211) THEN
17625C...pi+_tc
17626 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
17627 DO 350 I=1,MDCY(KC,3)
17628 IDC=I+MDCY(KC,2)-1
17629 IF(MDME(IDC,1).LT.0) GOTO 350
17630 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
17631 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
17632 PM3=0D0
17633 IF(I.EQ.5) PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
17634 RM1=PM1**2/SH
17635 RM2=PM2**2/SH
17636 RM3=PM3**2/SH
17637 IF(SQRT(RM1)+SQRT(RM2)+SQRT(RM3).GT.1D0) GOTO 350
17638 WID2=1D0
17639C...pi_tc -> f + f'.
17640 FCOF=1D0
17641 IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
17642C...pi_tc+ -> W b b~
17643 IF(I.EQ.5.AND.SHR.LT.PMAS(6,1)+PMAS(5,1)) THEN
17644 FCOF=3D0*RADC
17645 XMT2=PMAS(6,1)**2/SH
17646 FACP=FAC/(4D0*PARU(1))*FCOF*XMT2*RTCM(7)**2
17647 KFC3=PYCOMP(KFDP(IDC,3))
17648 CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3)
17649 CHECK = SQRT(RM1)
17650 T0 = (1D0-CHECK**2)*
17651 & (XMT2*(6D0*XMT2**2+3D0*XMT2*RM1-4D0*RM1**2)-
17652 & (5D0*XMT2**2+2D0*XMT2*RM1-8D0*RM1**2))/(4D0*XMT2**2)
17653 T1 = (1D0-XMT2)*(RM1-XMT2)*((XMT2**2+XMT2*RM1+4D0*RM1**2)
17654 & -3D0*XMT2**2*(XMT2+RM1))/(2D0*XMT2**3)
17655 T3 = RM1**2/XMT2**3*(3D0*XMT2-4D0*RM1+4D0*XMT2*RM1)
17656 WDTP(I)=FACP*(T0 + T1*LOG((XMT2-CHECK**2)/(XMT2-1D0))
17657 & +T3*LOG(CHECK))
17658 IF(KFLR.GT.0) THEN
17659 WID2=WIDS(24,2)
17660 ELSE
17661 WID2=WIDS(24,3)
17662 ENDIF
17663 ELSE
17664 FCOF=1D0
17665 IKA=IABS(KFDP(IDC,1))
17666 IF(IKA.LT.10) FCOF=3D0*RADC
17667 HM1=PM1
17668 HM2=PM2
17669 IF(I.GE.1.AND.I.LE.5) THEN
17670 IF(I.LE.2) THEN
17671 FCOF=FCOF*RTCM(5)**2
17672 ELSEIF(I.LE.4) THEN
17673 FCOF=FCOF*RTCM(6)**2
17674 ELSEIF(I.EQ.5) THEN
17675 FCOF=FCOF*RTCM(7)**2
17676 ENDIF
17677 HM1=PYMRUN(KFDP(IDC,1),SH)
17678 HM2=PYMRUN(KFDP(IDC,2),SH)
17679 ELSEIF(I.EQ.8) THEN
17680 FCOF=FCOF*RTCM(8)**2
17681 ENDIF
17682 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
17683 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17684 ENDIF
17685 WDTP(I)=FUDGE*WDTP(I)
17686 WDTP(0)=WDTP(0)+WDTP(I)
17687 IF(MDME(IDC,1).GT.0) THEN
17688 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17689 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17690 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17691 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17692 ENDIF
17693 350 CONTINUE
17694
17695 ELSEIF(KFLA.EQ.KTECHN+331) THEN
17696C...Techni-eta.
17697 FAC=(SH/PARP(46)**2)*SHR
17698 DO 360 I=1,MDCY(KC,3)
17699 IDC=I+MDCY(KC,2)-1
17700 IF(MDME(IDC,1).LT.0) GOTO 360
17701 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17702 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17703 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360
17704 WID2=1D0
17705 IF(I.LE.2) THEN
17706 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1))
17707 IF(I.EQ.2) WID2=WIDS(6,1)
17708 ELSE
17709 WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3)
17710 ENDIF
17711 WDTP(I)=FUDGE*WDTP(I)
17712 WDTP(0)=WDTP(0)+WDTP(I)
17713 IF(MDME(IDC,1).GT.0) THEN
17714 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17715 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17716 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17717 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17718 ENDIF
17719 360 CONTINUE
17720
17721 ELSEIF(KFLA.EQ.KTECHN+113) THEN
17722C...Techni-rho0:
17723 ALPRHT=2.91D0*(3D0/ITCM(1))
17724 FAC=(ALPRHT/12D0)*SHR
17725 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
17726 SQMZ=PMAS(23,1)**2
17727 SQMW=PMAS(24,1)**2
17728 SHP=SH
17729 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
17730 GMMZ=SHR*WDTPP(0)
17731 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
17732 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
17733 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
17734 DO 370 I=1,MDCY(KC,3)
17735 IDC=I+MDCY(KC,2)-1
17736 IF(MDME(IDC,1).LT.0) GOTO 370
17737 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17738 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17739 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370
17740 WID2=1D0
17741 IF(I.EQ.1) THEN
17742C...rho_tc0 -> W+ + W-.
17743 WDTP(I)=FAC*RTCM(3)**4*
17744 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17745 WID2=WIDS(24,1)
17746 ELSEIF(I.EQ.2) THEN
17747C...rho_tc0 -> W+ + pi_tc-.
17748 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
17749 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
17750 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
17751 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
17752 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
17753 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
17754 ELSEIF(I.EQ.3) THEN
17755C...rho_tc0 -> pi_tc+ + W-.
17756 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
17757 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
17758 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
17759 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
17760 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
17761 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(24,3)
17762 ELSEIF(I.EQ.4) THEN
17763C...rho_tc0 -> pi_tc+ + pi_tc-.
17764 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
17765 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17766 WID2=WIDS(PYCOMP(KTECHN+211),1)
17767 ELSEIF(I.EQ.5) THEN
17768C...rho_tc0 -> gamma + pi_tc0
17769 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17770 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
17771 & SHR**3
17772 WID2=WIDS(PYCOMP(KTECHN+111),2)
17773 ELSEIF(I.EQ.6) THEN
17774C...rho_tc0 -> gamma + pi_tc0'
17775 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17776 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*SHR**3
17777 WID2=WIDS(PYCOMP(KTECHN+221),2)
17778 ELSEIF(I.EQ.7) THEN
17779C...rho_tc0 -> Z0 + pi_tc0
17780 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17781 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
17782 & XW/XW1*SHR**3
17783 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
17784 ELSEIF(I.EQ.8) THEN
17785C...rho_tc0 -> Z0 + pi_tc0'
17786 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17787 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
17788 & XW/XW1*SHR**3
17789 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
17790 ELSE
17791C...rho_tc0 -> f + fbar.
17792 WID2=1D0
17793 IF(I.LE.16) THEN
17794 IA=I-8
17795 FCOF=3D0*RADC
17796 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
17797 ELSE
17798 IA=I-6
17799 FCOF=1D0
17800 IF(IA.GE.17) WID2=WIDS(IA,1)
17801 ENDIF
17802 EI=KCHG(IA,1)/3D0
17803 AI=SIGN(1D0,EI+0.1D0)
17804 VI=AI-4D0*EI*XWV
17805 VALI=0.5D0*(VI+AI)
17806 VARI=0.5D0*(VI-AI)
17807 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
17808 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
17809 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
17810 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
17811 ENDIF
17812 WDTP(I)=FUDGE*WDTP(I)
17813 WDTP(0)=WDTP(0)+WDTP(I)
17814 IF(MDME(IDC,1).GT.0) THEN
17815 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17816 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17817 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17818 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17819 ENDIF
17820 370 CONTINUE
17821
17822 ELSEIF(KFLA.EQ.KTECHN+213) THEN
17823C...Techni-rho+/-:
17824 ALPRHT=2.91D0*(3D0/ITCM(1))
17825 FAC=(ALPRHT/12D0)*SHR
17826 SQMZ=PMAS(23,1)**2
17827 SQMW=PMAS(24,1)**2
17828 SHP=SH
17829 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
17830 GMMW=SHR*WDTPP(0)
17831 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
17832 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
17833 DO 380 I=1,MDCY(KC,3)
17834 IDC=I+MDCY(KC,2)-1
17835 IF(MDME(IDC,1).LT.0) GOTO 380
17836 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17837 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17838 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380
17839 WID2=1D0
17840 IF(I.EQ.1) THEN
17841C...rho_tc+ -> W+ + Z0.
17842 WDTP(I)=FAC*RTCM(3)**4*
17843 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17844 IF(KFLR.GT.0) THEN
17845 WID2=WIDS(24,2)*WIDS(23,2)
17846 ELSE
17847 WID2=WIDS(24,3)*WIDS(23,2)
17848 ENDIF
17849 ELSEIF(I.EQ.2) THEN
17850C...rho_tc+ -> W+ + pi_tc0.
17851 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
17852 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
17853 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
17854 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
17855 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
17856 IF(KFLR.GT.0) THEN
17857 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+111),2)
17858 ELSE
17859 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+111),2)
17860 ENDIF
17861 ELSEIF(I.EQ.3) THEN
17862C...rho_tc+ -> pi_tc+ + Z0.
17863 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
17864 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
17865 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
17866 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMZ/SH)*
17867 & (1D0-RTCM(3)**2)/4D0/XW/XW1/24D0/RTCM(13)**2*SHR**3+
17868 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17869 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
17870 & SHR**3*XW/XW1
17871 IF(KFLR.GT.0) THEN
17872 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(23,2)
17873 ELSE
17874 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(23,2)
17875 ENDIF
17876 ELSEIF(I.EQ.4) THEN
17877C...rho_tc+ -> pi_tc+ + pi_tc0.
17878 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
17879 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17880 IF(KFLR.GT.0) THEN
17881 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(PYCOMP(KTECHN+111),2)
17882 ELSE
17883 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(PYCOMP(KTECHN+111),2)
17884 ENDIF
17885 ELSEIF(I.EQ.5) THEN
17886C...rho_tc+ -> pi_tc+ + gamma
17887 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17888 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
17889 & SHR**3
17890 IF(KFLR.GT.0) THEN
17891 WID2=WIDS(PYCOMP(KTECHN+211),2)
17892 ELSE
17893 WID2=WIDS(PYCOMP(KTECHN+211),3)
17894 ENDIF
17895 ELSEIF(I.EQ.6) THEN
17896C...rho_tc+ -> W+ + pi_tc0'
17897 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17898 & (1D0-RTCM(4)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3
17899 IF(KFLR.GT.0) THEN
17900 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+221),2)
17901 ELSE
17902 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+221),2)
17903 ENDIF
17904 ELSE
17905C...rho_tc+ -> f + fbar'.
17906 IA=I-6
17907 WID2=1D0
17908 IF(IA.LE.16) THEN
17909 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
17910 IF(KFLR.GT.0) THEN
17911 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
17912 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
17913 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
17914 ELSE
17915 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
17916 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
17917 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
17918 ENDIF
17919 ELSE
17920 FCOF=1D0
17921 IF(KFLR.GT.0) THEN
17922 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
17923 ELSE
17924 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
17925 ENDIF
17926 ENDIF
17927 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
17928 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17929 ENDIF
17930 WDTP(I)=FUDGE*WDTP(I)
17931 WDTP(0)=WDTP(0)+WDTP(I)
17932 IF(MDME(IDC,1).GT.0) THEN
17933 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17934 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17935 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17936 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17937 ENDIF
17938 380 CONTINUE
17939
17940 ELSEIF(KFLA.EQ.KTECHN+223) THEN
17941C...Techni-omega:
17942 ALPRHT=2.91D0*(3D0/ITCM(1))
17943 FAC=(ALPRHT/12D0)*SHR
17944 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR*(2D0*RTCM(2)-1D0)**2
17945 SQMZ=PMAS(23,1)**2
17946 SHP=SH
17947 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
17948 GMMZ=SHR*WDTPP(0)
17949 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
17950 BWZI=-(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
17951 DO 390 I=1,MDCY(KC,3)
17952 IDC=I+MDCY(KC,2)-1
17953 IF(MDME(IDC,1).LT.0) GOTO 390
17954 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17955 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17956 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390
17957 WID2=1D0
17958 IF(I.EQ.1) THEN
17959C...omega_tc0 -> gamma + pi_tc0.
17960 WDTP(I)=AEM/24D0/RTCM(12)**2*(1D0-RTCM(3)**2)*
17961 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*SHR**3
17962 WID2=WIDS(PYCOMP(KTECHN+111),2)
17963 ELSEIF(I.EQ.2) THEN
17964C...omega_tc0 -> Z0 + pi_tc0
17965 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17966 & (1D0-RTCM(3)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
17967 & XW/XW1*SHR**3
17968 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
17969 ELSEIF(I.EQ.3) THEN
17970C...omega_tc0 -> gamma + pi_tc0'
17971 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17972 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
17973 & SHR**3
17974 WID2=WIDS(PYCOMP(KTECHN+221),2)
17975 ELSEIF(I.EQ.4) THEN
17976C...omega_tc0 -> Z0 + pi_tc0'
17977 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17978 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
17979 & XW/XW1*SHR**3
17980 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
17981 ELSEIF(I.EQ.5) THEN
17982C...omega_tc0 -> W+ + pi_tc-
17983 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17984 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
17985 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
17986 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17987 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
17988 ELSEIF(I.EQ.6) THEN
17989C...omega_tc0 -> pi_tc+ + W-
17990 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17991 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
17992 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
17993 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17994 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
17995 ELSEIF(I.EQ.7) THEN
17996C...omega_tc0 -> W+ + W-.
17997 WDTP(I)=FAC*RTCM(3)**4*RTCM(11)**2*
17998 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17999 WID2=WIDS(24,1)
18000 ELSEIF(I.EQ.8) THEN
18001C...omega_tc0 -> pi_tc+ + pi_tc-.
18002 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*RTCM(11)**2*
18003 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
18004 WID2=WIDS(PYCOMP(KTECHN+211),1)
18005 ELSE
18006C...omega_tc0 -> f + fbar.
18007 WID2=1D0
18008 IF(I.LE.14) THEN
18009 IA=I-8
18010 FCOF=3D0*RADC
18011 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
18012 ELSE
18013 IA=I-6
18014 FCOF=1D0
18015 IF(IA.GE.17) WID2=WIDS(IA,1)
18016 ENDIF
18017 EI=KCHG(IA,1)/3D0
18018 AI=SIGN(1D0,EI+0.1D0)
18019 VI=AI-4D0*EI*XWV
18020 VALI=-0.5D0*(VI+AI)
18021 VARI=-0.5D0*(VI-AI)
18022 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
18023 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
18024 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
18025 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
18026 ENDIF
18027 WDTP(I)=FUDGE*WDTP(I)
18028 WDTP(0)=WDTP(0)+WDTP(I)
18029 IF(MDME(IDC,1).GT.0) THEN
18030 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18031 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18032 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18033 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18034 ENDIF
18035 390 CONTINUE
18036
18037C.....V8 -> quark anti-quark
18038 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
18039 FAC=AS/6D0*SHR
18040 TANT3=RTCM(21)
18041 IF(ITCM(2).EQ.0) THEN
18042 IMDL=1
18043 ELSEIF(ITCM(2).EQ.1) THEN
18044 IMDL=2
18045 ENDIF
18046 DO 400 I=1,MDCY(KC,3)
18047 IDC=I+MDCY(KC,2)-1
18048 IF(MDME(IDC,1).LT.0) GOTO 400
18049 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
18050 RM1=PM1**2/SH
18051 IF(RM1.GT.0.25D0) GOTO 400
18052 WID2=1D0
18053 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
18054 FMIX=1D0/TANT3**2
18055 ELSE
18056 FMIX=TANT3**2
18057 ENDIF
18058 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
18059 IF(I.EQ.6) WID2=WIDS(6,1)
18060 WDTP(I)=FUDGE*WDTP(I)
18061 WDTP(0)=WDTP(0)+WDTP(I)
18062 IF(MDME(IDC,1).GT.0) THEN
18063 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18064 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18065 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18066 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18067 ENDIF
18068 400 CONTINUE
18069
18070 ELSEIF(KFLA.EQ.KTECHN+100111.OR.KFLA.EQ.KTECHN+200111) THEN
18071 FAC=(1D0/(4D0*PARU(1)*RTCM(1)**2))*SHR
18072 CLEBF=0D0
18073 DO 410 I=1,MDCY(KC,3)
18074 IDC=I+MDCY(KC,2)-1
18075 IF(MDME(IDC,1).LT.0) GOTO 410
18076 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18077 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18078 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410
18079 WID2=1D0
18080C...pi_tc -> g + g
18081 IF(I.EQ.7) THEN
18082 IF(KFLA.EQ.KTECHN+100111) THEN
18083 CLEBG=4D0/3D0
18084 ELSE
18085 CLEBG=5D0/3D0
18086 ENDIF
18087 FACP=(AS/(8D0*PARU(1))*ITCM(1)/RTCM(1))**2
18088 & /(2D0*PARU(1))*SH*SHR*CLEBG
18089 WDTP(I)=FACP
18090 ELSE
18091C...pi_tc -> f + fbar.
18092 IF(I.EQ.6) WID2=WIDS(6,1)
18093 FCOF=1D0
18094 IKA=IABS(KFDP(IDC,1))
18095 IF(IKA.LT.10) FCOF=3D0*RADC
18096 HM1=PYMRUN(KFDP(IDC,1),SH)
18097 WDTP(I)=FAC*FCOF*HM1**2*CLEBF*
18098 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18099 ENDIF
18100 WDTP(I)=FUDGE*WDTP(I)
18101 WDTP(0)=WDTP(0)+WDTP(I)
18102 IF(MDME(IDC,1).GT.0) THEN
18103 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18104 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18105 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18106 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18107 ENDIF
18108 410 CONTINUE
18109
18110 ELSEIF(KFLA.GE.KTECHN+100113.AND.KFLA.LE.KTECHN+400113) THEN
18111 FAC=AS/6D0*SHR
18112 ALPRHT=2.91D0*(3D0/ITCM(1))
18113 TANT3=RTCM(21)
18114 SIN2T=2D0*TANT3/(TANT3**2+1D0)
18115 SINT3=TANT3/SQRT(TANT3**2+1D0)
18116 CSXPP=RTCM(22)
18117 RM82=RTCM(27)**2
18118 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
18119 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)
18120 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
18121 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)
18122 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
18123 & SINT3**2)*2D0
18124 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
18125 & SINT3**2)*2D0
18126 CALL PYWIDX(KTECHN+100021,SH,WDTPP,WDTEP)
18127
18128 IF(WDTPP(0).GT.RTCM(33)*SHR) WDTPP(0)=RTCM(33)*SHR
18129 GMV8=SHR*WDTPP(0)
18130 RMV8=PMAS(PYCOMP(KTECHN+100021),1)
18131 FV8RE=SH*(SH-RMV8**2)/((SH-RMV8**2)**2+GMV8**2)
18132 FV8IM=SH*GMV8/((SH-RMV8**2)**2+GMV8**2)
18133 IF(ITCM(2).EQ.0) THEN
18134 IMDL=1
18135 ELSE
18136 IMDL=2
18137 ENDIF
18138 DO 420 I=1,MDCY(KC,3)
18139 IF(I.EQ.7.AND.(KFLA.EQ.KTECHN+200113.OR.
18140 & KFLA.EQ.KTECHN+300113)) GOTO 420
18141 IDC=I+MDCY(KC,2)-1
18142 IF(MDME(IDC,1).LT.0) GOTO 420
18143 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18144 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18145 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 420
18146 WID2=1D0
18147 IF(I.LE.6) THEN
18148 IF(I.EQ.6) WID2=WIDS(6,1)
18149 XIG=1D0
18150 IF(KFLA.EQ.KTECHN+200113) THEN
18151 XIG=0D0
18152 XIJ=X12
18153 ELSEIF(KFLA.EQ.KTECHN+300113) THEN
18154 XIG=0D0
18155 XIJ=X21
18156 ELSEIF(KFLA.EQ.KTECHN+100113) THEN
18157 XIJ=X11
18158 ELSE
18159 XIJ=X22
18160 ENDIF
18161 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
18162 FMIX=1D0/TANT3/SIN2T
18163 ELSE
18164 FMIX=-TANT3/SIN2T
18165 ENDIF
18166 XFAC=(XIG+FMIX*XIJ*FV8RE)**2+(FMIX*XIJ*FV8IM)**2
18167 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*AS/ALPRHT*XFAC
18168 ELSEIF(I.EQ.7) THEN
18169 WDTP(I)=SHR*AS**2/(4D0*ALPRHT)
18170 ELSEIF(KFLA.EQ.KTECHN+400113.AND.I.LE.9) THEN
18171 PSH=SHR*(1D0-RM1)/2D0
18172 WDTP(I)=AS/9D0*PSH**3/RM82
18173 IF(I.EQ.8) THEN
18174 WDTP(I)=2D0*WDTP(I)*CSXPP**2
18175 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
18176 ELSE
18177 WDTP(I)=5D0*WDTP(I)
18178 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
18179 ENDIF
18180 ENDIF
18181 WDTP(I)=FUDGE*WDTP(I)
18182 WDTP(0)=WDTP(0)+WDTP(I)
18183 IF(MDME(IDC,1).GT.0) THEN
18184 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18185 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18186 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18187 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18188 ENDIF
18189 420 CONTINUE
18190
18191 ELSEIF(KFLA.EQ.KEXCIT+1) THEN
18192C...d* excited quark.
18193 FAC=(SH/RTCM(41)**2)*SHR
18194 DO 430 I=1,MDCY(KC,3)
18195 IDC=I+MDCY(KC,2)-1
18196 IF(MDME(IDC,1).LT.0) GOTO 430
18197 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18198 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18199 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 430
18200 WID2=1D0
18201 IF(I.EQ.1) THEN
18202C...d* -> g + d.
18203 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
18204 WID2=1D0
18205 ELSEIF(I.EQ.2) THEN
18206C...d* -> gamma + d.
18207 QF=-RTCM(43)/2D0+RTCM(44)/6D0
18208 WDTP(I)=FAC*AEM*QF**2/4D0
18209 WID2=1D0
18210 ELSEIF(I.EQ.3) THEN
18211C...d* -> Z0 + d.
18212 QF=-RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
18213 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
18214 & (1D0-RM1)**2*(2D0+RM1)
18215 WID2=WIDS(23,2)
18216 ELSEIF(I.EQ.4) THEN
18217C...d* -> W- + u.
18218 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
18219 & (1D0-RM1)**2*(2D0+RM1)
18220 IF(KFLR.GT.0) WID2=WIDS(24,3)
18221 IF(KFLR.LT.0) WID2=WIDS(24,2)
18222 ENDIF
18223 WDTP(I)=FUDGE*WDTP(I)
18224 WDTP(0)=WDTP(0)+WDTP(I)
18225 IF(MDME(IDC,1).GT.0) THEN
18226 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18227 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18228 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18229 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18230 ENDIF
18231 430 CONTINUE
18232
18233 ELSEIF(KFLA.EQ.KEXCIT+2) THEN
18234C...u* excited quark.
18235 FAC=(SH/RTCM(41)**2)*SHR
18236 DO 440 I=1,MDCY(KC,3)
18237 IDC=I+MDCY(KC,2)-1
18238 IF(MDME(IDC,1).LT.0) GOTO 440
18239 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18240 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18241 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 440
18242 WID2=1D0
18243 IF(I.EQ.1) THEN
18244C...u* -> g + u.
18245 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
18246 WID2=1D0
18247 ELSEIF(I.EQ.2) THEN
18248C...u* -> gamma + u.
18249 QF=RTCM(43)/2D0+RTCM(44)/6D0
18250 WDTP(I)=FAC*AEM*QF**2/4D0
18251 WID2=1D0
18252 ELSEIF(I.EQ.3) THEN
18253C...u* -> Z0 + u.
18254 QF=RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
18255 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
18256 & (1D0-RM1)**2*(2D0+RM1)
18257 WID2=WIDS(23,2)
18258 ELSEIF(I.EQ.4) THEN
18259C...u* -> W+ + d.
18260 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
18261 & (1D0-RM1)**2*(2D0+RM1)
18262 IF(KFLR.GT.0) WID2=WIDS(24,2)
18263 IF(KFLR.LT.0) WID2=WIDS(24,3)
18264 ENDIF
18265 WDTP(I)=FUDGE*WDTP(I)
18266 WDTP(0)=WDTP(0)+WDTP(I)
18267 IF(MDME(IDC,1).GT.0) THEN
18268 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18269 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18270 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18271 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18272 ENDIF
18273 440 CONTINUE
18274
18275 ELSEIF(KFLA.EQ.KEXCIT+11) THEN
18276C...e* excited lepton.
18277 FAC=(SH/RTCM(41)**2)*SHR
18278 DO 450 I=1,MDCY(KC,3)
18279 IDC=I+MDCY(KC,2)-1
18280 IF(MDME(IDC,1).LT.0) GOTO 450
18281 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18282 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18283 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 450
18284 WID2=1D0
18285 IF(I.EQ.1) THEN
18286C...e* -> gamma + e.
18287 QF=-RTCM(43)/2D0-RTCM(44)/2D0
18288 WDTP(I)=FAC*AEM*QF**2/4D0
18289 WID2=1D0
18290 ELSEIF(I.EQ.2) THEN
18291C...e* -> Z0 + e.
18292 QF=-RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
18293 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
18294 & (1D0-RM1)**2*(2D0+RM1)
18295 WID2=WIDS(23,2)
18296 ELSEIF(I.EQ.3) THEN
18297C...e* -> W- + nu.
18298 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
18299 & (1D0-RM1)**2*(2D0+RM1)
18300 IF(KFLR.GT.0) WID2=WIDS(24,3)
18301 IF(KFLR.LT.0) WID2=WIDS(24,2)
18302 ENDIF
18303 WDTP(I)=FUDGE*WDTP(I)
18304 WDTP(0)=WDTP(0)+WDTP(I)
18305 IF(MDME(IDC,1).GT.0) THEN
18306 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18307 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18308 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18309 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18310 ENDIF
18311 450 CONTINUE
18312
18313 ELSEIF(KFLA.EQ.KEXCIT+12) THEN
18314C...nu*_e excited neutrino.
18315 FAC=(SH/RTCM(41)**2)*SHR
18316 DO 460 I=1,MDCY(KC,3)
18317 IDC=I+MDCY(KC,2)-1
18318 IF(MDME(IDC,1).LT.0) GOTO 460
18319 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18320 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18321 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 460
18322 WID2=1D0
18323 IF(I.EQ.1) THEN
18324C...nu*_e -> Z0 + nu*_e.
18325 QF=RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
18326 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
18327 & (1D0-RM1)**2*(2D0+RM1)
18328 WID2=WIDS(23,2)
18329 ELSEIF(I.EQ.2) THEN
18330C...nu*_e -> W+ + e.
18331 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
18332 & (1D0-RM1)**2*(2D0+RM1)
18333 IF(KFLR.GT.0) WID2=WIDS(24,2)
18334 IF(KFLR.LT.0) WID2=WIDS(24,3)
18335 ENDIF
18336 WDTP(I)=FUDGE*WDTP(I)
18337 WDTP(0)=WDTP(0)+WDTP(I)
18338 IF(MDME(IDC,1).GT.0) THEN
18339 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18340 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18341 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18342 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18343 ENDIF
18344 460 CONTINUE
18345
18346 ELSEIF(KFLA.EQ.KDIMEN+39) THEN
18347C...G* (graviton resonance):
18348 FAC=(PARP(50)**2/PARU(1))*SHR
18349 DO 470 I=1,MDCY(KC,3)
18350 IDC=I+MDCY(KC,2)-1
18351 IF(MDME(IDC,1).LT.0) GOTO 470
18352 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18353 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18354 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 470
18355 WID2=1D0
18356 IF(I.LE.8) THEN
18357C...G* -> q + qbar
18358 FCOF=3D0*RADC
18359 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
18360 & PYHFTH(SH,SH*RM1,1D0)
18361 WDTP(I)=FAC*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
18362 & (1D0+8D0*RM1/3D0)/320D0
18363 IF(I.EQ.6) WID2=WIDS(6,1)
18364 IF(I.EQ.7.OR.I.EQ.8) WID2=WIDS(I,1)
18365 ELSEIF(I.LE.16) THEN
18366C...G* -> l+ + l-, nu + nubar
18367 FCOF=1D0
18368 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
18369 & (1D0+8D0*RM1/3D0)/320D0
18370 IF(I.EQ.15.OR.I.EQ.16) WID2=WIDS(2+I,1)
18371 ELSEIF(I.EQ.17) THEN
18372C...G* -> g + g.
18373 WDTP(I)=FAC/20D0
18374 ELSEIF(I.EQ.18) THEN
18375C...G* -> gamma + gamma.
18376 WDTP(I)=FAC/160D0
18377 ELSEIF(I.EQ.19) THEN
18378C...G* -> Z0 + Z0.
18379 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
18380 & 14D0*RM1/3D0+4D0*RM1**2)/160D0
18381 WID2=WIDS(23,1)
18382 ELSEIF(I.EQ.20) THEN
18383C...G* -> W+ + W-.
18384 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
18385 & 14D0*RM1/3D0+4D0*RM1**2)/80D0
18386 WID2=WIDS(24,1)
18387 ENDIF
18388 WDTP(I)=FUDGE*WDTP(I)
18389 WDTP(0)=WDTP(0)+WDTP(I)
18390 IF(MDME(IDC,1).GT.0) THEN
18391 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18392 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18393 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18394 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18395 ENDIF
18396 470 CONTINUE
18397
18398 ELSEIF(KFLA.EQ.9900012.OR.KFLA.EQ.9900014.OR.KFLA.EQ.9900016) THEN
18399C...nu_eR, nu_muR, nu_tauR: righthanded Majorana neutrinos.
18400 PMWR=MAX(1.001D0*SHR,PMAS(PYCOMP(9900024),1))
18401 FAC=(AEM**2/(768D0*PARU(1)*XW**2))*SHR**5/PMWR**4
18402 DO 480 I=1,MDCY(KC,3)
18403 IDC=I+MDCY(KC,2)-1
18404 IF(MDME(IDC,1).LT.0) GOTO 480
18405 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
18406 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
18407 PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
18408 IF(PM1+PM2+PM3.GE.SHR) GOTO 480
18409 WID2=1D0
18410 IF(I.LE.9) THEN
18411C...nu_lR -> l- qbar q'
18412 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
18413 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
18414 ELSEIF(I.LE.18) THEN
18415C...nu_lR -> l+ q qbar'
18416 FCOF=3D0*RADC*VCKM((I-10)/3+1,MOD(I-10,3)+1)
18417 IF(MOD(I-9,3).EQ.0) WID2=WIDS(6,3)
18418 ELSE
18419C...nu_lR -> l- l'+ nu_lR' + charge conjugate.
18420 FCOF=1D0
18421 WID2=WIDS(PYCOMP(KFDP(IDC,3)),2)
18422 ENDIF
18423 X=(PM1+PM2+PM3)/SHR
18424 FX=1D0-8D0*X**2+8D0*X**6-X**8-24D0*X**4*LOG(X)
18425 Y=(SHR/PMWR)**2
18426 FY=(12D0*(1D0-Y)*LOG(1D0-Y)+12D0*Y-6D0*Y**2-2D0*Y**3)/Y**4
18427 WDTP(I)=FAC*FCOF*FX*FY
18428 WDTP(I)=FUDGE*WDTP(I)
18429 WDTP(0)=WDTP(0)+WDTP(I)
18430 IF(MDME(IDC,1).GT.0) THEN
18431 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18432 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18433 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18434 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18435 ENDIF
18436 480 CONTINUE
18437
18438 ELSEIF(KFLA.EQ.9900023) THEN
18439C...Z_R0:
18440 FAC=(AEM/(48D0*XW*XW1*(1D0-2D0*XW)))*SHR
18441 DO 490 I=1,MDCY(KC,3)
18442 IDC=I+MDCY(KC,2)-1
18443 IF(MDME(IDC,1).LT.0) GOTO 490
18444 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18445 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18446 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 490
18447 WID2=1D0
18448 SYMMET=1D0
18449 IF(I.LE.6) THEN
18450C...Z_R0 -> q + qbar
18451 EF=KCHG(I,1)/3D0
18452 AF=SIGN(1D0,EF+0.1D0)*(1D0-2D0*XW)
18453 VF=SIGN(1D0,EF+0.1D0)-4D0*EF*XW
18454 FCOF=3D0*RADC
18455 IF(I.EQ.6) WID2=WIDS(6,1)
18456 ELSEIF(I.EQ.7.OR.I.EQ.10.OR.I.EQ.13) THEN
18457C...Z_R0 -> l+ + l-
18458 AF=-(1D0-2D0*XW)
18459 VF=-1D0+4D0*XW
18460 FCOF=1D0
18461 ELSEIF(I.EQ.8.OR.I.EQ.11.OR.I.EQ.14) THEN
18462C...Z0 -> nu_L + nu_Lbar, assumed Majorana.
18463 AF=-2D0*XW
18464 VF=0D0
18465 FCOF=1D0
18466 SYMMET=0.5D0
18467 ELSEIF(I.LE.15) THEN
18468C...Z0 -> nu_R + nu_R, assumed Majorana.
18469 AF=2D0*XW1
18470 VF=0D0
18471 FCOF=1D0
18472 WID2=WIDS(PYCOMP(KFDP(IDC,1)),1)
18473 SYMMET=0.5D0
18474 ENDIF
18475 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
18476 & SQRT(MAX(0D0,1D0-4D0*RM1))*SYMMET
18477 WDTP(I)=FUDGE*WDTP(I)
18478 WDTP(0)=WDTP(0)+WDTP(I)
18479 IF(MDME(IDC,1).GT.0) THEN
18480 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18481 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18482 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18483 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18484 ENDIF
18485 490 CONTINUE
18486
18487 ELSEIF(KFLA.EQ.9900024) THEN
18488C...W_R+/-:
18489 FAC=(AEM/(24D0*XW))*SHR
18490 DO 500 I=1,MDCY(KC,3)
18491 IDC=I+MDCY(KC,2)-1
18492 IF(MDME(IDC,1).LT.0) GOTO 500
18493 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18494 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18495 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 500
18496 WID2=1D0
18497 IF(I.LE.9) THEN
18498C...W_R+/- -> q + qbar'
18499 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
18500 IF(KFLR.GT.0) THEN
18501 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
18502 ELSE
18503 IF(MOD(I,3).EQ.0) WID2=WIDS(6,3)
18504 ENDIF
18505 ELSEIF(I.LE.12) THEN
18506C...W_R+/- -> l+/- + nu_R
18507 FCOF=1D0
18508 ENDIF
18509 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
18510 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18511 WDTP(I)=FUDGE*WDTP(I)
18512 WDTP(0)=WDTP(0)+WDTP(I)
18513 IF(MDME(IDC,1).GT.0) THEN
18514 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18515 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18516 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18517 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18518 ENDIF
18519 500 CONTINUE
18520
18521 ELSEIF(KFLA.EQ.9900041) THEN
18522C...H_L++/--:
18523 FAC=(1D0/(8D0*PARU(1)))*SHR
18524 DO 510 I=1,MDCY(KC,3)
18525 IDC=I+MDCY(KC,2)-1
18526 IF(MDME(IDC,1).LT.0) GOTO 510
18527 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18528 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18529 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 510
18530 WID2=1D0
18531 IF(I.LE.6) THEN
18532C...H_L++/-- -> l+/- + l'+/-
18533 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
18534 & (IABS(KFDP(IDC,2))-9)/2)**2
18535 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
18536 ELSEIF(I.EQ.7) THEN
18537C...H_L++/-- -> W_L+/- + W_L+/-
18538 FCOF=0.5D0*PARP(190)**4*PARP(192)**2/PMAS(24,1)**2*
18539 & (3D0*RM1+0.25D0/RM1-1D0)
18540 WID2=WIDS(24,4+(1-KFLS)/2)
18541 ENDIF
18542 WDTP(I)=FAC*FCOF*
18543 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18544 WDTP(I)=FUDGE*WDTP(I)
18545 WDTP(0)=WDTP(0)+WDTP(I)
18546 IF(MDME(IDC,1).GT.0) THEN
18547 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18548 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18549 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18550 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18551 ENDIF
18552 510 CONTINUE
18553
18554 ELSEIF(KFLA.EQ.9900042) THEN
18555C...H_R++/--:
18556 FAC=(1D0/(8D0*PARU(1)))*SHR
18557 DO 520 I=1,MDCY(KC,3)
18558 IDC=I+MDCY(KC,2)-1
18559 IF(MDME(IDC,1).LT.0) GOTO 520
18560 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18561 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18562 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 520
18563 WID2=1D0
18564 IF(I.LE.6) THEN
18565C...H_R++/-- -> l+/- + l'+/-
18566 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
18567 & (IABS(KFDP(IDC,2))-9)/2)**2
18568 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
18569 ELSEIF(I.EQ.7) THEN
18570C...H_R++/-- -> W_R+/- + W_R+/-
18571 FCOF=PARP(191)**2*(3D0*RM1+0.25D0/RM1-1D0)
18572 WID2=WIDS(PYCOMP(9900024),4+(1-KFLS)/2)
18573 ENDIF
18574 WDTP(I)=FAC*FCOF*
18575 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18576 WDTP(I)=FUDGE*WDTP(I)
18577 WDTP(0)=WDTP(0)+WDTP(I)
18578 IF(MDME(IDC,1).GT.0) THEN
18579 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18580 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18581 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18582 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18583 ENDIF
18584 520 CONTINUE
18585
18586 ENDIF
18587 MINT(61)=0
18588 MINT(62)=0
18589 MINT(63)=0
18590 RETURN
18591 END
18592
18593C***********************************************************************
18594
18595C...PYOFSH
18596C...Calculates partial width and differential cross-section maxima
18597C...of channels/processes not allowed on mass-shell, and selects
18598C...masses in such channels/processes.
18599
18600 SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
18601
18602C...Double precision and integer declarations.
18603 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
18604 IMPLICIT INTEGER(I-N)
18605 INTEGER PYK,PYCHGE,PYCOMP
18606C...Commonblocks.
18607 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
18608 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
18609 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
18610 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
18611 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
18612 COMMON/PYINT1/MINT(400),VINT(400)
18613 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
18614 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
18615 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
18616 &/PYINT2/,/PYINT5/
18617C...Local arrays.
18618 DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2),
18619 &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100),
18620 &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:400),
18621 &WDTE(0:400,0:5)
18622
18623C...Find if particles equal, maximum mass, matrix elements, etc.
18624 MINT(51)=0
18625 ISUB=MINT(1)
18626 KFD(1)=IABS(KFD1)
18627 KFD(2)=IABS(KFD2)
18628 MEQL=0
18629 IF(KFD(1).EQ.KFD(2)) MEQL=1
18630 MLM=0
18631 IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0))
18632 IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN
18633 NOFF=44
18634 PMMX=PMMO
18635 ELSE
18636 NOFF=40
18637 PMMX=VINT(1)
18638 IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1))
18639 ENDIF
18640 MMED=0
18641 IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
18642 &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
18643 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR.
18644 &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2
18645 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR.
18646 &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3
18647 LOOP=1
18648
18649C...Find where Breit-Wigners are required, else select discrete masses.
18650 100 DO 110 I=1,2
18651 KFCA=PYCOMP(KFD(I))
18652 IF(KFCA.GT.0) THEN
18653 PMD(I)=PMAS(KFCA,1)
18654 PGD(I)=PMAS(KFCA,2)
18655 ELSE
18656 PMD(I)=0D0
18657 PGD(I)=0D0
18658 ENDIF
18659 IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN
18660 MBW(I)=0
18661 PMG(I)=PMD(I)
18662 RMG(I)=(PMG(I)/PMMX)**2
18663 ELSE
18664 MBW(I)=1
18665 ENDIF
18666 110 CONTINUE
18667
18668C...Find allowed mass range and Breit-Wigner parameters.
18669 DO 120 I=1,2
18670 IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN
18671 PML(I)=PARP(42)
18672 PMU(I)=PMMX-PARP(42)
18673 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
18674 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
18675 ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN
18676 ILM=I
18677 IF(MLM.EQ.2) ILM=3-I
18678 PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42))
18679 IF(MBW(3-I).EQ.0) THEN
18680 PMU(I)=PMMX-PMD(3-I)
18681 ELSE
18682 PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42))
18683 ENDIF
18684 IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=
18685 & MIN(PMU(I),CKIN(NOFF+2*ILM))
18686 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
18687 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
18688 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
18689 IF(MBW(I).EQ.1) THEN
18690 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
18691 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
18692 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
18693 & PGD(I)))
18694 ENDIF
18695 ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN
18696 ILM=I
18697 IF(MLM.EQ.2) ILM=3-I
18698 PML(I)=MAX(CKIN(48+I),PARP(42))
18699 PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42))
18700 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
18701 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
18702 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
18703 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
18704 IF(MBW(I).EQ.1) THEN
18705 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
18706 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
18707 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
18708 & PGD(I)))
18709 ENDIF
18710 ENDIF
18711 120 CONTINUE
18712 IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0))
18713 &THEN
18714 CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses')
18715 MINT(51)=1
18716 RETURN
18717 ENDIF
18718
18719C...Calculation of partial width of resonance.
18720 IF(MOFSH.EQ.1) THEN
18721
18722C..If only one integration, pick that to be the inner.
18723 IF(MBW(1).EQ.0) THEN
18724 PM2=PMD(1)
18725 PMD(1)=PMD(2)
18726 PGD(1)=PGD(2)
18727 PML(1)=PML(2)
18728 PMU(1)=PMU(2)
18729 ELSEIF(MBW(2).EQ.0) THEN
18730 PM2=PMD(2)
18731 ENDIF
18732
18733C...Start outer loop of integration.
18734 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
18735 ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
18736 ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
18737 NPT2=1
18738 XPT2(1)=1D0
18739 INX2(1)=0
18740 FMAX2=0D0
18741 ENDIF
18742 130 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
18743 PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2))
18744 PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S))))
18745 ENDIF
18746 RM2=(PM2/PMMX)**2
18747
18748C...Start inner loop of integration.
18749 PML1=PML(1)
18750 PMU1=MIN(PMU(1),PMMX-PM2)
18751 IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2)
18752 ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
18753 ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
18754 IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN
18755 FUNC2=0D0
18756 GOTO 180
18757 ENDIF
18758 NPT1=1
18759 XPT1(1)=1D0
18760 INX1(1)=0
18761 FMAX1=0D0
18762 140 PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1))
18763 PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S))))
18764 RM1=(PM1/PMMX)**2
18765
18766C...Evaluate function value - inner loop.
18767 FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18768 IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2)
18769 IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+
18770 & RM2**2+10D0*RM1*RM2)
18771 IF(FUNC1.GT.FMAX1) FMAX1=FUNC1
18772 FPT1(NPT1)=FUNC1
18773
18774C...Go to next position in inner loop.
18775 IF(NPT1.EQ.1) THEN
18776 NPT1=NPT1+1
18777 XPT1(NPT1)=0D0
18778 INX1(NPT1)=1
18779 GOTO 140
18780 ELSEIF(NPT1.LE.8) THEN
18781 NPT1=NPT1+1
18782 IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1
18783 ISH1=ISH1+1
18784 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
18785 INX1(NPT1)=INX1(ISH1)
18786 INX1(ISH1)=NPT1
18787 GOTO 140
18788 ELSEIF(NPT1.LT.100) THEN
18789 ISN1=ISH1
18790 150 ISH1=ISH1+1
18791 IF(ISH1.GT.NPT1) ISH1=2
18792 IF(ISH1.EQ.ISN1) GOTO 160
18793 DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1)))
18794 IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150
18795 NPT1=NPT1+1
18796 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
18797 INX1(NPT1)=INX1(ISH1)
18798 INX1(ISH1)=NPT1
18799 GOTO 140
18800 ENDIF
18801
18802C...Calculate integral over inner loop.
18803 160 FSUM1=0D0
18804 DO 170 IPT1=2,NPT1
18805 FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))*
18806 & (XPT1(INX1(IPT1))-XPT1(IPT1))
18807 170 CONTINUE
18808 FUNC2=FSUM1*(ATU1-ATL1)/PARU(1)
18809 180 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
18810 IF(FUNC2.GT.FMAX2) FMAX2=FUNC2
18811 FPT2(NPT2)=FUNC2
18812
18813C...Go to next position in outer loop.
18814 IF(NPT2.EQ.1) THEN
18815 NPT2=NPT2+1
18816 XPT2(NPT2)=0D0
18817 INX2(NPT2)=1
18818 GOTO 130
18819 ELSEIF(NPT2.LE.8) THEN
18820 NPT2=NPT2+1
18821 IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1
18822 ISH2=ISH2+1
18823 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
18824 INX2(NPT2)=INX2(ISH2)
18825 INX2(ISH2)=NPT2
18826 GOTO 130
18827 ELSEIF(NPT2.LT.100) THEN
18828 ISN2=ISH2
18829 190 ISH2=ISH2+1
18830 IF(ISH2.GT.NPT2) ISH2=2
18831 IF(ISH2.EQ.ISN2) GOTO 200
18832 DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2)))
18833 IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190
18834 NPT2=NPT2+1
18835 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
18836 INX2(NPT2)=INX2(ISH2)
18837 INX2(ISH2)=NPT2
18838 GOTO 130
18839 ENDIF
18840
18841C...Calculate integral over outer loop.
18842 200 FSUM2=0D0
18843 DO 210 IPT2=2,NPT2
18844 FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))*
18845 & (XPT2(INX2(IPT2))-XPT2(IPT2))
18846 210 CONTINUE
18847 FSUM2=FSUM2*(ATU2-ATL2)/PARU(1)
18848 IF(MEQL.EQ.1) FSUM2=2D0*FSUM2
18849 ELSE
18850 FSUM2=FUNC2
18851 ENDIF
18852
18853C...Save result; second integration for user-selected mass range.
18854 IF(LOOP.EQ.1) WIDW=FSUM2
18855 WID2=FSUM2
18856 IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47)
18857 & .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN
18858 LOOP=2
18859 GOTO 100
18860 ENDIF
18861 RET1=WIDW
18862 RET2=WID2/WIDW
18863
18864C...Select two decay product masses of a resonance.
18865 ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN
18866 220 DO 230 I=1,2
18867 IF(MBW(I).EQ.0) GOTO 230
18868 PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*
18869 & (ATU(I)-ATL(I)))
18870 PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW))))
18871 RMG(I)=(PMG(I)/PMMX)**2
18872 230 CONTINUE
18873 IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
18874 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220
18875
18876C...Weight with matrix element (if none known, use beta factor).
18877 FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2)))
18878 IF(MMED.EQ.1) THEN
18879 WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2))
18880 ELSEIF(MMED.EQ.2) THEN
18881 WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+
18882 & RMG(2)**2+10D0*RMG(1)*RMG(2))
18883 ELSEIF(MMED.EQ.3) THEN
18884 WTBE=FLAM*(RMG(1)+FLAM**2/12D0)
18885 ELSE
18886 WTBE=FLAM
18887 ENDIF
18888 IF(WTBE.LT.PYR(0)) GOTO 220
18889 RET1=PMG(1)
18890 RET2=PMG(2)
18891
18892C...Find suitable set of masses for initialization of 2 -> 2 processes.
18893 ELSEIF(MOFSH.EQ.3) THEN
18894 IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN
18895 PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1)))
18896 PMG(2)=PMD(2)
18897 ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN
18898 PMG(1)=PMD(1)
18899 PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2)))
18900 ELSE
18901 IDIV=-1
18902 240 IDIV=IDIV+1
18903 PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1)))
18904 PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2)))
18905 IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240
18906 ENDIF
18907 RET1=PMG(1)
18908 RET2=PMG(2)
18909
18910C...Evaluate importance of excluded tails of Breit-Wigners.
18911 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
18912 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
18913 IF(MEQL.LE.1) THEN
18914 VINT(80)=1D0
18915 DO 250 I=1,2
18916 IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/
18917 & PARU(1)
18918 250 CONTINUE
18919 ELSE
18920 VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))*
18921 & (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2)))
18922 ENDIF
18923 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND.
18924 & MSTP(43).NE.2) VINT(80)=2D0*VINT(80)
18925 IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80)
18926 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
18927
18928C...Pick one particle to be the lighter (if improves efficiency).
18929 ELSEIF(MOFSH.EQ.4) THEN
18930 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
18931 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
18932 260 IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0))
18933
18934C...Select two masses according to Breit-Wigner + flat in s + 1/s.
18935 DO 270 I=1,2
18936 IF(MBW(I).EQ.0) GOTO 270
18937 PMV=PMU(I)
18938 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
18939 ATV=ATU(I)
18940 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
18941 RBR=PYR(0)
18942 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
18943 & ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR
18944 IF(RBR.LT.0.8D0) THEN
18945 PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I)))
18946 PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR))))
18947 ELSEIF(RBR.LT.0.9D0) THEN
18948 PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2)))
18949 ELSEIF(RBR.LT.1.5D0) THEN
18950 PMG(I)=PML(I)*(PMV/PML(I))**PYR(0)
18951 ELSE
18952 PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)*
18953 & (PMV**2-PML(I)**2))))
18954 ENDIF
18955 270 CONTINUE
18956 IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
18957 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN
18958 IF(MINT(48).EQ.1) THEN
18959 NGEN(0,1)=NGEN(0,1)+1
18960 NGEN(MINT(1),1)=NGEN(MINT(1),1)+1
18961 GOTO 260
18962 ELSE
18963 MINT(51)=1
18964 RETURN
18965 ENDIF
18966 ENDIF
18967 RET1=PMG(1)
18968 RET2=PMG(2)
18969
18970C...Give weight for selected mass distribution.
18971 VINT(80)=1D0
18972 DO 280 I=1,2
18973 IF(MBW(I).EQ.0) GOTO 280
18974 PMV=PMU(I)
18975 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
18976 ATV=ATU(I)
18977 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
18978 F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+
18979 & (PMD(I)*PGD(I))**2)/PARU(1)
18980 F1=1D0
18981 F2=1D0/PMG(I)**2
18982 F3=1D0/PMG(I)**4
18983 FI0=(ATV-ATL(I))/PARU(1)
18984 FI1=PMV**2-PML(I)**2
18985 FI2=2D0*LOG(PMV/PML(I))
18986 FI3=1D0/PML(I)**2-1D0/PMV**2
18987 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
18988 & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
18989 VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+
18990 & 5D0*F3/FI3))
18991 ELSE
18992 VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2))
18993 ENDIF
18994 VINT(80)=VINT(80)*FI0
18995 280 CONTINUE
18996 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
18997 ENDIF
18998
18999 RETURN
19000 END
19001
19002C***********************************************************************
19003
19004C...PYRECO
19005C...Handles the possibility of colour reconnection in W+W- events,
19006C...Based on the main scenarios of the Sjostrand and Khoze study:
19007C...I, II, II', intermediate and instantaneous; plus one model
19008C...along the lines of the Gustafson and Hakkinen: GH.
19009C...Note: also handles Z0 Z0 and W-W+ events, but notation below
19010C...is as if first resonance is W+ and second W-.
19011
19012 SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
19013
19014C...Double precision and integer declarations.
19015 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19016 IMPLICIT INTEGER(I-N)
19017 INTEGER PYK,PYCHGE,PYCOMP
19018C...Parameter value; number of points in MC integration.
19019 PARAMETER (NPT=100)
19020C...Commonblocks.
19021 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19022 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19023 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19024 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19025 COMMON/PYINT1/MINT(400),VINT(400)
19026 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
19027C...Local arrays.
19028 DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
19029 &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
19030 &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
19031 &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
19032 &TMC(20),IJOIN(100)
19033
19034C...Functions to give four-product and to do determinants.
19035 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)
19036 DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+
19037 &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+
19038 &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3)
19039
19040C...Only allow fraction of recoupling for GH, intermediate and
19041C...instantaneous.
19042 IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
19043 IF(PYR(0).GT.PARP(120)) RETURN
19044 ENDIF
19045 ISUB=MINT(1)
19046
19047C...Common part for scenarios I, II, II', and GH.
19048 IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
19049 &MSTP(115).EQ.5) THEN
19050
19051C...Read out frequently-used parameters.
19052 PI=PARU(1)
19053 HBAR=PARU(3)
19054 PMW=PMAS(24,1)
19055 IF(ISUB.EQ.22) PMW=PMAS(23,1)
19056 PGW=PMAS(24,2)
19057 IF(ISUB.EQ.22) PGW=PMAS(23,2)
19058 TFRAG=PARP(115)
19059 RHAD=PARP(116)
19060 FACT=PARP(117)
19061 BLOWR=PARP(118)
19062 BLOWT=PARP(119)
19063
19064C...Find range of decay products of the W's.
19065C...Background: the W's are stored in IW1 and IW2.
19066C...Their direct decay products in NSD1+1 through NSD1+4.
19067C...Products after shower (if any) in NSD1+5 through NAFT1
19068C...for first W and in NAFT1+1 through N for the second.
19069 IF(NAFT1.GT.NSD1+4) THEN
19070 NBEG(1)=NSD1+5
19071 NEND(1)=NAFT1
19072 ELSE
19073 NBEG(1)=NSD1+1
19074 NEND(1)=NSD1+2
19075 ENDIF
19076 IF(N.GT.NAFT1) THEN
19077 NBEG(2)=NAFT1+1
19078 NEND(2)=N
19079 ELSE
19080 NBEG(2)=NSD1+3
19081 NEND(2)=NSD1+4
19082 ENDIF
19083
19084C...Rearrange parton shower products along strings.
19085 NOLD=N
19086 CALL PYPREP(NSD1+1)
19087
19088C...Find partons pointing back to W+ and W-; store them with quark
19089C...end of string first.
19090 NNP=0
19091 NNM=0
19092 ISGP=0
19093 ISGM=0
19094 DO 120 I=NOLD+1,N
19095 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
19096 IF(IABS(K(I,2)).GE.22) GOTO 120
19097 IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
19098 IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
19099 NNP=NNP+1
19100 IF(ISGP.EQ.1) THEN
19101 INP(NNP)=I
19102 ELSE
19103 DO 100 I1=NNP,2,-1
19104 INP(I1)=INP(I1-1)
19105 100 CONTINUE
19106 INP(1)=I
19107 ENDIF
19108 IF(K(I,1).EQ.1) ISGP=0
19109 ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
19110 IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
19111 NNM=NNM+1
19112 IF(ISGM.EQ.1) THEN
19113 INM(NNM)=I
19114 ELSE
19115 DO 110 I1=NNM,2,-1
19116 INM(I1)=INM(I1-1)
19117 110 CONTINUE
19118 INM(1)=I
19119 ENDIF
19120 IF(K(I,1).EQ.1) ISGM=0
19121 ENDIF
19122 120 CONTINUE
19123
19124C...Boost to W+W- rest frame (not strictly needed).
19125 DO 130 J=1,3
19126 BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
19127 130 CONTINUE
19128 CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
19129 CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
19130 CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
19131
19132C...Select decay vertices of W+ and W-.
19133 TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/
19134 & SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2)
19135 TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/
19136 & SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2)
19137 GTMAX=MAX(TP,TM)
19138 DO 140 J=1,3
19139 XP(J)=TP*P(IW1,J)/P(IW1,4)
19140 XM(J)=TM*P(IW2,J)/P(IW2,4)
19141 140 CONTINUE
19142
19143C...Begin scenario I specifics.
19144 IF(MSTP(115).EQ.1) THEN
19145
19146C...Reconstruct velocity and direction of W+ string pieces.
19147 DO 170 IIP=1,NNP-1
19148 IF(K(INP(IIP),2).LT.0) GOTO 170
19149 I1=INP(IIP)
19150 I2=INP(IIP+1)
19151 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
19152 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
19153 DO 150 J=1,3
19154 V1(J)=P(I1,J)/P1A
19155 V2(J)=P(I2,J)/P2A
19156 BETP(IIP,J)=0.5D0*(V1(J)+V2(J))
19157 DIRP(IIP,J)=V1(J)-V2(J)
19158 150 CONTINUE
19159 BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2-
19160 & BETP(IIP,3)**2)
19161 DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2)
19162 DO 160 J=1,3
19163 DIRP(IIP,J)=DIRP(IIP,J)/DIRL
19164 160 CONTINUE
19165 170 CONTINUE
19166
19167C...Reconstruct velocity and direction of W- string pieces.
19168 DO 200 IIM=1,NNM-1
19169 IF(K(INM(IIM),2).LT.0) GOTO 200
19170 I1=INM(IIM)
19171 I2=INM(IIM+1)
19172 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
19173 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
19174 DO 180 J=1,3
19175 V1(J)=P(I1,J)/P1A
19176 V2(J)=P(I2,J)/P2A
19177 BETM(IIM,J)=0.5D0*(V1(J)+V2(J))
19178 DIRM(IIM,J)=V1(J)-V2(J)
19179 180 CONTINUE
19180 BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2-
19181 & BETM(IIM,3)**2)
19182 DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2)
19183 DO 190 J=1,3
19184 DIRM(IIM,J)=DIRM(IIM,J)/DIRL
19185 190 CONTINUE
19186 200 CONTINUE
19187
19188C...Loop over number of space-time points.
19189 NACC=0
19190 SUM=0D0
19191 DO 250 IPT=1,NPT
19192
19193C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
19194 R=SQRT(-LOG(PYR(0)))
19195 PHI=2D0*PI*PYR(0)
19196 X=BLOWR*RHAD*R*COS(PHI)
19197 Y=BLOWR*RHAD*R*SIN(PHI)
19198 R=SQRT(-LOG(PYR(0)))
19199 PHI=2D0*PI*PYR(0)
19200 Z=BLOWR*RHAD*R*COS(PHI)
19201 T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI))
19202
19203C...Reject impossible points. Weight for sample distribution.
19204 IF(T**2-X**2-Y**2-Z**2.LT.0D0) GOTO 250
19205 WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)*
19206 & EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2)
19207
19208C...Loop over W+ string pieces and find one with largest weight.
19209 IMAXP=0
19210 WTMAXP=1D-10
19211 XD(1)=X-XP(1)
19212 XD(2)=Y-XP(2)
19213 XD(3)=Z-XP(3)
19214 XD(4)=T-TP
19215 DO 220 IIP=1,NNP-1
19216 IF(K(INP(IIP),2).LT.0) GOTO 220
19217 BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3)
19218 BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4))
19219 DO 210 J=1,3
19220 XB(J)=XD(J)+BEDG*BETP(IIP,J)
19221 210 CONTINUE
19222 XB(4)=BETP(IIP,4)*(XD(4)-BED)
19223 SR2=XB(1)**2+XB(2)**2+XB(3)**2
19224 SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+
19225 & DIRP(IIP,3)*XB(3))**2
19226 WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
19227 & TFRAG**2)
19228 IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0
19229 IF(WTP.GT.WTMAXP) THEN
19230 IMAXP=IIP
19231 WTMAXP=WTP
19232 ENDIF
19233 220 CONTINUE
19234
19235C...Loop over W- string pieces and find one with largest weight.
19236 IMAXM=0
19237 WTMAXM=1D-10
19238 XD(1)=X-XM(1)
19239 XD(2)=Y-XM(2)
19240 XD(3)=Z-XM(3)
19241 XD(4)=T-TM
19242 DO 240 IIM=1,NNM-1
19243 IF(K(INM(IIM),2).LT.0) GOTO 240
19244 BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3)
19245 BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4))
19246 DO 230 J=1,3
19247 XB(J)=XD(J)+BEDG*BETM(IIM,J)
19248 230 CONTINUE
19249 XB(4)=BETM(IIM,4)*(XD(4)-BED)
19250 SR2=XB(1)**2+XB(2)**2+XB(3)**2
19251 SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+
19252 & DIRM(IIM,3)*XB(3))**2
19253 WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
19254 & TFRAG**2)
19255 IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0
19256 IF(WTM.GT.WTMAXM) THEN
19257 IMAXM=IIM
19258 WTMAXM=WTM
19259 ENDIF
19260 240 CONTINUE
19261
19262C...Result of integration.
19263 WT=0D0
19264 IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN
19265 WT=WTMAXP*WTMAXM/WTSMP
19266 SUM=SUM+WT
19267 NACC=NACC+1
19268 IAP(NACC)=IMAXP
19269 IAM(NACC)=IMAXM
19270 WTA(NACC)=WT
19271 ENDIF
19272 250 CONTINUE
19273 RES=BLOWR**3*BLOWT*SUM/NPT
19274
19275C...Decide whether to reconnect and, if so, where.
19276 IACC=0
19277 PREC=1D0-EXP(-FACT*RES)
19278 IF(PREC.GT.PYR(0)) THEN
19279 RSUM=PYR(0)*SUM
19280 DO 260 IA=1,NACC
19281 IACC=IA
19282 RSUM=RSUM-WTA(IA)
19283 IF(RSUM.LE.0D0) GOTO 270
19284 260 CONTINUE
19285 270 IIP=IAP(IACC)
19286 IIM=IAM(IACC)
19287 ENDIF
19288
19289C...Begin scenario II and II' specifics.
19290 ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN
19291
19292C...Loop through all string pieces, one from W+ and one from W-.
19293 NCROSS=0
19294 TC(0)=0D0
19295 DO 340 IIP=1,NNP-1
19296 IF(K(INP(IIP),2).LT.0) GOTO 340
19297 I1P=INP(IIP)
19298 I2P=INP(IIP+1)
19299 DO 330 IIM=1,NNM-1
19300 IF(K(INM(IIM),2).LT.0) GOTO 330
19301 I1M=INM(IIM)
19302 I2M=INM(IIM+1)
19303
19304C...Find endpoint velocity vectors.
19305 DO 280 J=1,3
19306 V1P(J)=P(I1P,J)/P(I1P,4)
19307 V2P(J)=P(I2P,J)/P(I2P,4)
19308 V1M(J)=P(I1M,J)/P(I1M,4)
19309 V2M(J)=P(I2M,J)/P(I2M,4)
19310 280 CONTINUE
19311
19312C...Define q matrix and find t.
19313 DO 290 J=1,3
19314 Q(1,J)=V2P(J)-V1P(J)
19315 Q(2,J)=-(V2M(J)-V1M(J))
19316 Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J)
19317 Q(4,J)=V1P(J)-V1M(J)
19318 290 CONTINUE
19319 T=-DETER(1,2,3)/DETER(1,2,4)
19320
19321C...Find alpha and beta; i.e. coordinates of crossing point.
19322 S11=Q(1,1)*(T-TP)
19323 S12=Q(2,1)*(T-TM)
19324 S13=Q(3,1)+Q(4,1)*T
19325 S21=Q(1,2)*(T-TP)
19326 S22=Q(2,2)*(T-TM)
19327 S23=Q(3,2)+Q(4,2)*T
19328 DEN=S11*S22-S12*S21
19329 ALP=(S12*S23-S22*S13)/DEN
19330 BET=(S21*S13-S11*S23)/DEN
19331
19332C...Check if solution acceptable.
19333 IANSW=1
19334 IF(T.LT.GTMAX) IANSW=0
19335 IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
19336 IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
19337
19338C...Find point of crossing and check that not inconsistent.
19339 DO 300 J=1,3
19340 XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP)
19341 XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM)
19342 300 CONTINUE
19343 D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+
19344 & (XPP(3)-XMM(3))**2
19345 D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2
19346 D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2
19347 IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
19348
19349C...Find string eigentimes at crossing.
19350 IF(IANSW.EQ.1) THEN
19351 TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2-
19352 & (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2))
19353 TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2-
19354 & (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2))
19355 ELSE
19356 TAUP=0D0
19357 TAUM=0D0
19358 ENDIF
19359
19360C...Order crossings by time. End loop over crossings.
19361 IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
19362 NCROSS=NCROSS+1
19363 DO 310 I1=NCROSS,1,-1
19364 IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
19365 IPC(I1)=IIP
19366 IMC(I1)=IIM
19367 TC(I1)=T
19368 TPC(I1)=TAUP
19369 TMC(I1)=TAUM
19370 GOTO 320
19371 ELSE
19372 IPC(I1)=IPC(I1-1)
19373 IMC(I1)=IMC(I1-1)
19374 TC(I1)=TC(I1-1)
19375 TPC(I1)=TPC(I1-1)
19376 TMC(I1)=TMC(I1-1)
19377 ENDIF
19378 310 CONTINUE
19379 320 CONTINUE
19380 ENDIF
19381 330 CONTINUE
19382 340 CONTINUE
19383
19384C...Loop over crossings; find first (if any) acceptable one.
19385 IACC=0
19386 IF(NCROSS.GE.1) THEN
19387 DO 350 IC=1,NCROSS
19388 PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2)
19389 IF(PNFRAG.GT.PYR(0)) THEN
19390C...Scenario II: only compare with fragmentation time.
19391 IF(MSTP(115).EQ.2) THEN
19392 IACC=IC
19393 IIP=IPC(IACC)
19394 IIM=IMC(IACC)
19395 GOTO 360
19396C...Scenario II': also require that string length decreases.
19397 ELSE
19398 IIP=IPC(IC)
19399 IIM=IMC(IC)
19400 I1P=INP(IIP)
19401 I2P=INP(IIP+1)
19402 I1M=INM(IIM)
19403 I2M=INM(IIM+1)
19404 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
19405 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
19406 IF(ELNEW.LT.ELOLD) THEN
19407 IACC=IC
19408 IIP=IPC(IACC)
19409 IIM=IMC(IACC)
19410 GOTO 360
19411 ENDIF
19412 ENDIF
19413 ENDIF
19414 350 CONTINUE
19415 360 CONTINUE
19416 ENDIF
19417
19418C...Begin scenario GH specifics.
19419 ELSEIF(MSTP(115).EQ.5) THEN
19420
19421C...Loop through all string pieces, one from W+ and one from W-.
19422 IACC=0
19423 ELMIN=1D0
19424 DO 380 IIP=1,NNP-1
19425 IF(K(INP(IIP),2).LT.0) GOTO 380
19426 I1P=INP(IIP)
19427 I2P=INP(IIP+1)
19428 DO 370 IIM=1,NNM-1
19429 IF(K(INM(IIM),2).LT.0) GOTO 370
19430 I1M=INM(IIM)
19431 I2M=INM(IIM+1)
19432
19433C...Look for largest decrease of (exponent of) Lambda measure.
19434 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
19435 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
19436 ELDIF=ELNEW/MAX(1D-10,ELOLD)
19437 IF(ELDIF.LT.ELMIN) THEN
19438 IACC=IIP+IIM
19439 ELMIN=ELDIF
19440 IPC(1)=IIP
19441 IMC(1)=IIM
19442 ENDIF
19443 370 CONTINUE
19444 380 CONTINUE
19445 IIP=IPC(1)
19446 IIM=IMC(1)
19447 ENDIF
19448
19449C...Common for scenarios I, II, II' and GH: reconnect strings.
19450 IF(IACC.NE.0) THEN
19451 MINT(32)=1
19452 NJOIN=0
19453 DO 390 IS=1,NNP+NNM
19454 NJOIN=NJOIN+1
19455 IF(IS.LE.IIP) THEN
19456 I=INP(IS)
19457 ELSEIF(IS.LE.IIP+NNM-IIM) THEN
19458 I=INM(IS-IIP+IIM)
19459 ELSEIF(IS.LE.IIP+NNM) THEN
19460 I=INM(IS-IIP-NNM+IIM)
19461 ELSE
19462 I=INP(IS-NNM)
19463 ENDIF
19464 IJOIN(NJOIN)=I
19465 IF(K(I,2).LT.0) THEN
19466 CALL PYJOIN(NJOIN,IJOIN)
19467 NJOIN=0
19468 ENDIF
19469 390 CONTINUE
19470
19471C...Restore original event record if no reconnection.
19472 ELSE
19473 DO 400 I=NSD1+1,NOLD
19474 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
19475 K(I,4)=MOD(K(I,4),MSTU(5)**2)
19476 K(I,5)=MOD(K(I,5),MSTU(5)**2)
19477 ENDIF
19478 400 CONTINUE
19479 DO 410 I=NOLD+1,N
19480 K(K(I,3),1)=3
19481 410 CONTINUE
19482 N=NOLD
19483 ENDIF
19484
19485C...Boost back system.
19486 CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
19487 CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
19488 IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
19489 & BEWW(1),BEWW(2),BEWW(3))
19490
19491C...Common part for intermediate and instantaneous scenarios.
19492 ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
19493 MINT(32)=1
19494
19495C...Remove old shower products and reset showering ones.
19496 N=NSD1+4
19497 DO 420 I=NSD1+1,NSD1+4
19498 K(I,1)=3
19499 K(I,4)=MOD(K(I,4),MSTU(5)**2)
19500 K(I,5)=MOD(K(I,5),MSTU(5)**2)
19501 420 CONTINUE
19502
19503C...Identify quark-antiquark pairs.
19504 IQ1=NSD1+1
19505 IQ2=NSD1+2
19506 IQ3=NSD1+3
19507 IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
19508 IQ4=2*NSD1+7-IQ3
19509
19510C...Reconnect strings.
19511 IJOIN(1)=IQ1
19512 IJOIN(2)=IQ4
19513 CALL PYJOIN(2,IJOIN)
19514 IJOIN(1)=IQ3
19515 IJOIN(2)=IQ2
19516 CALL PYJOIN(2,IJOIN)
19517
19518C...Do new parton showers in intermediate scenario.
19519 IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
19520 MSTJ50=MSTJ(50)
19521 MSTJ(50)=0
19522 CALL PYSHOW(IQ1,IQ2,P(IW1,5))
19523 CALL PYSHOW(IQ3,IQ4,P(IW2,5))
19524 MSTJ(50)=MSTJ50
19525
19526C...Do new parton showers in instantaneous scenario.
19527 ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
19528 PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2-
19529 & (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2
19530 PPM=SQRT(MAX(0D0,PPM2))
19531 CALL PYSHOW(IQ1,IQ4,PPM)
19532 PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2-
19533 & (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2
19534 PPM=SQRT(MAX(0D0,PPM2))
19535 CALL PYSHOW(IQ3,IQ2,PPM)
19536 ENDIF
19537 ENDIF
19538
19539 RETURN
19540 END
19541
19542C***********************************************************************
19543
19544C...PYKLIM
19545C...Checks generated variables against pre-set kinematical limits;
19546C...also calculates limits on variables used in generation.
19547
19548 SUBROUTINE PYKLIM(ILIM)
19549
19550C...Double precision and integer declarations.
19551 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19552 IMPLICIT INTEGER(I-N)
19553 INTEGER PYK,PYCHGE,PYCOMP
19554C...Commonblocks.
19555 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19556 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19557 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19558 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
19559 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
19560 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19561 COMMON/PYINT1/MINT(400),VINT(400)
19562 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
19563 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
19564 &/PYINT1/,/PYINT2/
19565
19566C...Common kinematical expressions.
19567 MINT(51)=0
19568 ISUB=MINT(1)
19569 ISTSB=ISET(ISUB)
19570 IF(ISUB.EQ.96) GOTO 100
19571 SQM3=VINT(63)
19572 SQM4=VINT(64)
19573 IF(ILIM.NE.0) THEN
19574 IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
19575 CKIN09=MAX(CKIN(9),CKIN(13))
19576 CKIN10=MIN(CKIN(10),CKIN(14))
19577 CKIN11=MAX(CKIN(11),CKIN(15))
19578 CKIN12=MIN(CKIN(12),CKIN(16))
19579 ELSE
19580 CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
19581 CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
19582 CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
19583 CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
19584 ENDIF
19585 ENDIF
19586 IF(ILIM.NE.1) THEN
19587 TAU=VINT(21)
19588 RM3=SQM3/(TAU*VINT(2))
19589 RM4=SQM4/(TAU*VINT(2))
19590 BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
19591 ENDIF
19592 PTHMIN=CKIN(3)
19593 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3)
19594 &PTHMIN=MAX(CKIN(3),CKIN(5))
19595
19596 IF(ILIM.EQ.0) THEN
19597C...Check generated values of tau, y*, cos(theta-hat), and tau' against
19598C...pre-set kinematical limits.
19599 YST=VINT(22)
19600 CTH=VINT(23)
19601 TAUP=VINT(26)
19602 TAUE=TAU
19603 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
19604 X1=SQRT(TAUE)*EXP(YST)
19605 X2=SQRT(TAUE)*EXP(-YST)
19606 XF=X1-X2
19607 IF(MINT(47).NE.1) THEN
19608 IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
19609 IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
19610 IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
19611 IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
19612 ENDIF
19613 IF(MINT(45).NE.1) THEN
19614 IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
19615 ENDIF
19616 IF(MINT(46).NE.1) THEN
19617 IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
19618 ENDIF
19619 IF(MINT(45).EQ.2) THEN
19620 IF(X1.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
19621 ENDIF
19622 IF(MINT(46).EQ.2) THEN
19623 IF(X2.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
19624 ENDIF
19625 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
19626 PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2))
19627 EXPY3=MAX(1D-20,(1D0+RM3-RM4+BE34*CTH)/
19628 & MAX(1D-20,(1D0+RM3-RM4-BE34*CTH)))
19629 EXPY4=MAX(1D-20,(1D0-RM3+RM4-BE34*CTH)/
19630 & MAX(1D-20,(1D0-RM3+RM4+BE34*CTH)))
19631 Y3=YST+0.5D0*LOG(EXPY3)
19632 Y4=YST+0.5D0*LOG(EXPY4)
19633 YLARGE=MAX(Y3,Y4)
19634 YSMALL=MIN(Y3,Y4)
19635 ETALAR=20D0
19636 ETASMA=-20D0
19637 STH=SQRT(MAX(0D0,1D0-CTH**2))
19638 EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*
19639 & CTH)**2-4D0*RM3))
19640 EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*
19641 & CTH)**2-4D0*RM4))
19642 IF(STH.GE.1D-10) THEN
19643 EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/
19644 & (BE34*STH)
19645 EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/
19646 & (BE34*STH)
19647 ETA3=LOG(MIN(1D10,MAX(1D-10,EXPET3)))
19648 ETA4=LOG(MIN(1D10,MAX(1D-10,EXPET4)))
19649 ETALAR=MAX(ETA3,ETA4)
19650 ETASMA=MIN(ETA3,ETA4)
19651 ENDIF
19652 CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3
19653 CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4
19654 CTSLAR=MIN(1D0,MAX(-1D0,CTS3,CTS4))
19655 CTSSMA=MAX(-1D0,MIN(1D0,CTS3,CTS4))
19656 SH=TAU*VINT(2)
19657 RPTS=4D0*VINT(71)**2/SH
19658 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
19659 RM34=MAX(1D-20,2D0*RM3*RM4)
19660 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
19661 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
19662 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
19663 THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
19664 UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
19665 IF(PTH.LT.PTHMIN) MINT(51)=1
19666 IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1
19667 IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
19668 IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
19669 IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
19670 IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
19671 IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
19672 IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
19673 IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
19674 IF(THA.LT.CKIN(35)) MINT(51)=1
19675 IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1
19676 IF(UHA.LT.CKIN(37)) MINT(51)=1
19677 IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1
19678 ENDIF
19679 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
19680 IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
19681 IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
19682 ENDIF
19683
19684C...Additional cuts on W2 (approximately) in DIS.
19685 IF(ISUB.EQ.10.AND.MINT(43).GE.2) THEN
19686 XBJ=X2
19687 IF(IABS(MINT(12)).LT.20) XBJ=X1
19688 Q2BJ=THA
19689 W2BJ=Q2BJ*(1D0-XBJ)/XBJ
19690 IF(W2BJ.LT.CKIN(39)) MINT(51)=1
19691 IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1
19692 ENDIF
19693
19694 ELSEIF(ILIM.EQ.1) THEN
19695C...Calculate limits on tau
19696C...0) due to definition
19697 TAUMN0=0D0
19698 TAUMX0=1D0
19699C...1) due to limits on subsystem mass
19700 TAUMN1=CKIN(1)**2/VINT(2)
19701 TAUMX1=1D0
19702 IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2)
19703C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
19704 TM3=SQRT(SQM3+PTHMIN**2)
19705 TM4=SQRT(SQM4+PTHMIN**2)
19706 YDCOSH=1D0
19707 IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12)
19708 TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
19709 TAUMX2=1D0
19710C...3) due to limits on pT-hat and cos(theta-hat)
19711 CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
19712 CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
19713 TAUMN3=0D0
19714 IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3=
19715 & (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+
19716 & SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2)
19717 TAUMX3=1D0
19718 IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3=
19719 & (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+
19720 & SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2)
19721C...4) due to limits on x1 and x2
19722 TAUMN4=CKIN(21)*CKIN(23)
19723 TAUMX4=CKIN(22)*CKIN(24)
19724C...5) due to limits on xF
19725 TAUMN5=0D0
19726 TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26))
19727C...6) due to limits on that and uhat
19728 TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2)
19729 TAUMX6=1D0
19730 IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6=
19731 & (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2)
19732
19733C...Net effect of all separate limits.
19734 VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6)
19735 VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6)
19736 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
19737 VINT(11)=1D0-1D-9
19738 VINT(31)=1D0+1D-9
19739 ELSEIF(MINT(47).EQ.5) THEN
19740 VINT(31)=MIN(VINT(31),1D0-2D-10)
19741 ELSEIF(MINT(47).GE.6) THEN
19742 VINT(31)=MIN(VINT(31),1D0-1D-10)
19743 ENDIF
19744 IF(VINT(31).LE.VINT(11)) MINT(51)=1
19745
19746 ELSEIF(ILIM.EQ.2) THEN
19747C...Calculate limits on y*
19748 TAUE=TAU
19749 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
19750 TAURT=SQRT(TAUE)
19751C...0) due to kinematics
19752 YSTMN0=LOG(TAURT)
19753 YSTMX0=-YSTMN0
19754C...1) due to explicit limits
19755 YSTMN1=CKIN(7)
19756 YSTMX1=CKIN(8)
19757C...2) due to limits on x1
19758 YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT)
19759 YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT)
19760C...3) due to limits on x2
19761 YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT)
19762 YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT)
19763C...4) due to limits on xF
19764 YEPMN4=0.5D0*ABS(CKIN(25))/TAURT
19765 YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25))
19766 YEPMX4=0.5D0*ABS(CKIN(26))/TAURT
19767 YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26))
19768C...5) due to simultaneous limits on y-large and y-small
19769 YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11)
19770 YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12)
19771 YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN)))
19772 YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX)))
19773 YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN)
19774 YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX)
19775C...6) due to simultaneous limits on cos(theta-hat) and y-large or
19776C... y-small
19777 CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2))))
19778 RZMN=BE34*MAX(CKIN(27),-CTHLIM)
19779 RZMX=BE34*MIN(CKIN(28),CTHLIM)
19780 YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX)
19781 YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN)
19782 YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN)
19783 YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX)
19784 YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX))
19785 YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN))
19786
19787C...Net effect of all separate limits.
19788 VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
19789 VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
19790 IF(MINT(47).EQ.1) THEN
19791 VINT(12)=-1D-9
19792 VINT(32)=1D-9
19793 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
19794 VINT(12)=(1D0-1D-9)*YSTMX0
19795 VINT(32)=(1D0+1D-9)*YSTMX0
19796 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
19797 VINT(12)=-(1D0+1D-9)*YSTMX0
19798 VINT(32)=-(1D0-1D-9)*YSTMX0
19799 ELSEIF(MINT(47).EQ.5) THEN
19800 YSTEE=LOG((1D0-1D-10)/TAURT)
19801 VINT(12)=MAX(VINT(12),-YSTEE)
19802 VINT(32)=MIN(VINT(32),YSTEE)
19803 ENDIF
19804 IF(VINT(32).LE.VINT(12)) MINT(51)=1
19805
19806 ELSEIF(ILIM.EQ.3) THEN
19807C...Calculate limits on cos(theta-hat)
19808 YST=VINT(22)
19809C...0) due to definition
19810 CTNMN0=-1D0
19811 CTNMX0=0D0
19812 CTPMN0=0D0
19813 CTPMX0=1D0
19814C...1) due to explicit limits
19815 CTNMN1=MIN(0D0,CKIN(27))
19816 CTNMX1=MIN(0D0,CKIN(28))
19817 CTPMN1=MAX(0D0,CKIN(27))
19818 CTPMX1=MAX(0D0,CKIN(28))
19819C...2) due to limits on pT-hat
19820 CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2))))
19821 CTPMX2=-CTNMN2
19822 CTNMX2=0D0
19823 CTPMN2=0D0
19824 IF(CKIN(4).GE.0D0) THEN
19825 CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/
19826 & (BE34**2*TAU*VINT(2))))
19827 CTPMN2=-CTNMX2
19828 ENDIF
19829C...3) due to limits on y-large and y-small
19830 CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST),
19831 & -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST)))
19832 CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST),
19833 & -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST))
19834 CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST),
19835 & -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST))
19836 CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST),
19837 & -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST)))
19838C...4) due to limits on that
19839 CTNMN4=-1D0
19840 CTNMX4=0D0
19841 CTPMN4=0D0
19842 CTPMX4=1D0
19843 SH=TAU*VINT(2)
19844 IF(CKIN(35).GT.0D0) THEN
19845 CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34
19846 IF(CTLIM.GT.0D0) THEN
19847 CTPMX4=CTLIM
19848 ELSE
19849 CTPMX4=0D0
19850 CTNMX4=CTLIM
19851 ENDIF
19852 ENDIF
19853 IF(CKIN(36).GT.0D0) THEN
19854 CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34
19855 IF(CTLIM.LT.0D0) THEN
19856 CTNMN4=CTLIM
19857 ELSE
19858 CTNMN4=0D0
19859 CTPMN4=CTLIM
19860 ENDIF
19861 ENDIF
19862C...5) due to limits on uhat
19863 CTNMN5=-1D0
19864 CTNMX5=0D0
19865 CTPMN5=0D0
19866 CTPMX5=1D0
19867 IF(CKIN(37).GT.0D0) THEN
19868 CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34
19869 IF(CTLIM.LT.0D0) THEN
19870 CTNMN5=CTLIM
19871 ELSE
19872 CTNMN5=0D0
19873 CTPMN5=CTLIM
19874 ENDIF
19875 ENDIF
19876 IF(CKIN(38).GT.0D0) THEN
19877 CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34
19878 IF(CTLIM.GT.0D0) THEN
19879 CTPMX5=CTLIM
19880 ELSE
19881 CTPMX5=0D0
19882 CTNMX5=CTLIM
19883 ENDIF
19884 ENDIF
19885
19886C...Net effect of all separate limits.
19887 VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5)
19888 VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5)
19889 VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5)
19890 VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5)
19891 IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
19892
19893 ELSEIF(ILIM.EQ.4) THEN
19894C...Calculate limits on tau'
19895C...0) due to kinematics
19896 TAPMN0=TAU
19897 IF(ISTSB.EQ.5.AND.KFPR(ISUB,2).GT.0) THEN
19898 PQRAT=2D0*PMAS(PYCOMP(KFPR(ISUB,2)),1)/VINT(1)
19899 TAPMN0=(SQRT(TAU)+PQRAT)**2
19900 ENDIF
19901 TAPMX0=1D0
19902C...1) due to explicit limits
19903 TAPMN1=CKIN(31)**2/VINT(2)
19904 TAPMX1=1D0
19905 IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2)
19906
19907C...Net effect of all separate limits.
19908 VINT(16)=MAX(TAPMN0,TAPMN1)
19909 VINT(36)=MIN(TAPMX0,TAPMX1)
19910 IF(MINT(47).EQ.1) THEN
19911 VINT(16)=1D0-1D-9
19912 VINT(36)=1D0+1D-9
19913 ELSEIF(MINT(47).EQ.5) THEN
19914 VINT(36)=MIN(VINT(36),1D0-2D-10)
19915 ELSEIF(MINT(47).EQ.6.OR.MINT(47).EQ.7) THEN
19916 VINT(36)=MIN(VINT(36),1D0-1D-10)
19917 ENDIF
19918 IF(VINT(36).LE.VINT(16)) MINT(51)=1
19919
19920 ENDIF
19921 RETURN
19922
19923C...Special case for low-pT and multiple interactions:
19924C...effective kinematical limits for tau, y*, cos(theta-hat).
19925 100 IF(ILIM.EQ.0) THEN
19926 ELSEIF(ILIM.EQ.1) THEN
19927 IF(MSTP(82).LE.1) THEN
19928 VINT(11)=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
19929 & VINT(2)
19930 ELSE
19931 VINT(11)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/VINT(2)
19932 ENDIF
19933 VINT(31)=1D0
19934 ELSEIF(ILIM.EQ.2) THEN
19935 VINT(12)=0.5D0*LOG(VINT(21))
19936 VINT(32)=-VINT(12)
19937 ELSEIF(ILIM.EQ.3) THEN
19938 IF(MSTP(82).LE.1) THEN
19939 ST2EFF=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
19940 & (VINT(21)*VINT(2))
19941 ELSE
19942 ST2EFF=0.01D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
19943 & (VINT(21)*VINT(2))
19944 ENDIF
19945 VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF))
19946 VINT(33)=0D0
19947 VINT(14)=0D0
19948 VINT(34)=-VINT(13)
19949 ENDIF
19950
19951 RETURN
19952 END
19953
19954C*********************************************************************
19955
19956C...PYKMAP
19957C...Maps a uniform distribution into a distribution of a kinematical
19958C...variable according to one of the possibilities allowed. It is
19959C...assumed that kinematical limits have been set by a PYKLIM call.
19960
19961 SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
19962
19963C...Double precision and integer declarations.
19964 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19965 IMPLICIT INTEGER(I-N)
19966 INTEGER PYK,PYCHGE,PYCOMP
19967C...Commonblocks.
19968 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19969 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19970 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
19971 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19972 COMMON/PYINT1/MINT(400),VINT(400)
19973 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
19974 SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
19975
19976C...Convert VVAR to tau variable.
19977 ISUB=MINT(1)
19978 ISTSB=ISET(ISUB)
19979 IF(IVAR.EQ.1) THEN
19980 TAUMIN=VINT(11)
19981 TAUMAX=VINT(31)
19982 IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
19983 TAURE=VINT(73)
19984 GAMRE=VINT(74)
19985 ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
19986 TAURE=VINT(75)
19987 GAMRE=VINT(76)
19988 ENDIF
19989 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
19990 TAU=1D0
19991 ELSEIF(MVAR.EQ.1) THEN
19992 TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
19993 ELSEIF(MVAR.EQ.2) THEN
19994 TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
19995 ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5) THEN
19996 RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
19997 TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
19998 ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6) THEN
19999 AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
20000 ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
20001 TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
20002 ELSEIF(MINT(47).EQ.5) THEN
20003 AUPP=LOG(MAX(2D-10,1D0-TAUMAX))
20004 ALOW=LOG(MAX(2D-10,1D0-TAUMIN))
20005 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
20006 ELSE
20007 AUPP=LOG(MAX(1D-10,1D0-TAUMAX))
20008 ALOW=LOG(MAX(1D-10,1D0-TAUMIN))
20009 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
20010 ENDIF
20011 VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
20012
20013C...Convert VVAR to y* variable.
20014 ELSEIF(IVAR.EQ.2) THEN
20015 YSTMIN=VINT(12)
20016 YSTMAX=VINT(32)
20017 TAUE=VINT(21)
20018 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
20019 IF(MINT(47).EQ.1) THEN
20020 YST=0D0
20021 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
20022 YST=-0.5D0*LOG(TAUE)
20023 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
20024 YST=0.5D0*LOG(TAUE)
20025 ELSEIF(MVAR.EQ.1) THEN
20026 YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
20027 ELSEIF(MVAR.EQ.2) THEN
20028 YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR)
20029 ELSEIF(MVAR.EQ.3) THEN
20030 AUPP=ATAN(EXP(YSTMAX))
20031 ALOW=ATAN(EXP(YSTMIN))
20032 YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
20033 ELSEIF(MVAR.EQ.4) THEN
20034 YST0=-0.5D0*LOG(TAUE)
20035 AUPP=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0))
20036 ALOW=LOG(MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
20037 YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW)))
20038 ELSE
20039 YST0=-0.5D0*LOG(TAUE)
20040 AUPP=LOG(MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
20041 ALOW=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0))
20042 YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0
20043 ENDIF
20044 VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
20045
20046C...Convert VVAR to cos(theta-hat) variable.
20047 ELSEIF(IVAR.EQ.3) THEN
20048 RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2)
20049 RSQM=1D0+RM34
20050 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
20051 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
20052 CTNMIN=VINT(13)
20053 CTNMAX=VINT(33)
20054 CTPMIN=VINT(14)
20055 CTPMAX=VINT(34)
20056 IF(MVAR.EQ.1) THEN
20057 ANEG=CTNMAX-CTNMIN
20058 APOS=CTPMAX-CTPMIN
20059 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
20060 VCTN=VVAR*(ANEG+APOS)/ANEG
20061 CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
20062 ELSE
20063 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
20064 CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
20065 ENDIF
20066 ELSEIF(MVAR.EQ.2) THEN
20067 RMNMIN=MAX(RM34,RSQM-CTNMIN)
20068 RMNMAX=MAX(RM34,RSQM-CTNMAX)
20069 RMPMIN=MAX(RM34,RSQM-CTPMIN)
20070 RMPMAX=MAX(RM34,RSQM-CTPMAX)
20071 ANEG=LOG(RMNMIN/RMNMAX)
20072 APOS=LOG(RMPMIN/RMPMAX)
20073 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
20074 VCTN=VVAR*(ANEG+APOS)/ANEG
20075 CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
20076 ELSE
20077 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
20078 CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
20079 ENDIF
20080 ELSEIF(MVAR.EQ.3) THEN
20081 RMNMIN=MAX(RM34,RSQM+CTNMIN)
20082 RMNMAX=MAX(RM34,RSQM+CTNMAX)
20083 RMPMIN=MAX(RM34,RSQM+CTPMIN)
20084 RMPMAX=MAX(RM34,RSQM+CTPMAX)
20085 ANEG=LOG(RMNMAX/RMNMIN)
20086 APOS=LOG(RMPMAX/RMPMIN)
20087 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
20088 VCTN=VVAR*(ANEG+APOS)/ANEG
20089 CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
20090 ELSE
20091 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
20092 CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
20093 ENDIF
20094 ELSEIF(MVAR.EQ.4) THEN
20095 RMNMIN=MAX(RM34,RSQM-CTNMIN)
20096 RMNMAX=MAX(RM34,RSQM-CTNMAX)
20097 RMPMIN=MAX(RM34,RSQM-CTPMIN)
20098 RMPMAX=MAX(RM34,RSQM-CTPMAX)
20099 ANEG=1D0/RMNMAX-1D0/RMNMIN
20100 APOS=1D0/RMPMAX-1D0/RMPMIN
20101 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
20102 VCTN=VVAR*(ANEG+APOS)/ANEG
20103 CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN)
20104 ELSE
20105 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
20106 CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP)
20107 ENDIF
20108 ELSEIF(MVAR.EQ.5) THEN
20109 RMNMIN=MAX(RM34,RSQM+CTNMIN)
20110 RMNMAX=MAX(RM34,RSQM+CTNMAX)
20111 RMPMIN=MAX(RM34,RSQM+CTPMIN)
20112 RMPMAX=MAX(RM34,RSQM+CTPMAX)
20113 ANEG=1D0/RMNMIN-1D0/RMNMAX
20114 APOS=1D0/RMPMIN-1D0/RMPMAX
20115 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
20116 VCTN=VVAR*(ANEG+APOS)/ANEG
20117 CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM
20118 ELSE
20119 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
20120 CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM
20121 ENDIF
20122 ENDIF
20123 IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
20124 IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
20125 VINT(23)=CTH
20126
20127C...Convert VVAR to tau' variable.
20128 ELSEIF(IVAR.EQ.4) THEN
20129 TAU=VINT(21)
20130 TAUPMN=VINT(16)
20131 TAUPMX=VINT(36)
20132 IF(MINT(47).EQ.1) THEN
20133 TAUP=1D0
20134 ELSEIF(MVAR.EQ.1) THEN
20135 TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
20136 ELSEIF(MVAR.EQ.2) THEN
20137 AUPP=(1D0-TAU/TAUPMX)**4
20138 ALOW=(1D0-TAU/TAUPMN)**4
20139 TAUP=TAU/MAX(1D-10,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0)
20140 ELSEIF(MINT(47).EQ.5) THEN
20141 AUPP=LOG(MAX(2D-10,1D0-TAUPMX))
20142 ALOW=LOG(MAX(2D-10,1D0-TAUPMN))
20143 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
20144 ELSE
20145 AUPP=LOG(MAX(1D-10,1D0-TAUPMX))
20146 ALOW=LOG(MAX(1D-10,1D0-TAUPMN))
20147 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
20148 ENDIF
20149 VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
20150
20151C...Selection of extra variables needed in 2 -> 3 process:
20152C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
20153C...Since no options are available, the functions of PYKLIM
20154C...and PYKMAP are joint for these choices.
20155 ELSEIF(IVAR.EQ.5) THEN
20156
20157C...Read out total energy and particle masses.
20158 MINT(51)=0
20159 MPTPK=1
20160 IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174
20161 & .OR.ISUB.EQ.178.OR.ISUB.EQ.179.OR.ISUB.EQ.351.OR.ISUB.EQ.352)
20162 & MPTPK=2
20163 SHP=VINT(26)*VINT(2)
20164 SHPR=SQRT(SHP)
20165 PM1=VINT(201)
20166 PM2=VINT(206)
20167 PM3=SQRT(VINT(21))*VINT(1)
20168 IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN
20169 MINT(51)=1
20170 RETURN
20171 ENDIF
20172 PMRS1=VINT(204)**2
20173 PMRS2=VINT(209)**2
20174
20175C...Specify coefficients of pT choice; upper and lower limits.
20176 IF(MPTPK.EQ.1) THEN
20177 HWT1=0.4D0
20178 HWT2=0.4D0
20179 ELSE
20180 HWT1=0.05D0
20181 HWT2=0.05D0
20182 ENDIF
20183 HWT3=1D0-HWT1-HWT2
20184 PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/
20185 & (4D0*SHP)
20186 IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
20187 PTSMN1=CKIN(51)**2
20188 PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/
20189 & (4D0*SHP)
20190 IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2)
20191 PTSMN2=CKIN(53)**2
20192
20193C...Select transverse momenta according to
20194C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
20195 HMX=PMRS1+PTSMX1
20196 HMN=PMRS1+PTSMN1
20197 IF(HMX.LT.1.0001D0*HMN) THEN
20198 MINT(51)=1
20199 RETURN
20200 ENDIF
20201 HDE=PTSMX1-PTSMN1
20202 RPT=PYR(0)
20203 IF(RPT.LT.HWT1) THEN
20204 PTS1=PTSMN1+PYR(0)*HDE
20205 ELSEIF(RPT.LT.HWT1+HWT2) THEN
20206 PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1)
20207 ELSE
20208 PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1)
20209 ENDIF
20210 WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+
20211 & HWT3*HMN*HMX/(PMRS1+PTS1)**2)
20212 HMX=PMRS2+PTSMX2
20213 HMN=PMRS2+PTSMN2
20214 IF(HMX.LT.1.0001D0*HMN) THEN
20215 MINT(51)=1
20216 RETURN
20217 ENDIF
20218 HDE=PTSMX2-PTSMN2
20219 RPT=PYR(0)
20220 IF(RPT.LT.HWT1) THEN
20221 PTS2=PTSMN2+PYR(0)*HDE
20222 ELSEIF(RPT.LT.HWT1+HWT2) THEN
20223 PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2)
20224 ELSE
20225 PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2)
20226 ENDIF
20227 WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+
20228 & HWT3*HMN*HMX/(PMRS2+PTS2)**2)
20229
20230C...Select azimuthal angles and check pT choice.
20231 PHI1=PARU(2)*PYR(0)
20232 PHI2=PARU(2)*PYR(0)
20233 PHIR=PHI2-PHI1
20234 PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR))
20235 IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT.
20236 & CKIN(56)**2)) THEN
20237 MINT(51)=1
20238 RETURN
20239 ENDIF
20240
20241C...Calculate transverse masses and check phase space not closed.
20242 PMS1=PM1**2+PTS1
20243 PMS2=PM2**2+PTS2
20244 PMS3=PM3**2+PTS3
20245 PMT1=SQRT(PMS1)
20246 PMT2=SQRT(PMS2)
20247 PMT3=SQRT(PMS3)
20248 PM12=(PMT1+PMT2)**2
20249 IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN
20250 MINT(51)=1
20251 RETURN
20252 ENDIF
20253
20254C...Select rapidity for particle 3 and check phase space not closed.
20255 Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2-
20256 & 4D0*PMS3*PM12)))/(2D0*SHPR*PMT3))
20257 IF(Y3MAX.LT.1D-6) THEN
20258 MINT(51)=1
20259 RETURN
20260 ENDIF
20261 Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX
20262 PZ3=PMT3*SINH(Y3)
20263 PE3=PMT3*COSH(Y3)
20264
20265C...Find momentum transfers in two mirror solutions (in 1-2 frame).
20266 PZ12=-PZ3
20267 PE12=SHPR-PE3
20268 PMS12=PE12**2-PZ12**2
20269 SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2))
20270 IF(SQL12.LT.1D-6*SHP) THEN
20271 MINT(51)=1
20272 RETURN
20273 ENDIF
20274 PMM1=PMS12+PMS1-PMS2
20275 PMM2=PMS12+PMS2-PMS1
20276 TFAC=-SHPR/(2D0*PMS12)
20277 T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12)
20278 T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12)
20279 T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12)
20280 T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12)
20281
20282C...Construct relative mirror weights and make choice.
20283 IF(MPTPK.EQ.1.OR.ISUB.EQ.351.OR.ISUB.EQ.352) THEN
20284 WTPU=1D0
20285 WTNU=1D0
20286 ELSE
20287 WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2
20288 WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2
20289 ENDIF
20290 WTP=WTPU/(WTPU+WTNU)
20291 WTN=WTNU/(WTPU+WTNU)
20292 EPS=1D0
20293 IF(WTN.GT.PYR(0)) EPS=-1D0
20294
20295C...Store result of variable choice and associated weights.
20296 VINT(202)=PTS1
20297 VINT(207)=PTS2
20298 VINT(203)=PHI1
20299 VINT(208)=PHI2
20300 VINT(205)=WTPTS1
20301 VINT(210)=WTPTS2
20302 VINT(211)=Y3
20303 VINT(212)=Y3MAX
20304 VINT(213)=EPS
20305 IF(EPS.GT.0D0) THEN
20306 VINT(214)=1D0/WTP
20307 VINT(215)=T1P
20308 VINT(216)=T2P
20309 ELSE
20310 VINT(214)=1D0/WTN
20311 VINT(215)=T1N
20312 VINT(216)=T2N
20313 ENDIF
20314 VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12)
20315 VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12)
20316 VINT(219)=0.5D0*(PMS12-PTS3)
20317 VINT(220)=SQL12
20318 ENDIF
20319
20320 RETURN
20321 END
20322
20323C***********************************************************************
20324
20325C...PYSIGH
20326C...Differential matrix elements for all included subprocesses
20327C...Note that what is coded is (disregarding the COMFAC factor)
20328C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
20329C...when d(sigma-hat) is given in the zero-width limit, the delta
20330C...function in tau is replaced by a (modified) Breit-Wigner:
20331C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
20332C...where H_res = s-hat/m_res*Gamma_res(s-hat);
20333C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
20334C...i.e., dimensionless quantities
20335C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
20336C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
20337C...(2pi)^4 delta^4(P - sum p_i)
20338C...COMFAC contains the factor pi/s (or equivalent) and
20339C...the conversion factor from GeV^-2 to mb
20340
20341 SUBROUTINE PYSIGH(NCHN,SIGS)
20342
20343C...Double precision and integer declarations
20344 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
20345 IMPLICIT INTEGER(I-N)
20346 INTEGER PYK,PYCHGE,PYCOMP
20347C...Parameter statement to help give large particle numbers.
20348 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
20349 &KEXCIT=4000000,KDIMEN=5000000)
20350C...Commonblocks
20351 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
20352 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
20353 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
20354 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
20355 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
20356 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
20357 COMMON/PYINT1/MINT(400),VINT(400)
20358 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
20359 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
20360 COMMON/PYINT4/MWID(500),WIDS(500,5)
20361 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
20362 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
20363 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
20364 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
20365 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
20366 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
20367 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
20368 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
20369 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
20370 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
20371 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
20372 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
20373 &/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYSGCM/
20374C...Local arrays and complex variables
20375 DIMENSION X(2),XPQ(-25:25)
20376
20377C...Map of processes onto which routine to call
20378C...in order to evaluate cross section:
20379C...0 = not implemented;
20380C...1 = standard QCD (including photons);
20381C...2 = heavy flavours;
20382C...3 = W/Z;
20383C...4 = Higgs (2 doublets; including longitudinal W/Z scattering);
20384C...5 = SUSY;
20385C...6 = Technicolor;
20386C...7 = exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
20387 DIMENSION MAPPR(500)
20388 DATA (MAPPR(I),I=1,180)/
20389 & 3, 3, 4, 0, 4, 0, 0, 4, 0, 1,
20390 1 1, 1, 1, 1, 3, 3, 0, 1, 3, 3,
20391 2 0, 3, 3, 4, 3, 4, 0, 1, 1, 3,
20392 3 3, 4, 1, 1, 3, 3, 0, 0, 0, 0,
20393 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
20394 5 0, 0, 1, 1, 0, 0, 0, 1, 0, 0,
20395 6 0, 0, 0, 0, 0, 0, 0, 1, 3, 3,
20396 7 4, 4, 4, 0, 0, 4, 4, 0, 0, 1,
20397 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
20398 9 1, 1, 1, 1, 1, 1, 0, 0, 1, 0,
20399 & 0, 4, 4, 2, 2, 2, 2, 2, 0, 4,
20400 1 4, 4, 4, 1, 1, 0, 0, 0, 0, 0,
20401 2 4, 4, 4, 4, 0, 0, 0, 0, 0, 0,
20402 3 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
20403 4 7, 7, 4, 7, 7, 7, 7, 7, 6, 0,
20404 5 4, 4, 4, 0, 0, 4, 4, 4, 0, 0,
20405 6 4, 7, 7, 7, 6, 6, 7, 7, 7, 0,
20406 7 4, 4, 4, 4, 0, 4, 4, 4, 4, 0/
20407 DATA (MAPPR(I),I=181,500)/
20408 8 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
20409 9 6, 6, 6, 6, 6, 0, 0, 0, 0, 0,
20410 & 100*5,
20411 & 5, 0, 0, 0, 0, 0, 0, 0, 0, 0,
20412 1 30*0,
20413 4 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
20414 5 7, 7, 7, 7, 0, 0, 0, 0, 0, 0,
20415 6 6, 6, 6, 6, 6, 6, 6, 6, 0, 6,
20416 7 6, 6, 6, 6, 6, 6, 6, 0, 0, 0,
20417 8 6, 6, 6, 6, 6, 6, 6, 6, 0, 0,
20418 9 7, 7, 7, 7, 7, 0, 0, 0, 0, 0,
20419 & 100*0/
20420
20421C...Reset number of channels and cross-section
20422 NCHN=0
20423 SIGS=0D0
20424
20425C...Read process to consider.
20426 ISUB=MINT(1)
20427 ISUBSV=ISUB
20428 MAP=MAPPR(ISUB)
20429
20430C...Read kinematical variables and limits
20431 ISTSB=ISET(ISUBSV)
20432 TAUMIN=VINT(11)
20433 YSTMIN=VINT(12)
20434 CTNMIN=VINT(13)
20435 CTPMIN=VINT(14)
20436 TAUPMN=VINT(16)
20437 TAU=VINT(21)
20438 YST=VINT(22)
20439 CTH=VINT(23)
20440 XT2=VINT(25)
20441 TAUP=VINT(26)
20442 TAUMAX=VINT(31)
20443 YSTMAX=VINT(32)
20444 CTNMAX=VINT(33)
20445 CTPMAX=VINT(34)
20446 TAUPMX=VINT(36)
20447
20448C...Derive kinematical quantities
20449 TAUE=TAU
20450 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
20451 X(1)=SQRT(TAUE)*EXP(YST)
20452 X(2)=SQRT(TAUE)*EXP(-YST)
20453 IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN
20454 IF(X(1).GT.1D0-1D-7) RETURN
20455 ELSEIF(MINT(45).EQ.3) THEN
20456 X(1)=MIN(1D0-1.1D-10,X(1))
20457 ENDIF
20458 IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
20459 IF(X(2).GT.1D0-1D-7) RETURN
20460 ELSEIF(MINT(46).EQ.3) THEN
20461 X(2)=MIN(1D0-1.1D-10,X(2))
20462 ENDIF
20463 SH=MAX(1D0,TAU*VINT(2))
20464 SQM3=VINT(63)
20465 SQM4=VINT(64)
20466 RM3=SQM3/SH
20467 RM4=SQM4/SH
20468 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
20469 RPTS=4D0*VINT(71)**2/SH
20470 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
20471 RM34=MAX(1D-20,2D0*RM3*RM4)
20472 RSQM=1D0+RM34
20473 IF(2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)).LT.0.0001D0)
20474 &RM34=MAX(RM34,2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)))
20475 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
20476 IF(ISTSB.EQ.0) THEN
20477 TH=VINT(45)
20478 UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
20479 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
20480 ELSE
20481C...Kinematics with incoming masses tricky: now depends on how
20482C...subprocess has been set up w.r.t. order of incoming partons.
20483 RM1=0D0
20484 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) RM1=-VINT(3)**2/SH
20485 RM2=0D0
20486 IF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) RM2=-VINT(4)**2/SH
20487 IF(ISUB.EQ.35) THEN
20488 RM2=MIN(RM1,RM2)
20489 RM1=0D0
20490 ENDIF
20491 BE12=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
20492 TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4)
20493 TH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM4-2D0*RM2*RM3-
20494 & BE12*BE34*CTH)
20495 UH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM3-2D0*RM2*RM4+
20496 & BE12*BE34*CTH)
20497 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
20498 ENDIF
20499 SHR=SQRT(SH)
20500 SH2=SH**2
20501 TH2=TH**2
20502 UH2=UH**2
20503
20504C...Choice of Q2 scale: hard, parton distributions, parton showers
20505 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
20506 Q2=SH
20507 ELSEIF(ISTSB.EQ.8) THEN
20508 IF(MINT(107).EQ.4) Q2=VINT(307)
20509 IF(MINT(108).EQ.4) Q2=VINT(308)
20510 ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
20511 Q2IN1=0D0
20512 IF(MINT(11).EQ.22.AND.VINT(3).LT.0D0) Q2IN1=VINT(3)**2
20513 Q2IN2=0D0
20514 IF(MINT(12).EQ.22.AND.VINT(4).LT.0D0) Q2IN2=VINT(4)**2
20515 IF(MSTP(32).EQ.1) THEN
20516 Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
20517 ELSEIF(MSTP(32).EQ.2) THEN
20518 Q2=SQPTH+0.5D0*(SQM3+SQM4)
20519 ELSEIF(MSTP(32).EQ.3) THEN
20520 Q2=MIN(-TH,-UH)
20521 ELSEIF(MSTP(32).EQ.4) THEN
20522 Q2=SH
20523 ELSEIF(MSTP(32).EQ.5) THEN
20524 Q2=-TH
20525 ELSEIF(MSTP(32).EQ.6) THEN
20526 XSF1=X(1)
20527 IF(ISTSB.EQ.9) XSF1=X(1)/VINT(143)
20528 XSF2=X(2)
20529 IF(ISTSB.EQ.9) XSF2=X(2)/VINT(144)
20530 Q2=(1D0+XSF1*Q2IN1/SH+XSF2*Q2IN2/SH)*
20531 & (SQPTH+0.5D0*(SQM3+SQM4))
20532 ELSEIF(MSTP(32).EQ.7) THEN
20533 Q2=(1D0+Q2IN1/SH+Q2IN2/SH)*(SQPTH+0.5D0*(SQM3+SQM4))
20534 ELSEIF(MSTP(32).EQ.8) THEN
20535 Q2=SQPTH+0.5D0*(Q2IN1+Q2IN2+SQM3+SQM4)
20536 ELSEIF(MSTP(32).EQ.9) THEN
20537 Q2=SQPTH+Q2IN1+Q2IN2+SQM3+SQM4
20538 ELSEIF(MSTP(32).EQ.10) THEN
20539 Q2=VINT(2)
20540 ENDIF
20541 IF(ISTSB.EQ.9) Q2=SQPTH
20542 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2=Q2+
20543 & (PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
20544 ENDIF
20545 Q2SF=Q2
20546 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
20547 Q2SF=PMAS(23,1)**2
20548 IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124.OR.
20549 & ISUB.EQ.351) Q2SF=PMAS(24,1)**2
20550 IF(ISUB.EQ.352) Q2SF=PMAS(PYCOMP(9900024),1)**2
20551 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
20552 & ISUB.EQ.186.OR.ISUB.EQ.187) THEN
20553 Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
20554 IF(MSTP(39).EQ.2) Q2SF=Q2SF+MAX(VINT(202),VINT(207))
20555 IF(MSTP(39).EQ.3) Q2SF=SH
20556 IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2)
20557 IF(MSTP(39).EQ.5) Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,1)),1)**2
20558 ENDIF
20559 ENDIF
20560 Q2PS=Q2SF
20561 Q2SF=Q2SF*PARP(34)
20562 IF(MSTP(69).GE.1.AND.MINT(47).EQ.5) Q2SF=VINT(2)
20563 IF(MSTP(69).GE.2) Q2SF=VINT(2)
20564 IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND.
20565 &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
20566 XBJ=X(2)
20567 IF(MINT(43).EQ.3) XBJ=X(1)
20568 IF(MSTP(22).EQ.1) THEN
20569 Q2PS=-TH
20570 ELSEIF(MSTP(22).EQ.2) THEN
20571 Q2PS=((1D0-XBJ)/XBJ)*(-TH)
20572 ELSEIF(MSTP(22).EQ.3) THEN
20573 Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH)
20574 ELSE
20575 Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH)
20576 ENDIF
20577 ENDIF
20578 IF(MSTP(68).EQ.1.AND.(ISUBSV.EQ.1.OR.ISUBSV.EQ.2.OR.
20579 &ISUBSV.EQ.102.OR.ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR.
20580 &ISUBSV.EQ.144.OR.ISUBSV.EQ.152.OR.ISUBSV.EQ.157)) THEN
20581 Q2PS=VINT(2)
20582 ELSEIF(MSTP(68).GE.2.AND.(ISUBSV.NE.11.AND.ISUBSV.NE.12.AND.
20583 &ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.ISUBSV.NE.53.AND.
20584 &ISUBSV.NE.68)) THEN
20585 Q2PS=VINT(2)
20586 ENDIF
20587
20588C...Store derived kinematical quantities
20589 VINT(41)=X(1)
20590 VINT(42)=X(2)
20591 VINT(44)=SH
20592 VINT(43)=SQRT(SH)
20593 VINT(45)=TH
20594 VINT(46)=UH
20595 IF(ISTSB.NE.8) VINT(48)=SQPTH
20596 IF(ISTSB.NE.8) VINT(47)=SQRT(SQPTH)
20597 VINT(50)=TAUP*VINT(2)
20598 VINT(49)=SQRT(MAX(0D0,VINT(50)))
20599 VINT(52)=Q2
20600 VINT(51)=SQRT(Q2)
20601 VINT(54)=Q2SF
20602 VINT(53)=SQRT(Q2SF)
20603 VINT(56)=Q2PS
20604 VINT(55)=SQRT(Q2PS)
20605
20606C...Calculate parton distributions
20607 IF(ISTSB.LE.0) GOTO 160
20608 IF(MINT(47).GE.2) THEN
20609 DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
20610 XSF=X(I)
20611 IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
20612 IF(ISUB.EQ.99) THEN
20613 IF(MINT(140+I).EQ.0) THEN
20614 XSF=VINT(309-I)/(VINT(2)+VINT(309-I)-VINT(I+2)**2)
20615 ELSE
20616 XSF=VINT(309-I)/(VINT(2)+VINT(307)+VINT(308))
20617 ENDIF
20618 VINT(40+I)=XSF
20619 Q2SF=VINT(309-I)
20620 ENDIF
20621 MINT(105)=MINT(102+I)
20622 MINT(109)=MINT(106+I)
20623 VINT(120)=VINT(2+I)
20624C.... ALICE
20625C.... Store side in MINT(124)
20626 MINT(124)=I
20627C....
20628 IF(MSTP(57).LE.1) THEN
20629 CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ)
20630 ELSE
20631 CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ)
20632 ENDIF
20633 DO 100 KFL=-25,25
20634 XSFX(I,KFL)=XPQ(KFL)
20635 100 CONTINUE
20636 110 CONTINUE
20637 ENDIF
20638
20639C...Calculate alpha_em, alpha_strong and K-factor
20640 XW=PARU(102)
20641 XWV=XW
20642 IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW=
20643 &1D0-(PMAS(24,1)/PMAS(23,1))**2
20644 XW1=1D0-XW
20645 XWC=1D0/(16D0*XW*XW1)
20646 AEM=PYALEM(Q2)
20647 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
20648 IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2)
20649 FACK=1D0
20650 FACA=1D0
20651 IF(MSTP(33).EQ.1) THEN
20652 FACK=PARP(31)
20653 ELSEIF(MSTP(33).EQ.2) THEN
20654 FACK=PARP(31)
20655 FACA=PARP(32)/PARP(31)
20656 ELSEIF(MSTP(33).EQ.3) THEN
20657 Q2AS=PARP(33)*Q2
20658 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+
20659 & PARU(112)*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
20660 AS=PYALPS(Q2AS)
20661 ENDIF
20662 VINT(138)=1D0
20663 VINT(57)=AEM
20664 VINT(58)=AS
20665
20666C...Set flags for allowed reacting partons/leptons
20667 DO 140 I=1,2
20668 DO 120 J=-25,25
20669 KFAC(I,J)=0
20670 120 CONTINUE
20671 IF(MINT(44+I).EQ.1) THEN
20672 KFAC(I,MINT(10+I))=1
20673 ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN
20674 KFAC(I,MINT(10+I))=1
20675 KFAC(I,22)=1
20676 KFAC(I,24)=1
20677 KFAC(I,-24)=1
20678 ELSE
20679 DO 130 J=-25,25
20680 KFAC(I,J)=KFIN(I,J)
20681 IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0
20682 IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0
20683 130 CONTINUE
20684 ENDIF
20685 140 CONTINUE
20686
20687C...Lower and upper limit for fermion flavour loops
20688 MMIN1=0
20689 MMAX1=0
20690 MMIN2=0
20691 MMAX2=0
20692 DO 150 J=-20,20
20693 IF(KFAC(1,-J).EQ.1) MMIN1=-J
20694 IF(KFAC(1,J).EQ.1) MMAX1=J
20695 IF(KFAC(2,-J).EQ.1) MMIN2=-J
20696 IF(KFAC(2,J).EQ.1) MMAX2=J
20697 150 CONTINUE
20698 MMINA=MIN(MMIN1,MMIN2)
20699 MMAXA=MAX(MMAX1,MMAX2)
20700
20701C...Common resonance mass and width combinations
20702 SQMZ=PMAS(23,1)**2
20703 SQMW=PMAS(24,1)**2
20704 GMMZ=PMAS(23,1)*PMAS(23,2)
20705 GMMW=PMAS(24,1)*PMAS(24,2)
20706
20707C...Polarization factors...implemented so far for W+W-(25)
20708 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
20709 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
20710 POLRR=(1D0+PARJ(132))*(1D0+PARJ(131))
20711 POLLL=(1D0-PARJ(132))*(1D0-PARJ(131))
20712
20713C...Phase space integral in tau
20714 COMFAC=PARU(1)*PARU(5)/VINT(2)
20715 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK
20716 IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND.
20717 &ISTSB.NE.8.AND.ISTSB.NE.9) THEN
20718 ATAU1=LOG(TAUMAX/TAUMIN)
20719 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
20720 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
20721 IF(MINT(72).GE.1) THEN
20722 TAUR1=VINT(73)
20723 GAMR1=VINT(74)
20724 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
20725 ATAU3=ATAUD/TAUR1
20726 IF(ATAUD.GT.1D-10) H1=H1+
20727 & (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
20728 ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
20729 ATAU4=ATAUD/GAMR1
20730 IF(ATAUD.GT.1D-10) H1=H1+
20731 & (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
20732 ENDIF
20733 IF(MINT(72).EQ.2) THEN
20734 TAUR2=VINT(75)
20735 GAMR2=VINT(76)
20736 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
20737 ATAU5=ATAUD/TAUR2
20738 IF(ATAUD.GT.1D-10) H1=H1+
20739 & (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
20740 ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
20741 ATAU6=ATAUD/GAMR2
20742 IF(ATAUD.GT.1D-10) H1=H1+
20743 & (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
20744 ENDIF
20745 IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
20746 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
20747 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
20748 & MAX(2D-10,1D0-TAU)
20749 ELSEIF(MINT(47).GE.6.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
20750 ATAU7=LOG(MAX(1D-10,1D0-TAUMIN)/MAX(1D-10,1D0-TAUMAX))
20751 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
20752 & MAX(1D-10,1D0-TAU)
20753 ENDIF
20754 COMFAC=COMFAC*ATAU1/(TAU*H1)
20755 ENDIF
20756
20757C...Phase space integral in y*
20758 IF((MINT(47).EQ.4.OR.MINT(47).EQ.5).AND.ISTSB.NE.8.AND.ISTSB.NE.9)
20759 &THEN
20760 AYST0=YSTMAX-YSTMIN
20761 IF(AYST0.LT.1D-10) THEN
20762 COMFAC=0D0
20763 ELSE
20764 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
20765 AYST2=AYST1
20766 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
20767 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
20768 & (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
20769 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
20770 IF(MINT(45).EQ.3) THEN
20771 YST0=-0.5D0*LOG(TAUE)
20772 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
20773 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
20774 IF(AYST4.GT.1D-10) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
20775 & MAX(1D-10,1D0-EXP(YST-YST0))
20776 ENDIF
20777 IF(MINT(46).EQ.3) THEN
20778 YST0=-0.5D0*LOG(TAUE)
20779 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
20780 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
20781 IF(AYST5.GT.1D-10) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
20782 & MAX(1D-10,1D0-EXP(-YST-YST0))
20783 ENDIF
20784 COMFAC=COMFAC*AYST0/H2
20785 ENDIF
20786 ENDIF
20787
20788C...2 -> 1 processes: reduction in angular part of phase space integral
20789C...for case of decaying resonance
20790 ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
20791 IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
20792 IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
20793 IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
20794 & KFPR(ISUB,1).EQ.39) THEN
20795 COMFAC=COMFAC*0.5D0*ACTH0
20796 ELSE
20797 COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
20798 & CTPMAX**3-CTPMIN**3)
20799 ENDIF
20800 ENDIF
20801
20802C...2 -> 2 processes: angular part of phase space integral
20803 ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
20804 ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
20805 & (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
20806 ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
20807 & (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
20808 ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
20809 & 1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
20810 ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
20811 & 1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
20812 H3=COEF(ISUBSV,13)+
20813 & (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
20814 & (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
20815 & (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
20816 & (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
20817 COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3
20818
20819C...2 -> 2 processes: take into account final state Breit-Wigners
20820 COMFAC=COMFAC*VINT(80)
20821 ENDIF
20822
20823C...2 -> 3, 4 processes: phace space integral in tau'
20824 IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
20825 ATAUP1=LOG(TAUPMX/TAUPMN)
20826 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
20827 H4=COEF(ISUBSV,18)+
20828 & (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
20829 IF(MINT(47).EQ.5) THEN
20830 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
20831 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-10,1D0-TAUP)
20832 ELSEIF(MINT(47).GE.6) THEN
20833 ATAUP3=LOG(MAX(1D-10,1D0-TAUPMN)/MAX(1D-10,1D0-TAUPMX))
20834 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(1D-10,1D0-TAUP)
20835 ENDIF
20836 COMFAC=COMFAC*ATAUP1/H4
20837 ENDIF
20838
20839C...2 -> 3, 4 processes: effective W/Z parton distributions
20840 IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
20841 IF(1D0-TAU/TAUP.GT.1D-4) THEN
20842 FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
20843 ELSE
20844 FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
20845 ENDIF
20846 COMFAC=COMFAC*FZW
20847 ENDIF
20848
20849C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
20850 IF(ISTSB.EQ.5) THEN
20851 COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
20852 & (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
20853 ENDIF
20854
20855C...Phase space integral for low-pT and multiple interactions
20856 IF(ISTSB.EQ.9) THEN
20857 COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
20858 ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
20859 ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
20860 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
20861 COMFAC=COMFAC*ATAU1/H1
20862 AYST0=YSTMAX-YSTMIN
20863 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
20864 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
20865 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
20866 & (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
20867 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
20868 COMFAC=COMFAC*AYST0/H2
20869 IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
20870C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
20871C...introduced to make cross-section finite for xT2 -> 0
20872 IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
20873 & (1D0+VINT(149)))
20874 ENDIF
20875
20876C...Real gamma + gamma: include factor 2 when different nature
20877 160 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
20878 &MSTP(14).LE.10) COMFAC=2D0*COMFAC
20879
20880C...Extra factors to include the effects of
20881C...longitudinal resolved photons (but not direct or DIS ones).
20882 DO 170 ISDE=1,2
20883 IF(MINT(10+ISDE).EQ.22.AND.MINT(106+ISDE).GE.1.AND.
20884 & MINT(106+ISDE).LE.3) THEN
20885 VINT(314+ISDE)=1D0
20886 XY=PARP(166+ISDE)
20887 IF(MSTP(16).EQ.0) THEN
20888 IF(VINT(304+ISDE).GT.0D0.AND.VINT(304+ISDE).LT.1D0)
20889 & XY=VINT(304+ISDE)
20890 ELSE
20891 IF(VINT(308+ISDE).GT.0D0.AND.VINT(308+ISDE).LT.1D0)
20892 & XY=VINT(308+ISDE)
20893 ENDIF
20894 Q2GA=VINT(306+ISDE)
20895 IF(MSTP(17).GT.0.AND.XY.GT.0D0.AND.XY.LT.1D0.AND.
20896 & Q2GA.GT.0D0) THEN
20897 REDUCE=0D0
20898 IF(MSTP(17).EQ.1) THEN
20899 REDUCE=4D0*Q2*Q2GA/(Q2+Q2GA)**2
20900 ELSEIF(MSTP(17).EQ.2) THEN
20901 REDUCE=4D0*Q2GA/(Q2+Q2GA)
20902 ELSEIF(MSTP(17).EQ.3) THEN
20903 PMVIRT=PMAS(PYCOMP(113),1)
20904 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
20905 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.1) THEN
20906 PMVIRT=PMAS(PYCOMP(113),1)
20907 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
20908 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.2) THEN
20909 PMVIRT=PMAS(PYCOMP(113),1)
20910 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
20911 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.3) THEN
20912 PMVSMN=4D0*PARP(15)**2
20913 PMVSMX=4D0*VINT(154)**2
20914 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
20915 REDLON=(3D0*PMVSMN+Q2GA)/(PMVSMN+Q2GA)**3-
20916 & (3D0*PMVSMX+Q2GA)/(PMVSMX+Q2GA)**3
20917 REDUCE=4D0*(Q2GA/6D0)*REDLON/REDTRA
20918 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.1) THEN
20919 PMVIRT=PMAS(PYCOMP(113),1)
20920 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
20921 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.2) THEN
20922 PMVIRT=PMAS(PYCOMP(113),1)
20923 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
20924 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.3) THEN
20925 PMVSMN=4D0*PARP(15)**2
20926 PMVSMX=4D0*VINT(154)**2
20927 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
20928 REDLON=1D0/(PMVSMN+Q2GA)**2-1D0/(PMVSMX+Q2GA)**2
20929 REDUCE=4D0*(Q2GA/2D0)*REDLON/REDTRA
20930 ENDIF
20931 BEAMAS=PYMASS(11)
20932 IF(VINT(302+ISDE).GT.0D0) BEAMAS=VINT(302+ISDE)
20933 FRACLT=1D0/(1D0+XY**2/2D0/(1D0-XY)*
20934 & (1D0-2D0*BEAMAS**2/Q2GA))
20935 VINT(314+ISDE)=1D0+PARP(165)*REDUCE*FRACLT
20936 ENDIF
20937 ELSE
20938 VINT(314+ISDE)=1D0
20939 ENDIF
20940 COMFAC=COMFAC*VINT(314+ISDE)
20941 170 CONTINUE
20942
20943C...Evaluate cross sections - done in separate routines by kind
20944C...of physics, to keep PYSIGH of sensible size.
20945 IF(MAP.EQ.1) THEN
20946C...Standard QCD (including photons).
20947 CALL PYSGQC(NCHN,SIGS)
20948 ELSEIF(MAP.EQ.2) THEN
20949C...Heavy flavours.
20950 CALL PYSGHF(NCHN,SIGS)
20951 ELSEIF(MAP.EQ.3) THEN
20952C...W/Z.
20953 CALL PYSGWZ(NCHN,SIGS)
20954 ELSEIF(MAP.EQ.4) THEN
20955C...Higgs (2 doublets; including longitudinal W/Z scattering).
20956 CALL PYSGHG(NCHN,SIGS)
20957 ELSEIF(MAP.EQ.5) THEN
20958C...SUSY.
20959 CALL PYSGSU(NCHN,SIGS)
20960 ELSEIF(MAP.EQ.6) THEN
20961C...Technicolor.
20962 CALL PYSGTC(NCHN,SIGS)
20963 ELSEIF(MAP.EQ.7) THEN
20964C...Exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
20965 CALL PYSGEX(NCHN,SIGS)
20966 ENDIF
20967
20968C...Multiply with parton distributions
20969 IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
20970 DO 180 ICHN=1,NCHN
20971 IF(MINT(45).GE.2) THEN
20972 KFL1=ISIG(ICHN,1)
20973 SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
20974 ENDIF
20975 IF(MINT(46).GE.2) THEN
20976 KFL2=ISIG(ICHN,2)
20977 SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
20978 ENDIF
20979 SIGS=SIGS+SIGH(ICHN)
20980 180 CONTINUE
20981 ENDIF
20982
20983 RETURN
20984 END
20985
20986C*********************************************************************
20987
20988C...PYSGQC
20989C...Subprocess cross sections for QCD processes,
20990C...including photons.
20991C...Auxiliary to PYSIGH.
20992
20993 SUBROUTINE PYSGQC(NCHN,SIGS)
20994
20995C...Double precision and integer declarations
20996 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
20997 IMPLICIT INTEGER(I-N)
20998 INTEGER PYK,PYCHGE,PYCOMP
20999C...Parameter statement to help give large particle numbers.
21000 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
21001 &KEXCIT=4000000,KDIMEN=5000000)
21002C...Commonblocks
21003 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21004 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21005 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
21006 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21007 COMMON/PYINT1/MINT(400),VINT(400)
21008 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
21009 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
21010 COMMON/PYINT4/MWID(500),WIDS(500,5)
21011 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
21012 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
21013 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
21014 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
21015 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
21016 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
21017 &/PYINT3/,/PYINT4/,/PYINT7/,/PYSGCM/
21018C...Local arrays
21019 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
21020
21021C...Differential cross section expressions.
21022
21023 IF(ISUB.LE.20) THEN
21024 IF(ISUB.EQ.10) THEN
21025C...f + f' -> f + f' (gamma/Z/W exchange)
21026 FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2
21027 FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ))
21028 FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2
21029 FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2
21030 DO 110 I=MMIN1,MMAX1
21031 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 110
21032 IA=IABS(I)
21033 DO 100 J=MMIN2,MMAX2
21034 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 100
21035 JA=IABS(J)
21036C...Electroweak couplings
21037 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
21038 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
21039 VI=AI-4D0*EI*XWV
21040 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
21041 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
21042 VJ=AJ-4D0*EJ*XWV
21043 EPSIJ=ISIGN(1,I*J)
21044C...gamma/Z exchange, only gamma exchange, or only Z exchange
21045 IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN
21046 IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN
21047 FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ*
21048 & (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+
21049 & FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+
21050 & 4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
21051 ELSEIF(MSTP(21).EQ.2) THEN
21052 FACNCF=FACGGF*EI**2*EJ**2
21053 ELSE
21054 FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*
21055 & (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
21056 ENDIF
21057C...Extrafactor 2 for only one incoming neutrino spin state.
21058 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACNCF=2D0*FACNCF
21059 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACNCF=2D0*FACNCF
21060 NCHN=NCHN+1
21061 ISIG(NCHN,1)=I
21062 ISIG(NCHN,2)=J
21063 ISIG(NCHN,3)=1
21064 SIGH(NCHN)=FACNCF
21065 ENDIF
21066C...W exchange
21067 IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN
21068 FACCCF=FACWWF*VINT(180+I)*VINT(180+J)
21069 IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2
21070 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF
21071 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF
21072 NCHN=NCHN+1
21073 ISIG(NCHN,1)=I
21074 ISIG(NCHN,2)=J
21075 ISIG(NCHN,3)=2
21076 SIGH(NCHN)=FACCCF
21077 ENDIF
21078 100 CONTINUE
21079 110 CONTINUE
21080
21081 ELSEIF(ISUB.EQ.11) THEN
21082C...f + f' -> f + f' (g exchange)
21083 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
21084 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
21085 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
21086 FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
21087 & MSTP(34)*2D0/3D0*SH2/(TH*UH))
21088 DO 130 I=MMIN1,MMAX1
21089 IA=IABS(I)
21090 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 130
21091 DO 120 J=MMIN2,MMAX2
21092 JA=IABS(J)
21093 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 120
21094 NCHN=NCHN+1
21095 ISIG(NCHN,1)=I
21096 ISIG(NCHN,2)=J
21097 ISIG(NCHN,3)=1
21098 SIGH(NCHN)=FACQQ1
21099 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
21100 IF(I.EQ.J) THEN
21101 SIGH(NCHN)=0.5D0*SIGH(NCHN)
21102 NCHN=NCHN+1
21103 ISIG(NCHN,1)=I
21104 ISIG(NCHN,2)=J
21105 ISIG(NCHN,3)=2
21106 SIGH(NCHN)=0.5D0*FACQQ2
21107 ENDIF
21108 120 CONTINUE
21109 130 CONTINUE
21110
21111 ELSEIF(ISUB.EQ.12) THEN
21112C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
21113 CALL PYWIDT(21,SH,WDTP,WDTE)
21114 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
21115 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
21116 DO 140 I=MMINA,MMAXA
21117 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
21118 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
21119 NCHN=NCHN+1
21120 ISIG(NCHN,1)=I
21121 ISIG(NCHN,2)=-I
21122 ISIG(NCHN,3)=1
21123 SIGH(NCHN)=FACQQB
21124 140 CONTINUE
21125
21126 ELSEIF(ISUB.EQ.13) THEN
21127C...f + fbar -> g + g (q + qbar -> g + g only)
21128 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
21129 & UH2/SH2)
21130 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
21131 & TH2/SH2)
21132 DO 150 I=MMINA,MMAXA
21133 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
21134 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
21135 NCHN=NCHN+1
21136 ISIG(NCHN,1)=I
21137 ISIG(NCHN,2)=-I
21138 ISIG(NCHN,3)=1
21139 SIGH(NCHN)=0.5D0*FACGG1
21140 NCHN=NCHN+1
21141 ISIG(NCHN,1)=I
21142 ISIG(NCHN,2)=-I
21143 ISIG(NCHN,3)=2
21144 SIGH(NCHN)=0.5D0*FACGG2
21145 150 CONTINUE
21146
21147 ELSEIF(ISUB.EQ.14) THEN
21148C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
21149 FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH)
21150 DO 160 I=MMINA,MMAXA
21151 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
21152 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
21153 EI=KCHG(IABS(I),1)/3D0
21154 NCHN=NCHN+1
21155 ISIG(NCHN,1)=I
21156 ISIG(NCHN,2)=-I
21157 ISIG(NCHN,3)=1
21158 SIGH(NCHN)=FACGG*EI**2
21159 160 CONTINUE
21160
21161 ELSEIF(ISUB.EQ.18) THEN
21162C...f + fbar -> gamma + gamma
21163 FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH)
21164 DO 170 I=MMINA,MMAXA
21165 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 170
21166 EI=KCHG(IABS(I),1)/3D0
21167 FCOI=1D0
21168 IF(IABS(I).LE.10) FCOI=FACA/3D0
21169 NCHN=NCHN+1
21170 ISIG(NCHN,1)=I
21171 ISIG(NCHN,2)=-I
21172 ISIG(NCHN,3)=1
21173 SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4
21174 170 CONTINUE
21175 ENDIF
21176
21177 ELSEIF(ISUB.LE.40) THEN
21178 IF(ISUB.EQ.28) THEN
21179C...f + g -> f + g (q + g -> q + g only)
21180 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
21181 & UH/SH)*FACA
21182 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
21183 & SH/UH)
21184 DO 190 I=MMINA,MMAXA
21185 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
21186 DO 180 ISDE=1,2
21187 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
21188 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
21189 NCHN=NCHN+1
21190 ISIG(NCHN,ISDE)=I
21191 ISIG(NCHN,3-ISDE)=21
21192 ISIG(NCHN,3)=1
21193 SIGH(NCHN)=FACQG1
21194 NCHN=NCHN+1
21195 ISIG(NCHN,ISDE)=I
21196 ISIG(NCHN,3-ISDE)=21
21197 ISIG(NCHN,3)=2
21198 SIGH(NCHN)=FACQG2
21199 180 CONTINUE
21200 190 CONTINUE
21201
21202 ELSEIF(ISUB.EQ.29) THEN
21203C...f + g -> f + gamma (q + g -> q + gamma only)
21204 FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH)
21205 DO 210 I=MMINA,MMAXA
21206 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 210
21207 EI=KCHG(IABS(I),1)/3D0
21208 FACGQ=FGQ*EI**2
21209 DO 200 ISDE=1,2
21210 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 200
21211 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 200
21212 NCHN=NCHN+1
21213 ISIG(NCHN,ISDE)=I
21214 ISIG(NCHN,3-ISDE)=21
21215 ISIG(NCHN,3)=1
21216 SIGH(NCHN)=FACGQ
21217 200 CONTINUE
21218 210 CONTINUE
21219
21220 ELSEIF(ISUB.EQ.33) THEN
21221C...f + gamma -> f + g (q + gamma -> q + g only)
21222 FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH)
21223 DO 230 I=MMINA,MMAXA
21224 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 230
21225 EI=KCHG(IABS(I),1)/3D0
21226 FACGQ=FGQ*EI**2
21227 DO 220 ISDE=1,2
21228 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 220
21229 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 220
21230 NCHN=NCHN+1
21231 ISIG(NCHN,ISDE)=I
21232 ISIG(NCHN,3-ISDE)=22
21233 ISIG(NCHN,3)=1
21234 SIGH(NCHN)=FACGQ
21235 220 CONTINUE
21236 230 CONTINUE
21237
21238 ELSEIF(ISUB.EQ.34) THEN
21239C...f + gamma -> f + gamma
21240 FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH)
21241 DO 250 I=MMINA,MMAXA
21242 IF(I.EQ.0) GOTO 250
21243 EI=KCHG(IABS(I),1)/3D0
21244 FACGQ=FGQ*EI**4
21245 DO 240 ISDE=1,2
21246 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 240
21247 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 240
21248 NCHN=NCHN+1
21249 ISIG(NCHN,ISDE)=I
21250 ISIG(NCHN,3-ISDE)=22
21251 ISIG(NCHN,3)=1
21252 SIGH(NCHN)=FACGQ
21253 240 CONTINUE
21254 250 CONTINUE
21255 ENDIF
21256
21257 ELSEIF(ISUB.LE.80) THEN
21258 IF(ISUB.EQ.53) THEN
21259C...g + g -> f + fbar (g + g -> q + qbar only)
21260 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 270
21261 IDC0=MDCY(21,2)-1
21262C...Begin by d, u, s flavours.
21263 FLAVWT=0D0
21264 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
21265 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
21266 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
21267 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
21268 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
21269 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
21270 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
21271 & UH2/SH2)*FLAVWT*FACA
21272 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
21273 & TH2/SH2)*FLAVWT*FACA
21274 NCHN=NCHN+1
21275 ISIG(NCHN,1)=21
21276 ISIG(NCHN,2)=21
21277 ISIG(NCHN,3)=1
21278 SIGH(NCHN)=FACQQ1
21279 NCHN=NCHN+1
21280 ISIG(NCHN,1)=21
21281 ISIG(NCHN,2)=21
21282 ISIG(NCHN,3)=2
21283 SIGH(NCHN)=FACQQ2
21284C...Next c and b flavours: modified that and uhat for fixed
21285C...cos(theta-hat).
21286 DO 260 IFL=4,5
21287 SQMAVG=PMAS(IFL,1)**2
21288 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
21289 BE34=SQRT(1D0-4D0*SQMAVG/SH)
21290 THQ=-0.5D0*SH*(1D0-BE34*CTH)
21291 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
21292 THUHQ=THQ*UHQ-SQMAVG*SH
21293 IF(MSTP(34).EQ.0) THEN
21294 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
21295 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
21296 ELSE
21297 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
21298 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
21299 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
21300 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
21301 ENDIF
21302 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
21303 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
21304 NCHN=NCHN+1
21305 ISIG(NCHN,1)=21
21306 ISIG(NCHN,2)=21
21307 ISIG(NCHN,3)=1+2*(IFL-3)
21308 SIGH(NCHN)=FACQQ1
21309 NCHN=NCHN+1
21310 ISIG(NCHN,1)=21
21311 ISIG(NCHN,2)=21
21312 ISIG(NCHN,3)=2+2*(IFL-3)
21313 SIGH(NCHN)=FACQQ2
21314 ENDIF
21315 260 CONTINUE
21316 270 CONTINUE
21317
21318 ELSEIF(ISUB.EQ.54) THEN
21319C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
21320 CALL PYWIDT(21,SH,WDTP,WDTE)
21321 WDTESU=0D0
21322 DO 280 I=1,MIN(8,MDCY(21,3))
21323 EF=KCHG(I,1)/3D0
21324 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
21325 & WDTE(I,4))
21326 280 CONTINUE
21327 FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH)
21328 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
21329 NCHN=NCHN+1
21330 ISIG(NCHN,1)=21
21331 ISIG(NCHN,2)=22
21332 ISIG(NCHN,3)=1
21333 SIGH(NCHN)=FACQQ
21334 ENDIF
21335 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
21336 NCHN=NCHN+1
21337 ISIG(NCHN,1)=22
21338 ISIG(NCHN,2)=21
21339 ISIG(NCHN,3)=1
21340 SIGH(NCHN)=FACQQ
21341 ENDIF
21342
21343 ELSEIF(ISUB.EQ.58) THEN
21344C...gamma + gamma -> f + fbar
21345 CALL PYWIDT(22,SH,WDTP,WDTE)
21346 WDTESU=0D0
21347 DO 290 I=1,MIN(12,MDCY(22,3))
21348 IF(I.LE.8) EF= KCHG(I,1)/3D0
21349 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
21350 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
21351 & WDTE(I,4))
21352 290 CONTINUE
21353 FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH)
21354 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
21355 NCHN=NCHN+1
21356 ISIG(NCHN,1)=22
21357 ISIG(NCHN,2)=22
21358 ISIG(NCHN,3)=1
21359 SIGH(NCHN)=FACFF
21360 ENDIF
21361
21362 ELSEIF(ISUB.EQ.68) THEN
21363C...g + g -> g + g
21364 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 300
21365 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+2D0*TH/SH+
21366 & TH2/SH2)*FACA
21367 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+2D0*SH/UH+
21368 & SH2/UH2)*FACA
21369 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+2D0*UH/TH+
21370 & UH2/TH2)
21371 NCHN=NCHN+1
21372 ISIG(NCHN,1)=21
21373 ISIG(NCHN,2)=21
21374 ISIG(NCHN,3)=1
21375 SIGH(NCHN)=0.5D0*FACGG1
21376 NCHN=NCHN+1
21377 ISIG(NCHN,1)=21
21378 ISIG(NCHN,2)=21
21379 ISIG(NCHN,3)=2
21380 SIGH(NCHN)=0.5D0*FACGG2
21381 NCHN=NCHN+1
21382 ISIG(NCHN,1)=21
21383 ISIG(NCHN,2)=21
21384 ISIG(NCHN,3)=3
21385 SIGH(NCHN)=0.5D0*FACGG3
21386 300 CONTINUE
21387
21388 ELSEIF(ISUB.EQ.80) THEN
21389C...q + gamma -> q' + pi+/-
21390 FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2)
21391 ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
21392 Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
21393 DELSH=UH*SQRT(ASSH*Q2FPSH)
21394 ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
21395 Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
21396 DELUH=SH*SQRT(ASUH*Q2FPUH)
21397 DO 320 I=MAX(-2,MMINA),MIN(2,MMAXA)
21398 IF(I.EQ.0) GOTO 320
21399 EI=KCHG(IABS(I),1)/3D0
21400 EJ=SIGN(1D0-ABS(EI),EI)
21401 DO 310 ISDE=1,2
21402 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 310
21403 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 310
21404 NCHN=NCHN+1
21405 ISIG(NCHN,ISDE)=I
21406 ISIG(NCHN,3-ISDE)=22
21407 ISIG(NCHN,3)=1
21408 SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2
21409 310 CONTINUE
21410 320 CONTINUE
21411 ENDIF
21412
21413 ELSEIF(ISUB.LE.100) THEN
21414 IF(ISUB.EQ.91) THEN
21415C...Elastic scattering
21416 SIGS=VINT(315)*VINT(316)*SIGT(0,0,1)
21417
21418 ELSEIF(ISUB.EQ.92) THEN
21419C...Single diffractive scattering (first side, i.e. XB)
21420 SIGS=VINT(315)*VINT(316)*SIGT(0,0,2)
21421
21422 ELSEIF(ISUB.EQ.93) THEN
21423C...Single diffractive scattering (second side, i.e. AX)
21424 SIGS=VINT(315)*VINT(316)*SIGT(0,0,3)
21425
21426 ELSEIF(ISUB.EQ.94) THEN
21427C...Double diffractive scattering
21428 SIGS=VINT(315)*VINT(316)*SIGT(0,0,4)
21429
21430 ELSEIF(ISUB.EQ.95) THEN
21431C...Low-pT scattering
21432 SIGS=VINT(315)*VINT(316)*SIGT(0,0,5)
21433
21434 ELSEIF(ISUB.EQ.96) THEN
21435C...Multiple interactions: sum of QCD processes
21436 CALL PYWIDT(21,SH,WDTP,WDTE)
21437
21438C...q + q' -> q + q'
21439 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
21440 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
21441 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
21442 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)/UH2
21443 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
21444 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
21445 DO 340 I=-5,5
21446 IF(I.EQ.0) GOTO 340
21447 DO 330 J=-5,5
21448 IF(J.EQ.0) GOTO 330
21449 NCHN=NCHN+1
21450 ISIG(NCHN,1)=I
21451 ISIG(NCHN,2)=J
21452 ISIG(NCHN,3)=111
21453 SIGH(NCHN)=FACQQ1
21454 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
21455 IF(I.EQ.J) THEN
21456 SIGH(NCHN)=0.5D0*FACQQ1*RATQQI
21457 NCHN=NCHN+1
21458 ISIG(NCHN,1)=I
21459 ISIG(NCHN,2)=J
21460 ISIG(NCHN,3)=112
21461 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
21462 ENDIF
21463 330 CONTINUE
21464 340 CONTINUE
21465
21466C...q + qbar -> q' + qbar' or g + g
21467 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
21468 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
21469 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
21470 & UH2/SH2)
21471 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
21472 & TH2/SH2)
21473 DO 350 I=-5,5
21474 IF(I.EQ.0) GOTO 350
21475 NCHN=NCHN+1
21476 ISIG(NCHN,1)=I
21477 ISIG(NCHN,2)=-I
21478 ISIG(NCHN,3)=121
21479 SIGH(NCHN)=FACQQB
21480 NCHN=NCHN+1
21481 ISIG(NCHN,1)=I
21482 ISIG(NCHN,2)=-I
21483 ISIG(NCHN,3)=131
21484 SIGH(NCHN)=0.5D0*FACGG1
21485 NCHN=NCHN+1
21486 ISIG(NCHN,1)=I
21487 ISIG(NCHN,2)=-I
21488 ISIG(NCHN,3)=132
21489 SIGH(NCHN)=0.5D0*FACGG2
21490 350 CONTINUE
21491
21492C...q + g -> q + g
21493 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
21494 & UH/SH)*FACA
21495 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
21496 & SH/UH)
21497 DO 370 I=-5,5
21498 IF(I.EQ.0) GOTO 370
21499 DO 360 ISDE=1,2
21500 NCHN=NCHN+1
21501 ISIG(NCHN,ISDE)=I
21502 ISIG(NCHN,3-ISDE)=21
21503 ISIG(NCHN,3)=281
21504 SIGH(NCHN)=FACQG1
21505 NCHN=NCHN+1
21506 ISIG(NCHN,ISDE)=I
21507 ISIG(NCHN,3-ISDE)=21
21508 ISIG(NCHN,3)=282
21509 SIGH(NCHN)=FACQG2
21510 360 CONTINUE
21511 370 CONTINUE
21512
21513C...g + g -> q + qbar (only d, u, s)
21514 IDC0=MDCY(21,2)-1
21515 FLAVWT=0D0
21516 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
21517 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
21518 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
21519 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
21520 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
21521 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
21522 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
21523 & UH2/SH2)*FLAVWT*FACA
21524 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
21525 & TH2/SH2)*FLAVWT*FACA
21526 NCHN=NCHN+1
21527 ISIG(NCHN,1)=21
21528 ISIG(NCHN,2)=21
21529 ISIG(NCHN,3)=531
21530 SIGH(NCHN)=FACQQ1
21531 NCHN=NCHN+1
21532 ISIG(NCHN,1)=21
21533 ISIG(NCHN,2)=21
21534 ISIG(NCHN,3)=532
21535 SIGH(NCHN)=FACQQ2
21536
21537C...g + g -> c + cbar, b + bbar: modified that/uhat for fixed
21538C...cos(theta-hat)
21539 DO 380 IFL=4,5
21540 SQMAVG=PMAS(IFL,1)**2
21541 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
21542 BE34=SQRT(1D0-4D0*SQMAVG/SH)
21543 THQ=-0.5D0*SH*(1D0-BE34*CTH)
21544 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
21545 THUHQ=THQ*UHQ-SQMAVG*SH
21546 IF(MSTP(34).EQ.0) THEN
21547 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
21548 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
21549 ELSE
21550 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
21551 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
21552 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
21553 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
21554 ENDIF
21555 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
21556 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
21557 NCHN=NCHN+1
21558 ISIG(NCHN,1)=21
21559 ISIG(NCHN,2)=21
21560 ISIG(NCHN,3)=531+2*(IFL-3)
21561 SIGH(NCHN)=FACQQ1
21562 NCHN=NCHN+1
21563 ISIG(NCHN,1)=21
21564 ISIG(NCHN,2)=21
21565 ISIG(NCHN,3)=532+2*(IFL-3)
21566 SIGH(NCHN)=FACQQ2
21567 ENDIF
21568 380 CONTINUE
21569
21570C...g + g -> g + g
21571 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
21572 & 2D0*TH/SH+TH2/SH2)*FACA
21573 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
21574 & 2D0*SH/UH+SH2/UH2)*FACA
21575 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+
21576 & 2D0*UH/TH+UH2/TH2)
21577 NCHN=NCHN+1
21578 ISIG(NCHN,1)=21
21579 ISIG(NCHN,2)=21
21580 ISIG(NCHN,3)=681
21581 SIGH(NCHN)=0.5D0*FACGG1
21582 NCHN=NCHN+1
21583 ISIG(NCHN,1)=21
21584 ISIG(NCHN,2)=21
21585 ISIG(NCHN,3)=682
21586 SIGH(NCHN)=0.5D0*FACGG2
21587 NCHN=NCHN+1
21588 ISIG(NCHN,1)=21
21589 ISIG(NCHN,2)=21
21590 ISIG(NCHN,3)=683
21591 SIGH(NCHN)=0.5D0*FACGG3
21592
21593 ELSEIF(ISUB.EQ.99) THEN
21594C...f + gamma* -> f.
21595 IF(MINT(107).EQ.4) THEN
21596 Q2GA=VINT(307)
21597 P2GA=VINT(308)
21598 ISDE=2
21599 ELSE
21600 Q2GA=VINT(308)
21601 P2GA=VINT(307)
21602 ISDE=1
21603 ENDIF
21604 COMFAC=PARU(5)*4D0*PARU(1)**2*PARU(101)*VINT(315)*VINT(316)
21605 PM2RHO=PMAS(PYCOMP(113),1)**2
21606 IF(MSTP(19).EQ.0) THEN
21607 COMFAC=COMFAC/Q2GA
21608 ELSEIF(MSTP(19).EQ.1) THEN
21609 COMFAC=COMFAC/(Q2GA+PM2RHO)
21610 ELSEIF(MSTP(19).EQ.2) THEN
21611 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
21612 ELSE
21613 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
21614 W2GA=VINT(2)
21615 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
21616 RDRDS=4.1D-3*W2GA**2.167D0/((Q2GA+0.15D0*W2GA)**2*
21617 & Q2GA**0.75D0)*(1D0+0.11D0*Q2GA*P2GA/(1D0+0.02D0*P2GA**2))
21618 XGA=Q2GA/(W2GA+VINT(307)+VINT(308))
21619 ELSE
21620 RDRDS=1.5D-4*W2GA**2.167D0/((Q2GA+0.041D0*W2GA)**2*
21621 & Q2GA**0.57D0)
21622 XGA=Q2GA/(W2GA+Q2GA-PMAS(PYCOMP(MINT(10+ISDE)),1)**2)
21623 ENDIF
21624 COMFAC=COMFAC*EXP(-MAX(1D-10,RDRDS))
21625 IF(MSTP(19).EQ.4) COMFAC=COMFAC/MAX(1D-2,1D0-XGA)
21626 ENDIF
21627 DO 390 I=MMINA,MMAXA
21628 IF(I.EQ.0.OR.KFAC(ISDE,I).EQ.0) GOTO 390
21629 IF(IABS(I).LT.10.AND.IABS(I).GT.MSTP(58)) GOTO 390
21630 EI=KCHG(IABS(I),1)/3D0
21631 NCHN=NCHN+1
21632 ISIG(NCHN,ISDE)=I
21633 ISIG(NCHN,3-ISDE)=22
21634 ISIG(NCHN,3)=1
21635 SIGH(NCHN)=COMFAC*EI**2
21636 390 CONTINUE
21637 ENDIF
21638
21639 ELSE
21640 IF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN
21641C...g + g -> gamma + gamma or g + g -> g + gamma
21642 A0STUR=0D0
21643 A0STUI=0D0
21644 A0TSUR=0D0
21645 A0TSUI=0D0
21646 A0UTSR=0D0
21647 A0UTSI=0D0
21648 A1STUR=0D0
21649 A1STUI=0D0
21650 A2STUR=0D0
21651 A2STUI=0D0
21652 ALST=LOG(-SH/TH)
21653 ALSU=LOG(-SH/UH)
21654 ALTU=LOG(TH/UH)
21655 IMAX=2*MSTP(1)
21656 IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38)
21657 DO 400 I=1,IMAX
21658 EI=KCHG(IABS(I),1)/3D0
21659 EIWT=EI**2
21660 IF(ISUB.EQ.115) EIWT=EI
21661 SQMQ=PMAS(I,1)**2
21662 EPSS=4D0*SQMQ/SH
21663 EPST=4D0*SQMQ/TH
21664 EPSU=4D0*SQMQ/UH
21665 IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1D-4) THEN
21666 B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+
21667 & PARU(1)**2)
21668 B0STUI=0D0
21669 B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2
21670 B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU)
21671 B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2
21672 B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST)
21673 B1STUR=-1D0
21674 B1STUI=0D0
21675 B2STUR=-1D0
21676 B2STUI=0D0
21677 ELSE
21678 CALL PYWAUX(1,EPSS,W1SR,W1SI)
21679 CALL PYWAUX(1,EPST,W1TR,W1TI)
21680 CALL PYWAUX(1,EPSU,W1UR,W1UI)
21681 CALL PYWAUX(2,EPSS,W2SR,W2SI)
21682 CALL PYWAUX(2,EPST,W2TR,W2TI)
21683 CALL PYWAUX(2,EPSU,W2UR,W2UI)
21684 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
21685 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
21686 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
21687 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
21688 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
21689 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
21690 B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+
21691 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)-
21692 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)-
21693 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+
21694 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
21695 & 0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
21696 B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+
21697 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)-
21698 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)-
21699 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+
21700 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
21701 & 0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
21702 B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+
21703 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)-
21704 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)-
21705 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+
21706 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
21707 & 0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)
21708 B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+
21709 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)-
21710 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)-
21711 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+
21712 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
21713 & 0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)
21714 B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+
21715 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)-
21716 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)-
21717 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+
21718 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
21719 & 0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR)
21720 B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+
21721 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)-
21722 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)-
21723 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+
21724 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
21725 & 0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI)
21726 B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+
21727 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+
21728 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+
21729 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
21730 B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+
21731 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+
21732 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+
21733 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
21734 B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+
21735 & 0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+
21736 & 0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR)
21737 B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+
21738 & 0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+
21739 & 0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI)
21740 ENDIF
21741 A0STUR=A0STUR+EIWT*B0STUR
21742 A0STUI=A0STUI+EIWT*B0STUI
21743 A0TSUR=A0TSUR+EIWT*B0TSUR
21744 A0TSUI=A0TSUI+EIWT*B0TSUI
21745 A0UTSR=A0UTSR+EIWT*B0UTSR
21746 A0UTSI=A0UTSI+EIWT*B0UTSI
21747 A1STUR=A1STUR+EIWT*B1STUR
21748 A1STUI=A1STUI+EIWT*B1STUI
21749 A2STUR=A2STUR+EIWT*B2STUR
21750 A2STUI=A2STUI+EIWT*B2STUI
21751 400 CONTINUE
21752 ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+
21753 & A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2
21754 FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM
21755 FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM
21756 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
21757 NCHN=NCHN+1
21758 ISIG(NCHN,1)=21
21759 ISIG(NCHN,2)=21
21760 ISIG(NCHN,3)=1
21761 IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG
21762 IF(ISUB.EQ.115) SIGH(NCHN)=FACGP
21763 410 CONTINUE
21764
21765 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
21766C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only)
21767 PH=0D0
21768 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
21769 & PH=VINT(3)**2
21770 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
21771 & PH=VINT(4)**2
21772 IF(ISUB.EQ.131) THEN
21773 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**2*
21774 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
21775 ELSE
21776 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
21777 ENDIF
21778 DO 430 I=MMINA,MMAXA
21779 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
21780 EI=KCHG(IABS(I),1)/3D0
21781 FACGQ=FGQ*EI**2
21782 DO 420 ISDE=1,2
21783 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 420
21784 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 420
21785 NCHN=NCHN+1
21786 ISIG(NCHN,ISDE)=I
21787 ISIG(NCHN,3-ISDE)=22
21788 ISIG(NCHN,3)=1
21789 SIGH(NCHN)=FACGQ
21790 420 CONTINUE
21791 430 CONTINUE
21792
21793 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
21794C...f + gamma*_(T,L) -> f + gamma
21795 PH=0D0
21796 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
21797 & PH=VINT(3)**2
21798 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
21799 & PH=VINT(4)**2
21800 IF(ISUB.EQ.133) THEN
21801 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**2*
21802 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
21803 ELSE
21804 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
21805 ENDIF
21806 DO 450 I=MMINA,MMAXA
21807 IF(I.EQ.0) GOTO 450
21808 EI=KCHG(IABS(I),1)/3D0
21809 FACGQ=FGQ*EI**4
21810 DO 440 ISDE=1,2
21811 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 440
21812 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 440
21813 NCHN=NCHN+1
21814 ISIG(NCHN,ISDE)=I
21815 ISIG(NCHN,3-ISDE)=22
21816 ISIG(NCHN,3)=1
21817 SIGH(NCHN)=FACGQ
21818 440 CONTINUE
21819 450 CONTINUE
21820
21821 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
21822C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only)
21823 PH=0D0
21824 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
21825 & PH=VINT(3)**2
21826 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
21827 & PH=VINT(4)**2
21828 CALL PYWIDT(21,SH,WDTP,WDTE)
21829 WDTESU=0D0
21830 DO 460 I=1,MIN(8,MDCY(21,3))
21831 EF=KCHG(I,1)/3D0
21832 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
21833 & WDTE(I,4))
21834 460 CONTINUE
21835 IF(ISUB.EQ.135) THEN
21836 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**2*
21837 & ((TH2+UH2-2D0*PH*SH)/(TH*UH)+4D0*PH*SH/(SH+PH)**2)
21838 ELSE
21839 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**4*8D0*PH*SH
21840 ENDIF
21841 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
21842 NCHN=NCHN+1
21843 ISIG(NCHN,1)=21
21844 ISIG(NCHN,2)=22
21845 ISIG(NCHN,3)=1
21846 SIGH(NCHN)=FACQQ
21847 ENDIF
21848 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
21849 NCHN=NCHN+1
21850 ISIG(NCHN,1)=22
21851 ISIG(NCHN,2)=21
21852 ISIG(NCHN,3)=1
21853 SIGH(NCHN)=FACQQ
21854 ENDIF
21855
21856 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
21857C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar
21858 PH1=0D0
21859 IF(VINT(3).LT.0D0) PH1=VINT(3)**2
21860 PH2=0D0
21861 IF(VINT(4).LT.0D0) PH2=VINT(4)**2
21862 CALL PYWIDT(22,SH,WDTP,WDTE)
21863 WDTESU=0D0
21864 DO 470 I=1,MIN(12,MDCY(22,3))
21865 IF(I.LE.8) EF= KCHG(I,1)/3D0
21866 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
21867 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
21868 & WDTE(I,4))
21869 470 CONTINUE
21870 DLAMB2=(TH+UH)**2-4D0*PH1*PH2
21871 IF(ISUB.EQ.137) THEN
21872 FPARAM=-SH*(TH+UH)/DLAMB2
21873 FACFF=COMFAC*AEM**2*WDTESU*2D0*SH2/(DLAMB2*TH2*UH2)*
21874 & (TH*UH-PH1*PH2)*((TH2+UH2)*(1D0-2D0*FPARAM*(1D0-FPARAM))-
21875 & 2D0*PH1*PH2*FPARAM**2)
21876 ELSEIF(ISUB.EQ.138) THEN
21877 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
21878 & PH2*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH1*SH*(TH-UH)**2/DLAMB2)+
21879 & 2D0*PH1**2*(TH-UH)**2)
21880 ELSEIF(ISUB.EQ.139) THEN
21881 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
21882 & PH1*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH2*SH*(TH-UH)**2/DLAMB2)+
21883 & 2D0*PH2**2*(TH-UH)**2)
21884 ELSE
21885 FACFF=COMFAC*AEM**2*WDTESU*32D0*SH2**2/(DLAMB2**3*TH2*UH2)*
21886 & PH1*PH2*(TH*UH-PH1*PH2)*(TH-UH)**2
21887 ENDIF
21888 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
21889 NCHN=NCHN+1
21890 ISIG(NCHN,1)=22
21891 ISIG(NCHN,2)=22
21892 ISIG(NCHN,3)=1
21893 SIGH(NCHN)=FACFF
21894 ENDIF
21895
21896 ENDIF
21897 ENDIF
21898
21899 RETURN
21900 END
21901
21902C*********************************************************************
21903
21904C...PYSGHF
21905C...Subprocess cross sections for heavy flavour production,
21906C...open and closed.
21907C...Auxiliary to PYSIGH.
21908
21909 SUBROUTINE PYSGHF(NCHN,SIGS)
21910
21911C...Double precision and integer declarations
21912 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21913 IMPLICIT INTEGER(I-N)
21914 INTEGER PYK,PYCHGE,PYCOMP
21915C...Parameter statement to help give large particle numbers.
21916 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
21917 &KEXCIT=4000000,KDIMEN=5000000)
21918C...Commonblocks
21919 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21920 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21921 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21922 COMMON/PYINT1/MINT(400),VINT(400)
21923 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
21924 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
21925 COMMON/PYINT4/MWID(500),WIDS(500,5)
21926 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
21927 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
21928 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
21929 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
21930 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
21931 &/PYINT4/,/PYSGCM/
21932C...Local arrays
21933 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
21934
21935C...Differential cross section expressions.
21936
21937 IF(ISUB.LE.100) THEN
21938 IF(ISUB.EQ.81) THEN
21939C...q + qbar -> Q + Qbar
21940 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
21941 THQ=-0.5D0*SH*(1D0-BE34*CTH)
21942 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
21943 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
21944 & 2D0*SQMAVG/SH)
21945 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
21946 WID2=1D0
21947 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
21948 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
21949 FACQQB=FACQQB*WID2
21950 DO 100 I=MMINA,MMAXA
21951 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
21952 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
21953 NCHN=NCHN+1
21954 ISIG(NCHN,1)=I
21955 ISIG(NCHN,2)=-I
21956 ISIG(NCHN,3)=1
21957 SIGH(NCHN)=FACQQB
21958 100 CONTINUE
21959
21960 ELSEIF(ISUB.EQ.82) THEN
21961C...g + g -> Q + Qbar
21962 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
21963 THQ=-0.5D0*SH*(1D0-BE34*CTH)
21964 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
21965 THUHQ=THQ*UHQ-SQMAVG*SH
21966 IF(MSTP(34).EQ.0) THEN
21967 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
21968 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
21969 ELSE
21970 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
21971 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
21972 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
21973 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
21974 ENDIF
21975 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
21976 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
21977 IF(MSTP(35).GE.1) THEN
21978 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
21979 FACQQ1=FACQQ1*FATRE
21980 FACQQ2=FACQQ2*FATRE
21981 ENDIF
21982 WID2=1D0
21983 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
21984 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
21985 FACQQ1=FACQQ1*WID2
21986 FACQQ2=FACQQ2*WID2
21987 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 110
21988 NCHN=NCHN+1
21989 ISIG(NCHN,1)=21
21990 ISIG(NCHN,2)=21
21991 ISIG(NCHN,3)=1
21992 SIGH(NCHN)=FACQQ1
21993 NCHN=NCHN+1
21994 ISIG(NCHN,1)=21
21995 ISIG(NCHN,2)=21
21996 ISIG(NCHN,3)=2
21997 SIGH(NCHN)=FACQQ2
21998 110 CONTINUE
21999
22000 ELSEIF(ISUB.EQ.83) THEN
22001C...f + q -> f' + Q
22002 FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2
22003 FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2
22004 DO 130 I=MMIN1,MMAX1
22005 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 130
22006 DO 120 J=MMIN2,MMAX2
22007 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 120
22008 IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 120
22009 IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 120
22010 IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1)
22011 & THEN
22012 NCHN=NCHN+1
22013 ISIG(NCHN,1)=I
22014 ISIG(NCHN,2)=J
22015 ISIG(NCHN,3)=1
22016 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
22017 & (IABS(I)+1)/2)*VINT(180+J)
22018 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2,
22019 & (MINT(55)+1)/2)*VINT(180+J)
22020 WID2=1D0
22021 IF(I.GT.0) THEN
22022 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
22023 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
22024 & WIDS(MINT(55),2)
22025 ELSE
22026 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
22027 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
22028 & WIDS(MINT(55),3)
22029 ENDIF
22030 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
22031 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
22032 ENDIF
22033 IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1)
22034 & THEN
22035 NCHN=NCHN+1
22036 ISIG(NCHN,1)=I
22037 ISIG(NCHN,2)=J
22038 ISIG(NCHN,3)=2
22039 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
22040 & (IABS(J)+1)/2)*VINT(180+I)
22041 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2,
22042 & (MINT(55)+1)/2)*VINT(180+I)
22043 IF(J.GT.0) THEN
22044 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
22045 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
22046 & WIDS(MINT(55),2)
22047 ELSE
22048 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
22049 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
22050 & WIDS(MINT(55),3)
22051 ENDIF
22052 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
22053 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
22054 ENDIF
22055 120 CONTINUE
22056 130 CONTINUE
22057
22058 ELSEIF(ISUB.EQ.84) THEN
22059C...g + gamma -> Q + Qbar
22060 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
22061 THQ=-0.5D0*SH*(1D0-BE34*CTH)
22062 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
22063 FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
22064 & (THQ**2+UHQ**2+4D0*SQMAVG*SH*(1D0-SQMAVG*SH/(THQ*UHQ)))/
22065 & (THQ*UHQ)
22066 IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQMAVG,0D0)
22067 WID2=1D0
22068 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
22069 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
22070 FACQQ=FACQQ*WID2
22071 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
22072 NCHN=NCHN+1
22073 ISIG(NCHN,1)=21
22074 ISIG(NCHN,2)=22
22075 ISIG(NCHN,3)=1
22076 SIGH(NCHN)=FACQQ
22077 ENDIF
22078 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
22079 NCHN=NCHN+1
22080 ISIG(NCHN,1)=22
22081 ISIG(NCHN,2)=21
22082 ISIG(NCHN,3)=1
22083 SIGH(NCHN)=FACQQ
22084 ENDIF
22085
22086 ELSEIF(ISUB.EQ.85) THEN
22087C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
22088 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
22089 THQ=-0.5D0*SH*(1D0-BE34*CTH)
22090 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
22091 FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
22092 & ((1D0-PARJ(131)*PARJ(132))*(THQ*UHQ-SQMAVG*SH)*
22093 & (UHQ**2+THQ**2+2D0*SQMAVG*SH)+(1D0+PARJ(131)*PARJ(132))*
22094 & SQMAVG*SH**2*(SH-2D0*SQMAVG))/(THQ*UHQ)**2
22095 IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF
22096 IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1)
22097 & FACFF=FACFF*PYHFTH(SH,SQMAVG,1D0)
22098 WID2=1D0
22099 IF(MINT(56).EQ.6) WID2=WIDS(6,1)
22100 IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1)
22101 IF(MINT(56).EQ.17) WID2=WIDS(17,1)
22102 FACFF=FACFF*WID2
22103 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
22104 NCHN=NCHN+1
22105 ISIG(NCHN,1)=22
22106 ISIG(NCHN,2)=22
22107 ISIG(NCHN,3)=1
22108 SIGH(NCHN)=FACFF
22109 ENDIF
22110
22111 ELSEIF(ISUB.EQ.86) THEN
22112C...g + g -> J/Psi + g
22113 FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)*
22114 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
22115 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
22116 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
22117 NCHN=NCHN+1
22118 ISIG(NCHN,1)=21
22119 ISIG(NCHN,2)=21
22120 ISIG(NCHN,3)=1
22121 SIGH(NCHN)=FACQQG
22122 ENDIF
22123
22124 ELSEIF(ISUB.EQ.87) THEN
22125C...g + g -> chi_0c + g
22126 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
22127 QGTW=(SH*TH*UH)/SH**3
22128 RGTW=SQM3/SH
22129 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
22130 & (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
22131 & 6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)-
22132 & PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+
22133 & 2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/
22134 & (QGTW*(QGTW-RGTW*PGTW)**4)
22135 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
22136 NCHN=NCHN+1
22137 ISIG(NCHN,1)=21
22138 ISIG(NCHN,2)=21
22139 ISIG(NCHN,3)=1
22140 SIGH(NCHN)=FACQQG
22141 ENDIF
22142
22143 ELSEIF(ISUB.EQ.88) THEN
22144C...g + g -> chi_1c + g
22145 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
22146 QGTW=(SH*TH*UH)/SH**3
22147 RGTW=SQM3/SH
22148 FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
22149 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+
22150 & 5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/
22151 & (QGTW-RGTW*PGTW)**4
22152 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
22153 NCHN=NCHN+1
22154 ISIG(NCHN,1)=21
22155 ISIG(NCHN,2)=21
22156 ISIG(NCHN,3)=1
22157 SIGH(NCHN)=FACQQG
22158 ENDIF
22159
22160 ELSEIF(ISUB.EQ.89) THEN
22161C...g + g -> chi_2c + g
22162 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
22163 QGTW=(SH*TH*UH)/SH**3
22164 RGTW=SQM3/SH
22165 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
22166 & (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
22167 & 3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+
22168 & 2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+
22169 & RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2*
22170 & QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
22171 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
22172 NCHN=NCHN+1
22173 ISIG(NCHN,1)=21
22174 ISIG(NCHN,2)=21
22175 ISIG(NCHN,3)=1
22176 SIGH(NCHN)=FACQQG
22177 ENDIF
22178 ENDIF
22179
22180 ELSEIF(ISUB.LE.200) THEN
22181 IF(ISUB.EQ.104) THEN
22182C...g + g -> chi_c0.
22183 KC=PYCOMP(10441)
22184 FACBW=COMFAC*12D0*AS**2*PARP(39)*PMAS(KC,2)/
22185 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
22186 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
22187 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
22188 NCHN=NCHN+1
22189 ISIG(NCHN,1)=21
22190 ISIG(NCHN,2)=21
22191 ISIG(NCHN,3)=1
22192 SIGH(NCHN)=FACBW
22193 ENDIF
22194
22195 ELSEIF(ISUB.EQ.105) THEN
22196C...g + g -> chi_c2.
22197 KC=PYCOMP(445)
22198 FACBW=COMFAC*16D0*AS**2*PARP(39)*PMAS(KC,2)/
22199 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
22200 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
22201 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
22202 NCHN=NCHN+1
22203 ISIG(NCHN,1)=21
22204 ISIG(NCHN,2)=21
22205 ISIG(NCHN,3)=1
22206 SIGH(NCHN)=FACBW
22207 ENDIF
22208
22209 ELSEIF(ISUB.EQ.106) THEN
22210C...g + g -> J/Psi + gamma.
22211 EQ=2D0/3D0
22212 FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)*
22213 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
22214 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
22215 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
22216 NCHN=NCHN+1
22217 ISIG(NCHN,1)=21
22218 ISIG(NCHN,2)=21
22219 ISIG(NCHN,3)=1
22220 SIGH(NCHN)=FACQQG
22221 ENDIF
22222
22223 ELSEIF(ISUB.EQ.107) THEN
22224C...g + gamma -> J/Psi + g.
22225 EQ=2D0/3D0
22226 FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)*
22227 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
22228 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
22229 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
22230 NCHN=NCHN+1
22231 ISIG(NCHN,1)=21
22232 ISIG(NCHN,2)=22
22233 ISIG(NCHN,3)=1
22234 SIGH(NCHN)=FACQQG
22235 ENDIF
22236 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
22237 NCHN=NCHN+1
22238 ISIG(NCHN,1)=22
22239 ISIG(NCHN,2)=21
22240 ISIG(NCHN,3)=1
22241 SIGH(NCHN)=FACQQG
22242 ENDIF
22243
22244 ELSEIF(ISUB.EQ.108) THEN
22245C...gamma + gamma -> J/Psi + gamma.
22246 EQ=2D0/3D0
22247 FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)*
22248 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
22249 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
22250 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
22251 NCHN=NCHN+1
22252 ISIG(NCHN,1)=22
22253 ISIG(NCHN,2)=22
22254 ISIG(NCHN,3)=1
22255 SIGH(NCHN)=FACQQG
22256 ENDIF
22257 ENDIF
22258 ENDIF
22259
22260 RETURN
22261 END
22262
22263C*********************************************************************
22264
22265C...PYSGWZ
22266C...Subprocess cross sections for W/Z processes,
22267C...except that longitudinal WW scattering is in Higgs sector.
22268C...Auxiliary to PYSIGH.
22269
22270 SUBROUTINE PYSGWZ(NCHN,SIGS)
22271
22272C...Double precision and integer declarations
22273 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22274 IMPLICIT INTEGER(I-N)
22275 INTEGER PYK,PYCHGE,PYCOMP
22276C...Parameter statement to help give large particle numbers.
22277 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
22278 &KEXCIT=4000000,KDIMEN=5000000)
22279C...Commonblocks
22280 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22281 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
22282 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
22283 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
22284 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22285 COMMON/PYINT1/MINT(400),VINT(400)
22286 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
22287 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
22288 COMMON/PYINT4/MWID(500),WIDS(500,5)
22289 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
22290 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
22291 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
22292 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
22293 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
22294 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
22295 &/PYINT2/,/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
22296C...Local arrays and complex numbers
22297 DIMENSION WDTP(0:400),WDTE(0:400,0:5),HGZ(6,3),HL3(3),HR3(3),
22298 &HL4(3),HR4(3)
22299 COMPLEX*16 COULCK,COULCP,COULCD,COULCR,COULCS
22300
22301C...Differential cross section expressions.
22302
22303 IF(ISUB.LE.20) THEN
22304 IF(ISUB.EQ.1) THEN
22305C...f + fbar -> gamma*/Z0
22306 MINT(61)=2
22307 CALL PYWIDT(23,SH,WDTP,WDTE)
22308 HS=SHR*WDTP(0)
22309 FACZ=4D0*COMFAC*3D0
22310 HP0=AEM/3D0*SH
22311 HP1=AEM/3D0*XWC*SH
22312 DO 100 I=MMINA,MMAXA
22313 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
22314 EI=KCHG(IABS(I),1)/3D0
22315 AI=SIGN(1D0,EI)
22316 VI=AI-4D0*EI*XWV
22317 HI0=HP0
22318 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
22319 HI1=HP1
22320 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
22321 NCHN=NCHN+1
22322 ISIG(NCHN,1)=I
22323 ISIG(NCHN,2)=-I
22324 ISIG(NCHN,3)=1
22325 SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+
22326 & EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*
22327 & (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/
22328 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114))
22329 100 CONTINUE
22330
22331 ELSEIF(ISUB.EQ.2) THEN
22332C...f + fbar' -> W+/-
22333 CALL PYWIDT(24,SH,WDTP,WDTE)
22334 HS=SHR*WDTP(0)
22335 FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0
22336 HP=AEM/(24D0*XW)*SH
22337 DO 120 I=MMIN1,MMAX1
22338 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
22339 IA=IABS(I)
22340 DO 110 J=MMIN2,MMAX2
22341 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
22342 JA=IABS(J)
22343 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
22344 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
22345 & GOTO 110
22346 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
22347 HI=HP*2D0
22348 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
22349 NCHN=NCHN+1
22350 ISIG(NCHN,1)=I
22351 ISIG(NCHN,2)=J
22352 ISIG(NCHN,3)=1
22353 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
22354 SIGH(NCHN)=HI*FACBW*HF
22355 110 CONTINUE
22356 120 CONTINUE
22357
22358 ELSEIF(ISUB.EQ.15) THEN
22359C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
22360 FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
22361C...gamma, gamma/Z interference and Z couplings to final fermion pairs
22362 HFGG=0D0
22363 HFGZ=0D0
22364 HFZZ=0D0
22365 RADC4=1D0+PYALPS(SQM4)/PARU(1)
22366 DO 130 I=1,MIN(16,MDCY(23,3))
22367 IDC=I+MDCY(23,2)-1
22368 IF(MDME(IDC,1).LT.0) GOTO 130
22369 IMDM=0
22370 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
22371 & IMDM=1
22372 IF(I.LE.8) THEN
22373 EF=KCHG(I,1)/3D0
22374 AF=SIGN(1D0,EF+0.1D0)
22375 VF=AF-4D0*EF*XWV
22376 ELSEIF(I.LE.16) THEN
22377 EF=KCHG(I+2,1)/3D0
22378 AF=SIGN(1D0,EF+0.1D0)
22379 VF=AF-4D0*EF*XWV
22380 ENDIF
22381 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
22382 IF(4D0*RM1.LT.1D0) THEN
22383 FCOF=1D0
22384 IF(I.LE.8) FCOF=3D0*RADC4
22385 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
22386 IF(IMDM.EQ.1) THEN
22387 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
22388 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
22389 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
22390 & AF**2*(1D0-4D0*RM1))*BE34
22391 ENDIF
22392 ENDIF
22393 130 CONTINUE
22394C...Propagators: as simulated in PYOFSH and as desired
22395 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
22396 MINT15=MINT(15)
22397 MINT(15)=1
22398 MINT(61)=1
22399 CALL PYWIDT(23,SQM4,WDTP,WDTE)
22400 MINT(15)=MINT15
22401 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
22402 HFGG=HFGG*HFAEM*VINT(111)/SQM4
22403 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
22404 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
22405C...Loop over flavours; consider full gamma/Z structure
22406 DO 140 I=MMINA,MMAXA
22407 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
22408 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
22409 EI=KCHG(IABS(I),1)/3D0
22410 AI=SIGN(1D0,EI)
22411 VI=AI-4D0*EI*XWV
22412 NCHN=NCHN+1
22413 ISIG(NCHN,1)=I
22414 ISIG(NCHN,2)=-I
22415 ISIG(NCHN,3)=1
22416 SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+
22417 & (VI**2+AI**2)*HFZZ)/HBW4
22418 140 CONTINUE
22419
22420 ELSEIF(ISUB.EQ.16) THEN
22421C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
22422 FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
22423C...Propagators: as simulated in PYOFSH and as desired
22424 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
22425 CALL PYWIDT(24,SQM4,WDTP,WDTE)
22426 GMMWC=SQRT(SQM4)*WDTP(0)
22427 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
22428 FACWG=FACWG*HBW4C/HBW4
22429 DO 160 I=MMIN1,MMAX1
22430 IA=IABS(I)
22431 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 160
22432 DO 150 J=MMIN2,MMAX2
22433 JA=IABS(J)
22434 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 150
22435 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 150
22436 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
22437 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
22438 FCKM=VCKM((IA+1)/2,(JA+1)/2)
22439 NCHN=NCHN+1
22440 ISIG(NCHN,1)=I
22441 ISIG(NCHN,2)=J
22442 ISIG(NCHN,3)=1
22443 SIGH(NCHN)=FACWG*FCKM*WIDSC
22444 150 CONTINUE
22445 160 CONTINUE
22446
22447 ELSEIF(ISUB.EQ.19) THEN
22448C...f + fbar -> gamma + (gamma*/Z0)
22449 FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
22450C...gamma, gamma/Z interference and Z couplings to final fermion pairs
22451 HFGG=0D0
22452 HFGZ=0D0
22453 HFZZ=0D0
22454 RADC4=1D0+PYALPS(SQM4)/PARU(1)
22455 DO 170 I=1,MIN(16,MDCY(23,3))
22456 IDC=I+MDCY(23,2)-1
22457 IF(MDME(IDC,1).LT.0) GOTO 170
22458 IMDM=0
22459 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
22460 & IMDM=1
22461 IF(I.LE.8) THEN
22462 EF=KCHG(I,1)/3D0
22463 AF=SIGN(1D0,EF+0.1D0)
22464 VF=AF-4D0*EF*XWV
22465 ELSEIF(I.LE.16) THEN
22466 EF=KCHG(I+2,1)/3D0
22467 AF=SIGN(1D0,EF+0.1D0)
22468 VF=AF-4D0*EF*XWV
22469 ENDIF
22470 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
22471 IF(4D0*RM1.LT.1D0) THEN
22472 FCOF=1D0
22473 IF(I.LE.8) FCOF=3D0*RADC4
22474 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
22475 IF(IMDM.EQ.1) THEN
22476 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
22477 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
22478 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
22479 & AF**2*(1D0-4D0*RM1))*BE34
22480 ENDIF
22481 ENDIF
22482 170 CONTINUE
22483C...Propagators: as simulated in PYOFSH and as desired
22484 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
22485 MINT15=MINT(15)
22486 MINT(15)=1
22487 MINT(61)=1
22488 CALL PYWIDT(23,SQM4,WDTP,WDTE)
22489 MINT(15)=MINT15
22490 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
22491 HFGG=HFGG*HFAEM*VINT(111)/SQM4
22492 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
22493 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
22494C...Loop over flavours; consider full gamma/Z structure
22495 DO 180 I=MMINA,MMAXA
22496 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180
22497 EI=KCHG(IABS(I),1)/3D0
22498 AI=SIGN(1D0,EI)
22499 VI=AI-4D0*EI*XWV
22500 FCOI=1D0
22501 IF(IABS(I).LE.10) FCOI=FACA/3D0
22502 NCHN=NCHN+1
22503 ISIG(NCHN,1)=I
22504 ISIG(NCHN,2)=-I
22505 ISIG(NCHN,3)=1
22506 SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+
22507 & (VI**2+AI**2)*HFZZ)/HBW4
22508 180 CONTINUE
22509
22510 ELSEIF(ISUB.EQ.20) THEN
22511C...f + fbar' -> gamma + W+/-
22512 FACGW=COMFAC*0.5D0*AEM**2/XW
22513C...Propagators: as simulated in PYOFSH and as desired
22514 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
22515 CALL PYWIDT(24,SQM4,WDTP,WDTE)
22516 GMMWC=SQRT(SQM4)*WDTP(0)
22517 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
22518 FACGW=FACGW*HBW4C/HBW4
22519C...Anomalous couplings
22520 TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
22521 TERM2=0D0
22522 TERM3=0D0
22523 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
22524 TERM2=RTCM(46)*(TH-UH)/(TH+UH)
22525 TERM3=0.5D0*RTCM(46)**2*(TH*UH+(TH2+UH2)*SH/
22526 & (4D0*SQMW))/(TH+UH)**2
22527 ENDIF
22528 DO 200 I=MMIN1,MMAX1
22529 IA=IABS(I)
22530 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 200
22531 DO 190 J=MMIN2,MMAX2
22532 JA=IABS(J)
22533 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 190
22534 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 190
22535 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
22536 & GOTO 190
22537 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
22538 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
22539 IF(IA.LE.10) THEN
22540 FACWR=UH/(TH+UH)-1D0/3D0
22541 FCKM=VCKM((IA+1)/2,(JA+1)/2)
22542 FCOI=FACA/3D0
22543 ELSE
22544 FACWR=-TH/(TH+UH)
22545 FCKM=1D0
22546 FCOI=1D0
22547 ENDIF
22548 FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3
22549 NCHN=NCHN+1
22550 ISIG(NCHN,1)=I
22551 ISIG(NCHN,2)=J
22552 ISIG(NCHN,3)=1
22553 SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC
22554 190 CONTINUE
22555 200 CONTINUE
22556 ENDIF
22557
22558 ELSEIF(ISUB.LE.40) THEN
22559 IF(ISUB.EQ.22) THEN
22560C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
22561C...Kinematics dependence
22562 FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)-
22563 & SQM3*SQM4*(1D0/TH2+1D0/UH2))
22564C...gamma, gamma/Z interference and Z couplings to final fermion pairs
22565 DO 220 I=1,6
22566 DO 210 J=1,3
22567 HGZ(I,J)=0D0
22568 210 CONTINUE
22569 220 CONTINUE
22570 RADC3=1D0+PYALPS(SQM3)/PARU(1)
22571 RADC4=1D0+PYALPS(SQM4)/PARU(1)
22572 DO 230 I=1,MIN(16,MDCY(23,3))
22573 IDC=I+MDCY(23,2)-1
22574 IF(MDME(IDC,1).LT.0) GOTO 230
22575 IMDM=0
22576 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1
22577 IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2
22578 IF(I.LE.8) THEN
22579 EF=KCHG(I,1)/3D0
22580 AF=SIGN(1D0,EF+0.1D0)
22581 VF=AF-4D0*EF*XWV
22582 ELSEIF(I.LE.16) THEN
22583 EF=KCHG(I+2,1)/3D0
22584 AF=SIGN(1D0,EF+0.1D0)
22585 VF=AF-4D0*EF*XWV
22586 ENDIF
22587 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3
22588 IF(4D0*RM1.LT.1D0) THEN
22589 FCOF=1D0
22590 IF(I.LE.8) FCOF=3D0*RADC3
22591 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
22592 IF(IMDM.GE.1) THEN
22593 HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
22594 HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
22595 HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
22596 & AF**2*(1D0-4D0*RM1))*BE34
22597 ENDIF
22598 ENDIF
22599 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
22600 IF(4D0*RM1.LT.1D0) THEN
22601 FCOF=1D0
22602 IF(I.LE.8) FCOF=3D0*RADC4
22603 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
22604 IF(IMDM.GE.1) THEN
22605 HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
22606 HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
22607 HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
22608 & AF**2*(1D0-4D0*RM1))*BE34
22609 ENDIF
22610 ENDIF
22611 230 CONTINUE
22612C...Propagators: as simulated in PYOFSH and as desired
22613 HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
22614 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
22615 MINT15=MINT(15)
22616 MINT(15)=1
22617 MINT(61)=1
22618 CALL PYWIDT(23,SQM3,WDTP,WDTE)
22619 MINT(15)=MINT15
22620 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
22621 DO 240 J=1,3
22622 HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3
22623 HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3
22624 HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3
22625 240 CONTINUE
22626 MINT15=MINT(15)
22627 MINT(15)=1
22628 MINT(61)=1
22629 CALL PYWIDT(23,SQM4,WDTP,WDTE)
22630 MINT(15)=MINT15
22631 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
22632 DO 250 J=1,3
22633 HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4
22634 HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4
22635 HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4
22636 250 CONTINUE
22637C...Loop over flavours; separate left- and right-handed couplings
22638 DO 270 I=MMINA,MMAXA
22639 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 270
22640 EI=KCHG(IABS(I),1)/3D0
22641 AI=SIGN(1D0,EI)
22642 VI=AI-4D0*EI*XWV
22643 VALI=VI-AI
22644 VARI=VI+AI
22645 FCOI=1D0
22646 IF(IABS(I).LE.10) FCOI=FACA/3D0
22647 DO 260 J=1,3
22648 HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J)
22649 HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J)
22650 HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J)
22651 HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J)
22652 260 CONTINUE
22653 FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+
22654 & HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+
22655 & HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+
22656 & HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3)
22657 NCHN=NCHN+1
22658 ISIG(NCHN,1)=I
22659 ISIG(NCHN,2)=-I
22660 ISIG(NCHN,3)=1
22661 SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4)
22662 270 CONTINUE
22663
22664 ELSEIF(ISUB.EQ.23) THEN
22665C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.)
22666 FACZW=COMFAC*0.5D0*(AEM/XW)**2
22667 FACZW=FACZW*WIDS(23,2)
22668 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
22669 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
22670 DO 290 I=MMIN1,MMAX1
22671 IA=IABS(I)
22672 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 290
22673 DO 280 J=MMIN2,MMAX2
22674 JA=IABS(J)
22675 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 280
22676 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 280
22677 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
22678 & GOTO 280
22679 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
22680 EI=KCHG(IA,1)/3D0
22681 AI=SIGN(1D0,EI+0.1D0)
22682 VI=AI-4D0*EI*XWV
22683 EJ=KCHG(JA,1)/3D0
22684 AJ=SIGN(1D0,EJ+0.1D0)
22685 VJ=AJ-4D0*EJ*XWV
22686 IF(VI+AI.GT.0) THEN
22687 VISAV=VI
22688 AISAV=AI
22689 VI=VJ
22690 AI=AJ
22691 VJ=VISAV
22692 AJ=AISAV
22693 ENDIF
22694 FCKM=1D0
22695 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
22696 FCOI=1D0
22697 IF(IA.LE.10) FCOI=FACA/3D0
22698 NCHN=NCHN+1
22699 ISIG(NCHN,1)=I
22700 ISIG(NCHN,2)=J
22701 ISIG(NCHN,3)=1
22702 SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+
22703 & (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))*
22704 & (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
22705 & THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
22706 & SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))*
22707 & WIDS(24,(5-KCHW)/2)
22708C***Protect against slightly negative cross sections. (Reason yet to be
22709C***sorted out. One possibility: addition of width to the W propagator.)
22710 SIGH(NCHN)=MAX(0D0,SIGH(NCHN))
22711 280 CONTINUE
22712 290 CONTINUE
22713
22714 ELSEIF(ISUB.EQ.25) THEN
22715C...f + fbar -> W+ + W-
22716C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
22717 GMMZC=GMMZ
22718 HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2)
22719 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
22720 CALL PYWIDT(24,SQM3,WDTP,WDTE)
22721 GMMW3=SQRT(SQM3)*WDTP(0)
22722 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
22723 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
22724 CALL PYWIDT(24,SQM4,WDTP,WDTE)
22725 GMMW4=SQRT(SQM4)*WDTP(0)
22726 HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2)
22727C...Kinematical functions
22728 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
22729 THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4)
22730 GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2
22731 GT=THUH34+4D0*THUH/TH2
22732 GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH
22733 GU=THUH34+4D0*THUH/UH2
22734 GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH
22735C...Common factors and couplings
22736 FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)
22737 FACWW=FACWW*WIDS(24,1)
22738 CGG=AEM**2/2D0
22739 CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH)
22740 CZZ=AEM**2/(32D0*XW**2)*HBWZC
22741 CNG=AEM**2/(4D0*XW)
22742 CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH)
22743 CNN=AEM**2/(16D0*XW**2)
22744C...Coulomb factor for W+W- pair
22745 IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
22746 COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1))
22747 COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH))
22748 IF(COULE.LT.100D0*PMAS(24,2)) THEN
22749 COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
22750 & PMAS(24,2)**2)-COULE))
22751 ELSE
22752 COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE))
22753 ENDIF
22754 IF(COULE.GT.-100D0*PMAS(24,2)) THEN
22755 COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
22756 & PMAS(24,2)**2)+COULE))
22757 ELSE
22758 COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/
22759 & ABS(COULE)))
22760 ENDIF
22761 IF(MSTP(40).EQ.1) THEN
22762 COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/
22763 & MAX(1D-10,2D0*COULP*COULP1))
22764 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
22765 ELSEIF(MSTP(40).EQ.2) THEN
22766 COULCK=DCMPLX(DBLE(COULP1),DBLE(COULP2))
22767 COULCP=DCMPLX(0D0,DBLE(COULP))
22768 COULCD=(COULCK+COULCP)/(COULCK-COULCP)
22769 COULCR=1D0+DBLE(PARU(101)*SQRT(SH))/
22770 & (4D0*COULCP)*LOG(COULCD)
22771 COULCS=DCMPLX(0D0,0D0)
22772 NSTP=100
22773 DO 300 ISTP=1,NSTP
22774 COULXX=(ISTP-0.5)/NSTP
22775 COULCS=COULCS+(1D0/COULXX)*LOG((1D0+COULXX*COULCD)/
22776 & (1D0+COULXX/COULCD))
22777 300 CONTINUE
22778 COULCR=COULCR+DBLE(PARU(101)**2*SH)/(16D0*COULCP*COULCK)*
22779 & (COULCS/NSTP)
22780 FACCOU=ABS(COULCR)**2
22781 ELSEIF(MSTP(40).EQ.3) THEN
22782 COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+
22783 & COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1))
22784 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
22785 ENDIF
22786 ELSEIF(MSTP(40).EQ.4) THEN
22787 FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34)
22788 ELSE
22789 FACCOU=1D0
22790 ENDIF
22791 VINT(95)=FACCOU
22792 FACWW=FACWW*FACCOU
22793C...Loop over allowed flavours
22794 DO 310 I=MMINA,MMAXA
22795 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
22796 EI=KCHG(IABS(I),1)/3D0
22797 AI=SIGN(1D0,EI+0.1D0)
22798 VI=AI-4D0*EI*XWV
22799 FCOI=1D0
22800 IF(IABS(I).LE.10) FCOI=FACA/3D0
22801 IF(MSTP(50).LE.0.OR.IABS(I).LE.10) THEN
22802 IF(AI.LT.0D0) THEN
22803 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+
22804 & (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT
22805 ELSE
22806 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS-
22807 & (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU
22808 ENDIF
22809 ELSE
22810 XMW02=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
22811 BET=SQRT(1D0-4D0*XMW02/SH)
22812 GAT=1D0/SQRT(1D0-BET**2)
22813 STHE2=1D0-CTH**2
22814 AMPZG=BET**3*(16D0+(4D0*BET**2*GAT**2+3D0/GAT**2)*STHE2)
22815 AMPNU=BET*(2D0+BET**2*GAT**2*STHE2/2D0+
22816 & 2D0*BET**2*(1D0-BET**2)*STHE2/(1D0-2D0*BET*CTH+BET**2)**2)
22817 AMPNG=BET*((1D0+BET**2)*(4D0+BET**2*GAT**2*STHE2)+
22818 & 2D0*(1D0-BET**2)*(BET**2*STHE2-2D0*(1D0-BET**2))/
22819 & (1D0-2D0*BET*CTH+BET**2))
22820 PROPI1=(0.25D0*SQMZ/XMW02)*HBWZC*(1D0-SQMZ/SH)
22821 PROPI2=(0.25D0*SQMZ/XMW02)**2*HBWZC
22822 A0=(2D0*(XMW02/SQMZ)-(1D0-BET**2)*XW)*POLL
22823 A1=(2D0*(XMW02/SQMZ)**2-2*XMW02/SQMZ*(1D0-BET**2)*XW)*POLL
22824 A2=(1D0-BET**2)**2*XW**2*(POLR+POLL)/2D0
22825 ATOT=AMPNU*POLL+(A1+A2)*PROPI2*AMPZG-A0*PROPI1*AMPNG
22826 ATOT=ATOT*CNN/SQMW*SH/BET*2D0
22827 DSIGWW=ATOT
22828 ENDIF
22829 NCHN=NCHN+1
22830 ISIG(NCHN,1)=I
22831 ISIG(NCHN,2)=-I
22832 ISIG(NCHN,3)=1
22833 SIGH(NCHN)=FACWW*FCOI*DSIGWW
22834 310 CONTINUE
22835
22836 ELSEIF(ISUB.EQ.30) THEN
22837C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
22838 FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/
22839 & (-SH*UH)
22840C...gamma, gamma/Z interference and Z couplings to final fermion pairs
22841 HFGG=0D0
22842 HFGZ=0D0
22843 HFZZ=0D0
22844 RADC4=1D0+PYALPS(SQM4)/PARU(1)
22845 DO 320 I=1,MIN(16,MDCY(23,3))
22846 IDC=I+MDCY(23,2)-1
22847 IF(MDME(IDC,1).LT.0) GOTO 320
22848 IMDM=0
22849 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
22850 & IMDM=1
22851 IF(I.LE.8) THEN
22852 EF=KCHG(I,1)/3D0
22853 AF=SIGN(1D0,EF+0.1D0)
22854 VF=AF-4D0*EF*XWV
22855 ELSEIF(I.LE.16) THEN
22856 EF=KCHG(I+2,1)/3D0
22857 AF=SIGN(1D0,EF+0.1D0)
22858 VF=AF-4D0*EF*XWV
22859 ENDIF
22860 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
22861 IF(4D0*RM1.LT.1D0) THEN
22862 FCOF=1D0
22863 IF(I.LE.8) FCOF=3D0*RADC4
22864 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
22865 IF(IMDM.EQ.1) THEN
22866 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
22867 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
22868 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
22869 & AF**2*(1D0-4D0*RM1))*BE34
22870 ENDIF
22871 ENDIF
22872 320 CONTINUE
22873C...Propagators: as simulated in PYOFSH and as desired
22874 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
22875 MINT15=MINT(15)
22876 MINT(15)=1
22877 MINT(61)=1
22878 CALL PYWIDT(23,SQM4,WDTP,WDTE)
22879 MINT(15)=MINT15
22880 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
22881 HFGG=HFGG*HFAEM*VINT(111)/SQM4
22882 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
22883 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
22884C...Loop over flavours; consider full gamma/Z structure
22885 DO 340 I=MMINA,MMAXA
22886 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
22887 EI=KCHG(IABS(I),1)/3D0
22888 AI=SIGN(1D0,EI)
22889 VI=AI-4D0*EI*XWV
22890 FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+
22891 & (VI**2+AI**2)*HFZZ)/HBW4
22892 DO 330 ISDE=1,2
22893 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
22894 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
22895 NCHN=NCHN+1
22896 ISIG(NCHN,ISDE)=I
22897 ISIG(NCHN,3-ISDE)=21
22898 ISIG(NCHN,3)=1
22899 SIGH(NCHN)=FACZQ
22900 330 CONTINUE
22901 340 CONTINUE
22902
22903 ELSEIF(ISUB.EQ.31) THEN
22904C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
22905 FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0*
22906 & (SH2+UH2+2D0*SQM4*TH)/(-SH*UH)
22907C...Propagators: as simulated in PYOFSH and as desired
22908 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
22909 CALL PYWIDT(24,SQM4,WDTP,WDTE)
22910 GMMWC=SQRT(SQM4)*WDTP(0)
22911 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
22912 FACWQ=FACWQ*HBW4C/HBW4
22913 DO 360 I=MMINA,MMAXA
22914 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
22915 IA=IABS(I)
22916 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
22917 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
22918 DO 350 ISDE=1,2
22919 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
22920 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
22921 NCHN=NCHN+1
22922 ISIG(NCHN,ISDE)=I
22923 ISIG(NCHN,3-ISDE)=21
22924 ISIG(NCHN,3)=1
22925 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
22926 350 CONTINUE
22927 360 CONTINUE
22928
22929 ELSEIF(ISUB.EQ.35) THEN
22930C...f + gamma -> f + (gamma*/Z0)
22931 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) THEN
22932 FZQN=SH2+UH2+2D0*(SQM4-VINT(3)**2)*TH
22933 FZQDTM=VINT(3)**2*SQM4-SH*(UH-VINT(4)**2)
22934 ELSEIF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) THEN
22935 FZQN=SH2+UH2+2D0*(SQM4-VINT(4)**2)*TH
22936 FZQDTM=VINT(4)**2*SQM4-SH*(UH-VINT(3)**2)
22937 ELSE
22938 FZQN=SH2+UH2+2D0*SQM4*TH
22939 FZQDTM=-SH*UH
22940 ENDIF
22941 FZQN=COMFAC*2D0*AEM**2*MAX(0D0,FZQN)
22942C...gamma, gamma/Z interference and Z couplings to final fermion pairs
22943 HFGG=0D0
22944 HFGZ=0D0
22945 HFZZ=0D0
22946 RADC4=1D0+PYALPS(SQM4)/PARU(1)
22947 DO 370 I=1,MIN(16,MDCY(23,3))
22948 IDC=I+MDCY(23,2)-1
22949 IF(MDME(IDC,1).LT.0) GOTO 370
22950 IMDM=0
22951 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
22952 & IMDM=1
22953 IF(I.LE.8) THEN
22954 EF=KCHG(I,1)/3D0
22955 AF=SIGN(1D0,EF+0.1D0)
22956 VF=AF-4D0*EF*XWV
22957 ELSEIF(I.LE.16) THEN
22958 EF=KCHG(I+2,1)/3D0
22959 AF=SIGN(1D0,EF+0.1D0)
22960 VF=AF-4D0*EF*XWV
22961 ENDIF
22962 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
22963 IF(4D0*RM1.LT.1D0) THEN
22964 FCOF=1D0
22965 IF(I.LE.8) FCOF=3D0*RADC4
22966 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
22967 IF(IMDM.EQ.1) THEN
22968 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
22969 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
22970 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
22971 & AF**2*(1D0-4D0*RM1))*BE34
22972 ENDIF
22973 ENDIF
22974 370 CONTINUE
22975C...Propagators: as simulated in PYOFSH and as desired
22976 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
22977 MINT15=MINT(15)
22978 MINT(15)=1
22979 MINT(61)=1
22980 CALL PYWIDT(23,SQM4,WDTP,WDTE)
22981 MINT(15)=MINT15
22982 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
22983 HFGG=HFGG*HFAEM*VINT(111)/SQM4
22984 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
22985 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
22986C...Loop over flavours; consider full gamma/Z structure
22987 DO 390 I=MMINA,MMAXA
22988 IF(I.EQ.0) GOTO 390
22989 EI=KCHG(IABS(I),1)/3D0
22990 AI=SIGN(1D0,EI)
22991 VI=AI-4D0*EI*XWV
22992 FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+
22993 & (VI**2+AI**2)*HFZZ)/HBW4
22994 FZQD=MAX(PMAS(IABS(I),1)**2*SQM4,FZQDTM)
22995 DO 380 ISDE=1,2
22996 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 380
22997 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 380
22998 NCHN=NCHN+1
22999 ISIG(NCHN,ISDE)=I
23000 ISIG(NCHN,3-ISDE)=22
23001 ISIG(NCHN,3)=1
23002 SIGH(NCHN)=FACZQ*FZQN/FZQD
23003 380 CONTINUE
23004 390 CONTINUE
23005
23006 ELSEIF(ISUB.EQ.36) THEN
23007C...f + gamma -> f' + W+/-
23008 FWQ=COMFAC*AEM**2/(2D0*XW)*
23009 & (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH)
23010C...Propagators: as simulated in PYOFSH and as desired
23011 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
23012 CALL PYWIDT(24,SQM4,WDTP,WDTE)
23013 GMMWC=SQRT(SQM4)*WDTP(0)
23014 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
23015 FWQ=FWQ*HBW4C/HBW4
23016 DO 410 I=MMINA,MMAXA
23017 IF(I.EQ.0) GOTO 410
23018 IA=IABS(I)
23019 EIA=ABS(KCHG(IABS(I),1)/3D0)
23020 FACWQ=FWQ*(EIA-SH/(SH+UH))**2
23021 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
23022 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
23023 DO 400 ISDE=1,2
23024 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 400
23025 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 400
23026 NCHN=NCHN+1
23027 ISIG(NCHN,ISDE)=I
23028 ISIG(NCHN,3-ISDE)=22
23029 ISIG(NCHN,3)=1
23030 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
23031 400 CONTINUE
23032 410 CONTINUE
23033 ENDIF
23034
23035 ELSEIF(ISUB.LE.100) THEN
23036 IF(ISUB.EQ.69) THEN
23037C...gamma + gamma -> W+ + W-
23038 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
23039 FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
23040 FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+
23041 & FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1)
23042 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 420
23043 NCHN=NCHN+1
23044 ISIG(NCHN,1)=22
23045 ISIG(NCHN,2)=22
23046 ISIG(NCHN,3)=1
23047 SIGH(NCHN)=FACWW
23048 420 CONTINUE
23049
23050 ELSEIF(ISUB.EQ.70) THEN
23051C...gamma + W+/- -> Z0 + W+/-
23052 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
23053 FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH))
23054 FACZW=COMFAC*6D0*AEM**2*(XW1/XW)*
23055 & (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+
23056 & FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2)
23057 DO 440 KCHW=1,-1,-2
23058 DO 430 ISDE=1,2
23059 IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 430
23060 NCHN=NCHN+1
23061 ISIG(NCHN,ISDE)=22
23062 ISIG(NCHN,3-ISDE)=24*KCHW
23063 ISIG(NCHN,3)=1
23064 SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2)
23065 430 CONTINUE
23066 440 CONTINUE
23067 ENDIF
23068 ENDIF
23069
23070 RETURN
23071 END
23072
23073C*********************************************************************
23074
23075C...PYSGHG
23076C...Subprocess cross sections for Higgs processes,
23077C...except Higgs pairs in PYSGSU, but including WW scattering.
23078C...Auxiliary to PYSIGH.
23079
23080 SUBROUTINE PYSGHG(NCHN,SIGS)
23081
23082C...Double precision and integer declarations
23083 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23084 IMPLICIT INTEGER(I-N)
23085 INTEGER PYK,PYCHGE,PYCOMP
23086C...Parameter statement to help give large particle numbers.
23087 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
23088 &KEXCIT=4000000,KDIMEN=5000000)
23089C...Commonblocks
23090 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23091 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23092 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23093 COMMON/PYINT1/MINT(400),VINT(400)
23094 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
23095 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
23096 COMMON/PYINT4/MWID(500),WIDS(500,5)
23097 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
23098 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
23099 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
23100 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
23101 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
23102 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
23103 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
23104 &/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/
23105C...Local arrays and complex variables
23106 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
23107 COMPLEX*16 A004,A204,A114,A00U,A20U,A11U
23108 COMPLEX*16 CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF
23109
23110C...Convert H or A process into equivalent h one
23111 IHIGG=1
23112 KFHIGG=25
23113 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
23114 &ISUB.LE.190)) THEN
23115 IHIGG=2
23116 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
23117 KFHIGG=33+IHIGG
23118 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
23119 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
23120 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
23121 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
23122 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
23123 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
23124 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
23125 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
23126 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
23127 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
23128 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
23129 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
23130 ENDIF
23131 SQMH=PMAS(KFHIGG,1)**2
23132 GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2)
23133
23134C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
23135 IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ.
23136 &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN
23137C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
23138 IF(MSTP(46).LE.4) THEN
23139 HDTLH=LOG(PMAS(25,1)/PARP(44))
23140 HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0
23141 HDTNR=-1D0/18D0+HDTLH/6D0
23142 ELSE
23143 HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2)
23144 HDTLQ=LOG(PARP(45)/PARP(44))
23145 HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0
23146 HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0
23147 ENDIF
23148
23149C...Calculate lowest and next-to-lowest order partial wave amplitudes
23150 HDTV=1D0/(16D0*PARU(1)*PARP(47)**2)
23151 A00L=DBLE(HDTV*SH)
23152 A20L=-0.5D0*A00L
23153 A11L=A00L/6D0
23154 HDTLS=LOG(SH/PARP(44)**2)
23155 A004=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
23156 & CMPLX(DBLE((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0-
23157 & (50D0/9D0)*HDTLS),DBLE(4D0*PARU(1)))
23158 A204=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
23159 & CMPLX(DBLE(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0-
23160 & (20D0/9D0)*HDTLS),DBLE(PARU(1)))
23161 A114=DBLE((HDTV*SH)**2/(6D0*PARU(1)))*
23162 & CMPLX(DBLE(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),DBLE(PARU(1)/6D0))
23163
23164C...Unitarize partial wave amplitudes with Pade or K-matrix method
23165 IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN
23166 A00U=A00L/(1D0-A004/A00L)
23167 A20U=A20L/(1D0-A204/A20L)
23168 A11U=A11L/(1D0-A114/A11L)
23169 ELSE
23170 A00U=(A00L+DBLE(A004))/(1D0-DCMPLX(0.D0,A00L+DBLE(A004)))
23171 A20U=(A20L+DBLE(A204))/(1D0-DCMPLX(0.D0,A20L+DBLE(A204)))
23172 A11U=(A11L+DBLE(A114))/(1D0-DCMPLX(0.D0,A11L+DBLE(A114)))
23173 ENDIF
23174 ENDIF
23175
23176C...Differential cross section expressions.
23177
23178 IF(ISUB.LE.60) THEN
23179 IF(ISUB.EQ.3) THEN
23180C...f + fbar -> h0 (or H0, or A0)
23181 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
23182 HS=SHR*WDTP(0)
23183 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
23184 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
23185 & FACBW=0D0
23186 HP=AEM/(8D0*XW)*SH/SQMW*SH
23187 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
23188 DO 100 I=MMINA,MMAXA
23189 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
23190 IA=IABS(I)
23191 RMQ=PYMRUN(IA,SH)**2/SH
23192 HI=HP*RMQ
23193 IF(IA.LE.10) HI=HP*RMQ*FACA/3D0
23194 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
23195 IKFI=1
23196 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
23197 IF(IA.GT.10) IKFI=3
23198 HI=HI*PARU(150+10*IHIGG+IKFI)**2
23199 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
23200 HI=HI/(1D0+RMSS(41))**2
23201 IF(IHIGG.NE.3) THEN
23202 HI=HI*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
23203 & PARU(151+10*IHIGG))**2
23204 ENDIF
23205 ENDIF
23206 ENDIF
23207 NCHN=NCHN+1
23208 ISIG(NCHN,1)=I
23209 ISIG(NCHN,2)=-I
23210 ISIG(NCHN,3)=1
23211 SIGH(NCHN)=HI*FACBW*HF
23212 100 CONTINUE
23213
23214 ELSEIF(ISUB.EQ.5) THEN
23215C...Z0 + Z0 -> h0
23216 CALL PYWIDT(25,SH,WDTP,WDTE)
23217 HS=SHR*WDTP(0)
23218 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
23219 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
23220 HP=AEM/(8D0*XW)*SH/SQMW*SH
23221 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
23222 HI=HP/4D0
23223 FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2
23224 DO 120 I=MMIN1,MMAX1
23225 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
23226 DO 110 J=MMIN2,MMAX2
23227 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
23228 EI=KCHG(IABS(I),1)/3D0
23229 AI=SIGN(1D0,EI)
23230 VI=AI-4D0*EI*XWV
23231 EJ=KCHG(IABS(J),1)/3D0
23232 AJ=SIGN(1D0,EJ)
23233 VJ=AJ-4D0*EJ*XWV
23234 NCHN=NCHN+1
23235 ISIG(NCHN,1)=I
23236 ISIG(NCHN,2)=J
23237 ISIG(NCHN,3)=1
23238 SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF
23239 110 CONTINUE
23240 120 CONTINUE
23241
23242 ELSEIF(ISUB.EQ.8) THEN
23243C...W+ + W- -> h0
23244 CALL PYWIDT(25,SH,WDTP,WDTE)
23245 HS=SHR*WDTP(0)
23246 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
23247 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
23248 HP=AEM/(8D0*XW)*SH/SQMW*SH
23249 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
23250 HI=HP/2D0
23251 FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2
23252 DO 140 I=MMIN1,MMAX1
23253 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
23254 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
23255 DO 130 J=MMIN2,MMAX2
23256 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
23257 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
23258 IF(EI*EJ.GT.0D0) GOTO 130
23259 NCHN=NCHN+1
23260 ISIG(NCHN,1)=I
23261 ISIG(NCHN,2)=J
23262 ISIG(NCHN,3)=1
23263 SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF
23264 130 CONTINUE
23265 140 CONTINUE
23266
23267 ELSEIF(ISUB.EQ.24) THEN
23268C...f + fbar -> Z0 + h0 (or H0, or A0)
23269C...Propagators: Z0, h0 as simulated in PYOFSH and as desired
23270 HBW3=GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
23271 CALL PYWIDT(23,SQM3,WDTP,WDTE)
23272 GMMZ3=SQRT(SQM3)*WDTP(0)
23273 HBW3C=GMMZ3/((SQM3-SQMZ)**2+GMMZ3**2)
23274 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
23275 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
23276 GMMH4=SQRT(SQM4)*WDTP(0)
23277 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
23278 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
23279 FACHZ=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*8D0*(AEM*XWC)**2*
23280 & (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2)
23281 FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2)
23282 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
23283 & PARU(154+10*IHIGG)**2
23284 DO 150 I=MMINA,MMAXA
23285 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
23286 EI=KCHG(IABS(I),1)/3D0
23287 AI=SIGN(1D0,EI)
23288 VI=AI-4D0*EI*XWV
23289 FCOI=1D0
23290 IF(IABS(I).LE.10) FCOI=FACA/3D0
23291 NCHN=NCHN+1
23292 ISIG(NCHN,1)=I
23293 ISIG(NCHN,2)=-I
23294 ISIG(NCHN,3)=1
23295 SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2)
23296 150 CONTINUE
23297
23298 ELSEIF(ISUB.EQ.26) THEN
23299C...f + fbar' -> W+/- + h0 (or H0, or A0)
23300C...Propagators: W+-, h0 as simulated in PYOFSH and as desired
23301 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
23302 CALL PYWIDT(24,SQM3,WDTP,WDTE)
23303 GMMW3=SQRT(SQM3)*WDTP(0)
23304 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
23305 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
23306 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
23307 GMMH4=SQRT(SQM4)*WDTP(0)
23308 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
23309 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
23310 FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/
23311 & ((SH-SQMW)**2+GMMW**2)*(HBW3C/HBW3)*(HBW4C/HBW4)
23312 FACHW=FACHW*WIDS(KFHIGG,2)
23313 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
23314 & PARU(155+10*IHIGG)**2
23315 DO 170 I=MMIN1,MMAX1
23316 IA=IABS(I)
23317 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 170
23318 DO 160 J=MMIN2,MMAX2
23319 JA=IABS(J)
23320 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 160
23321 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 160
23322 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
23323 & GOTO 160
23324 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
23325 FCKM=1D0
23326 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
23327 FCOI=1D0
23328 IF(IA.LE.10) FCOI=FACA/3D0
23329 NCHN=NCHN+1
23330 ISIG(NCHN,1)=I
23331 ISIG(NCHN,2)=J
23332 ISIG(NCHN,3)=1
23333 SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2)
23334 160 CONTINUE
23335 170 CONTINUE
23336
23337 ELSEIF(ISUB.EQ.32) THEN
23338C...f + g -> f + h0 (q + g -> q + h0 only)
23339 SQMHC=PMAS(25,1)**2
23340 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24D0
23341 DO 190 I=MMINA,MMAXA
23342 IA=IABS(I)
23343 IF(IA.NE.5) GOTO 190
23344 SQML=PMAS(IA,1)**2
23345 IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) SQML=SQML*
23346 & (LOG(MAX(4D0,PARP(37)**2*SQML/PARU(117)**2))/
23347 & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
23348 IUA=IA+MOD(IA,2)
23349 SQMQ=SQML
23350 FACHCQ=FHCQ*SQML/SQMW*
23351 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH+
23352 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
23353 & (SQMHC-SQMQ-SH)/SH)
23354 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
23355 DO 180 ISDE=1,2
23356 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
23357 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,1).EQ.0) GOTO 180
23358 NCHN=NCHN+1
23359 ISIG(NCHN,ISDE)=I
23360 ISIG(NCHN,3-ISDE)=21
23361 ISIG(NCHN,3)=1
23362 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
23363 180 CONTINUE
23364 190 CONTINUE
23365 ENDIF
23366
23367 ELSEIF(ISUB.LE.80) THEN
23368 IF(ISUB.EQ.71) THEN
23369C...Z0 + Z0 -> Z0 + Z0
23370 IF(SH.LE.4.01D0*SQMZ) GOTO 220
23371
23372 IF(MSTP(46).LE.2) THEN
23373C...Exact scattering ME:s for on-mass-shell gauge bosons
23374 BE2=1D0-4D0*SQMZ/SH
23375 TH=-0.5D0*SH*BE2*(1D0-CTH)
23376 UH=-0.5D0*SH*BE2*(1D0+CTH)
23377 IF(MAX(TH,UH).GT.-1D0) GOTO 220
23378 SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2
23379 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
23380 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
23381 THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2
23382 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
23383 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
23384 UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2
23385 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
23386 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
23387 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
23388 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
23389 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
23390 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+
23391 & (ASHIM+ATHIM+AUHIM)**2)
23392 IF(MSTP(46).EQ.2) FACZZ=0D0
23393
23394 ELSE
23395C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
23396 FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
23397 & ABS(A00U+2D0*A20U)**2
23398 ENDIF
23399 FACZZ=FACZZ*WIDS(23,1)
23400
23401 DO 210 I=MMIN1,MMAX1
23402 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 210
23403 EI=KCHG(IABS(I),1)/3D0
23404 AI=SIGN(1D0,EI)
23405 VI=AI-4D0*EI*XWV
23406 AVI=AI**2+VI**2
23407 DO 200 J=MMIN2,MMAX2
23408 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 200
23409 EJ=KCHG(IABS(J),1)/3D0
23410 AJ=SIGN(1D0,EJ)
23411 VJ=AJ-4D0*EJ*XWV
23412 AVJ=AJ**2+VJ**2
23413 NCHN=NCHN+1
23414 ISIG(NCHN,1)=I
23415 ISIG(NCHN,2)=J
23416 ISIG(NCHN,3)=1
23417 SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ
23418 200 CONTINUE
23419 210 CONTINUE
23420 220 CONTINUE
23421
23422 ELSEIF(ISUB.EQ.72) THEN
23423C...Z0 + Z0 -> W+ + W-
23424 IF(SH.LE.4.01D0*SQMZ) GOTO 250
23425
23426 IF(MSTP(46).LE.2) THEN
23427C...Exact scattering ME:s for on-mass-shell gauge bosons
23428 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
23429 CTH2=CTH**2
23430 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
23431 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
23432 IF(MAX(TH,UH).GT.-1D0) GOTO 250
23433 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
23434 & (1D0-2D0*SQMZ/SH)
23435 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
23436 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
23437 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
23438 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
23439 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
23440 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
23441 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
23442 ATWIM=0D0
23443 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
23444 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
23445 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
23446 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
23447 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
23448 AUWIM=0D0
23449 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
23450 A4IM=0D0
23451 FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
23452 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
23453 IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2)
23454 IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+
23455 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
23456 IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+
23457 & (ATWIM+AUWIM+A4IM)**2)
23458
23459 ELSE
23460C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
23461 FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
23462 & ABS(A00U-A20U)**2
23463 ENDIF
23464 FACWW=FACWW*WIDS(24,1)
23465
23466 DO 240 I=MMIN1,MMAX1
23467 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 240
23468 EI=KCHG(IABS(I),1)/3D0
23469 AI=SIGN(1D0,EI)
23470 VI=AI-4D0*EI*XWV
23471 AVI=AI**2+VI**2
23472 DO 230 J=MMIN2,MMAX2
23473 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 230
23474 EJ=KCHG(IABS(J),1)/3D0
23475 AJ=SIGN(1D0,EJ)
23476 VJ=AJ-4D0*EJ*XWV
23477 AVJ=AJ**2+VJ**2
23478 NCHN=NCHN+1
23479 ISIG(NCHN,1)=I
23480 ISIG(NCHN,2)=J
23481 ISIG(NCHN,3)=1
23482 SIGH(NCHN)=FACWW*AVI*AVJ
23483 230 CONTINUE
23484 240 CONTINUE
23485 250 CONTINUE
23486
23487 ELSEIF(ISUB.EQ.73) THEN
23488C...Z0 + W+/- -> Z0 + W+/-
23489 IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 280
23490
23491 IF(MSTP(46).LE.2) THEN
23492C...Exact scattering ME:s for on-mass-shell gauge bosons
23493 BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
23494 EP1=1D0-(SQMZ-SQMW)/SH
23495 EP2=1D0+(SQMZ-SQMW)/SH
23496 TH=-0.5D0*SH*BE2*(1D0-CTH)
23497 UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH)
23498 IF(MAX(TH,UH).GT.-1D0) GOTO 280
23499 THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH)
23500 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
23501 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
23502 ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
23503 & 1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+
23504 & 2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
23505 & 1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
23506 ASWIM=0D0
23507 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
23508 & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
23509 & (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)-
23510 & BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0*
23511 & (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+
23512 & 1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
23513 & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
23514 & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
23515 & (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*
23516 & (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2*
23517 & ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW*
23518 & (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
23519 AUWIM=0D0
23520 A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)-
23521 & 2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2)
23522 A4IM=0D0
23523 FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4*
23524 & (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2
23525 IF(MSTP(46).LE.0) FACZW=0D0
23526 IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+
23527 & (ATHIM+ASWIM+AUWIM+A4IM)**2)
23528 IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+
23529 & (ASWIM+AUWIM+A4IM)**2)
23530
23531 ELSE
23532C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
23533 FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0*
23534 & ABS(A20U+3D0*A11U*DBLE(CTH))**2
23535 ENDIF
23536 FACZW=FACZW*WIDS(23,2)
23537
23538 DO 270 I=MMIN1,MMAX1
23539 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 270
23540 EI=KCHG(IABS(I),1)/3D0
23541 AI=SIGN(1D0,EI)
23542 VI=AI-4D0*EI*XWV
23543 AVI=AI**2+VI**2
23544 KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I))
23545 DO 260 J=MMIN2,MMAX2
23546 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 260
23547 EJ=KCHG(IABS(J),1)/3D0
23548 AJ=SIGN(1D0,EJ)
23549 VJ=AI-4D0*EJ*XWV
23550 AVJ=AJ**2+VJ**2
23551 KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J))
23552 NCHN=NCHN+1
23553 ISIG(NCHN,1)=I
23554 ISIG(NCHN,2)=J
23555 ISIG(NCHN,3)=1
23556 SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2)
23557 NCHN=NCHN+1
23558 ISIG(NCHN,1)=I
23559 ISIG(NCHN,2)=J
23560 ISIG(NCHN,3)=2
23561 SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ
23562 260 CONTINUE
23563 270 CONTINUE
23564 280 CONTINUE
23565
23566 ELSEIF(ISUB.EQ.75) THEN
23567C...W+ + W- -> gamma + gamma
23568
23569 ELSEIF(ISUB.EQ.76) THEN
23570C...W+ + W- -> Z0 + Z0
23571 IF(SH.LE.4.01D0*SQMZ) GOTO 310
23572
23573 IF(MSTP(46).LE.2) THEN
23574C...Exact scattering ME:s for on-mass-shell gauge bosons
23575 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
23576 CTH2=CTH**2
23577 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
23578 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
23579 IF(MAX(TH,UH).GT.-1D0) GOTO 310
23580 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
23581 & (1D0-2D0*SQMZ/SH)
23582 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
23583 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
23584 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
23585 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
23586 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
23587 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
23588 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
23589 ATWIM=0D0
23590 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
23591 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
23592 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
23593 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
23594 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
23595 AUWIM=0D0
23596 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
23597 A4IM=0D0
23598 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
23599 & (SH/SQMW)**2*SH2
23600 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
23601 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+
23602 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
23603 IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+
23604 & (ATWIM+AUWIM+A4IM)**2)
23605
23606 ELSE
23607C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
23608 FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
23609 & ABS(A00U-A20U)**2
23610 ENDIF
23611 FACZZ=FACZZ*WIDS(23,1)
23612
23613 DO 300 I=MMIN1,MMAX1
23614 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 300
23615 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
23616 DO 290 J=MMIN2,MMAX2
23617 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 290
23618 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
23619 IF(EI*EJ.GT.0D0) GOTO 290
23620 NCHN=NCHN+1
23621 ISIG(NCHN,1)=I
23622 ISIG(NCHN,2)=J
23623 ISIG(NCHN,3)=1
23624 SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J)
23625 290 CONTINUE
23626 300 CONTINUE
23627 310 CONTINUE
23628
23629 ELSEIF(ISUB.EQ.77) THEN
23630C...W+/- + W+/- -> W+/- + W+/-
23631 IF(SH.LE.4.01D0*SQMW) GOTO 340
23632
23633 IF(MSTP(46).LE.2) THEN
23634C...Exact scattering ME:s for on-mass-shell gauge bosons
23635 BE2=1D0-4D0*SQMW/SH
23636 BE4=BE2**2
23637 CTH2=CTH**2
23638 CTH3=CTH**3
23639 TH=-0.5D0*SH*BE2*(1D0-CTH)
23640 UH=-0.5D0*SH*BE2*(1D0+CTH)
23641 IF(MAX(TH,UH).GT.-1D0) GOTO 340
23642 SHANG=(1D0+BE2)**2
23643 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
23644 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
23645 THANG=(BE2-CTH)**2
23646 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
23647 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
23648 UHANG=(BE2+CTH)**2
23649 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
23650 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
23651 SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH
23652 ASGRE=XW*SGZANG
23653 ASGIM=0D0
23654 ASZRE=XW1*SH/(SH-SQMZ)*SGZANG
23655 ASZIM=0D0
23656 TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+
23657 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3)
23658 ATGRE=0.5D0*XW*SH/TH*TGZANG
23659 ATGIM=0D0
23660 ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG
23661 ATZIM=0D0
23662 UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+
23663 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3)
23664 AUGRE=0.5D0*XW*SH/UH*UGZANG
23665 AUGIM=0D0
23666 AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG
23667 AUZIM=0D0
23668 A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2)
23669 A4AIM=0D0
23670 A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2)
23671 A4SIM=0D0
23672 FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
23673 & (SH/SQMW)**2*SH2
23674 IF(MSTP(46).LE.0) THEN
23675 AWWARE=ASHRE
23676 AWWAIM=ASHIM
23677 AWWSRE=0D0
23678 AWWSIM=0D0
23679 ELSEIF(MSTP(46).EQ.1) THEN
23680 AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
23681 AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
23682 AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
23683 AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
23684 ELSE
23685 AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
23686 AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
23687 AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
23688 AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
23689 ENDIF
23690 AWWA2=AWWARE**2+AWWAIM**2
23691 AWWS2=AWWSRE**2+AWWSIM**2
23692
23693 ELSE
23694C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
23695 FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
23696 & ABS(A00U+0.5D0*A20U+4.5D0*A11U*DBLE(CTH))**2
23697 FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2
23698 ENDIF
23699
23700 DO 330 I=MMIN1,MMAX1
23701 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 330
23702 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
23703 DO 320 J=MMIN2,MMAX2
23704 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 320
23705 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
23706 IF(EI*EJ.LT.0D0) THEN
23707C...W+W-
23708 IF(MSTP(45).EQ.1) GOTO 320
23709 IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1)
23710 IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1)
23711 ELSE
23712C...W+W+/W-W-
23713 IF(MSTP(45).EQ.2) GOTO 320
23714 IF(MSTP(46).LE.2) FACWW=FWW*AWWS2
23715 IF(MSTP(46).GE.3) FACWW=FWWS
23716 IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4)
23717 IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5)
23718 ENDIF
23719 NCHN=NCHN+1
23720 ISIG(NCHN,1)=I
23721 ISIG(NCHN,2)=J
23722 ISIG(NCHN,3)=1
23723 SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J)
23724 IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN)
23725 320 CONTINUE
23726 330 CONTINUE
23727 340 CONTINUE
23728 ENDIF
23729
23730 ELSEIF(ISUB.LE.120) THEN
23731 IF(ISUB.EQ.102) THEN
23732C...g + g -> h0 (or H0, or A0)
23733 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
23734 HS=SHR*WDTP(0)
23735 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
23736 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
23737 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
23738 & FACBW=0D0
23739 HI=SHR*WDTP(13)/32D0
23740 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 350
23741 NCHN=NCHN+1
23742 ISIG(NCHN,1)=21
23743 ISIG(NCHN,2)=21
23744 ISIG(NCHN,3)=1
23745 SIGH(NCHN)=HI*FACBW*HF
23746 350 CONTINUE
23747
23748 ELSEIF(ISUB.EQ.103) THEN
23749C...gamma + gamma -> h0 (or H0, or A0)
23750 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
23751 HS=SHR*WDTP(0)
23752 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
23753 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
23754 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
23755 & FACBW=0D0
23756 HI=SHR*WDTP(14)*2D0
23757 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 360
23758 NCHN=NCHN+1
23759 ISIG(NCHN,1)=22
23760 ISIG(NCHN,2)=22
23761 ISIG(NCHN,3)=1
23762 SIGH(NCHN)=HI*FACBW*HF
23763 360 CONTINUE
23764
23765 ELSEIF(ISUB.EQ.110) THEN
23766C...f + fbar -> gamma + h0
23767 THUH=MAX(TH*UH,SH*CKIN(3)**2)
23768 FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH
23769 FACHG=FACHG*WIDS(KFHIGG,2)
23770C...Calculate loop contributions for intermediate gamma* and Z0
23771 CIGTOT=DCMPLX(0D0,0D0)
23772 CIZTOT=DCMPLX(0D0,0D0)
23773 JMAX=3*MSTP(1)+1
23774 DO 370 J=1,JMAX
23775 IF(J.LE.2*MSTP(1)) THEN
23776 FNC=1D0
23777 EJ=KCHG(J,1)/3D0
23778 AJ=SIGN(1D0,EJ+0.1D0)
23779 VJ=AJ-4D0*EJ*XWV
23780 BALP=SQM4/(2D0*PMAS(J,1))**2
23781 BBET=SH/(2D0*PMAS(J,1))**2
23782 ELSEIF(J.LE.3*MSTP(1)) THEN
23783 FNC=3D0
23784 JL=2*(J-2*MSTP(1))-1
23785 EJ=KCHG(10+JL,1)/3D0
23786 AJ=SIGN(1D0,EJ+0.1D0)
23787 VJ=AJ-4D0*EJ*XWV
23788 BALP=SQM4/(2D0*PMAS(10+JL,1))**2
23789 BBET=SH/(2D0*PMAS(10+JL,1))**2
23790 ELSE
23791 BALP=SQM4/(2D0*PMAS(24,1))**2
23792 BBET=SH/(2D0*PMAS(24,1))**2
23793 ENDIF
23794 BABI=1D0/(BALP-BBET)
23795 IF(BALP.LT.1D0) THEN
23796 F0ALP=DCMPLX(DBLE(ASIN(SQRT(BALP))),0D0)
23797 F1ALP=F0ALP**2
23798 ELSE
23799 F0ALP=DCMPLX(DBLE(LOG(SQRT(BALP)+SQRT(BALP-1D0))),
23800 & -DBLE(0.5D0*PARU(1)))
23801 F1ALP=-F0ALP**2
23802 ENDIF
23803 F2ALP=DBLE(SQRT(ABS(BALP-1D0)/BALP))*F0ALP
23804 IF(BBET.LT.1D0) THEN
23805 F0BET=DCMPLX(DBLE(ASIN(SQRT(BBET))),0D0)
23806 F1BET=F0BET**2
23807 ELSE
23808 F0BET=DCMPLX(DBLE(LOG(SQRT(BBET)+SQRT(BBET-1D0))),
23809 & -DBLE(0.5D0*PARU(1)))
23810 F1BET=-F0BET**2
23811 ENDIF
23812 F2BET=DBLE(SQRT(ABS(BBET-1D0)/BBET))*F0BET
23813 IF(J.LE.3*MSTP(1)) THEN
23814 FIF=DBLE(0.5D0*BABI)+DBLE(BABI**2)*(DBLE(0.5D0*(1D0-BALP+
23815 & BBET))*(F1BET-F1ALP)+DBLE(BBET)*(F2BET-F2ALP))
23816 CIGTOT=CIGTOT+DBLE(FNC*EJ**2)*FIF
23817 CIZTOT=CIZTOT+DBLE(FNC*EJ*VJ)*FIF
23818 ELSE
23819 TXW=XW/XW1
23820 CIGTOT=CIGTOT-0.5*(DBLE(BABI*(1.5D0+BALP))+DBLE(BABI**2)*
23821 & (DBLE(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+
23822 & DBLE(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP)))
23823 CIZTOT=CIZTOT-DBLE(0.5D0*BABI*XW1)*(DBLE(5D0-TXW+2D0*BALP*
23824 & (1D0-TXW))*(1D0+DBLE(2D0*BABI*BBET)*(F2BET-F2ALP))+
23825 & DBLE(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))*
23826 & (F1BET-F1ALP))
23827 ENDIF
23828 370 CONTINUE
23829 CIGTOT=CIGTOT/DBLE(SH)
23830 CIZTOT=CIZTOT*DBLE(XWC)/DCMPLX(DBLE(SH-SQMZ),DBLE(GMMZ))
23831C...Loop over initial flavours
23832 DO 380 I=MMINA,MMAXA
23833 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
23834 EI=KCHG(IABS(I),1)/3D0
23835 AI=SIGN(1D0,EI)
23836 VI=AI-4D0*EI*XWV
23837 FCOI=1D0
23838 IF(IABS(I).LE.10) FCOI=FACA/3D0
23839 NCHN=NCHN+1
23840 ISIG(NCHN,1)=I
23841 ISIG(NCHN,2)=-I
23842 ISIG(NCHN,3)=1
23843 SIGH(NCHN)=FACHG*FCOI*(ABS(DBLE(EI)*CIGTOT+DBLE(VI)*
23844 & CIZTOT)**2+AI**2*ABS(CIZTOT)**2)
23845 380 CONTINUE
23846
23847 ELSEIF(ISUB.EQ.111) THEN
23848C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
23849 IF(MSTP(38).NE.0) THEN
23850C...Simple case: only do gg <-> h exactly.
23851 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
23852 FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP(13)/SQRT(SQM4))*
23853 & (TH**2+UH**2)/(SH*SQM4)
23854C...Propagators: as simulated in PYOFSH and as desired
23855 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
23856 GMMHC=SQRT(SQM4)*WDTP(0)
23857 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
23858 & ((SQM4-SQMH)**2+GMMHC**2)
23859 FACGH=FACGH*HBW4C/HBW4
23860 ELSE
23861C...Messy case: do full loop integrals
23862 A5STUR=0D0
23863 A5STUI=0D0
23864 DO 390 I=1,2*MSTP(1)
23865 SQMQ=PMAS(I,1)**2
23866 EPSS=4D0*SQMQ/SH
23867 EPSH=4D0*SQMQ/SQMH
23868 CALL PYWAUX(1,EPSS,W1SR,W1SI)
23869 CALL PYWAUX(1,EPSH,W1HR,W1HI)
23870 CALL PYWAUX(2,EPSS,W2SR,W2SI)
23871 CALL PYWAUX(2,EPSH,W2HR,W2HI)
23872 A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+
23873 & (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR))
23874 A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+
23875 & (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI))
23876 390 CONTINUE
23877 FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
23878 & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
23879 FACGH=FACGH*WIDS(25,2)
23880 ENDIF
23881 DO 400 I=MMINA,MMAXA
23882 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
23883 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
23884 NCHN=NCHN+1
23885 ISIG(NCHN,1)=I
23886 ISIG(NCHN,2)=-I
23887 ISIG(NCHN,3)=1
23888 SIGH(NCHN)=FACGH
23889 400 CONTINUE
23890
23891 ELSEIF(ISUB.EQ.112) THEN
23892C...f + g -> f + h0 (q + g -> q + h0 only)
23893 IF(MSTP(38).NE.0) THEN
23894C...Simple case: only do gg <-> h exactly.
23895 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
23896 FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP(13)/SQRT(SQM4))*
23897 & (SH**2+UH**2)/(-TH*SQM4)
23898C...Propagators: as simulated in PYOFSH and as desired
23899 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
23900 GMMHC=SQRT(SQM4)*WDTP(0)
23901 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
23902 & ((SQM4-SQMH)**2+GMMHC**2)
23903 FACQH=FACQH*HBW4C/HBW4
23904 ELSE
23905C...Messy case: do full loop integrals
23906 A5TSUR=0D0
23907 A5TSUI=0D0
23908 DO 410 I=1,2*MSTP(1)
23909 SQMQ=PMAS(I,1)**2
23910 EPST=4D0*SQMQ/TH
23911 EPSH=4D0*SQMQ/SQMH
23912 CALL PYWAUX(1,EPST,W1TR,W1TI)
23913 CALL PYWAUX(1,EPSH,W1HR,W1HI)
23914 CALL PYWAUX(2,EPST,W2TR,W2TI)
23915 CALL PYWAUX(2,EPSH,W2HR,W2HI)
23916 A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+
23917 & (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR))
23918 A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+
23919 & (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI))
23920 410 CONTINUE
23921 FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
23922 & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
23923 FACQH=FACQH*WIDS(25,2)
23924 ENDIF
23925 DO 430 I=MMINA,MMAXA
23926 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
23927 DO 420 ISDE=1,2
23928 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 420
23929 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 420
23930 NCHN=NCHN+1
23931 ISIG(NCHN,ISDE)=I
23932 ISIG(NCHN,3-ISDE)=21
23933 ISIG(NCHN,3)=1
23934 SIGH(NCHN)=FACQH
23935 420 CONTINUE
23936 430 CONTINUE
23937
23938 ELSEIF(ISUB.EQ.113) THEN
23939C...g + g -> g + h0
23940 IF(MSTP(38).NE.0) THEN
23941C...Simple case: only do gg <-> h exactly.
23942 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
23943 FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP(13)/SQRT(SQM4))*
23944 & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
23945C...Propagators: as simulated in PYOFSH and as desired
23946 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
23947 GMMHC=SQRT(SQM4)*WDTP(0)
23948 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
23949 & ((SQM4-SQMH)**2+GMMHC**2)
23950 FACGH=FACGH*HBW4C/HBW4
23951 ELSE
23952C...Messy case: do full loop integrals
23953 A2STUR=0D0
23954 A2STUI=0D0
23955 A2USTR=0D0
23956 A2USTI=0D0
23957 A2TUSR=0D0
23958 A2TUSI=0D0
23959 A4STUR=0D0
23960 A4STUI=0D0
23961 DO 440 I=1,2*MSTP(1)
23962 SQMQ=PMAS(I,1)**2
23963 EPSS=4D0*SQMQ/SH
23964 EPST=4D0*SQMQ/TH
23965 EPSU=4D0*SQMQ/UH
23966 EPSH=4D0*SQMQ/SQMH
23967 IF(EPSH.LT.1D-6) GOTO 440
23968 CALL PYWAUX(1,EPSS,W1SR,W1SI)
23969 CALL PYWAUX(1,EPST,W1TR,W1TI)
23970 CALL PYWAUX(1,EPSU,W1UR,W1UI)
23971 CALL PYWAUX(1,EPSH,W1HR,W1HI)
23972 CALL PYWAUX(2,EPSS,W2SR,W2SI)
23973 CALL PYWAUX(2,EPST,W2TR,W2TI)
23974 CALL PYWAUX(2,EPSU,W2UR,W2UI)
23975 CALL PYWAUX(2,EPSH,W2HR,W2HI)
23976 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
23977 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
23978 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
23979 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
23980 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
23981 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
23982 CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI)
23983 CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI)
23984 CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI)
23985 CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI)
23986 CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI)
23987 CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI)
23988 W3STUR=YHSTUR-Y3STUR-Y3UTSR
23989 W3STUI=YHSTUI-Y3STUI-Y3UTSI
23990 W3SUTR=YHSUTR-Y3SUTR-Y3TUSR
23991 W3SUTI=YHSUTI-Y3SUTI-Y3TUSI
23992 W3TSUR=YHTSUR-Y3TSUR-Y3USTR
23993 W3TSUI=YHTSUI-Y3TSUI-Y3USTI
23994 W3TUSR=YHTUSR-Y3TUSR-Y3SUTR
23995 W3TUSI=YHTUSI-Y3TUSI-Y3SUTI
23996 W3USTR=YHUSTR-Y3USTR-Y3TSUR
23997 W3USTI=YHUSTI-Y3USTI-Y3TSUI
23998 W3UTSR=YHUTSR-Y3UTSR-Y3STUR
23999 W3UTSI=YHUTSI-Y3UTSI-Y3STUI
24000 B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH*
24001 & (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)*
24002 & (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/
24003 & (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH*
24004 & (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR)
24005 B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2*
24006 & (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+
24007 & W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))*
24008 & (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0*
24009 & (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI)
24010 B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH*
24011 & (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)*
24012 & (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/
24013 & (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH*
24014 & (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR)
24015 B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2*
24016 & (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+
24017 & W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))*
24018 & (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0*
24019 & (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI)
24020 B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH*
24021 & (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)*
24022 & (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/
24023 & (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH*
24024 & (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR)
24025 B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2*
24026 & (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+
24027 & W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))*
24028 & (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0*
24029 & (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI)
24030 B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH*
24031 & (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)*
24032 & (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/
24033 & (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH*
24034 & (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR)
24035 B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2*
24036 & (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+
24037 & W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))*
24038 & (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0*
24039 & (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI)
24040 B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH*
24041 & (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)*
24042 & (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/
24043 & (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH*
24044 & (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR)
24045 B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2*
24046 & (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+
24047 & W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))*
24048 & (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0*
24049 & (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI)
24050 B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH*
24051 & (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)*
24052 & (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/
24053 & (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH*
24054 & (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR)
24055 B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2*
24056 & (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+
24057 & W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))*
24058 & (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0*
24059 & (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI)
24060 B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
24061 & (W2SR-W2HR+W3STUR))
24062 B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI)
24063 B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
24064 & (W2TR-W2HR+W3TUSR))
24065 B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI)
24066 B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
24067 & (W2UR-W2HR+W3USTR))
24068 B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI)
24069 A2STUR=A2STUR+B2STUR+B2SUTR
24070 A2STUI=A2STUI+B2STUI+B2SUTI
24071 A2USTR=A2USTR+B2USTR+B2UTSR
24072 A2USTI=A2USTI+B2USTI+B2UTSI
24073 A2TUSR=A2TUSR+B2TUSR+B2TSUR
24074 A2TUSI=A2TUSI+B2TUSI+B2TSUI
24075 A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
24076 A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
24077 440 CONTINUE
24078 FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3*
24079 & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
24080 & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
24081 FACGH=FACGH*WIDS(25,2)
24082 ENDIF
24083 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 450
24084 NCHN=NCHN+1
24085 ISIG(NCHN,1)=21
24086 ISIG(NCHN,2)=21
24087 ISIG(NCHN,3)=1
24088 SIGH(NCHN)=FACGH
24089 450 CONTINUE
24090 ENDIF
24091
24092 ELSEIF(ISUB.LE.170) THEN
24093 IF(ISUB.EQ.121) THEN
24094C...g + g -> Q + Qbar + h0
24095 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 460
24096 IA=KFPR(ISUBSV,2)
24097 PMF=PYMRUN(IA,SH)
24098 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
24099 & (0.5D0*PMF/PMAS(24,1))**2
24100 WID2=1D0
24101 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
24102 FACQQH=FACQQH*WID2
24103 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24104 IKFI=1
24105 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
24106 IF(IA.GT.10) IKFI=3
24107 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
24108 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
24109 FACQQH=FACQQH/(1D0+RMSS(41))**2
24110 IF(IHIGG.NE.3) THEN
24111 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
24112 & PARU(151+10*IHIGG))**2
24113 ENDIF
24114 ENDIF
24115 ENDIF
24116 CALL PYQQBH(WTQQBH)
24117 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
24118 HS=SHR*WDTP(0)
24119 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24120 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
24121 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
24122 & FACBW=0D0
24123 NCHN=NCHN+1
24124 ISIG(NCHN,1)=21
24125 ISIG(NCHN,2)=21
24126 ISIG(NCHN,3)=1
24127 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
24128 460 CONTINUE
24129
24130 ELSEIF(ISUB.EQ.122) THEN
24131C...q + qbar -> Q + Qbar + h0
24132 IA=KFPR(ISUBSV,2)
24133 PMF=PYMRUN(IA,SH)
24134 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
24135 & (0.5D0*PMF/PMAS(24,1))**2
24136 WID2=1D0
24137 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
24138 FACQQH=FACQQH*WID2
24139 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24140 IKFI=1
24141 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
24142 IF(IA.GT.10) IKFI=3
24143 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
24144 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
24145 FACQQH=FACQQH/(1D0+RMSS(41))**2
24146 IF(IHIGG.NE.3) THEN
24147 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
24148 & PARU(151+10*IHIGG))**2
24149 ENDIF
24150 ENDIF
24151 ENDIF
24152 CALL PYQQBH(WTQQBH)
24153 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
24154 HS=SHR*WDTP(0)
24155 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24156 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
24157 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
24158 & FACBW=0D0
24159 DO 470 I=MMINA,MMAXA
24160 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
24161 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 470
24162 NCHN=NCHN+1
24163 ISIG(NCHN,1)=I
24164 ISIG(NCHN,2)=-I
24165 ISIG(NCHN,3)=1
24166 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
24167 470 CONTINUE
24168
24169 ELSEIF(ISUB.EQ.123) THEN
24170C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
24171C...inner process)
24172 FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0
24173 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
24174 & PARU(154+10*IHIGG)**2
24175 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
24176 & (VINT(216)-VINT(209)**2))**2
24177 FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
24178 FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218)
24179 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
24180 HS=SHR*WDTP(0)
24181 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24182 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
24183 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
24184 & FACBW=0D0
24185 DO 490 I=MMIN1,MMAX1
24186 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 490
24187 IA=IABS(I)
24188 DO 480 J=MMIN2,MMAX2
24189 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 480
24190 JA=IABS(J)
24191 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
24192 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
24193 VI=AI-4D0*EI*XWV
24194 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
24195 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
24196 VJ=AJ-4D0*EJ*XWV
24197 FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ
24198 FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ
24199 NCHN=NCHN+1
24200 ISIG(NCHN,1)=I
24201 ISIG(NCHN,2)=J
24202 ISIG(NCHN,3)=1
24203 SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW
24204 480 CONTINUE
24205 490 CONTINUE
24206
24207 ELSEIF(ISUB.EQ.124) THEN
24208C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
24209C...inner process)
24210 FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW
24211 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
24212 & PARU(155+10*IHIGG)**2
24213 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
24214 & (VINT(216)-VINT(209)**2))**2
24215 FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
24216 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
24217 HS=SHR*WDTP(0)
24218 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24219 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
24220 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
24221 & FACBW=0D0
24222 DO 510 I=MMIN1,MMAX1
24223 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 510
24224 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
24225 DO 500 J=MMIN2,MMAX2
24226 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 500
24227 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
24228 IF(EI*EJ.GT.0D0) GOTO 500
24229 FACLR=VINT(180+I)*VINT(180+J)
24230 NCHN=NCHN+1
24231 ISIG(NCHN,1)=I
24232 ISIG(NCHN,2)=J
24233 ISIG(NCHN,3)=1
24234 SIGH(NCHN)=FACLR*FACWW*FACBW
24235 500 CONTINUE
24236 510 CONTINUE
24237
24238 ELSEIF(ISUB.EQ.143) THEN
24239C...f + fbar' -> H+/-
24240 SQMHC=PMAS(37,1)**2
24241 CALL PYWIDT(37,SH,WDTP,WDTE)
24242 HS=SHR*WDTP(0)
24243 FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2)
24244 HP=AEM/(8D0*XW)*SH/SQMW*SH
24245 DO 530 I=MMIN1,MMAX1
24246 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 530
24247 IA=IABS(I)
24248 IM=(MOD(IA,10)+1)/2
24249 DO 520 J=MMIN2,MMAX2
24250 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 520
24251 JA=IABS(J)
24252 JM=(MOD(JA,10)+1)/2
24253 IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 520
24254 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
24255 & GOTO 520
24256 IF(MOD(IA,2).EQ.0) THEN
24257 IU=IA
24258 IL=JA
24259 ELSE
24260 IU=JA
24261 IL=IA
24262 ENDIF
24263 RML=PYMRUN(IL,SH)**2/SH
24264 RMU=PYMRUN(IU,SH)**2/SH
24265 HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2)
24266 IF(IA.LE.10) HI=HI*FACA/3D0
24267 KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
24268 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
24269 NCHN=NCHN+1
24270 ISIG(NCHN,1)=I
24271 ISIG(NCHN,2)=J
24272 ISIG(NCHN,3)=1
24273 SIGH(NCHN)=HI*FACBW*HF
24274 520 CONTINUE
24275 530 CONTINUE
24276
24277 ELSEIF(ISUB.EQ.161) THEN
24278C...f + g -> f' + H+/- (b + g -> t + H+/- only)
24279C...(choice of only b and t to avoid kinematics problems)
24280 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24
24281C...H propagator: as simulated in PYOFSH and as desired
24282 SQMHC=PMAS(37,1)**2
24283 GMMHC=PMAS(37,1)*PMAS(37,2)
24284 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
24285 CALL PYWIDT(37,SQM4,WDTP,WDTE)
24286 GMMHCC=SQRT(SQM4)*WDTP(0)
24287 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
24288 FHCQ=FHCQ*HBW4C/HBW4
24289 DO 550 I=MMINA,MMAXA
24290 IA=IABS(I)
24291 IF(IA.NE.5) GOTO 550
24292 SQML=PYMRUN(IA,SH)**2
24293 IUA=IA+MOD(IA,2)
24294 SQMQ=PYMRUN(IUA,SH)**2
24295 FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW*
24296 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH+
24297 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
24298 & (SQMHC-SQMQ-SH)/SH)
24299 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
24300 DO 540 ISDE=1,2
24301 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 540
24302 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,1).EQ.0) GOTO 540
24303 NCHN=NCHN+1
24304 ISIG(NCHN,ISDE)=I
24305 ISIG(NCHN,3-ISDE)=21
24306 ISIG(NCHN,3)=1
24307 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
24308 540 CONTINUE
24309 550 CONTINUE
24310 ENDIF
24311 ENDIF
24312
24313 RETURN
24314 END
24315
24316C*********************************************************************
24317
24318C...PYSGSU
24319C...Subprocess cross sections for SUSY processes,
24320C...including Higgs pair production.
24321C...Auxiliary to PYSIGH.
24322
24323 SUBROUTINE PYSGSU(NCHN,SIGS)
24324
24325C...Double precision and integer declarations
24326 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24327 IMPLICIT INTEGER(I-N)
24328 INTEGER PYK,PYCHGE,PYCOMP
24329C...Parameter statement to help give large particle numbers.
24330 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
24331 &KEXCIT=4000000,KDIMEN=5000000)
24332C...Commonblocks
24333 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24334 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
24335 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24336 COMMON/PYINT1/MINT(400),VINT(400)
24337 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
24338 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
24339 COMMON/PYINT4/MWID(500),WIDS(500,5)
24340 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
24341 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
24342 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
24343 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
24344 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
24345 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
24346 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
24347 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
24348 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYSGCM/
24349C...Local arrays and complex variables
24350 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
24351 COMPLEX*16 OLPP,ORPP,OLP,ORP,OL,OR,QLL,QLR
24352 COMPLEX*16 QRR,QRL,GLIJ,GRIJ,PROPW,PROPZ
24353 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
24354
24355CMRENNA++
24356C...Z and W width, combinations of weak mixing angle
24357 ZWID=PMAS(23,2)
24358 WWID=PMAS(24,2)
24359 TANW=SQRT(XW/XW1)
24360 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
24361
24362C...Convert almost equivalent SUSY processes into each other
24363C...Extract differences in flavours and couplings
24364
24365C...Sleptons and sneutrinos
24366 IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN
24367 KFID=MOD(KFPR(ISUB,1),KSUSY1)
24368 ISUB=201
24369 ILR=0
24370 ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN
24371 KFID=MOD(KFPR(ISUB,1),KSUSY1)
24372 ISUB=201
24373 ILR=1
24374 ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN
24375 KFID=MOD(KFPR(ISUB,1),KSUSY1)
24376 ISUB=203
24377 ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN
24378 IF(ISUB.EQ.210) THEN
24379 RKF=2.0D0
24380 ELSEIF(ISUB.EQ.211) THEN
24381 RKF=SFMIX(15,1)**2
24382 ELSEIF(ISUB.EQ.212) THEN
24383 RKF=SFMIX(15,2)**2
24384 ENDIF
24385 ISUB=210
24386 ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN
24387 IF(ISUB.EQ.213) THEN
24388 KFID=MOD(KFPR(ISUB,1),KSUSY1)
24389 RKF=2.0D0
24390 ELSEIF(ISUB.EQ.214) THEN
24391 KFID=16
24392 RKF=1.0D0
24393 ENDIF
24394 ISUB=213
24395
24396C...Neutralinos
24397 ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN
24398 IF(ISUB.EQ.216) THEN
24399 IZID1=1
24400 IZID2=1
24401 ELSEIF(ISUB.EQ.217) THEN
24402 IZID1=2
24403 IZID2=2
24404 ELSEIF(ISUB.EQ.218) THEN
24405 IZID1=3
24406 IZID2=3
24407 ELSEIF(ISUB.EQ.219) THEN
24408 IZID1=4
24409 IZID2=4
24410 ELSEIF(ISUB.EQ.220) THEN
24411 IZID1=1
24412 IZID2=2
24413 ELSEIF(ISUB.EQ.221) THEN
24414 IZID1=1
24415 IZID2=3
24416 ELSEIF(ISUB.EQ.222) THEN
24417 IZID1=1
24418 IZID2=4
24419 ELSEIF(ISUB.EQ.223) THEN
24420 IZID1=2
24421 IZID2=3
24422 ELSEIF(ISUB.EQ.224) THEN
24423 IZID1=2
24424 IZID2=4
24425 ELSEIF(ISUB.EQ.225) THEN
24426 IZID1=3
24427 IZID2=4
24428 ENDIF
24429 ISUB=216
24430
24431C...Charginos
24432 ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN
24433 IF(ISUB.EQ.226) THEN
24434 IZID1=1
24435 IZID2=1
24436 ELSEIF(ISUB.EQ.227) THEN
24437 IZID1=2
24438 IZID2=2
24439 ELSEIF(ISUB.EQ.228) THEN
24440 IZID1=1
24441 IZID2=2
24442 ENDIF
24443 ISUB=226
24444
24445C...Neutralino + chargino
24446 ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN
24447 IF(ISUB.EQ.229) THEN
24448 IZID1=1
24449 IZID2=1
24450 ELSEIF(ISUB.EQ.230) THEN
24451 IZID1=1
24452 IZID2=2
24453 ELSEIF(ISUB.EQ.231) THEN
24454 IZID1=1
24455 IZID2=3
24456 ELSEIF(ISUB.EQ.232) THEN
24457 IZID1=1
24458 IZID2=4
24459 ELSEIF(ISUB.EQ.233) THEN
24460 IZID1=2
24461 IZID2=1
24462 ELSEIF(ISUB.EQ.234) THEN
24463 IZID1=2
24464 IZID2=2
24465 ELSEIF(ISUB.EQ.235) THEN
24466 IZID1=2
24467 IZID2=3
24468 ELSEIF(ISUB.EQ.236) THEN
24469 IZID1=2
24470 IZID2=4
24471 ENDIF
24472 ISUB=229
24473
24474C...Gluino + neutralino
24475 ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN
24476 IF(ISUB.EQ.237) THEN
24477 IZID=1
24478 ELSEIF(ISUB.EQ.238) THEN
24479 IZID=2
24480 ELSEIF(ISUB.EQ.239) THEN
24481 IZID=3
24482 ELSEIF(ISUB.EQ.240) THEN
24483 IZID=4
24484 ENDIF
24485 ISUB=237
24486
24487C...Gluino + chargino
24488 ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN
24489 IF(ISUB.EQ.241) THEN
24490 IZID=1
24491 ELSEIF(ISUB.EQ.242) THEN
24492 IZID=2
24493 ENDIF
24494 ISUB=241
24495
24496C...Squark + neutralino
24497 ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN
24498 ILR=0
24499 IF(MOD(ISUB,2).NE.0) ILR=1
24500 IF(ISUB.LE.247) THEN
24501 IZID=1
24502 ELSEIF(ISUB.LE.249) THEN
24503 IZID=2
24504 ELSEIF(ISUB.LE.251) THEN
24505 IZID=3
24506 ELSEIF(ISUB.LE.253) THEN
24507 IZID=4
24508 ENDIF
24509 ISUB=246
24510 RKF=5D0
24511
24512C...Squark + chargino
24513 ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN
24514 IF(ISUB.LE.255) THEN
24515 IZID=1
24516 ELSEIF(ISUB.LE.257) THEN
24517 IZID=2
24518 ENDIF
24519 IF(MOD(ISUB,2).EQ.0) THEN
24520 ILR=0
24521 ELSE
24522 ILR=1
24523 ENDIF
24524 ISUB=254
24525 RKF=5D0
24526
24527C...Squark + gluino
24528 ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN
24529 ISUB=258
24530 RKF=4D0
24531
24532C...Stops
24533 ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN
24534 ILR=0
24535 IF(ISUB.EQ.262) ILR=1
24536 ISUB=261
24537 ELSEIF(ISUB.EQ.265) THEN
24538 ISUB=264
24539
24540C...Squarks
24541 ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN
24542 ILR=0
24543 IF(ISUB.LE.273) THEN
24544 IF(ISUB.EQ.273) ILR=1
24545 ISUB=271
24546 RKF=16D0
24547 ELSEIF(ISUB.LE.276) THEN
24548 IF(ISUB.EQ.276) ILR=1
24549 ISUB=274
24550 RKF=16D0
24551 ELSEIF(ISUB.LE.278) THEN
24552 IF(ISUB.EQ.278) ILR=1
24553 ISUB=277
24554 RKF=4D0
24555 ELSE
24556 IF(ISUB.EQ.280) ILR=1
24557 ISUB=279
24558 RKF=4D0
24559 ENDIF
24560C...Sbottoms
24561 ELSEIF(ISUB.GE.281.AND.ISUB.LE.296) THEN
24562 ILR=0
24563 IF(ISUB.LE.283) THEN
24564 IF(ISUB.EQ.283) ILR=1
24565 ISUB=271
24566 RKF=4D0
24567 ELSEIF(ISUB.LE.286) THEN
24568 IF(ISUB.EQ.286) ILR=1
24569 ISUB=274
24570 RKF=4D0
24571 ELSEIF(ISUB.LE.288) THEN
24572 IF(ISUB.EQ.288) ILR=1
24573 ISUB=277
24574 RKF=1D0
24575 ELSEIF(ISUB.LE.290) THEN
24576 IF(ISUB.EQ.290) ILR=1
24577 ISUB=279
24578 RKF=1D0
24579 ELSEIF(ISUB.LE.293) THEN
24580 IF(ISUB.EQ.293) ILR=1
24581 ISUB=271
24582 RKF=1D0
24583 ELSEIF(ISUB.EQ.296) THEN
24584 ILR=1
24585 ISUB=274
24586 RKF=1D0
24587C...Squark + gluino
24588 ELSEIF(ISUB.EQ.294.OR.ISUB.EQ.295) THEN
24589 ISUB=258
24590 RKF=1D0
24591 ENDIF
24592C...H+/- + H0
24593 ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
24594 IF(ISUB.EQ.297) THEN
24595 RKF=.5D0*PARU(195)**2
24596 ELSEIF(ISUB.EQ.298) THEN
24597 RKF=.5D0*(1D0-PARU(195)**2)
24598 ENDIF
24599 ISUB=210
24600C...A0 + H0
24601 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
24602 IF(ISUB.EQ.299) THEN
24603 RKF=PARU(186)**2
24604 KFID=25
24605 ELSEIF(ISUB.EQ.300) THEN
24606 RKF=PARU(187)**2
24607 KFID=35
24608 ENDIF
24609 ISUB=213
24610C...H+ + H-
24611 ELSEIF(ISUB.EQ.301) THEN
24612 KFID=37
24613 RKF=1D0
24614 ISUB=201
24615 ENDIF
24616
24617C...Supersymmetric processes - all of type 2 -> 2 :
24618C...correct final-state Breit-Wigners from fixed to running width.
24619 IF(MSTP(42).GT.0) THEN
24620 DO 100 I=1,2
24621 KFLW=KFPR(ISUBSV,I)
24622 KCW=PYCOMP(KFLW)
24623 IF(PMAS(KCW,2).LT.PARP(41)) GOTO 100
24624 IF(I.EQ.1) SQMI=SQM3
24625 IF(I.EQ.2) SQMI=SQM4
24626 SQMS=PMAS(KCW,1)**2
24627 GMMS=PMAS(KCW,1)*PMAS(KCW,2)
24628 HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2)
24629 CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
24630 GMMI=SQRT(SQMI)*WDTP(0)
24631 HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2)
24632 COMFAC=COMFAC*(HBWI/HBWS)
24633 100 CONTINUE
24634 ENDIF
24635
24636C...Differential cross section expressions.
24637
24638 IF(ISUB.LE.210) THEN
24639 IF(ISUB.EQ.201) THEN
24640C...f + fbar -> e_L + e_Lbar
24641 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
24642 DO 130 I=MMIN1,MMAX1
24643 IA=IABS(I)
24644 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 130
24645 EI=KCHG(IA,1)/3D0
24646 TT3I=SIGN(1D0,EI+1D-6)/2D0
24647 EJ=-1D0
24648 TT3J=-1D0/2D0
24649 FCOL=1D0
24650C...Color factor for e+ e-
24651 IF(IA.GE.11) FCOL=3D0
24652 IF(ISUBSV.EQ.301) THEN
24653 A1=1D0
24654 A2=0D0
24655 ELSEIF(ILR.EQ.1) THEN
24656 A1=SFMIX(KFID,3)**2
24657 A2=SFMIX(KFID,4)**2
24658 ELSEIF(ILR.EQ.0) THEN
24659 A1=SFMIX(KFID,1)**2
24660 A2=SFMIX(KFID,2)**2
24661 ENDIF
24662 XLQ=(TT3J-EJ*XW)*A1
24663 XRQ=(-EJ*XW)*A2
24664 XLF=(TT3I-EI*XW)
24665 XRF=(-EI*XW)
24666 TAA=(EI*EJ)**2*(POLL+POLR)
24667 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ+XRQ)**2/XW**2/XW1**2
24668 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
24669 TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF*POLL+XRF*POLR)/XW/XW1
24670 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
24671 TNN=0.0D0
24672 TAN=0.0D0
24673 TZN=0.0D0
24674 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
24675 FAC2=SQRT(2D0)
24676 TNN1=0D0
24677 TNN2=0D0
24678 TNN3=0D0
24679 DO 120 II=1,4
24680 DK=1D0/(TH-SMZ(II)**2)
24681 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
24682 & ZMIX(II,1))
24683 FREK=FAC2*TANW*EI*ZMIX(II,1)
24684 TNN1=TNN1+FLEK**2*DK
24685 TNN2=TNN2+FREK**2*DK
24686 DO 110 JJ=1,4
24687 DL=1D0/(TH-SMZ(JJ)**2)
24688 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
24689 & ZMIX(JJ,1))
24690 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
24691 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
24692 110 CONTINUE
24693 120 CONTINUE
24694 TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2*POLL+
24695 & A2**2*TNN2**2*POLR)
24696 TNN=(TNN+SH*A1*A2*TNN3*((1D0-PARJ(131))*(1D0-PARJ(132))+
24697 & (1D0+PARJ(131))*(1D0+PARJ(132))))/4D0/XW**2
24698 TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
24699 & (TNN1*XLF*A1*POLL+TNN2*XRF*A2*POLR)
24700 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
24701 & (1D0-SQMZ/SH)/SH
24702 TZN=TZN/XW**2/XW1
24703 TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1*POLL+
24704 & A2*TNN2*POLR)/XW
24705 ENDIF
24706 FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0
24707 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2
24708 FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0
24709 NCHN=NCHN+1
24710 ISIG(NCHN,1)=I
24711 ISIG(NCHN,2)=-I
24712 ISIG(NCHN,3)=1
24713 SIGH(NCHN)=FACQQ1+FACQQ2
24714 130 CONTINUE
24715
24716 ELSEIF(ISUB.EQ.203) THEN
24717C...f + fbar -> e_L + e_Rbar
24718 DO 160 I=MMIN1,MMAX1
24719 IA=IABS(I)
24720 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
24721 EI=KCHG(IABS(I),1)/3D0
24722 TT3I=SIGN(1D0,EI)/2D0
24723 EJ=-1
24724 TT3J=-1D0/2D0
24725 FCOL=1D0
24726C...Color factor for e+ e-
24727 IF(IA.GE.11) FCOL=3D0
24728 A1=SFMIX(KFID,1)**2
24729 A2=SFMIX(KFID,2)**2
24730 XLQ=(TT3J-EJ*XW)
24731 XRQ=(-EJ*XW)
24732 XLF=(TT3I-EI*XW)
24733 XRF=(-EI*XW)
24734 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ-XRQ)**2
24735 & /XW**2/XW1**2*A1*A2
24736 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
24737 TNN=0.0D0
24738 TZN=0.0D0
24739 TNNA=0D0
24740 TNNB=0D0
24741 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
24742 FAC2=SQRT(2D0)
24743 TNN1=0D0
24744 TNN2=0D0
24745 TNN3=0D0
24746 DO 150 II=1,4
24747 DK=1D0/(TH-SMZ(II)**2)
24748 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
24749 & ZMIX(II,1))
24750 FREK=FAC2*TANW*EI*ZMIX(II,1)
24751 TNN1=TNN1+FLEK**2*DK
24752 TNN2=TNN2+FREK**2*DK
24753 DO 140 JJ=1,4
24754 DL=1D0/(TH-SMZ(JJ)**2)
24755 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
24756 & ZMIX(JJ,1))
24757 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
24758 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
24759 140 CONTINUE
24760 150 CONTINUE
24761 TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2*POLR+TNN1**2*POLL)
24762 TNNA=(TNN+SH*(A1**2*POLLL+A2**2*POLRR)*TNN3)/4D0
24763 TNNB=(TNN+SH*(A1**2*POLRR+A2**2*POLLL)*TNN3)/4D0
24764 TZN=(UH*TH-SQM3*SQM4)*A1*A2
24765 TZN=TZN*(XLQ-XRQ)*(XLF*TNN1*POLL-XRF*TNN2*POLR)/XW1
24766 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
24767 & (1D0-SQMZ/SH)/SH
24768 ENDIF
24769 FACQQ0=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
24770 FACQQ2=COMFAC*AEM**2/XW**2*(TNNA+TZN)*FCOL/3D0
24771 FACQQ1=COMFAC*AEM**2/XW**2*(TNNB+TZN)*FCOL/3D0
24772C%%%%%%%%%%%
24773 NCHN=NCHN+1
24774 ISIG(NCHN,1)=I
24775 ISIG(NCHN,2)=-I
24776 ISIG(NCHN,3)=1
24777 SIGH(NCHN)=(FACQQ0+FACQQ1)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
24778 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
24779 NCHN=NCHN+1
24780 ISIG(NCHN,1)=I
24781 ISIG(NCHN,2)=-I
24782 ISIG(NCHN,3)=2
24783 SIGH(NCHN)=(FACQQ0+FACQQ2)*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
24784 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
24785 160 CONTINUE
24786
24787 ELSEIF(ISUB.EQ.210) THEN
24788C...q + qbar' -> W*- > ~l_L + ~nu_L
24789 FAC0=RKF*COMFAC*AEM**2/XW**2/12D0
24790 FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW)
24791 DO 180 I=MMIN1,MMAX1
24792 IA=IABS(I)
24793 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 180
24794 DO 170 J=MMIN2,MMAX2
24795 JA=IABS(J)
24796 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 170
24797 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 170
24798 FCKM=3D0
24799 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
24800 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
24801 KCHW=2
24802 IF(KCHSUM.LT.0) KCHW=3
24803 NCHN=NCHN+1
24804 ISIG(NCHN,1)=I
24805 ISIG(NCHN,2)=J
24806 ISIG(NCHN,3)=1
24807 IF(ISUBSV.EQ.297.OR.ISUBSV.EQ.298) THEN
24808 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
24809 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
24810 ELSE
24811 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
24812 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
24813 ENDIF
24814 SIGH(NCHN)=FAC0*FAC1*FCKM*FACR
24815 170 CONTINUE
24816 180 CONTINUE
24817 ENDIF
24818
24819 ELSEIF(ISUB.LE.220) THEN
24820 IF(ISUB.EQ.213) THEN
24821C...f + fbar -> ~nu_L + ~nu_Lbar
24822 IF(ISUBSV.EQ.299.OR.ISUBSV.EQ.300) THEN
24823 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
24824 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
24825 ELSE
24826 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
24827 ENDIF
24828 COMFAC=COMFAC*FACR
24829 PROPZ2=(SH-SQMZ)**2+ZWID**2*SQMZ
24830 XLL=0.5D0
24831 XLR=0.0D0
24832 DO 190 I=MMIN1,MMAX1
24833 IA=IABS(I)
24834 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 190
24835 EI=KCHG(IA,1)/3D0
24836 FCOL=1D0
24837C...Color factor for e+ e-
24838 IF(IA.GE.11) FCOL=3D0
24839 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
24840 XRQ=-EI*XW
24841 TZC=0.0D0
24842 TCC=0.0D0
24843 IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN
24844 TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/
24845 & (TH-SMW(2)**2)
24846 TCC=TZC**2
24847 TZC=TZC/XW1*(SH-SQMZ)/PROPZ2*XLQ*XLL
24848 ENDIF
24849 FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ2
24850 FACQQ2=TZC+TCC/4D0
24851 NCHN=NCHN+1
24852 ISIG(NCHN,1)=I
24853 ISIG(NCHN,2)=-I
24854 ISIG(NCHN,3)=1
24855 SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC
24856 & *AEM**2*FCOL/3D0/XW**2
24857 190 CONTINUE
24858
24859 ELSEIF(ISUB.EQ.216) THEN
24860C...q + qbar -> ~chi0_1 + ~chi0_1
24861 IF(IZID1.EQ.IZID2) THEN
24862 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
24863 ELSE
24864 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
24865 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
24866 ENDIF
24867 FACXX=COMFAC*AEM**2/3D0/XW**2
24868 IF(IZID1.EQ.IZID2) FACXX=FACXX/2D0
24869 ZM12=SQM3
24870 ZM22=SQM4
24871 WU2 = (UH-ZM12)*(UH-ZM22)
24872 WT2 = (TH-ZM12)*(TH-ZM22)
24873 WS2 = SMZ(IZID1)*SMZ(IZID2)*SH
24874 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
24875 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
24876 DO 200 I=1,4
24877 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
24878 IF(IZID2.NE.IZID1) THEN
24879 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
24880 ENDIF
24881 200 CONTINUE
24882 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
24883 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
24884 ORPP=DCONJG(OLPP)
24885 DO 210 I=MMINA,MMAXA
24886 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210
24887 EI=KCHG(IABS(I),1)/3D0
24888 T3I=SIGN(1D0,EI+1D-6)/2D0
24889 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2
24890 XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2
24891 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
24892 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
24893 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
24894 QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
24895 QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
24896 & /DCMPLX(TH-XML2)
24897 QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
24898 QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
24899 & -DCONJG(GRIJ)/DCMPLX(UH-XMR2)
24900 FCOL=1D0
24901 IF(IABS(I).GE.11) FCOL=3D0
24902 FACGG1=(ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
24903 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
24904 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
24905 & QRL*DCONJG(QRR)*POLR)*WS2
24906 NCHN=NCHN+1
24907 ISIG(NCHN,1)=I
24908 ISIG(NCHN,2)=-I
24909 ISIG(NCHN,3)=1
24910 SIGH(NCHN)=FACXX*FACGG1*FCOL
24911 210 CONTINUE
24912 ENDIF
24913
24914 ELSEIF(ISUB.LE.230) THEN
24915 IF(ISUB.EQ.226) THEN
24916C...f + fbar -> ~chi+_1 + ~chi-_1
24917 FACXX=COMFAC*AEM**2/3D0
24918 ZM12=SQM3
24919 ZM22=SQM4
24920 WU2 = (UH-ZM12)*(UH-ZM22)
24921 WT2 = (TH-ZM12)*(TH-ZM22)
24922 WS2 = SMW(IZID1)*SMW(IZID2)*SH
24923 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
24924 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
24925 DIFF=0D0
24926 IF(IZID1.EQ.IZID2) DIFF=1D0
24927 DO 220 I=1,2
24928 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
24929 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
24930 IF(IZID2.NE.IZID1) THEN
24931 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
24932 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
24933 ENDIF
24934 220 CONTINUE
24935 OLP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
24936 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0+DCMPLX(XW*DIFF)
24937 ORP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
24938 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0+DCMPLX(XW*DIFF)
24939 DO 230 I=MMINA,MMAXA
24940 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 230
24941 EI=KCHG(IABS(I),1)/3D0
24942 T3I=SIGN(1D0,EI+1D-6)/2D0
24943 QRL=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*ORP
24944 QLL=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*PROPZ*ORP
24945 QRR=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*OLP
24946 IF(MOD(I,2).EQ.0) THEN
24947 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
24948 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
24949 & PROPZ*OLP-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*
24950 & DCMPLX(T3I/XW/(TH-XML2))
24951 ELSE
24952 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2
24953 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
24954 & PROPZ*OLP-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*
24955 & DCMPLX(T3I/XW/(TH-XML2))
24956 ENDIF
24957 FCOL=1D0
24958 IF(IABS(I).GE.11) FCOL=3D0
24959 FACSUM=((ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
24960 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
24961 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
24962 & QRL*DCONJG(QRR)*POLR)*WS2)*FACXX*FCOL
24963 NCHN=NCHN+1
24964 ISIG(NCHN,1)=I
24965 ISIG(NCHN,2)=-I
24966 ISIG(NCHN,3)=1
24967 IF(IZID1.EQ.IZID2) THEN
24968 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
24969 ELSE
24970 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
24971 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
24972 NCHN=NCHN+1
24973 ISIG(NCHN,1)=I
24974 ISIG(NCHN,2)=-I
24975 ISIG(NCHN,3)=2
24976 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
24977 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
24978 ENDIF
24979 230 CONTINUE
24980
24981 ELSEIF(ISUB.EQ.229) THEN
24982C...q + qbar' -> ~chi0_1 + ~chi+-_1
24983 FACXX=COMFAC*AEM**2/6D0/XW**2
24984 ZM12=SQM3
24985 ZM22=SQM4
24986 WU2 = (UH-ZM12)*(UH-ZM22)
24987 WT2 = (TH-ZM12)*(TH-ZM22)
24988 WS2 = SMW(IZID1)*SMZ(IZID2)*SH
24989 RT2I = 1D0/SQRT(2D0)
24990 PROPW = DCMPLX(SH-SQMW,-WWID*PMAS(24,1))/
24991 & DCMPLX((SH-SQMW)**2+WWID**2*SQMW,0D0)
24992 DO 240 I=1,2
24993 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
24994 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
24995 240 CONTINUE
24996 DO 250 I=1,4
24997 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
24998 250 CONTINUE
24999 OL=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
25000 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)*PROPW
25001 OR=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
25002 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)*PROPW
25003
25004 DO 270 I=MMIN1,MMAX1
25005 IA=IABS(I)
25006 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 270
25007 EI=KCHG(IA,1)/3D0
25008 T3I=SIGN(1D0,EI+1D-6)/2D0
25009 DO 260 J=MMIN2,MMAX2
25010 JA=IABS(J)
25011 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 260
25012 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 260
25013 EJ=KCHG(JA,1)/3D0
25014 T3J=SIGN(1D0,EJ+1D-6)/2D0
25015 FCKM=3D0
25016 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
25017 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
25018 KCHW=2
25019 IF(KCHSUM.LT.0) KCHW=3
25020 IF(MOD(IA,2).EQ.0) THEN
25021 ZMI2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
25022 ZMJ2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
25023 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
25024 & TANW+ZMIXC(IZID2,2)*T3I)/DCMPLX(UH-ZMI2)
25025 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
25026 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
25027 & /DCMPLX(TH-ZMJ2)
25028 ELSE
25029 ZMI2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
25030 ZMJ2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
25031 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
25032 & TANW+ZMIXC(IZID2,2)*T3J)/DCMPLX(UH-ZMJ2)
25033 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
25034 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
25035 & /DCMPLX(TH-ZMI2)
25036 ENDIF
25037 ZINTR=DBLE(QLR*DCONJG(QLL))
25038 FACGG1=FACXX*(ABS(QLL)**2*WU2+ABS(QLR)**2*WT2+
25039 & 2D0*ZINTR*WS2)
25040 NCHN=NCHN+1
25041 ISIG(NCHN,1)=I
25042 ISIG(NCHN,2)=J
25043 ISIG(NCHN,3)=1
25044 SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25045 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
25046 260 CONTINUE
25047 270 CONTINUE
25048 ENDIF
25049
25050 ELSEIF(ISUB.LE.240) THEN
25051 IF(ISUB.EQ.237) THEN
25052C...q + qbar -> gluino + ~chi0_1
25053 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25054 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25055 FAC0=COMFAC*AS*AEM*4D0/9D0/XW
25056 GM2=SQM3
25057 ZM2=SQM4
25058 DO 280 I=MMINA,MMAXA
25059 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 280
25060 EI=KCHG(IABS(I),1)/3D0
25061 IA=IABS(I)
25062 XLQC = -TANW*EI*ZMIX(IZID,1)
25063 XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
25064 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
25065 XLQ2=XLQC**2
25066 XRQ2=XRQC**2
25067 XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2
25068 XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2
25069 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2
25070 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2
25071 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2)
25072 SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN)
25073 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2
25074 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2
25075 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2)
25076 SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN)
25077 NCHN=NCHN+1
25078 ISIG(NCHN,1)=I
25079 ISIG(NCHN,2)=-I
25080 ISIG(NCHN,3)=1
25081 SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR)
25082 280 CONTINUE
25083 ENDIF
25084
25085 ELSEIF(ISUB.LE.250) THEN
25086 IF(ISUB.EQ.241) THEN
25087C...q + qbar' -> ~chi+-_1 + gluino
25088 FACWG=COMFAC*AS*AEM/XW*2D0/9D0
25089 GM2=SQM3
25090 ZM2=SQM4
25091 FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1)
25092 FAC0=UMIX(IZID,1)**2
25093 FAC1=VMIX(IZID,1)**2
25094 DO 300 I=MMIN1,MMAX1
25095 IA=IABS(I)
25096 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 300
25097 DO 290 J=MMIN2,MMAX2
25098 JA=IABS(J)
25099 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 290
25100 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 290
25101 FCKM=1D0
25102 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
25103 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
25104 KCHW=2
25105 IF(KCHSUM.LT.0) KCHW=3
25106 XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2
25107 XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2
25108 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2
25109 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2
25110 ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2)
25111 XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2
25112 XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2
25113 ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0
25114 AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0
25115 ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)*
25116 & SH/(TH-XMU2)/(UH-XMD2))/2D0
25117 NCHN=NCHN+1
25118 ISIG(NCHN,1)=I
25119 ISIG(NCHN,2)=J
25120 ISIG(NCHN,3)=1
25121 SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN-
25122 & FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25123 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
25124 290 CONTINUE
25125 300 CONTINUE
25126
25127 ELSEIF(ISUB.EQ.243) THEN
25128C...q + qbar -> gluino + gluino
25129 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25130 XMT=SQM3-TH
25131 XMU=SQM3-UH
25132 DO 310 I=MMINA,MMAXA
25133 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
25134 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
25135 NCHN=NCHN+1
25136 XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH
25137 XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH
25138 FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
25139 & 2D0*SQM3*SH)/SH2 +4D0/9D0*(XMT**2/XST**2+
25140 & XMU**2/XSU**2) - (XMT**2+SH*SQM3)/SH/XST +
25141 & SQM3*SH/XST/XSU/9D0- (XMU**2+SH*SQM3)/SH/XSU )
25142 XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
25143 XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
25144 FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
25145 & 2D0*SQM3*SH)/SH2 +4D0/9D0*(XMT**2/XST**2+
25146 & XMU**2/XSU**2) - (XMT**2+SH*SQM3)/SH/XST +
25147 & SQM3*SH/XST/XSU/9D0- (XMU**2+SH*SQM3)/SH/XSU )
25148 ISIG(NCHN,1)=I
25149 ISIG(NCHN,2)=-I
25150 ISIG(NCHN,3)=1
25151C...1/2 for identical particles
25152 SIGH(NCHN)=0.25D0*(FACGG1+FACGG2)
25153 310 CONTINUE
25154
25155 ELSEIF(ISUB.EQ.244) THEN
25156C...g + g -> gluino + gluino
25157 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25158 XMT=SQM3-TH
25159 XMU=SQM3-UH
25160 FACQQ1=COMFAC*AS**2*9D0/4D0*(
25161 & (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 -
25162 & (XMT*XMU+SQM3*(UH-TH))/SH/XMT )
25163 FACQQ2=COMFAC*AS**2*9D0/4D0*(
25164 & (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 -
25165 & (XMU*XMT+SQM3*(TH-UH))/SH/XMU )
25166 FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 +
25167 & SQM3*(SH-4D0*SQM3)/XMT/XMU)
25168 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 320
25169 NCHN=NCHN+1
25170 ISIG(NCHN,1)=21
25171 ISIG(NCHN,2)=21
25172 ISIG(NCHN,3)=1
25173 SIGH(NCHN)=FACQQ1/2D0
25174 NCHN=NCHN+1
25175 ISIG(NCHN,1)=21
25176 ISIG(NCHN,2)=21
25177 ISIG(NCHN,3)=2
25178 SIGH(NCHN)=FACQQ2/2D0
25179 NCHN=NCHN+1
25180 ISIG(NCHN,1)=21
25181 ISIG(NCHN,2)=21
25182 ISIG(NCHN,3)=3
25183 SIGH(NCHN)=FACQQ3/2D0
25184 320 CONTINUE
25185
25186 ELSEIF(ISUB.EQ.246) THEN
25187C...g + q_j -> ~chi0_1 + ~q_j
25188 FAC0=COMFAC*AS*AEM/6D0/XW
25189 ZM2=SQM4
25190 QM2=SQM3
25191 FACZQ0=FAC0*( (ZM2-TH)/SH +
25192 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
25193 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
25194 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
25195 DO 340 I=-KFNSQ,KFNSQ,2*KFNSQ
25196 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 340
25197 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
25198 EI=KCHG(IABS(I),1)/3D0
25199 IA=IABS(I)
25200 XRQZ = -TANW*EI*ZMIX(IZID,1)
25201 XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
25202 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
25203 IF(ILR.EQ.0) THEN
25204 BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2
25205 ELSE
25206 BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2
25207 ENDIF
25208 FACZQ=FACZQ0*BS
25209 KCHQ=2
25210 IF(I.LT.0) KCHQ=3
25211 DO 330 ISDE=1,2
25212 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
25213 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
25214 NCHN=NCHN+1
25215 ISIG(NCHN,ISDE)=I
25216 ISIG(NCHN,3-ISDE)=21
25217 ISIG(NCHN,3)=1
25218 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25219 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25220 330 CONTINUE
25221 340 CONTINUE
25222 ENDIF
25223
25224 ELSEIF(ISUB.LE.260) THEN
25225 IF(ISUB.EQ.254) THEN
25226C...g + q_j -> ~chi1_1 + ~q_i
25227 FAC0=COMFAC*AS*AEM/12D0/XW
25228 ZM2=SQM4
25229 QM2=SQM3
25230 AU=UMIX(IZID,1)**2
25231 AD=VMIX(IZID,1)**2
25232 FACZQ0=FAC0*( (ZM2-TH)/SH +
25233 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
25234 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
25235 KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1)
25236 IF(MOD(KFNSQ1,2).EQ.0) THEN
25237 KFNSQ=KFNSQ1-1
25238 KCHW=2
25239 ELSE
25240 KFNSQ=KFNSQ1+1
25241 KCHW=3
25242 ENDIF
25243 DO 360 I=-KFNSQ,KFNSQ,2*KFNSQ
25244 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 360
25245 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
25246 IA=IABS(I)
25247 IF(MOD(IA,2).EQ.0) THEN
25248 FACZQ=FACZQ0*AU
25249 ELSE
25250 FACZQ=FACZQ0*AD
25251 ENDIF
25252 FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2
25253 KCHQ=2
25254 IF(I.LT.0) KCHQ=3
25255 KCHWQ=KCHW
25256 IF(I.LT.0) KCHWQ=5-KCHW
25257 DO 350 ISDE=1,2
25258 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
25259 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
25260 NCHN=NCHN+1
25261 ISIG(NCHN,ISDE)=I
25262 ISIG(NCHN,3-ISDE)=21
25263 ISIG(NCHN,3)=1
25264 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25265 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ)
25266 350 CONTINUE
25267 360 CONTINUE
25268
25269 ELSEIF(ISUB.EQ.258) THEN
25270C...g + q_j -> gluino + ~q_i
25271 XG2=SQM4
25272 XQ2=SQM3
25273 XMT=XG2-TH
25274 XMU=XG2-UH
25275 XST=XQ2-TH
25276 XSU=XQ2-UH
25277 FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 -
25278 & ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) +
25279 & 0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) +
25280 & (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU
25281 FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0*
25282 & (SH*(UH+XG2)
25283 & +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH +
25284 & 0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+
25285 & (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU
25286 FACQG1=COMFAC*AS**2*FACQG1/2D0
25287 FACQG2=COMFAC*AS**2*FACQG2/2D0
25288 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
25289 DO 380 I=-KFNSQ,KFNSQ,2*KFNSQ
25290 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 380
25291 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 380
25292 KCHQ=2
25293 IF(I.LT.0) KCHQ=3
25294 FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25295 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25296 DO 370 ISDE=1,2
25297 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 370
25298 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 370
25299 NCHN=NCHN+1
25300 ISIG(NCHN,ISDE)=I
25301 ISIG(NCHN,3-ISDE)=21
25302 ISIG(NCHN,3)=1
25303 SIGH(NCHN)=FACQG1*FACSEL
25304 NCHN=NCHN+1
25305 ISIG(NCHN,ISDE)=I
25306 ISIG(NCHN,3-ISDE)=21
25307 ISIG(NCHN,3)=2
25308 SIGH(NCHN)=FACQG2*FACSEL
25309 370 CONTINUE
25310 380 CONTINUE
25311 ENDIF
25312
25313 ELSEIF(ISUB.LE.270) THEN
25314 IF(ISUB.EQ.261) THEN
25315C...q_i + q_ibar -> ~t_1 + ~t_1bar
25316 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )*
25317 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25318 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
25319 FAC0=AS**2*4D0/9D0
25320 DO 390 I=MMIN1,MMAX1
25321 IA=IABS(I)
25322 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 390
25323 IF(IA.GE.11.AND.IA.LE.18) THEN
25324 EI=KCHG(IA,1)/3D0
25325 EJ=KCHG(KFNSQ,1)/3D0
25326 T3I=SIGN(1D0,EI)/2D0
25327 T3J=SIGN(1D0,EJ)/2D0
25328 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2
25329 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2
25330 XLF=2D0*(T3I-EI*XW)
25331 XRF=2D0*(-EI*XW)
25332 TAA=0.5D0*(EI*EJ)**2
25333 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
25334 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
25335 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
25336 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
25337 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
25338 ENDIF
25339 NCHN=NCHN+1
25340 ISIG(NCHN,1)=I
25341 ISIG(NCHN,2)=-I
25342 ISIG(NCHN,3)=1
25343 SIGH(NCHN)=FACQQ1*FAC0
25344 390 CONTINUE
25345
25346 ELSEIF(ISUB.EQ.263) THEN
25347C...f + fbar -> ~t1 + ~t2bar
25348 DO 400 I=MMIN1,MMAX1
25349 IA=IABS(I)
25350 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
25351 EI=KCHG(IABS(I),1)/3D0
25352 TT3I=SIGN(1D0,EI)/2D0
25353 EJ=2D0/3D0
25354 TT3J=1D0/2D0
25355 FCOL=1D0
25356C...Color factor for e+ e-
25357 IF(IA.GE.11) FCOL=3D0
25358 XLQ=2D0*(TT3J-EJ*XW)
25359 XRQ=2D0*(-EJ*XW)
25360 XLF=2D0*(TT3I-EI*XW)
25361 XRF=2D0*(-EI*XW)
25362 TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2
25363 TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2
25364 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
25365C...Factor of 2 for t1 t2bar + t2 t1bar
25366 FACQQ1=2D0*COMFAC*AEM**2*TZZ*FCOL*4D0
25367 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2
25368 NCHN=NCHN+1
25369 ISIG(NCHN,1)=I
25370 ISIG(NCHN,2)=-I
25371 ISIG(NCHN,3)=1
25372 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25373 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
25374 NCHN=NCHN+1
25375 ISIG(NCHN,1)=I
25376 ISIG(NCHN,2)=-I
25377 ISIG(NCHN,3)=2
25378 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
25379 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25380 400 CONTINUE
25381
25382 ELSEIF(ISUB.EQ.264) THEN
25383C...g + g -> ~t_1 + ~t_1bar
25384 XSU=SQM3-UH
25385 XST=SQM3-TH
25386 FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0*
25387 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25388 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
25389 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
25390 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
25391 NCHN=NCHN+1
25392 ISIG(NCHN,1)=21
25393 ISIG(NCHN,2)=21
25394 ISIG(NCHN,3)=1
25395 SIGH(NCHN)=FACQQ1
25396 NCHN=NCHN+1
25397 ISIG(NCHN,1)=21
25398 ISIG(NCHN,2)=21
25399 ISIG(NCHN,3)=2
25400 SIGH(NCHN)=FACQQ2
25401 410 CONTINUE
25402 ENDIF
25403
25404 ELSEIF(ISUB.LE.280) THEN
25405 IF(ISUB.EQ.271) THEN
25406C...q + q' -> ~q + ~q' (~g exchange)
25407 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
25408 XMT=XMG2-TH
25409 XMU=XMG2-UH
25410 XSU1=SQM3-UH
25411 XSU2=SQM4-UH
25412 XST1=SQM3-TH
25413 XST2=SQM4-TH
25414 IF(ILR.EQ.1) THEN
25415 FACQQ1=COMFAC*AS**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 )
25416 FACQQ2=COMFAC*AS**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 )
25417 FACQQB=0.0D0
25418 ELSE
25419 FACQQ1=0.5D0*COMFAC*AS**2*4D0/9D0*( SH*XMG2/XMT**2 )
25420 FACQQ2=0.5D0*COMFAC*AS**2*4D0/9D0*( SH*XMG2/XMU**2 )
25421 FACQQB=0.5D0*COMFAC*AS**2*4D0/9D0*( -2D0*SH*XMG2/3D0/
25422 & XMT/XMU )
25423 ENDIF
25424 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
25425 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
25426 DO 430 I=-KFNSQI,KFNSQI,2*KFNSQI
25427 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 430
25428 IA=IABS(I)
25429 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
25430 KCHQ=2
25431 IF(I.LT.0) KCHQ=3
25432 DO 420 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
25433 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 420
25434 JA=IABS(J)
25435 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
25436 IF(I*J.LT.0) GOTO 420
25437 NCHN=NCHN+1
25438 ISIG(NCHN,1)=I
25439 ISIG(NCHN,2)=J
25440 ISIG(NCHN,3)=1
25441 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25442 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
25443 IF(I.EQ.J) THEN
25444 IF(ILR.EQ.0) THEN
25445 SIGH(NCHN)=0.5D0*(FACQQ1+0.5D0*FACQQB)*RKF*
25446 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
25447 ELSE
25448 SIGH(NCHN)=0.5D0*FACQQ1*RKF*
25449 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25450 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
25451 ENDIF
25452 NCHN=NCHN+1
25453 ISIG(NCHN,1)=I
25454 ISIG(NCHN,2)=J
25455 ISIG(NCHN,3)=2
25456 IF(ILR.EQ.0) THEN
25457 SIGH(NCHN)=0.5D0*(FACQQ2+0.5D0*FACQQB)*RKF*
25458 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
25459 ELSE
25460 SIGH(NCHN)=0.5D0*FACQQ2*RKF*
25461 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25462 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
25463 ENDIF
25464 ENDIF
25465 420 CONTINUE
25466 430 CONTINUE
25467
25468 ELSEIF(ISUB.EQ.274) THEN
25469C...q + qbar' -> ~q + ~qbar'
25470 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
25471 XMT=XMG2-TH
25472 XMU=XMG2-UH
25473 IF(ILR.EQ.0) THEN
25474C...Mrenna...Normalization.and.1/XMT
25475 FACQQ1=COMFAC*AS**2*2D0/9D0*(
25476 & (UH*TH-SQM3*SQM4)/XMT**2 )
25477 FACQQB=COMFAC*AS**2*2D0/9D0*(
25478 & (UH*TH-SQM3*SQM4)/SH2*(2D0-2D0/3D0*SH/XMT))
25479 FACQQB=FACQQB+FACQQ1
25480 ELSE
25481 FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )
25482 FACQQB=FACQQ1
25483 ENDIF
25484 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
25485 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
25486 DO 450 I=-KFNSQI,KFNSQI,2*KFNSQI
25487 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 450
25488 IA=IABS(I)
25489 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 450
25490 KCHQ=2
25491 IF(I.LT.0) KCHQ=3
25492 DO 440 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
25493 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 440
25494 JA=IABS(J)
25495 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 440
25496 IF(I*J.GT.0) GOTO 440
25497 NCHN=NCHN+1
25498 ISIG(NCHN,1)=I
25499 ISIG(NCHN,2)=J
25500 ISIG(NCHN,3)=1
25501 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25502 & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
25503 IF(I.EQ.-J) SIGH(NCHN)=FACQQB*RKF*
25504 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25505 440 CONTINUE
25506 450 CONTINUE
25507
25508 ELSEIF(ISUB.EQ.277) THEN
25509C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
25510C...if i .eq. j covered in 274
25511 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )
25512 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
25513 FAC0=0D0
25514 DO 460 I=MMIN1,MMAX1
25515 IA=IABS(I)
25516 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.
25517 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
25518 IF(IA.EQ.KFNSQ) GOTO 460
25519 IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN
25520 EI=KCHG(IA,1)/3D0
25521 EJ=KCHG(KFNSQ,1)/3D0
25522 T3J=SIGN(0.5D0,EJ)
25523 T3I=SIGN(1D0,EI)/2D0
25524 IF(ILR.EQ.0) THEN
25525 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1)
25526 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2)
25527 ELSE
25528 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3)
25529 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4)
25530 ENDIF
25531 XLF=2D0*(T3I-EI*XW)
25532 XRF=2D0*(-EI*XW)
25533 IF(ILR.EQ.0) THEN
25534 XRQ=0D0
25535 ELSE
25536 XLQ=0D0
25537 ENDIF
25538 TAA=0.5D0*(EI*EJ)**2
25539 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
25540 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
25541 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
25542 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
25543 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
25544 ELSEIF(IA.LE.6) THEN
25545 FAC0=AS**2*8D0/9D0/2D0
25546 ENDIF
25547 NCHN=NCHN+1
25548 ISIG(NCHN,1)=I
25549 ISIG(NCHN,2)=-I
25550 ISIG(NCHN,3)=1
25551 SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25552 460 CONTINUE
25553
25554 ELSEIF(ISUB.EQ.279) THEN
25555C...g + g -> ~q_j + ~q_jbar
25556 XSU=SQM3-UH
25557 XST=SQM3-TH
25558C...5=RKF because ~t ~tbar treated separately
25559 FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )
25560 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
25561 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
25562 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 470
25563 NCHN=NCHN+1
25564 ISIG(NCHN,1)=21
25565 ISIG(NCHN,2)=21
25566 ISIG(NCHN,3)=1
25567 SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25568 NCHN=NCHN+1
25569 ISIG(NCHN,1)=21
25570 ISIG(NCHN,2)=21
25571 ISIG(NCHN,3)=2
25572 SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25573 470 CONTINUE
25574
25575 ENDIF
25576 ENDIF
25577CMRENNA--
25578
25579 RETURN
25580 END
25581
25582C*********************************************************************
25583
25584C...PYSGTC
25585C...Subprocess cross sections for Technicolor processes.
25586C...Auxiliary to PYSIGH.
25587
25588 SUBROUTINE PYSGTC(NCHN,SIGS)
25589
25590C...Double precision and integer declarations
25591 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25592 IMPLICIT INTEGER(I-N)
25593 INTEGER PYK,PYCHGE,PYCOMP
25594C...Parameter statement to help give large particle numbers.
25595 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
25596 &KEXCIT=4000000,KDIMEN=5000000)
25597C...Commonblocks
25598 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
25599 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
25600 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
25601 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
25602 COMMON/PYINT1/MINT(400),VINT(400)
25603 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
25604 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
25605 COMMON/PYINT4/MWID(500),WIDS(500,5)
25606 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
25607 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
25608 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
25609 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
25610 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
25611 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
25612 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
25613C...Local arrays and complex variables
25614 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
25615 COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME
25616 COMPLEX*16 DAA,DZZ,DAZ,DWW,DWRHO
25617 COMPLEX*16 ZTC(6,6),YTC(6,6),DGGS,DGGT,DGGU,DGVS,DGVT,DGVU
25618 COMPLEX*16 DQQS,DQQT,DQQU,DQTS,DQGS,DTGS
25619 COMPLEX*16 DVVS,DVVT,DVVU
25620 INTEGER INDX(6)
25621
25622C...Combinations of weak mixing angle.
25623 TANW=SQRT(XW/XW1)
25624 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
25625
25626C...Convert almost equivalent technicolor processes into
25627C...a few basic processes, and set distinguishing parameters.
25628 IF(ISUB.GE.361.AND.ISUB.LE.379) THEN
25629 SQTV=RTCM(12)**2
25630 SQTA=RTCM(13)**2
25631 SN2W=2D0*SQRT(PARU(102)*(1D0-PARU(102)))
25632 CS2W=1D0-2D0*PARU(102)
25633 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
25634 CT2W=CS2W/SN2W
25635 CSXI=COS(ASIN(RTCM(3)))
25636 CSXIP=COS(ASIN(RTCM(4)))
25637 QUPD=2D0*RTCM(2)-1D0
25638 Q2UD=RTCM(2)**2+(RTCM(2)-1D0)**2
25639C... rho_tc0 -> W_L W_L
25640 IF(ISUB.EQ.361) THEN
25641 KFA=24
25642 KFB=24
25643 CAB2=RTCM(3)**4
25644C... rho_tc0 -> W_L pi_tc-
25645 ELSEIF(ISUB.EQ.362) THEN
25646 KFA=24
25647 KFB=KTECHN+211
25648 ISUB=361
25649 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
25650C... pi_tc pi_tc
25651 ELSEIF(ISUB.EQ.363) THEN
25652 KFA=KTECHN+211
25653 KFB=KTECHN+211
25654 ISUB=361
25655 CAB2=(1D0-RTCM(3)**2)**2
25656C... rho_tc0/omega_tc -> gamma pi_tc
25657 ELSEIF(ISUB.EQ.364) THEN
25658 KFA=22
25659 KFB=KTECHN+111
25660 VOGP=CSXI/RTCM(12)
25661C..........!!!
25662 VRGP=VOGP*QUPD
25663 AOGP=0D0
25664 ARGP=0D0
25665 VAGP=2D0*QUPD*CSXI
25666 VZGP=QUPD*CSXI*(1D0-4D0*PARU(102))/SN2W
25667C... gamma pi_tc'
25668 ELSEIF(ISUB.EQ.365) THEN
25669 KFA=22
25670 KFB=KTECHN+221
25671 ISUB=364
25672 VRGP=CSXIP/RTCM(12)
25673C..........!!!!
25674 VOGP=VRGP*QUPD
25675 AOGP=0D0
25676 ARGP=0D0
25677 VAGP=2D0*Q2UD*CSXIP
25678 VZGP=CSXIP/SN2W*(1D0-4D0*PARU(102)*Q2UD)
25679C... Z pi_tc
25680 ELSEIF(ISUB.EQ.366) THEN
25681 KFA=23
25682 KFB=KTECHN+111
25683 ISUB=364
25684 VOGP=CSXI*CT2W/RTCM(12)
25685 VRGP=-QUPD*CSXI*TANW/RTCM(12)
25686 AOGP=0D0
25687 ARGP=0D0
25688 VAGP=QUPD*CSXI*(1D0-4D0*PARU(102))/SN2W
25689 VZGP=-QUPD*CSXI*CS2W/(1D0-PARU(102))
25690C... Z pi_tc'
25691 ELSEIF(ISUB.EQ.367) THEN
25692 KFA=23
25693 KFB=KTECHN+221
25694 ISUB=364
25695 VRGP=CSXIP*CT2W/RTCM(12)
25696 VOGP=-QUPD*CSXIP*TANW/RTCM(12)
25697 AOGP=0D0
25698 ARGP=0D0
25699 VAGP=CSXIP*(1D0-4D0*Q2UD*PARU(102))/SN2W
25700 VZGP=2D0*CSXIP*(CS2W+4D0*Q2UD*PARU(102)**2)/SN2W**2
25701C... W_T pi_tc
25702 ELSEIF(ISUB.EQ.368) THEN
25703 KFA=24
25704 KFB=KTECHN+211
25705 ISUB=364
25706 VOGP=CSXI/(2D0*SQRT(PARU(102)))/RTCM(12)
25707 VRGP=0D0
25708 AOGP=0D0
25709C..........!!!!
25710 ARGP=-CSXI/(2D0*SQRT(PARU(102)))/RTCM(13)
25711 VAGP=QUPD*CSXI/(2D0*SQRT(PARU(102)))
25712 VZGP=-QUPD*CSXI/(2D0*SQRT(1D0-PARU(102)))
25713C... rho_tc+ -> W_L Z_L
25714 ELSEIF(ISUB.EQ.370) THEN
25715 KFA=24
25716 KFB=23
25717 CAB2=RTCM(3)**4
25718C... W_L pi_tc0
25719 ELSEIF(ISUB.EQ.371) THEN
25720 KFA=24
25721 KFB=KTECHN+111
25722 ISUB=370
25723 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
25724C... Z_L pi_tc+
25725 ELSEIF(ISUB.EQ.372) THEN
25726 KFA=KTECHN+211
25727 KFB=23
25728 ISUB=370
25729 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
25730C... pi_tc+ pi_tc0
25731 ELSEIF(ISUB.EQ.373) THEN
25732 KFA=KTECHN+211
25733 KFB=KTECHN+111
25734 ISUB=370
25735 CAB2=(1D0-RTCM(3)**2)**2
25736C... gamma pi_tc+
25737 ELSEIF(ISUB.EQ.374) THEN
25738 KFA=KTECHN+211
25739 KFB=22
25740 VRGP=QUPD*CSXI
25741 ARGP=0D0
25742 VWGP=QUPD*CSXI/(2D0*SQRT(PARU(102)))
25743C... Z_T pi_tc+
25744 ELSEIF(ISUB.EQ.375) THEN
25745 KFA=KTECHN+211
25746 KFB=23
25747 ISUB=374
25748 VRGP=-QUPD*CSXI*TANW
25749 ARGP=CSXI/(2D0*SQRT(PARU(102)*(1D0-PARU(102))))
25750 VWGP=-QUPD*CSXI/(2D0*SQRT(1D0-PARU(102)))
25751C... W_T pi_tc0
25752 ELSEIF(ISUB.EQ.376) THEN
25753 KFA=24
25754 KFB=KTECHN+111
25755 ISUB=374
25756 VRGP=0D0
25757 ARGP=-CSXI/(2D0*SQRT(PARU(102)))
25758 VWGP=0D0
25759C... W_T pi_tc0'
25760 ELSEIF(ISUB.EQ.377) THEN
25761 KFA=24
25762 KFB=KTECHN+221
25763 ISUB=374
25764 ARGP=0D0
25765 VRGP=CSXIP/(2D0*SQRT(PARU(102)))
25766 VWGP=CSXIP/(2D0*PARU(102))
25767 ENDIF
25768 ENDIF
25769
25770C...QCD 2 -> 2 processes: corrections from virtual technicolor exchange.
25771 IF(ISUB.GE.381.AND.ISUB.LE.388) THEN
25772 IF(ITCM(5).LE.4) THEN
25773 SQDQQS=1D0/SH2
25774 SQDQQT=1D0/TH2
25775 SQDQQU=1D0/UH2
25776 SQDGGS=SQDQQS
25777 SQDGGT=SQDQQT
25778 SQDGGU=SQDQQU
25779 REDGGS=1D0/SH
25780 REDGGT=1D0/TH
25781 REDGGU=1D0/UH
25782 REDGTU=1D0/UH/TH
25783 REDGSU=1D0/SH/UH
25784 REDGST=1D0/SH/TH
25785 REDQST=1D0/SH/TH
25786 REDQTU=1D0/UH/TH
25787 SQDLGS=0D0
25788 SQDLGT=0D0
25789 SQDQTS=SQDQQS
25790 ELSEIF(ITCM(5).EQ.5) THEN
25791 TANT3=RTCM(21)
25792 IF(ITCM(2).EQ.0) THEN
25793 IMDL=1
25794 ELSE
25795 IMDL=2
25796 ENDIF
25797 ALPRHT=2.91D0*(3D0/ITCM(1))
25798 SIN2T=2D0*TANT3/(TANT3**2+1D0)
25799 SINT3=TANT3/SQRT(TANT3**2+1D0)
25800 XIG=SQRT(PYALPS(SH)/ALPRHT)
25801 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
25802 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)/SIN2T
25803 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
25804 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)/SIN2T
25805 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
25806 & SINT3**2)*2D0/SIN2T
25807 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
25808 & SINT3**2)*2D0/SIN2T
25809
25810 SM1122=.5D0*(2D0-RTCM(29)**2-RTCM(31)**2)*RTCM(28)**2
25811 SM1112=X12*RTCM(28)**2*SIN2T
25812 SM1121=-X21*RTCM(28)**2*SIN2T
25813 SM2212=-SM1112
25814 SM2221=-SM1121
25815 SM1221=-.5D0*((1D0-RTCM(29)**2)*SIN(2D0*RTCM(30))+
25816 & (1D0-RTCM(31)**2)*SIN(2D0*RTCM(32)))*RTCM(28)**2
25817
25818C.........SH LOOP
25819 ZTC(1,1)=DCMPLX(SH,0D0)
25820 CALL PYWIDT(3100021,SH,WDTP,WDTE)
25821 IF(WDTP(0).GT.RTCM(33)*SHR) WDTP(0)=RTCM(33)*SHR
25822 ZTC(2,2)=DCMPLX(SH-PMAS(PYCOMP(3100021),1)**2,-SHR*WDTP(0))
25823 CALL PYWIDT(3100113,SH,WDTP,WDTE)
25824 ZTC(3,3)=DCMPLX(SH-PMAS(PYCOMP(3100113),1)**2,-SHR*WDTP(0))
25825 CALL PYWIDT(3400113,SH,WDTP,WDTE)
25826 ZTC(4,4)=DCMPLX(SH-PMAS(PYCOMP(3400113),1)**2,-SHR*WDTP(0))
25827 CALL PYWIDT(3200113,SH,WDTP,WDTE)
25828 ZTC(5,5)=DCMPLX(SH-PMAS(PYCOMP(3200113),1)**2,-SHR*WDTP(0))
25829 CALL PYWIDT(3300113,SH,WDTP,WDTE)
25830 ZTC(6,6)=DCMPLX(SH-PMAS(PYCOMP(3300113),1)**2,-SHR*WDTP(0))
25831 ZTC(1,2)=(0D0,0D0)
25832 ZTC(1,3)=DCMPLX(SH*XIG,0D0)
25833 ZTC(1,4)=ZTC(1,3)
25834 ZTC(1,5)=ZTC(1,2)
25835 ZTC(1,6)=ZTC(1,2)
25836 ZTC(2,3)=DCMPLX(SH*XIG*X11,0D0)
25837 ZTC(2,4)=DCMPLX(SH*XIG*X22,0D0)
25838 ZTC(2,5)=DCMPLX(SH*XIG*X12,0D0)
25839 ZTC(2,6)=DCMPLX(SH*XIG*X21,0D0)
25840 ZTC(3,4)=-SM1122
25841 ZTC(3,5)=-SM1112
25842 ZTC(3,6)=-SM1121
25843 ZTC(4,5)=-SM2212
25844 ZTC(4,6)=-SM2221
25845 ZTC(5,6)=-SM1221
25846
25847 DO 110 I=1,5
25848 DO 100 J=I+1,6
25849 ZTC(J,I)=ZTC(I,J)
25850 100 CONTINUE
25851 110 CONTINUE
25852 CALL PYLDCM(ZTC,6,6,INDX,D)
25853 DO 130 I=1,6
25854 DO 120 J=1,6
25855 YTC(I,J)=(0D0,0D0)
25856 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
25857 120 CONTINUE
25858 130 CONTINUE
25859
25860 DO 140 I=1,6
25861 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
25862 140 CONTINUE
25863 DGGS=YTC(1,1)
25864 DVVS=YTC(2,2)
25865 DGVS=YTC(1,2)
25866
25867 XIG=SQRT(PYALPS(-TH)/ALPRHT)
25868C.........TH LOOP
25869 ZTC(1,1)=DCMPLX(TH)
25870 ZTC(2,2)=DCMPLX(TH-PMAS(PYCOMP(3100021),1)**2)
25871 ZTC(3,3)=DCMPLX(TH-PMAS(PYCOMP(3100113),1)**2)
25872 ZTC(4,4)=DCMPLX(TH-PMAS(PYCOMP(3400113),1)**2)
25873 ZTC(5,5)=DCMPLX(TH-PMAS(PYCOMP(3200113),1)**2)
25874 ZTC(6,6)=DCMPLX(TH-PMAS(PYCOMP(3300113),1)**2)
25875 ZTC(1,2)=(0D0,0D0)
25876 ZTC(1,3)=DCMPLX(TH*XIG,0D0)
25877 ZTC(1,4)=ZTC(1,3)
25878 ZTC(1,5)=ZTC(1,2)
25879 ZTC(1,6)=ZTC(1,2)
25880 ZTC(2,3)=DCMPLX(TH*XIG*X11,0D0)
25881 ZTC(2,4)=DCMPLX(TH*XIG*X22,0D0)
25882 ZTC(2,5)=DCMPLX(TH*XIG*X12,0D0)
25883 ZTC(2,6)=DCMPLX(TH*XIG*X21,0D0)
25884 ZTC(3,4)=-SM1122
25885 ZTC(3,5)=-SM1112
25886 ZTC(3,6)=-SM1121
25887 ZTC(4,5)=-SM2212
25888 ZTC(4,6)=-SM2221
25889 ZTC(5,6)=-SM1221
25890 DO 160 I=1,5
25891 DO 150 J=I+1,6
25892 ZTC(J,I)=ZTC(I,J)
25893 150 CONTINUE
25894 160 CONTINUE
25895 CALL PYLDCM(ZTC,6,6,INDX,D)
25896 DO 180 I=1,6
25897 DO 170 J=1,6
25898 YTC(I,J)=(0D0,0D0)
25899 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
25900 170 CONTINUE
25901 180 CONTINUE
25902 DO 190 I=1,6
25903 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
25904 190 CONTINUE
25905 DGGT=YTC(1,1)
25906 DVVT=YTC(2,2)
25907 DGVT=YTC(1,2)
25908
25909 XIG=SQRT(PYALPS(-UH)/ALPRHT)
25910C.........UH LOOP
25911 ZTC(1,1)=DCMPLX(UH,0D0)
25912 ZTC(2,2)=DCMPLX(UH-PMAS(PYCOMP(3100021),1)**2)
25913 ZTC(3,3)=DCMPLX(UH-PMAS(PYCOMP(3100113),1)**2)
25914 ZTC(4,4)=DCMPLX(UH-PMAS(PYCOMP(3400113),1)**2)
25915 ZTC(5,5)=DCMPLX(UH-PMAS(PYCOMP(3200113),1)**2)
25916 ZTC(6,6)=DCMPLX(UH-PMAS(PYCOMP(3300113),1)**2)
25917 ZTC(1,2)=(0D0,0D0)
25918 ZTC(1,3)=DCMPLX(UH*XIG,0D0)
25919 ZTC(1,4)=ZTC(1,3)
25920 ZTC(1,5)=ZTC(1,2)
25921 ZTC(1,6)=ZTC(1,2)
25922 ZTC(2,3)=DCMPLX(UH*XIG*X11,0D0)
25923 ZTC(2,4)=DCMPLX(UH*XIG*X22,0D0)
25924 ZTC(2,5)=DCMPLX(UH*XIG*X12,0D0)
25925 ZTC(2,6)=DCMPLX(UH*XIG*X21,0D0)
25926 ZTC(3,4)=-SM1122
25927 ZTC(3,5)=-SM1112
25928 ZTC(3,6)=-SM1121
25929 ZTC(4,5)=-SM2212
25930 ZTC(4,6)=-SM2221
25931 ZTC(5,6)=-SM1221
25932 DO 210 I=1,5
25933 DO 200 J=I+1,6
25934 ZTC(J,I)=ZTC(I,J)
25935 200 CONTINUE
25936 210 CONTINUE
25937 CALL PYLDCM(ZTC,6,6,INDX,D)
25938 DO 230 I=1,6
25939 DO 220 J=1,6
25940 YTC(I,J)=(0D0,0D0)
25941 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
25942 220 CONTINUE
25943 230 CONTINUE
25944 DO 240 I=1,6
25945 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
25946 240 CONTINUE
25947 DGGU=YTC(1,1)
25948 DVVU=YTC(2,2)
25949 DGVU=YTC(1,2)
25950
25951 IF(IMDL.EQ.1) THEN
25952 DQQS=DGGS+DVVS*DCMPLX(TANT3**2)-DGVS*DCMPLX(2D0*TANT3)
25953 DQQT=DGGT+DVVT*DCMPLX(TANT3**2)-DGVT*DCMPLX(2D0*TANT3)
25954 DQQU=DGGU+DVVU*DCMPLX(TANT3**2)-DGVU*DCMPLX(2D0*TANT3)
25955 DQTS=DGGS-DVVS-DGVS*DCMPLX(TANT3-1D0/TANT3)
25956 DQGS=DGGS-DGVS*DCMPLX(TANT3)
25957 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
25958 ELSE
25959 DQQS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
25960 DQQT=DGGT+DVVT*DCMPLX(1D0/TANT3**2)+DGVT*DCMPLX(2D0/TANT3)
25961 DQQU=DGGU+DVVU*DCMPLX(1D0/TANT3**2)+DGVU*DCMPLX(2D0/TANT3)
25962 DQTS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
25963 DQGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
25964 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
25965 ENDIF
25966
25967 SQDQTS=ABS(DQTS)**2
25968 SQDQQS=ABS(DQQS)**2
25969 SQDQQT=ABS(DQQT)**2
25970 SQDQQU=ABS(DQQU)**2
25971 SQDLGS=ABS(DCMPLX(SH)*DQGS-DCMPLX(1D0))**2
25972 REDLGS=DBLE(DQGS)
25973 SQDHGS=ABS(DCMPLX(SH)*DTGS-DCMPLX(1D0))**2
25974 REDHGS=DBLE(DTGS)
25975 SQDLGT=ABS(DCMPLX(TH)*DGGT-DCMPLX(1D0))**2
25976
25977 SQDGGS=ABS(DGGS)**2
25978 SQDGGT=ABS(DGGT)**2
25979 SQDGGU=ABS(DGGU)**2
25980 REDGGS=DBLE(DGGS)
25981 REDGGT=DBLE(DGGT)
25982 REDGGU=DBLE(DGGU)
25983 REDGTU=DBLE(DGGU*DCONJG(DGGT))
25984 REDGSU=DBLE(DGGU*DCONJG(DGGS))
25985 REDGST=DBLE(DGGS*DCONJG(DGGT))
25986 REDQST=DBLE(DQQS*DCONJG(DQQT))
25987 REDQTU=DBLE(DQQT*DCONJG(DQQU))
25988 ENDIF
25989 ENDIF
25990
25991
25992C...Differential cross section expressions.
25993
25994 IF(ISUB.LE.190) THEN
25995 IF(ISUB.EQ.149) THEN
25996C...g + g -> eta_tc
25997 KCTC=PYCOMP(KTECHN+331)
25998 CALL PYWIDT(KTECHN+331,SH,WDTP,WDTE)
25999 HS=SHR*WDTP(0)
26000 FACBW=COMFAC*0.5D0/((SH-PMAS(KCTC,1)**2)**2+HS**2)
26001 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
26002 HP=SH
26003 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 250
26004 HI=HP*WDTP(3)
26005 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26006 NCHN=NCHN+1
26007 ISIG(NCHN,1)=21
26008 ISIG(NCHN,2)=21
26009 ISIG(NCHN,3)=1
26010 SIGH(NCHN)=HI*FACBW*HF
26011 250 CONTINUE
26012
26013 ELSEIF(ISUB.EQ.165) THEN
26014C...q + qbar -> l+ + l- (including contact term for compositeness)
26015 ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26016 ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26017 KFF=IABS(KFPR(ISUB,1))
26018 EF=KCHG(KFF,1)/3D0
26019 AF=SIGN(1D0,EF+0.1D0)
26020 VF=AF-4D0*EF*XWV
26021 VALF=VF+AF
26022 VARF=VF-AF
26023 FCOF=1D0
26024 IF(KFF.LE.10) FCOF=3D0
26025 WID2=1D0
26026 IF(KFF.EQ.6) WID2=WIDS(6,1)
26027 IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1)
26028 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
26029 DO 260 I=MMINA,MMAXA
26030 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 260
26031 EI=KCHG(IABS(I),1)/3D0
26032 AI=SIGN(1D0,EI+0.1D0)
26033 VI=AI-4D0*EI*XWV
26034 VALI=VI+AI
26035 VARI=VI-AI
26036 FCOI=1D0
26037 IF(IABS(I).LE.10) FCOI=FACA/3D0
26038 IF((ITCM(5).EQ.1.AND.IABS(I).LE.2).OR.ITCM(5).EQ.2) THEN
26039 FGZA=(EI*EF+VALI*VALF*ZRATR+RTCM(42)*SH/
26040 & (AEM*RTCM(41)**2))**2+(VALI*VALF*ZRATI)**2+
26041 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
26042 ELSE
26043 FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+
26044 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
26045 ENDIF
26046 FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+
26047 & (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2
26048 FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2)
26049 IF((ITCM(5).EQ.3.AND.IABS(I).EQ.2).OR.(ITCM(5).EQ.4.AND.
26050 & MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*RTCM(41)**4)
26051 NCHN=NCHN+1
26052 ISIG(NCHN,1)=I
26053 ISIG(NCHN,2)=-I
26054 ISIG(NCHN,3)=1
26055 SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2
26056 260 CONTINUE
26057
26058 ELSEIF(ISUB.EQ.166) THEN
26059C...q + q'bar -> l + nu_l (including contact term for compositeness)
26060 WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2)
26061 WCIFAC=WFAC+SH2/(4D0*RTCM(41)**4)
26062 KFF=IABS(KFPR(ISUB,1))
26063 FCOF=1D0
26064 IF(KFF.LE.10) FCOF=3D0
26065 DO 280 I=MMIN1,MMAX1
26066 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 280
26067 IA=IABS(I)
26068 DO 270 J=MMIN2,MMAX2
26069 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 270
26070 JA=IABS(J)
26071 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 270
26072 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
26073 & GOTO 270
26074 FCOI=1D0
26075 IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
26076 WID2=1D0
26077 IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND.
26078 & MOD(J,2).EQ.0)) THEN
26079 IF(KFF.EQ.5) WID2=WIDS(6,2)
26080 IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3)
26081 IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3)
26082 ELSE
26083 IF(KFF.EQ.5) WID2=WIDS(6,3)
26084 IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2)
26085 IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2)
26086 ENDIF
26087 NCHN=NCHN+1
26088 ISIG(NCHN,1)=I
26089 ISIG(NCHN,2)=J
26090 ISIG(NCHN,3)=1
26091 SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2
26092 IF((ITCM(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.ITCM(5).EQ.4)
26093 & SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2
26094 270 CONTINUE
26095 280 CONTINUE
26096 ENDIF
26097
26098 ELSEIF(ISUB.LE.200) THEN
26099 IF(ISUB.EQ.191) THEN
26100C...q + qbar -> rho_tc0.
26101 KCTC=PYCOMP(KTECHN+113)
26102 SQMRHT=PMAS(KCTC,1)**2
26103 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
26104 HS=SHR*WDTP(0)
26105 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
26106 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
26107 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26108 ALPRHT=2.91D0*(3D0/ITCM(1))
26109 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)
26110 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
26111 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26112 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26113 DO 290 I=MMINA,MMAXA
26114 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 290
26115 IA=IABS(I)
26116 EI=KCHG(IABS(I),1)/3D0
26117 AI=SIGN(1D0,EI+0.1D0)
26118 VI=AI-4D0*EI*XWV
26119 VALI=0.5D0*(VI+AI)
26120 VARI=0.5D0*(VI-AI)
26121 HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
26122 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
26123 IF(IA.LE.10) HI=HI*FACA/3D0
26124 NCHN=NCHN+1
26125 ISIG(NCHN,1)=I
26126 ISIG(NCHN,2)=-I
26127 ISIG(NCHN,3)=1
26128 SIGH(NCHN)=HI*FACBW*HF
26129 290 CONTINUE
26130
26131 ELSEIF(ISUB.EQ.192) THEN
26132C...q + qbar' -> rho_tc+/-.
26133 KCTC=PYCOMP(KTECHN+213)
26134 SQMRHT=PMAS(KCTC,1)**2
26135 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
26136 HS=SHR*WDTP(0)
26137 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
26138 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
26139 ALPRHT=2.91D0*(3D0/ITCM(1))
26140 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)*
26141 & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
26142 DO 310 I=MMIN1,MMAX1
26143 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 310
26144 IA=IABS(I)
26145 DO 300 J=MMIN2,MMAX2
26146 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 300
26147 JA=IABS(J)
26148 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 300
26149 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
26150 & GOTO 300
26151 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
26152 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4))
26153 HI=HP
26154 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
26155 NCHN=NCHN+1
26156 ISIG(NCHN,1)=I
26157 ISIG(NCHN,2)=J
26158 ISIG(NCHN,3)=1
26159 SIGH(NCHN)=HI*FACBW*HF
26160 300 CONTINUE
26161 310 CONTINUE
26162
26163 ELSEIF(ISUB.EQ.193) THEN
26164C...q + qbar -> omega_tc0.
26165 KCTC=PYCOMP(KTECHN+223)
26166 SQMOMT=PMAS(KCTC,1)**2
26167 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
26168 HS=SHR*WDTP(0)
26169 FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2)
26170 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
26171 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26172 ALPRHT=2.91D0*(3D0/ITCM(1))
26173 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)*
26174 & (2D0*RTCM(2)-1D0)**2
26175 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26176 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26177 DO 320 I=MMINA,MMAXA
26178 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
26179 IA=IABS(I)
26180 EI=KCHG(IABS(I),1)/3D0
26181 AI=SIGN(1D0,EI+0.1D0)
26182 VI=AI-4D0*EI*XWV
26183 VALI=0.5D0*(VI+AI)
26184 VARI=0.5D0*(VI-AI)
26185 HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
26186 & (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
26187 IF(IA.LE.10) HI=HI*FACA/3D0
26188 NCHN=NCHN+1
26189 ISIG(NCHN,1)=I
26190 ISIG(NCHN,2)=-I
26191 ISIG(NCHN,3)=1
26192 SIGH(NCHN)=HI*FACBW*HF
26193 320 CONTINUE
26194
26195 ELSEIF(ISUB.EQ.194) THEN
26196C...f + fbar -> f' + fbar' via s-channel rho_tc and omega_tc.
26197 KFA=KFPR(ISUBSV,1)
26198 ALPRHT=2.91D0*(3D0/ITCM(1))
26199 HP=AEM**2*COMFAC
26200 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
26201 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
26202
26203 QUPD=2D0*RTCM(2)-1D0
26204 FAR=SQRT(AEM/ALPRHT)
26205 FAO=FAR*QUPD
26206 FZR=FAR*CT2W
26207 FZO=-FAO*TANW
26208 SFAR=FAR**2
26209 SFAO=FAO**2
26210 SFZR=FZR**2
26211 SFZO=FZO**2
26212 CALL PYWIDT(23,SH,WDTP,WDTE)
26213 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
26214 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
26215 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
26216 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
26217 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
26218 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
26219 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
26220 DAA=(-Sfzr*SSMO - Sfzo*SSMR + SSMO*SSMR*SSMZ)/DETD/SH
26221 DZZ=(-Sfar*SSMO - Sfao*SSMR + SSMO*SSMR)/DETD/SH
26222 DAZ=(far*fzr*SSMO + fao*fzo*SSMR)/DETD/SH
26223
26224 XWRHT=1D0/(4D0*XW*(1D0-XW))
26225 KFF=IABS(KFPR(ISUB,1))
26226 EF=KCHG(KFF,1)/3D0
26227 AF=SIGN(1D0,EF+0.1D0)
26228 VF=AF-4D0*EF*XWV
26229 VALF=0.5D0*(VF+AF)
26230 VARF=0.5D0*(VF-AF)
26231 FCOF=1D0
26232 IF(KFF.LE.10) FCOF=3D0
26233
26234 WID2=1D0
26235 IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1)
26236 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
26237 DZZ=DZZ*DCMPLX(XWRHT,0D0)
26238 DAZ=DAZ*DCMPLX(SQRT(XWRHT),0D0)
26239
26240 DO 330 I=MMINA,MMAXA
26241 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 330
26242 EI=KCHG(IABS(I),1)/3D0
26243 AI=SIGN(1D0,EI+0.1D0)
26244 VI=AI-4D0*EI*XWV
26245 VALI=0.5D0*(VI+AI)
26246 VARI=0.5D0*(VI-AI)
26247 FCOI=FCOF
26248 IF(IABS(I).LE.10) FCOI=FCOI/3D0
26249 DIFLL=ABS(EI*EF*DAA+VALI*VALF*DZZ+DAZ*(EI*VALF+EF*VALI))**2
26250 DIFRR=ABS(EI*EF*DAA+VARI*VARF*DZZ+DAZ*(EI*VARF+EF*VARI))**2
26251 DIFLR=ABS(EI*EF*DAA+VALI*VARF*DZZ+DAZ*(EI*VARF+EF*VALI))**2
26252 DIFRL=ABS(EI*EF*DAA+VARI*VALF*DZZ+DAZ*(EI*VALF+EF*VARI))**2
26253 FACSIG=(DIFLL+DIFRR)*((UH-SQM4)**2+SH*SQM4)+
26254 & (DIFLR+DIFRL)*((TH-SQM3)**2+SH*SQM3)
26255 NCHN=NCHN+1
26256 ISIG(NCHN,1)=I
26257 ISIG(NCHN,2)=-I
26258 ISIG(NCHN,3)=1
26259 SIGH(NCHN)=HP*FCOI*FACSIG*WID2
26260 330 CONTINUE
26261
26262 ELSEIF(ISUB.EQ.195) THEN
26263C...f + fbar' -> f'' + fbar''' via s-channel rho_tc+
26264 KFA=KFPR(ISUBSV,1)
26265 KFB=KFA+1
26266 ALPRHT=2.91D0*(3D0/ITCM(1))
26267 FACTC=COMFAC*(AEM**2/12D0/XW**2)*(UH-SQM3)*(UH-SQM4)*3D0
26268
26269 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
26270 CALL PYWIDT(24,SH,WDTP,WDTE)
26271 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
26272 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
26273 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
26274
26275 FCOF=1D0
26276 IF(KFA.LE.8) FCOF=3D0
26277 DETD=SSMZ*SSMR-DCMPLX(FWR**2,0D0)
26278 HP=FACTC*ABS(SSMR/DETD)**2/SH**2*FCOF
26279
26280 DO 350 I=MMIN1,MMAX1
26281 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 350
26282 IA=IABS(I)
26283 DO 340 J=MMIN2,MMAX2
26284 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 340
26285 JA=IABS(J)
26286 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 340
26287 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
26288 & GOTO 340
26289 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
26290 HI=HP
26291 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
26292 NCHN=NCHN+1
26293 ISIG(NCHN,1)=I
26294 ISIG(NCHN,2)=J
26295 ISIG(NCHN,3)=1
26296 SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,(5+KCHR)/2)
26297 340 CONTINUE
26298 350 CONTINUE
26299 ENDIF
26300
26301 ELSEIF(ISUB.LE.380) THEN
26302 IF(ISUB.EQ.361) THEN
26303C...f + fbar -> W_L W_L, W_L pi_tc, pi_tc pi_tc
26304 FACA=(SH**2*BE34**2-(TH-UH)**2)
26305 ALPRHT=2.91D0*(3D0/ITCM(1))
26306 HP=(1D0/12D0)*AEM**2*CAB2*COMFAC*FACA*3D0
26307 FAR=SQRT(AEM/ALPRHT)
26308 FAO=FAR*QUPD
26309 FZR=FAR*CT2W
26310 FZO=-FAO*TANW
26311 SFAR=FAR**2
26312 SFAO=FAO**2
26313 SFZR=FZR**2
26314 SFZO=FZO**2
26315 CALL PYWIDT(23,SH,WDTP,WDTE)
26316 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
26317 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
26318 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
26319 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
26320 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
26321 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
26322 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
26323 DARHO=-(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)/DETD/SH
26324 DZRHO=-(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH
26325 DAA=-(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)/DETD/SH
26326 DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH
26327 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH
26328
26329 DO 360 I=MMINA,MMAXA
26330 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 360
26331 IA=IABS(I)
26332 EI=KCHG(IABS(I),1)/3D0
26333 AI=SIGN(1D0,EI+0.1D0)
26334 VI=AI-4D0*EI*XWV
26335 VALI=0.25D0*(VI+AI)
26336 VARI=0.25D0*(VI-AI)
26337 F2L=EI*(DARHO/FAR+DAA+CT2W*DAZ)+
26338 $ VALI*(CT2W*DZRHO/FZR+CT2W*DZZ+DAZ)/SQRT(XW*XW1)
26339 F2R=EI*(DARHO/FAR+DAA+CT2W*DAZ)+
26340 $ VARI*(CT2W*DZRHO/FZR+CT2W*DZZ+DAZ)/SQRT(XW*XW1)
26341 HI=ABS(F2L)**2+ABS(F2R)**2
26342 IF(IA.LE.10) HI=HI/3D0
26343 NCHN=NCHN+1
26344 ISIG(NCHN,1)=I
26345 ISIG(NCHN,2)=-I
26346 ISIG(NCHN,3)=1
26347 IF(KFA.EQ.KFB) THEN
26348 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),1)
26349 ELSE
26350 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
26351 NCHN=NCHN+1
26352 ISIG(NCHN,1)=I
26353 ISIG(NCHN,2)=-I
26354 ISIG(NCHN,3)=2
26355 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
26356 ENDIF
26357 360 CONTINUE
26358
26359 ELSEIF(ISUB.EQ.364) THEN
26360C...f + fbar -> gamma pi_tc, gamma pi_tc', Z pi_tc, Z pi_tc',
26361C...W pi_tc
26362 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
26363 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
26364 FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
26365
26366 ALPRHT=2.91D0*(3D0/ITCM(1))
26367 HP=(1D0/24D0)*AEM**2*COMFAC*3D0*SH
26368 FAR=SQRT(AEM/ALPRHT)
26369 FAO=FAR*QUPD
26370 FZR=FAR*CT2W
26371 FZO=-FAO*TANW
26372 SFAR=FAR**2
26373 SFAO=FAO**2
26374 SFZR=FZR**2
26375 SFZO=FZO**2
26376 CALL PYWIDT(23,SH,WDTP,WDTE)
26377 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
26378 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
26379 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
26380 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
26381 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
26382 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
26383 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
26384 DARHO=(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)/DETD/SH
26385 DZRHO=(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH
26386 DAOME=(-FAO*SFZR+FAR*FZO*FZR+FAO*SSMR*SSMZ)/DETD/SH
26387 DZOME=(-FZO*SFAR+FAR*FAO*FZR+FZO*SSMR)/DETD/SH
26388 DAA=(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)/DETD/SH
26389 DZZ=(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH
26390 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH
26391
26392 DO 370 I=MMINA,MMAXA
26393 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 370
26394 IA=IABS(I)
26395 EI=KCHG(IABS(I),1)/3D0
26396 AI=SIGN(1D0,EI+0.1D0)
26397 VI=AI-4D0*EI*XWV
26398 VALI=0.25D0*(VI+AI)
26399 VARI=0.25D0*(VI-AI)
26400C...........Add in anomaly contribution
26401 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*VRGP
26402 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*VOGP
26403 F2L=F2L+FANOM*(VAGP*(EI*DAA+VALI*DAZ/SQRT(XW*XW1))+
26404 $ VZGP*(EI*DAZ+VALI*DZZ/SQRT(XW*XW1)))
26405 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*VRGP
26406 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*VOGP
26407 F2R=F2R+FANOM*(VAGP*(EI*DAA+VARI*DAZ/SQRT(XW*XW1))+
26408 $ VZGP*(EI*DAZ+VARI*DZZ/SQRT(XW*XW1)))
26409 HI=(ABS(F2L)**2+ABS(F2R)**2)*VFAC
26410 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*ARGP
26411 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*AOGP
26412 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*ARGP
26413 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*AOGP
26414 HJ=(ABS(F2L)**2+ABS(F2R)**2)*AFAC
26415 HI=HI+HJ
26416 IF(IA.LE.10) HI=HI/3D0
26417 NCHN=NCHN+1
26418 ISIG(NCHN,1)=I
26419 ISIG(NCHN,2)=-I
26420 ISIG(NCHN,3)=1
26421 IF(ISUBSV.NE.368) THEN
26422 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),2)
26423 ELSE
26424 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
26425 NCHN=NCHN+1
26426 ISIG(NCHN,1)=I
26427 ISIG(NCHN,2)=-I
26428 ISIG(NCHN,3)=2
26429 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
26430 ENDIF
26431 370 CONTINUE
26432
26433 ELSEIF(ISUB.EQ.370) THEN
26434C...f + fbar' -> W_L Z_L, W_L pi_tc, Z_L pi_tc, pi_tc pi_tc
26435
26436 FACA=(SH**2*BE34**2-(TH-UH)**2)
26437 ALPRHT=2.91D0*(3D0/ITCM(1))
26438 HP=(1D0/96D0)*AEM**2*CAB2*COMFAC*FACA*3D0/XW**2
26439 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
26440 CALL PYWIDT(24,SH,WDTP,WDTE)
26441 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
26442 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
26443 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
26444 DETD=SSMZ*SSMR-DCMPLX(FWR**2,0D0)
26445 DWW=SSMR/DETD/SH
26446 DWRHO=-1D0/DETD/SH
26447 HP=HP*ABS(DWW+DWRHO)**2
26448 DO 390 I=MMIN1,MMAX1
26449 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 390
26450 IA=IABS(I)
26451 DO 380 J=MMIN2,MMAX2
26452 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 380
26453 JA=IABS(J)
26454 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 380
26455 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
26456 & GOTO 380
26457 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
26458 HI=HP
26459 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
26460 NCHN=NCHN+1
26461 ISIG(NCHN,1)=I
26462 ISIG(NCHN,2)=J
26463 ISIG(NCHN,3)=1
26464 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
26465 & WIDS(PYCOMP(KFB),2)
26466 380 CONTINUE
26467 390 CONTINUE
26468
26469 ELSEIF(ISUB.EQ.374) THEN
26470C...f + fbar' -> gamma pi_tc
26471 FANOM=SQRT(AEM)*ITCM(1)/2D0/PARU(2)/RTCM(1)
26472 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
26473 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)/SQTA*ARGP**2
26474 ALPRHT=2.91D0*(3D0/ITCM(1))
26475 HP=(1D0/48D0)*AEM**2/XW*COMFAC*3D0*SH
26476 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
26477 CALL PYWIDT(24,SH,WDTP,WDTE)
26478 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
26479 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
26480 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
26481 DETD=SSMZ*SSMR-DCMPLX(FWR**2,0D0)
26482 DWW=SSMR/DETD/SH
26483 DWRHO=-DCMPLX(FWR,0D0)/DETD/SH
26484 HP=HP*(AFAC*ABS(DWRHO)**2+
26485 $ VFAC*ABS(FANOM*DWW*VWGP+DWRHO*VRGP/SQRT(SQTV))**2)
26486 DO 410 I=MMIN1,MMAX1
26487 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410
26488 IA=IABS(I)
26489 DO 400 J=MMIN2,MMAX2
26490 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 400
26491 JA=IABS(J)
26492 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 400
26493 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
26494 & GOTO 400
26495 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
26496 HI=HP
26497 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
26498 NCHN=NCHN+1
26499 ISIG(NCHN,1)=I
26500 ISIG(NCHN,2)=J
26501 ISIG(NCHN,3)=1
26502 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
26503 & WIDS(PYCOMP(KFB),2)
26504 400 CONTINUE
26505 410 CONTINUE
26506 ENDIF
26507
26508 ELSEIF(ISUB.LE.390) THEN
26509 IF(ISUB.EQ.381) THEN
26510C...f + f' -> f + f' (g exchange)
26511 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)*SQDQQT
26512 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)*SQDQQT*FACA-
26513 & MSTP(34)*2D0/3D0*UH2*REDQST)
26514 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)*SQDQQU
26515 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
26516 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
26517 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
26518C...Modifications from contact interactions (compositeness)
26519 FACCI1=FACQQ1+COMFAC*(SH2/RTCM(41)**4)
26520 FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
26521 & (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/RTCM(41)**4)
26522 FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
26523 & (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/RTCM(41)**4)
26524 FACCI3=FACQQ1+COMFAC*(UH2/RTCM(41)**4)
26525 RATCII=(FACCI1*FACCI2+FACQQI)/(FACCI1+FACCI2)
26526 ELSEIF(ITCM(5).EQ.5) THEN
26527 FACCI1=FACQQ1
26528 FACCIB=FACQQB
26529 FACCI2=FACQQ2
26530 FACCI3=FACQQ1
26531CSM.......Check this change from
26532CSM RATCII=1D0
26533 RATCII=RATQQI
26534 ENDIF
26535 DO 430 I=MMIN1,MMAX1
26536 IA=IABS(I)
26537 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
26538 DO 420 J=MMIN2,MMAX2
26539 JA=IABS(J)
26540 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
26541 NCHN=NCHN+1
26542 ISIG(NCHN,1)=I
26543 ISIG(NCHN,2)=J
26544 ISIG(NCHN,3)=1
26545 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.(IA.GE.3.OR.
26546 & JA.GE.3))) THEN
26547 SIGH(NCHN)=FACQQ1
26548 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
26549 ELSE
26550 SIGH(NCHN)=FACCI1
26551 IF(I*J.LT.0) SIGH(NCHN)=FACCI3
26552 IF(I.EQ.-J) SIGH(NCHN)=FACCIB
26553 ENDIF
26554 IF(I.EQ.J) THEN
26555 NCHN=NCHN+1
26556 ISIG(NCHN,1)=I
26557 ISIG(NCHN,2)=J
26558 ISIG(NCHN,3)=2
26559 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IA.GE.3)) THEN
26560 SIGH(NCHN-1)=0.5D0*FACQQ1*RATQQI
26561 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
26562 ELSE
26563 SIGH(NCHN-1)=0.5D0*FACCI1*RATCII
26564 SIGH(NCHN)=0.5D0*FACCI2*RATCII
26565 ENDIF
26566 ENDIF
26567 420 CONTINUE
26568 430 CONTINUE
26569
26570 ELSEIF(ISUB.EQ.382) THEN
26571C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
26572 CALL PYWIDT(21,SH,WDTP,WDTE)
26573 FACQQF=COMFAC*AS**2*4D0/9D0*(TH2+UH2)
26574 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26575 IF(ITCM(5).EQ.1) THEN
26576C...Modifications from contact interactions (compositeness)
26577 FACCIB=FACQQB
26578 DO 440 I=1,2
26579 FACCIB=FACCIB+COMFAC*(UH2/RTCM(41)**4)*(WDTE(I,1)+
26580 & WDTE(I,2)+WDTE(I,4))
26581 440 CONTINUE
26582 ELSEIF(ITCM(5).GE.2.AND.ITCM(5).LE.4) THEN
26583 FACCIB=FACQQB+COMFAC*(UH2/RTCM(41)**4)*
26584 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26585 ELSEIF(ITCM(5).EQ.5) THEN
26586 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)-
26587 & WDTE(5,1)-WDTE(5,2)-WDTE(5,4))
26588 FACCIB=FACQQF*SQDQTS*(WDTE(5,1)+WDTE(5,2)+WDTE(5,4))
26589 ENDIF
26590 DO 450 I=MMINA,MMAXA
26591 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
26592 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 450
26593 NCHN=NCHN+1
26594 ISIG(NCHN,1)=I
26595 ISIG(NCHN,2)=-I
26596 ISIG(NCHN,3)=1
26597 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IABS(I).GE.3)) THEN
26598 SIGH(NCHN)=FACQQB
26599 ELSEIF(ITCM(5).EQ.5) THEN
26600 SIGH(NCHN)=FACQQB
26601 NCHN=NCHN+1
26602 ISIG(NCHN,1)=I
26603 ISIG(NCHN,2)=-I
26604 ISIG(NCHN,3)=2
26605 SIGH(NCHN)=FACCIB
26606 ELSE
26607 SIGH(NCHN)=FACCIB
26608 ENDIF
26609 450 CONTINUE
26610
26611 ELSEIF(ISUB.EQ.383) THEN
26612C...f + fbar -> g + g (q + qbar -> g + g only)
26613 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
26614 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
26615 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
26616 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
26617 IF(ITCM(5).EQ.5) THEN
26618 FACGG3=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
26619 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
26620 FACGG4=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
26621 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
26622 ENDIF
26623 DO 460 I=MMINA,MMAXA
26624 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
26625 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
26626 NCHN=NCHN+1
26627 ISIG(NCHN,1)=I
26628 ISIG(NCHN,2)=-I
26629 ISIG(NCHN,3)=1
26630 SIGH(NCHN)=0.5D0*FACGG1
26631 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG3
26632 NCHN=NCHN+1
26633 ISIG(NCHN,1)=I
26634 ISIG(NCHN,2)=-I
26635 ISIG(NCHN,3)=2
26636 SIGH(NCHN)=0.5D0*FACGG2
26637 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG4
26638 460 CONTINUE
26639
26640 ELSEIF(ISUB.EQ.384) THEN
26641C...f + g -> f + g (q + g -> q + g only)
26642 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
26643 & UH/SH-9D0/4D0*SH*UH/TH2*SQDLGT)*FACA
26644 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
26645 & SH/UH-9D0/4D0*SH*UH/TH2*SQDLGT)
26646 DO 480 I=MMINA,MMAXA
26647 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 480
26648 DO 470 ISDE=1,2
26649 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 470
26650 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 470
26651 NCHN=NCHN+1
26652 ISIG(NCHN,ISDE)=I
26653 ISIG(NCHN,3-ISDE)=21
26654 ISIG(NCHN,3)=1
26655 SIGH(NCHN)=FACQG1
26656 NCHN=NCHN+1
26657 ISIG(NCHN,ISDE)=I
26658 ISIG(NCHN,3-ISDE)=21
26659 ISIG(NCHN,3)=2
26660 SIGH(NCHN)=FACQG2
26661 470 CONTINUE
26662 480 CONTINUE
26663
26664 ELSEIF(ISUB.EQ.385) THEN
26665C...g + g -> f + fbar (g + g -> q + qbar only)
26666 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 500
26667 IDC0=MDCY(21,2)-1
26668C...Begin by d, u, s flavours.
26669 FLAVWT=0D0
26670 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
26671 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
26672 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
26673 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
26674 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
26675 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
26676 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
26677 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
26678 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
26679 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
26680 NCHN=NCHN+1
26681 ISIG(NCHN,1)=21
26682 ISIG(NCHN,2)=21
26683 ISIG(NCHN,3)=1
26684 SIGH(NCHN)=FACQQ1
26685 NCHN=NCHN+1
26686 ISIG(NCHN,1)=21
26687 ISIG(NCHN,2)=21
26688 ISIG(NCHN,3)=2
26689 SIGH(NCHN)=FACQQ2
26690C...Next c and b flavours: modified that and uhat for fixed
26691C...cos(theta-hat).
26692 DO 490 IFL=4,5
26693 SQMAVG=PMAS(IFL,1)**2
26694 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
26695 BE34=SQRT(1D0-4D0*SQMAVG/SH)
26696 THQ=-0.5D0*SH*(1D0-BE34*CTH)
26697 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
26698 THUHQ=THQ*UHQ-SQMAVG*SH
26699 IF(MSTP(34).EQ.0) THEN
26700 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
26701 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
26702 ELSE
26703 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
26704 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
26705 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
26706 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
26707 ENDIF
26708 IF(ITCM(5).GE.5) THEN
26709 IF(IFL.EQ.4) THEN
26710 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
26711 & 2.25D0*THQ*UHQ/SH2*SQDLGS
26712 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
26713 & 2.25D0*THQ*UHQ/SH2*SQDLGS
26714 ELSE
26715 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
26716 & 2.25D0*THQ*UHQ/SH2*SQDHGS
26717 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
26718 & 2.25D0*THQ*UHQ/SH2*SQDHGS
26719 ENDIF
26720 ENDIF
26721 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
26722 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
26723 NCHN=NCHN+1
26724 ISIG(NCHN,1)=21
26725 ISIG(NCHN,2)=21
26726 ISIG(NCHN,3)=1+2*(IFL-3)
26727 SIGH(NCHN)=FACQQ1
26728 NCHN=NCHN+1
26729 ISIG(NCHN,1)=21
26730 ISIG(NCHN,2)=21
26731 ISIG(NCHN,3)=2+2*(IFL-3)
26732 SIGH(NCHN)=FACQQ2
26733 ENDIF
26734 490 CONTINUE
26735 500 CONTINUE
26736
26737 ELSEIF(ISUB.EQ.386) THEN
26738C...g + g -> g + g
26739 IF(ITCM(5).LE.4) THEN
26740 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
26741 & 2D0*TH/SH+TH2/SH2)*FACA
26742 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
26743 & 2D0*SH/UH+SH2/UH2)*FACA
26744 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+
26745 & 2D0*UH/TH+UH2/TH2)
26746 ELSE
26747 GST= (12D0 + 40D0*TH/SH + 56D0*TH2/SH2 + 32D0*TH**3/SH**3 +
26748 & 16D0*TH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*TH + 16D0*TH2)+
26749 & 4D0*REDGST*(SH + 2D0*TH)*
26750 & (2D0*SH**3 - 3D0*SH2*TH - 2D0*SH*TH2 + 2D0*TH**3)/SH2 +
26751 & 2D0*REDGGS*(2D0*SH - 12D0*TH2/SH - 8D0*TH**3/SH2) +
26752 & 2D0*REDGGT*(4D0*SH - 22D0*TH - 68D0*TH2/SH - 60D0*TH**3/SH2-
26753 & 32D0*TH**4/SH**3 - 16D0*TH**5/SH**4) +
26754 & SQDGGT*(16D0*SH2 + 16D0*SH*TH + 68D0*TH2 + 144D0*TH**3/SH +
26755 & 96D0*TH**4/SH2 + 32D0*TH**5/SH**3 + 16D0*TH**6/SH**4))/16D0
26756 GSU= (12D0 + 40D0*UH/SH + 56D0*UH2/SH2 + 32D0*UH**3/SH**3 +
26757 & 16D0*UH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*UH + 16D0*UH2)+
26758 & 4D0*REDGSU*(SH + 2D0*UH)*
26759 & (2D0*SH**3 - 3D0*SH2*UH - 2D0*SH*UH2 + 2D0*UH**3)/SH2 +
26760 & 2D0*REDGGS*(2D0*SH - 12D0*UH2/SH - 8D0*UH**3/SH2) +
26761 & 2D0*REDGGU*(4D0*SH - 22D0*UH - 68D0*UH2/SH - 60D0*UH**3/SH2-
26762 & 32D0*UH**4/SH**3 - 16D0*UH**5/SH**4) +
26763 & SQDGGU*(16D0*SH2 + 16D0*SH*UH + 68D0*UH2 + 144D0*UH**3/SH +
26764 & 96D0*UH**4/SH2 + 32D0*UH**5/SH**3 + 16D0*UH**6/SH**4))/16D0
26765 GUT= (12D0 - 16D0*TH*(TH - UH)**2*UH/SH**4 +
26766 & 4D0*REDGGU*(2D0*TH**5 - 15D0*TH**4*UH - 48D0*TH**3*UH2 -
26767 & 58D0*TH2*UH**3 - 10D0*TH*UH**4 + UH**5)/SH**4 +
26768 & 4D0*REDGGT*(TH**5 - 10D0*TH**4*UH - 58D0*TH**3*UH2 -
26769 & 48D0*TH2*UH**3 - 15D0*TH*UH**4 + 2D0*UH**5)/SH**4 +
26770 & 4D0*SQDGGU*(4D0*TH**6 + 20D0*TH**5*UH + 57D0*TH**4*UH2 +
26771 & 72D0*TH**3*UH**3+ 38D0*TH2*UH**4+4D0*TH*UH**5 +UH**6)/SH**4+
26772 & 4D0*SQDGGT*(4D0*UH**6 + 4D0*TH**5*UH + 38D0*TH**4*UH2 +
26773 & 72D0*TH**3*UH**3 +57D0*TH2*UH**4+20D0*TH*UH**5+TH**6)/SH**4+
26774 & 2D0*REDGTU*((TH - UH)**2* (TH**4 + 20D0*TH**3*UH +
26775 & 30D0*TH2*UH2 + 20D0*TH*UH**3 + UH**4) +
26776 & SH2*(7D0*TH**4 + 52D0*TH**3*UH + 274D0*TH2*UH2 +
26777 & 52D0*TH*UH**3 + 7D0*UH**4))/(2D0*SH**4))/16D0
26778 FACGG1=COMFAC*AS**2*9D0/4D0*GST*FACA
26779 FACGG2=COMFAC*AS**2*9D0/4D0*GSU*FACA
26780 FACGG3=COMFAC*AS**2*9D0/4D0*GUT
26781 ENDIF
26782 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 510
26783 NCHN=NCHN+1
26784 ISIG(NCHN,1)=21
26785 ISIG(NCHN,2)=21
26786 ISIG(NCHN,3)=1
26787 SIGH(NCHN)=0.5D0*FACGG1
26788 NCHN=NCHN+1
26789 ISIG(NCHN,1)=21
26790 ISIG(NCHN,2)=21
26791 ISIG(NCHN,3)=2
26792 SIGH(NCHN)=0.5D0*FACGG2
26793 NCHN=NCHN+1
26794 ISIG(NCHN,1)=21
26795 ISIG(NCHN,2)=21
26796 ISIG(NCHN,3)=3
26797 SIGH(NCHN)=0.5D0*FACGG3
26798 510 CONTINUE
26799
26800 ELSEIF(ISUB.EQ.387) THEN
26801C...q + qbar -> Q + Qbar
26802 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
26803 THQ=-0.5D0*SH*(1D0-BE34*CTH)
26804 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
26805 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
26806 & 2D0*SQMAVG/SH)
26807 IF(ITCM(5).GE.5) THEN
26808 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
26809 FACQQB=FACQQB*SH2*SQDQTS
26810 ELSE
26811 FACQQB=FACQQB*SH2*SQDQQS
26812 ENDIF
26813 ENDIF
26814 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
26815 WID2=1D0
26816 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
26817 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
26818 FACQQB=FACQQB*WID2
26819 DO 520 I=MMINA,MMAXA
26820 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
26821 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 520
26822 NCHN=NCHN+1
26823 ISIG(NCHN,1)=I
26824 ISIG(NCHN,2)=-I
26825 ISIG(NCHN,3)=1
26826 SIGH(NCHN)=FACQQB
26827 520 CONTINUE
26828
26829 ELSEIF(ISUB.EQ.388) THEN
26830C...g + g -> Q + Qbar
26831 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
26832 THQ=-0.5D0*SH*(1D0-BE34*CTH)
26833 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
26834 THUHQ=THQ*UHQ-SQMAVG*SH
26835 IF(MSTP(34).EQ.0) THEN
26836 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
26837 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
26838 ELSE
26839 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
26840 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
26841 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
26842 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
26843 ENDIF
26844 IF(ITCM(5).GE.5) THEN
26845 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
26846 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
26847 & 2.25D0*THQ*UHQ/SH2*SQDHGS
26848 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
26849 & 2.25D0*THQ*UHQ/SH2*SQDHGS
26850 ELSE
26851 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
26852 & 2.25D0*THQ*UHQ/SH2*SQDLGS
26853 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
26854 & 2.25D0*THQ*UHQ/SH2*SQDLGS
26855 ENDIF
26856 ENDIF
26857 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
26858 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
26859 IF(MSTP(35).GE.1) THEN
26860 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
26861 FACQQ1=FACQQ1*FATRE
26862 FACQQ2=FACQQ2*FATRE
26863 ENDIF
26864 WID2=1D0
26865 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
26866 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
26867 FACQQ1=FACQQ1*WID2
26868 FACQQ2=FACQQ2*WID2
26869 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 530
26870 NCHN=NCHN+1
26871 ISIG(NCHN,1)=21
26872 ISIG(NCHN,2)=21
26873 ISIG(NCHN,3)=1
26874 SIGH(NCHN)=FACQQ1
26875 NCHN=NCHN+1
26876 ISIG(NCHN,1)=21
26877 ISIG(NCHN,2)=21
26878 ISIG(NCHN,3)=2
26879 SIGH(NCHN)=FACQQ2
26880 530 CONTINUE
26881 ENDIF
26882 ENDIF
26883
26884CMRENNA--
26885
26886 RETURN
26887 END
26888
26889C*********************************************************************
26890
26891C...PYSGEX
26892C...Subprocess cross sections for assorted exotic processes,
26893C...including Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*.
26894C...Auxiliary to PYSIGH.
26895
26896 SUBROUTINE PYSGEX(NCHN,SIGS)
26897
26898C...Double precision and integer declarations
26899 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26900 IMPLICIT INTEGER(I-N)
26901 INTEGER PYK,PYCHGE,PYCOMP
26902C...Parameter statement to help give large particle numbers.
26903 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
26904 &KEXCIT=4000000,KDIMEN=5000000)
26905C...Commonblocks
26906 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
26907 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
26908 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
26909 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
26910 COMMON/PYINT1/MINT(400),VINT(400)
26911 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
26912 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
26913 COMMON/PYINT4/MWID(500),WIDS(500,5)
26914 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
26915 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
26916 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
26917 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
26918 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
26919 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
26920 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
26921C...Local arrays
26922 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
26923
26924C...Differential cross section expressions.
26925
26926 IF(ISUB.LE.160) THEN
26927 IF(ISUB.EQ.141) THEN
26928C...f + fbar -> gamma*/Z0/Z'0
26929 SQMZP=PMAS(32,1)**2
26930 MINT(61)=2
26931 CALL PYWIDT(32,SH,WDTP,WDTE)
26932 HP0=AEM/3D0*SH
26933 HP1=AEM/3D0*XWC*SH
26934 HP2=HP1
26935 HS=SHR*VINT(117)
26936 HSP=SHR*WDTP(0)
26937 FACZP=4D0*COMFAC*3D0
26938 DO 100 I=MMINA,MMAXA
26939 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
26940 EI=KCHG(IABS(I),1)/3D0
26941 AI=SIGN(1D0,EI)
26942 VI=AI-4D0*EI*XWV
26943 IA=IABS(I)
26944 IF(IA.LT.10) THEN
26945 IF(IA.LE.2) THEN
26946 VPI=PARU(123-2*MOD(IABS(I),2))
26947 API=PARU(124-2*MOD(IABS(I),2))
26948 ELSEIF(IA.LE.4) THEN
26949 VPI=PARJ(182-2*MOD(IABS(I),2))
26950 API=PARJ(183-2*MOD(IABS(I),2))
26951 ELSE
26952 VPI=PARJ(190-2*MOD(IABS(I),2))
26953 API=PARJ(191-2*MOD(IABS(I),2))
26954 ENDIF
26955 ELSE
26956 IF(IA.LE.12) THEN
26957 VPI=PARU(127-2*MOD(IABS(I),2))
26958 API=PARU(128-2*MOD(IABS(I),2))
26959 ELSEIF(IA.LE.14) THEN
26960 VPI=PARJ(186-2*MOD(IABS(I),2))
26961 API=PARJ(187-2*MOD(IABS(I),2))
26962 ELSE
26963 VPI=PARJ(194-2*MOD(IABS(I),2))
26964 API=PARJ(195-2*MOD(IABS(I),2))
26965 ENDIF
26966 ENDIF
26967 HI0=HP0
26968 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
26969 HI1=HP1
26970 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
26971 HI2=HP2
26972 IF(IABS(I).LE.10) HI2=HI2*FACA/3D0
26973 NCHN=NCHN+1
26974 ISIG(NCHN,1)=I
26975 ISIG(NCHN,2)=-I
26976 ISIG(NCHN,3)=1
26977 SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI*
26978 & (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)*
26979 & VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)*
26980 & (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/
26981 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)*
26982 & ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)*
26983 & ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+
26984 & (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116))
26985 100 CONTINUE
26986
26987 ELSEIF(ISUB.EQ.142) THEN
26988C...f + fbar' -> W'+/-
26989 SQMWP=PMAS(34,1)**2
26990 CALL PYWIDT(34,SH,WDTP,WDTE)
26991 HS=SHR*WDTP(0)
26992 FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0
26993 HP=AEM/(24D0*XW)*SH
26994 DO 120 I=MMIN1,MMAX1
26995 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
26996 IA=IABS(I)
26997 DO 110 J=MMIN2,MMAX2
26998 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
26999 JA=IABS(J)
27000 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
27001 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
27002 & GOTO 110
27003 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
27004 HI=HP*(PARU(133)**2+PARU(134)**2)
27005 IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)*
27006 & VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
27007 NCHN=NCHN+1
27008 ISIG(NCHN,1)=I
27009 ISIG(NCHN,2)=J
27010 ISIG(NCHN,3)=1
27011 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
27012 SIGH(NCHN)=HI*FACBW*HF
27013 110 CONTINUE
27014 120 CONTINUE
27015
27016 ELSEIF(ISUB.EQ.144) THEN
27017C...f + fbar' -> R
27018 SQMR=PMAS(41,1)**2
27019 CALL PYWIDT(41,SH,WDTP,WDTE)
27020 HS=SHR*WDTP(0)
27021 FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0
27022 HP=AEM/(12D0*XW)*SH
27023 DO 140 I=MMIN1,MMAX1
27024 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
27025 IA=IABS(I)
27026 DO 130 J=MMIN2,MMAX2
27027 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
27028 JA=IABS(J)
27029 IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 130
27030 HI=HP
27031 IF(IA.LE.10) HI=HI*FACA/3D0
27032 HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
27033 NCHN=NCHN+1
27034 ISIG(NCHN,1)=I
27035 ISIG(NCHN,2)=J
27036 ISIG(NCHN,3)=1
27037 SIGH(NCHN)=HI*FACBW*HF
27038 130 CONTINUE
27039 140 CONTINUE
27040
27041 ELSEIF(ISUB.EQ.145) THEN
27042C...q + l -> LQ (leptoquark)
27043 SQMLQ=PMAS(42,1)**2
27044 CALL PYWIDT(42,SH,WDTP,WDTE)
27045 HS=SHR*WDTP(0)
27046 FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2)
27047 IF(ABS(SHR-PMAS(42,1)).GT.PARP(48)*PMAS(42,2)) FACBW=0D0
27048 HP=AEM/4D0*SH
27049 KFLQQ=KFDP(MDCY(42,2),1)
27050 KFLQL=KFDP(MDCY(42,2),2)
27051 DO 160 I=MMIN1,MMAX1
27052 IF(KFAC(1,I).EQ.0) GOTO 160
27053 IA=IABS(I)
27054 IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 160
27055 DO 150 J=MMIN2,MMAX2
27056 IF(KFAC(2,J).EQ.0) GOTO 150
27057 JA=IABS(J)
27058 IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 150
27059 IF(I*J.NE.KFLQQ*KFLQL) GOTO 150
27060 IF(JA.EQ.IA) GOTO 150
27061 IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I)
27062 IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J)
27063 HI=HP*PARU(151)
27064 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4))
27065 NCHN=NCHN+1
27066 ISIG(NCHN,1)=I
27067 ISIG(NCHN,2)=J
27068 ISIG(NCHN,3)=1
27069 SIGH(NCHN)=HI*FACBW*HF
27070 150 CONTINUE
27071 160 CONTINUE
27072
27073 ELSEIF(ISUB.EQ.146) THEN
27074C...e + gamma* -> e* (excited lepton)
27075 KFQSTR=KFPR(ISUB,1)
27076 KCQSTR=PYCOMP(KFQSTR)
27077 KFQEXC=MOD(KFQSTR,KEXCIT)
27078 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
27079 HS=SHR*WDTP(0)
27080 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
27081 QF=-RTCM(43)/2D0-RTCM(44)/2D0
27082 FACBW=FACBW*AEM*QF**2*SH/RTCM(41)**2
27083 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
27084 & FACBW=0D0
27085 HP=SH
27086 DO 180 I=-KFQEXC,KFQEXC,2*KFQEXC
27087 DO 170 ISDE=1,2
27088 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 170
27089 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 170
27090 HI=HP
27091 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27092 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
27093 NCHN=NCHN+1
27094 ISIG(NCHN,ISDE)=I
27095 ISIG(NCHN,3-ISDE)=22
27096 ISIG(NCHN,3)=1
27097 SIGH(NCHN)=HI*FACBW*HF
27098 170 CONTINUE
27099 180 CONTINUE
27100
27101 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
27102C...d + g -> d* and u + g -> u* (excited quarks)
27103 KFQSTR=KFPR(ISUB,1)
27104 KCQSTR=PYCOMP(KFQSTR)
27105 KFQEXC=MOD(KFQSTR,KEXCIT)
27106 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
27107 HS=SHR*WDTP(0)
27108 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
27109 FACBW=FACBW*AS*RTCM(45)**2*SH/(3D0*RTCM(41)**2)
27110 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
27111 & FACBW=0D0
27112 HP=SH
27113 DO 200 I=-KFQEXC,KFQEXC,2*KFQEXC
27114 DO 190 ISDE=1,2
27115 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 190
27116 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 190
27117 HI=HP
27118 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27119 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
27120 NCHN=NCHN+1
27121 ISIG(NCHN,ISDE)=I
27122 ISIG(NCHN,3-ISDE)=21
27123 ISIG(NCHN,3)=1
27124 SIGH(NCHN)=HI*FACBW*HF
27125 190 CONTINUE
27126 200 CONTINUE
27127 ENDIF
27128
27129 ELSEIF(ISUB.LE.190) THEN
27130 IF(ISUB.EQ.162) THEN
27131C...q + g -> LQ + lbar; LQ=leptoquark
27132 SQMLQ=PMAS(42,1)**2
27133 FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)*
27134 & (UH2+SQMLQ**2)/(UH-SQMLQ)**2
27135 KFLQQ=KFDP(MDCY(42,2),1)
27136 DO 220 I=MMINA,MMAXA
27137 IF(IABS(I).NE.KFLQQ) GOTO 220
27138 KCHLQ=ISIGN(1,I)
27139 DO 210 ISDE=1,2
27140 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 210
27141 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 210
27142 NCHN=NCHN+1
27143 ISIG(NCHN,ISDE)=I
27144 ISIG(NCHN,3-ISDE)=21
27145 ISIG(NCHN,3)=1
27146 SIGH(NCHN)=FACLQ*WIDS(42,(5-KCHLQ)/2)
27147 210 CONTINUE
27148 220 CONTINUE
27149
27150 ELSEIF(ISUB.EQ.163) THEN
27151C...g + g -> LQ + LQbar; LQ=leptoquark
27152 SQMLQ=PMAS(42,1)**2
27153 FACLQ=COMFAC*FACA*WIDS(42,1)*(AS**2/2D0)*
27154 & (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/
27155 & (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/
27156 & ((TH-SQMLQ)*(UH-SQMLQ)))
27157 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 230
27158 NCHN=NCHN+1
27159 ISIG(NCHN,1)=21
27160 ISIG(NCHN,2)=21
27161C...Since don't know proper colour flow, randomize between alternatives
27162 ISIG(NCHN,3)=INT(1.5D0+PYR(0))
27163 SIGH(NCHN)=FACLQ
27164 230 CONTINUE
27165
27166 ELSEIF(ISUB.EQ.164) THEN
27167C...q + qbar -> LQ + LQbar; LQ=leptoquark
27168 DELTA=0.25D0*(SQM3-SQM4)**2/SH
27169 SQMLQ=0.5D0*(SQM3+SQM4)-DELTA
27170 TH=TH-DELTA
27171 UH=UH-DELTA
27172C SQMLQ=PMAS(42,1)**2
27173 FACLQA=COMFAC*WIDS(42,1)*(AS**2/9D0)*
27174 & (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2
27175 FACLQS=COMFAC*WIDS(42,1)*((PARU(151)**2*AEM**2/8D0)*
27176 & (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)*
27177 & ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH))
27178 KFLQQ=KFDP(MDCY(42,2),1)
27179 DO 240 I=MMINA,MMAXA
27180 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
27181 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 240
27182 NCHN=NCHN+1
27183 ISIG(NCHN,1)=I
27184 ISIG(NCHN,2)=-I
27185 ISIG(NCHN,3)=1
27186 SIGH(NCHN)=FACLQA
27187 IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS
27188 240 CONTINUE
27189
27190 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
27191C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks)
27192 KFQSTR=KFPR(ISUB,2)
27193 KCQSTR=PYCOMP(KFQSTR)
27194 KFQEXC=MOD(KFQSTR,KEXCIT)
27195 FACQSA=COMFAC*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)
27196 FACQSB=COMFAC*0.25D0*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
27197 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
27198C...Propagators: as simulated in PYOFSH and as desired
27199 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
27200 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
27201 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
27202 GMMQC=SQRT(SQM4)*WDTP(0)
27203 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
27204 FACQSA=FACQSA*HBW4C/HBW4
27205 FACQSB=FACQSB*HBW4C/HBW4
27206C...Branching ratios.
27207 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
27208 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
27209 DO 260 I=MMIN1,MMAX1
27210 IA=IABS(I)
27211 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 260
27212 DO 250 J=MMIN2,MMAX2
27213 JA=IABS(J)
27214 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 250
27215 IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN
27216 NCHN=NCHN+1
27217 ISIG(NCHN,1)=I
27218 ISIG(NCHN,2)=J
27219 ISIG(NCHN,3)=1
27220 IF(I.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
27221 IF(I.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
27222 NCHN=NCHN+1
27223 ISIG(NCHN,1)=I
27224 ISIG(NCHN,2)=J
27225 ISIG(NCHN,3)=2
27226 IF(J.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
27227 IF(J.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
27228 ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN
27229 NCHN=NCHN+1
27230 ISIG(NCHN,1)=I
27231 ISIG(NCHN,2)=J
27232 ISIG(NCHN,3)=1
27233 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
27234 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSA*BRPOS
27235 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSA*BRNEG
27236 ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN
27237 NCHN=NCHN+1
27238 ISIG(NCHN,1)=I
27239 ISIG(NCHN,2)=J
27240 ISIG(NCHN,3)=1
27241 IF(I.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
27242 IF(I.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
27243 NCHN=NCHN+1
27244 ISIG(NCHN,1)=I
27245 ISIG(NCHN,2)=J
27246 ISIG(NCHN,3)=2
27247 IF(J.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
27248 IF(J.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
27249 ELSEIF(I.EQ.-J) THEN
27250 NCHN=NCHN+1
27251 ISIG(NCHN,1)=I
27252 ISIG(NCHN,2)=J
27253 ISIG(NCHN,3)=1
27254 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
27255 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
27256 NCHN=NCHN+1
27257 ISIG(NCHN,1)=I
27258 ISIG(NCHN,2)=J
27259 ISIG(NCHN,3)=2
27260 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
27261 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
27262 ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN
27263 NCHN=NCHN+1
27264 ISIG(NCHN,1)=I
27265 ISIG(NCHN,2)=J
27266 ISIG(NCHN,3)=1
27267 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
27268 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSB*BRPOS
27269 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSB*BRNEG
27270 ENDIF
27271 250 CONTINUE
27272 260 CONTINUE
27273
27274 ELSEIF(ISUB.EQ.169) THEN
27275C...q + qbar -> e + e* (excited lepton)
27276 KFQSTR=KFPR(ISUB,2)
27277 KCQSTR=PYCOMP(KFQSTR)
27278 KFQEXC=MOD(KFQSTR,KEXCIT)
27279 FACQSB=(COMFAC/12D0)*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
27280 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
27281C...Propagators: as simulated in PYOFSH and as desired
27282 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
27283 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
27284 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
27285 GMMQC=SQRT(SQM4)*WDTP(0)
27286 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
27287 FACQSB=FACQSB*HBW4C/HBW4
27288C...Branching ratios.
27289 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
27290 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
27291 DO 270 I=MMIN1,MMAX1
27292 IA=IABS(I)
27293 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 270
27294 J=-I
27295 JA=IABS(J)
27296 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 270
27297 NCHN=NCHN+1
27298 ISIG(NCHN,1)=I
27299 ISIG(NCHN,2)=J
27300 ISIG(NCHN,3)=1
27301 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
27302 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
27303 NCHN=NCHN+1
27304 ISIG(NCHN,1)=I
27305 ISIG(NCHN,2)=J
27306 ISIG(NCHN,3)=2
27307 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
27308 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
27309 270 CONTINUE
27310 ENDIF
27311
27312 ELSEIF(ISUB.LE.360) THEN
27313 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
27314C...l + l -> H_L++/-- or H_R++/--.
27315 KFRES=KFPR(ISUB,1)
27316 KFREC=PYCOMP(KFRES)
27317 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
27318 HS=SHR*WDTP(0)
27319 FACBW=8D0*COMFAC/((SH-PMAS(KFREC,1)**2)**2+HS**2)
27320 DO 290 I=MMIN1,MMAX1
27321 IA=IABS(I)
27322 IF((IA.NE.11.AND.IA.NE.13.AND.IA.NE.15).OR.KFAC(1,I).EQ.0)
27323 & GOTO 290
27324 DO 280 J=MMIN2,MMAX2
27325 JA=IABS(J)
27326 IF((JA.NE.11.AND.JA.NE.13.AND.JA.NE.15).OR.KFAC(2,J).EQ.0)
27327 & GOTO 280
27328 IF(I*J.LT.0) GOTO 280
27329 KCHH=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
27330 NCHN=NCHN+1
27331 ISIG(NCHN,1)=I
27332 ISIG(NCHN,2)=J
27333 ISIG(NCHN,3)=1
27334 HI=SH*PARP(181+3*((IA-11)/2)+(JA-11)/2)**2/(8D0*PARU(1))
27335 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
27336 SIGH(NCHN)=HI*FACBW*HF
27337 280 CONTINUE
27338 290 CONTINUE
27339
27340 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
27341C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'.
27342 KFRES=KFPR(ISUB,1)
27343 KFREC=PYCOMP(KFRES)
27344C...Propagators: as simulated in PYOFSH and as desired
27345 HBW3=PMAS(KFREC,1)*PMAS(KFREC,2)/((SQM3-PMAS(KFREC,1)**2)**2+
27346 & (PMAS(KFREC,1)*PMAS(KFREC,2))**2)
27347 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
27348 GMMC=SQRT(SQM3)*WDTP(0)
27349 HBW3C=GMMC/((SQM3-PMAS(KFREC,1)**2)**2+GMMC**2)
27350 FHCC=COMFAC*AEM*HBW3C/HBW3
27351 DO 310 I=MMINA,MMAXA
27352 IA=IABS(I)
27353 IF(IA.NE.11.AND.IA.NE.13.AND.IA.NE.15) GOTO 310
27354 SQML=PMAS(IA,1)**2
27355 J=ISIGN(KFPR(ISUB,2),-I)
27356 KCHH=ISIGN(2,KCHG(IA,1)*ISIGN(1,I))
27357 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))/WDTP(0)
27358 SMM1=8D0*(SH+TH-SQM3)*(SH+TH-2D0*SQM3-SQML-SQM4)/
27359 & (UH-SQM3)**2
27360 SMM2=2D0*((2D0*SQM3-3D0*SQML)*SQM4+(SQML-2D0*SQM4)*TH-
27361 & (TH-SQM4)*SH)/(TH-SQM4)**2
27362 SMM3=2D0*((2D0*SQM3-3D0*SQM4+TH)*SQML-(2D0*SQML-SQM4+TH)*
27363 & SH)/(SH-SQML)**2
27364 SMM12=4D0*((2D0*SQML-SQM4-2D0*SQM3+TH)*SH+(TH-3D0*SQM3-
27365 & 3D0*SQM4)*TH+(2D0*SQM3-2D0*SQML+3D0*SQM4)*SQM3)/
27366 & ((UH-SQM3)*(TH-SQM4))
27367 SMM13=-4D0*((TH+SQML-2D0*SQM4)*TH-(SQM3+3D0*SQML-2D0*SQM4)*
27368 & SQM3+(SQM3+3D0*SQML+TH)*SH-(TH-SQM3+SH)**2)/
27369 & ((UH-SQM3)*(SH-SQML))
27370 SMM23=-4D0*((SQML-SQM4+SQM3)*TH-SQM3**2+SQM3*(SQML+SQM4)-
27371 & 3D0*SQML*SQM4-(SQML-SQM4-SQM3+TH)*SH)/
27372 & ((SH-SQML)*(TH-SQM4))
27373 SMM=(SH/(SH-SQML))**2*(SMM1+SMM2+SMM3+SMM12+SMM13+SMM23)*
27374 & PARP(181+3*((IA-11)/2)+(IABS(J)-11)/2)**2/(4D0*PARU(1))
27375 DO 300 ISDE=1,2
27376 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 300
27377 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 300
27378 NCHN=NCHN+1
27379 ISIG(NCHN,ISDE)=I
27380 ISIG(NCHN,3-ISDE)=22
27381 ISIG(NCHN,3)=0
27382 SIGH(NCHN)=FHCC*SMM*WIDSC
27383 300 CONTINUE
27384 310 CONTINUE
27385
27386 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
27387C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R--
27388 KFRES=KFPR(ISUB,1)
27389 KFREC=PYCOMP(KFRES)
27390 SQMH=PMAS(KFREC,1)**2
27391 GMMH=PMAS(KFREC,1)*PMAS(KFREC,2)
27392C...Propagators: H++/-- as simulated in PYOFSH and as desired
27393 HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2)
27394 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
27395 GMMH3=SQRT(SQM3)*WDTP(0)
27396 HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2)
27397 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
27398 CALL PYWIDT(KFRES,SQM4,WDTP,WDTE)
27399 GMMH4=SQRT(SQM4)*WDTP(0)
27400 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
27401C...Kinematical and coupling functions
27402 FACHH=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*(TH*UH-SQM3*SQM4)
27403 XWHH=(1D0-2D0*XWV)/(8D0*XWV*(1D0-XWV))
27404C...Loop over allowed flavours
27405 DO 320 I=MMINA,MMAXA
27406 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
27407 EI=KCHG(IABS(I),1)/3D0
27408 AI=SIGN(1D0,EI+0.1D0)
27409 VI=AI-4D0*EI*XWV
27410 FCOI=1D0
27411 IF(IABS(I).LE.10) FCOI=FACA/3D0
27412 IF(ISUB.EQ.349) THEN
27413 HBWZ=1D0/((SH-SQMZ)**2+GMMZ**2)
27414 IF(IABS(I).LT.10) THEN
27415 DSIGHH=8D0*AEM**2*(EI**2/SH2+
27416 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
27417 & (VI**2+AI**2)*XWHH**2*HBWZ)
27418 ELSE
27419 IAOFF=181+3*((IABS(I)-11)/2)
27420 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
27421 & (4D0*PARU(1))
27422 DSIGHH=8D0*AEM**2*(EI**2/SH2+
27423 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
27424 & (VI**2+AI**2)*XWHH**2*HBWZ)+
27425 & 8D0*AEM*(EI*HSUM/(SH*TH)+
27426 & (VI+AI)*XWHH*HSUM*(SH-SQMZ)*HBWZ/TH)+
27427 & 4D0*HSUM**2/TH2
27428 ENDIF
27429 ELSE
27430 IF(IABS(I).LT.10) THEN
27431 DSIGHH=8D0*AEM**2*EI**2/SH2
27432 ELSE
27433 IAOFF=181+3*((IABS(I)-11)/2)
27434 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
27435 & (4D0*PARU(1))
27436 DSIGHH=8D0*AEM**2*EI**2/SH2+8D0*AEM*EI*HSUM/(SH*TH)+
27437 & 4D0*HSUM**2/TH2
27438 ENDIF
27439 ENDIF
27440 NCHN=NCHN+1
27441 ISIG(NCHN,1)=I
27442 ISIG(NCHN,2)=-I
27443 ISIG(NCHN,3)=1
27444 SIGH(NCHN)=FACHH*FCOI*DSIGHH
27445 320 CONTINUE
27446
27447 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
27448C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process)
27449 KFRES=KFPR(ISUB,1)
27450 KFREC=PYCOMP(KFRES)
27451 SQMH=PMAS(KFREC,1)**2
27452 IF(ISUB.EQ.351) FACNOR=PARP(190)**8*PARP(192)**2
27453 IF(ISUB.EQ.352) FACNOR=PARP(191)**6*2D0*
27454 & PMAS(PYCOMP(9900024),1)**2
27455 FACWW=COMFAC*FACNOR*TAUP*VINT(2)*VINT(219)
27456 FACPRT=1D0/((VINT(204)**2-VINT(215))*
27457 & (VINT(209)**2-VINT(216)))
27458 FACPRU=1D0/((VINT(204)**2+2D0*VINT(217))*
27459 & (VINT(209)**2+2D0*VINT(218)))
27460 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
27461 HS=SHR*WDTP(0)
27462 FACBW=(1D0/PARU(1))*VINT(2)/((SH-SQMH)**2+HS**2)
27463 IF(ABS(SHR-PMAS(KFREC,1)).GT.PARP(48)*PMAS(KFREC,2))
27464 & FACBW=0D0
27465 DO 340 I=MMIN1,MMAX1
27466 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 340
27467 IF(ISUB.EQ.352.AND.IABS(I).GT.10) GOTO 340
27468 KCHWI=(1-2*MOD(IABS(I),2))*ISIGN(1,I)
27469 DO 330 J=MMIN2,MMAX2
27470 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 330
27471 IF(ISUB.EQ.352.AND.IABS(J).GT.10) GOTO 330
27472 KCHWJ=(1-2*MOD(IABS(J),2))*ISIGN(1,J)
27473 KCHH=KCHWI+KCHWJ
27474 IF(IABS(KCHH).NE.2) GOTO 330
27475 FACLR=VINT(180+I)*VINT(180+J)
27476 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
27477 IF(I.EQ.J.AND.IABS(I).GT.10) THEN
27478 FACPRP=0.5D0*(FACPRT+FACPRU)**2
27479 ELSE
27480 FACPRP=FACPRT**2
27481 ENDIF
27482 NCHN=NCHN+1
27483 ISIG(NCHN,1)=I
27484 ISIG(NCHN,2)=J
27485 ISIG(NCHN,3)=1
27486 SIGH(NCHN)=FACLR*FACWW*FACPRP*FACBW*HF
27487 330 CONTINUE
27488 340 CONTINUE
27489
27490 ELSEIF(ISUB.EQ.353) THEN
27491C...f + fbar -> Z_R0
27492 SQMZR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
27493 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
27494 HS=SHR*WDTP(0)
27495 FACBW=4D0*COMFAC/((SH-SQMZR)**2+HS**2)*3D0
27496 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27497 HP=(AEM/(3D0*(1D0-2D0*XW)))*XWC*SH
27498 DO 350 I=MMINA,MMAXA
27499 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
27500 IF(IABS(I).LE.8) THEN
27501 EI=KCHG(IABS(I),1)/3D0
27502 AI=SIGN(1D0,EI+0.1D0)*(1D0-2D0*XW)
27503 VI=SIGN(1D0,EI+0.1D0)-4D0*EI*XW
27504 ELSE
27505 AI=-(1D0-2D0*XW)
27506 VI=-1D0+4D0*XW
27507 ENDIF
27508 HI=HP*(VI**2+AI**2)
27509 IF(IABS(I).LE.10) HI=HI*FACA/3D0
27510 NCHN=NCHN+1
27511 ISIG(NCHN,1)=I
27512 ISIG(NCHN,2)=-I
27513 ISIG(NCHN,3)=1
27514 SIGH(NCHN)=HI*FACBW*HF
27515 350 CONTINUE
27516
27517 ELSEIF(ISUB.EQ.354) THEN
27518C...f + fbar' -> W_R+/-
27519 SQMWR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
27520 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
27521 HS=SHR*WDTP(0)
27522 FACBW=4D0*COMFAC/((SH-SQMWR)**2+HS**2)*3D0
27523 HP=AEM/(24D0*XW)*SH
27524 DO 370 I=MMIN1,MMAX1
27525 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 370
27526 IA=IABS(I)
27527 DO 360 J=MMIN2,MMAX2
27528 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 360
27529 JA=IABS(J)
27530 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
27531 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
27532 & GOTO 360
27533 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
27534 HI=HP*2D0
27535 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
27536 NCHN=NCHN+1
27537 ISIG(NCHN,1)=I
27538 ISIG(NCHN,2)=J
27539 ISIG(NCHN,3)=1
27540 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
27541 SIGH(NCHN)=HI*FACBW*HF
27542 360 CONTINUE
27543 370 CONTINUE
27544 ENDIF
27545
27546 ELSEIF(ISUB.LE.400) THEN
27547 IF(ISUB.EQ.391) THEN
27548C...f + fbar -> G*.
27549 KFGSTR=KFPR(ISUB,1)
27550 KCGSTR=PYCOMP(KFGSTR)
27551 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
27552 HS=SHR*WDTP(0)
27553 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27554 FACG=COMFAC*PARP(50)**2/(16D0*PARU(1))*SH*HF/
27555 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
27556 DO 380 I=MMINA,MMAXA
27557 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
27558 HI=1D0
27559 IF(IABS(I).LE.10) HI=HI*FACA/3D0
27560 NCHN=NCHN+1
27561 ISIG(NCHN,1)=I
27562 ISIG(NCHN,2)=-I
27563 ISIG(NCHN,3)=1
27564 SIGH(NCHN)=FACG*HI
27565 380 CONTINUE
27566
27567 ELSEIF(ISUB.EQ.392) THEN
27568C...g + g -> G*.
27569 KFGSTR=KFPR(ISUB,1)
27570 KCGSTR=PYCOMP(KFGSTR)
27571 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
27572 HS=SHR*WDTP(0)
27573 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27574 FACG=COMFAC*PARP(50)**2/(32D0*PARU(1))*SH*HF/
27575 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
27576 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 390
27577 NCHN=NCHN+1
27578 ISIG(NCHN,1)=21
27579 ISIG(NCHN,2)=21
27580 ISIG(NCHN,3)=1
27581 SIGH(NCHN)=FACG
27582 390 CONTINUE
27583
27584 ELSEIF(ISUB.EQ.393) THEN
27585C...q + qbar -> g + G*.
27586 KFGSTR=KFPR(ISUB,2)
27587 KCGSTR=PYCOMP(KFGSTR)
27588 FACG=COMFAC*PARP(50)**2*AS*SH/(72D0*PARU(1)*SQM4)*
27589 & (4D0*(TH2+UH2)/SH2+9D0*(TH+UH)/SH+(TH2/UH+UH2/TH)/SH+
27590 & 3D0*(4D0+TH/UH+UH/TH)+4D0*(SH/UH+SH/TH)+
27591 & 2D0*SH2/(TH*UH))
27592C...Propagators: as simulated in PYOFSH and as desired
27593 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
27594 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
27595 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
27596 HS=SQRT(SQM4)*WDTP(0)
27597 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27598 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
27599 FACG=FACG*HBW4C/HBW4
27600 DO 400 I=MMINA,MMAXA
27601 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
27602 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
27603 NCHN=NCHN+1
27604 ISIG(NCHN,1)=I
27605 ISIG(NCHN,2)=-I
27606 ISIG(NCHN,3)=1
27607 SIGH(NCHN)=FACG
27608 400 CONTINUE
27609
27610 ELSEIF(ISUB.EQ.394) THEN
27611C...q + g -> q + G*.
27612 KFGSTR=KFPR(ISUB,2)
27613 KCGSTR=PYCOMP(KFGSTR)
27614 FACG=-COMFAC*PARP(50)**2*AS*SH/(192D0*PARU(1)*SQM4)*
27615 & (4D0*(SH2+UH2)/(TH*SH)+9D0*(SH+UH)/SH+SH/UH+UH2/SH2+
27616 & 3D0*TH*(4D0+SH/UH+UH/SH)/SH+4D0*TH2*(1D0/UH+1D0/SH)/SH+
27617 & 2D0*TH2*TH/(UH*SH2))
27618C...Propagators: as simulated in PYOFSH and as desired
27619 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
27620 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
27621 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
27622 HS=SQRT(SQM4)*WDTP(0)
27623 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27624 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
27625 FACG=FACG*HBW4C/HBW4
27626 DO 420 I=MMINA,MMAXA
27627 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 420
27628 DO 410 ISDE=1,2
27629 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 410
27630 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 410
27631 NCHN=NCHN+1
27632 ISIG(NCHN,ISDE)=I
27633 ISIG(NCHN,3-ISDE)=21
27634 ISIG(NCHN,3)=1
27635 SIGH(NCHN)=FACG
27636 410 CONTINUE
27637 420 CONTINUE
27638
27639 ELSEIF(ISUB.EQ.395) THEN
27640C...g + g -> g + G*.
27641 KFGSTR=KFPR(ISUB,2)
27642 KCGSTR=PYCOMP(KFGSTR)
27643 FACG=COMFAC*3D0*PARP(50)**2*AS*SH/(32D0*PARU(1)*SQM4)*
27644 & ((TH2+TH*UH+UH2)**2/(SH2*TH*UH)+2D0*(TH2/UH+UH2/TH)/SH+
27645 & 3D0*(TH/UH+UH/TH)+2D0*(SH/UH+SH/TH)+SH2/(TH*UH))
27646C...Propagators: as simulated in PYOFSH and as desired
27647 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
27648 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
27649 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
27650 HS=SQRT(SQM4)*WDTP(0)
27651 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27652 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
27653 FACG=FACG*HBW4C/HBW4
27654 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
27655 NCHN=NCHN+1
27656 ISIG(NCHN,1)=21
27657 ISIG(NCHN,2)=21
27658 ISIG(NCHN,3)=1
27659 SIGH(NCHN)=FACG
27660 ENDIF
27661 ENDIF
27662 ENDIF
27663
27664 RETURN
27665 END
27666
27667C*********************************************************************
27668
27669C...PYPDFU
27670C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon
27671C...parton distributions according to a few different parametrizations.
27672C...Note that what is coded is x times the probability distribution,
27673C...i.e. xq(x,Q2) etc.
27674
27675 SUBROUTINE PYPDFU(KF,X,Q2,XPQ)
27676
27677C...Double precision and integer declarations.
27678 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27679 IMPLICIT INTEGER(I-N)
27680 INTEGER PYK,PYCHGE,PYCOMP
27681C...Commonblocks.
27682 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27683 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27684 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27685 COMMON/PYINT1/MINT(400),VINT(400)
27686 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
27687 &XPDIR(-6:6)
27688 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/
27689C...Local arrays.
27690 DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
27691 &XPPI(-6:6),XPPR(-6:6)
27692
27693C...Interface to PDFLIB.
81935ff8 27694 COMMON/LW50513/XMIN,XMAX,Q2MIN,Q2MAX
27695 SAVE /LW50513/
2dfa57d1 27696 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
27697 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
27698 CHARACTER*20 PARM(20)
27699 DATA VALUE/20*0D0/,PARM/20*' '/
27700
27701C...Data related to Schuler-Sjostrand photon distributions.
27702 DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
27703
27704C...Reset parton distributions.
27705 MINT(92)=0
27706 DO 100 KFL=-25,25
27707 XPQ(KFL)=0D0
27708 100 CONTINUE
27709
27710C...Check x and particle species.
27711 IF(X.LE.0D0.OR.X.GE.1D0) THEN
27712 WRITE(MSTU(11),5000) X
27713 RETURN
27714 ENDIF
27715 KFA=IABS(KF)
27716 IF(KFA.NE.11.AND.KFA.NE.13.AND.KFA.NE.15.AND.KFA.NE.22.AND.
27717 &KFA.NE.211.AND.KFA.NE.2112.AND.KFA.NE.2212.AND.KFA.NE.3122.AND.
27718 &KFA.NE.3112.AND.KFA.NE.3212.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.
27719 &KFA.NE.3322.AND.KFA.NE.3334.AND.KFA.NE.111.AND.KFA.NE.321.AND.
27720 &KFA.NE.310.AND.KFA.NE.130) THEN
27721 WRITE(MSTU(11),5100) KF
27722 RETURN
27723 ENDIF
27724
27725C...Electron (or muon or tau) parton distribution call.
27726 IF(KFA.EQ.11.OR.KFA.EQ.13.OR.KFA.EQ.15) THEN
27727 CALL PYPDEL(KFA,X,Q2,XPEL)
27728 DO 110 KFL=-25,25
27729 XPQ(KFL)=XPEL(KFL)
27730 110 CONTINUE
27731
27732C...Photon parton distribution call (VDM+anomalous).
27733 ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
27734 IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
27735 CALL PYPDGA(X,Q2,XPGA)
27736 DO 120 KFL=-6,6
27737 XPQ(KFL)=XPGA(KFL)
27738 120 CONTINUE
27739 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
27740 Q2MX=Q2
27741 P2MX=0.36D0
27742 IF(MSTP(55).GE.7) P2MX=4.0D0
27743 IF(MSTP(57).EQ.0) Q2MX=P2MX
27744 P2=0D0
27745 IF(VINT(120).LT.0D0) P2=VINT(120)**2
27746 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
27747 DO 130 KFL=-6,6
27748 XPQ(KFL)=XPGA(KFL)
27749 130 CONTINUE
27750 VINT(231)=P2MX
27751 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
27752 Q2MX=Q2
27753 P2MX=0.36D0
27754 IF(MSTP(55).GE.11) P2MX=4.0D0
27755 IF(MSTP(57).EQ.0) Q2MX=P2MX
27756 P2=0D0
27757 IF(VINT(120).LT.0D0) P2=VINT(120)**2
27758 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
27759 DO 140 KFL=-6,6
27760 XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
27761 140 CONTINUE
27762 VINT(231)=P2MX
27763 ELSEIF(MSTP(56).EQ.2) THEN
27764C...Call PDFLIB parton distributions.
27765 PARM(1)='NPTYPE'
27766 VALUE(1)=3
27767 PARM(2)='NGROUP'
27768 VALUE(2)=MSTP(55)/1000
27769 PARM(3)='NSET'
27770 VALUE(3)=MOD(MSTP(55),1000)
27771 IF(MINT(93).NE.3000000+MSTP(55)) THEN
27772 CALL PDFSET(PARM,VALUE)
27773 MINT(93)=3000000+MSTP(55)
27774 ENDIF
27775 XX=X
27776 QQ2=MAX(0D0,Q2MIN,Q2)
27777 IF(MSTP(57).EQ.0) QQ2=Q2MIN
27778 P2=0D0
27779 IF(VINT(120).LT.0D0) P2=VINT(120)**2
27780 IP2=MSTP(60)
27781 IF(MSTP(55).EQ.5004) THEN
27782 IF(5D0*P2.LT.QQ2.AND.
27783 & QQ2.GT.0.6D0.AND.QQ2.LT.5D4.AND.
27784 & P2.GE.0D0.AND.P2.LT.10D0.AND.
27785 & XX.GT.1D-4.AND.XX.LT.1D0) THEN
27786 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
27787 & BOT,TOP,GLU)
27788 ELSE
27789 UPV=0D0
27790 DNV=0D0
27791 USEA=0D0
27792 DSEA=0D0
27793 STR=0D0
27794 CHM=0D0
27795 BOT=0D0
27796 TOP=0D0
27797 GLU=0D0
27798 ENDIF
27799 ELSE
27800 IF(P2.LT.QQ2) THEN
27801 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
27802 & BOT,TOP,GLU)
27803 ELSE
27804 UPV=0D0
27805 DNV=0D0
27806 USEA=0D0
27807 DSEA=0D0
27808 STR=0D0
27809 CHM=0D0
27810 BOT=0D0
27811 TOP=0D0
27812 GLU=0D0
27813 ENDIF
27814 ENDIF
27815 VINT(231)=Q2MIN
27816 XPQ(0)=GLU
27817 XPQ(1)=DNV
27818 XPQ(-1)=DNV
27819 XPQ(2)=UPV
27820 XPQ(-2)=UPV
27821 XPQ(3)=STR
27822 XPQ(-3)=STR
27823 XPQ(4)=CHM
27824 XPQ(-4)=CHM
27825 XPQ(5)=BOT
27826 XPQ(-5)=BOT
27827 XPQ(6)=TOP
27828 XPQ(-6)=TOP
27829 ELSE
27830 WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
27831 ENDIF
27832
27833C...Pion/gammaVDM parton distribution call.
27834 ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.KFA.EQ.321.OR.KFA.EQ.130.OR.
27835 &KFA.EQ.310.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
27836 IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
27837 & MSTP(55).LE.12) THEN
27838 ISET=1+MOD(MSTP(55)-1,4)
27839 Q2MX=Q2
27840 P2MX=0.36D0
27841 IF(ISET.GE.3) P2MX=4.0D0
27842 IF(MSTP(57).EQ.0) Q2MX=P2MX
27843 P2=0D0
27844 IF(VINT(120).LT.0D0) P2=VINT(120)**2
27845 CALL PYGGAM(ISET,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
27846 DO 150 KFL=-6,6
27847 XPQ(KFL)=XPVMD(KFL)
27848 150 CONTINUE
27849 VINT(231)=P2MX
27850 ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
27851 CALL PYPDPI(X,Q2,XPPI)
27852 DO 160 KFL=-6,6
27853 XPQ(KFL)=XPPI(KFL)
27854 160 CONTINUE
27855 ELSEIF(MSTP(54).EQ.2) THEN
27856C...Call PDFLIB parton distributions.
27857 PARM(1)='NPTYPE'
27858 VALUE(1)=2
27859 PARM(2)='NGROUP'
27860 VALUE(2)=MSTP(53)/1000
27861 PARM(3)='NSET'
27862 VALUE(3)=MOD(MSTP(53),1000)
27863 IF(MINT(93).NE.2000000+MSTP(53)) THEN
27864 CALL PDFSET(PARM,VALUE)
27865 MINT(93)=2000000+MSTP(53)
27866 ENDIF
27867 XX=X
27868 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
27869 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
27870 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
27871 VINT(231)=Q2MIN
27872 XPQ(0)=GLU
27873 XPQ(1)=DSEA
27874 XPQ(-1)=UPV+DSEA
27875 XPQ(2)=UPV+USEA
27876 XPQ(-2)=USEA
27877 XPQ(3)=STR
27878 XPQ(-3)=STR
27879 XPQ(4)=CHM
27880 XPQ(-4)=CHM
27881 XPQ(5)=BOT
27882 XPQ(-5)=BOT
27883 XPQ(6)=TOP
27884 XPQ(-6)=TOP
27885 ELSE
27886 WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
27887 ENDIF
27888
27889C...Anomalous photon parton distribution call.
27890 ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
27891 Q2MX=Q2
27892 P2MX=PARP(15)**2
27893 IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
27894 IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
27895 IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
27896 IF(MSTP(57).EQ.0) Q2MX=P2MX
27897 P2=0D0
27898 IF(VINT(120).LT.0D0) P2=VINT(120)**2
27899 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
27900 DO 170 KFL=-6,6
27901 XPQ(KFL)=XPANL(KFL)+XPANH(KFL)
27902 170 CONTINUE
27903 VINT(231)=P2MX
27904 ELSEIF(MSTP(56).EQ.1) THEN
27905 IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
27906 IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
27907 IF(MSTP(57).EQ.0) Q2MX=P2MX
27908 P2=0D0
27909 IF(VINT(120).LT.0D0) P2=VINT(120)**2
27910 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
27911 DO 180 KFL=-6,6
27912 XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
27913 180 CONTINUE
27914 VINT(231)=P2MX
27915 ELSEIF(MSTP(56).EQ.2) THEN
27916 IF(MSTP(57).EQ.0) Q2MX=P2MX
27917 CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
27918 DO 190 KFL=-6,6
27919 XPQ(KFL)=XPGA(KFL)
27920 190 CONTINUE
27921 VINT(231)=P2MX
27922 ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
27923 IF(MSTP(57).EQ.0) Q2MX=P2MX
27924 CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
27925 DO 200 KFL=-6,6
27926 XPQ(KFL)=XPGA(KFL)
27927 200 CONTINUE
27928 VINT(231)=P2MX
27929 ELSE
27930 210 RKF=11D0*PYR(0)
27931 KFR=1
27932 IF(RKF.GT.1D0) KFR=2
27933 IF(RKF.GT.5D0) KFR=3
27934 IF(RKF.GT.6D0) KFR=4
27935 IF(RKF.GT.10D0) KFR=5
27936 IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 210
27937 IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 210
27938 IF(MSTP(57).EQ.0) Q2MX=P2MX
27939 CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
27940 DO 220 KFL=-6,6
27941 XPQ(KFL)=XPGA(KFL)
27942 220 CONTINUE
27943 VINT(231)=P2MX
27944 ENDIF
27945
27946C...Proton parton distribution call.
27947 ELSE
27948 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
27949 CALL PYPDPR(X,Q2,XPPR)
27950 DO 230 KFL=-6,6
27951 XPQ(KFL)=XPPR(KFL)
27952 230 CONTINUE
27953 ELSEIF(MSTP(52).EQ.2) THEN
27954C...Call PDFLIB parton distributions.
27955 PARM(1)='NPTYPE'
27956 VALUE(1)=1
27957 PARM(2)='NGROUP'
27958 VALUE(2)=MSTP(51)/1000
27959 PARM(3)='NSET'
27960 VALUE(3)=MOD(MSTP(51),1000)
27961 IF(MINT(93).NE.1000000+MSTP(51)) THEN
27962 CALL PDFSET_ALICE(PARM,VALUE)
27963 MINT(93)=1000000+MSTP(51)
27964 ENDIF
27965 XX=X
27966 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
27967 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
27968 CALL STRUCTM_ALICE
27969 + (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
27970 VINT(231)=Q2MIN
27971 XPQ(0)=GLU
27972 XPQ(1)=DNV+DSEA
27973 XPQ(-1)=DSEA
27974 XPQ(2)=UPV+USEA
27975 XPQ(-2)=USEA
27976 XPQ(3)=STR
27977 XPQ(-3)=STR
27978 XPQ(4)=CHM
27979 XPQ(-4)=CHM
27980 XPQ(5)=BOT
27981 XPQ(-5)=BOT
27982 XPQ(6)=TOP
27983 XPQ(-6)=TOP
27984 ELSE
27985 WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
27986 ENDIF
27987 ENDIF
27988
27989C...Isospin average for pi0/gammaVDM.
27990 IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
27991 IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
27992 XPV=XPQ(2)-XPQ(1)
27993 XPQ(2)=XPQ(1)
27994 XPQ(-2)=XPQ(-1)
27995 ELSE
27996 XPS=0.5D0*(XPQ(1)+XPQ(-2))
27997 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
27998 XPQ(2)=XPS
27999 XPQ(-1)=XPS
28000 ENDIF
28001 IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
28002 XPQ(1)=XPQ(1)+0.2D0*XPV
28003 XPQ(-1)=XPQ(-1)+0.2D0*XPV
28004 XPQ(2)=XPQ(2)+0.8D0*XPV
28005 XPQ(-2)=XPQ(-2)+0.8D0*XPV
28006 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
28007 XPQ(3)=XPQ(3)+XPV
28008 XPQ(-3)=XPQ(-3)+XPV
28009 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
28010 XPQ(4)=XPQ(4)+XPV
28011 XPQ(-4)=XPQ(-4)+XPV
28012 IF(MSTP(55).GE.9) THEN
28013 DO 240 KFL=-6,6
28014 XPQ(KFL)=0D0
28015 240 CONTINUE
28016 ENDIF
28017 ELSE
28018 XPQ(1)=XPQ(1)+0.5D0*XPV
28019 XPQ(-1)=XPQ(-1)+0.5D0*XPV
28020 XPQ(2)=XPQ(2)+0.5D0*XPV
28021 XPQ(-2)=XPQ(-2)+0.5D0*XPV
28022 ENDIF
28023
28024C...Rescale for gammaVDM by effective gamma -> rho coupling.
28025C+++Do not rescale?
28026 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND..NOT.(MSTP(56).EQ.1
28027 & .AND.MSTP(55).GE.5.AND.MSTP(55).LE.12)) THEN
28028 DO 250 KFL=-6,6
28029 XPQ(KFL)=VINT(281)*XPQ(KFL)
28030 250 CONTINUE
28031 VINT(232)=VINT(281)*XPV
28032 ENDIF
28033
28034C...Simple recipes for kaons.
28035 ELSEIF(KFA.EQ.321) THEN
28036 XPQ(-3)=XPQ(-3)+XPQ(-1)-XPQ(1)
28037 XPQ(-1)=XPQ(1)
28038 ELSEIF(KFA.EQ.130.OR.KFA.EQ.310) THEN
28039 XPS=0.5D0*(XPQ(1)+XPQ(-2))
28040 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
28041 XPQ(2)=XPS
28042 XPQ(-1)=XPS
28043 XPQ(1)=XPQ(1)+0.5D0*XPV
28044 XPQ(-1)=XPQ(-1)+0.5D0*XPV
28045 XPQ(3)=XPQ(3)+0.5D0*XPV
28046 XPQ(-3)=XPQ(-3)+0.5D0*XPV
28047
28048C...Isospin conjugation for neutron.
28049 ELSEIF(KFA.EQ.2112) THEN
28050 XPS=XPQ(1)
28051 XPQ(1)=XPQ(2)
28052 XPQ(2)=XPS
28053 XPS=XPQ(-1)
28054 XPQ(-1)=XPQ(-2)
28055 XPQ(-2)=XPS
28056
28057C...Simple recipes for hyperon (average valence parton distribution).
28058 ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
28059 & .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
28060 XPVAL=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
28061 XPSEA=0.5D0*(XPQ(-1)+XPQ(-2))
28062 XPQ(1)=XPSEA
28063 XPQ(2)=XPSEA
28064 XPQ(-1)=XPSEA
28065 XPQ(-2)=XPSEA
28066 XPQ(KFA/1000)=XPQ(KFA/1000)+XPVAL
28067 XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPVAL
28068 XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPVAL
28069 ENDIF
28070
28071C...Charge conjugation for antiparticle.
28072 IF(KF.LT.0) THEN
28073 DO 260 KFL=1,25
28074 IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 260
28075 XPS=XPQ(KFL)
28076 XPQ(KFL)=XPQ(-KFL)
28077 XPQ(-KFL)=XPS
28078 260 CONTINUE
28079 ENDIF
28080
28081C...Allow gluon also in position 21.
28082 XPQ(21)=XPQ(0)
28083
28084C...Check positivity and reset above maximum allowed flavour.
28085 DO 270 KFL=-25,25
28086 XPQ(KFL)=MAX(0D0,XPQ(KFL))
28087 IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0
28088 270 CONTINUE
28089
28090C...Formats for error printouts.
28091 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
28092 5100 FORMAT(' Error: illegal particle code for parton distribution;',
28093 &' KF =',I5)
28094 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
28095 &3I5)
28096
28097 RETURN
28098 END
28099
28100C*********************************************************************
28101
28102C...PYPDFL
28103C...Gives proton parton distribution at small x and/or Q^2 according to
28104C...correct limiting behaviour.
28105
28106 SUBROUTINE PYPDFL(KF,X,Q2,XPQ)
28107
28108C...Double precision and integer declarations.
28109 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28110 IMPLICIT INTEGER(I-N)
28111 INTEGER PYK,PYCHGE,PYCOMP
28112C...Commonblocks.
28113 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28114 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28115 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28116 COMMON/PYINT1/MINT(400),VINT(400)
28117 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
28118C...Local arrays.
28119 DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3)
28120 DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/
28121
28122C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
28123 MINT(92)=0
28124 KFA=IABS(KF)
28125 IACC=0
28126 IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1
28127 IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1
28128 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1
28129 IF(IACC.EQ.0) THEN
28130 CALL PYPDFU(KF,X,Q2,XPQ)
28131 RETURN
28132 ENDIF
28133
28134C...Reset. Check x.
28135 DO 100 KFL=-25,25
28136 XPQ(KFL)=0D0
28137 100 CONTINUE
28138 IF(X.LE.0D0.OR.X.GE.1D0) THEN
28139 WRITE(MSTU(11),5000) X
28140 RETURN
28141 ENDIF
28142
28143C...Define valence content.
28144 KFC=KF
28145 NV1=2
28146 NV2=1
28147 IF(KF.EQ.2212) THEN
28148 KFV1=2
28149 KFV2=1
28150 ELSEIF(KF.EQ.-2212) THEN
28151 KFV1=-2
28152 KFV2=-1
28153 ELSEIF(KF.EQ.2112) THEN
28154 KFV1=1
28155 KFV2=2
28156 ELSEIF(KF.EQ.-2112) THEN
28157 KFV1=-1
28158 KFV2=-2
28159 ELSEIF(KF.EQ.211) THEN
28160 NV1=1
28161 KFV1=2
28162 KFV2=-1
28163 ELSEIF(KF.EQ.-211) THEN
28164 NV1=1
28165 KFV1=-2
28166 KFV2=1
28167 ELSEIF(MINT(105).LE.223) THEN
28168 KFV1=1
28169 WTV1=0.2D0
28170 KFV2=2
28171 WTV2=0.8D0
28172 ELSEIF(MINT(105).EQ.333) THEN
28173 KFV1=3
28174 WTV1=1.0D0
28175 KFV2=1
28176 WTV2=0.0D0
28177 ELSEIF(MINT(105).EQ.443) THEN
28178 KFV1=4
28179 WTV1=1.0D0
28180 KFV2=1
28181 WTV2=0.0D0
28182 ENDIF
28183
28184C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
28185 CALL PYPDFU(KFC,X,Q2,XPA)
28186 Q2MN=MAX(3D0,VINT(231))
28187 Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X))))
28188 XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0
28189
28190C...Large Q2 and large x: naive call is enough.
28191 IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN
28192 DO 110 KFL=-25,25
28193 XPQ(KFL)=XPA(KFL)
28194 110 CONTINUE
28195 MINT(92)=1
28196
28197C...Small Q2 and large x: dampen boundary value.
28198 ELSEIF(X.GT.XMN) THEN
28199
28200C...Evaluate at boundary and define dampening factors.
28201 CALL PYPDFU(KFC,X,Q2MN,XPA)
28202 FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN))
28203 FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0
28204
28205C...Separate valence and sea parts of parton distribution.
28206 IF(KFA.NE.22) THEN
28207 XFV1=XPA(KFV1)-XPA(-KFV1)
28208 XPA(KFV1)=XPA(-KFV1)
28209 XFV2=XPA(KFV2)-XPA(-KFV2)
28210 XPA(KFV2)=XPA(-KFV2)
28211 ELSE
28212 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
28213 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
28214 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
28215 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
28216 ENDIF
28217
28218C...Dampen valence and sea separately. Put back together.
28219 DO 120 KFL=-25,25
28220 XPQ(KFL)=FS*XPA(KFL)
28221 120 CONTINUE
28222 IF(KFA.NE.22) THEN
28223 XPQ(KFV1)=XPQ(KFV1)+FV*XFV1
28224 XPQ(KFV2)=XPQ(KFV2)+FV*XFV2
28225 ELSE
28226 XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232)
28227 XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232)
28228 XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232)
28229 XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232)
28230 ENDIF
28231 MINT(92)=2
28232
28233C...Large Q2 and small x: interpolate behaviour.
28234 ELSEIF(Q2.GT.Q2MN) THEN
28235
28236C...Evaluate at extremes and define coefficients for interpolation.
28237 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
28238 VI232A=VINT(232)
28239 CALL PYPDFU(KFC,X,Q2B,XPB)
28240 VI232B=VINT(232)
28241 FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN)
28242 FVA=(X/XMN)**0.45D0*FLA
28243 FSA=(X/XMN)**(-0.08D0)*FLA
28244 FB=1D0-FLA
28245
28246C...Separate valence and sea parts of parton distribution.
28247 IF(KFA.NE.22) THEN
28248 XFVA1=XPA(KFV1)-XPA(-KFV1)
28249 XPA(KFV1)=XPA(-KFV1)
28250 XFVA2=XPA(KFV2)-XPA(-KFV2)
28251 XPA(KFV2)=XPA(-KFV2)
28252 XFVB1=XPB(KFV1)-XPB(-KFV1)
28253 XPB(KFV1)=XPB(-KFV1)
28254 XFVB2=XPB(KFV2)-XPB(-KFV2)
28255 XPB(KFV2)=XPB(-KFV2)
28256 ELSE
28257 XPA(KFV1)=XPA(KFV1)-WTV1*VI232A
28258 XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A
28259 XPA(KFV2)=XPA(KFV2)-WTV2*VI232A
28260 XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A
28261 XPB(KFV1)=XPB(KFV1)-WTV1*VI232B
28262 XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B
28263 XPB(KFV2)=XPB(KFV2)-WTV2*VI232B
28264 XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B
28265 ENDIF
28266
28267C...Interpolate for valence and sea. Put back together.
28268 DO 130 KFL=-25,25
28269 XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL)
28270 130 CONTINUE
28271 IF(KFA.NE.22) THEN
28272 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1)
28273 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2)
28274 ELSE
28275 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
28276 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
28277 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
28278 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
28279 ENDIF
28280 MINT(92)=3
28281
28282C...Small Q2 and small x: dampen boundary value and add term.
28283 ELSE
28284
28285C...Evaluate at boundary and define dampening factors.
28286 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
28287 FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN)
28288 FA=1D0-FB
28289 FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0
28290 FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0
28291 FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0
28292 FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0
28293 FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0
28294 FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0
28295
28296C...Separate valence and sea parts of parton distribution.
28297 IF(KFA.NE.22) THEN
28298 XFV1=XPA(KFV1)-XPA(-KFV1)
28299 XPA(KFV1)=XPA(-KFV1)
28300 XFV2=XPA(KFV2)-XPA(-KFV2)
28301 XPA(KFV2)=XPA(-KFV2)
28302 ELSE
28303 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
28304 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
28305 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
28306 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
28307 ENDIF
28308
28309C...Dampen valence and sea separately. Add constant terms.
28310C...Put back together.
28311 DO 140 KFL=-25,25
28312 XPQ(KFL)=FSA*XPA(KFL)
28313 140 CONTINUE
28314 IF(KFA.NE.22) THEN
28315 DO 150 KFL=-3,3
28316 XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL)
28317 150 CONTINUE
28318 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1)
28319 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2)
28320 ELSE
28321 DO 160 KFL=-3,3
28322 XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL)
28323 160 CONTINUE
28324 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
28325 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
28326 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
28327 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
28328 ENDIF
28329 XPQ(21)=XPQ(0)
28330 MINT(92)=4
28331 ENDIF
28332
28333C...Format for error printout.
28334 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
28335
28336 RETURN
28337 END
28338
28339C*********************************************************************
28340
28341C...PYPDEL
28342C...Gives electron (or muon, or tau) parton distribution.
28343
28344 SUBROUTINE PYPDEL(KFA,X,Q2,XPEL)
28345
28346C...Double precision and integer declarations.
28347 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28348 IMPLICIT INTEGER(I-N)
28349 INTEGER PYK,PYCHGE,PYCOMP
28350C...Commonblocks.
28351 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28352 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28353 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28354 COMMON/PYINT1/MINT(400),VINT(400)
28355 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
28356C...Local arrays.
28357 DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6)
28358
28359C...Interface to PDFLIB.
81935ff8 28360 COMMON/LW50513/XMIN,XMAX,Q2MIN,Q2MAX
28361 SAVE /LW50513/
2dfa57d1 28362 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
28363 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
28364 CHARACTER*20 PARM(20)
28365 DATA VALUE/20*0D0/,PARM/20*' '/
28366
28367C...Some common constants.
28368 DO 100 KFL=-25,25
28369 XPEL(KFL)=0D0
28370 100 CONTINUE
28371 AEM=PARU(101)
28372 PME=PMAS(11,1)
28373 IF(KFA.EQ.13) PME=PMAS(13,1)
28374 IF(KFA.EQ.15) PME=PMAS(15,1)
28375 XL=LOG(MAX(1D-10,X))
28376 X1L=LOG(MAX(1D-10,1D0-X))
28377 HLE=LOG(MAX(3D0,Q2/PME**2))
28378 HBE2=(AEM/PARU(1))*(HLE-1D0)
28379
28380C...Electron inside electron, see R. Kleiss et al., in Z physics at
28381C...LEP 1, CERN 89-08, p. 34
28382 IF(MSTP(59).LE.1) THEN
28383 HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2*
28384 & (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0)
28385 HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))-
28386 & 0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)-
28387 & 4D0*XL/(1D0-X)-5D0-X)
28388 ELSE
28389 HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/
28390 & PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*
28391 & (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X)
28392 ENDIF
28393C...Zero distribution for very large x and rescale it for intermediate.
28394 IF(X.GT.1D0-1D-10) THEN
28395 HEE=0D0
28396 ELSEIF(X.GT.1D0-1D-7) THEN
28397 HEE=HEE*1000D0**HBE2/(1000D0**HBE2-1D0)
28398 ENDIF
28399 XPEL(KFA)=X*HEE
28400
28401C...Photon and (transverse) W- inside electron.
28402 AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2)
28403 IF(MSTP(13).LE.1) THEN
28404 HLG=HLE
28405 ELSE
28406 HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2))
28407 ENDIF
28408 XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2)
28409 HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102))
28410 XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2)
28411
28412C...Electron or positron inside photon inside electron.
28413 IF(KFA.EQ.11.AND.MSTP(12).EQ.1) THEN
28414 XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+
28415 & 2D0*X*(1D0+X)*XL)
28416 XPEL(11)=XPEL(11)+XFSEA
28417 XPEL(-11)=XFSEA
28418
28419C...Initialize PDFLIB photon parton distributions.
28420 IF(MSTP(56).EQ.2) THEN
28421 PARM(1)='NPTYPE'
28422 VALUE(1)=3
28423 PARM(2)='NGROUP'
28424 VALUE(2)=MSTP(55)/1000
28425 PARM(3)='NSET'
28426 VALUE(3)=MOD(MSTP(55),1000)
28427 IF(MINT(93).NE.3000000+MSTP(55)) THEN
28428 CALL PDFSET(PARM,VALUE)
28429 MINT(93)=3000000+MSTP(55)
28430 ENDIF
28431 ENDIF
28432
28433C...Quarks and gluons inside photon inside electron:
28434C...numerical convolution required.
28435 DO 110 KFL=0,6
28436 SXP(KFL)=0D0
28437 110 CONTINUE
28438 SUMXPP=0D0
28439 ITER=-1
28440 120 ITER=ITER+1
28441 SUMXP=SUMXPP
28442 NSTP=2**(ITER-1)
28443 IF(ITER.EQ.0) NSTP=2
28444 DO 130 KFL=0,6
28445 SXP(KFL)=0.5D0*SXP(KFL)
28446 130 CONTINUE
28447 WTSTP=0.5D0/NSTP
28448 IF(ITER.EQ.0) WTSTP=0.5D0
28449C...Pick grid of x_{gamma} values logarithmically even.
28450 DO 150 ISTP=1,NSTP
28451 IF(ITER.EQ.0) THEN
28452 XLE=XL*(ISTP-1)
28453 ELSE
28454 XLE=XL*(ISTP-0.5D0)/NSTP
28455 ENDIF
28456 XE=MIN(1D0-1D-10,EXP(XLE))
28457 XG=MIN(1D0-1D-10,X/XE)
28458C...Evaluate photon inside electron parton distribution for convolution.
28459 XPGP=1D0+(1D0-XE)**2
28460 IF(MSTP(13).LE.1) THEN
28461 XPGP=XPGP*HLE
28462 ELSE
28463 XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2))
28464 ENDIF
28465C...Evaluate photon parton distributions for convolution.
28466 IF(MSTP(56).EQ.1) THEN
28467 IF(MSTP(55).EQ.1) THEN
28468 CALL PYPDGA(XG,Q2,XPGA)
28469 ELSEIF(MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
28470 Q2MX=Q2
28471 P2MX=0.36D0
28472 IF(MSTP(55).GE.7) P2MX=4.0D0
28473 IF(MSTP(57).EQ.0) Q2MX=P2MX
28474 P2=0D0
28475 IF(VINT(120).LT.0D0) P2=VINT(120)**2
28476 CALL PYGGAM(MSTP(55)-4,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
28477 VINT(231)=P2MX
28478 ELSEIF(MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
28479 Q2MX=Q2
28480 P2MX=0.36D0
28481 IF(MSTP(55).GE.11) P2MX=4.0D0
28482 IF(MSTP(57).EQ.0) Q2MX=P2MX
28483 P2=0D0
28484 IF(VINT(120).LT.0D0) P2=VINT(120)**2
28485 CALL PYGGAM(MSTP(55)-8,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
28486 VINT(231)=P2MX
28487 ENDIF
28488 DO 140 KFL=0,5
28489 SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL)
28490 140 CONTINUE
28491 ELSEIF(MSTP(56).EQ.2) THEN
28492C...Call PDFLIB parton distributions.
28493 XX=XG
28494 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
28495 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
28496 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
28497 SXP(0)=SXP(0)+WTSTP*XPGP*GLU
28498 SXP(1)=SXP(1)+WTSTP*XPGP*DNV
28499 SXP(2)=SXP(2)+WTSTP*XPGP*UPV
28500 SXP(3)=SXP(3)+WTSTP*XPGP*STR
28501 SXP(4)=SXP(4)+WTSTP*XPGP*CHM
28502 SXP(5)=SXP(5)+WTSTP*XPGP*BOT
28503 SXP(6)=SXP(6)+WTSTP*XPGP*TOP
28504 ENDIF
28505 150 CONTINUE
28506 SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2)
28507 IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT.
28508 & PARP(14)*(SUMXPP+SUMXP))) GOTO 120
28509
28510C...Put convolution into output arrays.
28511 FCONV=AEMP*(-XL)
28512 XPEL(0)=FCONV*SXP(0)
28513 DO 160 KFL=1,6
28514 XPEL(KFL)=FCONV*SXP(KFL)
28515 XPEL(-KFL)=XPEL(KFL)
28516 160 CONTINUE
28517 ENDIF
28518
28519 RETURN
28520 END
28521
28522C*********************************************************************
28523
28524C...PYPDGA
28525C...Gives photon parton distribution.
28526
28527 SUBROUTINE PYPDGA(X,Q2,XPGA)
28528
28529C...Double precision and integer declarations.
28530 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28531 IMPLICIT INTEGER(I-N)
28532 INTEGER PYK,PYCHGE,PYCOMP
28533C...Commonblocks.
28534 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28535 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28536 COMMON/PYINT1/MINT(400),VINT(400)
28537 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
28538C...Local arrays.
28539 DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3),
28540 &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3),
28541 &DGCS(4,3),DGDS(4,3),DGES(4,3)
28542
28543C...The following data lines are coefficients needed in the
28544C...Drees and Grassie photon parton distribution parametrization.
28545 DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0,
28546 &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/
28547 DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0,
28548 &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/
28549 DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0,
28550 &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/
28551 DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0,
28552 &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/
28553 DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0,
28554 &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/
28555 DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1,
28556 &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/
28557 DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0,
28558 &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/
28559 DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0,
28560 &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/
28561 DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0,
28562 &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/
28563 DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0,
28564 &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/
28565 DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0,
28566 &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/
28567 DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0,
28568 &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/
28569 DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0,
28570 &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/
28571
28572C...Photon parton distribution from Drees and Grassie.
28573C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
28574 DO 100 KFL=-6,6
28575 XPGA(KFL)=0D0
28576 100 CONTINUE
28577 VINT(231)=1D0
28578 IF(MSTP(57).LE.0) THEN
28579 T=LOG(1D0/0.16D0)
28580 ELSE
28581 T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0)
28582 ENDIF
28583 X1=1D0-X
28584 NF=3
28585 IF(Q2.GT.25D0) NF=4
28586 IF(Q2.GT.300D0) NF=5
28587 NFE=NF-2
28588 AEM=PARU(101)
28589
28590C...Evaluate gluon content.
28591 DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE))
28592 DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE))
28593 DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE))
28594 XPGL=DGA*X**DGB*X1**DGC
28595
28596C...Evaluate up- and down-type quark content.
28597 DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE))
28598 DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE))
28599 DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE))
28600 DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE))
28601 DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE))
28602 XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
28603 DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE))
28604 DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE))
28605 DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE))
28606 DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE))
28607 DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE))
28608 DGF=9D0
28609 IF(NF.EQ.4) DGF=10D0
28610 IF(NF.EQ.5) DGF=55D0/6D0
28611 XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
28612 IF(NF.LE.3) THEN
28613 XPQU=(XPQS+9D0*XPQN)/6D0
28614 XPQD=(XPQS-4.5D0*XPQN)/6D0
28615 ELSEIF(NF.EQ.4) THEN
28616 XPQU=(XPQS+6D0*XPQN)/8D0
28617 XPQD=(XPQS-6D0*XPQN)/8D0
28618 ELSE
28619 XPQU=(XPQS+7.5D0*XPQN)/10D0
28620 XPQD=(XPQS-5D0*XPQN)/10D0
28621 ENDIF
28622
28623C...Put into output arrays.
28624 XPGA(0)=AEM*XPGL
28625 XPGA(1)=AEM*XPQD
28626 XPGA(2)=AEM*XPQU
28627 XPGA(3)=AEM*XPQD
28628 IF(NF.GE.4) XPGA(4)=AEM*XPQU
28629 IF(NF.GE.5) XPGA(5)=AEM*XPQD
28630 DO 110 KFL=1,6
28631 XPGA(-KFL)=XPGA(KFL)
28632 110 CONTINUE
28633
28634 RETURN
28635 END
28636
28637C*********************************************************************
28638
28639C...PYGGAM
28640C...Constructs the F2 and parton distributions of the photon
28641C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
28642C...For F2, c and b are included by the Bethe-Heitler formula;
28643C...in the 'MSbar' scheme additionally a Cgamma term is added.
28644C...Contains the SaS sets 1D, 1M, 2D and 2M.
28645C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
28646
28647 SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
28648
28649C...Double precision and integer declarations.
28650 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28651 IMPLICIT INTEGER(I-N)
28652 INTEGER PYK,PYCHGE,PYCOMP
28653C...Commonblocks.
28654 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
28655 &XPDIR(-6:6)
28656 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
28657 SAVE /PYINT8/,/PYINT9/
28658C...Local arrays.
28659 DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6)
28660C...Charm and bottom masses (low to compensate for J/psi etc.).
28661 DATA PMC/1.3D0/, PMB/4.6D0/
28662C...alpha_em and alpha_em/(2*pi).
28663 DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/
28664C...Lambda value for 4 flavours.
28665 DATA ALAM/0.20D0/
28666C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
28667 DATA FRACU/0.8D0/
28668C...VMD couplings f_V**2/(4*pi).
28669 DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/
28670C...Masses for rho (=omega) and phi.
28671 DATA PMRHO/0.770D0/, PMPHI/1.020D0/
28672C...Number of points in integration for IP2=1.
28673 DATA NSTEP/100/
28674
28675C...Reset output.
28676 F2GM=0D0
28677 DO 100 KFL=-6,6
28678 XPDFGM(KFL)=0D0
28679 XPVMD(KFL)=0D0
28680 XPANL(KFL)=0D0
28681 XPANH(KFL)=0D0
28682 XPBEH(KFL)=0D0
28683 XPDIR(KFL)=0D0
28684 VXPVMD(KFL)=0D0
28685 VXPANL(KFL)=0D0
28686 VXPANH(KFL)=0D0
28687 VXPDGM(KFL)=0D0
28688 100 CONTINUE
28689
28690C...Set Q0 cut-off parameter as function of set used.
28691 IF(ISET.LE.2) THEN
28692 Q0=0.6D0
28693 ELSE
28694 Q0=2D0
28695 ENDIF
28696 Q02=Q0**2
28697
28698C...Scale choice for off-shell photon; common factors.
28699 Q2A=Q2
28700 FACNOR=1D0
28701 IF(IP2.EQ.1) THEN
28702 P2MX=P2+Q02
28703 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
28704 FACNOR=LOG(Q2/Q02)/NSTEP
28705 ELSEIF(IP2.EQ.2) THEN
28706 P2MX=MAX(P2,Q02)
28707 ELSEIF(IP2.EQ.3) THEN
28708 P2MX=P2+Q02
28709 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
28710 ELSEIF(IP2.EQ.4) THEN
28711 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
28712 & ((Q2+P2)*(Q02+P2)))
28713 ELSEIF(IP2.EQ.5) THEN
28714 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
28715 & ((Q2+P2)*(Q02+P2)))
28716 P2MX=Q0*SQRT(P2MXA)
28717 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
28718 ELSEIF(IP2.EQ.6) THEN
28719 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
28720 & ((Q2+P2)*(Q02+P2)))
28721 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
28722 ELSE
28723 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
28724 & ((Q2+P2)*(Q02+P2)))
28725 P2MX=Q0*SQRT(P2MXA)
28726 P2MXB=P2MX
28727 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
28728 P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA
28729 IF(ABS(Q2-Q02).GT.1D-6) THEN
28730 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
28731 ELSEIF(P2.LT.Q02) THEN
28732 FACNOR=Q02**3/(Q02+P2)/(Q02**2-P2**2/2D0)
28733 ELSE
28734 FACNOR=1D0
28735 ENDIF
28736 ENDIF
28737
28738C...Call VMD parametrization for d quark and use to give rho, omega,
28739C...phi. Note dipole dampening for off-shell photon.
28740 CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
28741 XFVAL=VXPGA(1)
28742 XPGA(1)=XPGA(2)
28743 XPGA(-1)=XPGA(-2)
28744 FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
28745 FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
28746 DO 110 KFL=-5,5
28747 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
28748 110 CONTINUE
28749 XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL
28750 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
28751 XPVMD(3)=XPVMD(3)+FACS*XFVAL
28752 XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL
28753 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
28754 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
28755 VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL
28756 VXPVMD(2)=FRACU*FACUD*XFVAL
28757 VXPVMD(3)=FACS*XFVAL
28758 VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL
28759 VXPVMD(-2)=FRACU*FACUD*XFVAL
28760 VXPVMD(-3)=FACS*XFVAL
28761
28762 IF(IP2.NE.1) THEN
28763C...Anomalous parametrizations for different strategies
28764C...for off-shell photons; except full integration.
28765
28766C...Call anomalous parametrization for d + u + s.
28767 CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
28768 DO 120 KFL=-5,5
28769 XPANL(KFL)=FACNOR*XPGA(KFL)
28770 VXPANL(KFL)=FACNOR*VXPGA(KFL)
28771 120 CONTINUE
28772
28773C...Call anomalous parametrization for c and b.
28774 CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
28775 DO 130 KFL=-5,5
28776 XPANH(KFL)=FACNOR*XPGA(KFL)
28777 VXPANH(KFL)=FACNOR*VXPGA(KFL)
28778 130 CONTINUE
28779 CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
28780 DO 140 KFL=-5,5
28781 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
28782 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
28783 140 CONTINUE
28784
28785 ELSE
28786C...Special option: loop over flavours and integrate over k2.
28787 DO 170 KF=1,5
28788 DO 160 ISTEP=1,NSTEP
28789 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP)
28790 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
28791 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
28792 CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
28793 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
28794 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0)
28795 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0)
28796 DO 150 KFL=-5,5
28797 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
28798 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
28799 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
28800 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
28801 150 CONTINUE
28802 160 CONTINUE
28803 170 CONTINUE
28804 ENDIF
28805
28806C...Call Bethe-Heitler term expression for charm and bottom.
28807 CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH)
28808 XPBEH(4)=XPBH
28809 XPBEH(-4)=XPBH
28810 CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH)
28811 XPBEH(5)=XPBH
28812 XPBEH(-5)=XPBH
28813
28814C...For MSbar subtraction call C^gamma term expression for d, u, s.
28815 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
28816 CALL PYGDIR(X,Q2,P2,Q02,XPGA)
28817 DO 180 KFL=-5,5
28818 XPDIR(KFL)=XPGA(KFL)
28819 180 CONTINUE
28820 ENDIF
28821
28822C...Store result in output array.
28823 DO 190 KFL=-5,5
28824 CHSQ=1D0/9D0
28825 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0
28826 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
28827 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
28828 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
28829 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
28830 190 CONTINUE
28831
28832 RETURN
28833 END
28834
28835C*********************************************************************
28836
28837C...PYGVMD
28838C...Evaluates the VMD parton distributions of a photon,
28839C...evolved homogeneously from an initial scale P2 to Q2.
28840C...Does not include dipole suppression factor.
28841C...ISET is parton distribution set, see above;
28842C...additionally ISET=0 is used for the evolution of an anomalous photon
28843C...which branched at a scale P2 and then evolved homogeneously to Q2.
28844C...ALAM is the 4-flavour Lambda, which is automatically converted
28845C...to 3- and 5-flavour equivalents as needed.
28846C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
28847
28848 SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
28849
28850C...Double precision and integer declarations.
28851 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28852 IMPLICIT INTEGER(I-N)
28853 INTEGER PYK,PYCHGE,PYCOMP
28854C...Local arrays and data.
28855 DIMENSION XPGA(-6:6), VXPGA(-6:6)
28856 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
28857
28858C...Reset output.
28859 DO 100 KFL=-6,6
28860 XPGA(KFL)=0D0
28861 VXPGA(KFL)=0D0
28862 100 CONTINUE
28863 KFA=IABS(KF)
28864
28865C...Calculate Lambda; protect against unphysical Q2 and P2 input.
28866 ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
28867 ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
28868 P2EFF=MAX(P2,1.2D0*ALAM3**2)
28869 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
28870 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
28871 Q2EFF=MAX(Q2,P2EFF)
28872
28873C...Find number of flavours at lower and upper scale.
28874 NFP=4
28875 IF(P2EFF.LT.PMC**2) NFP=3
28876 IF(P2EFF.GT.PMB**2) NFP=5
28877 NFQ=4
28878 IF(Q2EFF.LT.PMC**2) NFQ=3
28879 IF(Q2EFF.GT.PMB**2) NFQ=5
28880
28881C...Find s as sum of 3-, 4- and 5-flavour parts.
28882 S=0D0
28883 IF(NFP.EQ.3) THEN
28884 Q2DIV=PMC**2
28885 IF(NFQ.EQ.3) Q2DIV=Q2EFF
28886 S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
28887 ENDIF
28888 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
28889 P2DIV=P2EFF
28890 IF(NFP.EQ.3) P2DIV=PMC**2
28891 Q2DIV=Q2EFF
28892 IF(NFQ.EQ.5) Q2DIV=PMB**2
28893 S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
28894 ENDIF
28895 IF(NFQ.EQ.5) THEN
28896 P2DIV=PMB**2
28897 IF(NFP.EQ.5) P2DIV=P2EFF
28898 S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
28899 ENDIF
28900
28901C...Calculate frequent combinations of x and s.
28902 X1=1D0-X
28903 XL=-LOG(X)
28904 S2=S**2
28905 S3=S**3
28906 S4=S**4
28907
28908C...Evaluate homogeneous anomalous parton distributions below or
28909C...above threshold.
28910 IF(ISET.EQ.0) THEN
28911 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
28912 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
28913 XVAL = X * 1.5D0 * (X**2+X1**2)
28914 XGLU = 0D0
28915 XSEA = 0D0
28916 ELSE
28917 XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
28918 & (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
28919 & 5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
28920 & X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
28921 XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
28922 & X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
28923 & ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
28924 XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
28925 & X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
28926 & ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
28927 & (2D0*X-1D0)*X*XL**2)
28928 ENDIF
28929
28930C...Evaluate set 1D parton distributions below or above threshold.
28931 ELSEIF(ISET.EQ.1) THEN
28932 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
28933 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
28934 XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
28935 XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
28936 XSEA = 0.100D0 * X1**3.76D0
28937 ELSE
28938 XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
28939 & X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
28940 XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
28941 & X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
28942 & XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
28943 & X**0.40D0 * X1**(1.76D0+3D0*S)
28944 XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
28945 & (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
28946 & X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
28947 XSEA0 = 0.100D0 * X1**3.76D0
28948 ENDIF
28949
28950C...Evaluate set 1M parton distributions below or above threshold.
28951 ELSEIF(ISET.EQ.2) THEN
28952 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
28953 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
28954 XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
28955 XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
28956 XSEA = 0D0
28957 ELSE
28958 XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
28959 & X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
28960 XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
28961 & EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
28962 & X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
28963 & EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
28964 XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
28965 & X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
28966 & XL**(2.8D0*S)
28967 XSEA0 = 0D0
28968 ENDIF
28969
28970C...Evaluate set 2D parton distributions below or above threshold.
28971 ELSEIF(ISET.EQ.3) THEN
28972 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
28973 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
28974 XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
28975 XGLU = 1.925D0 * X1**2
28976 XSEA = 0.242D0 * X1**4
28977 ELSE
28978 XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
28979 & X**(0.46D0+0.25D0*S) *
28980 & X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
28981 & (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
28982 XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
28983 & EXP(-18.67D0*S) *
28984 & X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
28985 & * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
28986 & XL**(9.3D0*S/(1D0+1.7D0*S))
28987 XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
28988 & (1D0-0.607D0*S+21.95D0*S2) *
28989 & X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
28990 XSEA0 = 0.242D0 * X1**4
28991 ENDIF
28992
28993C...Evaluate set 2M parton distributions below or above threshold.
28994 ELSEIF(ISET.EQ.4) THEN
28995 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
28996 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
28997 XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
28998 XGLU = 1.808D0 * X1**2
28999 XSEA = 0.209D0 * X1**4
29000 ELSE
29001 XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
29002 & X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
29003 & X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
29004 & XL**(5.15D0*S/(1D0+2D0*S)) +
29005 & (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
29006 XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
29007 & X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
29008 & X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
29009 & XL**(10.9D0*S/(1D0+2.5D0*S))
29010 XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
29011 & X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
29012 & X1**(4D0+S) * XL**(0.45D0*S)
29013 XSEA0 = 0.209D0 * X1**4
29014 ENDIF
29015 ENDIF
29016
29017C...Threshold factors for c and b sea.
29018 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
29019 XCHM=0D0
29020 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
29021 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
29022 IF(ISET.EQ.0) THEN
29023 XCHM=XSEA*(1D0-(SCH/SLL)**2)
29024 ELSE
29025 XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
29026 ENDIF
29027 ENDIF
29028 XBOT=0D0
29029 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
29030 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
29031 IF(ISET.EQ.0) THEN
29032 XBOT=XSEA*(1D0-(SBT/SLL)**2)
29033 ELSE
29034 XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
29035 ENDIF
29036 ENDIF
29037
29038C...Fill parton distributions.
29039 XPGA(0)=XGLU
29040 XPGA(1)=XSEA
29041 XPGA(2)=XSEA
29042 XPGA(3)=XSEA
29043 XPGA(4)=XCHM
29044 XPGA(5)=XBOT
29045 XPGA(KFA)=XPGA(KFA)+XVAL
29046 DO 110 KFL=1,5
29047 XPGA(-KFL)=XPGA(KFL)
29048 110 CONTINUE
29049 VXPGA(KFA)=XVAL
29050 VXPGA(-KFA)=XVAL
29051
29052 RETURN
29053 END
29054
29055C*********************************************************************
29056
29057C...PYGANO
29058C...Evaluates the parton distributions of the anomalous photon,
29059C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
29060C...KF=0 gives the sum over (up to) 5 flavours,
29061C...KF<0 limits to flavours up to abs(KF),
29062C...KF>0 is for flavour KF only.
29063C...ALAM is the 4-flavour Lambda, which is automatically converted
29064C...to 3- and 5-flavour equivalents as needed.
29065C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
29066
29067 SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
29068
29069C...Double precision and integer declarations.
29070 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29071 IMPLICIT INTEGER(I-N)
29072 INTEGER PYK,PYCHGE,PYCOMP
29073C...Local arrays and data.
29074 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
29075 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
29076
29077C...Reset output.
29078 DO 100 KFL=-6,6
29079 XPGA(KFL)=0D0
29080 VXPGA(KFL)=0D0
29081 100 CONTINUE
29082 IF(Q2.LE.P2) RETURN
29083 KFA=IABS(KF)
29084
29085C...Calculate Lambda; protect against unphysical Q2 and P2 input.
29086 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2
29087 ALAMSQ(4)=ALAM**2
29088 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2
29089 P2EFF=MAX(P2,1.2D0*ALAMSQ(3))
29090 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
29091 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
29092 Q2EFF=MAX(Q2,P2EFF)
29093 XL=-LOG(X)
29094
29095C...Find number of flavours at lower and upper scale.
29096 NFP=4
29097 IF(P2EFF.LT.PMC**2) NFP=3
29098 IF(P2EFF.GT.PMB**2) NFP=5
29099 NFQ=4
29100 IF(Q2EFF.LT.PMC**2) NFQ=3
29101 IF(Q2EFF.GT.PMB**2) NFQ=5
29102
29103C...Define range of flavour loop.
29104 IF(KF.EQ.0) THEN
29105 KFLMN=1
29106 KFLMX=5
29107 ELSEIF(KF.LT.0) THEN
29108 KFLMN=1
29109 KFLMX=KFA
29110 ELSE
29111 KFLMN=KFA
29112 KFLMX=KFA
29113 ENDIF
29114
29115C...Loop over flavours the photon can branch into.
29116 DO 110 KFL=KFLMN,KFLMX
29117
29118C...Light flavours: calculate t range and (approximate) s range.
29119 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
29120 TDIFF=LOG(Q2EFF/P2EFF)
29121 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
29122 & LOG(P2EFF/ALAMSQ(NFQ)))
29123 IF(NFQ.GT.NFP) THEN
29124 Q2DIV=PMB**2
29125 IF(NFQ.EQ.4) Q2DIV=PMC**2
29126 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
29127 & LOG(P2EFF/ALAMSQ(NFQ)))
29128 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
29129 & LOG(P2EFF/ALAMSQ(NFQ-1)))
29130 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
29131 ENDIF
29132 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
29133 Q2DIV=PMC**2
29134 SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
29135 & LOG(P2EFF/ALAMSQ(4)))
29136 SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
29137 & LOG(P2EFF/ALAMSQ(3)))
29138 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
29139 ENDIF
29140
29141C...u and s quark do not need a separate treatment when d has been done.
29142 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
29143
29144C...Charm: as above, but only include range above c threshold.
29145 ELSEIF(KFL.EQ.4) THEN
29146 IF(Q2.LE.PMC**2) GOTO 110
29147 P2EFF=MAX(P2EFF,PMC**2)
29148 Q2EFF=MAX(Q2EFF,P2EFF)
29149 TDIFF=LOG(Q2EFF/P2EFF)
29150 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
29151 & LOG(P2EFF/ALAMSQ(NFQ)))
29152 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
29153 Q2DIV=PMB**2
29154 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
29155 & LOG(P2EFF/ALAMSQ(NFQ)))
29156 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
29157 & LOG(P2EFF/ALAMSQ(NFQ-1)))
29158 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
29159 ENDIF
29160
29161C...Bottom: as above, but only include range above b threshold.
29162 ELSEIF(KFL.EQ.5) THEN
29163 IF(Q2.LE.PMB**2) GOTO 110
29164 P2EFF=MAX(P2EFF,PMB**2)
29165 Q2EFF=MAX(Q2,P2EFF)
29166 TDIFF=LOG(Q2EFF/P2EFF)
29167 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
29168 & LOG(P2EFF/ALAMSQ(NFQ)))
29169 ENDIF
29170
29171C...Evaluate flavour-dependent prefactor (charge^2 etc.).
29172 CHSQ=1D0/9D0
29173 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0
29174 FAC=AEM2PI*2D0*CHSQ*TDIFF
29175
29176C...Evaluate parton distributions (normalized to unit momentum sum).
29177 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
29178 XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 +
29179 & (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 +
29180 & 1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) *
29181 & X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S))
29182 XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) *
29183 & X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) *
29184 & ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL)
29185 XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) *
29186 & X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) *
29187 & ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 +
29188 & (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2)
29189
29190C...Threshold factors for c and b sea.
29191 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
29192 XCHM=0D0
29193 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
29194 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
29195 XCHM=XSEA*(1D0-(SCH/SLL)**3)
29196 ENDIF
29197 XBOT=0D0
29198 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
29199 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
29200 XBOT=XSEA*(1D0-(SBT/SLL)**3)
29201 ENDIF
29202 ENDIF
29203
29204C...Add contribution of each valence flavour.
29205 XPGA(0)=XPGA(0)+FAC*XGLU
29206 XPGA(1)=XPGA(1)+FAC*XSEA
29207 XPGA(2)=XPGA(2)+FAC*XSEA
29208 XPGA(3)=XPGA(3)+FAC*XSEA
29209 XPGA(4)=XPGA(4)+FAC*XCHM
29210 XPGA(5)=XPGA(5)+FAC*XBOT
29211 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
29212 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
29213 110 CONTINUE
29214 DO 120 KFL=1,5
29215 XPGA(-KFL)=XPGA(KFL)
29216 VXPGA(-KFL)=VXPGA(KFL)
29217 120 CONTINUE
29218
29219 RETURN
29220 END
29221
29222C*********************************************************************
29223
29224C...PYGBEH
29225C...Evaluates the Bethe-Heitler cross section for heavy flavour
29226C...production.
29227C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
29228
29229 SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)
29230
29231C...Double precision and integer declarations.
29232 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29233 IMPLICIT INTEGER(I-N)
29234 INTEGER PYK,PYCHGE,PYCOMP
29235
29236C...Local data.
29237 DATA AEM2PI/0.0011614D0/
29238
29239C...Reset output.
29240 XPBH=0D0
29241 SIGBH=0D0
29242
29243C...Check kinematics limits.
29244 IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
29245 W2=Q2*(1D0-X)/X-P2
29246 BETA2=1D0-4D0*PM2/W2
29247 IF(BETA2.LT.1D-10) RETURN
29248 BETA=SQRT(BETA2)
29249 RMQ=4D0*PM2/Q2
29250
29251C...Simple case: P2 = 0.
29252 IF(P2.LT.1D-4) THEN
29253 IF(BETA.LT.0.99D0) THEN
29254 XBL=LOG((1D0+BETA)/(1D0-BETA))
29255 ELSE
29256 XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
29257 ENDIF
29258 SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
29259 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)
29260
29261C...Complicated case: P2 > 0, based on approximation of
29262C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
29263 ELSE
29264 RPQ=1D0-4D0*X**2*P2/Q2
29265 IF(RPQ.GT.1D-10) THEN
29266 RPBE=SQRT(RPQ*BETA2)
29267 IF(RPBE.LT.0.99D0) THEN
29268 XBL=LOG((1D0+RPBE)/(1D0-RPBE))
29269 XBI=2D0*RPBE/(1D0-RPBE**2)
29270 ELSE
29271 RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
29272 XBL=LOG((1D0+RPBE)**2/RPBESN)
29273 XBI=2D0*RPBE/RPBESN
29274 ENDIF
29275 SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
29276 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
29277 & XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
29278 ENDIF
29279 ENDIF
29280
29281C...Multiply by charge-squared etc. to get parton distribution.
29282 CHSQ=1D0/9D0
29283 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0
29284 XPBH=3D0*CHSQ*AEM2PI*X*SIGBH
29285
29286 RETURN
29287 END
29288
29289C*********************************************************************
29290
29291C...PYGDIR
29292C...Evaluates the direct contribution, i.e. the C^gamma term,
29293C...as needed in MSbar parametrizations.
29294C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
29295
29296 SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA)
29297
29298C...Double precision and integer declarations.
29299 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29300 IMPLICIT INTEGER(I-N)
29301 INTEGER PYK,PYCHGE,PYCOMP
29302C...Local array and data.
29303 DIMENSION XPGA(-6:6)
29304 DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/
29305
29306C...Reset output.
29307 DO 100 KFL=-6,6
29308 XPGA(KFL)=0D0
29309 100 CONTINUE
29310
29311C...Evaluate common x-dependent expression.
29312 XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0
29313 CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X))
29314
29315C...d, u, s part by simple charge factor.
29316 XPGA(1)=(1D0/9D0)*CGAM
29317 XPGA(2)=(4D0/9D0)*CGAM
29318 XPGA(3)=(1D0/9D0)*CGAM
29319
29320C...Also fill for antiquarks.
29321 DO 110 KF=1,5
29322 XPGA(-KF)=XPGA(KF)
29323 110 CONTINUE
29324
29325 RETURN
29326 END
29327
29328C*********************************************************************
29329
29330C...PYPDPI
29331C...Gives pi+ parton distribution according to two different
29332C...parametrizations.
29333
29334 SUBROUTINE PYPDPI(X,Q2,XPPI)
29335
29336C...Double precision and integer declarations.
29337 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29338 IMPLICIT INTEGER(I-N)
29339 INTEGER PYK,PYCHGE,PYCOMP
29340C...Commonblocks.
29341 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29342 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29343 COMMON/PYINT1/MINT(400),VINT(400)
29344 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
29345C...Local arrays.
29346 DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6)
29347
29348C...The following data lines are coefficients needed in the
29349C...Owens pion parton distribution parametrizations, see below.
29350C...Expansion coefficients for up and down valence quark distributions.
29351 DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
29352 &4.0000D-01, 7.0000D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
29353 &-6.2120D-02, 6.4780D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
29354 &-7.1090D-03, 1.3350D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
29355 DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
29356 &4.0000D-01, 6.2800D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
29357 &-5.9090D-02, 6.4360D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
29358 &-6.5240D-03, 1.4510D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
29359C...Expansion coefficients for gluon distribution.
29360 DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
29361 &8.8800D-01, 0.0000D+00, 3.1100D+00, 6.0000D+00, 0.0000D+00,
29362 &-1.8020D+00, -1.5760D+00, -1.3170D-01, 2.8010D+00, -1.7280D+01,
29363 &1.8120D+00, 1.2000D+00, 5.0680D-01, -1.2160D+01, 2.0490D+01/
29364 DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
29365 &7.9400D-01, 0.0000D+00, 2.8900D+00, 6.0000D+00, 0.0000D+00,
29366 &-9.1440D-01, -1.2370D+00, 5.9660D-01, -3.6710D+00, -8.1910D+00,
29367 &5.9660D-01, 6.5820D-01, -2.5500D-01, -2.3040D+00, 7.7580D+00/
29368C...Expansion coefficients for (up+down+strange) quark sea distribution.
29369 DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
29370 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
29371 &-2.4280D-01, -2.1200D-01, 8.6730D-01, 1.2660D+00, 2.3820D+00,
29372 &1.3860D-01, 3.6710D-03, 4.7470D-02, -2.2150D+00, 3.4820D-01/
29373 DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
29374 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
29375 &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00, 5.6210D-01,
29376 &-1.7400D-01, -9.6230D-02, 1.5750D+00, 1.3780D+00, -2.7010D-01/
29377C...Expansion coefficients for charm quark sea distribution.
29378 DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
29379 &0.0000D+00, -2.2120D-02, 2.8940D+00, 0.0000D+00, 0.0000D+00,
29380 &7.9280D-02, -3.7850D-01, 9.4330D+00, 5.2480D+00, 8.3880D+00,
29381 &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/
29382 DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
29383 &0.0000D+00, -8.8200D-02, 1.9240D+00, 0.0000D+00, 0.0000D+00,
29384 &6.2290D-02, -2.8920D-01, 2.4240D-01, -4.4630D+00, -8.3670D-01,
29385 &-4.0990D-02, -1.0820D-01, 2.0360D+00, 5.2090D+00, -4.8400D-02/
29386
29387C...Euler's beta function, requires ordinary Gamma function
29388 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
29389
29390C...Reset output array.
29391 DO 100 KFL=-6,6
29392 XPPI(KFL)=0D0
29393 100 CONTINUE
29394
29395 IF(MSTP(53).LE.2) THEN
29396C...Pion parton distributions from Owens.
29397C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
29398
29399C...Determine set, Lambda and s expansion variable.
29400 NSET=MSTP(53)
29401 IF(NSET.EQ.1) ALAM=0.2D0
29402 IF(NSET.EQ.2) ALAM=0.4D0
29403 VINT(231)=4D0
29404 IF(MSTP(57).LE.0) THEN
29405 SD=0D0
29406 ELSE
29407 Q2IN=MIN(2D3,MAX(4D0,Q2))
29408 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
29409 ENDIF
29410
29411C...Calculate parton distributions.
29412 DO 120 KFL=1,4
29413 DO 110 IS=1,5
29414 TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
29415 & COW(3,IS,KFL,NSET)*SD**2
29416 110 CONTINUE
29417 IF(KFL.EQ.1) THEN
29418 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0)
29419 ELSE
29420 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
29421 & TS(5)*X**2)
29422 ENDIF
29423 120 CONTINUE
29424
29425C...Put into output array.
29426 XPPI(0)=XQ(2)
29427 XPPI(1)=XQ(3)/6D0
29428 XPPI(2)=XQ(1)+XQ(3)/6D0
29429 XPPI(3)=XQ(3)/6D0
29430 XPPI(4)=XQ(4)
29431 XPPI(-1)=XQ(1)+XQ(3)/6D0
29432 XPPI(-2)=XQ(3)/6D0
29433 XPPI(-3)=XQ(3)/6D0
29434 XPPI(-4)=XQ(4)
29435
29436C...Leading order pion parton distributions from Glueck, Reya and Vogt.
29437C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
29438C...10^-5 < x < 1.
29439 ELSE
29440
29441C...Determine s expansion variable and some x expressions.
29442 VINT(231)=0.25D0
29443 IF(MSTP(57).LE.0) THEN
29444 SD=0D0
29445 ELSE
29446 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
29447 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
29448 ENDIF
29449 SD2=SD**2
29450 XL=-LOG(X)
29451 XS=SQRT(X)
29452
29453C...Evaluate valence, gluon and sea distributions.
29454 XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)*
29455 & (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD)
29456 XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0*
29457 & SD-0.175D0*SD2)+
29458 & (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+
29459 & SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0*
29460 & XL)))*
29461 & (1D0-X)**(0.390D0+1.053D0*SD)
29462 XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0-
29463 & X)**3.359D0*
29464 & EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0*
29465 & XL))/
29466 & XL**(2.538D0-0.763D0*SD)
29467 IF(SD.LE.0.888D0) THEN
29468 XFCHM=0D0
29469 ELSE
29470 XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+
29471 & 0.771D0*SD)*
29472 & EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0*
29473 & XL))
29474 ENDIF
29475 IF(SD.LE.1.351D0) THEN
29476 XFBOT=0D0
29477 ELSE
29478 XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)*
29479 & EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0*
29480 & XL))
29481 ENDIF
29482
29483C...Put into output array.
29484 XPPI(0)=XFGLU
29485 XPPI(1)=XFSEA
29486 XPPI(2)=XFSEA
29487 XPPI(3)=XFSEA
29488 XPPI(4)=XFCHM
29489 XPPI(5)=XFBOT
29490 DO 130 KFL=1,5
29491 XPPI(-KFL)=XPPI(KFL)
29492 130 CONTINUE
29493 XPPI(2)=XPPI(2)+XFVAL
29494 XPPI(-1)=XPPI(-1)+XFVAL
29495 ENDIF
29496
29497 RETURN
29498 END
29499
29500C*********************************************************************
29501
29502C...PYPDPR
29503C...Gives proton parton distributions according to a few different
29504C...parametrizations.
29505
29506 SUBROUTINE PYPDPR(X,Q2,XPPR)
29507
29508C...Double precision and integer declarations.
29509 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29510 IMPLICIT INTEGER(I-N)
29511 INTEGER PYK,PYCHGE,PYCOMP
29512C...Commonblocks.
29513 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29514 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29515 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29516 COMMON/PYINT1/MINT(400),VINT(400)
29517 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
29518C...Arrays and data.
29519 DIMENSION XPPR(-6:6),Q2MIN(16)
29520 DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0,
29521 &1.0D0, 1.0D0, 2*0D0, 0.25D0, 5D0, 5D0, 4D0, 4D0, 0D0/
29522
29523C...Reset output array.
29524 DO 100 KFL=-6,6
29525 XPPR(KFL)=0D0
29526 100 CONTINUE
29527
29528C...Common preliminaries.
29529 NSET=MAX(1,MIN(16,MSTP(51)))
29530 IF(NSET.EQ.9.OR.NSET.EQ.10) NSET=6
29531 VINT(231)=Q2MIN(NSET)
29532 IF(MSTP(57).EQ.0) THEN
29533 Q2L=Q2MIN(NSET)
29534 ELSE
29535 Q2L=MAX(Q2MIN(NSET),Q2)
29536 ENDIF
29537
29538 IF(NSET.GE.1.AND.NSET.LE.3) THEN
29539C...Interface to the CTEQ 3 parton distributions.
29540 QRT=SQRT(MAX(1D0,Q2L))
29541
29542C...Loop over flavours.
29543 DO 110 I=-6,6
29544 IF(I.LE.0) THEN
29545 XPPR(I)=PYCTEQ(NSET,I,X,QRT)
29546 ELSEIF(I.LE.2) THEN
29547 XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I)
29548 ELSE
29549 XPPR(I)=XPPR(-I)
29550 ENDIF
29551 110 CONTINUE
29552
29553 ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN
29554C...Interface to the GRV 94 distributions.
29555 IF(NSET.EQ.4) THEN
29556 CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
29557 ELSEIF(NSET.EQ.5) THEN
29558 CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
29559 ELSE
29560 CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
29561 ENDIF
29562
29563C...Put into output array.
29564 XPPR(0)=GL
29565 XPPR(-1)=0.5D0*(UDB+DEL)
29566 XPPR(-2)=0.5D0*(UDB-DEL)
29567 XPPR(-3)=SB
29568 XPPR(-4)=CHM
29569 XPPR(-5)=BOT
29570 XPPR(1)=DV+XPPR(-1)
29571 XPPR(2)=UV+XPPR(-2)
29572 XPPR(3)=SB
29573 XPPR(4)=CHM
29574 XPPR(5)=BOT
29575
29576 ELSEIF(NSET.EQ.7) THEN
29577C...Interface to the CTEQ 5L parton distributions.
29578C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by
29579C...freezing x*f(x,Q2) at borders.
29580 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
29581 XIN=MAX(1D-6,MIN(1D0,X))
29582
29583C...Loop over flavours (with u <-> d notation mismatch).
29584 SUMUDB=PYCT5L(-1,XIN,QRT)
29585 RATUDB=PYCT5L(-2,XIN,QRT)
29586 DO 120 I=-5,2
29587 IF(I.EQ.1) THEN
29588 XPPR(I)=XIN*PYCT5L(2,XIN,QRT)
29589 ELSEIF(I.EQ.2) THEN
29590 XPPR(I)=XIN*PYCT5L(1,XIN,QRT)
29591 ELSEIF(I.EQ.-1) THEN
29592 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
29593 ELSEIF(I.EQ.-2) THEN
29594 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
29595 ELSE
29596 XPPR(I)=XIN*PYCT5L(I,XIN,QRT)
29597 IF(I.LT.0) XPPR(-I)=XPPR(I)
29598 ENDIF
29599 120 CONTINUE
29600
29601 ELSEIF(NSET.EQ.8) THEN
29602C...Interface to the CTEQ 5M1 parton distributions.
29603 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
29604 XIN=MAX(1D-6,MIN(1D0,X))
29605
29606C...Loop over flavours (with u <-> d notation mismatch).
29607 SUMUDB=PYCT5M(-1,XIN,QRT)
29608 RATUDB=PYCT5M(-2,XIN,QRT)
29609 DO 130 I=-5,2
29610 IF(I.EQ.1) THEN
29611 XPPR(I)=XIN*PYCT5M(2,XIN,QRT)
29612 ELSEIF(I.EQ.2) THEN
29613 XPPR(I)=XIN*PYCT5M(1,XIN,QRT)
29614 ELSEIF(I.EQ.-1) THEN
29615 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
29616 ELSEIF(I.EQ.-2) THEN
29617 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
29618 ELSE
29619 XPPR(I)=XIN*PYCT5M(I,XIN,QRT)
29620 IF(I.LT.0) XPPR(-I)=XPPR(I)
29621 ENDIF
29622 130 CONTINUE
29623
29624 ELSEIF(NSET.GE.11.AND.NSET.LE.15) THEN
29625C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions:
29626C...obsolete but offers backwards compatibility.
29627 CALL PYPDPO(X,Q2L,XPPR)
29628
29629C...Symmetric choice for debugging only
29630 ELSEIF(NSET.EQ.16) THEN
29631 XPPR(0)=.5D0/X
29632 XPPR(1)=.05D0/X
29633 XPPR(2)=.05D0/X
29634 XPPR(3)=.05D0/X
29635 XPPR(4)=.05D0/X
29636 XPPR(5)=.05D0/X
29637 XPPR(-1)=.05D0/X
29638 XPPR(-2)=.05D0/X
29639 XPPR(-3)=.05D0/X
29640 XPPR(-4)=.05D0/X
29641 XPPR(-5)=.05D0/X
29642
29643 ENDIF
29644
29645 RETURN
29646 END
29647
29648C*********************************************************************
29649
29650C...PYCTEQ
29651C...Gives the CTEQ 3 parton distribution function sets in
29652C...parametrized form, of October 24, 1994.
29653C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
29654C...J. Qiu, W.K. Tung and H. Weerts.
29655
29656 FUNCTION PYCTEQ (ISET, IPRT, X, Q)
29657
29658C...Double precision declaration.
29659 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29660 IMPLICIT INTEGER(I-N)
29661
29662C...Data on Lambda values of fits, minimum Q and quark masses.
29663 DIMENSION ALM(3), QMS(4:6)
29664 DATA ALM / 0.177D0, 0.239D0, 0.247D0 /
29665 DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 /
29666
29667C....Check flavour thresholds. Set up QI for SB.
29668 IP = IABS(IPRT)
29669 IF(IP .GE. 4) THEN
29670 IF(Q .LE. QMS(IP)) THEN
29671 PYCTEQ = 0D0
29672 RETURN
29673 ENDIF
29674 QI = QMS(IP)
29675 ELSE
29676 QI = QMN
29677 ENDIF
29678
29679C...Use "standard lambda" of parametrization program for expansion.
29680 ALAM = ALM (ISET)
29681 SBL = LOG(Q/ALAM) / LOG(QI/ALAM)
29682 SB = LOG (SBL)
29683 SB2 = SB*SB
29684 SB3 = SB2*SB
29685
29686C...Expansion for CTEQ3L.
29687 IF(ISET .EQ. 1) THEN
29688 IF(IPRT .EQ. 2) THEN
29689 A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2-
29690 & 0.3171D+00*SB3)
29691 A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3
29692 A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3
29693 A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3
29694 A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3
29695 A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3
29696 ELSEIF(IPRT .EQ. 1) THEN
29697 A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+
29698 & 0.7728D+00*SB3)
29699 A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3
29700 A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3
29701 A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3
29702 A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3
29703 A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3
29704 ELSEIF(IPRT .EQ. 0) THEN
29705 A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+
29706 & 0.5343D+00*SB3)
29707 A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3
29708 A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3
29709 A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3
29710 A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3
29711 A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3
29712 ELSEIF(IPRT .EQ. -1) THEN
29713 A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2-
29714 & 0.2031D+01*SB3)
29715 A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3
29716 A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3
29717 A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3
29718 A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3
29719 A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3
29720 ELSEIF(IPRT .EQ. -2) THEN
29721 A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2-
29722 & 0.9872D-01*SB3)
29723 A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3
29724 A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3
29725 A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3
29726 A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3
29727 A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3
29728 ELSEIF(IPRT .EQ. -3) THEN
29729 A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+
29730 & 0.8390D+00*SB3)
29731 A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3
29732 A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3
29733 A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3
29734 A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3
29735 A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3
29736 ELSEIF(IPRT .EQ. -4) THEN
29737 A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB +
29738 & 0.1651D-01*SB2)
29739 A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3
29740 A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3
29741 A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3
29742 A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3
29743 A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3
29744 ELSEIF(IPRT .EQ. -5) THEN
29745 A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB +
29746 & 0.3702D+01*SB2)
29747 A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3
29748 A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3
29749 A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3
29750 A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3
29751 A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3
29752 ELSEIF(IPRT .EQ. -6) THEN
29753 A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB -
29754 & 0.6943D+00*SB2)
29755 A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3
29756 A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3
29757 A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3
29758 A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3
29759 A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3
29760 ENDIF
29761
29762C...Expansion for CTEQ3M.
29763 ELSEIF(ISET .EQ. 2) THEN
29764 IF(IPRT .EQ. 2) THEN
29765 A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2-
29766 & 0.2935D+00*SB3)
29767 A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3
29768 A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3
29769 A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3
29770 A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3
29771 A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3
29772 ELSEIF(IPRT .EQ. 1) THEN
29773 A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2-
29774 & 0.4305D-01*SB3)
29775 A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3
29776 A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3
29777 A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3
29778 A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3
29779 A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3
29780 ELSEIF(IPRT .EQ. 0) THEN
29781 A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+
29782 & 0.1037D-01*SB3)
29783 A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3
29784 A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3
29785 A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3
29786 A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3
29787 A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3
29788 ELSEIF(IPRT .EQ. -1) THEN
29789 A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2-
29790 & 0.1602D+01*SB3)
29791 A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3
29792 A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3
29793 A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3
29794 A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3
29795 A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3
29796 ELSEIF(IPRT .EQ. -2) THEN
29797 A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+
29798 & 0.2496D+00*SB3)
29799 A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3
29800 A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3
29801 A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3
29802 A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3
29803 A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3
29804 ELSEIF(IPRT .EQ. -3) THEN
29805 A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+
29806 & 0.1936D+01*SB3)
29807 A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3
29808 A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3
29809 A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3
29810 A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3
29811 A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3
29812 ELSEIF(IPRT .EQ. -4) THEN
29813 A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB +
29814 & 0.5348D+00*SB2)
29815 A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3
29816 A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3
29817 A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3
29818 A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3
29819 A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3
29820 ELSEIF(IPRT .EQ. -5) THEN
29821 A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB +
29822 & 0.1569D+01*SB2)
29823 A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3
29824 A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3
29825 A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3
29826 A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3
29827 A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3
29828 ELSEIF(IPRT .EQ. -6) THEN
29829 A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB +
29830 & 0.8838D+01*SB2)
29831 A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3
29832 A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3
29833 A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3
29834 A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3
29835 A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3
29836 ENDIF
29837
29838C...Expansion for CTEQ3D.
29839 ELSEIF(ISET .EQ. 3) THEN
29840 IF(IPRT .EQ. 2) THEN
29841 A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2-
29842 & 0.2902D+00*SB3)
29843 A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3
29844 A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3
29845 A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3
29846 A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3
29847 A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3
29848 ELSEIF(IPRT .EQ. 1) THEN
29849 A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+
29850 & 0.7257D+00*SB3)
29851 A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3
29852 A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3
29853 A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3
29854 A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3
29855 A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3
29856 ELSEIF(IPRT .EQ. 0) THEN
29857 A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2-
29858 & 0.2734D-04*SB3)
29859 A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3
29860 A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3
29861 A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3
29862 A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3
29863 A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3
29864 ELSEIF(IPRT .EQ. -1) THEN
29865 A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2-
29866 & 0.1671D+01*SB3)
29867 A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3
29868 A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3
29869 A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3
29870 A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3
29871 A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3
29872 ELSEIF(IPRT .EQ. -2) THEN
29873 A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+
29874 & 0.2223D+00*SB3)
29875 A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3
29876 A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3
29877 A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3
29878 A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3
29879 A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3
29880 ELSEIF(IPRT .EQ. -3) THEN
29881 A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+
29882 & 0.1937D+01*SB3)
29883 A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3
29884 A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3
29885 A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3
29886 A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3
29887 A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3
29888 ELSEIF(IPRT .EQ. -4) THEN
29889 A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB +
29890 & 0.5137D+00*SB2)
29891 A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3
29892 A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3
29893 A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3
29894 A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3
29895 A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3
29896 ELSEIF(IPRT .EQ. -5) THEN
29897 A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB +
29898 & 0.2143D+01*SB2)
29899 A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3
29900 A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3
29901 A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3
29902 A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3
29903 A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3
29904 ELSEIF(IPRT .EQ. -6) THEN
29905 A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB +
29906 & 0.9998D+01*SB2)
29907 A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3
29908 A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3
29909 A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3
29910 A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3
29911 A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3
29912 ENDIF
29913 ENDIF
29914
29915C...Calculation of x * f(x, Q).
29916 PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4))
29917 & *(LOG(1D0+1D0/X))**A5 )
29918
29919 RETURN
29920 END
29921
29922C*********************************************************************
29923
29924C...PYGRVL
29925C...Gives the GRV 94 L (leading order) parton distribution function set
29926C...in parametrized form.
29927C...Authors: M. Glueck, E. Reya and A. Vogt.
29928
29929 SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
29930
29931C...Double precision declaration.
29932 IMPLICIT DOUBLE PRECISION (A - Z)
29933
29934C...Common expressions.
29935 MU2 = 0.23D0
29936 LAM2 = 0.2322D0 * 0.2322D0
29937 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
29938 DS = SQRT (S)
29939 S2 = S * S
29940 S3 = S2 * S
29941
29942C...uv :
29943 NU = 2.284D0 + 0.802D0 * S + 0.055D0 * S2
29944 AKU = 0.590D0 - 0.024D0 * S
29945 BKU = 0.131D0 + 0.063D0 * S
29946 AU = -0.449D0 - 0.138D0 * S - 0.076D0 * S2
29947 BU = 0.213D0 + 2.669D0 * S - 0.728D0 * S2
29948 CU = 8.854D0 - 9.135D0 * S + 1.979D0 * S2
29949 DU = 2.997D0 + 0.753D0 * S - 0.076D0 * S2
29950 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
29951
29952C...dv :
29953 ND = 0.371D0 + 0.083D0 * S + 0.039D0 * S2
29954 AKD = 0.376D0
29955 BKD = 0.486D0 + 0.062D0 * S
29956 AD = -0.509D0 + 3.310D0 * S - 1.248D0 * S2
29957 BD = 12.41D0 - 10.52D0 * S + 2.267D0 * S2
29958 CD = 6.373D0 - 6.208D0 * S + 1.418D0 * S2
29959 DD = 3.691D0 + 0.799D0 * S - 0.071D0 * S2
29960 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
29961
29962C...del :
29963 NE = 0.082D0 + 0.014D0 * S + 0.008D0 * S2
29964 AKE = 0.409D0 - 0.005D0 * S
29965 BKE = 0.799D0 + 0.071D0 * S
29966 AE = -38.07D0 + 36.13D0 * S - 0.656D0 * S2
29967 BE = 90.31D0 - 74.15D0 * S + 7.645D0 * S2
29968 CE = 0.0D0
29969 DE = 7.486D0 + 1.217D0 * S - 0.159D0 * S2
29970 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
29971
29972C...udb :
29973 ALX = 1.451D0
29974 BEX = 0.271D0
29975 AKX = 0.410D0 - 0.232D0 * S
29976 BKX = 0.534D0 - 0.457D0 * S
29977 AGX = 0.890D0 - 0.140D0 * S
29978 BGX = -0.981D0
29979 CX = 0.320D0 + 0.683D0 * S
29980 DX = 4.752D0 + 1.164D0 * S + 0.286D0 * S2
29981 EX = 4.119D0 + 1.713D0 * S
29982 ESX = 0.682D0 + 2.978D0 * S
29983 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
29984 & DX, EX, ESX)
29985
29986C...sb :
29987 STS = 0D0
29988 ALS = 0.914D0
29989 BES = 0.577D0
29990 AKS = 1.798D0 - 0.596D0 * S
29991 AS = -5.548D0 + 3.669D0 * DS - 0.616D0 * S
29992 BS = 18.92D0 - 16.73D0 * DS + 5.168D0 * S
29993 DST = 6.379D0 - 0.350D0 * S + 0.142D0 * S2
29994 EST = 3.981D0 + 1.638D0 * S
29995 ESS = 6.402D0
29996 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
29997
29998C...cb :
29999 STC = 0.888D0
30000 ALC = 1.01D0
30001 BEC = 0.37D0
30002 AKC = 0D0
30003 AC = 0D0
30004 BC = 4.24D0 - 0.804D0 * S
30005 DCT = 3.46D0 - 1.076D0 * S
30006 ECT = 4.61D0 + 1.49D0 * S
30007 ESC = 2.555D0 + 1.961D0 * S
30008 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
30009
30010C...bb :
30011 STB = 1.351D0
30012 ALB = 1.00D0
30013 BEB = 0.51D0
30014 AKB = 0D0
30015 AB = 0D0
30016 BB = 1.848D0
30017 DBT = 2.929D0 + 1.396D0 * S
30018 EBT = 4.71D0 + 1.514D0 * S
30019 ESB = 4.02D0 + 1.239D0 * S
30020 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
30021
30022C...gl :
30023 ALG = 0.524D0
30024 BEG = 1.088D0
30025 AKG = 1.742D0 - 0.930D0 * S
30026 BKG = - 0.399D0 * S2
30027 AG = 7.486D0 - 2.185D0 * S
30028 BG = 16.69D0 - 22.74D0 * S + 5.779D0 * S2
30029 CG = -25.59D0 + 29.71D0 * S - 7.296D0 * S2
30030 DG = 2.792D0 + 2.215D0 * S + 0.422D0 * S2 - 0.104D0 * S3
30031 EG = 0.807D0 + 2.005D0 * S
30032 ESG = 3.841D0 + 0.316D0 * S
30033 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG,
30034 & DG, EG, ESG)
30035
30036 RETURN
30037 END
30038
30039C*********************************************************************
30040
30041C...PYGRVM
30042C...Gives the GRV 94 M (MSbar) parton distribution function set
30043C...in parametrized form.
30044C...Authors: M. Glueck, E. Reya and A. Vogt.
30045
30046 SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
30047
30048C...Double precision declaration.
30049 IMPLICIT DOUBLE PRECISION (A - Z)
30050
30051C...Common expressions.
30052 MU2 = 0.34D0
30053 LAM2 = 0.248D0 * 0.248D0
30054 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
30055 DS = SQRT (S)
30056 S2 = S * S
30057 S3 = S2 * S
30058
30059C...uv :
30060 NU = 1.304D0 + 0.863D0 * S
30061 AKU = 0.558D0 - 0.020D0 * S
30062 BKU = 0.183D0 * S
30063 AU = -0.113D0 + 0.283D0 * S - 0.321D0 * S2
30064 BU = 6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3
30065 CU = 7.771D0 - 10.09D0 * S + 2.630D0 * S2
30066 DU = 3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3
30067 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
30068
30069C...dv :
30070 ND = 0.102D0 - 0.017D0 * S + 0.005D0 * S2
30071 AKD = 0.270D0 - 0.019D0 * S
30072 BKD = 0.260D0
30073 AD = 2.393D0 + 6.228D0 * S - 0.881D0 * S2
30074 BD = 46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3
30075 CD = 17.83D0 - 53.47D0 * S + 21.24D0 * S2
30076 DD = 4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3
30077 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
30078
30079C...del :
30080 NE = 0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3
30081 AKE = 0.409D0 - 0.007D0 * S
30082 BKE = 0.782D0 + 0.082D0 * S
30083 AE = -29.65D0 + 26.49D0 * S + 5.429D0 * S2
30084 BE = 90.20D0 - 74.97D0 * S + 4.526D0 * S2
30085 CE = 0.0D0
30086 DE = 8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3
30087 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
30088
30089C...udb :
30090 ALX = 0.877D0
30091 BEX = 0.561D0
30092 AKX = 0.275D0
30093 BKX = 0.0D0
30094 AGX = 0.997D0
30095 BGX = 3.210D0 - 1.866D0 * S
30096 CX = 7.300D0
30097 DX = 9.010D0 + 0.896D0 * DS + 0.222D0 * S2
30098 EX = 3.077D0 + 1.446D0 * S
30099 ESX = 3.173D0 - 2.445D0 * DS + 2.207D0 * S
30100 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
30101 & DX, EX, ESX)
30102
30103C...sb :
30104 STS = 0D0
30105 ALS = 0.756D0
30106 BES = 0.216D0
30107 AKS = 1.690D0 + 0.650D0 * DS - 0.922D0 * S
30108 AS = -4.329D0 + 1.131D0 * S
30109 BS = 9.568D0 - 1.744D0 * S
30110 DST = 9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2
30111 EST = 3.031D0 + 1.639D0 * S
30112 ESS = 5.837D0 + 0.815D0 * S
30113 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
30114
30115C...cb :
30116 STC = 0.820D0
30117 ALC = 0.98D0
30118 BEC = 0D0
30119 AKC = -0.625D0 - 0.523D0 * S
30120 AC = 0D0
30121 BC = 1.896D0 + 1.616D0 * S
30122 DCT = 4.12D0 + 0.683D0 * S
30123 ECT = 4.36D0 + 1.328D0 * S
30124 ESC = 0.677D0 + 0.679D0 * S
30125 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
30126
30127C...bb :
30128 STB = 1.297D0
30129 ALB = 0.99D0
30130 BEB = 0D0
30131 AKB = - 0.193D0 * S
30132 AB = 0D0
30133 BB = 0D0
30134 DBT = 3.447D0 + 0.927D0 * S
30135 EBT = 4.68D0 + 1.259D0 * S
30136 ESB = 1.892D0 + 2.199D0 * S
30137 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
30138
30139C...gl :
30140 ALG = 1.014D0
30141 BEG = 1.738D0
30142 AKG = 1.724D0 + 0.157D0 * S
30143 BKG = 0.800D0 + 1.016D0 * S
30144 AG = 7.517D0 - 2.547D0 * S
30145 BG = 34.09D0 - 52.21D0 * DS + 17.47D0 * S
30146 CG = 4.039D0 + 1.491D0 * S
30147 DG = 3.404D0 + 0.830D0 * S
30148 EG = -1.112D0 + 3.438D0 * S - 0.302D0 * S2
30149 ESG = 3.256D0 - 0.436D0 * S
30150 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
30151
30152 RETURN
30153 END
30154
30155C*********************************************************************
30156
30157C...PYGRVD
30158C...Gives the GRV 94 D (DIS) parton distribution function set
30159C...in parametrized form.
30160C...Authors: M. Glueck, E. Reya and A. Vogt.
30161
30162 SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
30163
30164C...Double precision declaration.
30165 IMPLICIT DOUBLE PRECISION (A - Z)
30166
30167C...Common expressions.
30168 MU2 = 0.34D0
30169 LAM2 = 0.248D0 * 0.248D0
30170 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
30171 DS = SQRT (S)
30172 S2 = S * S
30173 S3 = S2 * S
30174
30175C...uv :
30176 NU = 2.484D0 + 0.116D0 * S + 0.093D0 * S2
30177 AKU = 0.563D0 - 0.025D0 * S
30178 BKU = 0.054D0 + 0.154D0 * S
30179 AU = -0.326D0 - 0.058D0 * S - 0.135D0 * S2
30180 BU = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3
30181 CU = 11.52D0 - 12.99D0 * S + 3.161D0 * S2
30182 DU = 2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3
30183 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
30184
30185C...dv :
30186 ND = 0.156D0 - 0.017D0 * S
30187 AKD = 0.299D0 - 0.022D0 * S
30188 BKD = 0.259D0 - 0.015D0 * S
30189 AD = 3.445D0 + 1.278D0 * S + 0.326D0 * S2
30190 BD = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3
30191 CD = 55.45D0 - 69.92D0 * S + 20.78D0 * S2
30192 DD = 3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3
30193 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
30194
30195C...del :
30196 NE = 0.099D0 + 0.019D0 * S + 0.002D0 * S2
30197 AKE = 0.419D0 - 0.013D0 * S
30198 BKE = 1.064D0 - 0.038D0 * S
30199 AE = -44.00D0 + 98.70D0 * S - 14.79D0 * S2
30200 BE = 28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3
30201 CE = 84.57D0 - 108.8D0 * S + 31.52D0 * S2
30202 DE = 7.469D0 + 2.480D0 * S - 0.866D0 * S2
30203 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
30204
30205C...udb :
30206 ALX = 1.215D0
30207 BEX = 0.466D0
30208 AKX = 0.326D0 + 0.150D0 * S
30209 BKX = 0.956D0 + 0.405D0 * S
30210 AGX = 0.272D0
30211 BGX = 3.794D0 - 2.359D0 * DS
30212 CX = 2.014D0
30213 DX = 7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2
30214 EX = 3.049D0 + 1.597D0 * S
30215 ESX = 4.396D0 - 4.594D0 * DS + 3.268D0 * S
30216 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
30217 & DX, EX, ESX)
30218
30219C...sb :
30220 STS = 0D0
30221 ALS = 0.175D0
30222 BES = 0.344D0
30223 AKS = 1.415D0 - 0.641D0 * DS
30224 AS = 0.580D0 - 9.763D0 * DS + 6.795D0 * S - 0.558D0 * S2
30225 BS = 5.617D0 + 5.709D0 * DS - 3.972D0 * S
30226 DST = 13.78D0 - 9.581D0 * S + 5.370D0 * S2 - 0.996D0 * S3
30227 EST = 4.546D0 + 0.372D0 * S2
30228 ESS = 5.053D0 - 1.070D0 * S + 0.805D0 * S2
30229 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
30230
30231C...cb :
30232 STC = 0.820D0
30233 ALC = 0.98D0
30234 BEC = 0D0
30235 AKC = -0.625D0 - 0.523D0 * S
30236 AC = 0D0
30237 BC = 1.896D0 + 1.616D0 * S
30238 DCT = 4.12D0 + 0.683D0 * S
30239 ECT = 4.36D0 + 1.328D0 * S
30240 ESC = 0.677D0 + 0.679D0 * S
30241 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
30242
30243C...bb :
30244 STB = 1.297D0
30245 ALB = 0.99D0
30246 BEB = 0D0
30247 AKB = - 0.193D0 * S
30248 AB = 0D0
30249 BB = 0D0
30250 DBT = 3.447D0 + 0.927D0 * S
30251 EBT = 4.68D0 + 1.259D0 * S
30252 ESB = 1.892D0 + 2.199D0 * S
30253 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
30254
30255C...gl :
30256 ALG = 1.258D0
30257 BEG = 1.846D0
30258 AKG = 2.423D0
30259 BKG = 2.427D0 + 1.311D0 * S - 0.153D0 * S2
30260 AG = 25.09D0 - 7.935D0 * S
30261 BG = -14.84D0 - 124.3D0 * DS + 72.18D0 * S
30262 CG = 590.3D0 - 173.8D0 * S
30263 DG = 5.196D0 + 1.857D0 * S
30264 EG = -1.648D0 + 3.988D0 * S - 0.432D0 * S2
30265 ESG = 3.232D0 - 0.542D0 * S
30266 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
30267
30268 RETURN
30269 END
30270
30271C*********************************************************************
30272
30273C...PYGRVV
30274C...Auxiliary for the GRV 94 parton distribution functions
30275C...for u and d valence and d-u sea.
30276C...Authors: M. Glueck, E. Reya and A. Vogt.
30277
30278 FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D)
30279
30280C...Double precision declaration.
30281 IMPLICIT DOUBLE PRECISION (A - Z)
30282
30283C...Evaluation.
30284 DX = SQRT (X)
30285 PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) *
30286 & (1D0- X)**D
30287
30288 RETURN
30289 END
30290
30291C*********************************************************************
30292
30293C...PYGRVW
30294C...Auxiliary for the GRV 94 parton distribution functions
30295C...for d+u sea and gluon.
30296C...Authors: M. Glueck, E. Reya and A. Vogt.
30297
30298 FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
30299
30300C...Double precision declaration.
30301 IMPLICIT DOUBLE PRECISION (A - Z)
30302
30303C...Evaluation.
30304 LX = LOG (1D0/X)
30305 PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
30306 & * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D
30307
30308 RETURN
30309 END
30310
30311C*********************************************************************
30312
30313C...PYGRVS
30314C...Auxiliary for the GRV 94 parton distribution functions
30315C...for s, c and b sea.
30316C...Authors: M. Glueck, E. Reya and A. Vogt.
30317
30318 FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
30319
30320C...Double precision declaration.
30321 IMPLICIT DOUBLE PRECISION (A - Z)
30322
30323C...Evaluation.
30324 IF(S.LE.STH) THEN
30325 PYGRVS = 0D0
30326 ELSE
30327 DX = SQRT (X)
30328 LX = LOG (1D0/X)
30329 PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) *
30330 & (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX))
30331 ENDIF
30332
30333 RETURN
30334 END
30335
30336C*********************************************************************
30337
30338C...PYCT5L
30339C...Auxiliary function for parametrization of CTEQ5L.
30340C...Author: J. Pumplin 9/99.
30341
30342C...CTEQ5M1 and CTEQ5L Parton Distribution Functions
30343C...in Parametrized Form
30344C... September 15, 1999
30345C
30346C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON:
30347C... CTEQ5 PPARTON DISTRIBUTIONS"
30348C...hep-ph/9903282
30349
30350C...The CTEQ5M1 set given here is an updated version of the original
30351C...CTEQ5M set posted, in the table version, on the Web page of CTEQ.
30352C...The differences between CTEQ5M and CTEQ5M1 are insignificant for
30353C...almost all applications.
30354C...The improvement is in the QCD evolution which is now more
30355C...accurate, and which agrees completely with the benchmark work
30356C...of the HERA 96/97 Workshop.
30357C...The differences between the parametrized and the corresponding
30358C...table versions (on which it is based) are of similar order as
30359C...between the two version.
30360
30361C...!! Because accurate parametrizations over a wide range of (x,Q)
30362C...is hard to obtain, only the most widely used sets CTEQ5M and
30363C...CTEQ5L are available in parametrized form for now.
30364
30365C...These parametrizations were obtained by Jon Pumplin.
30366
30367C Iset PDF Description Alpha_s(Mz) Lam4 Lam5
30368C -------------------------------------------------------------------
30369C 1 CTEQ5M1 Standard NLO MSbar scheme 0.118 326 226
30370C 3 CTEQ5L Leading Order 0.127 192 146
30371C -------------------------------------------------------------------
30372C...Note the Qcd-lambda values given for CTEQ5L is for the leading
30373C...order form of Alpha_s!! Alpha_s(Mz) gives the absolute
30374C...calibration.
30375
30376C...The two Iset value are adopted to agree with the standard table
30377C...versions.
30378
30379C...Range of validity:
30380C...The range of (x, Q) covered by this parametrization of the QCD
30381C...evolved parton distributions is 1E-6 < x < 1 ;
30382C...1.1 GeV < Q < 10 TeV. Of course, the PDF's are constrained by
30383C...data only in a subset of that region; and the assumed DGLAP
30384C...evolution is unlikely to be valid for all of it either.
30385
30386C...The range of (x, Q) used in the CTEQ5 round of global analysis is
30387C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for
30388C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and
30389C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data.
30390
30391 FUNCTION PYCT5L(IFL,X,Q)
30392
30393C...Double precision declaration.
30394 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30395 IMPLICIT INTEGER(I-N)
30396
30397 PARAMETER (NEX=8, NLF=2)
30398 DIMENSION AM(0:NEX,0:NLF,-5:2)
30399 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
30400 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
30401 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
30402 DIMENSION AF(0:NEX)
30403
30404 DATA MEXVEC( 2) / 8 /
30405 DATA MLFVEC( 2) / 2 /
30406 DATA UT1VEC( 2) / 0.4971265E+01 /
30407 DATA UT2VEC( 2) / -0.1105128E+01 /
30408 DATA ALFVEC( 2) / 0.2987216E+00 /
30409 DATA QMAVEC( 2) / 0.0000000E+00 /
30410 DATA (AM( 0,K, 2),K=0, 2)
30411 & / 0.5292616E+01, -0.2751910E+01, -0.2488990E+01 /
30412 DATA (AM( 1,K, 2),K=0, 2)
30413 & / 0.9714424E+00, 0.1011827E-01, -0.1023660E-01 /
30414 DATA (AM( 2,K, 2),K=0, 2)
30415 & / -0.1651006E+02, 0.7959721E+01, 0.8810563E+01 /
30416 DATA (AM( 3,K, 2),K=0, 2)
30417 & / -0.1643394E+02, 0.5892854E+01, 0.9348874E+01 /
30418 DATA (AM( 4,K, 2),K=0, 2)
30419 & / 0.3067422E+02, 0.4235796E+01, -0.5112136E+00 /
30420 DATA (AM( 5,K, 2),K=0, 2)
30421 & / 0.2352526E+02, -0.5305168E+01, -0.1169174E+02 /
30422 DATA (AM( 6,K, 2),K=0, 2)
30423 & / -0.1095451E+02, 0.3006577E+01, 0.5638136E+01 /
30424 DATA (AM( 7,K, 2),K=0, 2)
30425 & / -0.1172251E+02, -0.2183624E+01, 0.4955794E+01 /
30426 DATA (AM( 8,K, 2),K=0, 2)
30427 & / 0.1662533E-01, 0.7622870E-02, -0.4895887E-03 /
30428
30429 DATA MEXVEC( 1) / 8 /
30430 DATA MLFVEC( 1) / 2 /
30431 DATA UT1VEC( 1) / 0.2612618E+01 /
30432 DATA UT2VEC( 1) / -0.1258304E+06 /
30433 DATA ALFVEC( 1) / 0.3407552E+00 /
30434 DATA QMAVEC( 1) / 0.0000000E+00 /
30435 DATA (AM( 0,K, 1),K=0, 2)
30436 & / 0.9905300E+00, -0.4502235E+00, 0.1624441E+00 /
30437 DATA (AM( 1,K, 1),K=0, 2)
30438 & / 0.8867534E+00, 0.1630829E-01, -0.4049085E-01 /
30439 DATA (AM( 2,K, 1),K=0, 2)
30440 & / 0.8547974E+00, 0.3336301E+00, 0.1371388E+00 /
30441 DATA (AM( 3,K, 1),K=0, 2)
30442 & / 0.2941113E+00, -0.1527905E+01, 0.2331879E+00 /
30443 DATA (AM( 4,K, 1),K=0, 2)
30444 & / 0.3384235E+02, 0.3715315E+01, 0.8276930E+00 /
30445 DATA (AM( 5,K, 1),K=0, 2)
30446 & / 0.6230115E+01, 0.3134639E+01, -0.1729099E+01 /
30447 DATA (AM( 6,K, 1),K=0, 2)
30448 & / -0.1186928E+01, -0.3282460E+00, 0.1052020E+00 /
30449 DATA (AM( 7,K, 1),K=0, 2)
30450 & / -0.8545702E+01, -0.6247947E+01, 0.3692561E+01 /
30451 DATA (AM( 8,K, 1),K=0, 2)
30452 & / 0.1724598E-01, 0.7120465E-02, 0.4003646E-04 /
30453
30454 DATA MEXVEC( 0) / 8 /
30455 DATA MLFVEC( 0) / 2 /
30456 DATA UT1VEC( 0) / -0.4656819E+00 /
30457 DATA UT2VEC( 0) / -0.2742390E+03 /
30458 DATA ALFVEC( 0) / 0.4491863E+00 /
30459 DATA QMAVEC( 0) / 0.0000000E+00 /
30460 DATA (AM( 0,K, 0),K=0, 2)
30461 & / 0.1193572E+03, -0.3886845E+01, -0.1133965E+01 /
30462 DATA (AM( 1,K, 0),K=0, 2)
30463 & / -0.9421449E+02, 0.3995885E+01, 0.1607363E+01 /
30464 DATA (AM( 2,K, 0),K=0, 2)
30465 & / 0.4206383E+01, 0.2485954E+00, 0.2497468E+00 /
30466 DATA (AM( 3,K, 0),K=0, 2)
30467 & / 0.1210557E+03, -0.3015765E+01, -0.1423651E+01 /
30468 DATA (AM( 4,K, 0),K=0, 2)
30469 & / -0.1013897E+03, -0.7113478E+00, 0.2621865E+00 /
30470 DATA (AM( 5,K, 0),K=0, 2)
30471 & / -0.1312404E+01, -0.9297691E+00, -0.1562531E+00 /
30472 DATA (AM( 6,K, 0),K=0, 2)
30473 & / 0.1627137E+01, 0.4954111E+00, -0.6387009E+00 /
30474 DATA (AM( 7,K, 0),K=0, 2)
30475 & / 0.1537698E+00, -0.2487878E+00, 0.8305947E+00 /
30476 DATA (AM( 8,K, 0),K=0, 2)
30477 & / 0.2496448E-01, 0.2457823E-02, 0.8234276E-03 /
30478
30479 DATA MEXVEC(-1) / 8 /
30480 DATA MLFVEC(-1) / 2 /
30481 DATA UT1VEC(-1) / 0.3862583E+01 /
30482 DATA UT2VEC(-1) / -0.1265969E+01 /
30483 DATA ALFVEC(-1) / 0.2457668E+00 /
30484 DATA QMAVEC(-1) / 0.0000000E+00 /
30485 DATA (AM( 0,K,-1),K=0, 2)
30486 & / 0.2647441E+02, 0.1059277E+02, -0.9176654E+00 /
30487 DATA (AM( 1,K,-1),K=0, 2)
30488 & / 0.1990636E+01, 0.8558918E-01, 0.4248667E-01 /
30489 DATA (AM( 2,K,-1),K=0, 2)
30490 & / -0.1476095E+02, -0.3276255E+02, 0.1558110E+01 /
30491 DATA (AM( 3,K,-1),K=0, 2)
30492 & / -0.2966889E+01, -0.3649037E+02, 0.1195914E+01 /
30493 DATA (AM( 4,K,-1),K=0, 2)
30494 & / -0.1000519E+03, -0.2464635E+01, 0.1964849E+00 /
30495 DATA (AM( 5,K,-1),K=0, 2)
30496 & / 0.3718331E+02, 0.4700389E+02, -0.2772142E+01 /
30497 DATA (AM( 6,K,-1),K=0, 2)
30498 & / -0.1872722E+02, -0.2291189E+02, 0.1089052E+01 /
30499 DATA (AM( 7,K,-1),K=0, 2)
30500 & / -0.1628146E+02, -0.1823993E+02, 0.2537369E+01 /
30501 DATA (AM( 8,K,-1),K=0, 2)
30502 & / -0.1156300E+01, -0.1280495E+00, 0.5153245E-01 /
30503
30504 DATA MEXVEC(-2) / 7 /
30505 DATA MLFVEC(-2) / 2 /
30506 DATA UT1VEC(-2) / 0.1895615E+00 /
30507 DATA UT2VEC(-2) / -0.3069097E+01 /
30508 DATA ALFVEC(-2) / 0.5293999E+00 /
30509 DATA QMAVEC(-2) / 0.0000000E+00 /
30510 DATA (AM( 0,K,-2),K=0, 2)
30511 & / -0.6556775E+00, 0.2490190E+00, 0.3966485E-01 /
30512 DATA (AM( 1,K,-2),K=0, 2)
30513 & / 0.1305102E+01, -0.1188925E+00, -0.4600870E-02 /
30514 DATA (AM( 2,K,-2),K=0, 2)
30515 & / -0.2371436E+01, 0.3566814E+00, -0.2834683E+00 /
30516 DATA (AM( 3,K,-2),K=0, 2)
30517 & / -0.6152826E+01, 0.8339877E+00, -0.7233230E+00 /
30518 DATA (AM( 4,K,-2),K=0, 2)
30519 & / -0.8346558E+01, 0.2892168E+01, 0.2137099E+00 /
30520 DATA (AM( 5,K,-2),K=0, 2)
30521 & / 0.1279530E+02, 0.1021114E+00, 0.5787439E+00 /
30522 DATA (AM( 6,K,-2),K=0, 2)
30523 & / 0.5858816E+00, -0.1940375E+01, -0.4029269E+00 /
30524 DATA (AM( 7,K,-2),K=0, 2)
30525 & / -0.2795725E+02, -0.5263392E+00, 0.1290229E+01 /
30526
30527 DATA MEXVEC(-3) / 7 /
30528 DATA MLFVEC(-3) / 2 /
30529 DATA UT1VEC(-3) / 0.3753257E+01 /
30530 DATA UT2VEC(-3) / -0.1113085E+01 /
30531 DATA ALFVEC(-3) / 0.3713141E+00 /
30532 DATA QMAVEC(-3) / 0.0000000E+00 /
30533 DATA (AM( 0,K,-3),K=0, 2)
30534 & / 0.1580931E+01, -0.2273826E+01, -0.1822245E+01 /
30535 DATA (AM( 1,K,-3),K=0, 2)
30536 & / 0.2702644E+01, 0.6763243E+00, 0.7231586E-02 /
30537 DATA (AM( 2,K,-3),K=0, 2)
30538 & / -0.1857924E+02, 0.3907500E+01, 0.5850109E+01 /
30539 DATA (AM( 3,K,-3),K=0, 2)
30540 & / -0.3044793E+02, 0.2639332E+01, 0.5566644E+01 /
30541 DATA (AM( 4,K,-3),K=0, 2)
30542 & / -0.4258011E+01, -0.5429244E+01, 0.4418946E+00 /
30543 DATA (AM( 5,K,-3),K=0, 2)
30544 & / 0.3465259E+02, -0.5532604E+01, -0.4904153E+01 /
30545 DATA (AM( 6,K,-3),K=0, 2)
30546 & / -0.1658858E+02, 0.2923275E+01, 0.2266286E+01 /
30547 DATA (AM( 7,K,-3),K=0, 2)
30548 & / -0.1149263E+02, 0.2877475E+01, -0.7999105E+00 /
30549
30550 DATA MEXVEC(-4) / 7 /
30551 DATA MLFVEC(-4) / 2 /
30552 DATA UT1VEC(-4) / 0.4400772E+01 /
30553 DATA UT2VEC(-4) / -0.1356116E+01 /
30554 DATA ALFVEC(-4) / 0.3712017E-01 /
30555 DATA QMAVEC(-4) / 0.1300000E+01 /
30556 DATA (AM( 0,K,-4),K=0, 2)
30557 & / -0.8293661E+00, -0.3982375E+01, -0.6494283E-01 /
30558 DATA (AM( 1,K,-4),K=0, 2)
30559 & / 0.2754618E+01, 0.8338636E+00, -0.6885160E-01 /
30560 DATA (AM( 2,K,-4),K=0, 2)
30561 & / -0.1657987E+02, 0.1439143E+02, -0.6887240E+00 /
30562 DATA (AM( 3,K,-4),K=0, 2)
30563 & / -0.2800703E+02, 0.1535966E+02, -0.7377693E+00 /
30564 DATA (AM( 4,K,-4),K=0, 2)
30565 & / -0.6460216E+01, -0.4783019E+01, 0.4913297E+00 /
30566 DATA (AM( 5,K,-4),K=0, 2)
30567 & / 0.3141830E+02, -0.3178031E+02, 0.7136013E+01 /
30568 DATA (AM( 6,K,-4),K=0, 2)
30569 & / -0.1802509E+02, 0.1862163E+02, -0.4632843E+01 /
30570 DATA (AM( 7,K,-4),K=0, 2)
30571 & / -0.1240412E+02, 0.2565386E+02, -0.1066570E+02 /
30572
30573 DATA MEXVEC(-5) / 6 /
30574 DATA MLFVEC(-5) / 2 /
30575 DATA UT1VEC(-5) / 0.5562568E+01 /
30576 DATA UT2VEC(-5) / -0.1801317E+01 /
30577 DATA ALFVEC(-5) / 0.4952010E-02 /
30578 DATA QMAVEC(-5) / 0.4500000E+01 /
30579 DATA (AM( 0,K,-5),K=0, 2)
30580 & / -0.6031237E+01, 0.1992727E+01, -0.1076331E+01 /
30581 DATA (AM( 1,K,-5),K=0, 2)
30582 & / 0.2933912E+01, 0.5839674E+00, 0.7509435E-01 /
30583 DATA (AM( 2,K,-5),K=0, 2)
30584 & / -0.8284919E+01, 0.1488593E+01, -0.8251678E+00 /
30585 DATA (AM( 3,K,-5),K=0, 2)
30586 & / -0.1925986E+02, 0.2805753E+01, -0.3015446E+01 /
30587 DATA (AM( 4,K,-5),K=0, 2)
30588 & / -0.9480483E+01, -0.9767837E+00, -0.1165544E+01 /
30589 DATA (AM( 5,K,-5),K=0, 2)
30590 & / 0.2193195E+02, -0.1788518E+02, 0.9460908E+01 /
30591 DATA (AM( 6,K,-5),K=0, 2)
30592 & / -0.1327377E+02, 0.1201754E+02, -0.6277844E+01 /
30593
30594 IF(Q .LE. QMAVEC(IFL)) THEN
30595 PYCT5L = 0.D0
30596 RETURN
30597 ENDIF
30598
30599 IF(X .GE. 1.D0) THEN
30600 PYCT5L = 0.D0
30601 RETURN
30602 ENDIF
30603
30604 TMP = LOG(Q/ALFVEC(IFL))
30605 IF(TMP .LE. 0.D0) THEN
30606 PYCT5L = 0.D0
30607 RETURN
30608 ENDIF
30609
30610 SB = LOG(TMP)
30611 SB1 = SB - 1.2D0
30612 SB2 = SB1*SB1
30613
30614 DO 110 I = 0, NEX
30615 AF(I) = 0.D0
30616 SBX = 1.D0
30617 DO 100 K = 0, MLFVEC(IFL)
30618 AF(I) = AF(I) + SBX*AM(I,K,IFL)
30619 SBX = SB1*SBX
30620 100 CONTINUE
30621 110 CONTINUE
30622
30623 Y = -LOG(X)
30624 U = LOG(X/0.00001D0)
30625
30626 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
30627 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
30628 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
30629 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
30630 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
30631
30632 PYCT5L = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
30633
30634C...Include threshold factor.
30635 PYCT5L = PYCT5L * (1.D0 - QMAVEC(IFL)/Q)
30636
30637 RETURN
30638 END
30639
30640C*********************************************************************
30641
30642C...PYCT5M
30643C...Auxiliary function for parametrization of CTEQ5M1.
30644C...Author: J. Pumplin 9/99.
30645
30646 FUNCTION PYCT5M(IFL,X,Q)
30647
30648C...Double precision declaration.
30649 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30650 IMPLICIT INTEGER(I-N)
30651
30652 PARAMETER (NEX=8, NLF=2)
30653 DIMENSION AM(0:NEX,0:NLF,-5:2)
30654 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
30655 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
30656 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
30657 DIMENSION AF(0:NEX)
30658
30659 DATA MEXVEC( 2) / 8 /
30660 DATA MLFVEC( 2) / 2 /
30661 DATA UT1VEC( 2) / 0.5141718E+01 /
30662 DATA UT2VEC( 2) / -0.1346944E+01 /
30663 DATA ALFVEC( 2) / 0.5260555E+00 /
30664 DATA QMAVEC( 2) / 0.0000000E+00 /
30665 DATA (AM( 0,K, 2),K=0, 2)
30666 & / 0.4289071E+01, -0.2536870E+01, -0.1259948E+01 /
30667 DATA (AM( 1,K, 2),K=0, 2)
30668 & / 0.9839410E+00, 0.4168426E-01, -0.5018952E-01 /
30669 DATA (AM( 2,K, 2),K=0, 2)
30670 & / -0.1651961E+02, 0.9246261E+01, 0.5996400E+01 /
30671 DATA (AM( 3,K, 2),K=0, 2)
30672 & / -0.2077936E+02, 0.9786469E+01, 0.7656465E+01 /
30673 DATA (AM( 4,K, 2),K=0, 2)
30674 & / 0.3054926E+02, 0.1889536E+01, 0.1380541E+01 /
30675 DATA (AM( 5,K, 2),K=0, 2)
30676 & / 0.3084695E+02, -0.1212303E+02, -0.1053551E+02 /
30677 DATA (AM( 6,K, 2),K=0, 2)
30678 & / -0.1426778E+02, 0.6239537E+01, 0.5254819E+01 /
30679 DATA (AM( 7,K, 2),K=0, 2)
30680 & / -0.1909811E+02, 0.3695678E+01, 0.5495729E+01 /
30681 DATA (AM( 8,K, 2),K=0, 2)
30682 & / 0.1889751E-01, 0.5027193E-02, 0.6624896E-03 /
30683
30684 DATA MEXVEC( 1) / 8 /
30685 DATA MLFVEC( 1) / 2 /
30686 DATA UT1VEC( 1) / 0.4138426E+01 /
30687 DATA UT2VEC( 1) / -0.3221374E+01 /
30688 DATA ALFVEC( 1) / 0.4960962E+00 /
30689 DATA QMAVEC( 1) / 0.0000000E+00 /
30690 DATA (AM( 0,K, 1),K=0, 2)
30691 & / 0.1332497E+01, -0.3703718E+00, 0.1288638E+00 /
30692 DATA (AM( 1,K, 1),K=0, 2)
30693 & / 0.7544687E+00, 0.3255075E-01, -0.4706680E-01 /
30694 DATA (AM( 2,K, 1),K=0, 2)
30695 & / -0.7638814E+00, 0.5008313E+00, -0.9237374E-01 /
30696 DATA (AM( 3,K, 1),K=0, 2)
30697 & / -0.3689889E+00, -0.1055098E+01, -0.4645065E+00 /
30698 DATA (AM( 4,K, 1),K=0, 2)
30699 & / 0.3991610E+02, 0.1979881E+01, 0.1775814E+01 /
30700 DATA (AM( 5,K, 1),K=0, 2)
30701 & / 0.6201080E+01, 0.2046288E+01, 0.3804571E+00 /
30702 DATA (AM( 6,K, 1),K=0, 2)
30703 & / -0.8027900E+00, -0.7011688E+00, -0.8049612E+00 /
30704 DATA (AM( 7,K, 1),K=0, 2)
30705 & / -0.8631305E+01, -0.3981200E+01, 0.6970153E+00 /
30706 DATA (AM( 8,K, 1),K=0, 2)
30707 & / 0.2371230E-01, 0.5372683E-02, 0.1118701E-02 /
30708
30709 DATA MEXVEC( 0) / 8 /
30710 DATA MLFVEC( 0) / 2 /
30711 DATA UT1VEC( 0) / -0.1026789E+01 /
30712 DATA UT2VEC( 0) / -0.9051707E+01 /
30713 DATA ALFVEC( 0) / 0.9462977E+00 /
30714 DATA QMAVEC( 0) / 0.0000000E+00 /
30715 DATA (AM( 0,K, 0),K=0, 2)
30716 & / 0.1191990E+03, -0.8548739E+00, -0.1963040E+01 /
30717 DATA (AM( 1,K, 0),K=0, 2)
30718 & / -0.9449972E+02, 0.1074771E+01, 0.2056055E+01 /
30719 DATA (AM( 2,K, 0),K=0, 2)
30720 & / 0.3701064E+01, -0.1167947E-02, 0.1933573E+00 /
30721 DATA (AM( 3,K, 0),K=0, 2)
30722 & / 0.1171345E+03, -0.1064540E+01, -0.1875312E+01 /
30723 DATA (AM( 4,K, 0),K=0, 2)
30724 & / -0.1014453E+03, -0.5707427E+00, 0.4511242E-01 /
30725 DATA (AM( 5,K, 0),K=0, 2)
30726 & / 0.6365168E+01, 0.1275354E+01, -0.4964081E+00 /
30727 DATA (AM( 6,K, 0),K=0, 2)
30728 & / -0.3370693E+01, -0.1122020E+01, 0.5947751E-01 /
30729 DATA (AM( 7,K, 0),K=0, 2)
30730 & / -0.5327270E+01, -0.9293556E+00, 0.6629940E+00 /
30731 DATA (AM( 8,K, 0),K=0, 2)
30732 & / 0.2437513E-01, 0.1600939E-02, 0.6855336E-03 /
30733
30734 DATA MEXVEC(-1) / 8 /
30735 DATA MLFVEC(-1) / 2 /
30736 DATA UT1VEC(-1) / 0.5243571E+01 /
30737 DATA UT2VEC(-1) / -0.2870513E+01 /
30738 DATA ALFVEC(-1) / 0.6701448E+00 /
30739 DATA QMAVEC(-1) / 0.0000000E+00 /
30740 DATA (AM( 0,K,-1),K=0, 2)
30741 & / 0.2428863E+02, 0.1907035E+01, -0.4606457E+00 /
30742 DATA (AM( 1,K,-1),K=0, 2)
30743 & / 0.2006810E+01, -0.1265915E+00, 0.7153556E-02 /
30744 DATA (AM( 2,K,-1),K=0, 2)
30745 & / -0.1884546E+02, -0.2339471E+01, 0.5740679E+01 /
30746 DATA (AM( 3,K,-1),K=0, 2)
30747 & / -0.2527892E+02, -0.2044124E+01, 0.1280470E+02 /
30748 DATA (AM( 4,K,-1),K=0, 2)
30749 & / -0.1013824E+03, -0.1594199E+01, 0.2216401E+00 /
30750 DATA (AM( 5,K,-1),K=0, 2)
30751 & / 0.8070930E+02, 0.1792072E+01, -0.2164364E+02 /
30752 DATA (AM( 6,K,-1),K=0, 2)
30753 & / -0.4641050E+02, 0.1977338E+00, 0.1273014E+02 /
30754 DATA (AM( 7,K,-1),K=0, 2)
30755 & / -0.3910568E+02, 0.1719632E+01, 0.1086525E+02 /
30756 DATA (AM( 8,K,-1),K=0, 2)
30757 & / -0.1185496E+01, -0.1905847E+00, -0.8744118E-03 /
30758
30759 DATA MEXVEC(-2) / 7 /
30760 DATA MLFVEC(-2) / 2 /
30761 DATA UT1VEC(-2) / 0.4782210E+01 /
30762 DATA UT2VEC(-2) / -0.1976856E+02 /
30763 DATA ALFVEC(-2) / 0.7558374E+00 /
30764 DATA QMAVEC(-2) / 0.0000000E+00 /
30765 DATA (AM( 0,K,-2),K=0, 2)
30766 & / -0.6216935E+00, 0.2369963E+00, -0.7909949E-02 /
30767 DATA (AM( 1,K,-2),K=0, 2)
30768 & / 0.1245440E+01, -0.1031510E+00, 0.4916523E-02 /
30769 DATA (AM( 2,K,-2),K=0, 2)
30770 & / -0.7060824E+01, -0.3875283E-01, 0.1784981E+00 /
30771 DATA (AM( 3,K,-2),K=0, 2)
30772 & / -0.7430595E+01, 0.1964572E+00, -0.1284999E+00 /
30773 DATA (AM( 4,K,-2),K=0, 2)
30774 & / -0.6897810E+01, 0.2620543E+01, 0.8012553E-02 /
30775 DATA (AM( 5,K,-2),K=0, 2)
30776 & / 0.1507713E+02, 0.2340307E-01, 0.2482535E+01 /
30777 DATA (AM( 6,K,-2),K=0, 2)
30778 & / -0.1815341E+01, -0.1538698E+01, -0.2014208E+01 /
30779 DATA (AM( 7,K,-2),K=0, 2)
30780 & / -0.2571932E+02, 0.2903941E+00, -0.2848206E+01 /
30781
30782 DATA MEXVEC(-3) / 7 /
30783 DATA MLFVEC(-3) / 2 /
30784 DATA UT1VEC(-3) / 0.4518239E+01 /
30785 DATA UT2VEC(-3) / -0.2690590E+01 /
30786 DATA ALFVEC(-3) / 0.6124079E+00 /
30787 DATA QMAVEC(-3) / 0.0000000E+00 /
30788 DATA (AM( 0,K,-3),K=0, 2)
30789 & / -0.2734458E+01, -0.7245673E+00, -0.6351374E+00 /
30790 DATA (AM( 1,K,-3),K=0, 2)
30791 & / 0.2927174E+01, 0.4822709E+00, -0.1088787E-01 /
30792 DATA (AM( 2,K,-3),K=0, 2)
30793 & / -0.1771017E+02, -0.1416635E+01, 0.8467622E+01 /
30794 DATA (AM( 3,K,-3),K=0, 2)
30795 & / -0.4972782E+02, -0.3348547E+01, 0.1767061E+02 /
30796 DATA (AM( 4,K,-3),K=0, 2)
30797 & / -0.7102770E+01, -0.3205337E+01, 0.4101704E+00 /
30798 DATA (AM( 5,K,-3),K=0, 2)
30799 & / 0.7169698E+02, -0.2205985E+01, -0.2463931E+02 /
30800 DATA (AM( 6,K,-3),K=0, 2)
30801 & / -0.4090347E+02, 0.2103486E+01, 0.1416507E+02 /
30802 DATA (AM( 7,K,-3),K=0, 2)
30803 & / -0.2952639E+02, 0.5376136E+01, 0.7825585E+01 /
30804
30805 DATA MEXVEC(-4) / 7 /
30806 DATA MLFVEC(-4) / 2 /
30807 DATA UT1VEC(-4) / 0.2783230E+01 /
30808 DATA UT2VEC(-4) / -0.1746328E+01 /
30809 DATA ALFVEC(-4) / 0.1115653E+01 /
30810 DATA QMAVEC(-4) / 0.1300000E+01 /
30811 DATA (AM( 0,K,-4),K=0, 2)
30812 & / -0.1743872E+01, -0.1128921E+01, -0.2841969E+00 /
30813 DATA (AM( 1,K,-4),K=0, 2)
30814 & / 0.3345755E+01, 0.3187765E+00, 0.1378124E+00 /
30815 DATA (AM( 2,K,-4),K=0, 2)
30816 & / -0.2037615E+02, 0.4121687E+01, 0.2236520E+00 /
30817 DATA (AM( 3,K,-4),K=0, 2)
30818 & / -0.4703104E+02, 0.5353087E+01, -0.1455347E+01 /
30819 DATA (AM( 4,K,-4),K=0, 2)
30820 & / -0.1060230E+02, -0.1551122E+01, -0.1078863E+01 /
30821 DATA (AM( 5,K,-4),K=0, 2)
30822 & / 0.5088892E+02, -0.8197304E+01, 0.8083451E+01 /
30823 DATA (AM( 6,K,-4),K=0, 2)
30824 & / -0.2819070E+02, 0.4554086E+01, -0.5890995E+01 /
30825 DATA (AM( 7,K,-4),K=0, 2)
30826 & / -0.1098238E+02, 0.2590096E+01, -0.8062879E+01 /
30827
30828 DATA MEXVEC(-5) / 6 /
30829 DATA MLFVEC(-5) / 2 /
30830 DATA UT1VEC(-5) / 0.1619654E+02 /
30831 DATA UT2VEC(-5) / -0.3367346E+01 /
30832 DATA ALFVEC(-5) / 0.5109891E-02 /
30833 DATA QMAVEC(-5) / 0.4500000E+01 /
30834 DATA (AM( 0,K,-5),K=0, 2)
30835 & / -0.6800138E+01, 0.2493627E+01, -0.1075724E+01 /
30836 DATA (AM( 1,K,-5),K=0, 2)
30837 & / 0.3036555E+01, 0.3324733E+00, 0.2008298E+00 /
30838 DATA (AM( 2,K,-5),K=0, 2)
30839 & / -0.5203879E+01, -0.8493476E+01, -0.4523208E+01 /
30840 DATA (AM( 3,K,-5),K=0, 2)
30841 & / -0.1524239E+01, -0.3411912E+01, -0.1771867E+02 /
30842 DATA (AM( 4,K,-5),K=0, 2)
30843 & / -0.1099444E+02, 0.1320930E+01, -0.2353831E+01 /
30844 DATA (AM( 5,K,-5),K=0, 2)
30845 & / 0.1699299E+02, -0.3565802E+02, 0.3566872E+02 /
30846 DATA (AM( 6,K,-5),K=0, 2)
30847 & / -0.1465793E+02, 0.2703365E+02, -0.2176372E+02 /
30848
30849 IF(Q .LE. QMAVEC(IFL)) THEN
30850 PYCT5M = 0.D0
30851 RETURN
30852 ENDIF
30853
30854 IF(X .GE. 1.D0) THEN
30855 PYCT5M = 0.D0
30856 RETURN
30857 ENDIF
30858
30859 TMP = LOG(Q/ALFVEC(IFL))
30860 IF(TMP .LE. 0.D0) THEN
30861 PYCT5M = 0.D0
30862 RETURN
30863 ENDIF
30864
30865 SB = LOG(TMP)
30866 SB1 = SB - 1.2D0
30867 SB2 = SB1*SB1
30868
30869 DO 110 I = 0, NEX
30870 AF(I) = 0.D0
30871 SBX = 1.D0
30872 DO 100 K = 0, MLFVEC(IFL)
30873 AF(I) = AF(I) + SBX*AM(I,K,IFL)
30874 SBX = SB1*SBX
30875 100 CONTINUE
30876 110 CONTINUE
30877
30878 Y = -LOG(X)
30879 U = LOG(X/0.00001D0)
30880
30881 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
30882 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
30883 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
30884 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
30885 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
30886
30887 PYCT5M = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
30888
30889C...Include threshold factor.
30890 PYCT5M = PYCT5M * (1.D0 - QMAVEC(IFL)/Q)
30891
30892 RETURN
30893 END
30894
30895C*********************************************************************
30896
30897C...PYPDPO
30898C...Auxiliary to PYPDPR. Gives proton parton distributions according to
30899C...a few older parametrizations, now obsolete but convenient for
30900C...backwards checks.
30901
30902 SUBROUTINE PYPDPO(X,Q2,XPPR)
30903
30904C...Double precision and integer declarations.
30905 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30906 IMPLICIT INTEGER(I-N)
30907 INTEGER PYK,PYCHGE,PYCOMP
30908C...Commonblocks.
30909 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30910 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30911 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30912 COMMON/PYINT1/MINT(400),VINT(400)
30913 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
30914 DIMENSION XPPR(-6:6),XQ(9),TX(6),TT(6),TS(6),NEHLQ(8,2),
30915 &CEHLQ(6,6,2,8,2),CDO(3,6,5,2)
30916
30917
30918C...The following data lines are coefficients needed in the
30919C...Eichten, Hinchliffe, Lane, Quigg proton structure function
30920C...parametrizations, see below.
30921C...Powers of 1-x in different cases.
30922 DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
30923C...Expansion coefficients for up valence quark distribution.
30924 DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
30925 1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04,
30926 2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03,
30927 3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03,
30928 4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03,
30929 5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03,
30930 6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04,
30931 1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04,
30932 2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03,
30933 3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04,
30934 4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04,
30935 5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05,
30936 6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/
30937 DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
30938 1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04,
30939 2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03,
30940 3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03,
30941 4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03,
30942 5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03,
30943 6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04,
30944 1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04,
30945 2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03,
30946 3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04,
30947 4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04,
30948 5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05,
30949 6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/
30950C...Expansion coefficients for down valence quark distribution.
30951 DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
30952 1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04,
30953 2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03,
30954 3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03,
30955 4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03,
30956 5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04,
30957 6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04,
30958 1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04,
30959 2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03,
30960 3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04,
30961 4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04,
30962 5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05,
30963 6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/
30964 DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
30965 1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04,
30966 2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03,
30967 3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03,
30968 4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03,
30969 5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04,
30970 6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04,
30971 1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04,
30972 2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03,
30973 3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04,
30974 4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04,
30975 5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05,
30976 6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/
30977C...Expansion coefficients for up and down sea quark distributions.
30978 DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
30979 1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04,
30980 2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03,
30981 3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05,
30982 4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04,
30983 5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04,
30984 6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05,
30985 1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04,
30986 2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03,
30987 3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04,
30988 4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05,
30989 5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00,
30990 6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/
30991 DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
30992 1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04,
30993 2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03,
30994 3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04,
30995 4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04,
30996 5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04,
30997 6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04,
30998 1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03,
30999 2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03,
31000 3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04,
31001 4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05,
31002 5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05,
31003 6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/
31004C...Expansion coefficients for gluon distribution.
31005 DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
31006 1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02,
31007 2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02,
31008 3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02,
31009 4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03,
31010 5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04,
31011 6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03,
31012 1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02,
31013 2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02,
31014 3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02,
31015 4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03,
31016 5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03,
31017 6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/
31018 DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
31019 1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02,
31020 2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02,
31021 3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02,
31022 4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02,
31023 5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02,
31024 6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02,
31025 1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02,
31026 2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01,
31027 3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02,
31028 4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03,
31029 5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03,
31030 6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/
31031C...Expansion coefficients for strange sea quark distribution.
31032 DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
31033 1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04,
31034 2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03,
31035 3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04,
31036 4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04,
31037 5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04,
31038 6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05,
31039 1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04,
31040 2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03,
31041 3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04,
31042 4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05,
31043 5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00,
31044 6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/
31045 DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
31046 1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04,
31047 2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03,
31048 3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04,
31049 4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04,
31050 5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04,
31051 6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04,
31052 1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03,
31053 2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03,
31054 3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04,
31055 4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05,
31056 5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05,
31057 6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/
31058C...Expansion coefficients for charm sea quark distribution.
31059 DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
31060 1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03,
31061 2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03,
31062 3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04,
31063 4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05,
31064 5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05,
31065 6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05,
31066 1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04,
31067 2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03,
31068 3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04,
31069 4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04,
31070 5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05,
31071 6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/
31072 DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
31073 1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03,
31074 2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03,
31075 3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04,
31076 4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05,
31077 5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05,
31078 6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05,
31079 1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03,
31080 2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03,
31081 3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04,
31082 4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04,
31083 5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05,
31084 6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/
31085C...Expansion coefficients for bottom sea quark distribution.
31086 DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
31087 1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03,
31088 2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04,
31089 3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04,
31090 4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05,
31091 5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05,
31092 6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05,
31093 1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03,
31094 2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03,
31095 3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04,
31096 4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05,
31097 5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05,
31098 6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/
31099 DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
31100 1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03,
31101 2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04,
31102 3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04,
31103 4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05,
31104 5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00,
31105 6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05,
31106 1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03,
31107 2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03,
31108 3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04,
31109 4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05,
31110 5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05,
31111 6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/
31112C...Expansion coefficients for top sea quark distribution.
31113 DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
31114 1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04,
31115 2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04,
31116 3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04,
31117 4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00,
31118 5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05,
31119 6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
31120 1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03,
31121 2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03,
31122 3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04,
31123 4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05,
31124 5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00,
31125 6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/
31126 DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
31127 1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04,
31128 2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04,
31129 3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04,
31130 4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00,
31131 5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05,
31132 6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
31133 1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03,
31134 2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03,
31135 3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04,
31136 4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05,
31137 5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00,
31138 6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/
31139
31140C...The following data lines are coefficients needed in the
31141C...Duke, Owens proton structure function parametrizations, see below.
31142C...Expansion coefficients for (up+down) valence quark distribution.
31143 DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/
31144 1 4.190D-01, 3.460D+00, 4.400D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31145 2 4.000D-03, 7.240D-01,-4.860D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31146 3-7.000D-03,-6.600D-02, 1.330D+00, 0.000D+00, 0.000D+00, 0.000D+00/
31147 DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/
31148 1 3.740D-01, 3.330D+00, 6.030D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31149 2 1.400D-02, 7.530D-01,-6.220D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31150 3 0.000D+00,-7.600D-02, 1.560D+00, 0.000D+00, 0.000D+00, 0.000D+00/
31151C...Expansion coefficients for down valence quark distribution.
31152 DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/
31153 1 7.630D-01, 4.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31154 2-2.370D-01, 6.270D-01,-4.210D-01, 0.000D+00, 0.000D+00, 0.000D+00,
31155 3 2.600D-02,-1.900D-02, 3.300D-02, 0.000D+00, 0.000D+00, 0.000D+00/
31156 DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/
31157 1 7.610D-01, 3.830D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31158 2-2.320D-01, 6.270D-01,-4.180D-01, 0.000D+00, 0.000D+00, 0.000D+00,
31159 3 2.300D-02,-1.900D-02, 3.600D-02, 0.000D+00, 0.000D+00, 0.000D+00/
31160C...Expansion coefficients for (up+down+strange) sea quark distribution.
31161 DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/
31162 1 1.265D+00, 0.000D+00, 8.050D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31163 2-1.132D+00,-3.720D-01, 1.590D+00, 6.310D+00,-1.050D+01, 1.470D+01,
31164 3 2.930D-01,-2.900D-02,-1.530D-01,-2.730D-01,-3.170D+00, 9.800D+00/
31165 DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/
31166 1 1.670D+00, 0.000D+00, 9.150D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31167 2-1.920D+00,-2.730D-01, 5.300D-01, 1.570D+01,-1.010D+02, 2.230D+02,
31168 3 5.820D-01,-1.640D-01,-7.630D-01,-2.830D+00, 4.470D+01,-1.170D+02/
31169C...Expansion coefficients for charm sea quark distribution.
31170 DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/
31171 1 0.000D+00,-3.600D-02, 6.350D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31172 2 1.350D-01,-2.220D-01, 3.260D+00,-3.030D+00, 1.740D+01,-1.790D+01,
31173 3-7.500D-02,-5.800D-02,-9.090D-01, 1.500D+00,-1.130D+01, 1.560D+01/
31174 DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/
31175 1 0.000D+00,-1.200D-01, 3.510D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31176 2 6.700D-02,-2.330D-01, 3.660D+00,-4.740D-01, 9.500D+00,-1.660D+01,
31177 3-3.100D-02,-2.300D-02,-4.530D-01, 3.580D-01,-5.430D+00, 1.550D+01/
31178C...Expansion coefficients for gluon distribution.
31179 DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/
31180 1 1.560D+00, 0.000D+00, 6.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
31181 2-1.710D+00,-9.490D-01, 1.440D+00,-7.190D+00,-1.650D+01, 1.530D+01,
31182 3 6.380D-01, 3.250D-01,-1.050D+00, 2.550D-01, 1.090D+01,-1.010D+01/
31183 DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/
31184 1 8.790D-01, 0.000D+00, 4.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
31185 2-9.710D-01,-1.160D+00, 1.230D+00,-5.640D+00,-7.540D+00,-5.960D-01,
31186 3 4.340D-01, 4.760D-01,-2.540D-01,-8.170D-01, 5.500D+00, 1.260D-01/
31187
31188C...Euler's beta function, requires ordinary Gamma function
31189 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
31190
31191C...Leading order proton parton distributions from Glueck, Reya and
31192C...Vogt. Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
31193C...10^-5 < x < 1.
31194 IF(MSTP(51).EQ.11) THEN
31195
31196C...Determine s expansion variable and some x expressions.
31197 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
31198 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
31199 SD2=SD**2
31200 XL=-LOG(X)
31201 XS=SQRT(X)
31202
31203C...Evaluate valence, gluon and sea distributions.
31204 XFVUD=(0.663D0+0.191D0*SD-0.041D0*SD2+0.031D0*SD**3)*
31205 & X**0.326D0*(1D0+(-1.97D0+6.74D0*SD-1.96D0*SD2)*XS+
31206 & (24.4D0-20.7D0*SD+4.08D0*SD2)*X)*
31207 & (1D0-X)**(2.86D0+0.70D0*SD-0.02D0*SD2)
31208 XFVDD=(0.579D0+0.283D0*SD+0.047D0*SD2)*X**(0.523D0-0.015D0*SD)*
31209 & (1D0+(2.22D0-0.59D0*SD-0.27D0*SD2)*XS+(5.95D0-6.19D0*SD+
31210 & 1.55D0*SD2)*X)*(1D0-X)**(3.57D0+0.94D0*SD-0.16D0*SD2)
31211 XFGLU=(X**(1.00D0-0.17D0*SD)*((4.879D0*SD-1.383D0*SD2)+
31212 & (25.92D0-28.97D0*SD+5.596D0*SD2)*X+(-25.69D0+23.68D0*SD-
31213 & 1.975D0*SD2)*X**2)+SD**0.558D0*EXP(-(0.595D0+2.138D0*SD)+
31214 & SQRT(4.066D0*SD**1.218D0*XL)))*
31215 & (1D0-X)**(2.537D0+1.718D0*SD+0.353D0*SD2)
31216 XFSEA=(X**(0.412D0-0.171D0*SD)*(0.363D0-1.196D0*X+(1.029D0+
31217 & 1.785D0*SD-0.459D0*SD2)*X**2)*XL**(0.566D0-0.496D0*SD)+
31218 & SD**1.396D0*EXP(-(3.838D0+1.944D0*SD)+SQRT(2.845D0*SD**1.331D0*
31219 & XL)))*(1D0-X)**(4.696D0+2.109D0*SD)
31220 XFSTR=SD**0.803D0*(1D0+(-3.055D0+1.024D0*SD**0.67D0)*XS+
31221 & (27.4D0-20.0D0*SD**0.154D0)*X)*(1D0-X)**6.22D0*
31222 & EXP(-(4.33D0+1.408D0*SD)+SQRT((8.27D0-0.437D0*SD)*
31223 & SD**0.563D0*XL))/XL**(2.082D0-0.577D0*SD)
31224 IF(SD.LE.0.888D0) THEN
31225 XFCHM=0D0
31226 ELSE
31227 XFCHM=(SD-0.888D0)**1.01D0*(1.+(4.24D0-0.804D0*SD)*X)*
31228 & (1D0-X)**(3.46D0+1.076D0*SD)*EXP(-(4.61D0+1.49D0*SD)+
31229 & SQRT((2.555D0+1.961D0*SD)*SD**0.37D0*XL))
31230 ENDIF
31231 IF(SD.LE.1.351D0) THEN
31232 XFBOT=0D0
31233 ELSE
31234 XFBOT=(SD-1.351D0)*(1D0+1.848D0*X)*(1D0-X)**(2.929D0+
31235 & 1.396D0*SD)*EXP(-(4.71D0+1.514D0*SD)+
31236 & SQRT((4.02D0+1.239D0*SD)*SD**0.51D0*XL))
31237 ENDIF
31238
31239C...Put into output array.
31240 XPPR(0)=XFGLU
31241 XPPR(1)=XFVDD+XFSEA
31242 XPPR(2)=XFVUD-XFVDD+XFSEA
31243 XPPR(3)=XFSTR
31244 XPPR(4)=XFCHM
31245 XPPR(5)=XFBOT
31246 XPPR(-1)=XFSEA
31247 XPPR(-2)=XFSEA
31248 XPPR(-3)=XFSTR
31249 XPPR(-4)=XFCHM
31250 XPPR(-5)=XFBOT
31251
31252C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg.
31253C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1
31254 ELSEIF(MSTP(51).EQ.12.OR.MSTP(51).EQ.13) THEN
31255
31256C...Determine set, Lambda and x and t expansion variables.
31257 NSET=MSTP(51)-11
31258 IF(NSET.EQ.1) ALAM=0.2D0
31259 IF(NSET.EQ.2) ALAM=0.29D0
31260 TMIN=LOG(5D0/ALAM**2)
31261 TMAX=LOG(1D8/ALAM**2)
31262 T=LOG(MAX(1D0,Q2/ALAM**2))
31263 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
31264 NX=1
31265 IF(X.LE.0.1D0) NX=2
31266 IF(NX.EQ.1) VX=(2D0*X-1.1D0)/0.9D0
31267 IF(NX.EQ.2) VX=MAX(-1D0,(2D0*LOG(X)+11.51293D0)/6.90776D0)
31268
31269C...Chebyshev polynomials for x and t expansion.
31270 TX(1)=1D0
31271 TX(2)=VX
31272 TX(3)=2D0*VX**2-1D0
31273 TX(4)=4D0*VX**3-3D0*VX
31274 TX(5)=8D0*VX**4-8D0*VX**2+1D0
31275 TX(6)=16D0*VX**5-20D0*VX**3+5D0*VX
31276 TT(1)=1D0
31277 TT(2)=VT
31278 TT(3)=2D0*VT**2-1D0
31279 TT(4)=4D0*VT**3-3D0*VT
31280 TT(5)=8D0*VT**4-8D0*VT**2+1D0
31281 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
31282
31283C...Calculate structure functions.
31284 DO 120 KFL=1,6
31285 XQSUM=0D0
31286 DO 110 IT=1,6
31287 DO 100 IX=1,6
31288 XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)
31289 100 CONTINUE
31290 110 CONTINUE
31291 XQ(KFL)=XQSUM*(1D0-X)**NEHLQ(KFL,NSET)
31292 120 CONTINUE
31293
31294C...Put into output array.
31295 XPPR(0)=XQ(4)
31296 XPPR(1)=XQ(2)+XQ(3)
31297 XPPR(2)=XQ(1)+XQ(3)
31298 XPPR(3)=XQ(5)
31299 XPPR(4)=XQ(6)
31300 XPPR(-1)=XQ(3)
31301 XPPR(-2)=XQ(3)
31302 XPPR(-3)=XQ(5)
31303 XPPR(-4)=XQ(6)
31304
31305C...Special expansion for bottom (threshold effects).
31306 IF(MSTP(58).GE.5) THEN
31307 IF(NSET.EQ.1) TMIN=8.1905D0
31308 IF(NSET.EQ.2) TMIN=7.4474D0
31309 IF(T.GT.TMIN) THEN
31310 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
31311 TT(1)=1D0
31312 TT(2)=VT
31313 TT(3)=2D0*VT**2-1D0
31314 TT(4)=4D0*VT**3-3D0*VT
31315 TT(5)=8D0*VT**4-8D0*VT**2+1D0
31316 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
31317 XQSUM=0D0
31318 DO 140 IT=1,6
31319 DO 130 IX=1,6
31320 XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)
31321 130 CONTINUE
31322 140 CONTINUE
31323 XPPR(5)=XQSUM*(1D0-X)**NEHLQ(7,NSET)
31324 XPPR(-5)=XPPR(5)
31325 ENDIF
31326 ENDIF
31327
31328C...Special expansion for top (threshold effects).
31329 IF(MSTP(58).GE.6) THEN
31330 IF(NSET.EQ.1) TMIN=11.5528D0
31331 IF(NSET.EQ.2) TMIN=10.8097D0
31332 TMIN=TMIN+2D0*LOG(PMAS(6,1)/30D0)
31333 TMAX=TMAX+2D0*LOG(PMAS(6,1)/30D0)
31334 IF(T.GT.TMIN) THEN
31335 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
31336 TT(1)=1D0
31337 TT(2)=VT
31338 TT(3)=2D0*VT**2-1D0
31339 TT(4)=4D0*VT**3-3D0*VT
31340 TT(5)=8D0*VT**4-8D0*VT**2+1D0
31341 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
31342 XQSUM=0D0
31343 DO 160 IT=1,6
31344 DO 150 IX=1,6
31345 XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)
31346 150 CONTINUE
31347 160 CONTINUE
31348 XPPR(6)=XQSUM*(1D0-X)**NEHLQ(8,NSET)
31349 XPPR(-6)=XPPR(6)
31350 ENDIF
31351 ENDIF
31352
31353C...Proton parton distributions from Duke, Owens.
31354C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2.
31355 ELSEIF(MSTP(51).EQ.14.OR.MSTP(51).EQ.15) THEN
31356
31357C...Determine set, Lambda and s expansion parameter.
31358 NSET=MSTP(51)-13
31359 IF(NSET.EQ.1) ALAM=0.2D0
31360 IF(NSET.EQ.2) ALAM=0.4D0
31361 Q2IN=MIN(1D6,MAX(4D0,Q2))
31362 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
31363
31364C...Calculate structure functions.
31365 DO 180 KFL=1,5
31366 DO 170 IS=1,6
31367 TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+
31368 & CDO(3,IS,KFL,NSET)*SD**2
31369 170 CONTINUE
31370 IF(KFL.LE.2) THEN
31371 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)*(1D0+TS(3)*X)/(EULBET(TS(1),
31372 & TS(2)+1D0)*(1D0+TS(3)*TS(1)/(TS(1)+TS(2)+1D0)))
31373 ELSE
31374 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
31375 & TS(5)*X**2+TS(6)*X**3)
31376 ENDIF
31377 180 CONTINUE
31378
31379C...Put into output arrays.
31380 XPPR(0)=XQ(5)
31381 XPPR(1)=XQ(2)+XQ(3)/6D0
31382 XPPR(2)=3D0*XQ(1)-XQ(2)+XQ(3)/6D0
31383 XPPR(3)=XQ(3)/6D0
31384 XPPR(4)=XQ(4)
31385 XPPR(-1)=XQ(3)/6D0
31386 XPPR(-2)=XQ(3)/6D0
31387 XPPR(-3)=XQ(3)/6D0
31388 XPPR(-4)=XQ(4)
31389
31390 ENDIF
31391
31392 RETURN
31393 END
31394
31395C*********************************************************************
31396
31397C...PYHFTH
31398C...Gives threshold attractive/repulsive factor for heavy flavour
31399C...production.
31400
31401 FUNCTION PYHFTH(SH,SQM,FRATT)
31402
31403C...Double precision and integer declarations.
31404 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31405 IMPLICIT INTEGER(I-N)
31406 INTEGER PYK,PYCHGE,PYCOMP
31407C...Commonblocks.
31408 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31409 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
31410 COMMON/PYINT1/MINT(400),VINT(400)
31411 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
31412
31413C...Value for alpha_strong.
31414 IF(MSTP(35).LE.1) THEN
31415 ALSSG=PARP(35)
31416 ELSE
31417 MST115=MSTU(115)
31418 MSTU(115)=MSTP(36)
31419 Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+
31420 & PARP(36)**2)))
31421 ALSSG=PYALPS(Q2BN)
31422 MSTU(115)=MST115
31423 ENDIF
31424
31425C...Evaluate attractive and repulsive factors.
31426 XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
31427 FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
31428 XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
31429 FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
31430 PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU
31431 VINT(138)=PYHFTH
31432
31433 RETURN
31434 END
31435
31436C*********************************************************************
31437
31438C...PYSPLI
31439C...Splits a hadron remnant into two (partons or hadron + parton)
31440C...in case it is more complicated than just a quark or a diquark.
31441
31442 SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
31443
31444C...Double precision and integer declarations.
31445 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31446 IMPLICIT INTEGER(I-N)
31447 INTEGER PYK,PYCHGE,PYCOMP
31448C...Commonblocks. PYDAT1 temporary
31449 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
31450 COMMON/PYINT1/MINT(400),VINT(400)
31451 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31452 SAVE /PYPARS/,/PYINT1/,/PYDAT1/
31453C...Local array.
31454 DIMENSION KFL(3)
31455
31456C...Preliminaries. Parton composition.
31457 KFA=IABS(KF)
31458 KFS=ISIGN(1,KF)
31459 KFL(1)=MOD(KFA/1000,10)
31460 KFL(2)=MOD(KFA/100,10)
31461 KFL(3)=MOD(KFA/10,10)
31462 IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
31463 KFL(2)=INT(1.5D0+PYR(0))
31464 IF(MINT(105).EQ.333) KFL(2)=3
31465 IF(MINT(105).EQ.443) KFL(2)=4
31466 KFL(3)=KFL(2)
31467 ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN
31468 KFL(2)=2
31469 KFL(3)=2
31470 ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN
31471 KFL(2)=1
31472 KFL(3)=1
31473 ELSEIF((KFA.EQ.130.OR.KFA.EQ.310).AND.PYR(0).GT.0.5D0) THEN
31474 KFL(2)=MOD(KFA/10,10)
31475 KFL(3)=MOD(KFA/100,10)
31476 ENDIF
31477 IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN
31478 KFLR=KFLIN*KFS
31479 ELSE
31480 KFLR=KFLIN
31481 ENDIF
31482 KFLCH=0
31483
31484C...Subdivide lepton.
31485 IF(KFA.GE.11.AND.KFA.LE.18) THEN
31486 IF(KFLR.EQ.KFA) THEN
31487 KFLSP=KFS*22
31488 ELSEIF(KFLR.EQ.22) THEN
31489 KFLSP=KFA
31490 ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN
31491 KFLSP=KFA+1
31492 ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN
31493 KFLSP=KFA-1
31494 ELSEIF(KFLR.EQ.21) THEN
31495 KFLSP=KFA
31496 KFLCH=KFS*21
31497 ELSE
31498 KFLSP=KFA
31499 KFLCH=-KFLR
31500 ENDIF
31501
31502C...Subdivide photon.
31503 ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN
31504 IF(KFLR.NE.21) THEN
31505 KFLSP=-KFLR
31506 ELSE
31507 RAGR=0.75D0*PYR(0)
31508 KFLSP=1
31509 IF(RAGR.GT.0.125D0) KFLSP=2
31510 IF(RAGR.GT.0.625D0) KFLSP=3
31511 IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP
31512 KFLCH=-KFLSP
31513 ENDIF
31514
31515C...Subdivide Reggeon or Pomeron.
31516 ELSEIF(KFA.EQ.110.OR.KFA.EQ.990) THEN
31517 IF(KFLIN.EQ.21) THEN
31518 KFLSP=KFS*21
31519 ELSE
31520 KFLSP=-KFLIN
31521 ENDIF
31522
31523C...Subdivide meson.
31524 ELSEIF(KFL(1).EQ.0) THEN
31525 KFL(2)=KFL(2)*(-1)**KFL(2)
31526 KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
31527 IF(KFLR.EQ.KFL(2)) THEN
31528 KFLSP=KFL(3)
31529 ELSEIF(KFLR.EQ.KFL(3)) THEN
31530 KFLSP=KFL(2)
31531 ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN
31532 KFLSP=KFL(2)
31533 KFLCH=KFL(3)
31534 ELSEIF(KFLR.EQ.21) THEN
31535 KFLSP=KFL(3)
31536 KFLCH=KFL(2)
31537 ELSEIF(KFLR*KFL(2).GT.0) THEN
31538 NTRY=0
31539 100 NTRY=NTRY+1
31540 CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
31541 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
31542 GOTO 100
31543 ELSEIF(KFLCH.EQ.0) THEN
31544 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
31545 MINT(51)=1
31546 RETURN
31547 ENDIF
31548 KFLSP=KFL(3)
31549 ELSE
31550 NTRY=0
31551 110 NTRY=NTRY+1
31552 CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
31553 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
31554 GOTO 110
31555 ELSEIF(KFLCH.EQ.0) THEN
31556 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
31557 MINT(51)=1
31558 RETURN
31559 ENDIF
31560 KFLSP=KFL(2)
31561 ENDIF
31562
31563C...Subdivide baryon.
31564 ELSE
31565 NAGR=0
31566 DO 120 J=1,3
31567 IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
31568 120 CONTINUE
31569 IF(NAGR.GE.1) THEN
31570 RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0)
31571 IAGR=0
31572 DO 130 J=1,3
31573 IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0
31574 IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J
31575 130 CONTINUE
31576 ELSE
31577 IAGR=1.00001D0+2.99998D0*PYR(0)
31578 ENDIF
31579 ID1=1
31580 IF(IAGR.EQ.1) ID1=2
31581 IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
31582 ID2=6-IAGR-ID1
31583 KSP=3
31584 IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
31585 IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1
31586 ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
31587 IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1
31588 ELSEIF(MOD(KFA,10).EQ.2) THEN
31589 IF(IAGR.EQ.1) KSP=1
31590 IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1
31591 ENDIF
31592 KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
31593 IF(KFLR.EQ.21) THEN
31594 KFLCH=KFL(IAGR)
31595 ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
31596 NTRY=0
31597 140 NTRY=NTRY+1
31598 CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
31599 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
31600 GOTO 140
31601 ELSEIF(KFLCH.EQ.0) THEN
31602 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
31603 MINT(51)=1
31604 RETURN
31605 ENDIF
31606 ELSEIF(NAGR.EQ.0) THEN
31607 NTRY=0
31608 150 NTRY=NTRY+1
31609 CALL PYKFDI(10000*KFL(ID1)+KFLSP,-KFLR,KFDUMP,KFLCH)
31610 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
31611 GOTO 150
31612 ELSEIF(KFLCH.EQ.0) THEN
31613 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
31614 MINT(51)=1
31615 RETURN
31616 ENDIF
31617 KFLSP=KFL(IAGR)
31618 ENDIF
31619 ENDIF
31620
31621C...Add on correct sign for result.
31622 KFLCH=KFLCH*KFS
31623 KFLSP=KFLSP*KFS
31624
31625 RETURN
31626 END
31627
31628C*********************************************************************
31629
31630C...PYGAMM
31631C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
31632C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
31633C...(Dover, 1965) 6.1.36.
31634
31635 FUNCTION PYGAMM(X)
31636
31637C...Double precision and integer declarations.
31638 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31639 IMPLICIT INTEGER(I-N)
31640 INTEGER PYK,PYCHGE,PYCOMP
31641C...Local array and data.
31642 DIMENSION B(8)
31643 DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
31644 &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/
31645
31646 NX=INT(X)
31647 DX=X-NX
31648
31649 PYGAMM=1D0
31650 DXP=1D0
31651 DO 100 I=1,8
31652 DXP=DXP*DX
31653 PYGAMM=PYGAMM+B(I)*DXP
31654 100 CONTINUE
31655 IF(X.LT.1D0) THEN
31656 PYGAMM=PYGAMM/X
31657 ELSE
31658 DO 110 IX=1,NX-1
31659 PYGAMM=(X-IX)*PYGAMM
31660 110 CONTINUE
31661 ENDIF
31662
31663 RETURN
31664 END
31665
31666C***********************************************************************
31667
31668C...PYWAUX
31669C...Calculates real and imaginary parts of the auxiliary functions W1
31670C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
31671C...der Bij, Nucl. Phys. B297 (1988) 221.
31672
31673 SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)
31674
31675C...Double precision and integer declarations.
31676 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31677 IMPLICIT INTEGER(I-N)
31678 INTEGER PYK,PYCHGE,PYCOMP
31679C...Commonblocks.
31680 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31681 SAVE /PYDAT1/
31682
31683 ASINH(X)=LOG(X+SQRT(X**2+1D0))
31684 ACOSH(X)=LOG(X+SQRT(X**2-1D0))
31685
31686 IF(EPS.LT.0D0) THEN
31687 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
31688 IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
31689 WIM=0D0
31690 ELSEIF(EPS.LT.1D0) THEN
31691 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
31692 IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
31693 IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
31694 IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
31695 ELSE
31696 IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
31697 IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
31698 WIM=0D0
31699 ENDIF
31700
31701 RETURN
31702 END
31703
31704C***********************************************************************
31705
31706C...PYI3AU
31707C...Calculates real and imaginary parts of the auxiliary function I3;
31708C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
31709C...Nucl. Phys. B297 (1988) 221.
31710
31711 SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM)
31712
31713C...Double precision and integer declarations.
31714 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31715 IMPLICIT INTEGER(I-N)
31716 INTEGER PYK,PYCHGE,PYCOMP
31717C...Commonblocks.
31718 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31719 SAVE /PYDAT1/
31720
31721 BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS))
31722 IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS))
31723
31724 IF(EPS.LT.0D0) THEN
31725 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
31726 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
31727 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
31728 & PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)-
31729 & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-
31730 & LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)*
31731 & LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+
31732 & LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)*
31733 & EPS))
31734 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
31735 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
31736 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
31737 & PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)-
31738 & PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+
31739 & 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+
31740 & LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+
31741 & LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS))
31742 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
31743 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
31744 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
31745 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)-
31746 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+
31747 & 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+
31748 & LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+
31749 & LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS))
31750 ELSE
31751 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
31752 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)-
31753 & PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2-
31754 & LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+
31755 & LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0))
31756 ENDIF
31757 F3IM=0D0
31758 ELSEIF(EPS.LT.1D0) THEN
31759 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
31760 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
31761 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
31762 & PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)-
31763 & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
31764 & (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
31765 & (0.25D0*(RAT+1D0)*EPS))
31766 F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
31767 & (0.25D0*(RAT+1D0)*EPS))
31768 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
31769 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
31770 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
31771 & PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)-
31772 & PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+
31773 & LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))*
31774 & LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
31775 F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
31776 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
31777 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
31778 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
31779 & PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)-
31780 & PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+
31781 & LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/
31782 & (1D0+0.25D0*RAT*EPS-GA))
31783 F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/
31784 & (1D0+0.25D0*RAT*EPS-GA))
31785 ELSE
31786 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
31787 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)-
31788 & PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))*
31789 & LOG((GA+BE-1D0)/(BE-GA))
31790 F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA))
31791 ENDIF
31792 ELSE
31793 RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2)
31794 RCTHE=RSQ*(1D0-2D0*BE/EPS)
31795 RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2))
31796 RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS)
31797 RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2))
31798 R=SQRT(RSQ)
31799 THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R)))
31800 PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R)))
31801 F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
31802 & PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
31803 & (PHI-THE)*(PHI+THE-PARU(1))
31804 F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
31805 & PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
31806 ENDIF
31807
31808 Y3RE=2D0/(2D0*BE-1D0)*F3RE
31809 Y3IM=2D0/(2D0*BE-1D0)*F3IM
31810
31811 RETURN
31812 END
31813
31814C***********************************************************************
31815
31816C...PYSPEN
31817C...Calculates real and imaginary part of Spence function; see
31818C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
31819
31820 FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
31821
31822C...Double precision and integer declarations.
31823 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31824 IMPLICIT INTEGER(I-N)
31825 INTEGER PYK,PYCHGE,PYCOMP
31826C...Commonblocks.
31827 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31828 SAVE /PYDAT1/
31829C...Local array and data.
31830 DIMENSION B(0:14)
31831 DATA B/
31832 &1.000000D+00, -5.000000D-01, 1.666667D-01,
31833 &0.000000D+00, -3.333333D-02, 0.000000D+00,
31834 &2.380952D-02, 0.000000D+00, -3.333333D-02,
31835 &0.000000D+00, 7.575757D-02, 0.000000D+00,
31836 &-2.531135D-01, 0.000000D+00, 1.166667D+00/
31837
31838 XRE=XREIN
31839 XIM=XIMIN
31840 IF(ABS(1D0-XRE).LT.1D-6.AND.ABS(XIM).LT.1D-6) THEN
31841 IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
31842 IF(IREIM.EQ.2) PYSPEN=0D0
31843 RETURN
31844 ENDIF
31845
31846 XMOD=SQRT(XRE**2+XIM**2)
31847 IF(XMOD.LT.1D-6) THEN
31848 IF(IREIM.EQ.1) PYSPEN=0D0
31849 IF(IREIM.EQ.2) PYSPEN=0D0
31850 RETURN
31851 ENDIF
31852
31853 XARG=SIGN(ACOS(XRE/XMOD),XIM)
31854 SP0RE=0D0
31855 SP0IM=0D0
31856 SGN=1D0
31857 IF(XMOD.GT.1D0) THEN
31858 ALGXRE=LOG(XMOD)
31859 ALGXIM=XARG-SIGN(PARU(1),XARG)
31860 SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
31861 SP0IM=-ALGXRE*ALGXIM
31862 SGN=-1D0
31863 XMOD=1D0/XMOD
31864 XARG=-XARG
31865 XRE=XMOD*COS(XARG)
31866 XIM=XMOD*SIN(XARG)
31867 ENDIF
31868 IF(XRE.GT.0.5D0) THEN
31869 ALGXRE=LOG(XMOD)
31870 ALGXIM=XARG
31871 XRE=1D0-XRE
31872 XIM=-XIM
31873 XMOD=SQRT(XRE**2+XIM**2)
31874 XARG=SIGN(ACOS(XRE/XMOD),XIM)
31875 ALGYRE=LOG(XMOD)
31876 ALGYIM=XARG
31877 SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
31878 SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
31879 SGN=-SGN
31880 ENDIF
31881
31882 XRE=1D0-XRE
31883 XIM=-XIM
31884 XMOD=SQRT(XRE**2+XIM**2)
31885 XARG=SIGN(ACOS(XRE/XMOD),XIM)
31886 ZRE=-LOG(XMOD)
31887 ZIM=-XARG
31888
31889 SPRE=0D0
31890 SPIM=0D0
31891 SAVERE=1D0
31892 SAVEIM=0D0
31893 DO 100 I=0,14
31894 IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
31895 TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
31896 TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
31897 SAVERE=TERMRE
31898 SAVEIM=TERMIM
31899 SPRE=SPRE+B(I)*TERMRE
31900 SPIM=SPIM+B(I)*TERMIM
31901 100 CONTINUE
31902
31903 110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
31904 IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
31905
31906 RETURN
31907 END
31908
31909C***********************************************************************
31910
31911C...PYQQBH
31912C...Calculates the matrix element for the processes
31913C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
31914C...REDUCE output and part of the rest courtesy Z. Kunszt, see
31915C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
31916
31917 SUBROUTINE PYQQBH(WTQQBH)
31918
31919C...Double precision and integer declarations.
31920 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31921 IMPLICIT INTEGER(I-N)
31922 INTEGER PYK,PYCHGE,PYCOMP
31923C...Commonblocks.
31924 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31925 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31926 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
31927 COMMON/PYINT1/MINT(400),VINT(400)
31928 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
31929 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/
31930C...Local arrays and function.
31931 DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8)
31932 DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)-
31933 &PP(I,3)*PP(J,3)
31934
31935C...Mass parameters.
31936 WTQQBH=0D0
31937 ISUB=MINT(1)
31938 SHPR=SQRT(VINT(26))*VINT(1)
31939 PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1)
31940 PH=SQRT(VINT(21))*VINT(1)
31941 SPQ=PQ**2
31942 SPH=PH**2
31943
31944C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
31945 DO 100 I=1,2
31946 PT=SQRT(MAX(0D0,VINT(197+5*I)))
31947 PP(I,1)=PT*COS(VINT(198+5*I))
31948 PP(I,2)=PT*SIN(VINT(198+5*I))
31949 100 CONTINUE
31950 PP(3,1)=-PP(1,1)-PP(2,1)
31951 PP(3,2)=-PP(1,2)-PP(2,2)
31952 PMS1=SPQ+PP(1,1)**2+PP(1,2)**2
31953 PMS2=SPQ+PP(2,1)**2+PP(2,2)**2
31954 PMS3=SPH+PP(3,1)**2+PP(3,2)**2
31955 PMT3=SQRT(PMS3)
31956 PP(3,3)=PMT3*SINH(VINT(211))
31957 PP(3,4)=PMT3*COSH(VINT(211))
31958 PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2
31959 PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
31960 &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12)
31961 PP(2,3)=-PP(1,3)-PP(3,3)
31962 PP(1,4)=SQRT(PMS1+PP(1,3)**2)
31963 PP(2,4)=SQRT(PMS2+PP(2,3)**2)
31964
31965C...Set up incoming kinematics and derived momentum combinations.
31966 DO 110 I=4,5
31967 PP(I,1)=0D0
31968 PP(I,2)=0D0
31969 PP(I,3)=-0.5D0*SHPR*(-1)**I
31970 PP(I,4)=-0.5D0*SHPR
31971 110 CONTINUE
31972 DO 120 J=1,4
31973 PP(6,J)=PP(1,J)+PP(2,J)
31974 PP(7,J)=PP(1,J)+PP(3,J)
31975 PP(8,J)=PP(1,J)+PP(4,J)
31976 PP(9,J)=PP(1,J)+PP(5,J)
31977 PP(10,J)=-PP(2,J)-PP(3,J)
31978 PP(11,J)=-PP(2,J)-PP(4,J)
31979 PP(12,J)=-PP(2,J)-PP(5,J)
31980 PP(13,J)=-PP(4,J)-PP(5,J)
31981 120 CONTINUE
31982
31983C...Derived kinematics invariants.
31984 X1=DOT(1,2)
31985 X2=DOT(1,3)
31986 X3=DOT(1,4)
31987 X4=DOT(1,5)
31988 X5=DOT(2,3)
31989 X6=DOT(2,4)
31990 X7=DOT(2,5)
31991 X8=DOT(3,4)
31992 X9=DOT(3,5)
31993 X10=DOT(4,5)
31994
31995C...Propagators.
31996 SS1=DOT(7,7)-SPQ
31997 SS2=DOT(8,8)-SPQ
31998 SS3=DOT(9,9)-SPQ
31999 SS4=DOT(10,10)-SPQ
32000 SS5=DOT(11,11)-SPQ
32001 SS6=DOT(12,12)-SPQ
32002 SS7=DOT(13,13)
32003 DX(1)=SS1*SS6
32004 DX(2)=SS2*SS6
32005 DX(3)=SS2*SS4
32006 DX(4)=SS1*SS5
32007 DX(5)=SS3*SS5
32008 DX(6)=SS3*SS4
32009 DX(7)=SS7*SS1
32010 DX(8)=SS7*SS4
32011
32012C...Define colour coefficients for g + g -> Q + Qbar + H.
32013 IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN
32014 DO 140 I=1,3
32015 DO 130 J=1,3
32016 CLR(I,J)=16D0/3D0
32017 CLR(I+3,J+3)=16D0/3D0
32018 CLR(I,J+3)=-2D0/3D0
32019 CLR(I+3,J)=-2D0/3D0
32020 130 CONTINUE
32021 140 CONTINUE
32022 DO 160 L=1,2
32023 DO 150 I=1,3
32024 CLR(I,6+L)=-6D0
32025 CLR(I+3,6+L)=6D0
32026 CLR(6+L,I)=-6D0
32027 CLR(6+L,I+3)=6D0
32028 150 CONTINUE
32029 160 CONTINUE
32030 DO 180 K1=1,2
32031 DO 170 K2=1,2
32032 CLR(6+K1,6+K2)=12D0
32033 170 CONTINUE
32034 180 CONTINUE
32035
32036C...Evaluate matrix elements for g + g -> Q + Qbar + H.
32037 FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2*
32038 & X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2*
32039 & X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7
32040 FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2
32041 & *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2*
32042 & X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+
32043 & X10)
32044 FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4*
32045 & X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10
32046 & +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
32047 & -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7
32048 & -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+
32049 & X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6)
32050 FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10-
32051 & X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6
32052 & )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+
32053 & 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2*
32054 & X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6)
32055 FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1*
32056 & X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1*
32057 & X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4
32058 & *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1**
32059 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4*
32060 & X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7
32061 & +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5-
32062 & X4*X6*X5)
32063 FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4-
32064 & X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3*
32065 & X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2
32066 & *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5
32067 & +X4*X9*X5+X4*X5**2)
32068 FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2*
32069 & PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1*
32070 & X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3*
32071 & X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7*
32072 & X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7-
32073 & X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5)
32074 FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2*
32075 & PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+
32076 & 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8*
32077 & X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6
32078 & +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8*
32079 & X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4*
32080 & X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2*
32081 & X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+
32082 & X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2)
32083 FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*(
32084 & X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7
32085 FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2
32086 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3*
32087 & X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+
32088 & X6)
32089 FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1*
32090 & X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1*
32091 & X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4
32092 & *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1
32093 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4
32094 & *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3*
32095 & X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6*
32096 & X5+X4*X6*X5)
32097 FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1
32098 & *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3-
32099 & 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4-
32100 & X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1*
32101 & X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3
32102 & *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4*
32103 & X6**2)
32104 FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1*
32105 & X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1*
32106 & X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4*
32107 & X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1**
32108 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4*
32109 & X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7
32110 & -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5-
32111 & X4*X6*X5)
32112 FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
32113 & 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
32114 & X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3*
32115 & X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2
32116 & *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5
32117 & +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
32118 & -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1*
32119 & X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1*
32120 & X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3*
32121 & X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3
32122 & *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5)
32123 FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
32124 & 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
32125 & X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2*
32126 & X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4
32127 & *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5-
32128 & X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
32129 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9-
32130 & X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9
32131 & *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10*
32132 & X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3*
32133 & X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5)
32134 FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6
32135 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3*
32136 & X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5
32137 FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3-
32138 & X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3*
32139 & X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2
32140 & *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5
32141 & +X3*X8*X5+X3*X5**2)
32142 FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1*
32143 & X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1*
32144 & X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3
32145 & *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1
32146 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3
32147 & *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3*
32148 & X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7*
32149 & X5+X4*X6*X5)
32150 FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+
32151 & X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6
32152 & )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2*
32153 & X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2*
32154 & X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10)
32155 FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2*
32156 & PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4*
32157 & X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+
32158 & X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4*
32159 & X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+
32160 & X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3*
32161 & X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2
32162 & *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7
32163 & +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5)
32164 FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2*
32165 & PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+
32166 & 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7
32167 & +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9*
32168 & X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4
32169 & *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8)
32170 FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2*
32171 & X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2*
32172 & X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6
32173 FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4
32174 & *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+
32175 & X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+
32176 & X10)
32177 FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2*
32178 & X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10
32179 & +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
32180 & -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7
32181 & -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+
32182 & X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7)
32183 FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2
32184 & *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1*
32185 & X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3*
32186 & X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7*
32187 & X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2*
32188 & X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5)
32189 FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2
32190 & *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9
32191 & +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4
32192 & *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4*
32193 & X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2
32194 & *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3
32195 & *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2
32196 & *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9*
32197 & X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2)
32198 FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*(
32199 & X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6
32200 FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2
32201 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4*
32202 & X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+
32203 & X7)
32204 FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
32205 & 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
32206 & X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+
32207 & 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+
32208 & 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+
32209 & 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(-
32210 & X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3
32211 & *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10*
32212 & X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2*
32213 & X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4
32214 & *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5)
32215 FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
32216 & 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
32217 & X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+
32218 & 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2*
32219 & X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+
32220 & 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(
32221 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3*
32222 & X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9
32223 & *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10*
32224 & X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+
32225 & X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5)
32226 FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7
32227 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4*
32228 & X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5
32229 FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2
32230 & *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4
32231 & -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9
32232 & -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+
32233 & 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9
32234 & *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4
32235 & *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2
32236 & **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+
32237 & 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5)
32238 FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2
32239 & *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*
32240 & X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12*
32241 & X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9
32242 & *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2*
32243 & X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8)
32244 FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9*
32245 & X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7*
32246 & X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2
32247 & *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8
32248 & *X6)
32249 FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+
32250 & 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4*
32251 & X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9*
32252 & X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3*
32253 & X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2
32254 & +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+
32255 & 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5)
32256 FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2
32257 & *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4
32258 & *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2*
32259 & X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4*
32260 & X8)
32261 FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
32262 & X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6
32263 & )+2*X2*(-X10*X5+X9*X6+X8*X7)
32264 FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
32265 & X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2
32266 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3*
32267 & X9*X5)
32268 FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
32269 & X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2
32270 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4*
32271 & X8*X5)
32272 FM(9,10)=0.5D0*(FMXX+FM(9,10))
32273 FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
32274 & X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6
32275 & )+2*X5*(-X10*X2+X9*X3+X8*X4)
32276
32277C...Repackage matrix elements.
32278 DO 200 I=1,8
32279 DO 190 J=1,8
32280 RM(I,J)=FM(I,J)
32281 190 CONTINUE
32282 200 CONTINUE
32283 RM(7,7)=FM(7,7)-2D0*FM(9,9)
32284 RM(7,8)=FM(7,8)-2D0*FM(9,10)
32285 RM(8,8)=FM(8,8)-2D0*FM(10,10)
32286
32287C...Produce final result: matrix elements * colours * propagators.
32288 DO 220 I=1,8
32289 DO 210 J=I,8
32290 FAC=8D0
32291 IF(I.EQ.J)FAC=4D0
32292 WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J))
32293 210 CONTINUE
32294 220 CONTINUE
32295 WTQQBH=-WTQQBH/256D0
32296
32297 ELSE
32298C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
32299 A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3
32300 & *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9
32301 & *X6+X8*X7)
32302 A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8-
32303 & 2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7
32304 & +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8*
32305 & X5)
32306 A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3*
32307 & X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3
32308 & *X9+X4*X8)
32309
32310C...Produce final result: matrix elements * propagators.
32311 A11=A11/DX(7)**2
32312 A12=A12/(DX(7)*DX(8))
32313 A22=A22/DX(8)**2
32314 WTQQBH=-(A11+A22+2D0*A12)*8D0/9D0
32315 ENDIF
32316
32317 RETURN
32318 END
32319
32320C*********************************************************************
32321
32322C...PYMSIN
32323C...Initializes supersymmetry: finds sparticle masses and
32324C...branching ratios and stores this information.
32325C...AUTHOR: STEPHEN MRENNA
32326C...Baryon- and lepton-number violating parameters by P. Z. Skands.
32327
32328 SUBROUTINE PYMSIN
32329
32330C...Double precision and integer declarations.
32331 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32332 IMPLICIT INTEGER(I-N)
32333 INTEGER PYK,PYCHGE,PYCOMP
32334C...Parameter statement to help give large particle numbers.
32335 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
32336 &KEXCIT=4000000,KDIMEN=5000000)
32337C...Commonblocks.
32338 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32339 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32340 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
32341 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
32342 COMMON/PYINT4/MWID(500),WIDS(500,5)
32343 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
32344 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
32345 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
32346 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
32347 COMMON/PYHTRI/HHH(7)
32348 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT4/,/PYMSSM/,
32349 &/PYMSRV/,/PYSSMT/
32350
32351C...Local variables.
32352 DOUBLE PRECISION ALFA,BETA
32353 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
32354 INTEGER I,J,J1,I1,K1
32355 INTEGER KC,LKNT,IDLAM(400,3)
32356 DOUBLE PRECISION XLAM(0:400)
32357 DOUBLE PRECISION WDTP(0:400),WDTE(0:400,0:5)
32358 DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
32359 DOUBLE PRECISION DELM,XMDIF
32360 DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
32361 DOUBLE PRECISION ARG,SGNMU,R
32362 INTEGER IMSSM
32363 INTEGER IRPRTY
32364 INTEGER KFSUSY(36),MWIDSU(36),MDCYSU(36)
32365 SAVE MWIDSU,MDCYSU
32366 DATA KFSUSY/
32367 &1000001,2000001,1000002,2000002,1000003,2000003,
32368 &1000004,2000004,1000005,2000005,1000006,2000006,
32369 &1000011,2000011,1000012,2000012,1000013,2000013,
32370 &1000014,2000014,1000015,2000015,1000016,2000016,
32371 &1000021,1000022,1000023,1000025,1000035,1000024,
32372 &1000037,1000039, 25, 35, 36, 37/
32373 DATA INIT/0/
32374
32375C...Do nothing if SUSY not requested.
32376 IMSSM=IMSS(1)
32377 IF(IMSSM.EQ.0) RETURN
32378
32379C...Save copy of MWID(KC) and MDCY(KC,1) values before
32380C...they are set to zero for the LSP.
32381 IF(INIT.EQ.0) THEN
32382 INIT=1
32383 DO 100 I=1,36
32384 KF=KFSUSY(I)
32385 KC=PYCOMP(KF)
32386 MWIDSU(I)=MWID(KC)
32387 MDCYSU(I)=MDCY(KC,1)
32388 100 CONTINUE
32389 ENDIF
32390
32391C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP.
32392 DO 110 I=1,36
32393 KF=KFSUSY(I)
32394 KC=PYCOMP(KF)
32395 IF(MDCY(KC,1).EQ.0.AND.MDCYSU(I).NE.0) THEN
32396 MWID(KC)=MWIDSU(I)
32397 MDCY(KC,1)=MDCYSU(I)
32398 ENDIF
32399 110 CONTINUE
32400
32401C...First part of routine: set masses and couplings.
32402
32403C...Reset mixing values in sfermion sector to pure left/right.
32404 DO 120 I=1,16
32405 SFMIX(I,1)=1D0
32406 SFMIX(I,4)=1D0
32407 SFMIX(I,2)=0D0
32408 SFMIX(I,3)=0D0
32409 120 CONTINUE
32410
32411C...Common couplings.
32412 TANB=RMSS(5)
32413 BETA=ATAN(TANB)
32414 COSB=COS(BETA)
32415 SINB=TANB*COSB
32416 COS2B=COS(2D0*BETA)
32417 ALFA=RMSS(18)
32418 XMW2=PMAS(24,1)**2
32419 XMZ2=PMAS(23,1)**2
32420 XW=PARU(102)
32421
32422C...Define sparticle masses for a general MSSM simulation.
32423 IF(IMSSM.EQ.1) THEN
32424 IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9)
32425 DO 130 I=1,5,2
32426 KC=PYCOMP(KSUSY1+I)
32427 PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0)
32428 KC=PYCOMP(KSUSY2+I)
32429 PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0)
32430 KC=PYCOMP(KSUSY1+I+1)
32431 PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0)
32432 KC=PYCOMP(KSUSY2+I+1)
32433 PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0)
32434 130 CONTINUE
32435 XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA))
32436 IF(XARG.LT.0D0) THEN
32437 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
32438 & ' FROM THE SUM RULE. '
32439 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
32440 RETURN
32441 ELSE
32442 XARG=SQRT(XARG)
32443 ENDIF
32444 DO 140 I=11,15,2
32445 PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6)
32446 PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7)
32447 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
32448 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
32449 140 CONTINUE
32450 IF(IMSS(8).EQ.1) THEN
32451 RMSS(13)=RMSS(6)
32452 RMSS(14)=RMSS(7)
32453 ENDIF
32454
32455C...Alternatively derive masses from SUGRA relations.
32456 ELSEIF(IMSSM.EQ.2) THEN
32457 CALL PYAPPS
32458C...Or use ISASUSY
32459 ELSEIF(IMSSM.EQ.12) THEN
32460 CALL PYSUGI
32461 ALFA=RMSS(18)
32462 GOTO 170
32463 ENDIF
32464
32465C...Add in extra D-term contributions.
32466 IF(IMSS(7).EQ.1) THEN
32467 R=0.43D0
32468 DX=RMSS(23)
32469 DY=RMSS(24)
32470 DS=RMSS(25)
32471 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
32472 WRITE(MSTU(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
32473 WRITE(MSTU(11),*) 'C IN A U(B-L) THEORY '
32474 WRITE(MSTU(11),*) 'C DX = ',DX
32475 WRITE(MSTU(11),*) 'C DY = ',DY
32476 WRITE(MSTU(11),*) 'C DS = ',DS
32477 WRITE(MSTU(11),*) 'C '
32478 DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS
32479 WRITE(MSTU(11),*) 'C DY AT THE WEAK SCALE = ',DY
32480 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
32481 DQ2=DY/6D0-DX/3D0-DS/3D0
32482 DU2=-2D0*DY/3D0-DX/3D0-DS/3D0
32483 DD2=DY/3D0+DX-2D0*DS/3D0
32484 DL2=-DY/2D0+DX-2D0*DS/3D0
32485 DE2=DY-DX/3D0-DS/3D0
32486 DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0
32487 DHD2=-DY/2D0-2D0*DX/3D0+DS
32488 DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS)
32489 & /ABS(COS2B)
32490 DMA2 = 2D0*DMU2+DHU2+DHD2
32491 DO 150 I=1,5,2
32492 KC=PYCOMP(KSUSY1+I)
32493 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
32494 KC=PYCOMP(KSUSY2+I)
32495 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2)
32496 KC=PYCOMP(KSUSY1+I+1)
32497 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
32498 KC=PYCOMP(KSUSY2+I+1)
32499 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2)
32500 150 CONTINUE
32501 DO 160 I=11,15,2
32502 KC=PYCOMP(KSUSY1+I)
32503 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
32504 KC=PYCOMP(KSUSY2+I)
32505 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2)
32506 KC=PYCOMP(KSUSY1+I+1)
32507 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
32508 160 CONTINUE
32509 IF(RMSS(4)**2+DMU2.LT.0D0) THEN
32510 WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE '
32511 STOP
32512 ENDIF
32513 SGNMU=SIGN(1D0,RMSS(4))
32514 RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2)
32515 ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2
32516 RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
32517 ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2
32518 RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
32519 ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2
32520 RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
32521 ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2
32522 RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
32523 ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2
32524 RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG)
32525 IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN
32526 WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW '
32527 STOP
32528 ENDIF
32529 RMSS(19)=SQRT(RMSS(19)**2+DMA2)
32530 RMSS(6)=SQRT(RMSS(6)**2+DL2)
32531 RMSS(7)=SQRT(RMSS(7)**2+DE2)
32532 WRITE(MSTU(11),*) ' MTL = ',RMSS(10)
32533 WRITE(MSTU(11),*) ' MBR = ',RMSS(11)
32534 WRITE(MSTU(11),*) ' MTR = ',RMSS(12)
32535 WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13)
32536 WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14)
32537 ENDIF
32538
32539C...Fix the third generation sfermions.
32540 CALL PYTHRG
32541
32542C...Fix the neutralino--chargino--gluino sector.
32543 CALL PYINOM
32544
32545C...Fix the Higgs sector.
32546 CALL PYHGGM(ALFA)
32547
32548C...Choose the Gunion-Haber convention.
32549 ALFA=-ALFA
32550 RMSS(18)=ALFA
32551
32552C...Print information on mass parameters.
32553 IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN
32554 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
32555 WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
32556 WRITE(MSTU(11),*) ' M0 = ',RMSS(8)
32557 WRITE(MSTU(11),*) ' M1/2=',RMSS(1)
32558 WRITE(MSTU(11),*) ' TANB=',RMSS(5)
32559 WRITE(MSTU(11),*) ' MU = ',RMSS(4)
32560 WRITE(MSTU(11),*) ' AT = ',RMSS(16)
32561 WRITE(MSTU(11),*) ' MA = ',RMSS(19)
32562 WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1)
32563 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
32564 ENDIF
32565 IF(IMSS(20).EQ.1) THEN
32566 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
32567 WRITE(MSTU(11),*) ' DEBUG MODE '
32568 WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2),
32569 & UMIX(2,1),UMIX(2,2)
32570 WRITE(MSTU(11),*) ' UMIXI = ',UMIXI(1,1),UMIXI(1,2),
32571 & UMIXI(2,1),UMIXI(2,2)
32572 WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2),
32573 & VMIX(2,1),VMIX(2,2)
32574 WRITE(MSTU(11),*) ' VMIXI = ',VMIXI(1,1),VMIXI(1,2),
32575 & VMIXI(2,1),VMIXI(2,2)
32576 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(1,I),I=1,4)
32577 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(1,I),I=1,4)
32578 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(2,I),I=1,4)
32579 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(2,I),I=1,4)
32580 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(3,I),I=1,4)
32581 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(3,I),I=1,4)
32582 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(4,I),I=1,4)
32583 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(4,I),I=1,4)
32584 WRITE(MSTU(11),*) ' ALFA = ',ALFA
32585 WRITE(MSTU(11),*) ' BETA = ',BETA
32586 WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4)
32587 WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4)
32588 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
32589 ENDIF
32590
32591C...Set up the Higgs couplings - needed here since initialization
32592C...in PYINRE did not yet occur when PYWIDT is called below.
32593 170 AL=ALFA
32594 BE=BETA
32595 SINA=SIN(AL)
32596 COSA=COS(AL)
32597 COSB=COS(BE)
32598 SINB=TANB*COSB
32599 SBMA=SIN(BE-AL)
32600 SAPB=SIN(AL+BE)
32601 CAPB=COS(AL+BE)
32602 CBMA=COS(BE-AL)
32603 C2A=COS(2D0*AL)
32604 C2B=COSB**2-SINB**2
32605C...tanb (used for H+)
32606 PARU(141)=TANB
32607
32608C...Firstly: h
32609C...Coupling to d-type quarks
32610 PARU(161)=SINA/COSB
32611C...Coupling to u-type quarks
32612 PARU(162)=-COSA/SINB
32613C...Coupling to leptons
32614 PARU(163)=PARU(161)
32615C...Coupling to Z
32616 PARU(164)=SBMA
32617C...Coupling to W
32618 PARU(165)=PARU(164)
32619
32620C...Secondly: H
32621C...Coupling to d-type quarks
32622 PARU(171)=-COSA/COSB
32623C...Coupling to u-type quarks
32624 PARU(172)=-SINA/SINB
32625C...Coupling to leptons
32626 PARU(173)=PARU(171)
32627C...Coupling to Z
32628 PARU(174)=CBMA
32629C...Coupling to W
32630 PARU(175)=PARU(174)
32631C...Coupling to h
32632 IF(IMSS(4).EQ.2) THEN
32633 PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
32634 ELSE
32635 HHH(3)=HHH(3)+HHH(4)+HHH(5)
32636 PARU(176)=-3D0/HHH(1)*(HHH(1)*SINA**2*COSB*COSA+
32637 1 HHH(2)*COSA**2*SINB*SINA+HHH(3)*(SINA**3*SINB+COSA**3*COSB-
32638 2 2D0/3D0*CBMA)-HHH(6)*SINA*(COSB*C2A+COSA*CAPB)+
32639 3 HHH(7)*COSA*(SINB*C2A+SINA*CAPB))
32640 ENDIF
32641C...Coupling to H+
32642C...Define later
32643 IF(IMSS(4).EQ.2) THEN
32644 PARU(168)=-SBMA-COS(2D0*BE)*SAPB/2D0/(1D0-XW)
32645 ELSE
32646 PARU(168)=1D0/HHH(1)*(HHH(1)*SINB**2*COSB*SINA-
32647 1 HHH(2)*COSB**2*SINB*COSA-HHH(3)*(SINB**3*COSA-COSB**3*SINA)+
32648 2 2D0*HHH(5)*SBMA-HHH(6)*SINB*(COSB*SAPB+SINA*C2B)-
32649 3 HHH(7)*COSB*(COSA*C2B-SINB*SAPB)-(HHH(5)-HHH(4))*SBMA)
32650 ENDIF
32651C...Coupling to A
32652 IF(IMSS(4).EQ.2) THEN
32653 PARU(177)=COS(2D0*BE)*COS(BE+AL)
32654 ELSE
32655 PARU(177)=-1D0/HHH(1)*(HHH(1)*SINB**2*COSB*COSA+
32656 1 HHH(2)*COSB**2*SINB*SINA+HHH(3)*(SINB**3*SINA+COSB**3*COSA)-
32657 2 2D0*HHH(5)*CBMA-HHH(6)*SINB*(COSB*CAPB+COSA*C2B)+
32658 3 HHH(7)*COSB*(SINB*CAPB+SINA*C2B))
32659 ENDIF
32660C...Coupling to H+
32661 IF(IMSS(4).EQ.2) THEN
32662 PARU(178)=PARU(177)
32663 ELSE
32664 PARU(178)=PARU(177)-(HHH(5)-HHH(4))/HHH(1)*CBMA
32665 ENDIF
32666C...Thirdly, A
32667C...Coupling to d-type quarks
32668 PARU(181)=TANB
32669C...Coupling to u-type quarks
32670 PARU(182)=1D0/PARU(181)
32671C...Coupling to leptons
32672 PARU(183)=PARU(181)
32673 PARU(184)=0D0
32674 PARU(185)=0D0
32675C...Coupling to Z h
32676 PARU(186)=COS(BE-AL)
32677C...Coupling to Z H
32678 PARU(187)=SIN(BE-AL)
32679 PARU(188)=0D0
32680 PARU(189)=0D0
32681 PARU(190)=0D0
32682
32683C...Finally: H+
32684C...Coupling to W h
32685 PARU(195)=COS(BE-AL)
32686
32687C...Tell that all Higgs couplings have been set.
32688 MSTP(4)=1
32689
32690C...Set R-Violating couplings.
32691C...Set lambda couplings to common value or "natural values".
32692 IF ((IMSS(51).NE.3).AND.(IMSS(51).NE.0)) THEN
32693 VIR3=1D0/(126D0)**3
32694 DO 200 IRK=1,3
32695 DO 190 IRI=1,3
32696 DO 180 IRJ=1,3
32697 IF (IRI.NE.IRJ) THEN
32698 IF (IRI.LT.IRJ) THEN
32699 RVLAM(IRI,IRJ,IRK)=RMSS(51)
32700 IF (IMSS(51).EQ.2) RVLAM(IRI,IRJ,IRK)=RMSS(51)*
32701 & SQRT(PMAS(9+2*IRI,1)*PMAS(9+2*IRJ,1)*
32702 & PMAS(9+2*IRK,1)*VIR3)
32703 ELSE
32704 RVLAM(IRI,IRJ,IRK)=-RVLAM(IRJ,IRI,IRK)
32705 ENDIF
32706 ELSE
32707 RVLAM(IRI,IRJ,IRK)=0D0
32708 ENDIF
32709 180 CONTINUE
32710 190 CONTINUE
32711 200 CONTINUE
32712 ENDIF
32713C...Set lambda' couplings to common value or "natural values".
32714 IF ((IMSS(52).NE.3).AND.(IMSS(52).NE.0)) THEN
32715 VIR3=1D0/(126D0)**3
32716 DO 230 IRI=1,3
32717 DO 220 IRJ=1,3
32718 DO 210 IRK=1,3
32719 RVLAMP(IRI,IRJ,IRK)=RMSS(52)
32720 IF (IMSS(52).EQ.2) RVLAMP(IRI,IRJ,IRK)=RMSS(52)*
32721 & SQRT(PMAS(9+2*IRI,1)*0.5D0*(PMAS(2*IRJ,1)+
32722 & PMAS(2*IRJ-1,1))*PMAS(2*IRK-1,1)*VIR3)
32723 210 CONTINUE
32724 220 CONTINUE
32725 230 CONTINUE
32726 ENDIF
32727C...Set lambda'' couplings to common value or "natural values".
32728 IF ((IMSS(53).NE.3).AND.(IMSS(53).NE.0)) THEN
32729 VIR3=1D0/(126D0)**3
32730 DO 260 IRI=1,3
32731 DO 250 IRJ=1,3
32732 DO 240 IRK=1,3
32733 IF (IRJ.NE.IRK) THEN
32734 IF (IRJ.LT.IRK) THEN
32735 RVLAMB(IRI,IRJ,IRK)=RMSS(53)
32736 IF (IMSS(53).EQ.2) RVLAMB(IRI,IRJ,IRK)=
32737 & RMSS(53)*SQRT(PMAS(2*IRI,1)*PMAS(2*IRJ-1,1)*
32738 & PMAS(2*IRK-1,1)*VIR3)
32739 ELSE
32740 RVLAMB(IRI,IRJ,IRK)=-RVLAMB(IRI,IRK,IRJ)
32741 ENDIF
32742 ELSE
32743 RVLAMB(IRI,IRJ,IRK) = 0D0
32744 ENDIF
32745 240 CONTINUE
32746 250 CONTINUE
32747 260 CONTINUE
32748 ENDIF
32749
32750C...Antisymmetrize couplings set by user
32751 IF (IMSS(51).EQ.3.OR.IMSS(53).EQ.3) THEN
32752 DO 290 IRI=1,3
32753 DO 280 IRJ=1,3
32754 DO 270 IRK=1,3
32755 IF (RVLAM(IRI,IRJ,IRK).NE.-RVLAM(IRJ,IRI,IRK)) THEN
32756 RVLAM(IRJ,IRI,IRK)=-RVLAM(IRI,IRJ,IRK)
32757 IF (IRI.EQ.IRJ) RVLAM(IRI,IRJ,IRK)=0D0
32758 ENDIF
32759 IF (RVLAMB(IRI,IRJ,IRK).NE.-RVLAMB(IRI,IRK,IRJ)) THEN
32760 RVLAMB(IRI,IRK,IRJ)=-RVLAMB(IRI,IRJ,IRK)
32761 IF (IRJ.EQ.IRK) RVLAMB(IRI,IRJ,IRK)=0D0
32762 ENDIF
32763 270 CONTINUE
32764 280 CONTINUE
32765 290 CONTINUE
32766 ENDIF
32767
32768C...Second part of routine: set decay modes and branching ratios.
32769
32770C...Allow chi10 -> gravitino + gamma or not.
32771 KC=PYCOMP(KSUSY1+39)
32772 IF( IMSS(11) .NE. 0 ) THEN
32773 PMAS(KC,1)=RMSS(21)/1000000000D0
32774 PMAS(KC,2)=0.0001D0
32775 IRPRTY=0
32776 WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
32777 ELSE IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
32778 IRPRTY=0
32779 IF (IMSS(51).GE.1) WRITE(MSTU(11),*)
32780 & ' ALLOWING SUSY LLE DECAYS'
32781 IF (IMSS(52).GE.1) WRITE(MSTU(11),*)
32782 & ' ALLOWING SUSY LQD DECAYS'
32783 IF (IMSS(53).GE.1) WRITE(MSTU(11),*)
32784 & ' ALLOWING SUSY UDD DECAYS'
32785 IF (IMSS(53).GE.1.AND.IMSS(52).GE.1) WRITE(MSTU(11),*)
32786 & ' --- Warning: R-Violating couplings possibly',
32787 & ' incompatible with proton decay'
32788 ELSE
32789 PMAS(KC,1)=9999D0
32790 IRPRTY=1
32791 ENDIF
32792
32793C...Loop over sparticle and Higgs species.
32794 PMCHI1=PMAS(PYCOMP(KSUSY1+22),1)
32795C...Find the LSP or NLSP for a gravitino LSP
32796 ILSP=0
32797 PMLSP=1D20
32798 DO 300 I=1,36
32799 KF=KFSUSY(I)
32800 IF(KF.EQ.1000039) GOTO 300
32801 KC=PYCOMP(KF)
32802 IF(PMAS(KC,1).LT.PMLSP) THEN
32803 ILSP=I
32804 PMLSP=PMAS(KC,1)
32805 ENDIF
32806 300 CONTINUE
32807 DO 370 I=1,36
32808 KF=KFSUSY(I)
32809 KC=PYCOMP(KF)
32810 LKNT=0
32811
32812C...Sfermion decays.
32813 IF(I.LE.24) THEN
32814C...First check to see if sneutrino is lighter than chi10.
32815 IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND.
32816 & PMAS(KC,1).LT.PMCHI1) THEN
32817 ELSE
32818 CALL PYSFDC(KF,XLAM,IDLAM,LKNT)
32819 ENDIF
32820
32821C...Gluino decays.
32822 ELSEIF(I.EQ.25) THEN
32823 CALL PYGLUI(KF,XLAM,IDLAM,LKNT)
32824 IF(I.EQ.ILSP.AND.IRPRTY.EQ.1) LKNT=0
32825
32826C...Neutralino decays.
32827 ELSEIF(I.GE.26.AND.I.LE.29) THEN
32828 CALL PYNJDC(KF,XLAM,IDLAM,LKNT)
32829C...chi10 stable or chi10 -> gravitino + gamma.
32830 IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN
32831 PMAS(KC,2)=1D-6
32832 MDCY(KC,1)=0
32833 MWID(KC)=0
32834 ENDIF
32835
32836C...Chargino decays.
32837 ELSEIF(I.GE.30.AND.I.LE.31) THEN
32838 CALL PYCJDC(KF,XLAM,IDLAM,LKNT)
32839
32840C...Gravitino is stable.
32841 ELSEIF(I.EQ.32) THEN
32842 MDCY(KC,1)=0
32843 MWID(KC)=0
32844
32845C...Higgs decays.
32846 ELSEIF(I.GE.33.AND.I.LE.36) THEN
32847C...Calculate decays to non-SUSY particles.
32848 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
32849 LKNT=0
32850 DO 310 I1=0,100
32851 XLAM(I1)=0D0
32852 310 CONTINUE
32853 DO 330 I1=1,MDCY(KC,3)
32854 K1=MDCY(KC,2)+I1-1
32855 IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR.
32856 & IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 330
32857 XLAM(I1)=WDTP(I1)
32858 XLAM(0)=XLAM(0)+XLAM(I1)
32859 DO 320 J1=1,3
32860 IDLAM(I1,J1)=KFDP(K1,J1)
32861 320 CONTINUE
32862 LKNT=LKNT+1
32863 330 CONTINUE
32864C...Add the decays to SUSY particles.
32865 CALL PYHEXT(KF,XLAM,IDLAM,LKNT)
32866 ENDIF
32867C...Zero the branching ratios for use in loop mode
32868C...thanks to K. Matchev (FNAL)
32869 DO 340 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
32870 BRAT(IDC)=0D0
32871 340 CONTINUE
32872
32873C...Set stable particles.
32874 IF(LKNT.EQ.0) THEN
32875 MDCY(KC,1)=0
32876 MWID(KC)=0
32877 PMAS(KC,2)=1D-6
32878 PMAS(KC,3)=1D-5
32879 PMAS(KC,4)=0D0
32880
32881C...Store branching ratios in the standard tables.
32882 ELSE
32883 IDC=MDCY(KC,2)+MDCY(KC,3)-1
32884 DELM=1D6
32885 DO 360 IL=1,LKNT
32886 IDCSV=IDC
32887 350 IDC=IDC+1
32888 BRAT(IDC)=0D0
32889 IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2)
32890 IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ.
32891 & KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN
32892 BRAT(IDC)=XLAM(IL)/XLAM(0)
32893 XMDIF=PMAS(KC,1)
32894 IF(MDME(IDC,1).GE.1) THEN
32895 XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)-
32896 & PMAS(PYCOMP(KFDP(IDC,2)),1)
32897 IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF-
32898 & PMAS(PYCOMP(KFDP(IDC,3)),1)
32899 ENDIF
32900 IF(I.LE.32) THEN
32901 IF(XMDIF.GE.0D0) THEN
32902 DELM=MIN(DELM,XMDIF)
32903 ELSE
32904 WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF
32905 WRITE(MSTU(11),*) ' KF = ',KF
32906 WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3)
32907 ENDIF
32908 ENDIF
32909 GOTO 360
32910 ELSEIF(IDC.EQ.IDCSV) THEN
32911 WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ',
32912 & 'channel not recognized:'
32913 WRITE(MSTU(11),*) KF,' -> ',(IDLAM(I,J),J=1,3)
32914 GOTO 360
32915 ELSE
32916 GOTO 350
32917 ENDIF
32918 360 CONTINUE
32919
32920C...Store width, cutoff and lifetime.
32921 PMAS(KC,2)=XLAM(0)
32922 IF(PMAS(KC,2).LT.0.1D0*DELM) THEN
32923 PMAS(KC,3)=PMAS(KC,2)*10D0
32924 ELSE
32925 PMAS(KC,3)=0.95D0*DELM
32926 ENDIF
32927 IF(PMAS(KC,2).NE.0D0) THEN
32928 PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12
32929 ENDIF
32930 ENDIF
32931 370 CONTINUE
32932
32933 RETURN
32934 END
32935
32936C*********************************************************************
32937
32938C...PYAPPS
32939C...Uses approximate analytical formulae to determine the full set of
32940C...MSSM parameters from SUGRA input.
32941C...See M. Drees and S.P. Martin, hep-ph/9504124
32942
32943 SUBROUTINE PYAPPS
32944
32945C...Double precision and integer declarations.
32946 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32947 IMPLICIT INTEGER(I-N)
32948 INTEGER PYK,PYCHGE,PYCOMP
32949C...Parameter statement to help give large particle numbers.
32950 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
32951 &KEXCIT=4000000,KDIMEN=5000000)
32952C...Commonblocks.
32953 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32954 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32955 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
32956 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/
32957
32958 IMSS(5)=0
32959 IMSS(8)=0
32960 XMT=PMAS(6,1)
32961 XMZ2=PMAS(23,1)**2
32962 XMW2=PMAS(24,1)**2
32963 TANB=RMSS(5)
32964 BETA=ATAN(TANB)
32965 XW=PARU(102)
32966 XMG=RMSS(1)
32967 XMG2=XMG*XMG
32968 XM0=RMSS(8)
32969 XM02=XM0*XM0
32970 AT=-RMSS(16)
32971 RMSS(15)=AT
32972 RMSS(17)=AT
32973 SINB=TANB/SQRT(TANB**2+1D0)
32974 COSB=SINB/TANB
32975
32976 DTERM=XMZ2*COS(2D0*BETA)
32977 XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM)
32978 XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM)
32979 RMSS(6)=XMEL
32980 RMSS(7)=XMER
32981 XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM))
32982 XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM))
32983 XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM))
32984 XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM))
32985 DO 100 I=1,5,2
32986 PMAS(PYCOMP(KSUSY1+I),1)=XMDL
32987 PMAS(PYCOMP(KSUSY2+I),1)=XMDR
32988 PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL
32989 PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR
32990 100 CONTINUE
32991 XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA))
32992 IF(XARG.LT.0D0) THEN
32993 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
32994 & ' FROM THE SUM RULE. '
32995 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
32996 RETURN
32997 ELSE
32998 XARG=SQRT(XARG)
32999 ENDIF
33000 DO 110 I=11,15,2
33001 PMAS(PYCOMP(KSUSY1+I),1)=XMEL
33002 PMAS(PYCOMP(KSUSY2+I),1)=XMER
33003 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
33004 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
33005 110 CONTINUE
33006 RMT=PYMRUN(6,PMAS(6,1)**2)
33007 XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+
33008 &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG))
33009 RMB=PYMRUN(5,PMAS(6,1)**2)
33010 XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+
33011 &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG))
33012 XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0)
33013 ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/
33014 &SINB)**2)
33015 RMSS(16)=-ATP
33016 XMU2=-.5D0*XMZ2+(SINB**2*(XM02+.52D0*XMG2-XTOP)-
33017 &COSB**2*(XM02+.52D0*XMG2-XBOT-XTAU/3D0))/(COSB**2-SINB**2)
33018 XMA2=2D0*(XM02+.52D0*XMG2+XMU2)-XTOP-XBOT-XTAU/3D0
33019 XMU=SIGN(SQRT(XMU2),RMSS(4))
33020 RMSS(4)=XMU
33021 IF(XMA2.GT.0D0) THEN
33022 RMSS(19)=SQRT(XMA2)
33023 ELSE
33024 WRITE(MSTU(11),*) ' PYAPPS:: PSEUDOSCALAR MASS**2 < 0 '
33025 STOP
33026 ENDIF
33027 ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM
33028 IF(ARG.GT.0D0) THEN
33029 RMSS(14)=SQRT(ARG)
33030 ELSE
33031 WRITE(MSTU(11),*) ' PYAPPS:: RIGHT STAU MASS**2 < 0 '
33032 STOP
33033 ENDIF
33034 ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM
33035 IF(ARG.GT.0D0) THEN
33036 RMSS(13)=SQRT(ARG)
33037 ELSE
33038 WRITE(MSTU(11),*) ' PYAPPS:: LEFT STAU MASS**2 < 0 '
33039 STOP
33040 ENDIF
33041 ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0)
33042 IF(ARG.GT.0D0) THEN
33043 RMSS(10)=SQRT(ARG)
33044 ELSE
33045 RMSS(10)=-SQRT(-ARG)
33046 ENDIF
33047 ARG=PYRNMQ(2,-2D0*XTOP/3D0)
33048 IF(ARG.GT.0D0) THEN
33049 RMSS(12)=SQRT(ARG)
33050 ELSE
33051 RMSS(12)=-SQRT(-ARG)
33052 ENDIF
33053 ARG=PYRNMQ(3,-2D0*XBOT/3D0)
33054 IF(ARG.GT.0D0) THEN
33055 RMSS(11)=SQRT(ARG)
33056 ELSE
33057 RMSS(11)=-SQRT(-ARG)
33058 ENDIF
33059
33060 RETURN
33061 END
33062
33063C*********************************************************************
33064
33065C...PYSUGI
33066C...Interface to ISASUSY version 7.61.
33067C...Warning: if you use earlier versions, change dimension to
33068C...SUPER(66) in /SSPAR/ and remove MHPNEG and ASM3 from /SUGPAS/.
33069C...Calls SUGRA (in ISAJET) to perform RGE evolution.
33070C...Then converts to Gunion-Haber conventions.
33071
33072 SUBROUTINE PYSUGI
33073 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33074
33075 INTEGER PYK,PYCHGE,PYCOMP
33076 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
33077 &KEXCIT=4000000,KDIMEN=5000000)
33078
33079C...Date of Change
33080 CHARACTER DOC*11
33081 PARAMETER (DOC='22 Nov 2002')
33082
33083C...ISASUGRA Input:
33084 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
33085C...ISASUGRA Output
33086 CHARACTER*40 ISAVER,VISAJE
33087 REAL SUPER
33088 COMMON /SSPAR/ SUPER(69)
33089 COMMON /SUGMG/ MSS(32),GSS(29),MGUTSS,GGUTSS,AGUTSS,FTGUT,
33090 $FBGUT,FTAGUT,FNGUT
33091 REAL MSS,GSS,MGUTSS,GGUTSS,AGUTSS,FTGUT,FBGUT,FTAGUT,FNGUT
33092 COMMON /SUGPAS/ XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
33093 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
33094 $FNMZ,AMNRMJ,NOGOOD,IAL3UN,ITACHY,MHPNEG,ASM3
33095 REAL XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
33096 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
33097 $FNMZ,AMNRMJ,ASM3
33098 INTEGER NOGOOD,IAL3UN,ITACHY,MHPNEG
33099C SUPER: Filled by ISASUGRA.
33100C SUPER(1) = mass of ~g
33101C SUPER(2:17) = mass of ~u_L,~u_R,~d_L,~d_R,~s_L,~s_R,~c_L,~c_R,~b_L
33102C ,~b_R,~b_1,~b_2,~t_L,~t_R,~t_1,~t_2
33103C SUPER(18:25) = mass of ~e_L,~e_R,~mu_L,~mu_R,~tau_L,~tau_R,~tau_1
33104C ,~tau_2
33105C SUPER(26:28) = mass of ~nu_e,~nu_mu,~nu_tau
33106C SUPER(29) = Higgsino mass = - mu
33107C SUPER(30) = ratio v2/v1 of vev's
33108C SUPER(31:34) = Signed neutralino masses
33109C SUPER(35:50) = Neutralino mixing matrix
33110C SUPER(51:52) = Signed chargino masses
33111C SUPER(53:54) = Chargino left, right mixing angles
33112C SUPER(55:58) = mass of h0, H0, A0, H+
33113C SUPER(59) = Higgs mixing angle alpha
33114C SUPER(60:65) = A_t, theta_t, A_b, theta_b, A_tau, theta_tau
33115C SUPER(66) = Gravitino mass
33116C GSS: Filled by ISASUGRA
33117C GSS( 1) = g_1 GSS( 2) = g_2 GSS( 3) = g_3
33118C GSS( 4) = y_tau GSS( 5) = y_b GSS( 6) = y_t
33119C GSS( 7) = M_1 GSS( 8) = M_2 GSS( 9) = M_3
33120C GSS(10) = A_tau GSS(11) = A_b GSS(12) = A_t
33121C GSS(13) = M_h1^2 GSS(14) = M_h2^2 GSS(15) = M_er^2
33122C GSS(16) = M_el^2 GSS(17) = M_dnr^2 GSS(18) = M_upr^2
33123C GSS(19) = M_upl^2 GSS(20) = M_taur^2 GSS(21) = M_taul^2
33124C GSS(22) = M_btr^2 GSS(23) = M_tpr^2 GSS(24) = M_tpl^2
33125C GSS(25) = mu GSS(26) = B GSS(27) = Y_N
33126C GSS(28) = M_nr GSS(29) = A_n
33127C MSS: Filled by ISASUGRA
33128C MSS( 1) = glss MSS( 2) = upl MSS( 3) = upr
33129C MSS( 4) = dnl MSS( 5) = dnr MSS( 6) = stl
33130C MSS( 7) = str MSS( 8) = chl MSS( 9) = chr
33131C MSS(10) = b1 MSS(11) = b2 MSS(12) = t1
33132C MSS(13) = t2 MSS(14) = nuel MSS(15) = numl
33133C MSS(16) = nutl MSS(17) = el- MSS(18) = er-
33134C MSS(19) = mul- MSS(20) = mur- MSS(21) = tau1
33135C MSS(22) = tau2 MSS(23) = z1ss MSS(24) = z2ss
33136C MSS(25) = z3ss MSS(26) = z4ss MSS(27) = w1ss
33137C MSS(28) = w2ss MSS(29) = hl0 MSS(30) = hh0
33138C MSS(31) = ha0 MSS(32) = h+
33139C Unification, filled by ISASUGRA if applicable.
33140C MGUTSS = M_GUT GGUTSS = g_GUT AGUTSS = alpha_GUTC
33141C...SPYTHIA Input/Output:
33142 INTEGER IMSS
33143 DOUBLE PRECISION RMSS
33144 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
33145 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
33146 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
33147 SAVE /SUGMG/,/SSPAR/
33148C
33149C...PYTHIA common blocks
33150C...Parameters.
33151 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33152 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
33153C...Particle properties + some flavour parameters.
33154 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33155 SAVE /PYDAT2/,/PYSSMT/
33156
33157C...Start by checking for incompatibilities/inconsistencies:
33158 DO 100 ICHK=2,9
33159 IF (ICHK.NE.8.AND.ICHK.NE.4.AND.IMSS(ICHK).NE.0) THEN
33160 WRITE (MSTU(11),*) '(PYSUGI:) IMSS(',ICHK,')=',IMSS(ICHK)
33161 & ,' option not used by PYSUGI'
33162 ENDIF
33163 100 CONTINUE
33164C...ISAJET works with REAL numbers.
33165 MZERO=REAL(RMSS(8))
33166 MHLF=REAL(RMSS(1))
33167 AZERO=REAL(RMSS(16))
33168 TANB=REAL(RMSS(5))
33169 SGNMU=REAL(RMSS(4))
33170 MTOP=REAL(PMAS(6,1))
33171C...Initialize MSSM parameter array
33172 DO 110 IPAR=1,66
33173 SUPER(IPAR)=0.0
33174 110 CONTINUE
33175C...Call ISASUGRA
33176 CALL SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,1)
33177C...Check whether ISASUSY thought the model was OK.
33178 IF (NOGOOD.NE.0) THEN
33179 IF (NOGOOD.EQ.1) CALL PYERRM(26
33180 & ,'(PYSUGI:) SUSY parameters give tachyonic particles.')
33181 IF (NOGOOD.EQ.2) CALL PYERRM(26
33182 & ,'(PYSUGI:) SUSY parameters give no EWSB.')
33183 IF (NOGOOD.EQ.3) CALL PYERRM(26
33184 & ,'(PYSUGI:) SUSY parameters give m(A0) < 0.')
33185 IF (NOGOOD.EQ.4) CALL PYERRM(26
33186 & ,'(PYSUGI:) SUSY parameters give Yukawa > 100.')
33187 IF (NOGOOD.EQ.7) CALL PYERRM(26
33188 & ,'(PYSUGI:) SUSY parameters give x_T EWSB bad.')
33189 IF (NOGOOD.EQ.8) CALL PYERRM(26
33190 & ,'(PYSUGI:) SUSY parameters give m(h0)^2 < 0.')
33191C...Give warning, but don't stop, if LSP not ~chi_10.
33192 IF (NOGOOD.EQ.5) CALL PYERRM(16
33193 & ,'(PYSUGI:) SUSY parameters give ~chi_10 not LSP.')
33194 ENDIF
33195C...Warn about possible GUT scale tachyons.
33196 IF (ITACHY.NE.0) CALL PYERRM(16,
33197 & '(PYSUGI:) Tachyonic sleptons at GUT scale.')
33198
33199C...M1 and M2.
33200 RMSS(1)=GSS(7)
33201 RMSS(2)=GSS(8)
33202C...Gluino Mass.
33203 RMSS(3)=SUPER(1)
33204C...Mu = - Higgsino mass.
33205 RMSS(4)=-SUPER(29)
33206 RMSS(5)=TANB
33207C...Slepton and squark masses. 2 first generations.
33208 RMSS(6)=0.5*(SUPER(18)+SUPER(20))
33209 RMSS(7)=0.5*(SUPER(19)+SUPER(21))
33210 RMSS(8)=0.25*(SUPER(2)+SUPER(4)+SUPER(6)+SUPER(8))
33211 RMSS(9)=0.25*(SUPER(3)+SUPER(5)+SUPER(7)+SUPER(9))
33212C...Third generation.
33213 RMSS(10)=0.5*(SUPER(14)+SUPER(10))
33214 RMSS(11)=SUPER(11)
33215 RMSS(12)=SUPER(15)
33216 RMSS(13)=SUPER(22)
33217 RMSS(14)=SUPER(23)
33218C...~b, ~t, and ~tau trilinear couplings and mixing angles.
33219 RMSS(15)=SUPER(62)
33220 RMSS(16)=SUPER(60)
33221 RMSS(17)=SUPER(64)
33222 RMSS(26)=SUPER(63)
33223 RMSS(27)=SUPER(61)
33224 RMSS(28)=SUPER(65)
33225C...Higgs mixing angle alpha (Gunion-Haber convention).
33226 RMSS(18)=-SUPER(59)
33227C...A0 mass.
33228 RMSS(19)=SUPER(57)
33229C...GUT scale coupling
33230 RMSS(20)=AGUTSS
33231C...Gravitino mass (for future compatibility)
33232 RMSS(21)=SUPER(66)
33233
33234C...Now we're done with RMSS. Time to fill PMAS (m > 0 required).
33235C...Higgs sector.
33236 PMAS(PYCOMP(25),1)=ABS(SUPER(55))
33237 PMAS(PYCOMP(35),1)=ABS(SUPER(56))
33238 PMAS(PYCOMP(36),1)=ABS(SUPER(57))
33239 PMAS(PYCOMP(37),1)=ABS(SUPER(58))
33240C...Gluino.
33241 PMAS(PYCOMP(KSUSY1+21),1)=ABS(SUPER(1))
33242C...Squarks and Sleptons.
33243 DO 120 ILR=1,2
33244 ILRM=ILR-1
33245 PMAS(PYCOMP(ILR*KSUSY1+1),1)=ABS(SUPER(4+ILRM))
33246 PMAS(PYCOMP(ILR*KSUSY1+2),1)=ABS(SUPER(2+ILRM))
33247 PMAS(PYCOMP(ILR*KSUSY1+3),1)=ABS(SUPER(6+ILRM))
33248 PMAS(PYCOMP(ILR*KSUSY1+4),1)=ABS(SUPER(8+ILRM))
33249 PMAS(PYCOMP(ILR*KSUSY1+5),1)=ABS(SUPER(12+ILRM))
33250 PMAS(PYCOMP(ILR*KSUSY1+6),1)=ABS(SUPER(16+ILRM))
33251 PMAS(PYCOMP(ILR*KSUSY1+11),1)=ABS(SUPER(18+ILRM))
33252 PMAS(PYCOMP(ILR*KSUSY1+13),1)=ABS(SUPER(20+ILRM))
33253 PMAS(PYCOMP(ILR*KSUSY1+15),1)=ABS(SUPER(24+ILRM))
33254 120 CONTINUE
33255 PMAS(PYCOMP(KSUSY1+12),1)=ABS(SUPER(26))
33256 PMAS(PYCOMP(KSUSY1+14),1)=ABS(SUPER(27))
33257 PMAS(PYCOMP(KSUSY1+16),1)=ABS(SUPER(28))
33258C...Neutralinos.
33259 PMAS(PYCOMP(KSUSY1+22),1)=ABS(SUPER(31))
33260 PMAS(PYCOMP(KSUSY1+23),1)=ABS(SUPER(32))
33261 PMAS(PYCOMP(KSUSY1+25),1)=ABS(SUPER(33))
33262 PMAS(PYCOMP(KSUSY1+35),1)=ABS(SUPER(34))
33263C...Signed masses (extra minus from going to G-H convention).
33264 SMZ(1)=-SUPER(31)
33265 SMZ(2)=-SUPER(32)
33266 SMZ(3)=-SUPER(33)
33267 SMZ(4)=-SUPER(34)
33268C...Charginos
33269 PMAS(PYCOMP(KSUSY1+24),1)=ABS(SUPER(51))
33270 PMAS(PYCOMP(KSUSY1+37),1)=ABS(SUPER(52))
33271C...Signed masses (extra minus from going to G-H convention).
33272 SMW(1)=-SUPER(51)
33273 SMW(2)=-SUPER(52)
33274
33275C... Neutralino Mixing.
33276 DO 130 IN=1,4
33277 ZMIX(IN,1)= SUPER(38+4*(IN-1))
33278 ZMIX(IN,2)= SUPER(37+4*(IN-1))
33279 ZMIX(IN,3)=-SUPER(36+4*(IN-1))
33280 ZMIX(IN,4)=-SUPER(35+4*(IN-1))
33281 130 CONTINUE
33282C...Chargino Mixing (PYTHIA same angle as HERWIG).
33283 THX=1D0
33284 THY=1D0
33285 IF (SUPER(53).GT.0) THX=-1D0
33286 IF (SUPER(54).GT.0) THY=-1D0
33287 UMIX(1,1) = -SIN(SUPER(53))
33288 UMIX(1,2) = -COS(SUPER(53))
33289 UMIX(2,1) = -THX*COS(SUPER(53))
33290 UMIX(2,2) = THX*SIN(SUPER(53))
33291 VMIX(1,1) = -SIN(SUPER(54))
33292 VMIX(1,2) = -COS(SUPER(54))
33293 VMIX(2,1) = -THY*COS(SUPER(54))
33294 VMIX(2,2) = THY*SIN(SUPER(54))
33295C...Sfermion mixing (PYTHIA same angle as ISAJET)
33296 SFMIX(5,1)=COS(SUPER(63))
33297 SFMIX(5,2)=SIN(SUPER(63))
33298 SFMIX(5,3)=-SIN(SUPER(63))
33299 SFMIX(5,4)=COS(SUPER(63))
33300 SFMIX(6,1)=COS(SUPER(61))
33301 SFMIX(6,2)=SIN(SUPER(61))
33302 SFMIX(6,3)=-SIN(SUPER(61))
33303 SFMIX(6,4)=COS(SUPER(61))
33304 SFMIX(15,1)=COS(SUPER(65))
33305 SFMIX(15,2)=SIN(SUPER(65))
33306 SFMIX(15,3)=-SIN(SUPER(65))
33307 SFMIX(15,4)=COS(SUPER(65))
33308
33309 IF (MSTP(122).NE.0) THEN
33310C...Print a few lines to make the user know what's happening
33311 ISAVER=VISAJE()
33312 WRITE(MSTU(11),5000) DOC, ISAVER
33313 WRITE(MSTU(11),5100)
33314 WRITE(MSTU(11),5200) MZERO, MHLF, AZERO, TANB, NINT(SGNMU), MTOP
33315 WRITE(MSTU(11),5300)
33316 WRITE(MSTU(11),5500) 'EW scale masses'
33317 WRITE(MSTU(11),5700) (SUPER(IP),IP=2,16,2),(SUPER(IP),IP=3,17,2)
33318 WRITE(MSTU(11),5800) (SUPER(IP),IP=18,24,2),(SUPER(IP),IP=26,28)
33319 & ,(SUPER(IP),IP=19,25,2)
33320 WRITE(MSTU(11),5900) SUPER(1),(SMZ(IP),IP=1,4), (SMW(IP)
33321 & ,IP=1,2)
33322 WRITE(MSTU(11),6000) (SUPER(IP),IP=55,58)
33323 WRITE(MSTU(11),5400)
33324 WRITE(MSTU(11),5500) 'Mixing structure'
33325 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
33326 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
33327 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
33328 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
33329 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
33330 & ),(SFMIX(15,J),J=3,4)
33331 WRITE(MSTU(11),5400)
33332 WRITE(MSTU(11),5500) 'Couplings'
33333 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17),RMSS(20)
33334 WRITE(MSTU(11),5400)
33335 WRITE(MSTU(11),6500)
33336 ENDIF
33337
33338C...Fix the higgs sector (in PYMSIN) using the masses and mixing angle
33339C...output by ISASUGRA.
33340 IMSS(4)=2
33341
33342 5000 FORMAT(1x,19('*'),1x,'PYSUGI v1.1: PYTHIA/ISASUGRA '
33343 & ,'INTERFACE',1x,19('*')/1x,'*',3x,'PYSUGI: Last Change',1x,A
33344 & ,1x,'-',1x,'P.Z. Skands'/1x,'*',2x,A/1x,'*')
33345 5100 FORMAT(1x,'*',1x,'ISASUGRA Input:'/1x,'*',1x,'----------------')
33346 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
33347 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
33348 5300 FORMAT(1x,'*'/1x,'*',1x,'ISASUGRA Output:'/1x,'*',1x
33349 & ,'----------------')
33350 5400 FORMAT(1x,'*',1x,A)
33351 5500 FORMAT(1x,'*',1x,A,':')
33352 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
33353 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
33354 5700 FORMAT(1x,'*',4x,4x,'~u',2x,1x,4x,'~d',2x,1x,4x,'~s',2x,1x,
33355 & 4x,'~c',2x,1x,4x,'~b',2x,1x,2x,'~b(12)',1x,4x,'~t',2x,1x, 2x,
33356 & '~t(12)'/1x,'*',2x,'L',1x,8(F8.2,1x)/1x,'*',2x,'R',1x,8(F8.2
33357 & ,1x))
33358 5800 FORMAT(1x,'*'/1x,'*',4x,4x,'~e',2x,1x,3x,'~mu',2x,1x,3x,'~tau',1x
33359 & ,1x,'~tau(12)',1x,2x,'~nu_e',1x,1x,1x,'~nu_mu',1x,1x,1x
33360 & ,'~nu_tau'/1x,'*',2x,'L',1x,7(F8.2,1x)/1x,'*',2x,'R',1x,4(F8
33361 & .2,1x))
33362 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
33363 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
33364 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
33365 6000 FORMAT(1x,'*'/1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
33366 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x))
33367 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
33368 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
33369 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
33370 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
33371 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
33372 & ,1x,F6.3,1x),'|')
33373 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
33374 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
33375 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
33376 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
33377 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
33378 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
33379 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
33380 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
33381 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
33382 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
33383 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
33384 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
33385 6400 FORMAT(1x,'*',3x,'A_b = ',F8.2,4x,'A_t = ',F8.2,4x,'A_tau = ',F8.2
33386 & ,4x,'Alpha_GUT = ',F8.2)
33387 6500 FORMAT(1x,32('*'),1x,'END OF PYSUGI',1x,31('*'))
33388 END
33389
33390C*********************************************************************
33391
33392C...PYRNMQ
33393C...Determines the running mass of Squarks.
33394
33395 FUNCTION PYRNMQ(ID,DTERM)
33396
33397C...Double precision and integer declarations.
33398 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33399 IMPLICIT INTEGER(I-N)
33400 INTEGER PYK,PYCHGE,PYCOMP
33401C...Commonblock.
33402 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
33403 SAVE /PYMSSM/
33404
33405C...Local variables.
33406 DOUBLE PRECISION PI,R
33407 DOUBLE PRECISION TOL
33408 DOUBLE PRECISION CI(3)
33409 EXTERNAL PYALPS
33410 DOUBLE PRECISION PYALPS
33411 DATA TOL/0.001D0/
33412 DATA PI,R/3.141592654D0,.61803399D0/
33413 DATA CI/0.47D0,0.07D0,0.02D0/
33414
33415 C=1D0-R
33416 CA=CI(ID)
33417 AG=(0.71D0)**2/4D0/PI
33418 AG=RMSS(20)
33419 XM0=RMSS(8)
33420 XMG=RMSS(1)
33421 XM02=XM0*XM0
33422 XMG2=XMG*XMG
33423
33424 AS=PYALPS(XM02+6D0*XMG2)
33425 CG=8D0/9D0*((AS/AG)**2-1D0)
33426 BX=XM02+(CA+CG)*XMG2+DTERM
33427 AX=MIN(50D0**2,0.5D0*BX)
33428 CX=MAX(2000D0**2,2D0*BX)
33429
33430 X0=AX
33431 X3=CX
33432 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
33433 X1=BX
33434 X2=BX+C*(CX-BX)
33435 ELSE
33436 X2=BX
33437 X1=BX-C*(BX-AX)
33438 ENDIF
33439 AS1=PYALPS(X1)
33440 CG=8D0/9D0*((AS1/AG)**2-1D0)
33441 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
33442 AS2=PYALPS(X2)
33443 CG=8D0/9D0*((AS2/AG)**2-1D0)
33444 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
33445 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
33446 IF(F2.LT.F1) THEN
33447 X0=X1
33448 X1=X2
33449 X2=R*X1+C*X3
33450 F1=F2
33451 AS2=PYALPS(X2)
33452 CG=8D0/9D0*((AS2/AG)**2-1D0)
33453 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
33454 ELSE
33455 X3=X2
33456 X2=X1
33457 X1=R*X2+C*X0
33458 F2=F1
33459 AS1=PYALPS(X1)
33460 CG=8D0/9D0*((AS1/AG)**2-1D0)
33461 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
33462 ENDIF
33463 GOTO 100
33464 ENDIF
33465 IF(F1.LT.F2) THEN
33466 PYRNMQ=X1
33467 XMIN=X1
33468 ELSE
33469 PYRNMQ=X2
33470 XMIN=X2
33471 ENDIF
33472
33473 RETURN
33474 END
33475
33476C*********************************************************************
33477
33478C...PYTHRG
33479C...Calculates the mass eigenstates of the third generation sfermions.
33480C...Created: 5-31-96
33481
33482 SUBROUTINE PYTHRG
33483
33484C...Double precision and integer declarations.
33485 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33486 IMPLICIT INTEGER(I-N)
33487 INTEGER PYK,PYCHGE,PYCOMP
33488C...Parameter statement to help give large particle numbers.
33489 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
33490 &KEXCIT=4000000,KDIMEN=5000000)
33491C...Commonblocks.
33492 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33493 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33494 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
33495 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
33496 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
33497 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
33498
33499C...Local variables.
33500 DOUBLE PRECISION BETA
33501 DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
33502 DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
33503 DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
33504 DOUBLE PRECISION ATR,AMQR,AMQL
33505 INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
33506 INTEGER IF,I,J,II,JJ,IT,L
33507 LOGICAL DTERM
33508 DATA SMALL/1D-3/
33509 DATA ID1/10,10,13/
33510 DATA ID2/5,6,15/
33511 DATA ID3/15,16,17/
33512 DATA ID4/11,12,14/
33513 DATA DTERM/.TRUE./
33514
33515 XMZ2=PMAS(23,1)**2
33516 XMW2=PMAS(24,1)**2
33517 TANB=RMSS(5)
33518 XMU=-RMSS(4)
33519 BETA=ATAN(TANB)
33520 COS2B=COS(2D0*BETA)
33521
33522C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
33523
33524 IOPT=IMSS(5)
33525 IF(IOPT.EQ.1) THEN
33526 CTT=DCOS(RMSS(27))
33527 CTT2=CTT**2
33528 STT=DSIN(RMSS(27))
33529 STT2=STT**2
33530 XM12=RMSS(10)**2
33531 XM22=RMSS(12)**2
33532 XMQL2=CTT2*XM12+STT2*XM22
33533 XMQR2=STT2*XM12+CTT2*XM22
33534 XMF2=PYMRUN(6,PMAS(6,1)**2)**2
33535 ATOP=-XMU/TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
33536 RMSS(16)=ATOP
33537C......SUBTRACT OUT D-TERM AND FERMION MASS
33538 XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0
33539 XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0
33540 IF(XMQL2.GE.0D0) THEN
33541 RMSS(10)=SQRT(XMQL2)
33542 ELSE
33543 RMSS(10)=-SQRT(-XMQL2)
33544 ENDIF
33545 IF(XMQR2.GE.0D0) THEN
33546 RMSS(12)=SQRT(XMQR2)
33547 ELSE
33548 RMSS(12)=-SQRT(-XMQR2)
33549 ENDIF
33550
33551C SAME FOR BOTTOM SQUARK
33552 CTT=DCOS(RMSS(26))
33553 CTT2=CTT**2
33554 STT=DSIN(RMSS(26))
33555 STT2=STT**2
33556 XM22=RMSS(11)**2
33557 XMF2=PYMRUN(5,PMAS(6,1)**2)**2
33558 XMQL2=SIGN(RMSS(10)**2,RMSS(10))-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2
33559 IF(ABS(CTT).GE..9999D0) THEN
33560 ABOT=-XMU*TANB
33561 XMQR2=RMSS(11)**2
33562 ELSEIF(ABS(CTT).LE.1D-4) THEN
33563 ABOT=-XMU*TANB
33564 XMQR2=RMSS(11)**2
33565 ELSE
33566 XM12=(XMQL2-STT2*XM22)/CTT2
33567 XMQR2=STT2*XM12+CTT2*XM22
33568 ABOT=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
33569 ENDIF
33570 RMSS(15)=ABOT
33571C......SUBTRACT OUT D-TERM AND FERMION MASS
33572 XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2
33573 IF(XMQR2.GE.0D0) THEN
33574 RMSS(11)=SQRT(XMQR2)
33575 ELSE
33576 RMSS(11)=-SQRT(-XMQR2)
33577 ENDIF
33578C SAME FOR TAU SLEPTON
33579 CTT=DCOS(RMSS(28))
33580 CTT2=CTT**2
33581 STT=DSIN(RMSS(28))
33582 STT2=STT**2
33583 XM12=RMSS(13)**2
33584 XM22=RMSS(14)**2
33585 XMQL2=CTT2*XM12+STT2*XM22
33586 XMQR2=STT2*XM12+CTT2*XM22
33587 XMFR=PMAS(15,1)
33588 XMF2=XMFR**2
33589 ATAU=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
33590 RMSS(17)=ATAU
33591C......SUBTRACT OUT D-TERM AND FERMION MASS
33592 XMQL2=XMQL2-XMF2+(-.5D0*XMZ2+XMW2)*COS2B
33593 XMQR2=XMQR2-XMF2+(XMZ2-XMW2)*COS2B
33594 IF(XMQL2.GE.0D0) THEN
33595 RMSS(13)=SQRT(XMQL2)
33596 ELSE
33597 RMSS(13)=-SQRT(-XMQL2)
33598 ENDIF
33599 IF(XMQR2.GE.0D0) THEN
33600 RMSS(14)=SQRT(XMQR2)
33601 ELSE
33602 RMSS(14)=-SQRT(-XMQR2)
33603 ENDIF
33604 ENDIF
33605 DO 170 L=1,3
33606 AMQL=RMSS(ID1(L))
33607 IF(AMQL.LT.0D0) THEN
33608 XMQL2=-AMQL**2
33609 ELSE
33610 XMQL2=AMQL**2
33611 ENDIF
33612 ATR=RMSS(ID3(L))
33613 AMQR=RMSS(ID4(L))
33614 IF(AMQR.LT.0D0) THEN
33615 XMQR2=-AMQR**2
33616 ELSE
33617 XMQR2=AMQR**2
33618 ENDIF
33619 IF=ID2(L)
33620 XMF=PYMRUN(IF,PMAS(6,1)**2)
33621 XMF2=XMF**2
33622 AM2(1,1)=XMQL2+XMF2
33623 AM2(2,2)=XMQR2+XMF2
33624 IF(AM2(1,1).EQ.AM2(2,2)) AM2(2,2)=AM2(2,2)*1.00001D0
33625 IF(DTERM) THEN
33626 IF(L.EQ.1) THEN
33627 AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0
33628 AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
33629 AM2(1,2)=XMF*(ATR+XMU*TANB)
33630 ELSEIF(L.EQ.2) THEN
33631 AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0
33632 AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0
33633 AM2(1,2)=XMF*(ATR+XMU/TANB)
33634 ELSEIF(L.EQ.3) THEN
33635 IF(IMSS(8).EQ.1) THEN
33636 AM2(1,1)=RMSS(6)**2
33637 AM2(2,2)=RMSS(7)**2
33638 AM2(1,2)=0D0
33639 RMSS(13)=RMSS(6)
33640 RMSS(14)=RMSS(7)
33641 ELSE
33642 AM2(1,1)=AM2(1,1)-(-.5D0*XMZ2+XMW2)*COS2B
33643 AM2(2,2)=AM2(2,2)-(XMZ2-XMW2)*COS2B
33644 AM2(1,2)=XMF*(ATR+XMU*TANB)
33645 ENDIF
33646 ENDIF
33647 ENDIF
33648 AM2(2,1)=AM2(1,2)
33649 DETM=AM2(1,1)*AM2(2,2)-AM2(2,1)**2
33650 IF(DETM.LT.0D0) THEN
33651 WRITE(MSTU(11),*) ID2(L),DETM,AM2
33652 CALL PYERRM(30,' NEGATIVE**2 MASS FOR SFERMION IN PYTHRG ')
33653 ENDIF
33654 SAME=0.5D0*(AM2(1,1)+AM2(2,2))
33655 DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1))
33656 XMF12=SAME-DIFF
33657 XMF22=SAME+DIFF
33658 IT=0
33659 IF(XMF22-XMF12.GT.0D0) THEN
33660 RT(1,1) = SQRT(MAX(0D0,(XMF22-AM2(1,1))/(XMF22-XMF12)))
33661 RT(2,2) = RT(1,1)
33662 RT(1,2) = -SIGN(SQRT(MAX(0D0,1D0-RT(1,1)**2)),
33663 & AM2(1,2)/(XMF22-XMF12))
33664 RT(2,1) = -RT(1,2)
33665 ELSE
33666 RT(1,1) = 1D0
33667 RT(2,2) = RT(1,1)
33668 RT(1,2) = 0D0
33669 RT(2,1) = -RT(1,2)
33670 ENDIF
33671 100 CONTINUE
33672 IT=IT+1
33673
33674 DO 140 I=1,2
33675 DO 130 JJ=1,2
33676 DI(I,JJ)=0D0
33677 DO 120 II=1,2
33678 DO 110 J=1,2
33679 DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II)
33680 110 CONTINUE
33681 120 CONTINUE
33682 130 CONTINUE
33683 140 CONTINUE
33684
33685 IF(DI(1,1).GT.DI(2,2)) THEN
33686 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION '
33687 WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22)
33688 WRITE(MSTU(11),*) AM2
33689 WRITE(MSTU(11),*) DI
33690 WRITE(MSTU(11),*) RT
33691 DI(1,1)=-RT(2,1)
33692 DI(2,2)=RT(1,2)
33693 DI(1,2)=-RT(2,2)
33694 DI(2,1)=RT(1,1)
33695 DO 160 I=1,2
33696 DO 150 J=1,2
33697 RT(I,J)=DI(I,J)
33698 150 CONTINUE
33699 160 CONTINUE
33700 GOTO 100
33701 ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN
33702 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
33703 & ' OFF DIAGONAL ELEMENTS '
33704 WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22)
33705 WRITE(MSTU(11),*) DI
33706 WRITE(MSTU(11),*) ' ROTATION = ',RT
33707C...STOP
33708 ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN
33709 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
33710 & ' NEGATIVE MASSES '
33711 STOP
33712 ENDIF
33713 PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12)
33714 PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22)
33715 SFMIX(IF,1)=RT(1,1)
33716 SFMIX(IF,2)=RT(1,2)
33717 SFMIX(IF,3)=RT(2,1)
33718 SFMIX(IF,4)=RT(2,2)
33719 170 CONTINUE
33720
33721C.....TAU SNEUTRINO MASS...L=3
33722
33723 XARG=AM2(1,1)+XMW2*COS2B
33724 IF(XARG.LT.0D0) THEN
33725 WRITE(MSTU(11),*) ' PYTHRG:: TAU SNEUTRINO MASS IS NEGATIVE'//
33726 & ' FROM THE SUM RULE. '
33727 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
33728 RETURN
33729 ELSE
33730 PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG)
33731 ENDIF
33732
33733 RETURN
33734 END
33735
33736C*********************************************************************
33737
33738C...PYINOM
33739C...Finds the mass eigenstates and mixing matrices for neutralinos
33740C...and charginos.
33741
33742 SUBROUTINE PYINOM
33743
33744C...Double precision and integer declarations.
33745 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33746 IMPLICIT INTEGER(I-N)
33747 INTEGER PYCOMP
33748C...Parameter statement to help give large particle numbers.
33749 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
33750 &KEXCIT=4000000,KDIMEN=5000000)
33751C...Commonblocks.
33752 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33753 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33754 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
33755 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
33756 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
33757 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
33758
33759C...Local variables.
33760 DOUBLE PRECISION XMW,XMZ,XM(4)
33761 DOUBLE PRECISION AR(4,4),WR(4),ZR(4,4),ZI(4,4),AI(4,4)
33762 DOUBLE PRECISION WI(4),FV1(4),FV2(4),FV3(4)
33763 DOUBLE PRECISION COSW,SINW
33764 DOUBLE PRECISION XMU
33765 DOUBLE PRECISION TANB,COSB,SINB
33766 DOUBLE PRECISION XM1,XM2,XM3,BETA
33767 DOUBLE PRECISION Q2,AEM,A1,A2,AQ,RM1,RM2
33768 DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
33769 DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
33770 DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
33771 DOUBLE PRECISION PYALPS,PYALEM
33772 DOUBLE PRECISION PYRNM3
33773 COMPLEX*16 CAR(4,4),CAI(4,4),CA1,CA2
33774 INTEGER IERR,INDEX(4),I,J,K,IOPT,ILR,KFNCHI(4)
33775 DATA KFNCHI/1000022,1000023,1000025,1000035/
33776
33777 IOPT=IMSS(2)
33778 IF(IMSS(1).EQ.2) THEN
33779 IOPT=1
33780 ENDIF
33781C...M1, M2, AND M3 ARE INDEPENDENT
33782 IF(IOPT.EQ.0) THEN
33783 XM1=RMSS(1)
33784 XM2=RMSS(2)
33785 XM3=RMSS(3)
33786 ELSEIF(IOPT.GE.1) THEN
33787 Q2=PMAS(23,1)**2
33788 AEM=PYALEM(Q2)
33789 A2=AEM/PARU(102)
33790 A1=AEM/(1D0-PARU(102))
33791 XM1=RMSS(1)
33792 XM2=RMSS(2)
33793 IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0
33794 IF(IOPT.EQ.1) THEN
33795 XM2=XM1*A2/A1*3D0/5D0
33796 RMSS(2)=XM2
33797 ELSEIF(IOPT.EQ.3) THEN
33798 XM1=XM2*5D0/3D0*A1/A2
33799 RMSS(1)=XM1
33800 ENDIF
33801 XM3=PYRNM3(XM2/A2)
33802 RMSS(3)=XM3
33803 IF(XM3.LE.0D0) THEN
33804 WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3
33805 STOP
33806 ENDIF
33807 ENDIF
33808
33809C...GLUINO MASS
33810 IF(IMSS(3).EQ.1) THEN
33811 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)
33812 ELSE
33813 AQ=0D0
33814 DO 110 I=1,4
33815 DO 100 ILR=1,2
33816 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
33817 AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0)
33818 & +(1D0-RM1)**2*LOG(ABS(1D0-RM1)))
33819 100 CONTINUE
33820 110 CONTINUE
33821
33822 DO 130 I=5,6
33823 DO 120 ILR=1,2
33824 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
33825 RM2=PMAS(I,1)**2/XM3**2
33826 ARG=(RM1-RM2-1D0)**2-4D0*RM2**2
33827 IF(ARG.GE.0D0) THEN
33828 X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG))
33829 AX0=ABS(X0)
33830 X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG))
33831 AX1=ABS(X1)
33832 IF(X0.EQ.1D0) THEN
33833 AT=-1D0
33834 BT=0.25D0
33835 ELSEIF(X0.EQ.0D0) THEN
33836 AT=0D0
33837 BT=-0.25D0
33838 ELSE
33839 AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+
33840 & 0.5D0*X0**2*LOG(AX0)
33841 BT=(-1D0-2D0*X0)/4D0
33842 ENDIF
33843 IF(X1.EQ.1D0) THEN
33844 AT=-1D0+AT
33845 BT=0.25D0+BT
33846 ELSEIF(X1.EQ.0D0) THEN
33847 AT=0D0+AT
33848 BT=-0.25D0+BT
33849 ELSE
33850 AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0*
33851 & X1**2*LOG(AX1)+AT
33852 BT=(-1D0-2D0*X1)/4D0+BT
33853 ENDIF
33854 AQ=AQ+AT+BT
33855 ELSE
33856 X0=0.5D0*(1D0+RM2-RM1)
33857 Y0=-0.5D0*SQRT(-ARG)
33858 AMGX0=SQRT(X0**2+Y0**2)
33859 AM1X0=SQRT((1D0-X0)**2+Y0**2)
33860 ARGX0=ATAN2(-X0,-Y0)
33861 AR1X0=ATAN2(1D0-X0,Y0)
33862 X1=X0
33863 Y1=-Y0
33864 AMGX1=AMGX0
33865 AM1X1=AM1X0
33866 ARGX1=ATAN2(-X1,-Y1)
33867 AR1X1=ATAN2(1D0-X1,Y1)
33868 AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2)
33869 & +0.5D0*(X0**2-Y0**2)*LOG(AMGX0)
33870 BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 )
33871 AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2)
33872 & +0.5D0*(X1**2-Y1**2)*LOG(AMGX1)
33873 BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 )
33874 AQ=AQ+AT+BT
33875 ENDIF
33876 120 CONTINUE
33877 130 CONTINUE
33878 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)*(1D0+PYALPS(XM3**2)
33879 & /(2D0*PARU(2))*(15D0+AQ))
33880 ENDIF
33881
33882C...NEUTRALINO MASSES
33883 DO 150 I=1,4
33884 DO 140 J=1,4
33885 AI(I,J)=0D0
33886 140 CONTINUE
33887 150 CONTINUE
33888 XMZ=PMAS(23,1)
33889 XMW=PMAS(24,1)
33890 XMU=RMSS(4)
33891 SINW=SQRT(PARU(102))
33892 COSW=SQRT(1D0-PARU(102))
33893 TANB=RMSS(5)
33894 BETA=ATAN(TANB)
33895 COSB=COS(BETA)
33896 SINB=TANB*COSB
33897
33898C... Definitions:
33899C... psi^0 =(-i bino^0, -i wino^0, h_d^0(=H_1^0), h_u^0(=H_2^0))
33900C... => L_neutralino = -1/2*(psi^0)^T * [AR] * psi^0 + h.c.
33901 AR(1,1) = XM1*COS(RMSS(30))
33902 AI(1,1) = XM1*SIN(RMSS(30))
33903 AR(2,2) = XM2*COS(RMSS(31))
33904 AI(2,2) = XM2*SIN(RMSS(31))
33905 AR(3,3) = 0D0
33906 AR(4,4) = 0D0
33907 AR(1,2) = 0D0
33908 AR(2,1) = 0D0
33909 AR(1,3) = -XMZ*SINW*COSB
33910 AR(3,1) = AR(1,3)
33911 AR(1,4) = XMZ*SINW*SINB
33912 AR(4,1) = AR(1,4)
33913 AR(2,3) = XMZ*COSW*COSB
33914 AR(3,2) = AR(2,3)
33915 AR(2,4) = -XMZ*COSW*SINB
33916 AR(4,2) = AR(2,4)
33917 AR(3,4) = -XMU*COS(RMSS(33))
33918 AI(3,4) = -XMU*SIN(RMSS(33))
33919 AR(4,3) = -XMU*COS(RMSS(33))
33920 AI(4,3) = -XMU*SIN(RMSS(33))
33921C CALL PYEIG4(AR,WR,ZR)
33922 CALL PYEICG(4,4,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
33923 IF(IERR.NE.0) THEN
33924 WRITE(MSTU(11),*) ' PROBLEM WITH PYEICG IN PYINOM '
33925 ENDIF
33926 DO 160 I=1,4
33927 INDEX(I)=I
33928 XM(I)=ABS(WR(I))
33929 160 CONTINUE
33930 DO 180 I=2,4
33931 K=I
33932 DO 170 J=I-1,1,-1
33933 IF(XM(K).LT.XM(J)) THEN
33934 ITMP=INDEX(J)
33935 XTMP=XM(J)
33936 INDEX(J)=INDEX(K)
33937 XM(J)=XM(K)
33938 INDEX(K)=ITMP
33939 XM(K)=XTMP
33940 K=K-1
33941 ELSE
33942 GOTO 180
33943 ENDIF
33944 170 CONTINUE
33945 180 CONTINUE
33946
33947
33948 DO 210 I=1,4
33949 K=INDEX(I)
33950 SMZ(I)=WR(K)
33951 PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I))
33952 S=0D0
33953 DO 190 J=1,4
33954 S=S+ZR(J,K)**2+ZI(J,K)**2
33955 190 CONTINUE
33956 DO 200 J=1,4
33957 ZMIX(I,J)=ZR(J,K)/SQRT(S)
33958 ZMIXI(I,J)=ZI(J,K)/SQRT(S)
33959 IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0
33960 IF(ABS(ZMIXI(I,J)).LT.1D-6) ZMIXI(I,J)=0D0
33961 200 CONTINUE
33962 210 CONTINUE
33963
33964C...CHARGINO MASSES
33965C.....Find eigenvectors of X X^*
33966 AI(1,1) = 0D0
33967 AI(2,2) = 0D0
33968 AR(1,1) = XM2**2+2D0*XMW**2*SINB**2
33969 AR(2,2) = XMU**2+2D0*XMW**2*COSB**2
33970 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
33971 &XMU*COS(RMSS(33))*SINB)
33972 AI(1,2) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*COSB-
33973 &XMU*SIN(RMSS(33))*SINB)
33974 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
33975 &XMU*COS(RMSS(33))*SINB)
33976 AI(2,1) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*COSB+
33977 &XMU*SIN(RMSS(33))*SINB)
33978 CALL PYEICG(4,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
33979 IF(IERR.NE.0) THEN
33980 WRITE(MSTU(11),*) ' PROBLEM WITH PYEICG IN PYINOM '
33981 ENDIF
33982 INDEX(1)=1
33983 INDEX(2)=2
33984 IF(WR(2).LT.WR(1)) THEN
33985 INDEX(1)=2
33986 INDEX(2)=1
33987 ENDIF
33988
33989 DO 240 I=1,2
33990 K=INDEX(I)
33991 SMW(I)=SQRT(WR(K))
33992 S=0D0
33993 DO 220 J=1,2
33994 S=S+ZR(J,K)**2+ZI(J,K)**2
33995 220 CONTINUE
33996 DO 230 J=1,2
33997 UMIX(I,J)=ZR(J,K)/SQRT(S)
33998 UMIXI(I,J)=-ZI(J,K)/SQRT(S)
33999 IF(ABS(UMIX(I,J)).LT.1D-6) UMIX(I,J)=0D0
34000 IF(ABS(UMIXI(I,J)).LT.1D-6) UMIXI(I,J)=0D0
34001 230 CONTINUE
34002 240 CONTINUE
34003 IF(ABS(SMW(1)).LT.ABS(SMZ(1))) THEN
34004 SMW(1)=SIGN(ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1),SMW(1))
34005 ENDIF
34006 PMAS(PYCOMP(KSUSY1+24),1)=SMW(1)
34007 PMAS(PYCOMP(KSUSY1+37),1)=SMW(2)
34008
34009C.....Find eigenvectors of X^* X
34010 AI(1,1) = 0D0
34011 AI(2,2) = 0D0
34012 AR(1,1) = XM2**2+2D0*XMW**2*COSB**2
34013 AR(2,2) = XMU**2+2D0*XMW**2*SINB**2
34014 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
34015 &XMU*COS(RMSS(33))*COSB)
34016 AI(1,2) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*SINB+
34017 &XMU*SIN(RMSS(33))*COSB)
34018 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
34019 &XMU*COS(RMSS(33))*COSB)
34020 AI(2,1) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*SINB-
34021 &XMU*SIN(RMSS(33))*COSB)
34022 CALL PYEICG(4,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
34023 IF(IERR.NE.0) THEN
34024 WRITE(MSTU(11),*) ' PROBLEM WITH PYEICG IN PYINOM '
34025 ENDIF
34026 INDEX(1)=1
34027 INDEX(2)=2
34028 IF(WR(2).LT.WR(1)) THEN
34029 INDEX(1)=2
34030 INDEX(2)=1
34031 ENDIF
34032
34033 DO 270 I=1,2
34034 K=INDEX(I)
34035 S=0D0
34036 DO 250 J=1,2
34037 S=S+ZR(J,K)**2+ZI(J,K)**2
34038 250 CONTINUE
34039 DO 260 J=1,2
34040 VMIX(I,J)=ZR(J,K)/SQRT(S)
34041 VMIXI(I,J)=-ZI(J,K)/SQRT(S)
34042 IF(ABS(VMIX(I,J)).LT.1D-6) VMIX(I,J)=0D0
34043 IF(ABS(VMIXI(I,J)).LT.1D-6) VMIXI(I,J)=0D0
34044 260 CONTINUE
34045 270 CONTINUE
34046
34047
34048 RETURN
34049 END
34050
34051C*********************************************************************
34052
34053C...PYRNM3
34054C...Calculates the running of M3, the SU(3) gluino mass parameter.
34055
34056 FUNCTION PYRNM3(RGUT)
34057
34058C...Double precision and integer declarations.
34059 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34060 IMPLICIT INTEGER(I-N)
34061 INTEGER PYK,PYCHGE,PYCOMP
34062
34063C...Local variables.
34064 DOUBLE PRECISION R
34065 DOUBLE PRECISION TOL
34066 EXTERNAL PYALPS
34067 DOUBLE PRECISION PYALPS
34068 DATA TOL/0.001D0/
34069 DATA R/0.61803399D0/
34070
34071 C=1D0-R
34072
34073 BX=RGUT*PYALPS(RGUT**2)
34074 AX=MIN(50D0,BX*0.5D0)
34075 CX=MAX(2000D0,2D0*BX)
34076
34077 X0=AX
34078 X3=CX
34079 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
34080 X1=BX
34081 X2=BX+C*(CX-BX)
34082 ELSE
34083 X2=BX
34084 X1=BX-C*(BX-AX)
34085 ENDIF
34086 AS1=PYALPS(X1**2)
34087 F1=ABS(X1-RGUT*AS1)
34088 AS2=PYALPS(X2**2)
34089 F2=ABS(X2-RGUT*AS2)
34090 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
34091 IF(F2.LT.F1) THEN
34092 X0=X1
34093 X1=X2
34094 X2=R*X1+C*X3
34095 F1=F2
34096 AS2=PYALPS(X2**2)
34097 F2=ABS(X2-RGUT*AS2)
34098 ELSE
34099 X3=X2
34100 X2=X1
34101 X1=R*X2+C*X0
34102 F2=F1
34103 AS1=PYALPS(X1**2)
34104 F1=ABS(X1-RGUT*AS1)
34105 ENDIF
34106 GOTO 100
34107 ENDIF
34108 IF(F1.LT.F2) THEN
34109 PYRNM3=X1
34110 XMIN=X1
34111 ELSE
34112 PYRNM3=X2
34113 XMIN=X2
34114 ENDIF
34115
34116 RETURN
34117 END
34118
34119C*********************************************************************
34120
34121C...PYEIG4
34122C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
34123C...Specific application: mixing in neutralino sector.
34124
34125 SUBROUTINE PYEIG4(A,W,Z)
34126
34127C...Double precision and integer declarations.
34128 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34129 IMPLICIT INTEGER(I-N)
34130 INTEGER PYK,PYCHGE,PYCOMP
34131
34132C...Arrays: in call and local.
34133 DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)
34134
34135C...Coefficients of fourth-degree equation from matrix.
34136C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
34137 B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
34138 B2=0D0
34139 DO 110 I=1,3
34140 DO 100 J=I+1,4
34141 B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
34142 100 CONTINUE
34143 110 CONTINUE
34144 B1=0D0
34145 B0=0D0
34146 DO 120 I=1,4
34147 I1=MOD(I,4)+1
34148 I2=MOD(I+1,4)+1
34149 I3=MOD(I+2,4)+1
34150 B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
34151 & A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
34152 & A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
34153 B0=B0+(-1D0)**(I+1)*A(1,I)*(
34154 & A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
34155 & A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
34156 & A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
34157 120 CONTINUE
34158
34159C...Coefficients of third-degree equation needed for
34160C...separation into two second-degree equations.
34161C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
34162 C2=-B2
34163 C1=B1*B3-4D0*B0
34164 C0=-B1**2-B0*B3**2+4D0*B0*B2
34165 CQ=C1/3D0-C2**2/9D0
34166 CR=C1*C2/6D0-C0/2D0-C2**3/27D0
34167 CQR=CQ**3+CR**2
34168
34169C...Cases with one or three real roots.
34170 IF(CQR.GE.0D0) THEN
34171 S1=(CR+SQRT(CQR))**(1D0/3D0)
34172 S2=(CR-SQRT(CQR))**(1D0/3D0)
34173 U=S1+S2-C2/3D0
34174 ELSE
34175 SABS=SQRT(-CQ)
34176 THE=ACOS(CR/SABS**3)/3D0
34177 SRE=SABS*COS(THE)
34178 U=2D0*SRE-C2/3D0
34179 ENDIF
34180
34181C...Find and solve two second-degree equations.
34182 P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
34183 P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
34184 Q1=U/2D0+SQRT(U**2/4D0-B0)
34185 Q2=U/2D0-SQRT(U**2/4D0-B0)
34186 IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
34187 QSAV=Q1
34188 Q1=Q2
34189 Q2=QSAV
34190 ENDIF
34191 X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
34192 X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
34193 X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
34194 X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)
34195
34196C...Order eigenvalues in asceding mass.
34197 W(1)=X(1)
34198 DO 150 I1=2,4
34199 DO 130 I2=I1-1,1,-1
34200 IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
34201 W(I2+1)=W(I2)
34202 130 CONTINUE
34203 140 W(I2+1)=X(I1)
34204 150 CONTINUE
34205
34206C...Find equation system for eigenvectors.
34207 DO 250 I=1,4
34208 DO 170 J1=1,4
34209 D(J1,J1)=A(J1,J1)-W(I)
34210 DO 160 J2=J1+1,4
34211 D(J1,J2)=A(J1,J2)
34212 D(J2,J1)=A(J2,J1)
34213 160 CONTINUE
34214 170 CONTINUE
34215
34216C...Find largest element in matrix.
34217 DAMAX=0D0
34218 DO 190 J1=1,4
34219 DO 180 J2=1,4
34220 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
34221 JA=J1
34222 JB=J2
34223 DAMAX=ABS(D(J1,J2))
34224 180 CONTINUE
34225 190 CONTINUE
34226
34227C...Subtract others by multiple of row selected above.
34228 DAMAX=0D0
34229 DO 210 J3=JA+1,JA+3
34230 J1=J3-4*((J3-1)/4)
34231 RL=D(J1,JB)/D(JA,JB)
34232 DO 200 J2=1,4
34233 D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
34234 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
34235 JC=J1
34236 JD=J2
34237 DAMAX=ABS(D(J1,J2))
34238 200 CONTINUE
34239 210 CONTINUE
34240
34241C...Do one more subtraction of a row.
34242 DAMAX=0D0
34243 DO 230 J3=JC+1,JC+3
34244 J1=J3-4*((J3-1)/4)
34245 IF(J1.EQ.JA) GOTO 230
34246 RL=D(J1,JD)/D(JC,JD)
34247 DO 220 J2=1,4
34248 IF(J2.EQ.JB) GOTO 220
34249 D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
34250 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
34251 JE=J1
34252 DAMAX=ABS(D(J1,J2))
34253 220 CONTINUE
34254 230 CONTINUE
34255
34256C...Construct unnormalized eigenvector.
34257 JF1=JD+1-4*(JD/4)
34258 JF2=JD+2-4*((JD+1)/4)
34259 IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
34260 IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
34261 E(JF1)=-D(JE,JF2)
34262 E(JF2)=D(JE,JF1)
34263 E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
34264 E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
34265 & D(JA,JB)
34266
34267C...Normalize and fill in final array.
34268 EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
34269 SGN=(-1D0)**INT(PYR(0)+0.5D0)
34270 DO 240 J=1,4
34271 Z(I,J)=SGN*E(J)/EA
34272 240 CONTINUE
34273 250 CONTINUE
34274
34275 RETURN
34276 END
34277
34278C*********************************************************************
34279
34280C...PYHGGM
34281C...Determines the Higgs boson mass spectrum using several inputs.
34282
34283 SUBROUTINE PYHGGM(ALPHA)
34284
34285C...Double precision and integer declarations.
34286 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34287 IMPLICIT INTEGER(I-N)
34288 INTEGER PYK,PYCHGE,PYCOMP
34289C...Parameter statement to help give large particle numbers.
34290 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
34291 &KEXCIT=4000000,KDIMEN=5000000)
34292C...Commonblocks.
34293 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34294 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34295 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
34296 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
34297 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/
34298
34299C...Local variables.
34300 DOUBLE PRECISION AT,AB,XMU,TANB
34301 DOUBLE PRECISION ALPHA
34302 INTEGER IHOPT
34303 DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
34304 DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
34305 DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
34306 DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
34307
34308 IHOPT=IMSS(4)
34309 IF(IHOPT.EQ.2) THEN
34310 ALPHA=RMSS(18)
34311 RETURN
34312 ENDIF
34313 AT=RMSS(16)
34314 AB=RMSS(15)
34315 DMGL=RMSS(3)
34316 XMU=RMSS(4)
34317 TANB=RMSS(5)
34318
34319 DMA=RMSS(19)
34320 DTANB=TANB
34321 DMQ=RMSS(10)
34322 DMUR=RMSS(12)
34323 DMDR=RMSS(11)
34324 DMTOP=PMAS(6,1)
34325 DMC=PMAS(PYCOMP(KSUSY1+37),1)
34326 DAU=AT
34327 DAD=AB
34328 DMU=XMU
34329 RMSS(40)=0D0
34330 RMSS(41)=0D0
34331
34332 IF(IHOPT.EQ.0) THEN
34333 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
34334 & DMHCH,DSA,DCA,DTANBA)
34335 ELSEIF(IHOPT.EQ.1) THEN
34336 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
34337 & DMHCH,DSA,DCA,DTANBA)
34338 CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU,
34339 & DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA,
34340 & DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA,DMGL,DDT,DDB)
34341 RMSS(40)=DDT
34342 RMSS(41)=DDB
34343 DMH=DMHP
34344 DHM=DHMP
34345 DMA=DAMP
34346 IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.5D-1) THEN
34347 WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
34348 WRITE(MSTU(11),*) ' STOP1 MASSES = ',
34349 & PMAS(PYCOMP(1000006),1),DSTOP2
34350 ENDIF
34351 IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.5D-1) THEN
34352 WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
34353 WRITE(MSTU(11),*) ' STOP2 MASSES = ',
34354 & PMAS(PYCOMP(2000006),1),DSTOP1
34355 ENDIF
34356 IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.5D-1) THEN
34357 WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
34358 WRITE(MSTU(11),*) ' SBOT1 MASSES = ',
34359 & PMAS(PYCOMP(1000005),1),DSBOT2
34360 ENDIF
34361 IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.5D-1) THEN
34362 WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
34363 WRITE(MSTU(11),*) ' SBOT2 MASSES = ',
34364 & PMAS(PYCOMP(2000005),1),DSBOT1
34365 ENDIF
34366
34367 ENDIF
34368
34369 ALPHA=ACOS(DCA)
34370
34371 PMAS(25,1)=DMH
34372 PMAS(35,1)=DHM
34373 PMAS(36,1)=DMA
34374 PMAS(37,1)=DMHCH
34375
34376 RETURN
34377 END
34378
34379C*********************************************************************
34380
34381C...PYSUBH
34382C...This routine computes the renormalization group improved
34383C...values of Higgs masses and couplings in the MSSM.
34384
34385C...Program based on the work by M. Carena, J.R. Espinosa,
34386c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
34387
34388C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
34389C...All masses in GeV units. MA is the CP-odd Higgs mass,
34390C...MTOP is the physical top mass, MQ and MUR are the soft
34391C...supersymmetry breaking mass parameters of left handed
34392C...and right handed stops respectively, AU and AD are the
34393C...stop and sbottom trilinear soft breaking terms,
34394C...respectively, and MU is the supersymmetric
34395C...Higgs mass parameter. We use the conventions from
34396C...the physics report of Haber and Kane: left right
34397C...stop mixing term proportional to (AU - MU/TANB)
34398C...We use as input TANB defined at the scale MTOP
34399
34400C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
34401C...where MH and HM are the lightest and heaviest CP-even
34402C...Higgs masses, MHCH is the charged Higgs mass and
34403C...ALPHA is the Higgs mixing angle
34404C...TANBA is the angle TANB at the CP-odd Higgs mass scale
34405
34406C...Range of validity:
34407C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
34408C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
34409C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
34410C...are the sbottom mass eigenvalues, respectively. This
34411C...range automatically excludes the existence of tachyons.
34412C...For the charged Higgs mass computation, the method is
34413C...valid if
34414C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
34415C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
34416C...where M_SUSY**2 is the average of the squared stop mass
34417C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
34418C...masses have been assumed to be of order of the stop ones
34419C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
34420
34421 SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
34422 &XMHCH,SA,CA,TANBA)
34423
34424C...Double precision and integer declarations.
34425 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34426 IMPLICIT INTEGER(I-N)
34427 INTEGER PYK,PYCHGE,PYCOMP
34428C...Parameter statement to help give large particle numbers.
34429 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
34430 &KEXCIT=4000000,KDIMEN=5000000)
34431C...Commonblocks.
34432 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34433 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34434 COMMON/PYHTRI/HHH(7)
34435 SAVE /PYDAT1/,/PYDAT2/
34436
34437C...Local variables.
34438 DOUBLE PRECISION PYALEM,PYALPS
34439 DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
34440 DOUBLE PRECISION XMHCH,SA,CA
34441 DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
34442 DOUBLE PRECISION Q02
34443 DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
34444 DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
34445 DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
34446 DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
34447 DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
34448 DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
34449 DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
34450 DOUBLE PRECISION AU2,XMU2,XMZ,XMS3
34451
34452 XMZ = PMAS(23,1)
34453 Q02=XMZ**2
34454 AEM=PYALEM(Q02)
34455 ALP1=AEM/(1D0-PARU(102))
34456 ALP2=AEM/PARU(102)
34457 ALPH3Z=PYALPS(Q02)
34458
34459 ALP1 = 0.0101D0
34460 ALP2 = 0.0337D0
34461 ALPH3Z = 0.12D0
34462
34463 V = 174.1D0
34464 PI = PARU(1)
34465 TANBA = TANB
34466 TANBT = TANB
34467
34468C...MBOTTOM(MTOP) = 3. GEV
34469 XMB = PYMRUN(5,XMTOP**2)
34470 ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z*
34471 &LOG(XMTOP**2/XMZ**2))
34472
34473C...RMTOP= RUNNING TOP QUARK MASS
34474 RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
34475 XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0
34476 T = LOG(XMS**2/XMTOP**2)
34477 SINB = TANB/((1D0 + TANB**2)**0.5D0)
34478 COSB = SINB/TANB
34479C...IF(MA.LE.XMTOP) TANBA = TANBT
34480 IF(XMA.GT.XMTOP)
34481 &TANBA = TANBT*(1D0-3D0/32D0/PI**2*
34482 &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
34483 &LOG(XMA**2/XMTOP**2))
34484
34485 SINBT = TANBT/SQRT(1D0 + TANBT**2)
34486 COSBT = 1D0/SQRT(1D0 + TANBT**2)
34487C COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
34488 G1 = SQRT(ALP1*4D0*PI)
34489 G2 = SQRT(ALP2*4D0*PI)
34490 G3 = SQRT(ALP3*4D0*PI)
34491 HU = RMTOP/V/SINBT
34492 HD = XMB/V/COSBT
34493 HU2=HU*HU
34494 HD2=HD*HD
34495 HU4=HU2*HU2
34496 HD4=HD2*HD2
34497 AU2=AU**2
34498 AD2=AD**2
34499 XMS2=XMS**2
34500 XMS3=XMS**3
34501 XMS4=XMS2*XMS2
34502 XMU2=XMU*XMU
34503 PI2=PI*PI
34504
34505 XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2)
34506 XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2)
34507 AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4
34508 &+ 3D0*(AU + AD)**2/XMS2)/6D0
34509 XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2)
34510 &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
34511 &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2)
34512 &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2
34513 &- 16D0*G3**2) *T/16D0/PI2)
34514 XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2)
34515 &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
34516 &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2)
34517 &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2
34518 &- 16D0*G3**2) *T/16D0/PI2)
34519 XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
34520 &(HU2 + HD2)*T/16D0/PI2)
34521 &+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
34522 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
34523 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
34524 &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0
34525 &- 16D0*G3**2) *T/16D0/PI2)
34526 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
34527 &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2
34528 &- 16D0*G3**2) *T/16D0/PI2)
34529 XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2)
34530 &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
34531 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
34532 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
34533 &XMS4)*
34534 &(1+ (6D0*HU2 -2D0* HD2
34535 &- 16D0*G3**2) *T/16D0/PI2)
34536 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
34537 &XMS4)*
34538 &(1+ (6D0*HD2 -2D0* HU2/2D0
34539 &- 16D0*G3**2) *T/16D0/PI2)
34540 XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) *
34541 &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2)
34542 &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) *
34543 &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2)
34544 XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) *
34545 &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
34546 &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) *
34547 &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
34548 XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) *
34549 &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
34550 &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) *
34551 &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
34552 HHH(1)=XLAM1
34553 HHH(2)=XLAM2
34554 HHH(3)=XLAM3
34555 HHH(4)=XLAM4
34556 HHH(5)=XLAM5
34557 HHH(6)=XLAM6
34558 HHH(7)=XLAM7
34559 TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 +
34560 &2D0* XLAM6*SINBT*COSBT
34561 &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT
34562 &+ XLAM5*COSBT**2)
34563 DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) +
34564 &XLAM6*COSBT**2
34565 &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 +
34566 &2D0* XLAM6* COSBT*SINBT
34567 &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
34568 &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 *
34569 &((XLAM1* COSBT**2 +2D0*
34570 &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 +
34571 &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2)
34572 &*SINBT**2
34573 &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3
34574 &+ XLAM4) + XLAM6*COSBT**2
34575 &+ XLAM7* SINBT**2))
34576
34577 XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0
34578 XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0
34579 XHM = SQRT(XHM2)
34580 XMH = SQRT(XMH2)
34581 XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2
34582 XMHCH = SQRT(XMHCH2)
34583
34584 SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) -
34585 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
34586 &XLAM6* COSBT*SINBT
34587 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
34588 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
34589 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/
34590 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0
34591
34592 COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) +
34593 &XLAM6*COSBT**2 + XLAM7* SINBT**2) -
34594 &XMA**2*SINBT*COSBT))/2D0**0.5D0/
34595 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)*
34596 &(((TRM2**2 - 4D0* DETM2)**0.5D0) -
34597 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
34598 &XLAM6* COSBT*SINBT
34599 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
34600 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
34601 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2))))
34602
34603 SA = -SINALP
34604 CA = -COSALP
34605
34606 100 CONTINUE
34607
34608 RETURN
34609 END
34610
34611C*********************************************************************
34612
34613C...PYPOLE
34614C...This subroutine computes the CP-even higgs and CP-odd pole
34615c...Higgs masses and mixing angles.
34616
34617C...Program based on the work by M. Carena, M. Quiros
34618C...and C.E.M. Wagner, "Effective potential methods and
34619C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
34620
34621C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
34622C...AT,AB,MU
34623C...where MCHI is the largest chargino mass, MA is the running
34624C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
34625C...expectaion values at the scale MTOP, MQ is the third generation
34626C...left handed squark mass parameter, MUR is the third generation
34627C...right handed stop mass parameter, MDR is the third generation
34628C...right handed sbottom mass parameter, MTOP is the pole top quark
34629C...mass; AT,AB are the soft supersymmetry breaking trilinear
34630C...couplings of the stop and sbottoms, respectively, and MU is the
34631C...supersymmetric mass parameter
34632
34633C...The parameter IHIGGS=0,1,2,3 corresponds to the number of
34634C...Higgses whose pole mass is computed. If IHIGGS=0 only running
34635C...masses are given, what makes the running of the program
34636c...much faster and it is quite generally a good approximation
34637c...(for a theoretical discussion see ref. above). If IHIGGS=1,
34638C...only the pole mass for H is computed. If IHIGGS=2, then h and H,
34639c...and if IHIGGS=3, then h,H,A polarizations are computed
34640
34641C...Output: MH and MHP which are the lightest CP-even Higgs running
34642C...and pole masses, respectively; HM and HMP are the heaviest CP-even
34643C...Higgs running and pole masses, repectively; SA and CA are the
34644C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
34645C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
34646C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
34647C...the value of TANB at the CP-odd Higgs mass scale
34648
34649C...This subroutine makes use of CERN library subroutine
34650C...integration package, which makes the computation of the
34651C...pole Higgs masses somewhat faster. We thank P. Janot for this
34652C...improvement. Those who are not able to call the CERN
34653C...libraries, please use the subroutine SUBHPOLE2.F, which
34654C...although somewhat slower, gives identical results
34655
34656 SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
34657 &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA,XMG,DT,DB)
34658
34659C...Double precision and integer declarations.
34660 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34661 IMPLICIT INTEGER(I-N)
34662
34663C...Parameters.
34664 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34665 SAVE /PYDAT1/
34666 INTEGER PYK,PYCHGE,PYCOMP
34667
34668C...Local variables.
34669 DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
34670 &SSBOT2(2),B(2,2),COUPB(2,2),
34671 &HCOUPT(2,2),HCOUPB(2,2),
34672 &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
34673
34674 DELTA(1,1) = 1D0
34675 DELTA(2,2) = 1D0
34676 DELTA(1,2) = 0D0
34677 DELTA(2,1) = 0D0
34678 V = 174.1D0
34679 XMZ=91.18D0
34680 PI=PARU(1)
34681 RXMT=PYMRUN(6,XMT**2)
34682 CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
34683 &XMU,XMH,HM,XMCH,SA,CA,SAB,CAB,TANBA,XMG,DT,DB)
34684
34685 SINB = TANB/(TANB**2+1D0)**0.5D0
34686 COSB = 1D0/(TANB**2+1D0)**0.5D0
34687 COS2B = SINB**2 - COSB**2
34688 SINBPA = SINB*CA + COSB*SA
34689 COSBPA = COSB*CA - SINB*SA
34690 RMBOT = PYMRUN(5,XMT**2)
34691 XMQ2 = XMQ**2
34692 XMUR2 = XMUR**2
34693 IF(XMUR.LT.0D0) XMUR2=-XMUR2
34694 XMDR2 = XMDR**2
34695 XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B
34696 XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
34697 IF(XMST11.LT.0D0) GOTO 500
34698 IF(XMST22.LT.0D0) GOTO 500
34699 XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B
34700 XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
34701 IF(XMSB11.LT.0D0) GOTO 500
34702 IF(XMSB22.LT.0D0) GOTO 500
34703C WMST11 = RXMT**2 + XMQ2
34704C WMST22 = RXMT**2 + XMUR2
34705 XMST12 = RXMT*(AT - XMU/TANB)
34706 XMSB12 = RMBOT*(AB - XMU*TANB)
34707
34708CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34709C...STOP EIGENVALUES CALCULATION
34710CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34711
34712 STOP12 = 0.5D0*(XMST11+XMST22) +
34713 &0.5D0*((XMST11+XMST22)**2 -
34714 &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
34715 STOP22 = 0.5D0*(XMST11+XMST22) -
34716 &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
34717 &XMST12**2))**0.5D0
34718
34719 IF(STOP22.LT.0D0) GOTO 500
34720 SSTOP2(1) = STOP12
34721 SSTOP2(2) = STOP22
34722 STOP1 = STOP12**0.5D0
34723 STOP2 = STOP22**0.5D0
34724C STOP1W = STOP1
34725C STOP2W = STOP2
34726
34727 IF(XMST12.EQ.0D0) XST11 = 1D0
34728 IF(XMST12.EQ.0D0) XST12 = 0D0
34729 IF(XMST12.EQ.0D0) XST21 = 0D0
34730 IF(XMST12.EQ.0D0) XST22 = 1D0
34731
34732 IF(XMST12.EQ.0D0) GOTO 110
34733
34734 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
34735 XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
34736 XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
34737 XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
34738
34739 110 T(1,1) = XST11
34740 T(2,2) = XST22
34741 T(1,2) = XST12
34742 T(2,1) = XST21
34743
34744 SBOT12 = 0.5D0*(XMSB11+XMSB22) +
34745 &0.5D0*((XMSB11+XMSB22)**2 -
34746 &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
34747 SBOT22 = 0.5D0*(XMSB11+XMSB22) -
34748 &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
34749 &XMSB12**2))**0.5D0
34750 IF(SBOT22.LT.0D0) GOTO 500
34751 SBOT1 = SBOT12**0.5D0
34752 SBOT2 = SBOT22**0.5D0
34753
34754 SSBOT2(1) = SBOT12
34755 SSBOT2(2) = SBOT22
34756
34757 IF(XMSB12.EQ.0D0) XSB11 = 1D0
34758 IF(XMSB12.EQ.0D0) XSB12 = 0D0
34759 IF(XMSB12.EQ.0D0) XSB21 = 0D0
34760 IF(XMSB12.EQ.0D0) XSB22 = 1D0
34761
34762 IF(XMSB12.EQ.0D0) GOTO 130
34763
34764 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
34765 XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
34766 XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
34767 XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
34768
34769 130 B(1,1) = XSB11
34770 B(2,2) = XSB22
34771 B(1,2) = XSB12
34772 B(2,1) = XSB21
34773
34774
34775 SINT = 0.2320D0
34776 SQR = DSQRT(2D0)
34777 VP = 174.1D0*SQR
34778
34779CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34780C...STARTING OF LIGHT HIGGS
34781CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34782
34783 IF(IHIGGS.EQ.0) GOTO 490
34784
34785 DO 150 I = 1,2
34786 DO 140 J = 1,2
34787 COUPT(I,J) =
34788 & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
34789 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
34790 & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
34791 & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
34792 & T(1,J)*T(2,I))
34793 140 CONTINUE
34794 150 CONTINUE
34795
34796
34797 DO 170 I = 1,2
34798 DO 160 J = 1,2
34799 COUPB(I,J) =
34800 & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
34801 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
34802 & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
34803 & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
34804 & B(1,J)*B(2,I))
34805 160 CONTINUE
34806 170 CONTINUE
34807
34808 PRUN = XMH
34809 EPS = 1D-4*PRUN
34810 ITER = 0
34811 180 ITER = ITER + 1
34812 DO 230 I3 = 1,3
34813
34814 PR(I3)=PRUN+(I3-2)*EPS/2
34815 P2=PR(I3)**2
34816 POLT = 0D0
34817 DO 200 I = 1,2
34818 DO 190 J = 1,2
34819 POLT = POLT + COUPT(I,J)**2*3D0*
34820 & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
34821 190 CONTINUE
34822 200 CONTINUE
34823
34824 POLB = 0D0
34825 DO 220 I = 1,2
34826 DO 210 J = 1,2
34827 POLB = POLB + COUPB(I,J)**2*3D0*
34828 & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
34829 210 CONTINUE
34830 220 CONTINUE
34831C RXMT2 = RXMT**2
34832 XMT2=XMT**2
34833
34834 POLTT =
34835 & 3D0*RXMT**2/8D0/PI**2/ V **2*
34836 & CA**2/SINB**2 *
34837 & (-2D0*XMT**2+0.5D0*P2)*
34838 & PYFINT(P2,XMT2,XMT2)
34839
34840 POL = POLT + POLB + POLTT
34841 POLAR(I3) = P2 - XMH**2 - POL
34842 230 CONTINUE
34843 DERIV = (POLAR(3)-POLAR(1))/EPS
34844 DRUN = - POLAR(2)/DERIV
34845 PRUN = PRUN + DRUN
34846 P2 = PRUN**2
34847 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 240
34848 GOTO 180
34849 240 CONTINUE
34850
34851 XMHP = DSQRT(P2)
34852
34853CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34854C...END OF LIGHT HIGGS
34855CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34856
34857 250 IF(IHIGGS.EQ.1) GOTO 490
34858
34859CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34860C... STARTING OF HEAVY HIGGS
34861CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34862
34863 DO 270 I = 1,2
34864 DO 260 J = 1,2
34865 HCOUPT(I,J) =
34866 & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
34867 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
34868 & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
34869 & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
34870 & T(1,J)*T(2,I))
34871 260 CONTINUE
34872 270 CONTINUE
34873
34874 DO 290 I = 1,2
34875 DO 280 J = 1,2
34876 HCOUPB(I,J) =
34877 & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
34878 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
34879 & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
34880 & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
34881 & B(1,J)*B(2,I))
34882 HCOUPB(I,J)=0D0
34883 280 CONTINUE
34884 290 CONTINUE
34885
34886 PRUN = HM
34887 EPS = 1D-4*PRUN
34888 ITER = 0
34889 300 ITER = ITER + 1
34890 DO 350 I3 = 1,3
34891 PR(I3)=PRUN+(I3-2)*EPS/2
34892 HP2=PR(I3)**2
34893
34894 HPOLT = 0D0
34895 DO 320 I = 1,2
34896 DO 310 J = 1,2
34897 HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
34898 & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
34899 310 CONTINUE
34900 320 CONTINUE
34901
34902 HPOLB = 0D0
34903 DO 340 I = 1,2
34904 DO 330 J = 1,2
34905 HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
34906 & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
34907 330 CONTINUE
34908 340 CONTINUE
34909
34910C RXMT2 = RXMT**2
34911 XMT2 = XMT**2
34912
34913 HPOLTT =
34914 & 3D0*RXMT**2/8D0/PI**2/ V **2*
34915 & SA**2/SINB**2 *
34916 & (-2D0*XMT**2+0.5D0*HP2)*
34917 & PYFINT(HP2,XMT2,XMT2)
34918
34919 HPOL = HPOLT + HPOLB + HPOLTT
34920 POLAR(I3) =HP2-HM**2-HPOL
34921 350 CONTINUE
34922 DERIV = (POLAR(3)-POLAR(1))/EPS
34923 DRUN = - POLAR(2)/DERIV
34924 PRUN = PRUN + DRUN
34925 HP2 = PRUN**2
34926 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 360
34927 GOTO 300
34928 360 CONTINUE
34929
34930
34931 370 CONTINUE
34932 HMP = HP2**0.5D0
34933
34934CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34935C... END OF HEAVY HIGGS
34936CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34937
34938 IF(IHIGGS.EQ.2) GOTO 490
34939
34940CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34941C...BEGINNING OF PSEUDOSCALAR HIGGS
34942CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34943
34944 DO 390 I = 1,2
34945 DO 380 J = 1,2
34946 ACOUPT(I,J) =
34947 & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
34948 & (T(1,I)*T(2,J) -T(1,J)*T(2,I))
34949 380 CONTINUE
34950 390 CONTINUE
34951 DO 410 I = 1,2
34952 DO 400 J = 1,2
34953 ACOUPB(I,J) =
34954 & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
34955 & (B(1,I)*B(2,J) -B(1,J)*B(2,I))
34956 400 CONTINUE
34957 410 CONTINUE
34958
34959 PRUN = XMA
34960 EPS = 1D-4*PRUN
34961 ITER = 0
34962 420 ITER = ITER + 1
34963 DO 470 I3 = 1,3
34964 PR(I3)=PRUN+(I3-2)*EPS/2
34965 AP2=PR(I3)**2
34966 APOLT = 0D0
34967 DO 440 I = 1,2
34968 DO 430 J = 1,2
34969 APOLT = APOLT + ACOUPT(I,J)**2*3D0*
34970 & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
34971 430 CONTINUE
34972 440 CONTINUE
34973 APOLB = 0D0
34974 DO 460 I = 1,2
34975 DO 450 J = 1,2
34976 APOLB = APOLB + ACOUPB(I,J)**2*3D0*
34977 & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
34978 450 CONTINUE
34979 460 CONTINUE
34980C RXMT2 = RXMT**2
34981 XMT2=XMT**2
34982 APOLTT =
34983 & 3D0*RXMT**2/8D0/PI**2/ V **2*
34984 & COSB**2/SINB**2 *
34985 & (-0.5D0*AP2)*
34986 & PYFINT(AP2,XMT2,XMT2)
34987 APOL = APOLT + APOLB + APOLTT
34988 POLAR(I3) = AP2 - XMA**2 -APOL
34989 470 CONTINUE
34990 DERIV = (POLAR(3)-POLAR(1))/EPS
34991 DRUN = - POLAR(2)/DERIV
34992 PRUN = PRUN + DRUN
34993 AP2 = PRUN**2
34994 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 480
34995 GOTO 420
34996 480 CONTINUE
34997
34998 AMP = DSQRT(AP2)
34999
35000CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35001C...END OF PSEUDOSCALAR HIGGS
35002CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35003
35004 IF(IHIGGS.EQ.3) GOTO 490
35005
35006 490 CONTINUE
35007 RETURN
35008 500 CONTINUE
35009 WRITE(MSTU(11),*) ' EXITING IN PYPOLE '
35010 WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
35011 WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
35012 WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
35013 STOP
35014 END
35015
35016C*********************************************************************
35017
35018C...PYRGHM
35019C...Auxiliary to PYPOLE.
35020
35021 SUBROUTINE PYRGHM(MCHI,MA,TANB,MQ,MUR,MD,MTOP,AU,AD,MU,
35022 * MHP,HMP,MCH,SA,CA,SAB,CAB,TANBA,MGLU,DELTAMT,DELTAMB)
35023 IMPLICIT DOUBLE PRECISION(A-H,L,M,O-Z)
35024 DIMENSION VH(2,2),M2(2,2),M2P(2,2)
35025C...Parameters.
35026 INTEGER MSTU,MSTJ
35027 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35028 SAVE /PYDAT1/
35029
35030 MZ = 91.18D0
35031 PI = PARU(1)
35032 V = 174.1D0
35033 ALPHA1 = 0.0101D0
35034 ALPHA2 = 0.0337D0
35035 ALPHA3Z = 0.12D0
35036 TANBA = TANB
35037 TANBT = TANB
35038C MBOTTOM(MTOP) = 3. GEV
35039 MB = PYMRUN(5,MTOP**2)
35040 ALPHA3 = ALPHA3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPHA3Z*
35041 *LOG(MTOP**2/MZ**2))
35042C RMTOP= RUNNING TOP QUARK MASS
35043 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
35044 TQ = LOG((MQ**2+MTOP**2)/MTOP**2)
35045 TU = LOG((MUR**2 + MTOP**2)/MTOP**2)
35046 TD = LOG((MD**2 + MTOP**2)/MTOP**2)
35047CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35048C
35049C NEW DEFINITION, TGLU.
35050C
35051CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35052 TGLU = LOG(MGLU**2/MTOP**2)
35053 SINB = TANB/DSQRT(1D0 + TANB**2)
35054 COSB = SINB/TANB
35055 IF(MA.GT.MTOP)
35056 *TANBA = TANB*(1D0-3D0/32D0/PI**2*
35057 *(RMTOP**2/V**2/SINB**2-MB**2/V**2/COSB**2)*
35058 *LOG(MA**2/MTOP**2))
35059 IF(MA.LT.MTOP.OR.MA.EQ.MTOP) TANBT = TANBA
35060 SINB = TANBT/SQRT(1D0 + TANBT**2)
35061 COSB = 1D0/DSQRT(1D0 + TANBT**2)
35062 G1 = SQRT(ALPHA1*4D0*PI)
35063 G2 = SQRT(ALPHA2*4D0*PI)
35064 G3 = SQRT(ALPHA3*4D0*PI)
35065 HU = RMTOP/V/SINB
35066 HD = MB/V/COSB
35067 CALL PYGFXX(MA,TANBA,MQ,MUR,MD,MTOP,AU,AD,MU,MGLU,VH,STOP1,STOP2,
35068 *SBOT1,SBOT2,DELTAMT,DELTAMB)
35069 IF(MQ.GT.MUR) TP = TQ - TU
35070 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TP = TU - TQ
35071 IF(MQ.GT.MUR) TDP = TU
35072 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TDP = TQ
35073 IF(MQ.GT.MD) TPD = TQ - TD
35074 IF(MQ.LT.MD.OR.MQ.EQ.MD) TPD = TD - TQ
35075 IF(MQ.GT.MD) TDPD = TD
35076 IF(MQ.LT.MD.OR.MQ.EQ.MD) TDPD = TQ
35077
35078 IF(MQ.GT.MD) DLAMBDA1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD
35079 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA1 = 3D0/32D0/PI**2*
35080 * HD**2*(G1**2/3D0+G2**2)*TPD
35081
35082 IF(MQ.GT.MUR) DLAMBDA2 =12D0/96D0/PI**2*G1**2*HU**2*TP
35083 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA2 = 3D0/32D0/PI**2*
35084 * HU**2*(-G1**2/3D0+G2**2)*TP
35085
35086CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35087C
35088C DLAMBDAP1 AND DLAMBDAP2 ARE THE NEW LOG CORRECTIONS DUE TO
35089C THE PRESENCE OF THE GLUINO MASS. THEY ARE IN GENERAL VERY SMALL,
35090C AND ONLY PRESENT IF THERE IS A HIERARCHY OF MASSES BETWEEN THE
35091C TWO STOPS.
35092C
35093C
35094CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35095
35096 DLAMBDAP2 = 0D0
35097 IF(MGLU.LT.MUR.OR.MGLU.LT.MQ) THEN
35098 IF(MQ.GT.MUR.AND.MGLU.GT.MUR) THEN
35099 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TGLU**2)
35100 ENDIF
35101
35102 IF(MQ.GT.MUR.AND.MGLU.LT.MUR) THEN
35103 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
35104 ENDIF
35105
35106 IF(MQ.GT.MUR.AND.MGLU.EQ.MUR) THEN
35107 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
35108 ENDIF
35109
35110 IF(MUR.GT.MQ.AND.MGLU.GT.MQ) THEN
35111 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TGLU**2)
35112 ENDIF
35113
35114 IF(MUR.GT.MQ.AND.MGLU.LT.MQ) THEN
35115 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
35116 ENDIF
35117
35118 IF(MUR.GT.MQ.AND.MGLU.EQ.MQ) THEN
35119 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
35120 ENDIF
35121 ENDIF
35122 DLAMBDA3 = 0D0
35123 DLAMBDA4 = 0D0
35124 IF(MQ.GT.MD) DLAMBDA3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD
35125 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA3 = 3D0/64D0/PI**2*HD**2*
35126 *(G2**2-G1**2/3D0)*TPD
35127 IF(MQ.GT.MUR) DLAMBDA3 = DLAMBDA3 -
35128 *1D0/16D0/PI**2*G1**2*HU**2*TP
35129 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA3 = DLAMBDA3 +
35130 * 3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP
35131 IF(MQ.LT.MUR) DLAMBDA4 = -3D0/32D0/PI**2*G2**2*HU**2*TP
35132 IF(MQ.LT.MD) DLAMBDA4 = DLAMBDA4 - 3D0/32D0/PI**2*G2**2*
35133 *HD**2*TPD
35134 LAMBDA1 = ((G1**2 + G2**2)/4D0)*
35135 * (1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2)
35136 *+(3D0*HD**4D0/16D0/PI**2) *TPD*(1D0
35137 *+ (3D0*HD**2/2D0 + HU**2/2D0
35138 *- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2)
35139 *+(3D0*HD**4D0/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0
35140 *- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAMBDA1
35141 LAMBDA2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2*
35142 *(TP + TDP)/8D0/PI**2)
35143 *+(3D0*HU**4D0/16D0/PI**2) *TP*(1D0
35144 *+ (3D0*HU**2/2D0 + HD**2/2D0
35145 *- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2)
35146 *+(3D0*HU**4D0/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0
35147 *- 8D0*G3**2) * TDP/16D0/PI**2) + DLAMBDA2 + DLAMBDAP2
35148 LAMBDA3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
35149 *(HU**2)*(TP + TDP)/16D0/PI**2 -3D0*
35150 *(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA3
35151 LAMBDA4 = (- G2**2/2D0)*(1D0
35152 *-3D0*(HU**2)*(TP + TDP)/16D0/PI**2
35153 *-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA4
35154
35155 LAMBDA5 = 0D0
35156 LAMBDA6 = 0D0
35157 LAMBDA7 = 0D0
35158
35159 M2(1,1) = 2D0*V**2*(LAMBDA1*COSB**2+2D0*LAMBDA6*
35160 *COSB*SINB + LAMBDA5*SINB**2) + MA**2*SINB**2
35161
35162 M2(2,2) = 2D0*V**2*(LAMBDA5*COSB**2+2D0*LAMBDA7*
35163 *COSB*SINB + LAMBDA2*SINB**2) + MA**2*COSB**2
35164 M2(1,2) = 2D0*V**2*(LAMBDA6*COSB**2+(LAMBDA3+LAMBDA4)*
35165 *COSB*SINB + LAMBDA7*SINB**2) - MA**2*SINB*COSB
35166
35167 M2(2,1) = M2(1,2)
35168CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35169CCC THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
35170CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35171
35172 MSSUSY=DSQRT(.5D0*(MQ**2+MUR**2)+MTOP**2)
35173
35174 IF(MCHI.GT.MSSUSY) GOTO 100
35175 IF(MCHI.LT.MTOP) MCHI=MTOP
35176
35177 TCHAR=LOG(MSSUSY**2/MCHI**2)
35178
35179 DELTAL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR
35180 DELTAL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4
35181 *+4D0/32D0/PI**2*G1**2*G2**2)*TCHAR
35182
35183 DELTAM112=2D0*DELTAL12*V**2*COSB**2
35184 DELTAM222=2D0*DELTAL12*V**2*SINB**2
35185 DELTAM122=2D0*DELTAL3P4*V**2*SINB*COSB
35186
35187 M2(1,1)=M2(1,1)+DELTAM112
35188 M2(2,2)=M2(2,2)+DELTAM222
35189 M2(1,2)=M2(1,2)+DELTAM122
35190 M2(2,1)=M2(2,1)+DELTAM122
35191
35192 100 CONTINUE
35193
35194CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35195CCC END OF CHARGINOS/NEUTRALINOS
35196CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35197
35198 DO 120 I = 1,2
35199 DO 110 J = 1,2
35200 M2P(I,J) = M2(I,J) + VH(I,J)
35201 110 CONTINUE
35202 120 CONTINUE
35203 TRM2P = M2P(1,1) + M2P(2,2)
35204 DETM2P = M2P(1,1)*M2P(2,2) - M2P(1,2)*M2P(2,1)
35205 MH2P = (TRM2P - DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
35206 HM2P = (TRM2P + DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
35207 HMP = DSQRT(HM2P)
35208 MCH2=MA**2+(LAMBDA5-LAMBDA4)*V**2
35209 MCH=DSQRT(MCH2)
35210 IF(MH2P.LT.0.) GOTO 130
35211 MHP = SQRT(MH2P)
35212 SIN2ALPHA = 2D0*M2P(1,2)/SQRT(TRM2P**2-4D0*DETM2P)
35213 COS2ALPHA = (M2P(1,1)-M2P(2,2))/SQRT(TRM2P**2-4D0*DETM2P)
35214 IF(COS2ALPHA.GE.0.) THEN
35215 ALPHA = ASIN(SIN2ALPHA)/2D0
35216 ELSE
35217 ALPHA = -PI/2D0-ASIN(SIN2ALPHA)/2D0
35218 ENDIF
35219 SA = SIN(ALPHA)
35220 CA = COS(ALPHA)
35221CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35222C
35223C HERE THE VALUES OF SAB AND CAB ARE DEFINED, IN ORDER
35224C TO DEFINE THE NEW COUPLINGS OF THE LIGHTEST AND
35225C HEAVY CP-EVEN HIGGS TO THE BOTTOM QUARK.
35226C
35227C
35228CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35229 SAB = SA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0+CA/SA/TANB))
35230 CAB = CA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0-SA/CA/TANB))
35231 130 CONTINUE
35232 RETURN
35233 END
35234
35235C*********************************************************************
35236
35237C...PYGFXX
35238C...Auxiliary to PYRGHM.
35239
35240 SUBROUTINE PYGFXX(MA,TANB,MQ,MUR,MD,MTOP,AT,AB,XMU,XMGL,VH,
35241 * STOP1,STOP2,SBOT1,SBOT2,DELTAMT,DELTAMB)
35242 IMPLICIT DOUBLE PRECISION(A-H,M,O-Z)
35243 DIMENSION VH(2,2),VH3T(2,2),VH3B(2,2),AL(2,2)
35244C...Commonblocks.
35245 INTEGER MSTU,MSTJ,KCHG
35246 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35247 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35248 SAVE /PYDAT1/,/PYDAT2/
35249
35250 G(X,Y) = 2.D0 - (X+Y)/(X-Y)*DLOG(X/Y)
35251
35252 T(X,Y,Z) = (X**2*Y**2*LOG(X**2/Y**2) + X**2*Z**2*LOG(Z**2/X**2)
35253 * + Y**2*Z**2*LOG(Y**2/Z**2))/((X**2-Y**2)*(Y**2-Z**2)*(X**2-Z**2))
35254
35255 IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0
35256 MQ2 = MQ**2
35257 MUR2 = MUR**2
35258 MD2 = MD**2
35259 TANBA = TANB
35260 SINBA = TANBA/DSQRT(TANBA**2+1D0)
35261 COSBA = SINBA/TANBA
35262
35263 SINB = TANB/DSQRT(TANB**2+1D0)
35264 COSB = SINB/TANB
35265
35266 PI = PARU(1)
35267 MZ = PMAS(23,1)
35268 MW = PMAS(24,1)
35269 SW = 1D0-MW**2/MZ**2
35270 V = 174.1D0
35271
35272 ALPHA3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(MTOP**2/MZ**2))
35273 G2 = DSQRT(0.0336D0*4D0*PI)
35274 G1 = DSQRT(0.0101D0*4D0*PI)
35275
35276 IF(MQ.GT.MUR) MST = MQ
35277 IF(MUR.GT.MQ.OR.MUR.EQ.MQ) MST = MUR
35278
35279 MSUSYT = DSQRT(MST**2 + MTOP**2)
35280
35281 IF(MQ.GT.MD) MSB = MQ
35282 IF(MD.GT.MQ.OR.MD.EQ.MQ) MSB = MD
35283
35284 MB = PYMRUN(5,MSB**2)
35285 MSUSYB = DSQRT(MSB**2 + MB**2)
35286 TT = LOG(MSUSYT**2/MTOP**2)
35287 TB = LOG(MSUSYB**2/MTOP**2)
35288
35289 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
35290 HT = RMTOP/(V*SINB)
35291 HTST = RMTOP/V
35292 HB = MB/V/COSB
35293 G32 = ALPHA3*4D0*PI
35294 BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2
35295 BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2
35296 AL2 = 3D0/8D0/PI**2*HT**2
35297C BT2ST = -(8.*G32 - 9.*HTST**2/2.)/(4.*PI)**2
35298C ALST = 3./8./PI**2*HTST**2
35299 AL1 = 3D0/8D0/PI**2*HB**2
35300
35301 AL(1,1) = AL1
35302 AL(1,2) = (AL2+AL1)/2D0
35303 AL(2,1) = (AL2+AL1)/2D0
35304 AL(2,2) = AL2
35305
35306 IF(MA.GT.MTOP) THEN
35307 VI = V*(1D0 + 3D0/32D0/PI**2*HTST**2*
35308 * LOG(MTOP**2/MA**2))
35309 H1I = VI* COSBA
35310 H2I = VI*SINBA
35311 H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYT**2))**.25D0
35312 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYT**2))**.25D0
35313 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYB**2))**.25D0
35314 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYB**2))**.25D0
35315 ELSE
35316 VI = V
35317 H1I = VI*COSB
35318 H2I = VI*SINB
35319 H1T=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYT**2))**.25D0
35320 H2T=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYT**2))**.25D0
35321 H1B=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYB**2))**.25D0
35322 H2B=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYB**2))**.25D0
35323 ENDIF
35324
35325 TANBST = H2T/H1T
35326 SINBT = TANBST/DSQRT(1D0+TANBST**2)
35327
35328 TANBSB = H2B/H1B
35329 SINBB = TANBSB/DSQRT(1D0+TANBSB**2)
35330 COSBB = SINBB/TANBSB
35331
35332 DELTAMT = 0D0
35333 DELTAMB = 0D0
35334
35335 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
35336 MTOP2 = DSQRT(MTOP4)
35337 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
35338 * /(1D0+DELTAMB)**4
35339 MBOT2 = DSQRT(MBOT4)
35340
35341 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
35342 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
35343 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
35344 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
35345 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
35346 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
35347 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
35348 * MQ2 - MUR2)**2*0.25D0
35349 * + MTOP2*(AT-XMU/TANBST)**2)
35350 IF(STOP22.LT.0.) GOTO 120
35351 SBOT12 = (MQ2 + MD2)*.5D0
35352 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
35353 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
35354 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
35355 SBOT22 = (MQ2 + MD2)*.5D0
35356 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
35357 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
35358 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
35359 IF(SBOT22.LT.0.) SBOT22 = 10000D0
35360
35361 STOP1 = DSQRT(STOP12)
35362 STOP2 = DSQRT(STOP22)
35363 SBOT1 = DSQRT(SBOT12)
35364 SBOT2 = DSQRT(SBOT22)
35365
35366CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35367C
35368C HERE IS THE DEFINITION OF DELTAMB AND DELTAMT, WHICH
35369C ARE THE VERTEX CORRECTIONS TO THE BOTTOM AND TOP QUARK
35370C MASS, KEEPING THE DOMINANT QCD AND TOP YUKAWA COUPLING
35371C INDUCED CORRECTIONS.
35372C
35373CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35374
35375 X=SBOT1
35376 Y=SBOT2
35377 Z=XMGL
35378 IF(X.EQ.Y) X = X - 0.00001D0
35379 IF(X.EQ.Z) X = X - 0.00002D0
35380 IF(Y.EQ.Z) Y = Y - 0.00003D0
35381
35382 T1=T(X,Y,Z)
35383 X=STOP1
35384 Y=STOP2
35385 Z=XMU
35386 IF(X.EQ.Y) X = X - 0.00001D0
35387 IF(X.EQ.Z) X = X - 0.00002D0
35388 IF(Y.EQ.Z) Y = Y - 0.00003D0
35389 T2=T(X,Y,Z)
35390 DELTAMB = -2*ALPHA3/3D0/PI*XMGL*(AB-XMU*TANB)*T1
35391 * + HT**2/(4D0*PI)**2*(AT-XMU/TANB)*XMU*TANB*T2
35392 X=STOP1
35393 Y=STOP2
35394 Z=XMGL
35395 IF(X.EQ.Y) X = X - 0.00001D0
35396 IF(X.EQ.Z) X = X - 0.00002D0
35397 IF(Y.EQ.Z) Y = Y - 0.00003D0
35398 T3=T(X,Y,Z)
35399 DELTAMT = -2D0*ALPHA3/3D0/PI*(AT-XMU/TANB)*XMGL*T3
35400
35401CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35402C
35403C HERE THE NEW VALUES OF THE TOP AND BOTTOM QUARK MASSES AT
35404C THE SCALE MS ARE DEFINED, TO BE USED IN THE EFFECTIVE
35405C POTENTIAL APPROXIMATION. THEY ARE JUST THE OLD ONES, BUT
35406C INCLUDING THE FINITE CORRECTIONS DELTAMT AND DELTAMB.
35407C THE DELTAMB CORRECTIONS CAN BECOME LARGE AND ARE RESUMMED
35408C TO ALL ORDERS, AS SUGGESTED IN THE TWO RECENT WORKS BY M. CARENA,
35409C S. MRENNA AND C.E.M. WAGNER, AS WELL AS IN THE WORK BY M. CARENA,
35410C D. GARCIA, U. NIERSTE AND C.E.M. WAGNER, TO APPEAR. THE TOP
35411C QUARK MASS CORRECTIONS ARE SMALL AND ARE KEPT IN THE PERTURBATIVE
35412C FORMULATION. THE FUNCTION T(X,Y,Z) IS NECESSARY FOR THE
35413C CALCULATION. THE ENTRIES ARE MASSES AND NOT THEIR SQUARES !
35414C
35415C
35416CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35417
35418 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
35419 MTOP2 = DSQRT(MTOP4)
35420 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
35421 * /(1D0+DELTAMB)**4
35422 MBOT2 = DSQRT(MBOT4)
35423
35424 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
35425 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
35426 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
35427 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
35428 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
35429 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
35430 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
35431 * MQ2 - MUR2)**2*0.25D0
35432 * + MTOP2*(AT-XMU/TANBST)**2)
35433
35434 IF(STOP22.LT.0.) GOTO 120
35435 SBOT12 = (MQ2 + MD2)*.5D0
35436 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
35437 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
35438 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
35439 SBOT22 = (MQ2 + MD2)*.5D0
35440 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
35441 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
35442 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
35443 IF(SBOT22.LT.0.) GOTO 120
35444
35445
35446 STOP1 = DSQRT(STOP12)
35447 STOP2 = DSQRT(STOP22)
35448 SBOT1 = DSQRT(SBOT12)
35449 SBOT2 = DSQRT(SBOT22)
35450
35451CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35452CCC D-TERMS
35453CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35454 STW=SW
35455
35456 F1T=(MQ2-MUR2)/(STOP12-STOP22)*(.5D0-4D0/3D0*STW)*
35457 * LOG(STOP1/STOP2)
35458 * +(.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(MQ2+MTOP2))
35459 * + 2D0/3D0*STW*LOG(STOP1*STOP2/(MUR2+MTOP2))
35460
35461 F1B=(MQ2-MD2)/(SBOT12-SBOT22)*(-.5D0+2D0/3D0*STW)*
35462 * LOG(SBOT1/SBOT2)
35463 * +(-.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(MQ2+MBOT2))
35464 * - 1D0/3D0*STW*LOG(SBOT1*SBOT2/(MD2+MBOT2))
35465
35466 F2T=DSQRT(MTOP2)*(AT-XMU/TANBST)/(STOP12-STOP22)*
35467 * (-.5D0*LOG(STOP12/STOP22)
35468 * +(4D0/3D0*STW-.5D0)*(MQ2-MUR2)/(STOP12-STOP22)*
35469 * G(STOP12,STOP22))
35470
35471 F2B=DSQRT(MBOT2)*(AB-XMU*TANBSB)/(SBOT12-SBOT22)*
35472 * (.5D0*LOG(SBOT12/SBOT22)
35473 * +(-2D0/3D0*STW+.5D0)*(MQ2-MD2)/(SBOT12-SBOT22)*
35474 * G(SBOT12,SBOT22))
35475
35476 VH3B(1,1) = MBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/
35477 * (MQ2+MBOT2)/(MD2+MBOT2))
35478 * + 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))*
35479 * LOG(SBOT1**2/SBOT2**2)) +
35480 * MBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/
35481 * (SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22)
35482
35483 VH3T(1,1) =
35484 * MTOP4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2
35485 * -STOP2**2))**2*G(STOP12,STOP22)
35486
35487 VH3B(1,1)=VH3B(1,1)+
35488 * MZ**2*(2*MBOT2*F1B-DSQRT(MBOT2)*AB*F2B)
35489
35490 VH3T(1,1) = VH3T(1,1) +
35491 * MZ**2*(DSQRT(MTOP2)*XMU/TANBST*F2T)
35492
35493 VH3T(2,2) = MTOP4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/
35494 * (MQ2+MTOP2)/(MUR2+MTOP2))
35495 * + 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))*
35496 * LOG(STOP1**2/STOP2**2)) +
35497 * MTOP4/(SINBT**2)*(AT*(AT-XMU/TANBST)/
35498 * (STOP1**2-STOP2**2))**2*G(STOP12,STOP22)
35499
35500 VH3B(2,2) =
35501 * MBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2
35502 * -SBOT2**2))**2*G(SBOT12,SBOT22)
35503
35504 VH3T(2,2)=VH3T(2,2)+
35505 * MZ**2*(-2*MTOP2*F1T+DSQRT(MTOP2)*AT*F2T)
35506 VH3B(2,2) = VH3B(2,2) -MZ**2*DSQRT(MBOT2)*XMU*TANBSB*F2B
35507 VH3T(1,2) = -
35508 * MTOP4/(SINBT**2)*XMU*(AT-XMU/TANBST)/
35509 * (STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT*
35510 * (AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22))
35511
35512 VH3B(1,2) =
35513 * - MBOT4/(COSBB**2)*XMU*(AB-XMU*TANBSB)/
35514 * (SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB*
35515 * (AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22))
35516
35517
35518 VH3T(1,2)=VH3T(1,2) +
35519 *MZ**2*(MTOP2/TANBST*F1T-DSQRT(MTOP2)*(AT/TANBST+XMU)/2D0*F2T)
35520
35521 VH3B(1,2)=VH3B(1,2) +
35522 *MZ**2*(-MBOT2*TANBSB*F1B+DSQRT(MBOT2)*(AB*TANBSB+XMU)/2D0*F2B)
35523
35524 VH3T(2,1) = VH3T(1,2)
35525 VH3B(2,1) = VH3B(1,2)
35526
35527C TQ = LOG((MQ2 + MTOP2)/MTOP2)
35528C TU = LOG((MUR2+MTOP2)/MTOP2)
35529C TQD = LOG((MQ2 + MB**2)/MB**2)
35530C TD = LOG((MD2+MB**2)/MB**2)
35531
35532 DO 110 I = 1,2
35533 DO 100 J = 1,2
35534 VH(I,J) =
35535 * 6D0/(8D0*PI**2*(H1T**2+H2T**2))
35536 * *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) +
35537 * 6D0/(8D0*PI**2*(H1B**2+H2B**2))
35538 * *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0)
35539 100 CONTINUE
35540 110 CONTINUE
35541
35542 GOTO 150
35543 120 DO 140 I =1,2
35544 DO 130 J = 1,2
35545 VH(I,J) = -1D15
35546 130 CONTINUE
35547 140 CONTINUE
35548
35549
35550 150 RETURN
35551 END
35552
35553
35554
35555
35556
35557C*********************************************************************
35558
35559C...PYFINT
35560C...Auxiliary routine to PYPOLE for SUSY Higgs calculations.
35561
35562 FUNCTION PYFINT(A,B,C)
35563
35564C...Double precision and integer declarations.
35565 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35566 IMPLICIT INTEGER(I-N)
35567 INTEGER PYK,PYCHGE,PYCOMP
35568C...Commonblock.
35569 COMMON/PYINTS/XXM(20)
35570 SAVE/PYINTS/
35571
35572C...Local variables.
35573 EXTERNAL PYFISB
35574 DOUBLE PRECISION PYFISB
35575
35576 XXM(1)=A
35577 XXM(2)=B
35578 XXM(3)=C
35579 XLO=0D0
35580 XHI=1D0
35581 PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3)
35582
35583 RETURN
35584 END
35585
35586C*********************************************************************
35587
35588C...PYFISB
35589C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
35590
35591 FUNCTION PYFISB(X)
35592
35593C...Double precision and integer declarations.
35594 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35595 IMPLICIT INTEGER(I-N)
35596 INTEGER PYK,PYCHGE,PYCOMP
35597C...Commonblock.
35598 COMMON/PYINTS/XXM(20)
35599 SAVE/PYINTS/
35600
35601 PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/
35602 &(X*(XXM(2)-XXM(3))+XXM(3)))
35603
35604 RETURN
35605 END
35606
35607C*********************************************************************
35608
35609C...PYSFDC
35610C...Calculates decays of sfermions.
35611
35612 SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT)
35613
35614C...Double precision and integer declarations.
35615 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35616 IMPLICIT INTEGER(I-N)
35617 INTEGER PYK,PYCHGE,PYCOMP
35618C...Parameter statement to help give large particle numbers.
35619 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
35620 &KEXCIT=4000000,KDIMEN=5000000)
35621C...Commonblocks.
35622 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35623 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35624 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
35625 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
35626 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
35627 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
35628
35629C...Local variables.
35630 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2)
35631 COMPLEX*16 CAL,CAR,CBL,CBR,CALP,CARP,CBLP,CBRP,CA,CB
35632 INTEGER KFIN,KCIN
35633 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,AXMJ
35634 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
35635 DOUBLE PRECISION PYLAMF,XL
35636 DOUBLE PRECISION TANW,XW,AEM,C1,AS
35637 DOUBLE PRECISION AL,AR,BL,BR
35638 DOUBLE PRECISION CH1,CH2,CH3,CH4
35639 DOUBLE PRECISION XMBOT,XMTOP
35640 DOUBLE PRECISION XLAM(0:400)
35641 INTEGER IDLAM(400,3)
35642 INTEGER LKNT,IX,ILR,IDU,J,I,IKNT,IFL,II
35643 DOUBLE PRECISION SR2
35644 DOUBLE PRECISION CBETA,SBETA
35645 DOUBLE PRECISION CW
35646 DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
35647 DOUBLE PRECISION COSA,SINA,TANB
35648 DOUBLE PRECISION PYALEM,PI,PYALPS,EI
35649 DOUBLE PRECISION GHRR,GHLL,GHLR,XMB,BLR
35650 INTEGER IG,KF1,KF2
35651 INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
35652 DATA IGG/23,25,35,36/
35653 DATA PI/3.141592654D0/
35654 DATA SR2/1.4142136D0/
35655 DATA KFNCHI/1000022,1000023,1000025,1000035/
35656 DATA KFCCHI/1000024,1000037/
35657
35658C...COUNT THE NUMBER OF DECAY MODES
35659 LKNT=0
35660
35661C...NO NU_R DECAYS
35662 IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR.
35663 &KFIN.EQ.KSUSY2+16) RETURN
35664
35665 XMW=PMAS(24,1)
35666 XMW2=XMW**2
35667 XMZ=PMAS(23,1)
35668 XW=PARU(102)
35669 TANW = SQRT(XW/(1D0-XW))
35670 CW=SQRT(1D0-XW)
35671
35672 DO 110 I=1,4
35673 DO 100 J=1,4
35674 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
35675 100 CONTINUE
35676 110 CONTINUE
35677 DO 130 I=1,2
35678 DO 120 J=1,2
35679 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
35680 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
35681 120 CONTINUE
35682 130 CONTINUE
35683
35684C...KCIN
35685 KCIN=PYCOMP(KFIN)
35686C...ILR is 1 for left and 2 for right.
35687 ILR=KFIN/KSUSY1
35688C...IFL is matching non-SUSY flavour.
35689 IFL=MOD(KFIN,KSUSY1)
35690C...IDU is weak isospin, 1 for down and 2 for up.
35691 IDU=2-MOD(IFL,2)
35692
35693 XMI=PMAS(KCIN,1)
35694 XMI2=XMI**2
35695 AEM=PYALEM(XMI2)
35696 AS =PYALPS(XMI2)
35697 C1=AEM/XW
35698 XMI3=XMI**3
35699 EI=KCHG(IFL,1)/3D0
35700
35701 XMBOT=PYMRUN(5,XMI2)
35702 XMTOP=PYMRUN(6,XMI2)
35703
35704 TANB=RMSS(5)
35705 BETA=ATAN(TANB)
35706 ALFA=RMSS(18)
35707 CBETA=COS(BETA)
35708 SBETA=TANB*CBETA
35709 SINA=SIN(ALFA)
35710 COSA=COS(ALFA)
35711 XMU=-RMSS(4)
35712 ATRIT=RMSS(16)
35713 ATRIB=RMSS(15)
35714 ATRIL=RMSS(17)
35715
35716C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
35717
35718 IF(IMSS(11).EQ.1) THEN
35719 XMP=RMSS(29)
35720 IDG=39+KSUSY1
35721 XMGR=PMAS(PYCOMP(IDG),1)
35722 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
35723 IF(IFL.EQ.5) THEN
35724 XMF=XMBOT
35725 ELSEIF(IFL.EQ.6) THEN
35726 XMF=XMTOP
35727 ELSE
35728 XMF=PMAS(IFL,1)
35729 ENDIF
35730 IF(XMI.GT.XMGR+XMF) THEN
35731 LKNT=LKNT+1
35732 IDLAM(LKNT,1)=IDG
35733 IDLAM(LKNT,2)=IFL
35734 IDLAM(LKNT,3)=0
35735 XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4
35736 ENDIF
35737 ENDIF
35738
35739C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
35740
35741C...CHARGED DECAYS:
35742 DO 140 IX=1,2
35743C...DI -> U CHI1-,CHI2-
35744 IF(IDU.EQ.1) THEN
35745 XMFP=PMAS(IFL+1,1)
35746 XMF =PMAS(IFL,1)
35747C...UI -> D CHI1+,CHI2+
35748 ELSE
35749 XMFP=PMAS(IFL-1,1)
35750 XMF =PMAS(IFL,1)
35751 ENDIF
35752 XMJ=SMW(IX)
35753 AXMJ=ABS(XMJ)
35754 IF(XMI.GE.AXMJ+XMFP) THEN
35755 XMA2=XMJ**2
35756 XMB2=XMFP**2
35757 IF(IDU.EQ.2) THEN
35758 IF(IFL.EQ.6) THEN
35759 XMFP=XMBOT
35760 XMF =XMTOP
35761 ELSEIF(IFL.LT.6) THEN
35762 XMF=0D0
35763 XMFP=0D0
35764 ENDIF
35765 CBL=VMIXC(IX,1)
35766 CAL=-XMFP*UMIXC(IX,2)/SR2/XMW/CBETA
35767 CBR=-XMF*VMIXC(IX,2)/SR2/XMW/SBETA
35768 CAR=0D0
35769 ELSE
35770 IF(IFL.EQ.5) THEN
35771 XMF =XMBOT
35772 XMFP=XMTOP
35773 ELSEIF(IFL.LT.5) THEN
35774 XMF=0D0
35775 XMFP=0D0
35776 ENDIF
35777 CBL=UMIXC(IX,1)
35778 CAL=-XMFP*VMIXC(IX,2)/SR2/XMW/SBETA
35779 CBR=-XMF*UMIXC(IX,2)/SR2/XMW/CBETA
35780 CAR=0D0
35781 ENDIF
35782
35783 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
35784 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
35785 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
35786 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
35787 CAL=CALP
35788 CBL=CBLP
35789 CAR=CARP
35790 CBR=CBRP
35791
35792C...F1 -> F` CHI
35793 IF(ILR.EQ.1) THEN
35794 CA=CAL
35795 CB=CBL
35796C...F2 -> F` CHI
35797 ELSE
35798 CA=CAR
35799 CB=CBR
35800 ENDIF
35801 LKNT=LKNT+1
35802 XL=PYLAMF(XMI2,XMA2,XMB2)
35803C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
35804 XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
35805 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMFP)
35806 IDLAM(LKNT,3)=0
35807 IF(IDU.EQ.1) THEN
35808 IDLAM(LKNT,1)=-KFCCHI(IX)
35809 IDLAM(LKNT,2)=IFL+1
35810 ELSE
35811 IDLAM(LKNT,1)=KFCCHI(IX)
35812 IDLAM(LKNT,2)=IFL-1
35813 ENDIF
35814 ENDIF
35815 140 CONTINUE
35816
35817C...NEUTRAL DECAYS
35818 DO 150 IX=1,4
35819C...DI -> D CHI10
35820 XMF=PMAS(IFL,1)
35821 XMJ=SMZ(IX)
35822 AXMJ=ABS(XMJ)
35823 IF(XMI.GE.AXMJ+XMF) THEN
35824 XMA2=XMJ**2
35825 XMB2=XMF**2
35826 IF(IDU.EQ.1) THEN
35827 IF(IFL.EQ.5) THEN
35828 XMF=XMBOT
35829 ELSEIF(IFL.LT.5) THEN
35830 XMF=0D0
35831 ENDIF
35832 CBL=-ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI+1)
35833 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
35834 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
35835 CBR=CAL
35836 ELSE
35837 IF(IFL.EQ.6) THEN
35838 XMF=XMTOP
35839 ELSEIF(IFL.LT.5) THEN
35840 XMF=0D0
35841 ENDIF
35842 CBL=ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-1)
35843 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
35844 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
35845 CBR=CAL
35846 ENDIF
35847
35848 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
35849 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
35850 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
35851 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
35852 CAL=CALP
35853 CBL=CBLP
35854 CAR=CARP
35855 CBR=CBRP
35856
35857C...F1 -> F CHI
35858 IF(ILR.EQ.1) THEN
35859 CA=CAL
35860 CB=CBL
35861C...F2 -> F CHI
35862 ELSE
35863 CA=CAR
35864 CB=CBR
35865 ENDIF
35866 LKNT=LKNT+1
35867 XL=PYLAMF(XMI2,XMA2,XMB2)
35868C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
35869 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
35870 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMF)
35871 IDLAM(LKNT,1)=KFNCHI(IX)
35872 IDLAM(LKNT,2)=IFL
35873 IDLAM(LKNT,3)=0
35874 ENDIF
35875 150 CONTINUE
35876
35877C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
35878C...IG=23,25,35,36
35879 DO 160 II=1,4
35880 IG=IGG(II)
35881 IF(ILR.EQ.1) GOTO 160
35882 XMB=PMAS(IG,1)
35883 XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1)
35884 IF(XMI.LT.XMSF1+XMB) GOTO 160
35885 IF(IG.EQ.23) THEN
35886 BL=-SIGN(.5D0,EI)/CW+EI*XW/CW
35887 BR=EI*XW/CW
35888 BLR=0D0
35889 ELSEIF(IG.EQ.25) THEN
35890 IF(IFL.EQ.5) THEN
35891 XMF=XMBOT
35892 ELSEIF(IFL.EQ.6) THEN
35893 XMF=XMTOP
35894 ELSEIF(IFL.LT.5) THEN
35895 XMF=0D0
35896 ELSE
35897 XMF=PMAS(IFL,1)
35898 ENDIF
35899 IF(IDU.EQ.2) THEN
35900 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
35901 & XMF**2/XMW*COSA/SBETA
35902 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
35903 & XMF**2/XMW*COSA/SBETA
35904 ELSE
35905 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
35906 & XMF**2/XMW*(-SINA)/CBETA
35907 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
35908 & XMF**2/XMW*(-SINA)/CBETA
35909 ENDIF
35910 IF(IFL.EQ.5) THEN
35911 AT=ATRIB
35912 ELSEIF(IFL.EQ.6) THEN
35913 AT=ATRIT
35914 ELSEIF(IFL.EQ.15) THEN
35915 AT=ATRIL
35916 ELSE
35917 AT=0D0
35918 ENDIF
35919C.........need to complexify
35920 IF(IDU.EQ.2) THEN
35921 GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+
35922 & AT*COSA)
35923 ELSE
35924 GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA-
35925 & AT*SINA)
35926 ENDIF
35927 BL=GHLL
35928 BR=GHRR
35929 BLR=-GHLR
35930 ELSEIF(IG.EQ.35) THEN
35931 IF(IFL.EQ.5) THEN
35932 XMF=XMBOT
35933 ELSEIF(IFL.EQ.6) THEN
35934 XMF=XMTOP
35935 ELSEIF(IFL.LT.5) THEN
35936 XMF=0D0
35937 ELSE
35938 XMF=PMAS(IFL,1)
35939 ENDIF
35940 IF(IDU.EQ.2) THEN
35941 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
35942 & XMF**2/XMW*SINA/SBETA
35943 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
35944 & XMF**2/XMW*SINA/SBETA
35945 ELSE
35946 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
35947 & XMF**2/XMW*COSA/CBETA
35948 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
35949 & XMF**2/XMW*COSA/CBETA
35950 ENDIF
35951 IF(IFL.EQ.5) THEN
35952 AT=ATRIB
35953 ELSEIF(IFL.EQ.6) THEN
35954 AT=ATRIT
35955 ELSEIF(IFL.EQ.15) THEN
35956 AT=ATRIL
35957 ELSE
35958 AT=0D0
35959 ENDIF
35960C.........Need to complexify
35961 IF(IDU.EQ.2) THEN
35962 GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+
35963 & AT*SINA)
35964 ELSE
35965 GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+
35966 & AT*COSA)
35967 ENDIF
35968 BL=GHLL
35969 BR=GHRR
35970 BLR=GHLR
35971 ELSEIF(IG.EQ.36) THEN
35972 GHLL=0D0
35973 GHRR=0D0
35974 IF(IFL.EQ.5) THEN
35975 XMF=XMBOT
35976 ELSEIF(IFL.EQ.6) THEN
35977 XMF=XMTOP
35978 ELSEIF(IFL.LT.5) THEN
35979 XMF=0D0
35980 ELSE
35981 XMF=PMAS(IFL,1)
35982 ENDIF
35983 IF(IFL.EQ.5) THEN
35984 AT=ATRIB
35985 ELSEIF(IFL.EQ.6) THEN
35986 AT=ATRIT
35987 ELSEIF(IFL.EQ.15) THEN
35988 AT=ATRIL
35989 ELSE
35990 AT=0D0
35991 ENDIF
35992C.........Need to complexify
35993 IF(IDU.EQ.2) THEN
35994 GHLR=XMF/2D0/XMW*(-XMU+AT/TANB)
35995 ELSE
35996 GHLR=XMF/2D0/XMW/(-XMU+AT*TANB)
35997 ENDIF
35998 BL=GHLL
35999 BR=GHRR
36000 BLR=GHLR
36001 ENDIF
36002 AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+
36003 & SFMIX(IFL,2)*SFMIX(IFL,4)*BR+
36004 & (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR
36005 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
36006 LKNT=LKNT+1
36007 IF(IG.EQ.23) THEN
36008 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
36009 ELSE
36010 XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2
36011 ENDIF
36012 IDLAM(LKNT,3)=0
36013 IDLAM(LKNT,1)=KFIN-KSUSY1
36014 IDLAM(LKNT,2)=IG
36015 160 CONTINUE
36016
36017C...SF -> SF' + W
36018 XMB=PMAS(24,1)
36019 IF(MOD(IFL,2).EQ.0) THEN
36020 KF1=KSUSY1+IFL-1
36021 ELSE
36022 KF1=KSUSY1+IFL+1
36023 ENDIF
36024 KF2=KF1+KSUSY1
36025 XMSF1=PMAS(PYCOMP(KF1),1)
36026 XMSF2=PMAS(PYCOMP(KF2),1)
36027 IF(XMI.GT.XMB+XMSF1) THEN
36028 IF(MOD(IFL,2).EQ.0) THEN
36029 IF(ILR.EQ.1) THEN
36030 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1)
36031 ELSE
36032 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1)
36033 ENDIF
36034 ELSE
36035 IF(ILR.EQ.1) THEN
36036 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1)
36037 ELSE
36038 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1)
36039 ENDIF
36040 ENDIF
36041 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
36042 LKNT=LKNT+1
36043 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
36044 IDLAM(LKNT,3)=0
36045 IDLAM(LKNT,1)=KF1
36046 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
36047 ENDIF
36048 IF(XMI.GT.XMB+XMSF2) THEN
36049 IF(MOD(IFL,2).EQ.0) THEN
36050 IF(ILR.EQ.1) THEN
36051 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3)
36052 ELSE
36053 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3)
36054 ENDIF
36055 ELSE
36056 IF(ILR.EQ.1) THEN
36057 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3)
36058 ELSE
36059 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3)
36060 ENDIF
36061 ENDIF
36062 XL=PYLAMF(XMI2,XMSF2**2,XMB**2)
36063 LKNT=LKNT+1
36064 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
36065 IDLAM(LKNT,3)=0
36066 IDLAM(LKNT,1)=KF2
36067 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
36068 ENDIF
36069
36070C...SF -> SF' + HC
36071 XMB=PMAS(37,1)
36072 IF(MOD(IFL,2).EQ.0) THEN
36073 KF1=KSUSY1+IFL-1
36074 ELSE
36075 KF1=KSUSY1+IFL+1
36076 ENDIF
36077 KF2=KF1+KSUSY1
36078 XMSF1=PMAS(PYCOMP(KF1),1)
36079 XMSF2=PMAS(PYCOMP(KF2),1)
36080 IF(XMI.GT.XMB+XMSF1) THEN
36081 XMF=0D0
36082 XMFP=0D0
36083 AT=0D0
36084 AB=0D0
36085 IF(MOD(IFL,2).EQ.0) THEN
36086C...T1-> B1 HC
36087 IF(ILR.EQ.1) THEN
36088 CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1)
36089 CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2)
36090 CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2)
36091 CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1)
36092C...T2-> B1 HC
36093 ELSE
36094 CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1)
36095 CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2)
36096 CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2)
36097 CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1)
36098 ENDIF
36099 IF(IFL.EQ.6) THEN
36100 XMF=XMTOP
36101 XMFP=XMBOT
36102 AT=ATRIT
36103 AB=ATRIB
36104 ENDIF
36105 ELSE
36106C...B1 -> T1 HC
36107 IF(ILR.EQ.1) THEN
36108 CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1)
36109 CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2)
36110 CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2)
36111 CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1)
36112C...B2-> T1 HC
36113 ELSE
36114 CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1)
36115 CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2)
36116 CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1)
36117 CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2)
36118 ENDIF
36119 IF(IFL.EQ.5) THEN
36120 XMF=XMTOP
36121 XMFP=XMBOT
36122 AT=ATRIT
36123 AB=ATRIB
36124 ENDIF
36125 ENDIF
36126 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
36127 LKNT=LKNT+1
36128C.......Need to complexify
36129 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
36130 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
36131 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
36132 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
36133 IDLAM(LKNT,3)=0
36134 IDLAM(LKNT,1)=KF1
36135 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
36136 ENDIF
36137 IF(XMI.GT.XMB+XMSF2) THEN
36138 XMF=0D0
36139 XMFP=0D0
36140 AT=0D0
36141 AB=0D0
36142 IF(MOD(IFL,2).EQ.0) THEN
36143C...T1-> B2 HC
36144 IF(ILR.EQ.1) THEN
36145 CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1)
36146 CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2)
36147 CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1)
36148 CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2)
36149C...T2-> B2 HC
36150 ELSE
36151 CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3)
36152 CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4)
36153 CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4)
36154 CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3)
36155 ENDIF
36156 IF(IFL.EQ.6) THEN
36157 XMF=XMTOP
36158 XMFP=XMBOT
36159 AT=ATRIT
36160 AB=ATRIB
36161 ENDIF
36162 ELSE
36163C...B1 -> T2 HC
36164 IF(ILR.EQ.1) THEN
36165 CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1)
36166 CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2)
36167 CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2)
36168 CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1)
36169C...B2-> T2 HC
36170 ELSE
36171 CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3)
36172 CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4)
36173 CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4)
36174 CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3)
36175 ENDIF
36176 IF(IFL.EQ.5) THEN
36177 XMF=XMTOP
36178 XMFP=XMBOT
36179 AT=ATRIT
36180 AB=ATRIB
36181 ENDIF
36182 ENDIF
36183 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
36184 LKNT=LKNT+1
36185C.......Need to complexify
36186 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
36187 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
36188 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
36189 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
36190 IDLAM(LKNT,3)=0
36191 IDLAM(LKNT,1)=KF2
36192 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
36193 ENDIF
36194
36195C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
36196
36197 IF(IFL.LE.6) THEN
36198 XMFP=0D0
36199 XMF=0D0
36200 IF(IFL.EQ.6) XMF=PMAS(6,1)
36201 IF(IFL.EQ.5) XMF=PMAS(5,1)
36202 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
36203 AXMJ=ABS(XMJ)
36204 IF(XMI.GE.AXMJ+XMF) THEN
36205 AL=-SFMIX(IFL,3)
36206 BL=SFMIX(IFL,1)
36207 AR=-SFMIX(IFL,4)
36208 BR=SFMIX(IFL,2)
36209C...F1 -> F CHI
36210 IF(ILR.EQ.1) THEN
36211 XCA=AL
36212 XCB=BL
36213C...F2 -> F CHI
36214 ELSE
36215 XCA=AR
36216 XCB=BR
36217 ENDIF
36218 LKNT=LKNT+1
36219 XMA2=XMJ**2
36220 XMB2=XMF**2
36221 XL=PYLAMF(XMI2,XMA2,XMB2)
36222 XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
36223 & (XCA**2+XCB**2)+4D0*XCA*XCB*XMJ*XMF)
36224 IDLAM(LKNT,1)=KSUSY1+21
36225 IDLAM(LKNT,2)=IFL
36226 IDLAM(LKNT,3)=0
36227 ENDIF
36228 ENDIF
36229
36230C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
36231 IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT.
36232 &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN
36233C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
36234C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
36235C...M*M = C1**2 * G**2/(16PI**2)
36236C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
36237 LKNT=LKNT+1
36238 XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
36239 XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL)
36240 IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3
36241 IDLAM(LKNT,1)=KSUSY1+22
36242 IDLAM(LKNT,2)=4
36243 IDLAM(LKNT,3)=0
36244 ENDIF
36245
36246C...R-violating sfermion decays (SKANDS).
36247 CALL PYRVSF(KFIN,XLAM,IDLAM,LKNT)
36248
36249 IKNT=LKNT
36250 XLAM(0)=0D0
36251 DO 170 I=1,IKNT
36252 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
36253 XLAM(0)=XLAM(0)+XLAM(I)
36254 170 CONTINUE
36255 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3
36256
36257 RETURN
36258 END
36259
36260C*********************************************************************
36261
36262C...PYGLUI
36263C...Calculates gluino decay modes.
36264
36265 SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT)
36266
36267C...Double precision and integer declarations.
36268 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36269 IMPLICIT INTEGER(I-N)
36270 INTEGER PYK,PYCHGE,PYCOMP
36271C...Parameter statement to help give large particle numbers.
36272 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
36273 &KEXCIT=4000000,KDIMEN=5000000)
36274C...Commonblocks.
36275 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36276 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36277 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
36278 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
36279 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
36280CC &SFMIX(16,4),
36281C COMMON/PYINTS/XXM(20)
36282 COMPLEX*16 CXC
36283 COMMON/PYINTC/XXC(10),CXC(8)
36284 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
36285
36286C...Local variables
36287 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
36288 DOUBLE PRECISION XMI,XMJ,XMF,AXMJ,AXMI
36289 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
36290 DOUBLE PRECISION PYLAMF,XL
36291 DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
36292 DOUBLE PRECISION CA,CB,AL,AR,BL,BR
36293 DOUBLE PRECISION XLAM(0:400)
36294 INTEGER IDLAM(400,3)
36295 INTEGER LKNT,IX,ILR,I,IKNT,IFL
36296 DOUBLE PRECISION SR2
36297 DOUBLE PRECISION GAM
36298 DOUBLE PRECISION PYALEM,PI,PYALPS,EI,T3I
36299 EXTERNAL PYGAUS,PYXXZ6
36300 DOUBLE PRECISION PYGAUS,PYXXZ6
36301 DOUBLE PRECISION PREC
36302 INTEGER KFNCHI(4),KFCCHI(2)
36303 DATA PI/3.141592654D0/
36304 DATA SR2/1.4142136D0/
36305 DATA PREC/1D-2/
36306 DATA KFNCHI/1000022,1000023,1000025,1000035/
36307 DATA KFCCHI/1000024,1000037/
36308
36309C...COUNT THE NUMBER OF DECAY MODES
36310 LKNT=0
36311 IF(KFIN.NE.KSUSY1+21) RETURN
36312 KCIN=PYCOMP(KFIN)
36313
36314 XW=PARU(102)
36315 TANW = SQRT(XW/(1D0-XW))
36316
36317 XMI=PMAS(KCIN,1)
36318 AXMI=ABS(XMI)
36319 XMI2=XMI**2
36320 AEM=PYALEM(XMI2)
36321 AS =PYALPS(XMI2)
36322 C1=AEM/XW
36323 XMI3=AXMI**3
36324
36325 XMI=SIGN(XMI,RMSS(3))
36326
36327C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
36328
36329 IF(IMSS(11).EQ.1) THEN
36330 XMP=RMSS(29)
36331 IDG=39+KSUSY1
36332 XMGR=PMAS(PYCOMP(IDG),1)
36333 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
36334 IF(AXMI.GT.XMGR) THEN
36335 LKNT=LKNT+1
36336 IDLAM(LKNT,1)=IDG
36337 IDLAM(LKNT,2)=21
36338 IDLAM(LKNT,3)=0
36339 XLAM(LKNT)=XFAC
36340 ENDIF
36341 ENDIF
36342
36343C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
36344
36345 DO 110 IFL=1,6
36346 DO 100 ILR=1,2
36347 XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1)
36348 AXMJ=ABS(XMJ)
36349 XMF=PMAS(IFL,1)
36350 IF(AXMI.GE.AXMJ+XMF) THEN
36351C...Minus sign difference from gluino-quark-squark feynman rules
36352 AL=SFMIX(IFL,1)
36353 BL=-SFMIX(IFL,3)
36354 AR=SFMIX(IFL,2)
36355 BR=-SFMIX(IFL,4)
36356C...F1 -> F CHI
36357 IF(ILR.EQ.1) THEN
36358 CA=AL
36359 CB=BL
36360C...F2 -> F CHI
36361 ELSE
36362 CA=AR
36363 CB=BR
36364 ENDIF
36365 LKNT=LKNT+1
36366 XMA2=XMJ**2
36367 XMB2=XMF**2
36368 XL=PYLAMF(XMI2,XMA2,XMB2)
36369 XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)*
36370 & (CA**2+CB**2)-4D0*CA*CB*XMI*XMF)
36371 IDLAM(LKNT,1)=ILR*KSUSY1+IFL
36372 IDLAM(LKNT,2)=-IFL
36373 IDLAM(LKNT,3)=0
36374 LKNT=LKNT+1
36375 XLAM(LKNT)=XLAM(LKNT-1)
36376 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36377 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36378 IDLAM(LKNT,3)=0
36379 ENDIF
36380 100 CONTINUE
36381 110 CONTINUE
36382
36383C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
36384C...GLUINO -> NI Q QBAR
36385 DO 170 IX=1,4
36386 XMJ=SMZ(IX)
36387 AXMJ=ABS(XMJ)
36388 IF(AXMI.GE.AXMJ) THEN
36389 DO 120 I=1,4
36390 ZMIXC(IX,I)=DCMPLX(ZMIX(IX,I),ZMIXI(IX,I))
36391 120 CONTINUE
36392 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))/SR2
36393 ORPP=DCONJG(OLPP)
36394 XXC(1)=0D0
36395 XXC(2)=XMJ
36396 XXC(3)=0D0
36397 XXC(4)=XMI
36398 IA=1
36399 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
36400 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
36401 XXC(7)=XXC(5)
36402 XXC(8)=XXC(6)
36403 XXC(9)=1D6
36404 XXC(10)=0D0
36405 EI=KCHG(IA,1)/3D0
36406 T3I=SIGN(1D0,EI+1D-6)/2D0
36407 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
36408 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
36409 CXC(1)=0D0
36410 CXC(2)=-GLIJ
36411 CXC(3)=0D0
36412 CXC(4)=DCONJG(GLIJ)
36413 CXC(5)=0D0
36414 CXC(6)=GRIJ
36415 CXC(7)=0D0
36416 CXC(8)=-DCONJG(GRIJ)
36417 S12MIN=0D0
36418 S12MAX=(AXMI-AXMJ)**2
36419 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 130
36420 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
36421 LKNT=LKNT+1
36422 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
36423 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
36424 IDLAM(LKNT,1)=KFNCHI(IX)
36425 IDLAM(LKNT,2)=1
36426 IDLAM(LKNT,3)=-1
36427 ENDIF
36428 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
36429 LKNT=LKNT+1
36430 XLAM(LKNT)=XLAM(LKNT-1)
36431 IDLAM(LKNT,1)=KFNCHI(IX)
36432 IDLAM(LKNT,2)=3
36433 IDLAM(LKNT,3)=-3
36434 ENDIF
36435 130 CONTINUE
36436 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
36437 PMOLD=PMAS(PYCOMP(KSUSY1+5),1)
36438 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+5),1)+PMAS(5,1)) THEN
36439 GOTO 140
36440 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) THEN
36441 PMAS(PYCOMP(KSUSY1+5),1)=100D0*XMI
36442 ENDIF
36443 CALL PYTBBN(IX,100,-1D0/3D0,XMI,GAM)
36444 LKNT=LKNT+1
36445 XLAM(LKNT)=GAM
36446 IDLAM(LKNT,1)=KFNCHI(IX)
36447 IDLAM(LKNT,2)=5
36448 IDLAM(LKNT,3)=-5
36449 PMAS(PYCOMP(KSUSY1+5),1)=PMOLD
36450 ENDIF
36451C...U-TYPE QUARKS
36452 140 CONTINUE
36453 IA=2
36454 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
36455 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
36456C IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 290
36457 XXC(7)=XXC(5)
36458 XXC(8)=XXC(6)
36459 EI=KCHG(IA,1)/3D0
36460 T3I=SIGN(1D0,EI+1D-6)/2D0
36461 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
36462 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
36463 CXC(2)=-GLIJ
36464 CXC(4)=DCONJG(GLIJ)
36465 CXC(6)=GRIJ
36466 CXC(8)=-DCONJG(GRIJ)
36467 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 150
36468 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
36469 LKNT=LKNT+1
36470 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
36471 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
36472 IDLAM(LKNT,1)=KFNCHI(IX)
36473 IDLAM(LKNT,2)=2
36474 IDLAM(LKNT,3)=-2
36475 ENDIF
36476 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
36477 LKNT=LKNT+1
36478 XLAM(LKNT)=XLAM(LKNT-1)
36479 IDLAM(LKNT,1)=KFNCHI(IX)
36480 IDLAM(LKNT,2)=4
36481 IDLAM(LKNT,3)=-4
36482 ENDIF
36483 150 CONTINUE
36484C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
36485C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
36486 XMF=PMAS(6,1)
36487 IF(AXMI.GE.AXMJ+2D0*XMF) THEN
36488 PMOLD=PMAS(PYCOMP(KSUSY1+6),1)
36489 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+6),1)+XMF) THEN
36490 GOTO 160
36491 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+6),1)+XMF) THEN
36492 PMAS(PYCOMP(KSUSY1+6),1)=100D0*XMI
36493 ENDIF
36494 CALL PYTBBN(IX,100,2D0/3D0,XMI,GAM)
36495 LKNT=LKNT+1
36496 XLAM(LKNT)=GAM
36497 IDLAM(LKNT,1)=KFNCHI(IX)
36498 IDLAM(LKNT,2)=6
36499 IDLAM(LKNT,3)=-6
36500 PMAS(PYCOMP(KSUSY1+6),1)=PMOLD
36501 ENDIF
36502 160 CONTINUE
36503 ENDIF
36504 170 CONTINUE
36505
36506C...GLUINO -> CI Q QBAR'
36507 DO 210 IX=1,2
36508 XMJ=SMW(IX)
36509 AXMJ=ABS(XMJ)
36510 IF(AXMI.GE.AXMJ) THEN
36511 DO 180 I=1,2
36512 VMIXC(IX,I)=DCMPLX(VMIX(IX,I),VMIXI(IX,I))
36513 UMIXC(IX,I)=DCMPLX(UMIX(IX,I),UMIXI(IX,I))
36514 180 CONTINUE
36515 S12MIN=0D0
36516 S12MAX=(AXMI-AXMJ)**2
36517 XXC(1)=0D0
36518 XXC(2)=XMJ
36519 XXC(3)=0D0
36520 XXC(4)=XMI
36521 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
36522 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
36523 XXC(9)=1D6
36524 XXC(10)=0D0
36525 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
36526 ORPP=DCONJG(OLPP)
36527 CXC(1)=DCMPLX(0D0,0D0)
36528 CXC(3)=DCMPLX(0D0,0D0)
36529 CXC(5)=DCMPLX(0D0,0D0)
36530 CXC(7)=DCMPLX(0D0,0D0)
36531 CXC(2)=UMIXC(IX,1)*OLPP/SR2
36532 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
36533 CXC(6)=DCMPLX(0D0,0D0)
36534 CXC(8)=DCMPLX(0D0,0D0)
36535 IF(XXC(5).LT.AXMI) THEN
36536 XXC(5)=1D6
36537 ELSEIF(XXC(6).LT.AXMI) THEN
36538 XXC(6)=1D6
36539 ENDIF
36540 XXC(7)=XXC(6)
36541 XXC(8)=XXC(5)
36542 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 190
36543 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
36544 LKNT=LKNT+1
36545 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
36546 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
36547 IDLAM(LKNT,1)=KFCCHI(IX)
36548 IDLAM(LKNT,2)=1
36549 IDLAM(LKNT,3)=-2
36550 LKNT=LKNT+1
36551 XLAM(LKNT)=XLAM(LKNT-1)
36552 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36553 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36554 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
36555 ENDIF
36556 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
36557 LKNT=LKNT+1
36558 XLAM(LKNT)=XLAM(LKNT-1)
36559 IDLAM(LKNT,1)=KFCCHI(IX)
36560 IDLAM(LKNT,2)=3
36561 IDLAM(LKNT,3)=-4
36562 LKNT=LKNT+1
36563 XLAM(LKNT)=XLAM(LKNT-1)
36564 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36565 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36566 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
36567 ENDIF
36568 190 CONTINUE
36569
36570 XMF=PMAS(6,1)
36571 XMFP=PMAS(5,1)
36572 IF(AXMI.GE.AXMJ+XMF+XMFP) THEN
36573 IF(XMI.GT.MIN(PMAS(PYCOMP(KSUSY1+5),1)+XMFP,
36574 $ PMAS(PYCOMP(KSUSY2+6),1)+XMF)) GOTO 200
36575 PMOLT2=PMAS(PYCOMP(KSUSY2+6),1)
36576 PMOLB2=PMAS(PYCOMP(KSUSY2+5),1)
36577 PMOLT1=PMAS(PYCOMP(KSUSY1+6),1)
36578 PMOLB1=PMAS(PYCOMP(KSUSY1+5),1)
36579 IF(XMI.GT.PMOLT2+XMF) PMOLT2=100D0*AXMI
36580 IF(XMI.GT.PMOLT1+XMF) PMOLT1=100D0*AXMI
36581 IF(XMI.GT.PMOLB2+XMFP) PMOLB2=100D0*AXMI
36582 IF(XMI.GT.PMOLB1+XMFP) PMOLB1=100D0*AXMI
36583 CALL PYTBBC(IX,100,XMI,GAM)
36584 LKNT=LKNT+1
36585 XLAM(LKNT)=GAM
36586 IDLAM(LKNT,1)=KFCCHI(IX)
36587 IDLAM(LKNT,2)=5
36588 IDLAM(LKNT,3)=-6
36589 LKNT=LKNT+1
36590 XLAM(LKNT)=XLAM(LKNT-1)
36591 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36592 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36593 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
36594 PMAS(PYCOMP(KSUSY2+6),1)=PMOLT2
36595 PMAS(PYCOMP(KSUSY2+5),1)=PMOLB2
36596 PMAS(PYCOMP(KSUSY1+6),1)=PMOLT1
36597 PMAS(PYCOMP(KSUSY1+5),1)=PMOLB1
36598 ENDIF
36599 200 CONTINUE
36600 ENDIF
36601 210 CONTINUE
36602
36603C...R-parity violating (3-body) decays.
36604 CALL PYRVGL(KFIN,XLAM,IDLAM,LKNT)
36605
36606 IKNT=LKNT
36607 XLAM(0)=0D0
36608 DO 220 I=1,IKNT
36609 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
36610 XLAM(0)=XLAM(0)+XLAM(I)
36611 220 CONTINUE
36612 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
36613
36614 RETURN
36615 END
36616
36617C*********************************************************************
36618
36619C...PYTBBN
36620C...Calculates the three-body decay of gluinos into
36621C...neutralinos and third generation fermions.
36622
36623 SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
36624
36625C...Double precision and integer declarations.
36626 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36627 IMPLICIT INTEGER(I-N)
36628 INTEGER PYK,PYCHGE,PYCOMP
36629C...Parameter statement to help give large particle numbers.
36630 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
36631 &KEXCIT=4000000,KDIMEN=5000000)
36632C...Commonblocks.
36633 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36634 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36635 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
36636 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
36637 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
36638 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
36639
36640C...Local variables.
36641 EXTERNAL PYSIMP,PYLAMF
36642 DOUBLE PRECISION PYSIMP,PYLAMF
36643 INTEGER LIN,NN
36644 DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
36645 DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
36646 DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
36647 DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
36648 DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
36649 DOUBLE PRECISION XLN1,XLN2,B1,B2
36650 DOUBLE PRECISION E,XMGLU,GAM
36651 DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
36652 SAVE HRB,HLB,FLB,FRB
36653 DOUBLE PRECISION ALPHAW,ALPHAS
36654 DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
36655 SAVE HLT,HRT,FLT,FRT
36656 DOUBLE PRECISION AMN(4),AN(4,4),ZN(3)
36657 SAVE AMN,AN,ZN
36658 DOUBLE PRECISION AMBOT,SINC,COSC
36659 DOUBLE PRECISION AMTOP,SINA,COSA
36660 DOUBLE PRECISION SINW,COSW,TANW
36661 DOUBLE PRECISION ROT1(4,4)
36662 LOGICAL IFIRST
36663 SAVE IFIRST
36664 DATA IFIRST/.TRUE./
36665
36666 TANB=RMSS(5)
36667 SINB=TANB/SQRT(1D0+TANB**2)
36668 COSB=SINB/TANB
36669 XW=PARU(102)
36670 SINW=SQRT(XW)
36671 COSW=SQRT(1D0-XW)
36672 TANW=SINW/COSW
36673 AMW=PMAS(24,1)
36674 COSC=SFMIX(5,1)
36675 SINC=SFMIX(5,3)
36676 COSA=SFMIX(6,1)
36677 SINA=SFMIX(6,3)
36678 AMBOT=PYMRUN(5,XMGLU**2)
36679 AMTOP=PYMRUN(6,XMGLU**2)
36680 W2=SQRT(2D0)
36681 FAKT1=AMBOT/W2/AMW/COSB
36682 FAKT2=AMTOP/W2/AMW/SINB
36683 IF(IFIRST) THEN
36684 DO 110 II=1,4
36685 AMN(II)=SMZ(II)
36686 DO 100 J=1,4
36687 ROT1(II,J)=0D0
36688 AN(II,J)=0D0
36689 100 CONTINUE
36690 110 CONTINUE
36691 ROT1(1,1)=COSW
36692 ROT1(1,2)=-SINW
36693 ROT1(2,1)=-ROT1(1,2)
36694 ROT1(2,2)=ROT1(1,1)
36695 ROT1(3,3)=COSB
36696 ROT1(3,4)=SINB
36697 ROT1(4,3)=-ROT1(3,4)
36698 ROT1(4,4)=ROT1(3,3)
36699 DO 140 II=1,4
36700 DO 130 J=1,4
36701 DO 120 JJ=1,4
36702 AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J)
36703 120 CONTINUE
36704 130 CONTINUE
36705 140 CONTINUE
36706 DO 150 J=1,4
36707 ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4))
36708 ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
36709 ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0*
36710 & XW)*AN(J,2)/COSW
36711 HRT(J)=ZN(1)*COSA-ZN(3)*SINA
36712 HLT(J)=ZN(1)*COSA+ZN(2)*SINA
36713 FLT(J)=ZN(3)*COSA+ZN(1)*SINA
36714 FRT(J)=ZN(2)*COSA-ZN(1)*SINA
36715C FLU(J)=ZN(3)
36716C FRU(J)=ZN(2)
36717 ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4))
36718 ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
36719 ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW
36720 HRB(J)=ZN(1)*COSC-ZN(3)*SINC
36721 HLB(J)=ZN(1)*COSC+ZN(2)*SINC
36722 FLB(J)=ZN(3)*COSC+ZN(1)*SINC
36723 FRB(J)=ZN(2)*COSC-ZN(1)*SINC
36724C FLD(J)=ZN(3)
36725C FRD(J)=ZN(2)
36726 150 CONTINUE
36727C AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
36728C AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
36729C AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
36730C AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
36731 IFIRST=.FALSE.
36732 ENDIF
36733
36734 IF(NINT(3D0*E).EQ.2) THEN
36735 HL=HLT(I)
36736 HR=HRT(I)
36737 FL=FLT(I)
36738 FR=FRT(I)
36739 COSD=SFMIX(6,1)
36740 SIND=SFMIX(6,3)
36741 XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2
36742 XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2
36743 XM=PMAS(6,1)
36744 ELSE
36745 HL=HLB(I)
36746 HR=HRB(I)
36747 FL=FLB(I)
36748 FR=FRB(I)
36749 COSD=SFMIX(5,1)
36750 SIND=SFMIX(5,3)
36751 XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2
36752 XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2
36753 XM=PMAS(5,1)
36754 ENDIF
36755 COSD2=COSD*COSD
36756 SIND2=SIND*SIND
36757 COS2D=COSD2-SIND2
36758 SIN2D=SIND*COSD*2D0
36759 HL2=HL*HL
36760 HR2=HR*HR
36761 FL2=FL*FL
36762 FR2=FR*FR
36763 FF=FL*FR
36764 HH=HL*HR
36765 HFL=HL*FL
36766 HFR=HR*FR
36767 HRFL=HR*FL
36768 HLFR=HL*FR
36769 XM2=XM*XM
36770 XMG=XMGLU
36771 XMG2=XMG*XMG
36772 ALPHAW=PYALEM(XMG2)
36773 ALPHAS=PYALPS(XMG2)
36774 XMR=AMN(I)
36775 XMR2=XMR*XMR
36776 XMQ4=XMG*XM2*XMR
36777 XM24=(XMG2+XM2)*(XM2+XMR2)
36778 SMIN=4D0*XM2
36779 SMAX=(XMG-ABS(XMR))**2
36780 XMQA=XMG2+2D0*XM2+XMR2
36781 DO 170 LIN=1,NN-1
36782 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
36783 GRS=SBAR-XMQA
36784 W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR)
36785 W=DSQRT(W)
36786 XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W)))
36787 XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W)))
36788 B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W)
36789 B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W)
36790 G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D
36791 & +2D0*(FF*SIND2-HH*COSD2))*W
36792 G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D)
36793 & +4D0*HFL*XM*XMR)*XLN1
36794 & +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24
36795 & +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D)
36796 & -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1))
36797 & +8D0*HFL*XMQ4*SIN2D)*B1
36798 G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D)
36799 & +4D0*HFR*XMR*XM)*XLN2
36800 & +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24
36801 & +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2))
36802 & +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2)
36803 & -8D0*HFR*XMQ4*SIN2D)*B2
36804 G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
36805 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR
36806 & -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2)
36807 & +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2)
36808 & -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1
36809 G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))*
36810 & (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2)
36811 & +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1))
36812 G(5)=(2D0*(HH*COSD2-FF*SIND2)
36813 & *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2
36814 & +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1)
36815 & +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR)
36816 & *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2)
36817 & +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2)
36818 & +COS2D*XM*(SBAR+XMG2-XMR2))
36819 & +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2))
36820 & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
36821 G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
36822 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR
36823 & -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2)
36824 & -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2)
36825 & -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2
36826 SUMME(LIN)=0D0
36827 DO 160 J=0,6
36828 SUMME(LIN)=SUMME(LIN)+G(J)
36829 160 CONTINUE
36830 170 CONTINUE
36831 SUMME(0)=0D0
36832 SUMME(NN)=0D0
36833 GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
36834 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
36835
36836 RETURN
36837 END
36838
36839C*********************************************************************
36840
36841C...PYTBBC
36842C...Calculates the three-body decay of gluinos into
36843C...charginos and third generation fermions.
36844
36845 SUBROUTINE PYTBBC(I,NN,XMGLU,GAM)
36846
36847C...Double precision and integer declarations.
36848 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36849 IMPLICIT INTEGER(I-N)
36850 INTEGER PYK,PYCHGE,PYCOMP
36851C...Parameter statement to help give large particle numbers.
36852 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
36853 &KEXCIT=4000000,KDIMEN=5000000)
36854C...Commonblocks.
36855 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36856 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36857 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
36858 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
36859 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
36860 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
36861
36862C...Local variables.
36863 EXTERNAL PYSIMP,PYLAMF
36864 DOUBLE PRECISION PYSIMP,PYLAMF
36865 INTEGER I,NN,LIN
36866 DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
36867 DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
36868 DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
36869 DOUBLE PRECISION SUMME(0:100),A(4,8)
36870 DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
36871 DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
36872 DOUBLE PRECISION XMGLU,GAM
36873 DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
36874 &DDD(2),EEE(2),FFF(2)
36875 SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF
36876 DOUBLE PRECISION ALPHAW,ALPHAS
36877 DOUBLE PRECISION AMC(2)
36878 SAVE AMC
36879 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
36880 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
36881 SAVE AMSB,AMST
36882 LOGICAL IFIRST
36883 SAVE IFIRST
36884 DATA IFIRST/.TRUE./
36885
36886 TANB=RMSS(5)
36887 SINB=TANB/SQRT(1D0+TANB**2)
36888 COSB=SINB/TANB
36889 XW=PARU(102)
36890 AMW=PMAS(24,1)
36891 COSC=SFMIX(5,1)
36892 SINC=SFMIX(5,3)
36893 COSA=SFMIX(6,1)
36894 SINA=SFMIX(6,3)
36895 AMBOT=PYMRUN(5,XMGLU**2)
36896 AMTOP=PYMRUN(6,XMGLU**2)
36897 W2=SQRT(2D0)
36898 AMW=PMAS(24,1)
36899 FAKT1=AMBOT/W2/AMW/COSB
36900 FAKT2=AMTOP/W2/AMW/SINB
36901 IF(IFIRST) THEN
36902 AMC(1)=SMW(1)
36903 AMC(2)=SMW(2)
36904 DO 100 JJ=1,2
36905 CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC
36906 EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC
36907 DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC
36908 FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC
36909 XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA
36910 AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA
36911 XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA
36912 BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA
36913 100 CONTINUE
36914 AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
36915 AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
36916 AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
36917 AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
36918 IFIRST=.FALSE.
36919 ENDIF
36920
36921 ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I)
36922 ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I)
36923 VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I)
36924 VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I)
36925
36926 COS2A=COSA**2-SINA**2
36927 SIN2A=SINA*COSA*2D0
36928 COS2C=COSC**2-SINC**2
36929 SIN2C=SINC*COSC*2D0
36930
36931 XMG=XMGLU
36932 XMT=PMAS(6,1)
36933 XMB=PMAS(5,1)
36934 XMR=AMC(I)
36935 XMG2=XMG*XMG
36936 ALPHAW=PYALEM(XMG2)
36937 ALPHAS=PYALPS(XMG2)
36938 XMT2=XMT*XMT
36939 XMB2=XMB*XMB
36940 XMR2=XMR*XMR
36941 XMQ2=XMG2+XMT2+XMB2+XMR2
36942 XMQ4=XMG*XMT*XMB*XMR
36943 XMQ3=XMG2*XMR2+XMT2*XMB2
36944 XMGBTR=(XMG2+XMB2)*(XMT2+XMR2)
36945 XMGTBR=(XMG2+XMT2)*(XMB2+XMR2)
36946
36947 XMST(1)=AMST(1)*AMST(1)
36948 XMST(2)=AMST(1)*AMST(1)
36949 XMST(3)=AMST(2)*AMST(2)
36950 XMST(4)=AMST(2)*AMST(2)
36951 XMSB(1)=AMSB(1)*AMSB(1)
36952 XMSB(2)=AMSB(2)*AMSB(2)
36953 XMSB(3)=AMSB(1)*AMSB(1)
36954 XMSB(4)=AMSB(2)*AMSB(2)
36955
36956 A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I)
36957 A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I))
36958 A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I))
36959 A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I))
36960 A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I))
36961 A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I))
36962 A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I))
36963 A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I))
36964
36965 A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I)
36966 A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I))
36967 A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I))
36968 A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I))
36969 A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I))
36970 A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I))
36971 A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I))
36972 A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I))
36973
36974 A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I)
36975 A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I))
36976 A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I))
36977 A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I))
36978 A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I))
36979 A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I))
36980 A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I))
36981 A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I))
36982
36983 A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I)
36984 A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I))
36985 A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I))
36986 A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I))
36987 A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I))
36988 A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I))
36989 A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I))
36990 A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I))
36991
36992 SMAX=(XMG-ABS(XMR))**2
36993 SMIN=(XMB+XMT)**2+0.1D0
36994
36995 DO 120 LIN=0,NN-1
36996 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
36997 AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR
36998 GRS=SBAR-XMQ2
36999 W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2)
37000 W=DSQRT(W)/2D0/SBAR
37001 ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W)))
37002 ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W)))
37003 ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W)))
37004 ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W)))
37005 SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A)
37006 & +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1
37007 & +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR
37008 & -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2))
37009 & +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2)
37010 & +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4)
37011 & *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W))
37012 SUMME(LIN)=SUMME(LIN)-ULR(2)*W
37013 & +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A)
37014 & -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2
37015 & +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR
37016 & +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2))
37017 & -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2)
37018 & +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4)
37019 & *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W))
37020 SUMME(LIN)=SUMME(LIN)-VLR(1)*W
37021 & +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C)
37022 & +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1
37023 & +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR
37024 & -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2))
37025 & +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2)
37026 & +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4)
37027 & *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W))
37028 SUMME(LIN)=SUMME(LIN)-VLR(2)*W
37029 & +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C)
37030 & -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2
37031 & +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR
37032 & +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2))
37033 & -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2)
37034 & +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4)
37035 & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
37036 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1))
37037 & *((AAA(I)*BBB(I)-XX1(I)*XX2(I))
37038 & *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1)
37039 & +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1))
37040 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1))
37041 & *((EEE(I)*FFF(I)-CCC(I)*DDD(I))
37042 & *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1)
37043 & +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1))
37044 DO 110 J=1,4
37045 SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W
37046 & +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3)
37047 & +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2)
37048 & +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2)
37049 & -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR)
37050 & -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8))
37051 & *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W)))
37052 & -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3)
37053 & +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2)
37054 & +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2)
37055 & -A(J,6)*(XMG2+XMR2-SBAR)
37056 & -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8))
37057 & *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W))))
37058 & /(GRS+XMSB(J)+XMST(J))
37059 110 CONTINUE
37060 120 CONTINUE
37061 SUMME(NN)=0D0
37062 GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
37063 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
37064
37065 RETURN
37066 END
37067
37068C*********************************************************************
37069
37070C...PYNJDC
37071C...Calculates decay widths for the neutralinos (admixtures of
37072C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
37073
37074C...Input: KCIN = KF code for particle
37075C...Output: XLAM = widths
37076C... IDLAM = KF codes for decay particles
37077C... IKNT = number of decay channels defined
37078C...AUTHOR: STEPHEN MRENNA
37079C...Last change:
37080C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
37081C...when CHIGAMMA .NE. 0
37082C...10 FEB 96: Calculate this decay for small tan(beta)
37083
37084 SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT)
37085
37086C...Double precision and integer declarations.
37087 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37088 IMPLICIT INTEGER(I-N)
37089 INTEGER PYK,PYCHGE,PYCOMP
37090C...Parameter statement to help give large particle numbers.
37091 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
37092 &KEXCIT=4000000,KDIMEN=5000000)
37093C...Commonblocks.
37094 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37095 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37096 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
37097c COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
37098c &SFMIX(16,4)
37099 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
37100 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
37101C COMMON/PYINTS/XXM(20)
37102 COMPLEX*16 CXC
37103 COMMON/PYINTC/XXC(10),CXC(8)
37104 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
37105
37106C...Local variables.
37107 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
37108 COMPLEX*16 QIJ,RIJ,F21K,F12K,CAL,CAR,CBL,CBR,CA,CB
37109 INTEGER KFIN
37110 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
37111 &XMZ,XMZ2,AXMJ,AXMI
37112 DOUBLE PRECISION S12MIN,S12MAX
37113 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2
37114 DOUBLE PRECISION PYLAMF,XL
37115 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I
37116 DOUBLE PRECISION PYX2XH,PYX2XG
37117 DOUBLE PRECISION XLAM(0:400)
37118 INTEGER IDLAM(400,3)
37119 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
37120 INTEGER ITH(3),KF1,KF2
37121 INTEGER ITHC
37122 DOUBLE PRECISION DH(3),EH(3)
37123 DOUBLE PRECISION SR2
37124 DOUBLE PRECISION CBETA,SBETA
37125 DOUBLE PRECISION GAMCON,XMT1,XMT2
37126 DOUBLE PRECISION PYALEM,PI,PYALPS
37127 DOUBLE PRECISION RAT1,RAT2
37128 DOUBLE PRECISION T3T,FCOL
37129 DOUBLE PRECISION ALFA,BETA,TANB
37130 DOUBLE PRECISION PYXXGA
37131 EXTERNAL PYGAUS,PYXXZ6
37132 DOUBLE PRECISION PYGAUS,PYXXZ6
37133 DOUBLE PRECISION PREC
37134 INTEGER KFNCHI(4),KFCCHI(2)
37135 DATA ITH/25,35,36/
37136 DATA ITHC/37/
37137 DATA PREC/1D-2/
37138 DATA PI/3.141592654D0/
37139 DATA SR2/1.4142136D0/
37140 DATA KFNCHI/1000022,1000023,1000025,1000035/
37141 DATA KFCCHI/1000024,1000037/
37142
37143C...COUNT THE NUMBER OF DECAY MODES
37144 LKNT=0
37145
37146 XMW=PMAS(24,1)
37147 XMW2=XMW**2
37148 XMZ=PMAS(23,1)
37149 XMZ2=XMZ**2
37150 XW=1D0-XMW2/XMZ2
37151 XW1=1D0-XW
37152 TANW = SQRT(XW/XW1)
37153
37154C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
37155 IX=1
37156 IF(KFIN.EQ.KFNCHI(2)) IX=2
37157 IF(KFIN.EQ.KFNCHI(3)) IX=3
37158 IF(KFIN.EQ.KFNCHI(4)) IX=4
37159
37160 XMI=SMZ(IX)
37161 XMI2=XMI**2
37162 AXMI=ABS(XMI)
37163 AEM=PYALEM(XMI2)
37164 AS =PYALPS(XMI2)
37165 C1=AEM/XW
37166 XMI3=ABS(XMI**3)
37167
37168 TANB=RMSS(5)
37169 BETA=ATAN(TANB)
37170 ALFA=RMSS(18)
37171 CBETA=COS(BETA)
37172 SBETA=TANB*CBETA
37173 CALFA=COS(ALFA)
37174 SALFA=SIN(ALFA)
37175
37176 DO 110 I=1,4
37177 DO 100 J=1,4
37178 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
37179 100 CONTINUE
37180 110 CONTINUE
37181 DO 130 I=1,2
37182 DO 120 J=1,2
37183 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
37184 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
37185 120 CONTINUE
37186 130 CONTINUE
37187
37188C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
37189 IF(IX.EQ.1.AND.IMSS(11).EQ.0) GOTO 300
37190
37191C...FORCE CHI0_2 -> CHI0_1 + GAMMA
37192 IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN
37193 XMJ=SMZ(1)
37194 AXMJ=ABS(XMJ)
37195 LKNT=LKNT+1
37196 GAMCON=AEM**3/8D0/PI/XMW2/XW
37197 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
37198 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
37199 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
37200 IDLAM(LKNT,1)=KSUSY1+22
37201 IDLAM(LKNT,2)=22
37202 IDLAM(LKNT,3)=0
37203 WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT)
37204 GOTO 340
37205 ENDIF
37206
37207C...GRAVITINO DECAY MODES
37208
37209 IF(IMSS(11).EQ.1) THEN
37210 XMP=RMSS(29)
37211 IDG=39+KSUSY1
37212 XMGR=PMAS(PYCOMP(IDG),1)
37213 SINW=SQRT(XW)
37214 COSW=SQRT(1D0-XW)
37215 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
37216 IF(AXMI.GT.XMGR+PMAS(22,1)) THEN
37217 LKNT=LKNT+1
37218 IDLAM(LKNT,1)=IDG
37219 IDLAM(LKNT,2)=22
37220 IDLAM(LKNT,3)=0
37221 XLAM(LKNT)=XFAC*ABS(ZMIXC(IX,1)*COSW+ZMIXC(IX,2)*SINW)**2
37222 ENDIF
37223 IF(AXMI.GT.XMGR+XMZ) THEN
37224 LKNT=LKNT+1
37225 IDLAM(LKNT,1)=IDG
37226 IDLAM(LKNT,2)=23
37227 IDLAM(LKNT,3)=0
37228 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,1)*SINW-ZMIXC(IX,2)*COSW)**2 +
37229 $ .5D0*ABS(ZMIXC(IX,3)*CBETA-ZMIXC(IX,4)*SBETA)**2)*
37230 & (1D0-XMZ2/XMI2)**4
37231 ENDIF
37232 IF(AXMI.GT.XMGR+PMAS(25,1)) THEN
37233 LKNT=LKNT+1
37234 IDLAM(LKNT,1)=IDG
37235 IDLAM(LKNT,2)=25
37236 IDLAM(LKNT,3)=0
37237 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SALFA-ZMIXC(IX,4)*CALFA)**2)*
37238 $ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4
37239 ENDIF
37240 IF(AXMI.GT.XMGR+PMAS(35,1)) THEN
37241 LKNT=LKNT+1
37242 IDLAM(LKNT,1)=IDG
37243 IDLAM(LKNT,2)=35
37244 IDLAM(LKNT,3)=0
37245 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*CALFA+ZMIXC(IX,4)*SALFA)**2)*
37246 $ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4
37247 ENDIF
37248 IF(AXMI.GT.XMGR+PMAS(36,1)) THEN
37249 LKNT=LKNT+1
37250 IDLAM(LKNT,1)=IDG
37251 IDLAM(LKNT,2)=36
37252 IDLAM(LKNT,3)=0
37253 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SBETA+ZMIXC(IX,4)*CBETA)**2)*
37254 $ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4
37255 ENDIF
37256 IF(IX.EQ.1) GOTO 300
37257 ENDIF
37258
37259 DO 220 IJ=1,IX-1
37260 XMJ=SMZ(IJ)
37261 AXMJ=ABS(XMJ)
37262 XMJ2=XMJ**2
37263
37264C...CHI0_I -> CHI0_J + GAMMA
37265 IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN
37266 RAT1=ABS(ZMIXC(IJ,1))**2+ABS(ZMIXC(IJ,2))**2
37267 RAT1=RAT1/( 1D-6+ABS(ZMIXC(IX,3))**2+ABS(ZMIXC(IX,4))**2 )
37268 RAT2=ABS(ZMIXC(IX,1))**2+ABS(ZMIXC(IX,2))**2
37269 RAT2=RAT2/( 1D-6+ABS(ZMIXC(IJ,3))**2+ABS(ZMIXC(IJ,4))**2 )
37270 IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR.
37271 & (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN
37272 LKNT=LKNT+1
37273 IDLAM(LKNT,1)=KFNCHI(IJ)
37274 IDLAM(LKNT,2)=22
37275 IDLAM(LKNT,3)=0
37276 GAMCON=AEM**3/8D0/PI/XMW2/XW
37277 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
37278 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
37279 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
37280 ENDIF
37281 ENDIF
37282
37283C...CHI0_I -> CHI0_J + Z0
37284 IF(AXMI.GE.AXMJ+XMZ) THEN
37285 LKNT=LKNT+1
37286 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
37287 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
37288 ORPP=-DCONJG(OLPP)
37289 GX2=ABS(OLPP)**2+ABS(ORPP)**2
37290 GLR=DBLE(OLPP*DCONJG(ORPP))
37291 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
37292 IDLAM(LKNT,1)=KFNCHI(IJ)
37293 IDLAM(LKNT,2)=23
37294 IDLAM(LKNT,3)=0
37295 ELSEIF(AXMI.GE.AXMJ) THEN
37296 XXC(1)=0D0
37297 XXC(2)=XMJ
37298 XXC(3)=0D0
37299 XXC(4)=XMI
37300 XXC(9)=XMZ
37301 XXC(10)=PMAS(23,2)
37302 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
37303 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
37304 ORPP=DCONJG(OLPP)
37305C...CHARGED LEPTONS
37306 FID=11
37307 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
37308 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
37309 EI=KCHG(FID,1)/3D0
37310 T3I=SIGN(1D0,EI+1D-6)/2D0
37311 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
37312 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
37313 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
37314 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
37315 CXC(2)=-GLIJ
37316 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
37317 CXC(4)=DCONJG(GLIJ)
37318 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
37319 CXC(6)=GRIJ
37320 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
37321 CXC(8)=-DCONJG(GRIJ)
37322 S12MIN=0D0
37323 S12MAX=(AXMI-AXMJ)**2
37324 IF( XXC(5).LT.AXMI ) THEN
37325 XXC(5)=1D6
37326 ENDIF
37327 IF(XXC(6).LT.AXMI ) THEN
37328 XXC(6)=1D6
37329 ENDIF
37330 XXC(7)=XXC(5)
37331 XXC(8)=XXC(6)
37332
37333 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
37334 LKNT=LKNT+1
37335 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37336 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
37337 IDLAM(LKNT,1)=KFNCHI(IJ)
37338 IDLAM(LKNT,2)=FID
37339 IDLAM(LKNT,3)=-FID
37340 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
37341 LKNT=LKNT+1
37342 XLAM(LKNT)=XLAM(LKNT-1)
37343 IDLAM(LKNT,1)=KFNCHI(IJ)
37344 IDLAM(LKNT,2)=13
37345 IDLAM(LKNT,3)=-13
37346 ENDIF
37347 ENDIF
37348 140 CONTINUE
37349 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
37350 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
37351 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
37352 ELSE
37353 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
37354 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
37355 ENDIF
37356 IF( XXC(5).LT.AXMI ) THEN
37357 XXC(5)=1D6
37358 ENDIF
37359 IF(XXC(6).LT.AXMI ) THEN
37360 XXC(6)=1D6
37361 ENDIF
37362 XXC(7)=XXC(5)
37363 XXC(8)=XXC(6)
37364
37365 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
37366 LKNT=LKNT+1
37367 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37368 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
37369 IDLAM(LKNT,1)=KFNCHI(IJ)
37370 IDLAM(LKNT,2)=15
37371 IDLAM(LKNT,3)=-15
37372 ENDIF
37373
37374C...NEUTRINOS
37375 150 CONTINUE
37376 FID=12
37377 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
37378 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
37379 EI=KCHG(FID,1)/3D0
37380 T3I=SIGN(1D0,EI+1D-6)/2D0
37381 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
37382 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
37383 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
37384 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
37385 CXC(2)=-GLIJ
37386 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
37387 CXC(4)=DCONJG(GLIJ)
37388 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
37389 CXC(6)=GRIJ
37390 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
37391 CXC(8)=-DCONJG(GRIJ)
37392 S12MIN=0D0
37393 S12MAX=(AXMI-AXMJ)**2
37394 IF( XXC(5).LT.AXMI ) THEN
37395 XXC(5)=1D6
37396 ENDIF
37397 IF( XXC(6).LT.AXMI ) THEN
37398 XXC(6)=1D6
37399 ENDIF
37400 XXC(7)=XXC(5)
37401 XXC(8)=XXC(6)
37402
37403 LKNT=LKNT+1
37404 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37405 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
37406 IDLAM(LKNT,1)=KFNCHI(IJ)
37407 IDLAM(LKNT,2)=12
37408 IDLAM(LKNT,3)=-12
37409 LKNT=LKNT+1
37410 XLAM(LKNT)=XLAM(LKNT-1)
37411 IDLAM(LKNT,1)=KFNCHI(IJ)
37412 IDLAM(LKNT,2)=14
37413 IDLAM(LKNT,3)=-14
37414 160 CONTINUE
37415
37416 IF(PMAS(PYCOMP(KSUSY1+16),1).NE.PMAS(PYCOMP(KSUSY1+12),1))
37417 & THEN
37418 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
37419 IF( XXC(5).LT.AXMI ) THEN
37420 XXC(5)=1D6
37421 ENDIF
37422 XXC(7)=XXC(5)
37423 LKNT=LKNT+1
37424 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37425 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
37426 ELSE
37427 LKNT=LKNT+1
37428 XLAM(LKNT)=XLAM(LKNT-1)
37429 ENDIF
37430 IDLAM(LKNT,1)=KFNCHI(IJ)
37431 IDLAM(LKNT,2)=16
37432 IDLAM(LKNT,3)=-16
37433C...D-TYPE QUARKS
37434 170 CONTINUE
37435 FID=1
37436 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
37437 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
37438 EI=KCHG(FID,1)/3D0
37439 T3I=SIGN(1D0,EI+1D-6)/2D0
37440 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
37441 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
37442 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
37443 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
37444 CXC(2)=-GLIJ
37445 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
37446 CXC(4)=DCONJG(GLIJ)
37447 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
37448 CXC(6)=GRIJ
37449 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
37450 CXC(8)=-DCONJG(GRIJ)
37451 S12MIN=0D0
37452 S12MAX=(AXMI-AXMJ)**2
37453 IF( XXC(5).LT.AXMI ) THEN
37454 XXC(5)=1D6
37455 ENDIF
37456 IF( XXC(6).LT.AXMI ) THEN
37457 XXC(6)=1D6
37458 ENDIF
37459 XXC(7)=XXC(5)
37460 XXC(8)=XXC(6)
37461
37462 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
37463 LKNT=LKNT+1
37464 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37465 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
37466 IDLAM(LKNT,1)=KFNCHI(IJ)
37467 IDLAM(LKNT,2)=1
37468 IDLAM(LKNT,3)=-1
37469 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
37470 LKNT=LKNT+1
37471 XLAM(LKNT)=XLAM(LKNT-1)
37472 IDLAM(LKNT,1)=KFNCHI(IJ)
37473 IDLAM(LKNT,2)=3
37474 IDLAM(LKNT,3)=-3
37475 ENDIF
37476 ENDIF
37477 180 CONTINUE
37478 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
37479 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
37480 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
37481 ELSE
37482 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
37483 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
37484 ENDIF
37485 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
37486 IF(XXC(5).LT.AXMI) THEN
37487 XXC(5)=1D6
37488 ELSEIF(XXC(6).LT.AXMI) THEN
37489 XXC(6)=1D6
37490 ENDIF
37491 XXC(7)=XXC(5)
37492 XXC(8)=XXC(6)
37493 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
37494 LKNT=LKNT+1
37495 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37496 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
37497 IDLAM(LKNT,1)=KFNCHI(IJ)
37498 IDLAM(LKNT,2)=5
37499 IDLAM(LKNT,3)=-5
37500 ENDIF
37501
37502C...U-TYPE QUARKS
37503 190 CONTINUE
37504 FID=2
37505 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
37506 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
37507 EI=KCHG(FID,1)/3D0
37508 T3I=SIGN(1D0,EI+1D-6)/2D0
37509 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
37510 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
37511 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
37512 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
37513 CXC(2)=-GLIJ
37514 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
37515 CXC(4)=DCONJG(GLIJ)
37516 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
37517 CXC(6)=GRIJ
37518 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
37519 CXC(8)=-DCONJG(GRIJ)
37520
37521 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 200
37522 IF(XXC(5).LT.AXMI) THEN
37523 XXC(5)=1D6
37524 ELSEIF(XXC(6).LT.AXMI) THEN
37525 XXC(6)=1D6
37526 ENDIF
37527 XXC(7)=XXC(5)
37528 XXC(8)=XXC(6)
37529
37530 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
37531 LKNT=LKNT+1
37532 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37533 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
37534 IDLAM(LKNT,1)=KFNCHI(IJ)
37535 IDLAM(LKNT,2)=2
37536 IDLAM(LKNT,3)=-2
37537 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
37538 LKNT=LKNT+1
37539 XLAM(LKNT)=XLAM(LKNT-1)
37540 IDLAM(LKNT,1)=KFNCHI(IJ)
37541 IDLAM(LKNT,2)=4
37542 IDLAM(LKNT,3)=-4
37543 ENDIF
37544 ENDIF
37545 200 CONTINUE
37546 ENDIF
37547
37548C...CHI0_I -> CHI0_J + H0_K
37549 EH(1)=SIN(ALFA)
37550 EH(2)=COS(ALFA)
37551 EH(3)=-SIN(BETA)
37552 DH(1)=COS(ALFA)
37553 DH(2)=-SIN(ALFA)
37554 DH(3)=COS(BETA)
37555 QIJ=ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,2))+
37556 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,2)-
37557 & TANW*(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,1))+
37558 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,1))
37559 RIJ=DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,2)+
37560 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,2))-
37561 & TANW*(DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,1)+
37562 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,1)))
37563 DO 210 IH=1,3
37564 XMH=PMAS(ITH(IH),1)
37565 XMH2=XMH**2
37566 IF(AXMI.GE.AXMJ+XMH) THEN
37567 LKNT=LKNT+1
37568 XL=PYLAMF(XMI2,XMJ2,XMH2)
37569 F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH))
37570 F12K=F21K
37571C...SIGN OF MASSES I,J
37572 XMK=XMJ
37573 IF(IH.EQ.3) XMK=-XMK
37574 GX2=ABS(F21K)**2+ABS(F12K)**2
37575 GLR=DBLE(F21K*DCONJG(F12K))
37576 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
37577 IDLAM(LKNT,1)=KFNCHI(IJ)
37578 IDLAM(LKNT,2)=ITH(IH)
37579 IDLAM(LKNT,3)=0
37580 ENDIF
37581 210 CONTINUE
37582 220 CONTINUE
37583
37584C...CHI0_I -> CHI+_J + W-
37585 DO 260 IJ=1,2
37586 XMJ=SMW(IJ)
37587 AXMJ=ABS(XMJ)
37588 XMJ2=XMJ**2
37589 IF(AXMI.GE.AXMJ+XMW) THEN
37590 LKNT=LKNT+1
37591 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
37592 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)/SR2)
37593 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
37594 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))/SR2)
37595 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
37596 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
37597 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
37598 IDLAM(LKNT,1)=KFCCHI(IJ)
37599 IDLAM(LKNT,2)=-24
37600 IDLAM(LKNT,3)=0
37601 LKNT=LKNT+1
37602 XLAM(LKNT)=XLAM(LKNT-1)
37603 IDLAM(LKNT,1)=-KFCCHI(IJ)
37604 IDLAM(LKNT,2)=24
37605 IDLAM(LKNT,3)=0
37606 ELSEIF(AXMI.GE.AXMJ) THEN
37607 S12MIN=0D0
37608 S12MAX=(AXMI-AXMJ)**2
37609 RT2I = 1D0/SQRT(2D0)
37610 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
37611 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)*RT2I)*RT2I
37612 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
37613 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))*RT2I)*RT2I
37614 CXC(5)=DCMPLX(0D0,0D0)
37615 CXC(7)=DCMPLX(0D0,0D0)
37616 IA=11
37617 JA=12
37618 EI=KCHG(IA,1)/3D0
37619 T3I=SIGN(1D0,EI+1D-6)/2D0
37620 EJ=KCHG(JA,1)/3D0
37621 T3J=SIGN(1D0,EJ+1D-6)/2D0
37622 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
37623 & TANW+ZMIXC(IX,2)*T3J)*RT2I
37624 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
37625 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)*RT2I
37626 CXC(6)=DCMPLX(0D0,0D0)
37627 CXC(8)=DCMPLX(0D0,0D0)
37628 XXC(1)=0D0
37629 XXC(2)=XMJ
37630 XXC(3)=0D0
37631 XXC(4)=XMI
37632 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
37633 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
37634 XXC(9)=PMAS(24,1)
37635 XXC(10)=PMAS(24,2)
37636 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 230
37637 IF(XXC(5).LT.AXMI) THEN
37638 XXC(5)=1D6
37639 ELSEIF(XXC(6).LT.AXMI) THEN
37640 XXC(6)=1D6
37641 ENDIF
37642 XXC(7)=XXC(6)
37643 XXC(8)=XXC(5)
37644 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
37645 LKNT=LKNT+1
37646 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37647 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
37648 IDLAM(LKNT,1)=KFCCHI(IJ)
37649 IDLAM(LKNT,2)=11
37650 IDLAM(LKNT,3)=-12
37651 LKNT=LKNT+1
37652 XLAM(LKNT)=XLAM(LKNT-1)
37653 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37654 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37655 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
37656 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
37657 LKNT=LKNT+1
37658 XLAM(LKNT)=XLAM(LKNT-1)
37659 IDLAM(LKNT,1)=KFCCHI(IJ)
37660 IDLAM(LKNT,2)=13
37661 IDLAM(LKNT,3)=-14
37662 LKNT=LKNT+1
37663 XLAM(LKNT)=XLAM(LKNT-1)
37664 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37665 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37666 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
37667 ENDIF
37668 ENDIF
37669 230 CONTINUE
37670 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
37671 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
37672 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
37673 ELSE
37674 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
37675 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
37676 ENDIF
37677 IF(XXC(5).LT.AXMI) THEN
37678 XXC(5)=1D6
37679 ENDIF
37680 IF(XXC(6).LT.AXMI) THEN
37681 XXC(6)=1D6
37682 ENDIF
37683 XXC(7)=XXC(6)
37684 XXC(8)=XXC(5)
37685 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
37686 LKNT=LKNT+1
37687 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37688 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
37689 XLAM(LKNT)=XLAM(LKNT-1)
37690 IDLAM(LKNT,1)=KFCCHI(IJ)
37691 IDLAM(LKNT,2)=15
37692 IDLAM(LKNT,3)=-16
37693 LKNT=LKNT+1
37694 XLAM(LKNT)=XLAM(LKNT-1)
37695 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37696 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37697 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
37698 ENDIF
37699
37700C...NOW, DO THE QUARKS
37701 240 CONTINUE
37702 IA=1
37703 JA=2
37704 EI=KCHG(IA,1)/3D0
37705 T3I=SIGN(1D0,EI+1D-6)/2D0
37706 EJ=KCHG(JA,1)/3D0
37707 T3J=SIGN(1D0,EJ+1D-6)/2D0
37708 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
37709 & TANW+ZMIXC(IX,2)*T3J)
37710 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
37711 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)
37712 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
37713 XXC(6)=PMAS(PYCOMP(KSUSY1+JA),1)
37714 IF(XXC(5).LT.AXMI) THEN
37715 XXC(5)=1D6
37716 ENDIF
37717 IF(XXC(6).LT.AXMI) THEN
37718 XXC(6)=1D6
37719 ENDIF
37720 XXC(7)=XXC(6)
37721 XXC(8)=XXC(5)
37722 IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN
37723 LKNT=LKNT+1
37724 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
37725 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
37726 IDLAM(LKNT,1)=KFCCHI(IJ)
37727 IDLAM(LKNT,2)=1
37728 IDLAM(LKNT,3)=-2
37729 LKNT=LKNT+1
37730 XLAM(LKNT)=XLAM(LKNT-1)
37731 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37732 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37733 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
37734 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
37735 LKNT=LKNT+1
37736 XLAM(LKNT)=XLAM(LKNT-1)
37737 IDLAM(LKNT,1)=KFCCHI(IJ)
37738 IDLAM(LKNT,2)=3
37739 IDLAM(LKNT,3)=-4
37740 LKNT=LKNT+1
37741 XLAM(LKNT)=XLAM(LKNT-1)
37742 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37743 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37744 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
37745 ENDIF
37746 ENDIF
37747 250 CONTINUE
37748 ENDIF
37749 260 CONTINUE
37750 270 CONTINUE
37751
37752C...CHI0_I -> CHI+_I + H-
37753 DO 280 IJ=1,2
37754 XMJ=SMW(IJ)
37755 AXMJ=ABS(XMJ)
37756 XMJ2=XMJ**2
37757 XMHP=PMAS(ITHC,1)
37758 IF(AXMI.GE.AXMJ+XMHP) THEN
37759 LKNT=LKNT+1
37760 OLPP=CBETA*(ZMIXC(IX,4)*DCONJG(VMIXC(IJ,1))+(ZMIXC(IX,2)+
37761 & ZMIXC(IX,1)*TANW)*DCONJG(VMIXC(IJ,2))/SR2)
37762 ORPP=SBETA*(DCONJG(ZMIXC(IX,3))*UMIXC(IJ,1)-
37763 & (DCONJG(ZMIXC(IX,2))+DCONJG(ZMIXC(IX,1))*TANW)*
37764 & UMIXC(IJ,2)/SR2)
37765 GX2=ABS(OLPP)**2+ABS(ORPP)**2
37766 GLR=DBLE(OLPP*DCONJG(ORPP))
37767 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
37768 IDLAM(LKNT,1)=KFCCHI(IJ)
37769 IDLAM(LKNT,2)=-ITHC
37770 IDLAM(LKNT,3)=0
37771 LKNT=LKNT+1
37772 XLAM(LKNT)=XLAM(LKNT-1)
37773 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37774 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37775 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
37776 ELSE
37777
37778 ENDIF
37779 280 CONTINUE
37780
37781C...2-BODY DECAYS TO FERMION SFERMION
37782 DO 290 J=1,16
37783 IF(J.GE.7.AND.J.LE.10) GOTO 290
37784 KF1=KSUSY1+J
37785 KF2=KSUSY2+J
37786 XMSF1=PMAS(PYCOMP(KF1),1)
37787 XMSF2=PMAS(PYCOMP(KF2),1)
37788 XMF=PMAS(J,1)
37789 IF(J.LE.6) THEN
37790 FCOL=3D0
37791 ELSE
37792 FCOL=1D0
37793 ENDIF
37794
37795 EI=KCHG(J,1)/3D0
37796 T3T=SIGN(1D0,EI)
37797 IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0
37798 IF(MOD(J,2).EQ.0) THEN
37799 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
37800 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
37801 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
37802 CBR=CAL
37803 ELSE
37804 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
37805 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
37806 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
37807 CBR=CAL
37808 ENDIF
37809
37810C...D~ D_L
37811 IF(AXMI.GE.XMF+XMSF1) THEN
37812 LKNT=LKNT+1
37813 XMA2=XMSF1**2
37814 XMB2=XMF**2
37815 XL=PYLAMF(XMI2,XMA2,XMB2)
37816 CA=CAL*SFMIX(J,1)+CAR*SFMIX(J,2)
37817 CB=CBL*SFMIX(J,1)+CBR*SFMIX(J,2)
37818 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
37819 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
37820 IDLAM(LKNT,1)=KF1
37821 IDLAM(LKNT,2)=-J
37822 IDLAM(LKNT,3)=0
37823 LKNT=LKNT+1
37824 XLAM(LKNT)=XLAM(LKNT-1)
37825 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37826 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37827 IDLAM(LKNT,3)=0
37828 ENDIF
37829
37830C...D~ D_R
37831 IF(AXMI.GE.XMF+XMSF2) THEN
37832 LKNT=LKNT+1
37833 XMA2=XMSF2**2
37834 XMB2=XMF**2
37835 CA=CAL*SFMIX(J,3)+CAR*SFMIX(J,4)
37836 CB=CBL*SFMIX(J,3)+CBR*SFMIX(J,4)
37837 XL=PYLAMF(XMI2,XMA2,XMB2)
37838 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
37839 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
37840 IDLAM(LKNT,1)=KF2
37841 IDLAM(LKNT,2)=-J
37842 IDLAM(LKNT,3)=0
37843 LKNT=LKNT+1
37844 XLAM(LKNT)=XLAM(LKNT-1)
37845 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37846 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37847 IDLAM(LKNT,3)=0
37848 ENDIF
37849 290 CONTINUE
37850 300 CONTINUE
37851C...3-BODY DECAY TO Q Q~ GLUINO
37852 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
37853 IF(AXMI.GE.XMJ) THEN
37854 RT2I = 1D0/SQRT(2D0)
37855 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))*RT2I
37856 ORPP=DCONJG(OLPP)
37857 AXMJ=ABS(XMJ)
37858 XXC(1)=0D0
37859 XXC(2)=XMJ
37860 XXC(3)=0D0
37861 XXC(4)=XMI
37862 FID=1
37863 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
37864 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
37865 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 310
37866 XXC(7)=XXC(5)
37867 XXC(8)=XXC(6)
37868 XXC(9)=1D6
37869 XXC(10)=0D0
37870 EI=KCHG(FID,1)/3D0
37871 T3I=SIGN(1D0,EI+1D-6)/2D0
37872 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
37873 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
37874 CXC(1)=0D0
37875 CXC(2)=-GLIJ
37876 CXC(3)=0D0
37877 CXC(4)=DCONJG(GLIJ)
37878 CXC(5)=0D0
37879 CXC(6)=GRIJ
37880 CXC(7)=0D0
37881 CXC(8)=-DCONJG(GRIJ)
37882 S12MIN=0D0
37883 S12MAX=(AXMI-AXMJ)**2
37884C...ALL QUARKS BUT T
37885 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
37886 LKNT=LKNT+1
37887 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
37888 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
37889 IDLAM(LKNT,1)=KSUSY1+21
37890 IDLAM(LKNT,2)=1
37891 IDLAM(LKNT,3)=-1
37892 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
37893 LKNT=LKNT+1
37894 XLAM(LKNT)=XLAM(LKNT-1)
37895 IDLAM(LKNT,1)=KSUSY1+21
37896 IDLAM(LKNT,2)=3
37897 IDLAM(LKNT,3)=-3
37898 ENDIF
37899 ENDIF
37900 310 CONTINUE
37901 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
37902 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
37903 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
37904 ELSE
37905 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
37906 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
37907 ENDIF
37908 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 320
37909 XXC(7)=XXC(5)
37910 XXC(8)=XXC(6)
37911 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
37912 LKNT=LKNT+1
37913 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
37914 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
37915 IDLAM(LKNT,1)=KSUSY1+21
37916 IDLAM(LKNT,2)=5
37917 IDLAM(LKNT,3)=-5
37918 ENDIF
37919C...U-TYPE QUARKS
37920 320 CONTINUE
37921 FID=2
37922 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
37923 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
37924 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 330
37925 XXC(7)=XXC(5)
37926 XXC(8)=XXC(6)
37927 EI=KCHG(FID,1)/3D0
37928 T3I=SIGN(1D0,EI+1D-6)/2D0
37929 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
37930 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
37931 CXC(2)=-GLIJ
37932 CXC(4)=DCONJG(GLIJ)
37933 CXC(6)=GRIJ
37934 CXC(8)=-DCONJG(GRIJ)
37935 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
37936 LKNT=LKNT+1
37937 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
37938 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
37939 IDLAM(LKNT,1)=KSUSY1+21
37940 IDLAM(LKNT,2)=2
37941 IDLAM(LKNT,3)=-2
37942 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
37943 LKNT=LKNT+1
37944 XLAM(LKNT)=XLAM(LKNT-1)
37945 IDLAM(LKNT,1)=KSUSY1+21
37946 IDLAM(LKNT,2)=4
37947 IDLAM(LKNT,3)=-4
37948 ENDIF
37949 ENDIF
37950 330 CONTINUE
37951 ENDIF
37952
37953C...R-violating decay modes (SKANDS).
37954 CALL PYRVNE(KFIN,XLAM,IDLAM,LKNT)
37955
37956 340 IKNT=LKNT
37957 XLAM(0)=0D0
37958 DO 350 I=1,IKNT
37959 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
37960 XLAM(0)=XLAM(0)+XLAM(I)
37961 350 CONTINUE
37962 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
37963
37964 RETURN
37965 END
37966
37967C*********************************************************************
37968
37969C...PYCJDC
37970C...Calculate decay widths for the charginos (admixtures of
37971C...charged Wino and charged Higgsino.
37972
37973C...Input: KCIN = KF code for particle
37974C...Output: XLAM = widths
37975C... IDLAM = KF codes for decay particles
37976C... IKNT = number of decay channels defined
37977C...AUTHOR: STEPHEN MRENNA
37978C...Last change:
37979C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
37980C...when CHIENU .NE. 0
37981
37982 SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT)
37983
37984C...Double precision and integer declarations.
37985 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37986 IMPLICIT INTEGER(I-N)
37987 INTEGER PYK,PYCHGE,PYCOMP
37988C...Parameter statement to help give large particle numbers.
37989 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
37990 &KEXCIT=4000000,KDIMEN=5000000)
37991C...Commonblocks.
37992 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37993 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37994 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
37995 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
37996 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
37997CC &SFMIX(16,4),
37998C COMMON/PYINTS/XXM(20)
37999 COMPLEX*16 CXC
38000 COMMON/PYINTC/XXC(10),CXC(8)
38001 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
38002
38003C...Local variables
38004 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
38005 COMPLEX*16 CAL,CBL,CAR,CBR,CA,CB
38006 INTEGER KFIN,KCIN
38007 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
38008 &XMZ,XMZ2,AXMJ,AXMI
38009 DOUBLE PRECISION S12MIN,S12MAX
38010 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2,XMK
38011 DOUBLE PRECISION PYLAMF,XL
38012 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I,BETA,ALFA
38013 DOUBLE PRECISION PYX2XH,PYX2XG
38014 DOUBLE PRECISION XLAM(0:400)
38015 INTEGER IDLAM(400,3)
38016 INTEGER LKNT,IX,IH,J,IJ,I,IKNT
38017 INTEGER ITH(3)
38018 INTEGER ITHC
38019 DOUBLE PRECISION ETAH(3),DH(3),EH(3)
38020 DOUBLE PRECISION SR2
38021 DOUBLE PRECISION CBETA,SBETA,TANB
38022
38023 DOUBLE PRECISION PYALEM,PI,PYALPS
38024 DOUBLE PRECISION FCOL
38025 INTEGER KF1,KF2,ISF
38026 INTEGER KFNCHI(4),KFCCHI(2)
38027
38028 DOUBLE PRECISION TEMP
38029 EXTERNAL PYGAUS,PYXXZ6
38030 DOUBLE PRECISION PYGAUS,PYXXZ6
38031 DOUBLE PRECISION PREC
38032 DATA ITH/25,35,36/
38033 DATA ITHC/37/
38034 DATA ETAH/1D0,1D0,-1D0/
38035 DATA SR2/1.4142136D0/
38036 DATA PI/3.141592654D0/
38037 DATA PREC/1D-2/
38038 DATA KFNCHI/1000022,1000023,1000025,1000035/
38039 DATA KFCCHI/1000024,1000037/
38040
38041C...COUNT THE NUMBER OF DECAY MODES
38042 LKNT=0
38043 XMW=PMAS(24,1)
38044 XMW2=XMW**2
38045 XMZ=PMAS(23,1)
38046 XMZ2=XMZ**2
38047 XW=1D0-XMW2/XMZ2
38048 XW1=1D0-XW
38049 TANW = SQRT(XW/XW1)
38050
38051C...1 OR 2 DEPENDING ON CHARGINO TYPE
38052 IX=1
38053 IF(KFIN.EQ.KFCCHI(2)) IX=2
38054 KCIN=PYCOMP(KFIN)
38055
38056 XMI=SMW(IX)
38057 XMI2=XMI**2
38058 AXMI=ABS(XMI)
38059 AEM=PYALEM(XMI2)
38060 AS =PYALPS(XMI2)
38061 C1=AEM/XW
38062 XMI3=ABS(XMI**3)
38063 TANB=RMSS(5)
38064 BETA=ATAN(TANB)
38065 CBETA=COS(BETA)
38066 SBETA=TANB*CBETA
38067 ALFA=RMSS(18)
38068
38069 DO 110 I=1,2
38070 DO 100 J=1,2
38071 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
38072 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
38073 100 CONTINUE
38074 110 CONTINUE
38075
38076C...GRAVITINO DECAY MODES
38077
38078 IF(IMSS(11).EQ.1) THEN
38079 XMP=RMSS(29)
38080 IDG=39+KSUSY1
38081 XMGR=PMAS(PYCOMP(IDG),1)
38082C SINW=SQRT(XW)
38083C COSW=SQRT(1D0-XW)
38084 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
38085 IF(AXMI.GT.XMGR+XMW) THEN
38086 LKNT=LKNT+1
38087 IDLAM(LKNT,1)=IDG
38088 IDLAM(LKNT,2)=24
38089 IDLAM(LKNT,3)=0
38090 XLAM(LKNT)=XFAC*(
38091 & .5D0*(ABS(VMIXC(IX,1))**2+ABS(UMIXC(IX,1))**2)+
38092 & .5D0*((ABS(VMIXC(IX,2))*SBETA)**2+(ABS(UMIXC(IX,2))*CBETA)**2))*
38093 & (1D0-XMW2/XMI2)**4
38094 ENDIF
38095 IF(AXMI.GT.XMGR+PMAS(37,1)) THEN
38096 LKNT=LKNT+1
38097 IDLAM(LKNT,1)=IDG
38098 IDLAM(LKNT,2)=37
38099 IDLAM(LKNT,3)=0
38100 XLAM(LKNT)=XFAC*(.5D0*((ABS(VMIXC(IX,2))*CBETA)**2+
38101 & (ABS(UMIXC(IX,2))*SBETA)**2))
38102 & *(1D0-PMAS(37,1)**2/XMI2)**4
38103 ENDIF
38104 ENDIF
38105
38106C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
38107 IF(IX.EQ.1) GOTO 170
38108 XMJ=SMW(1)
38109 AXMJ=ABS(XMJ)
38110 XMJ2=XMJ**2
38111
38112C...CHI_2+ -> CHI_1+ + Z0
38113 IF(AXMI.GE.AXMJ+XMZ) THEN
38114 LKNT=LKNT+1
38115 IJ=1
38116 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
38117 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
38118 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
38119 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
38120 GX2=ABS(OLPP)**2+ABS(ORPP)**2
38121 GLR=DBLE(OLPP*DCONJG(ORPP))
38122 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
38123 IDLAM(LKNT,1)=KFCCHI(1)
38124 IDLAM(LKNT,2)=23
38125 IDLAM(LKNT,3)=0
38126
38127C...CHARGED LEPTONS
38128 ELSEIF(AXMI.GE.AXMJ) THEN
38129 S12MIN=0D0
38130 S12MAX=(AXMI-AXMJ)**2
38131 IA=11
38132 JA=12
38133 EI=KCHG(IABS(IA),1)/3D0
38134 T3I=SIGN(1D0,EI+1D-6)/2D0
38135 XXC(1)=0D0
38136 XXC(2)=XMJ
38137 XXC(3)=0D0
38138 XXC(4)=XMI
38139 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
38140 XXC(6)=1D6
38141 XXC(9)=PMAS(23,1)
38142 XXC(10)=PMAS(23,2)
38143 IJ=1
38144 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
38145 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
38146 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
38147 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
38148 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
38149 CXC(2)=DCMPLX(0D0,0D0)
38150 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
38151 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
38152 CXC(5)=-DCMPLX(EI/XW1)*ORPP
38153 CXC(6)=DCMPLX(0D0,0D0)
38154 CXC(7)=-DCMPLX(EI/XW1)*OLPP
38155 CXC(8)=DCMPLX(0D0,0D0)
38156 IF( XXC(5).LT.AXMI ) THEN
38157 XXC(5)=1D6
38158 ENDIF
38159 XXC(7)=XXC(5)
38160 XXC(8)=XXC(6)
38161 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
38162 LKNT=LKNT+1
38163 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
38164 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38165 IDLAM(LKNT,1)=KFCCHI(1)
38166 IDLAM(LKNT,2)=11
38167 IDLAM(LKNT,3)=-11
38168 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
38169 LKNT=LKNT+1
38170 XLAM(LKNT)=XLAM(LKNT-1)
38171 IDLAM(LKNT,1)=KFCCHI(1)
38172 IDLAM(LKNT,2)=13
38173 IDLAM(LKNT,3)=-13
38174 ENDIF
38175 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
38176 LKNT=LKNT+1
38177 XLAM(LKNT)=XLAM(LKNT-1)
38178 IDLAM(LKNT,1)=KFCCHI(1)
38179 IDLAM(LKNT,2)=15
38180 IDLAM(LKNT,3)=-15
38181 ENDIF
38182 ENDIF
38183
38184C...NEUTRINOS
38185 120 CONTINUE
38186 IA=12
38187 JA=11
38188 EI=KCHG(IABS(IA),1)/3D0
38189 T3I=SIGN(1D0,EI+1D-6)/2D0
38190 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
38191 XXC(6)=1D6
38192 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
38193 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
38194 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
38195 CXC(5)=-DCMPLX(EI/XW1)*ORPP
38196 CXC(7)=-DCMPLX(EI/XW1)*OLPP
38197 IF( XXC(5).LT.AXMI ) THEN
38198 XXC(5)=1D6
38199 ENDIF
38200 XXC(7)=XXC(5)
38201 XXC(8)=XXC(6)
38202 IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN
38203 LKNT=LKNT+1
38204 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
38205 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38206 IDLAM(LKNT,1)=KFCCHI(1)
38207 IDLAM(LKNT,2)=12
38208 IDLAM(LKNT,3)=-12
38209 LKNT=LKNT+1
38210 XLAM(LKNT)=XLAM(LKNT-1)
38211 IDLAM(LKNT,1)=KFCCHI(1)
38212 IDLAM(LKNT,2)=14
38213 IDLAM(LKNT,3)=-14
38214 ENDIF
38215 IF(AXMI.GE.AXMJ+2D0*PMAS(16,1)) THEN
38216 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
38217 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
38218 ELSE
38219 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
38220 ENDIF
38221 IF( XXC(5).LT.AXMI ) THEN
38222 XXC(5)=1D6
38223 ENDIF
38224 XXC(7)=XXC(5)
38225 LKNT=LKNT+1
38226 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
38227 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38228 IDLAM(LKNT,1)=KFCCHI(1)
38229 IDLAM(LKNT,2)=16
38230 IDLAM(LKNT,3)=-16
38231 ENDIF
38232
38233C...D-TYPE QUARKS
38234 130 CONTINUE
38235 IA=1
38236 JA=2
38237 EI=KCHG(IABS(IA),1)/3D0
38238 T3I=SIGN(1D0,EI+1D-6)/2D0
38239 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
38240 XXC(6)=1D6
38241 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
38242 CXC(2)=DCMPLX(0D0,0D0)
38243 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
38244 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
38245 CXC(5)=-DCMPLX(EI/XW1)*ORPP
38246 CXC(6)=DCMPLX(0D0,0D0)
38247 CXC(7)=-DCMPLX(EI/XW1)*OLPP
38248 CXC(8)=DCMPLX(0D0,0D0)
38249 IF( XXC(5).LT.AXMI ) THEN
38250 XXC(5)=1D6
38251 ENDIF
38252 XXC(7)=XXC(5)
38253 XXC(8)=XXC(6)
38254 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
38255 LKNT=LKNT+1
38256 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
38257 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38258 IDLAM(LKNT,1)=KFCCHI(1)
38259 IDLAM(LKNT,2)=1
38260 IDLAM(LKNT,3)=-1
38261 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
38262 LKNT=LKNT+1
38263 XLAM(LKNT)=XLAM(LKNT-1)
38264 IDLAM(LKNT,1)=KFCCHI(1)
38265 IDLAM(LKNT,2)=3
38266 IDLAM(LKNT,3)=-3
38267 ENDIF
38268 ENDIF
38269 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
38270 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
38271 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
38272 ELSE
38273 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
38274 ENDIF
38275 IF( XXC(5).LT.AXMI ) THEN
38276 XXC(5)=1D6
38277 ENDIF
38278 XXC(7)=XXC(5)
38279 LKNT=LKNT+1
38280 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
38281 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38282 IDLAM(LKNT,1)=KFCCHI(1)
38283 IDLAM(LKNT,2)=5
38284 IDLAM(LKNT,3)=-5
38285 ENDIF
38286
38287C...U-TYPE QUARKS
38288 140 CONTINUE
38289 IA=2
38290 JA=1
38291 EI=KCHG(IABS(IA),1)/3D0
38292 T3I=SIGN(1D0,EI+1D-6)/2D0
38293 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
38294 XXC(6)=1D6
38295 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
38296 CXC(2)=DCMPLX(0D0,0D0)
38297 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
38298 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
38299 CXC(5)=-DCMPLX(EI/XW1)*ORPP
38300 CXC(6)=DCMPLX(0D0,0D0)
38301 CXC(7)=-DCMPLX(EI/XW1)*OLPP
38302 CXC(8)=DCMPLX(0D0,0D0)
38303 IF( XXC(5).LT.AXMI ) THEN
38304 XXC(5)=1D6
38305 ENDIF
38306 XXC(7)=XXC(5)
38307 XXC(8)=XXC(6)
38308 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
38309 LKNT=LKNT+1
38310 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
38311 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38312 IDLAM(LKNT,1)=KFCCHI(1)
38313 IDLAM(LKNT,2)=2
38314 IDLAM(LKNT,3)=-2
38315 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
38316 LKNT=LKNT+1
38317 XLAM(LKNT)=XLAM(LKNT-1)
38318 IDLAM(LKNT,1)=KFCCHI(1)
38319 IDLAM(LKNT,2)=4
38320 IDLAM(LKNT,3)=-4
38321 ENDIF
38322 ENDIF
38323 150 CONTINUE
38324 ENDIF
38325
38326C...CHI_2+ -> CHI_1+ + H0_K
38327 EH(2)=COS(ALFA)
38328 EH(1)=SIN(ALFA)
38329 EH(3)=-SBETA
38330 DH(2)=-SIN(ALFA)
38331 DH(1)=COS(ALFA)
38332 DH(3)=COS(BETA)
38333 DO 160 IH=1,3
38334 XMH=PMAS(ITH(IH),1)
38335 XMH2=XMH**2
38336C...NO 3-BODY OPTION
38337 IF(AXMI.GE.AXMJ+XMH) THEN
38338 LKNT=LKNT+1
38339 XL=PYLAMF(XMI2,XMJ2,XMH2)
38340 OLPP=(VMIXC(2,1)*DCONJG(UMIXC(1,2))*EH(IH) -
38341 & VMIXC(2,2)*DCONJG(UMIXC(1,1))*DH(IH))/SR2
38342 ORPP=(DCONJG(VMIXC(1,1))*UMIXC(2,2)*EH(IH) -
38343 & DCONJG(VMIXC(1,2))*UMIXC(2,1)*DH(IH))/SR2
38344 XMK=XMJ*ETAH(IH)
38345 GX2=ABS(OLPP)**2+ABS(ORPP)**2
38346 GLR=DBLE(OLPP*DCONJG(ORPP))
38347 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
38348 IDLAM(LKNT,1)=KFCCHI(1)
38349 IDLAM(LKNT,2)=ITH(IH)
38350 IDLAM(LKNT,3)=0
38351 ENDIF
38352 160 CONTINUE
38353
38354C...CHI1 JUMPS TO HERE
38355 170 CONTINUE
38356
38357C...CHI+_I -> CHI0_J + W+
38358 DO 220 IJ=1,4
38359 XMJ=SMZ(IJ)
38360 AXMJ=ABS(XMJ)
38361 XMJ2=XMJ**2
38362 IF(AXMI.GE.AXMJ+XMW) THEN
38363 LKNT=LKNT+1
38364 DO 180 I=1,4
38365 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
38366 180 CONTINUE
38367 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
38368 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)
38369 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
38370 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)
38371 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
38372 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
38373 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
38374 IDLAM(LKNT,1)=KFNCHI(IJ)
38375 IDLAM(LKNT,2)=24
38376 IDLAM(LKNT,3)=0
38377C...LEPTONS
38378 ELSEIF(AXMI.GE.AXMJ) THEN
38379 S12MIN=0D0
38380 S12MAX=(AXMI-AXMJ)**2
38381 DO 190 I=1,4
38382 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
38383 190 CONTINUE
38384 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
38385 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)/SR2
38386 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
38387 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)/SR2
38388 CXC(5)=DCMPLX(0D0,0D0)
38389 CXC(7)=DCMPLX(0D0,0D0)
38390 IA=11
38391 JA=12
38392 EI=KCHG(IA,1)/3D0
38393 T3I=SIGN(1D0,EI+1D-6)/2D0
38394 EJ=KCHG(JA,1)/3D0
38395 T3J=SIGN(1D0,EJ+1D-6)/2D0
38396 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
38397 & TANW+ZMIXC(IJ,2)*T3J)/SR2
38398 CXC(4)=-DCONJG(UMIXC(IX,1))*(
38399 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)/SR2
38400 CXC(6)=DCMPLX(0D0,0D0)
38401 CXC(8)=DCMPLX(0D0,0D0)
38402 XXC(1)=0D0
38403 XXC(2)=XMJ
38404 XXC(3)=0D0
38405 XXC(4)=XMI
38406 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
38407 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
38408 XXC(9)=PMAS(24,1)
38409 XXC(10)=PMAS(24,2)
38410CCC IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
38411 IF(XXC(5).LT.AXMI) THEN
38412 XXC(5)=1D6
38413 ELSEIF(XXC(6).LT.AXMI) THEN
38414 XXC(6)=1D6
38415 ENDIF
38416 XXC(7)=XXC(6)
38417 XXC(8)=XXC(5)
38418C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
38419C...--> 1/(16PI)/M**3*(AEM/XW)**2
38420 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
38421 LKNT=LKNT+1
38422 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38423 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
38424 IDLAM(LKNT,1)=KFNCHI(IJ)
38425 IDLAM(LKNT,2)=-11
38426 IDLAM(LKNT,3)=12
38427C...ONLY DECAY CHI+1 -> E+ NU_E
38428 IF( IMSS(12).NE. 0 ) GOTO 260
38429 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
38430 LKNT=LKNT+1
38431 XLAM(LKNT)=XLAM(LKNT-1)
38432 IDLAM(LKNT,1)=KFNCHI(IJ)
38433 IDLAM(LKNT,2)=-13
38434 IDLAM(LKNT,3)=14
38435 ENDIF
38436 ENDIF
38437 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
38438 LKNT=LKNT+1
38439 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
38440 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
38441 ELSE
38442 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
38443 ENDIF
38444 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
38445 IF(XXC(5).LT.AXMI) THEN
38446 XXC(5)=1D6
38447 ELSEIF(XXC(6).LT.AXMI) THEN
38448 XXC(6)=1D6
38449 ENDIF
38450 XXC(7)=XXC(6)
38451 XXC(8)=XXC(5)
38452 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38453 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
38454 IDLAM(LKNT,1)=KFNCHI(IJ)
38455 IDLAM(LKNT,2)=-15
38456 IDLAM(LKNT,3)=16
38457 ENDIF
38458
38459C...NOW, DO THE QUARKS
38460 200 CONTINUE
38461 IA=1
38462 JA=2
38463 EI=KCHG(IA,1)/3D0
38464 T3I=SIGN(1D0,EI+1D-6)/2D0
38465 EJ=KCHG(JA,1)/3D0
38466 T3J=SIGN(1D0,EJ+1D-6)/2D0
38467 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
38468 & TANW+ZMIXC(IX,2)*T3J)
38469 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
38470 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)
38471 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
38472 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
38473 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 210
38474 IF(XXC(5).LT.AXMI) THEN
38475 XXC(5)=1D6
38476 ENDIF
38477 IF(XXC(6).LT.AXMI) THEN
38478 XXC(6)=1D6
38479 ENDIF
38480 XXC(7)=XXC(6)
38481 XXC(8)=XXC(5)
38482 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
38483 LKNT=LKNT+1
38484 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
38485 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38486 IDLAM(LKNT,1)=KFNCHI(IJ)
38487 IDLAM(LKNT,2)=-1
38488 IDLAM(LKNT,3)=2
38489 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
38490 LKNT=LKNT+1
38491 XLAM(LKNT)=XLAM(LKNT-1)
38492 IDLAM(LKNT,1)=KFNCHI(IJ)
38493 IDLAM(LKNT,2)=-3
38494 IDLAM(LKNT,3)=4
38495 ENDIF
38496 ENDIF
38497 210 CONTINUE
38498 ENDIF
38499 220 CONTINUE
38500
38501C...CHI+_I -> CHI0_J + H+
38502 DO 230 IJ=1,4
38503 XMJ=SMZ(IJ)
38504 AXMJ=ABS(XMJ)
38505 XMJ2=XMJ**2
38506 XMHP=PMAS(ITHC,1)
38507 IF(AXMI.GE.AXMJ+XMHP) THEN
38508 LKNT=LKNT+1
38509 OLPP=CBETA*(ZMIXC(IJ,4)*DCONJG(VMIXC(IX,1))+(ZMIXC(IJ,2)+
38510 & ZMIXC(IJ,1)*TANW)*DCONJG(VMIXC(IX,2))/SR2)
38511 ORPP=SBETA*(DCONJG(ZMIXC(IJ,3))*UMIXC(IX,1)-
38512 & (DCONJG(ZMIXC(IJ,2))+DCONJG(ZMIXC(IJ,1))*TANW)*
38513 & UMIXC(IX,2)/SR2)
38514 GX2=ABS(OLPP)**2+ABS(ORPP)**2
38515 GLR=DBLE(OLPP*DCONJG(ORPP))
38516 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
38517 IDLAM(LKNT,1)=KFNCHI(IJ)
38518 IDLAM(LKNT,2)=ITHC
38519 IDLAM(LKNT,3)=0
38520 ELSE
38521
38522 ENDIF
38523 230 CONTINUE
38524
38525C...2-BODY DECAYS TO FERMION SFERMION
38526 DO 240 J=1,16
38527 IF(J.GE.7.AND.J.LE.10) GOTO 240
38528 IF(MOD(J,2).EQ.0) THEN
38529 KF1=KSUSY1+J-1
38530 ELSE
38531 KF1=KSUSY1+J+1
38532 ENDIF
38533 KF2=KF1+KSUSY1
38534 XMSF1=PMAS(PYCOMP(KF1),1)
38535 XMSF2=PMAS(PYCOMP(KF2),1)
38536 XMF=PMAS(J,1)
38537 IF(J.LE.6) THEN
38538 FCOL=3D0
38539 ELSE
38540 FCOL=1D0
38541 ENDIF
38542
38543C...U~ D_L
38544 IF(MOD(J,2).EQ.0) THEN
38545 XMFP=PMAS(J-1,1)
38546 CAL=UMIXC(IX,1)
38547 CBL=-XMF*VMIXC(IX,2)/XMW/SBETA/SR2
38548 CAR=-XMFP*UMIXC(IX,2)/XMW/CBETA/SR2
38549 CBR=0D0
38550 ISF=J-1
38551 ELSE
38552 XMFP=PMAS(J+1,1)
38553 CAL=VMIXC(IX,1)
38554 CBL=-XMF*UMIXC(IX,2)/XMW/CBETA/SR2
38555 CBR=0D0
38556 CAR=-XMFP*VMIXC(IX,2)/XMW/SBETA/SR2
38557 ISF=J+1
38558 ENDIF
38559
38560C...~U_L D
38561 IF(AXMI.GE.XMF+XMSF1) THEN
38562 LKNT=LKNT+1
38563 XMA2=XMSF1**2
38564 XMB2=XMF**2
38565 XL=PYLAMF(XMI2,XMA2,XMB2)
38566 CA=CAL*SFMIX(ISF,1)+CAR*SFMIX(ISF,2)
38567 CB=CBL*SFMIX(ISF,1)+CBR*SFMIX(ISF,2)
38568 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
38569 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
38570 IDLAM(LKNT,3)=0
38571 IF(MOD(J,2).EQ.0) THEN
38572 IDLAM(LKNT,1)=-KF1
38573 IDLAM(LKNT,2)=J
38574 ELSE
38575 IDLAM(LKNT,1)=KF1
38576 IDLAM(LKNT,2)=-J
38577 ENDIF
38578 ENDIF
38579
38580C...U~ D_R
38581 IF(AXMI.GE.XMF+XMSF2) THEN
38582 LKNT=LKNT+1
38583 XMA2=XMSF2**2
38584 XMB2=XMF**2
38585 CA=CAL*SFMIX(ISF,3)+CAR*SFMIX(ISF,4)
38586 CB=CBL*SFMIX(ISF,3)+CBR*SFMIX(ISF,4)
38587 XL=PYLAMF(XMI2,XMA2,XMB2)
38588 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
38589 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
38590 IDLAM(LKNT,3)=0
38591 IF(MOD(J,2).EQ.0) THEN
38592 IDLAM(LKNT,1)=-KF2
38593 IDLAM(LKNT,2)=J
38594 ELSE
38595 IDLAM(LKNT,1)=KF2
38596 IDLAM(LKNT,2)=-J
38597 ENDIF
38598 ENDIF
38599 240 CONTINUE
38600
38601C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
38602C...A 2-BODY -- 2-BODY CHAIN
38603 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
38604 IF(AXMI.GE.XMJ) THEN
38605 AXMJ=ABS(XMJ)
38606 S12MIN=0D0
38607 S12MAX=(AXMI-AXMJ)**2
38608 XXC(1)=0D0
38609 XXC(2)=XMJ
38610 XXC(3)=0D0
38611 XXC(4)=XMI
38612 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
38613 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
38614 XXC(9)=1D6
38615 XXC(10)=0D0
38616 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
38617 ORPP=DCONJG(OLPP)
38618 CXC(1)=DCMPLX(0D0,0D0)
38619 CXC(3)=DCMPLX(0D0,0D0)
38620 CXC(5)=DCMPLX(0D0,0D0)
38621 CXC(7)=DCMPLX(0D0,0D0)
38622 CXC(2)=UMIXC(IX,1)*OLPP/SR2
38623 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
38624 CXC(6)=DCMPLX(0D0,0D0)
38625 CXC(8)=DCMPLX(0D0,0D0)
38626 IF(XXC(5).LT.AXMI) THEN
38627 XXC(5)=1D6
38628 ELSEIF(XXC(6).LT.AXMI) THEN
38629 XXC(6)=1D6
38630 ENDIF
38631 XXC(7)=XXC(6)
38632 XXC(8)=XXC(5)
38633 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 250
38634 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
38635 LKNT=LKNT+1
38636 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
38637 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38638 IDLAM(LKNT,1)=KSUSY1+21
38639 IDLAM(LKNT,2)=-1
38640 IDLAM(LKNT,3)=2
38641 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
38642 LKNT=LKNT+1
38643 XLAM(LKNT)=XLAM(LKNT-1)
38644 IDLAM(LKNT,1)=KSUSY1+21
38645 IDLAM(LKNT,2)=-3
38646 IDLAM(LKNT,3)=4
38647 ENDIF
38648 ENDIF
38649 250 CONTINUE
38650 ENDIF
38651
38652C...R-violating decay modes (SKANDS).
38653 CALL PYRVCH(KFIN,XLAM,IDLAM,LKNT)
38654
38655 260 IKNT=LKNT
38656 XLAM(0)=0D0
38657 DO 270 I=1,IKNT
38658 XLAM(0)=XLAM(0)+XLAM(I)
38659 IF(XLAM(I).LT.0D0) THEN
38660 WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN,
38661 & (IDLAM(I,J),J=1,3)
38662 XLAM(I)=0D0
38663 ENDIF
38664 270 CONTINUE
38665 IF(XLAM(0).EQ.0D0) THEN
38666 XLAM(0)=1D-6
38667 WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0)
38668 WRITE(MSTU(11),*) LKNT
38669 WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT)
38670 ENDIF
38671
38672 RETURN
38673 END
38674
38675C*********************************************************************
38676
38677C...PYXXZ6
38678C...Used in the calculation of inoi -> inoj + f + ~f.
38679
38680 FUNCTION PYXXZ6(X)
38681
38682C...Double precision and integer declarations.
38683 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38684 IMPLICIT INTEGER(I-N)
38685 INTEGER PYK,PYCHGE,PYCOMP
38686C...Parameter statement to help give large particle numbers.
38687 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
38688 &KEXCIT=4000000,KDIMEN=5000000)
38689C...Commonblocks.
38690 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38691C COMMON/PYINTS/XXM(20)
38692 COMPLEX*16 CXC
38693 COMMON/PYINTC/XXC(10),CXC(8)
38694 SAVE /PYDAT1/,/PYINTC/
38695
38696C...Local variables.
38697 COMPLEX*16 QLLS,QRRS,QRLS,QLRS,QLLU,QRRU,QLRT,QRLT
38698 DOUBLE PRECISION PYXXZ6,X
38699 DOUBLE PRECISION XM12,XM22,XM32,S,S13,WPROP2
38700 DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
38701 DOUBLE PRECISION SIJ
38702 DOUBLE PRECISION XMV,XMG,XMSU1,XMSU2,XMSD1,XMSD2
38703 DOUBLE PRECISION OL2
38704 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
38705 INTEGER I
38706
38707C...Statement functions.
38708C...Integral from x to y of (t-a)(b-t) dt.
38709 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
38710C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
38711 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
38712 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
38713C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
38714 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
38715 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
38716C...Integral from x to y of (t-a)/(b-t) dt.
38717 UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
38718C...Integral from x to y of 1/(t-a) dt.
38719 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
38720
38721 XM12=XXC(1)**2
38722 XM22=XXC(2)**2
38723 XM32=XXC(3)**2
38724 S=XXC(4)**2
38725 S13=X
38726
38727 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
38728 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
38729 &( (X-XM22-S)**2 -4D0*XM22*S ) )
38730
38731 S23MIN=(S23AVE-S23DEL)
38732 S23MAX=(S23AVE+S23DEL)
38733
38734 XMSD1=XXC(5)**2
38735 XMSD2=XXC(7)**2
38736 XMSU1=XXC(6)**2
38737 XMSU2=XXC(8)**2
38738
38739 XMV=XXC(9)
38740 XMG=XXC(10)
38741 QLLS=CXC(1)
38742 QLLU=CXC(2)
38743 QLRS=CXC(3)
38744 QLRT=CXC(4)
38745 QRLS=CXC(5)
38746 QRLT=CXC(6)
38747 QRRS=CXC(7)
38748 QRRU=CXC(8)
38749 WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
38750 SIJ=2D0*XXC(2)*XXC(4)*S13
38751 IF(XMV.LE.1000D0) THEN
38752 OL2=ABS(QLLS)**2+ABS(QRRS)**2+ABS(QLRS)**2+ABS(QRLS)**2
38753 OLR=-2D0*DBLE(QLRS*DCONJG(QLLS)+QRLS*DCONJG(QRRS))
38754 WW=(OL2*2D0*TINT(S23MAX,S23MIN,XM22,S)
38755 & +OLR*SIJ*(S23MAX-S23MIN))/WPROP2
38756 IF(XXC(5).LE.10000D0) THEN
38757 WFL1=4D0*(DBLE(QLLS*DCONJG(QLLU))*
38758 & TINT2(S23MAX,S23MIN,XM22,S,XMSD1)-
38759 & .5D0*DBLE(QLLS*DCONJG(QLRT))*SIJ*TPROP(S23MAX,S23MIN,XMSD2)+
38760 & DBLE(QLRS*DCONJG(QLRT))*TINT2(S23MAX,S23MIN,XM22,S,XMSD2)-
38761 & .5D0*DBLE(QLRS*DCONJG(QLLU))*SIJ*TPROP(S23MAX,S23MIN,XMSD1))
38762 & *(S13-XMV**2)/WPROP2
38763 ELSE
38764 WFL1=0D0
38765 ENDIF
38766
38767 IF(XXC(6).LE.10000D0) THEN
38768 WFL2=4D0*(DBLE(QRRS*DCONJG(QRRU))*
38769 & TINT2(S23MAX,S23MIN,XM22,S,XMSU1)-
38770 & .5D0*DBLE(QRRS*DCONJG(QRLT))*SIJ*TPROP(S23MAX,S23MIN,XMSU2)+
38771 & DBLE(QRLS*DCONJG(QRLT))*TINT2(S23MAX,S23MIN,XM22,S,XMSU2)-
38772 & .5D0*DBLE(QRLS*DCONJG(QRRU))*SIJ*TPROP(S23MAX,S23MIN,XMSU1))
38773 & *(S13-XMV**2)/WPROP2
38774 ELSE
38775 WFL2=0D0
38776 ENDIF
38777 ELSE
38778 WW=0D0
38779 WFL1=0D0
38780 WFL2=0D0
38781 ENDIF
38782 IF(XXC(5).LE.10000D0) THEN
38783 WF1=2D0*ABS(QLLU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD1)
38784 & +2D0*ABS(QLRT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD2)
38785 & - 2D0*DBLE(QLRT*DCONJG(QLLU))*
38786 & SIJ*UTINT(S23MAX,S23MIN,XMSD1,XM22+S-S13-XMSD2)
38787 ELSE
38788 WF1=0D0
38789 ENDIF
38790 IF(XXC(6).LE.10000D0) THEN
38791 WF2=2D0*ABS(QRRU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU1)
38792 & +2D0*ABS(QRLT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU2)
38793 & - 2D0*DBLE(QRLT*DCONJG(QRRU))*
38794 & SIJ*UTINT(S23MAX,S23MIN,XMSU1,XM22+S-S13-XMSU2)
38795 ELSE
38796 WF2=0D0
38797 ENDIF
38798
38799 PYXXZ6=(WW+WF1+WF2+WFL1+WFL2)
38800
38801 IF(PYXXZ6.LT.0D0) THEN
38802 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ6 '
38803 WRITE(MSTU(11),*) XXc(1),XXc(2),XXc(3),XXc(4)
38804 WRITE(MSTU(11),*) (XXc(I),I=5,8)
38805 WRITE(MSTU(11),*) (XXc(I),I=9,12)
38806 WRITE(MSTU(11),*) (XXc(I),I=13,16)
38807 WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2
38808 WRITE(MSTU(11),*) S23MIN,S23MAX
38809 PYXXZ6=0D0
38810 ENDIF
38811
38812 RETURN
38813 END
38814
38815
38816C*********************************************************************
38817
38818C...PYXXGA
38819C...Calculates chi0_i -> chi0_j + gamma.
38820
38821 FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL)
38822
38823C...Double precision and integer declarations.
38824 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38825 IMPLICIT INTEGER(I-N)
38826 INTEGER PYK,PYCHGE,PYCOMP
38827
38828C...Local variables.
38829 DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
38830 DOUBLE PRECISION F1,F2
38831
38832 F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR)
38833 F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL)
38834 PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3
38835 PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2
38836
38837 RETURN
38838 END
38839
38840C*********************************************************************
38841
38842C...PYX2XG
38843C...Calculates the decay rate for ino -> ino + gauge boson.
38844
38845 FUNCTION PYX2XG(C1,XM1,XM2,XM3,GX2,GLR)
38846
38847C...Double precision and integer declarations.
38848 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38849 IMPLICIT INTEGER(I-N)
38850 INTEGER PYK,PYCHGE,PYCOMP
38851
38852C...Local variables.
38853 DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GX2,GLR
38854 DOUBLE PRECISION XL,PYLAMF,C1
38855 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
38856
38857 XMI2=XM1**2
38858 XMI3=ABS(XM1**3)
38859 XMJ2=XM2**2
38860 XMV2=XM3**2
38861 XL=PYLAMF(XMI2,XMJ2,XMV2)
38862 PYX2XG=C1/8D0/XMI3*SQRT(XL)
38863 &*(GX2*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))-
38864 &12D0*GLR*XM1*XM2*XMV2)
38865
38866 RETURN
38867 END
38868
38869C*********************************************************************
38870
38871C...PYX2XH
38872C...Calculates the decay rate for ino -> ino + H.
38873
38874 FUNCTION PYX2XH(C1,XM1,XM2,XM3,GX2,GLR)
38875
38876C...Double precision and integer declarations.
38877 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38878 IMPLICIT INTEGER(I-N)
38879 INTEGER PYK,PYCHGE,PYCOMP
38880
38881C...Local variables.
38882 DOUBLE PRECISION PYX2XH,XM1,XM2,XM3
38883 DOUBLE PRECISION XL,PYLAMF,C1
38884 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
38885
38886 XMI2=XM1**2
38887 XMI3=ABS(XM1**3)
38888 XMJ2=XM2**2
38889 XMV2=XM3**2
38890 XL=PYLAMF(XMI2,XMJ2,XMV2)
38891 PYX2XH=C1/8D0/XMI3*SQRT(XL)
38892 &*(GX2*(XMI2+XMJ2-XMV2)+
38893 &4D0*GLR*XM1*XM2)
38894
38895 RETURN
38896 END
38897
38898C*********************************************************************
38899
38900C...PYHEXT
38901C...Calculates the non-standard decay modes of the Higgs boson.
38902C...
38903C...Author: Stephen Mrenna
38904C...Last Update: April 2001
38905C......Allow complex values for Z,U, and V
38906
38907 SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT)
38908
38909C...Double precision and integer declarations.
38910 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38911 IMPLICIT INTEGER(I-N)
38912 INTEGER PYK,PYCHGE,PYCOMP
38913C...Parameter statement to help give large particle numbers.
38914 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
38915 &KEXCIT=4000000,KDIMEN=5000000)
38916C...Commonblocks.
38917 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38918 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38919 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38920 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
38921 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
38922 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
38923 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/
38924
38925C...Local variables.
38926 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
38927 COMPLEX*16 QIJ,RIJ,F21K,F12K
38928 INTEGER KFIN
38929 DOUBLE PRECISION XMI,XMJ,XMF,XMW,XMW2,XMZ,AXMJ,AXMI
38930 DOUBLE PRECISION XMI2,XMI3,XMJ2
38931 DOUBLE PRECISION PYLAMF,XL,CF,EI
38932 INTEGER IDU,IFL
38933 DOUBLE PRECISION TANW,XW,AEM,C1,AS
38934 DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
38935 DOUBLE PRECISION XLAM(0:400)
38936 INTEGER IDLAM(400,3)
38937 INTEGER LKNT,IH,J,IJ,I,IKNT,IK
38938 INTEGER ITH(4)
38939 INTEGER KFNCHI(4),KFCCHI(2)
38940 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
38941 DOUBLE PRECISION SR2
38942 DOUBLE PRECISION BETA,ALFA
38943 DOUBLE PRECISION CBETA,SBETA,GR,GL,TANB
38944 DOUBLE PRECISION PYALEM
38945 DOUBLE PRECISION AL,AR,ALR
38946 DOUBLE PRECISION XMK,AXMK,COSA,SINA,CW,XML
38947 DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
38948 DOUBLE PRECISION XMJL,XMJR,XM1,XM2
38949 DATA ITH/25,35,36,37/
38950 DATA ETAH/1D0,1D0,-1D0/
38951 DATA SR2/1.4142136D0/
38952 DATA KFNCHI/1000022,1000023,1000025,1000035/
38953 DATA KFCCHI/1000024,1000037/
38954
38955C...COUNT THE NUMBER OF DECAY MODES
38956 LKNT=IKNT
38957
38958 XMW=PMAS(24,1)
38959 XMW2=XMW**2
38960 XMZ=PMAS(23,1)
38961 XW=PARU(102)
38962 TANW = SQRT(XW/(1D0-XW))
38963 CW=SQRT(1D0-XW)
38964
38965C...1 - 4 DEPENDING ON Higgs species.
38966 IH=1
38967 IF(KFIN.EQ.ITH(2)) IH=2
38968 IF(KFIN.EQ.ITH(3)) IH=3
38969 IF(KFIN.EQ.ITH(4)) IH=4
38970
38971 XMI=PMAS(KFIN,1)
38972 XMI2=XMI**2
38973 AXMI=ABS(XMI)
38974 AEM=PYALEM(XMI2)
38975 C1=AEM/XW
38976 XMI3=ABS(XMI**3)
38977
38978 TANB=RMSS(5)
38979 BETA=ATAN(TANB)
38980 CBETA=COS(BETA)
38981 SBETA=TANB*CBETA
38982 ALFA=RMSS(18)
38983 COSA=COS(ALFA)
38984 SINA=SIN(ALFA)
38985 ATRIT=RMSS(16)
38986 ATRIB=RMSS(15)
38987 ATRIL=RMSS(17)
38988 XMUZ=-RMSS(4)
38989
38990 DO 110 I=1,4
38991 DO 100 J=1,4
38992 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
38993 100 CONTINUE
38994 110 CONTINUE
38995 DO 130 I=1,2
38996 DO 120 J=1,2
38997 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
38998 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
38999 120 CONTINUE
39000 130 CONTINUE
39001
39002
39003 IF(IH.EQ.4) GOTO 220
39004
39005C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
39006C...H0_K -> CHI0_I + CHI0_J
39007 EH(2)=SINA
39008 EH(1)=COSA
39009 EH(3)=CBETA
39010 DH(2)=COSA
39011 DH(1)=-SINA
39012 DH(3)=SBETA
39013 DO 150 IJ=1,4
39014 XMJ=SMZ(IJ)
39015 AXMJ=ABS(XMJ)
39016 DO 140 IK=1,IJ
39017 XMK=SMZ(IK)
39018 AXMK=ABS(XMK)
39019 IF(AXMI.GE.AXMJ+AXMK) THEN
39020 LKNT=LKNT+1
39021 QIJ=ZMIXC(IK,3)*ZMIXC(IJ,2)+
39022 & ZMIXC(IJ,3)*ZMIXC(IK,2)-
39023 & TANW*(ZMIXC(IK,3)*ZMIXC(IJ,1)+
39024 & ZMIXC(IJ,3)*ZMIXC(IK,1))
39025 RIJ=ZMIXC(IK,4)*ZMIXC(IJ,2)+
39026 & ZMIXC(IJ,4)*ZMIXC(IK,2)-
39027 & TANW*(ZMIXC(IK,4)*ZMIXC(IJ,1)+
39028 & ZMIXC(IJ,4)*ZMIXC(IK,1))
39029 F21K=0.5D0*DCONJG(QIJ*DH(IH)-RIJ*EH(IH))
39030 F12K=0.5D0*(QIJ*DH(IH)-RIJ*EH(IH))
39031C...SIGN OF MASSES I,J
39032 XML=XMK*ETAH(IH)
39033 GX2=ABS(F12K)**2+ABS(F21K)**2
39034 GLR=DBLE(F12K*DCONJG(F21K))
39035 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
39036 IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0
39037 IDLAM(LKNT,1)=KFNCHI(IJ)
39038 IDLAM(LKNT,2)=KFNCHI(IK)
39039 IDLAM(LKNT,3)=0
39040 ENDIF
39041 140 CONTINUE
39042 150 CONTINUE
39043
39044C...H0_K -> CHI+_I CHI-_J
39045 DO 170 IJ=1,2
39046 XMJ=SMW(IJ)
39047 AXMJ=ABS(XMJ)
39048 DO 160 IK=1,2
39049 XMK=SMW(IK)
39050 AXMK=ABS(XMK)
39051 IF(AXMI.GE.AXMJ+AXMK) THEN
39052 LKNT=LKNT+1
39053 OLPP=DCONJG(VMIXC(IJ,1)*UMIXC(IK,2)*DH(IH) +
39054 & VMIXC(IJ,2)*UMIXC(IK,1)*EH(IH))/SR2
39055 ORPP=(VMIXC(IK,1)*UMIXC(IJ,2)*DH(IH) +
39056 & VMIXC(IK,2)*UMIXC(IJ,1)*EH(IH))/SR2
39057 GX2=ABS(OLPP)**2+ABS(ORPP)**2
39058 GLR=DBLE(OLPP*DCONJG(ORPP))
39059 XML=XMK*ETAH(IH)
39060 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
39061 IDLAM(LKNT,1)=KFCCHI(IJ)
39062 IDLAM(LKNT,2)=-KFCCHI(IK)
39063 IDLAM(LKNT,3)=0
39064 ENDIF
39065 160 CONTINUE
39066 170 CONTINUE
39067
39068C...HIGGS TO SFERMION SFERMION
39069 DO 200 IFL=1,16
39070 IF(IFL.GE.7.AND.IFL.LE.10) GOTO 200
39071 IJ=KSUSY1+IFL
39072 XMJL=PMAS(PYCOMP(IJ),1)
39073 XMJR=PMAS(PYCOMP(IJ+KSUSY1),1)
39074 IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN
39075 XMJ=XMJL
39076 XMJ2=XMJ**2
39077 XL=PYLAMF(XMI2,XMJ2,XMJ2)
39078 XMF=PMAS(IFL,1)
39079 EI=KCHG(IFL,1)/3D0
39080 IDU=2-MOD(IFL,2)
39081
39082 IF(IH.EQ.1) THEN
39083 IF(IDU.EQ.1) THEN
39084 GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+
39085 & XMF**2/XMW*SINA/CBETA
39086 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+
39087 & XMF**2/XMW*SINA/CBETA
39088 IF(IFL.EQ.5) THEN
39089 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
39090 & ATRIB*SINA)
39091 ELSEIF(IFL.EQ.15) THEN
39092 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
39093 & ATRIL*SINA)
39094 ELSE
39095 GHLR=0D0
39096 ENDIF
39097 ELSE
39098 GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)-
39099 & XMF**2/XMW*COSA/SBETA
39100 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)-
39101 & XMF**2/XMW*COSA/SBETA
39102 IF(IFL.EQ.6) THEN
39103 GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA-
39104 & ATRIT*COSA)
39105 ELSE
39106 GHLR=0D0
39107 ENDIF
39108 ENDIF
39109
39110 ELSEIF(IH.EQ.2) THEN
39111 IF(IDU.EQ.1) THEN
39112 GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)-
39113 & XMF**2/XMW*COSA/CBETA
39114 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
39115 & XMF**2/XMW*COSA/CBETA
39116 IF(IFL.EQ.5) THEN
39117 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
39118 & ATRIB*COSA)
39119 ELSEIF(IFL.EQ.15) THEN
39120 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
39121 & ATRIL*COSA)
39122 ELSE
39123 GHLR=0D0
39124 ENDIF
39125 ELSE
39126 GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)-
39127 & XMF**2/XMW*SINA/SBETA
39128 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
39129 & XMF**2/XMW*SINA/SBETA
39130 IF(IFL.EQ.6) THEN
39131 GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+
39132 & ATRIT*SINA)
39133 ELSE
39134 GHLR=0D0
39135 ENDIF
39136 ENDIF
39137
39138 ELSEIF(IH.EQ.3) THEN
39139 GHLL=0D0
39140 GHRR=0D0
39141 GHLR=0D0
39142 IF(IDU.EQ.1) THEN
39143 IF(IFL.EQ.5) THEN
39144 GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ)
39145 ELSEIF(IFL.EQ.15) THEN
39146 GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ)
39147 ENDIF
39148 ELSE
39149 IF(IFL.EQ.6) THEN
39150 GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ)
39151 ENDIF
39152 ENDIF
39153 ENDIF
39154 IF(IH.EQ.3) GOTO 180
39155
39156 AL=SFMIX(IFL,1)**2
39157 AR=SFMIX(IFL,2)**2
39158 ALR=SFMIX(IFL,1)*SFMIX(IFL,2)
39159 IF(IFL.LE.6) THEN
39160 CF=3D0
39161 ELSE
39162 CF=1D0
39163 ENDIF
39164
39165 IF(AXMI.GE.2D0*XMJ) THEN
39166 LKNT=LKNT+1
39167 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
39168 & (GHLL*AL+GHRR*AR
39169 & +2D0*GHLR*ALR)**2
39170 IDLAM(LKNT,1)=IJ
39171 IDLAM(LKNT,2)=-IJ
39172 IDLAM(LKNT,3)=0
39173 ENDIF
39174
39175 IF(AXMI.GE.2D0*XMJR) THEN
39176 LKNT=LKNT+1
39177 AL=SFMIX(IFL,3)**2
39178 AR=SFMIX(IFL,4)**2
39179 ALR=SFMIX(IFL,3)*SFMIX(IFL,4)
39180 XMJ=XMJR
39181 XMJ2=XMJ**2
39182 XL=PYLAMF(XMI2,XMJ2,XMJ2)
39183 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
39184 & (GHLL*AL+GHRR*AR
39185 & +2D0*GHLR*ALR)**2
39186 IDLAM(LKNT,1)=IJ+KSUSY1
39187 IDLAM(LKNT,2)=-(IJ+KSUSY1)
39188 IDLAM(LKNT,3)=0
39189 ENDIF
39190 180 CONTINUE
39191
39192 IF(AXMI.GE.XMJL+XMJR) THEN
39193 LKNT=LKNT+1
39194 AL=SFMIX(IFL,1)*SFMIX(IFL,3)
39195 AR=SFMIX(IFL,2)*SFMIX(IFL,4)
39196 ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3)
39197 XMJ=XMJR
39198 XMJ2=XMJ**2
39199 XL=PYLAMF(XMI2,XMJ2,XMJL**2)
39200 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
39201 & (GHLL*AL+GHRR*AR)**2
39202 IDLAM(LKNT,1)=IJ
39203 IDLAM(LKNT,2)=-(IJ+KSUSY1)
39204 IDLAM(LKNT,3)=0
39205 LKNT=LKNT+1
39206 IDLAM(LKNT,1)=-IJ
39207 IDLAM(LKNT,2)=IJ+KSUSY1
39208 IDLAM(LKNT,3)=0
39209 XLAM(LKNT)=XLAM(LKNT-1)
39210 ENDIF
39211 ENDIF
39212 190 CONTINUE
39213 200 CONTINUE
39214 210 CONTINUE
39215
39216 GOTO 270
39217 220 CONTINUE
39218
39219C...H+ -> CHI+_I + CHI0_J
39220 DO 240 IJ=1,4
39221 XMJ=SMZ(IJ)
39222 AXMJ=ABS(XMJ)
39223 XMJ2=XMJ**2
39224 DO 230 IK=1,2
39225 XMK=SMW(IK)
39226 AXMK=ABS(XMK)
39227 IF(AXMI.GE.AXMJ+AXMK) THEN
39228 LKNT=LKNT+1
39229 OLPP=CBETA*DCONJG(ZMIXC(IJ,4)*VMIXC(IK,1)+(ZMIXC(IJ,2)+
39230 & ZMIXC(IJ,1)*TANW)*VMIXC(IK,2)/SR2)
39231 ORPP=SBETA*(ZMIXC(IJ,3)*UMIXC(IK,1)-
39232 & (ZMIXC(IJ,2)+ZMIXC(IJ,1)*TANW)*UMIXC(IK,2)/SR2)
39233 GX2=ABS(OLPP)**2+ABS(ORPP)**2
39234 GLR=DBLE(OLPP*DCONJG(ORPP))
39235 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GX2,GLR)
39236 IDLAM(LKNT,1)=KFNCHI(IJ)
39237 IDLAM(LKNT,2)=KFCCHI(IK)
39238 IDLAM(LKNT,3)=0
39239 ENDIF
39240 230 CONTINUE
39241 240 CONTINUE
39242
39243 GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2)
39244 GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB)
39245 AL=0D0
39246 AR=0D0
39247 CF=3D0
39248
39249C...H+ -> T_1 B_1~
39250 XM1=PMAS(PYCOMP(KSUSY1+6),1)
39251 XM2=PMAS(PYCOMP(KSUSY1+5),1)
39252 IF(XMI.GE.XM1+XM2) THEN
39253 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39254 LKNT=LKNT+1
39255 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
39256 & (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2
39257 IDLAM(LKNT,1)=KSUSY1+6
39258 IDLAM(LKNT,2)=-(KSUSY1+5)
39259 IDLAM(LKNT,3)=0
39260 ENDIF
39261
39262C...H+ -> T_2 B_1~
39263 XM1=PMAS(PYCOMP(KSUSY2+6),1)
39264 XM2=PMAS(PYCOMP(KSUSY1+5),1)
39265 IF(XMI.GE.XM1+XM2) THEN
39266 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39267 LKNT=LKNT+1
39268 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
39269 & (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2
39270 IDLAM(LKNT,1)=KSUSY2+6
39271 IDLAM(LKNT,2)=-(KSUSY1+5)
39272 IDLAM(LKNT,3)=0
39273 ENDIF
39274
39275C...H+ -> T_1 B_2~
39276 XM1=PMAS(PYCOMP(KSUSY1+6),1)
39277 XM2=PMAS(PYCOMP(KSUSY2+5),1)
39278 IF(XMI.GE.XM1+XM2) THEN
39279 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39280 LKNT=LKNT+1
39281 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
39282 & (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2
39283 IDLAM(LKNT,1)=KSUSY1+6
39284 IDLAM(LKNT,2)=-(KSUSY2+5)
39285 IDLAM(LKNT,3)=0
39286 ENDIF
39287
39288C...H+ -> T_2 B_2~
39289 XM1=PMAS(PYCOMP(KSUSY2+6),1)
39290 XM2=PMAS(PYCOMP(KSUSY2+5),1)
39291 IF(XMI.GE.XM1+XM2) THEN
39292 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39293 LKNT=LKNT+1
39294 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
39295 & (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2
39296 IDLAM(LKNT,1)=KSUSY2+6
39297 IDLAM(LKNT,2)=-(KSUSY2+5)
39298 IDLAM(LKNT,3)=0
39299 ENDIF
39300
39301C...H+ -> UL DL~
39302 GL=-XMW/SR2*SIN(2D0*BETA)
39303 DO 250 IJ=1,3,2
39304 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
39305 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
39306 IF(XMI.GE.XM1+XM2) THEN
39307 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39308 LKNT=LKNT+1
39309 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
39310 IDLAM(LKNT,1)=-(KSUSY1+IJ)
39311 IDLAM(LKNT,2)=KSUSY1+IJ+1
39312 IDLAM(LKNT,3)=0
39313 ENDIF
39314 250 CONTINUE
39315
39316C...H+ -> EL~ NUL
39317 CF=1D0
39318 DO 260 IJ=11,13,2
39319 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
39320 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
39321 IF(XMI.GE.XM1+XM2) THEN
39322 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39323 LKNT=LKNT+1
39324 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
39325 IDLAM(LKNT,1)=-(KSUSY1+IJ)
39326 IDLAM(LKNT,2)=KSUSY1+IJ+1
39327 IDLAM(LKNT,3)=0
39328 ENDIF
39329 260 CONTINUE
39330
39331C...H+ -> TAU1 NUTAUL
39332 XM1=PMAS(PYCOMP(KSUSY1+15),1)
39333 XM2=PMAS(PYCOMP(KSUSY1+16),1)
39334 IF(XMI.GE.XM1+XM2) THEN
39335 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39336 LKNT=LKNT+1
39337 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,1)**2
39338 IDLAM(LKNT,1)=-(KSUSY1+15)
39339 IDLAM(LKNT,2)= KSUSY1+16
39340 IDLAM(LKNT,3)=0
39341 ENDIF
39342
39343C...H+ -> TAU2 NUTAUL
39344 XM1=PMAS(PYCOMP(KSUSY2+15),1)
39345 XM2=PMAS(PYCOMP(KSUSY1+16),1)
39346 IF(XMI.GE.XM1+XM2) THEN
39347 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39348 LKNT=LKNT+1
39349 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,3)**2
39350 IDLAM(LKNT,1)=-(KSUSY2+15)
39351 IDLAM(LKNT,2)= KSUSY1+16
39352 IDLAM(LKNT,3)=0
39353 ENDIF
39354
39355 270 CONTINUE
39356 IKNT=LKNT
39357 XLAM(0)=0D0
39358 DO 280 I=1,IKNT
39359 IF(XLAM(I).LE.0D0) XLAM(I)=0D0
39360 XLAM(0)=XLAM(0)+XLAM(I)
39361 280 CONTINUE
39362 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
39363
39364 RETURN
39365 END
39366
39367C*********************************************************************
39368
39369C...PYH2XX
39370C...Calculates the decay rate for a Higgs to an ino pair.
39371
39372 FUNCTION PYH2XX(C1,XM1,XM2,XM3,GX2,GLR)
39373
39374C...Double precision and integer declarations.
39375 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39376 IMPLICIT INTEGER(I-N)
39377 INTEGER PYK,PYCHGE,PYCOMP
39378C...Commonblocks.
39379 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39380 SAVE /PYDAT1/
39381
39382C...Local variables.
39383 DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
39384 DOUBLE PRECISION XL,PYLAMF,C1
39385 DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
39386
39387 XMI2=XM1**2
39388 XMI3=ABS(XM1**3)
39389 XMJ2=XM2**2
39390 XMK2=XM3**2
39391 XL=PYLAMF(XMI2,XMJ2,XMK2)
39392 PYH2XX=C1/4D0/XMI3*SQRT(XL)
39393 &*(GX2*(XMI2-XMJ2-XMK2)-
39394 &4D0*GLR*XM3*XM2)
39395 IF(PYH2XX.LT.0D0) THEN
39396 WRITE(MSTU(11),*) ' NEGATIVE WIDTH IN PYH2XX '
39397 WRITE(MSTU(11),*) XMI2,XMJ2,XMK2,GX2,GLR,XM1,XM2,XM3
39398 STOP
39399 ENDIF
39400
39401 RETURN
39402 END
39403
39404C*********************************************************************
39405
39406C...PYGAUS
39407C...Integration by adaptive Gaussian quadrature.
39408C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
39409
39410 FUNCTION PYGAUS(F, A, B, EPS)
39411
39412C...Double precision and integer declarations.
39413 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39414 IMPLICIT INTEGER(I-N)
39415 INTEGER PYK,PYCHGE,PYCOMP
39416
39417C...Local declarations.
39418 EXTERNAL F
39419 DOUBLE PRECISION F,W(12), X(12)
39420 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
39421 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
39422 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
39423 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
39424 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
39425 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
39426 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
39427 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
39428 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
39429 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
39430 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
39431 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
39432
39433C...The Gaussian quadrature algorithm.
39434 H = 0D0
39435 IF(B .EQ. A) GOTO 140
39436 CONST = 5D-3 / ABS(B-A)
39437 BB = A
39438 100 CONTINUE
39439 AA = BB
39440 BB = B
39441 110 CONTINUE
39442 C1 = 0.5D0*(BB+AA)
39443 C2 = 0.5D0*(BB-AA)
39444 S8 = 0D0
39445 DO 120 I = 1, 4
39446 U = C2*X(I)
39447 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
39448 120 CONTINUE
39449 S16 = 0D0
39450 DO 130 I = 5, 12
39451 U = C2*X(I)
39452 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
39453 130 CONTINUE
39454 S16 = C2*S16
39455 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
39456 H = H + S16
39457 IF(BB .NE. B) GOTO 100
39458 ELSE
39459 BB = C1
39460 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
39461 H = 0D0
39462 CALL PYERRM(18,'(PYGAUS:) too high accuracy required')
39463 GOTO 140
39464 ENDIF
39465 140 CONTINUE
39466 PYGAUS = H
39467
39468 RETURN
39469 END
39470
39471C*********************************************************************
39472
39473C...PYGAU2
39474C...Integration by adaptive Gaussian quadrature.
39475C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
39476C...Carbon copy of PYGAUS, but avoids having to use it recursively.
39477
39478 FUNCTION PYGAU2(F, A, B, EPS)
39479
39480C...Double precision and integer declarations.
39481 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39482 IMPLICIT INTEGER(I-N)
39483 INTEGER PYK,PYCHGE,PYCOMP
39484
39485C...Local declarations.
39486 EXTERNAL F
39487 DOUBLE PRECISION F,W(12), X(12)
39488 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
39489 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
39490 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
39491 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
39492 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
39493 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
39494 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
39495 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
39496 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
39497 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
39498 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
39499 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
39500
39501C...The Gaussian quadrature algorithm.
39502 H = 0D0
39503 IF(B .EQ. A) GOTO 140
39504 CONST = 5D-3 / ABS(B-A)
39505 BB = A
39506 100 CONTINUE
39507 AA = BB
39508 BB = B
39509 110 CONTINUE
39510 C1 = 0.5D0*(BB+AA)
39511 C2 = 0.5D0*(BB-AA)
39512 S8 = 0D0
39513 DO 120 I = 1, 4
39514 U = C2*X(I)
39515 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
39516 120 CONTINUE
39517 S16 = 0D0
39518 DO 130 I = 5, 12
39519 U = C2*X(I)
39520 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
39521 130 CONTINUE
39522 S16 = C2*S16
39523 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
39524 H = H + S16
39525 IF(BB .NE. B) GOTO 100
39526 ELSE
39527 BB = C1
39528 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
39529 H = 0D0
39530 CALL PYERRM(18,'(PYGAU2:) too high accuracy required')
39531 GOTO 140
39532 ENDIF
39533 140 CONTINUE
39534 PYGAU2 = H
39535
39536 RETURN
39537 END
39538
39539C*********************************************************************
39540
39541C...PYSIMP
39542C...Simpson formula for an integral.
39543
39544 FUNCTION PYSIMP(Y,X0,X1,N)
39545
39546C...Double precision and integer declarations.
39547 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39548 IMPLICIT INTEGER(I-N)
39549 INTEGER PYK,PYCHGE,PYCOMP
39550
39551C...Local variables.
39552 DOUBLE PRECISION Y,X0,X1,H,S
39553 DIMENSION Y(0:N)
39554
39555 S=0D0
39556 H=(X1-X0)/N
39557 DO 100 I=0,N-2,2
39558 S=S+Y(I)+4D0*Y(I+1)+Y(I+2)
39559 100 CONTINUE
39560 PYSIMP=S*H/3D0
39561
39562 RETURN
39563 END
39564
39565C*********************************************************************
39566
39567C...PYLAMF
39568C...The standard lambda function.
39569
39570 FUNCTION PYLAMF(X,Y,Z)
39571
39572C...Double precision and integer declarations.
39573 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39574 IMPLICIT INTEGER(I-N)
39575 INTEGER PYK,PYCHGE,PYCOMP
39576
39577C...Local variables.
39578 DOUBLE PRECISION PYLAMF,X,Y,Z
39579
39580 PYLAMF=(X-(Y+Z))**2-4D0*Y*Z
39581 IF(PYLAMF.LT.0D0) PYLAMF=0D0
39582
39583 RETURN
39584 END
39585
39586C*********************************************************************
39587
39588C...PYTBDY
39589C...Generates 3-body decays of gauginos.
39590
39591 SUBROUTINE PYTBDY(IDIN)
39592
39593C...Double precision and integer declarations.
39594 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39595 IMPLICIT INTEGER(I-N)
39596 INTEGER PYK,PYCHGE,PYCOMP
39597C...Parameter statement to help give large particle numbers.
39598 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
39599 &KEXCIT=4000000,KDIMEN=5000000)
39600C...Commonblocks.
39601 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
39602 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39603 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39604C COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
39605C COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39606 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
39607 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
39608C SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYSSMT/
39609 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSSMT/
39610
39611C...Local variables.
39612 DOUBLE PRECISION XM(5)
39613 COMPLEX*16 OLPP,ORPP,QLL,QLR,QRR,QRL,GLIJ,GRIJ,PROPZ
39614 COMPLEX*16 QLLS,QRRS,QLRS,QRLS,QLLU,QRRU,QLRT,QRLT
39615 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
39616 DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
39617 DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
39618 DOUBLE PRECISION CPHI1,SPHI1
39619 DOUBLE PRECISION S23DEL,EPS
39620 DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
39621 PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3)
39622 DOUBLE PRECISION F1,F2,X0,X1,X2,X3
39623 INTEGER INOID(4)
39624 DATA INOID/22,23,25,35/
39625 DATA EPS/1D-6/
39626
39627 ID=IDIN
39628 ISKIP=1
39629 XM(1)=P(N+1,5)
39630 XM(2)=P(N+2,5)
39631 XM(3)=P(N+3,5)
39632 XM(5)=P(ID,5)
39633
39634C...GENERATE S12
39635 S12MIN=(XM(1)+XM(2))**2
39636 S12MAX=(XM(5)-XM(3))**2
39637 YJACO1=S12MAX-S12MIN
39638
39639C...Initialize some parameters
39640 XW=PARU(102)
39641 XW1=1D0-XW
39642 TANW=SQRT(XW/XW1)
39643 IZID1=0
39644 IWID1=0
39645 IZID2=0
39646 IWID2=0
39647 DO 100 I1=1,4
39648 IF(MOD(K(N+1,2),KSUSY1).EQ.INOID(I1)) IZID1=I1
39649 IF(MOD(K(ID,2),KSUSY1).EQ.INOID(I1)) IZID2=I1
39650 100 CONTINUE
39651 IF(MOD(K(N+1,2),KSUSY1).EQ.24) IWID1=1
39652 IF(MOD(K(N+1,2),KSUSY1).EQ.37) IWID1=2
39653 IF(MOD(K(ID,2),KSUSY1).EQ.24) IWID2=1
39654 IF(MOD(K(ID,2),KSUSY1).EQ.37) IWID2=2
39655 IA=K(N+2,2)
39656 JA=K(N+3,2)
39657 ZM12=XM(5)**2
39658 ZM22=XM(1)**2
39659 EI=KCHG(IABS(IA),1)/3D0
39660 T3I=SIGN(1D0,EI+1D-6)/2D0
39661 IF(MAX(ABS(IA),ABS(JA)).EQ.6) THEN
39662 ISKIP=0
39663 ELSEIF(IZID1*IZID2.NE.0) THEN
39664 SQMZ=PMAS(23,1)**2
39665 GMMZ=PMAS(23,1)*PMAS(23,2)
39666 DO 110 I=1,4
39667 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
39668 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
39669 110 CONTINUE
39670 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
39671 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
39672 ORPP=DCONJG(OLPP)
39673 XLL2=PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
39674 XLR2=XLL2
39675 XRR2=PMAS(PYCOMP(KSUSY2+IABS(IA)),1)**2
39676 XRL2=XRR2
39677 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
39678 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
39679 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
39680 XM1M2=SMZ(IZID1)*SMZ(IZID2)
39681 QLLS=DCMPLX((T3I-EI*XW)/XW1)*OLPP
39682 QLLU=-GLIJ
39683 QLRS=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
39684 QLRT=DCONJG(GLIJ)
39685 QRLS=-DCMPLX((EI*XW)/XW1)*OLPP
39686 QRLT=GRIJ
39687 QRRS=DCMPLX((EI*XW)/XW1)*ORPP
39688 QRRU=-DCONJG(GRIJ)
39689 ELSEIF(IZID1*IWID2.NE.0.OR.IZID2*IWID1.NE.0) THEN
39690 IF(IZID1.NE.0) THEN
39691 XM1M2=SMZ(IZID1)*SMW(IWID2)
39692 IZID1=IWID2
39693 IZID2=IZID1
39694 ELSE
39695 XM1M2=SMZ(IZID2)*SMW(IWID1)
39696 IZID1=IWID1
39697 ENDIF
39698 RT2I = 1D0/SQRT(2D0)
39699 SQMZ=PMAS(24,1)**2
39700 GMMZ=PMAS(24,1)*PMAS(24,2)
39701 DO 120 I=1,2
39702 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
39703 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
39704 120 CONTINUE
39705 DO 130 I=1,4
39706 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
39707 130 CONTINUE
39708 QLLS=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
39709 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)
39710 QLRS=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
39711 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)
39712 EJ=KCHG(JA,1)/3D0
39713 T3J=SIGN(1D0,EJ+1D-6)/2D0
39714 QRLS=DCMPLX(0D0,0D0)
39715 QRLT=QRLS
39716 QRRS=QRLS
39717 QRRU=QRLS
39718 XRR2=1D6**2
39719 XRL2=XRR2
39720 XLR2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
39721 XLL2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
39722 IF(MOD(IA,2).EQ.0) THEN
39723 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
39724 & TANW+ZMIXC(IZID2,2)*T3I)
39725 QLRT=-DCONJG(UMIXC(IZID1,1))*(
39726 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
39727 ELSE
39728 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
39729 & TANW+ZMIXC(IZID2,2)*T3J)
39730 QLRT=-DCONJG(UMIXC(IZID1,1))*(
39731 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
39732 ENDIF
39733 ELSEIF(IWID1*IWID2.NE.0) THEN
39734 IZID1=IWID1
39735 IZID2=IWID2
39736 XM1M2=SMW(IWID1)*SMW(IWID2)
39737 SQMZ=PMAS(23,1)**2
39738 GMMZ=PMAS(23,1)*PMAS(23,2)
39739 DO 140 I=1,2
39740 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
39741 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
39742 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
39743 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
39744 140 CONTINUE
39745 OLPP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
39746 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0
39747 ORPP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
39748 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0
39749 QRLS=-DCMPLX(EI/XW1)*ORPP
39750 QLLS=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
39751 QRRS=-DCMPLX(EI/XW1)*OLPP
39752 QLRS=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
39753 IF(MOD(IA,2).EQ.0) THEN
39754 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)-1),1)**2
39755 QLRT=-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*DCMPLX(T3I/XW)
39756 ELSE
39757 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)+1),1)**2
39758 QLRT=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*DCMPLX(T3I/XW)
39759 ENDIF
39760 ELSEIF(MOD(K(N+1,2),KSUSY1).EQ.21.OR.MOD(K(ID,2),KSUSY1).EQ.21)
39761 &THEN
39762 ISKIP=0
39763 ELSE
39764 ISKIP=0
39765 ENDIF
39766
39767 IF(ISKIP.NE.0) THEN
39768 WTMAX=0D0
39769 DO 160 KT=1,100
39770 S12=S12MIN+YJACO1*(KT-1)/99
39771 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
39772 & *(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
39773 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
39774 & -(2D0*XM(1)*XM(2))**2
39775 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
39776 & -(2D0*XM(3)*XM(5))**2
39777 S23DF1=S23DF1*EPS
39778 S23DF2=S23DF2*EPS
39779 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
39780 S23DEL=S23DEL/EPS
39781 S23MIN=S23AVE-S23DEL
39782 S23MAX=S23AVE+S23DEL
39783 YJACO2=S23MAX-S23MIN
39784 TH=S12
39785 DO 150 KS=1,100
39786 S23=S23MIN+YJACO2*(KS-1)/99
39787 SH=S23
39788 UH=ZM12+ZM22-SH-TH
39789 WU2 = (UH-ZM12)*(UH-ZM22)
39790 WT2 = (TH-ZM12)*(TH-ZM22)
39791 WS2 = XM1M2*SH
39792 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
39793 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
39794 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
39795 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
39796 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
39797 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
39798 WT0=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
39799 & (ABS(QRL)**2+ABS(QLR)**2)*WT2+
39800 & 2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
39801 IF(WT0.GT.WTMAX) WTMAX=WT0
39802 150 CONTINUE
39803 160 CONTINUE
39804
39805 WTMAX=WTMAX*1.05D0
39806 ENDIF
39807
39808C...FIND S12*
39809 AX=S12MIN
39810 CX=S12MAX
39811 BX=S12MIN+0.5D0*YJACO1
39812 X0=AX
39813 X3=CX
39814 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
39815 X1=BX
39816 X2=BX+C*(CX-BX)
39817 ELSE
39818 X2=BX
39819 X1=BX-C*(BX-AX)
39820 ENDIF
39821
39822C...SOLVE FOR F1 AND F2
39823 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
39824 &-(2D0*XM(1)*XM(2))**2
39825 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
39826 &-(2D0*XM(3)*XM(5))**2
39827 S23DF1=S23DF1*EPS
39828 S23DF2=S23DF2*EPS
39829 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
39830 F1=-2D0*S23DEL/EPS
39831 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
39832 &-(2D0*XM(1)*XM(2))**2
39833 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
39834 &-(2D0*XM(3)*XM(5))**2
39835 S23DF1=S23DF1*EPS
39836 S23DF2=S23DF2*EPS
39837 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
39838 F2=-2D0*S23DEL/EPS
39839
39840 170 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
39841C...Possibility of infinite loop with .LT.; changed to .LE. (SKANDS)
39842 IF(F2.LE.F1)THEN
39843 X0=X1
39844 X1=X2
39845 X2=R*X1+C*X3
39846 F1=F2
39847 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
39848 & -(2D0*XM(1)*XM(2))**2
39849 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
39850 & -(2D0*XM(3)*XM(5))**2
39851 S23DF1=S23DF1*EPS
39852 S23DF2=S23DF2*EPS
39853 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
39854 F2=-2D0*S23DEL/EPS
39855 ELSE
39856 X3=X2
39857 X2=X1
39858 X1=R*X2+C*X0
39859 F2=F1
39860 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
39861 & -(2D0*XM(1)*XM(2))**2
39862 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
39863 & -(2D0*XM(3)*XM(5))**2
39864 S23DF1=S23DF1*EPS
39865 S23DF2=S23DF2*EPS
39866 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
39867 F1=-2D0*S23DEL/EPS
39868 ENDIF
39869 GOTO 170
39870 ENDIF
39871C...WE WANT THE MAXIMUM, NOT THE MINIMUM
39872 IF(F1.LT.F2)THEN
39873 GOLDEN=-F1
39874 XMIN=X1
39875 ELSE
39876 GOLDEN=-F2
39877 XMIN=X2
39878 ENDIF
39879
39880 IKNT=0
39881 180 S12=S12MIN+PYR(0)*YJACO1
39882 IKNT=IKNT+1
39883C...GENERATE S23
39884 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
39885 &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
39886 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
39887 &-(2D0*XM(1)*XM(2))**2
39888 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
39889 &-(2D0*XM(3)*XM(5))**2
39890 S23DF1=S23DF1*EPS
39891 S23DF2=S23DF2*EPS
39892 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
39893 S23DEL=S23DEL/EPS
39894 S23MIN=S23AVE-S23DEL
39895 S23MAX=S23AVE+S23DEL
39896 YJACO2=S23MAX-S23MIN
39897 S23=S23MIN+PYR(0)*YJACO2
39898
39899C...CHECK THE SAMPLING
39900 IF(IKNT.GT.100) THEN
39901 WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY '
39902 GOTO 190
39903 ENDIF
39904 IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 180
39905
39906 IF(ISKIP.EQ.0) GOTO 190
39907
39908 SH=S23
39909 TH=S12
39910 UH=ZM12+ZM22-SH-TH
39911
39912 WU2 = (UH-ZM12)*(UH-ZM22)
39913 WT2 = (TH-ZM12)*(TH-ZM22)
39914 WS2 = XM1M2*SH
39915 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
39916 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
39917
39918 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
39919 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
39920 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
39921 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
39922c QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
39923c QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
39924c &/DCMPLX(TH-XML2)
39925c QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
39926c QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
39927c &-DCONJG(GRIJ)/DCMPLX(UH-XMR2)
39928 WT=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
39929 &(ABS(QRL)**2+ABS(QLR)**2)*WT2+
39930 &2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
39931
39932 IF(WT.LT.PYR(0)*WTMAX) GOTO 180
39933 IF(WT.GT.WTMAX) PRINT*,' WT > WTMAX ',WT,WTMAX
39934
39935 190 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5))
39936 D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5))
39937 D2=XM(5)-D1-D3
39938 P1=SQRT(D1*D1-XM(1)**2)
39939 P2=SQRT(D2*D2-XM(2)**2)
39940 P3=SQRT(D3*D3-XM(3)**2)
39941 CTHE1=2D0*PYR(0)-1D0
39942 ANG1=2D0*PYR(0)*PARU(1)
39943 CPHI1=COS(ANG1)
39944 SPHI1=SIN(ANG1)
39945 ARG=1D0-CTHE1**2
39946 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
39947 STHE1=SQRT(ARG)
39948 P(N+1,1)=P1*STHE1*CPHI1
39949 P(N+1,2)=P1*STHE1*SPHI1
39950 P(N+1,3)=P1*CTHE1
39951 P(N+1,4)=D1
39952
39953C...GET CPHI3
39954 ANG3=2D0*PYR(0)*PARU(1)
39955 CPHI3=COS(ANG3)
39956 SPHI3=SIN(ANG3)
39957 CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3
39958 ARG=1D0-CTHE3**2
39959 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
39960 STHE3=SQRT(ARG)
39961 P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1
39962 &+P3*STHE3*SPHI3*SPHI1
39963 &+P3*CTHE3*STHE1*CPHI1
39964 P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1
39965 &-P3*STHE3*SPHI3*CPHI1
39966 &+P3*CTHE3*STHE1*SPHI1
39967 P(N+3,3)=P3*STHE3*CPHI3*STHE1
39968 &+P3*CTHE3*CTHE1
39969 P(N+3,4)=D3
39970
39971 DO 200 I=1,3
39972 P(N+2,I)=-P(N+1,I)-P(N+3,I)
39973 200 CONTINUE
39974 P(N+2,4)=D2
39975
39976 RETURN
39977 END
39978
39979C*********************************************************************
39980
39981C...PYTECM
39982C...Finds the s-hat dependent eigenvalues of the inverse propagator
39983C...matrix for gamma, Z, techni-rho, and techni-omega to optimize the
39984C...phase space generation.
39985
39986 SUBROUTINE PYTECM(S1,S2)
39987
39988C...Double precision and integer declarations.
39989 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39990 IMPLICIT INTEGER(I-N)
39991 INTEGER PYK,PYCHGE,PYCOMP
39992C...Parameter statement to help give large particle numbers.
39993 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
39994 &KEXCIT=4000000,KDIMEN=5000000)
39995C...Commonblocks.
39996 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39997 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39998 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39999 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
40000 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYTCSM/
40001
40002C...Local variables.
40003 DOUBLE PRECISION AR(4,4),WR(4),ZR(4,4),ZI(4,4),WORK(12,12),
40004 &AT(4,4),WI(4),FV1(4),FV2(4),FV3(4),sh,aem,tanw,ct2w,qupd,alprht,
40005 &far,fao,fzr,fzo,shr,R1,R2,S1,S2,WDTP(0:400),WDTE(0:400,0:5)
40006 INTEGER i,j,ierr
40007
40008 SH=PMAS(PYCOMP(KTECHN+113),1)**2
40009 AEM=PYALEM(SH)
40010
40011 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
40012 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
40013 QUPD=2D0*RTCM(2)-1D0
40014
40015 ALPRHT=2.91D0*(3D0/DBLE(ITCM(1)))
40016 FAR=SQRT(AEM/ALPRHT)
40017 FAO=FAR*QUPD
40018 FZR=FAR*CT2W
40019 FZO=-FAO*TANW
40020
40021 AR(1,1) = SH
40022 AR(2,2) = SH-PMAS(23,1)**2
40023 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+113),1)**2
40024 AR(4,4) = SH-PMAS(PYCOMP(KTECHN+223),1)**2
40025 AR(1,2) = 0D0
40026 AR(2,1) = 0D0
40027 AR(1,3) = -SH*FAR
40028 AR(3,1) = AR(1,3)
40029 AR(1,4) = -SH*FAO
40030 AR(4,1) = AR(1,4)
40031 AR(2,3) = -SH*FZR
40032 AR(3,2) = AR(2,3)
40033 AR(2,4) = -SH*FZO
40034 AR(4,2) = AR(2,4)
40035 AR(3,4) = 0D0
40036 AR(4,3) = 0D0
40037CCCCCCCC
40038 DO 110 I=1,4
40039 DO 100 J=1,4
40040 AT(I,J)=0D0
40041 100 CONTINUE
40042 110 CONTINUE
40043 SHR=SQRT(SH)
40044 CALL PYWIDT(23,SH,WDTP,WDTE)
40045 AT(2,2) = WDTP(0)*SHR
40046 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
40047 AT(3,3) = WDTP(0)*SHR
40048 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
40049 AT(4,4) = WDTP(0)*SHR
40050CCCC
40051 CALL PYEICG(4,4,AR,AT,WR,WI,0,ZR,ZI,FV1,FV2,FV3,IERR)
40052 DO 120 I=1,4
40053 WI(I)=SQRT(ABS(SH-WR(I)))
40054 WR(I)=ABS(WR(I))
40055 120 CONTINUE
40056 R1=MIN(WR(1),WR(2),WR(3),WR(4))
40057 R2=1D20
40058 S1=0D0
40059 S2=0D0
40060 DO 130 I=1,4
40061 IF(ABS(WR(I)-R1).LT.1D-6) THEN
40062 S1=WI(I)
40063 GOTO 130
40064 ENDIF
40065 IF(WR(I).LE.R2) THEN
40066 R2=WR(I)
40067 S2=WI(I)
40068 ENDIF
40069 130 CONTINUE
40070 S1=S1**2
40071 S2=S2**2
40072 RETURN
40073 END
40074
40075C*********************************************************************
40076
40077C...PYEIGC
40078C...Finds eigenvalues of a general complex matrix
40079C
40080C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
40081C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
40082C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
40083C OF A COMPLEX GENERAL MATRIX.
40084C
40085C ON INPUT
40086C
40087C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
40088C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
40089C DIMENSION STATEMENT.
40090C
40091C N IS THE ORDER OF THE MATRIX A=(AR,AI).
40092C
40093C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
40094C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
40095C
40096C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
40097C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
40098C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
40099C
40100C ON OUTPUT
40101C
40102C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
40103C RESPECTIVELY, OF THE EIGENVALUES.
40104C
40105C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
40106C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
40107C
40108C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
40109C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
40110C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO.
40111C
40112C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS.
40113C
40114C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
40115C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
40116C
40117C THIS VERSION DATED AUGUST 1983.
40118C
40119
40120 SUBROUTINE PYEICG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
40121
40122 INTEGER N,NM,IS1,IS2,IERR,MATZ
40123 DOUBLE PRECISION AR(4,4),AI(4,4),WR(4),WI(4),ZR(4,4),ZI(4,4),
40124 X FV1(4),FV2(4),FV3(4)
40125 IF (N .LE. NM) GOTO 100
40126 IERR = 10 * N
40127 GOTO 120
40128C
40129 100 CALL PYCBAL(NM,N,AR,AI,IS1,IS2,FV1)
40130 CALL PYCRTH(NM,N,IS1,IS2,AR,AI,FV2,FV3)
40131 IF (MATZ .NE. 0) GOTO 110
40132C .......... FIND EIGENVALUES ONLY ..........
40133 CALL PYCMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR)
40134 GOTO 120
40135C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
40136 110 CALL PYCMQ2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR)
40137 IF (IERR .NE. 0) GOTO 120
40138 CALL PYCBA2(NM,N,IS1,IS2,FV1,N,ZR,ZI)
40139 120 RETURN
40140 END
40141
40142C*********************************************************************
40143
40144C...PYCMQR
40145C...Auxiliary to PYEICG.
40146C
40147C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
40148C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
40149C AND WILKINSON.
40150C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
40151C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
40152C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
40153C
40154C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
40155C UPPER HESSENBERG MATRIX BY THE QR METHOD.
40156C
40157C ON INPUT
40158C
40159C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
40160C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
40161C DIMENSION STATEMENT.
40162C
40163C N IS THE ORDER OF THE MATRIX.
40164C
40165C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
40166C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
40167C SET LOW=1, IGH=N.
40168C
40169C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
40170C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
40171C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
40172C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
40173C THE REDUCTION BY CORTH, IF PERFORMED.
40174C
40175C ON OUTPUT
40176C
40177C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
40178C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE
40179C CALLING COMQR IF SUBSEQUENT CALCULATION OF
40180C EIGENVECTORS IS TO BE PERFORMED.
40181C
40182C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
40183C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
40184C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
40185C FOR INDICES IERR+1,...,N.
40186C
40187C IERR IS SET TO
40188C ZERO FOR NORMAL RETURN,
40189C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
40190C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
40191C
40192C CALLS PYCDIV FOR COMPLEX DIVISION.
40193C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
40194C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
40195C
40196C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
40197C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
40198C
40199C THIS VERSION DATED AUGUST 1983.
40200C
40201
40202 SUBROUTINE PYCMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
40203
40204 INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
40205 DOUBLE PRECISION HR(4,4),HI(4,4),WR(4),WI(4)
40206 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
40207 X PYTHAG
40208
40209 IERR = 0
40210 IF (LOW .EQ. IGH) GOTO 130
40211C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
40212 L = LOW + 1
40213C
40214 DO 120 I = L, IGH
40215 LL = MIN0(I+1,IGH)
40216 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 120
40217 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
40218 YR = HR(I,I-1) / NORM
40219 YI = HI(I,I-1) / NORM
40220 HR(I,I-1) = NORM
40221 HI(I,I-1) = 0.0D0
40222C
40223 DO 100 J = I, IGH
40224 SI = YR * HI(I,J) - YI * HR(I,J)
40225 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
40226 HI(I,J) = SI
40227 100 CONTINUE
40228C
40229 DO 110 J = LOW, LL
40230 SI = YR * HI(J,I) + YI * HR(J,I)
40231 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
40232 HI(J,I) = SI
40233 110 CONTINUE
40234C
40235 120 CONTINUE
40236C .......... STORE ROOTS ISOLATED BY CBAL ..........
40237 130 DO 140 I = 1, N
40238 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
40239 WR(I) = HR(I,I)
40240 WI(I) = HI(I,I)
40241 140 CONTINUE
40242C
40243 EN = IGH
40244 TR = 0.0D0
40245 TI = 0.0D0
40246 ITN = 30*N
40247C .......... SEARCH FOR NEXT EIGENVALUE ..........
40248 150 IF (EN .LT. LOW) GOTO 320
40249 ITS = 0
40250 ENM1 = EN - 1
40251C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
40252C FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
40253 160 DO 170 LL = LOW, EN
40254 L = EN + LOW - LL
40255 IF (L .EQ. LOW) GOTO 180
40256 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
40257 X + DABS(HR(L,L)) + DABS(HI(L,L))
40258 TST2 = TST1 + DABS(HR(L,L-1))
40259 IF (TST2 .EQ. TST1) GOTO 180
40260 170 CONTINUE
40261C .......... FORM SHIFT ..........
40262 180 IF (L .EQ. EN) GOTO 300
40263 IF (ITN .EQ. 0) GOTO 310
40264 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 200
40265 SR = HR(EN,EN)
40266 SI = HI(EN,EN)
40267 XR = HR(ENM1,EN) * HR(EN,ENM1)
40268 XI = HI(ENM1,EN) * HR(EN,ENM1)
40269 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 210
40270 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
40271 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
40272 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
40273 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 190
40274 ZZR = -ZZR
40275 ZZI = -ZZI
40276 190 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
40277 SR = SR - XR
40278 SI = SI - XI
40279 GOTO 210
40280C .......... FORM EXCEPTIONAL SHIFT ..........
40281 200 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
40282 SI = 0.0D0
40283C
40284 210 DO 220 I = LOW, EN
40285 HR(I,I) = HR(I,I) - SR
40286 HI(I,I) = HI(I,I) - SI
40287 220 CONTINUE
40288C
40289 TR = TR + SR
40290 TI = TI + SI
40291 ITS = ITS + 1
40292 ITN = ITN - 1
40293C .......... REDUCE TO TRIANGLE (ROWS) ..........
40294 LP1 = L + 1
40295C
40296 DO 240 I = LP1, EN
40297 SR = HR(I,I-1)
40298 HR(I,I-1) = 0.0D0
40299 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
40300 XR = HR(I-1,I-1) / NORM
40301 WR(I-1) = XR
40302 XI = HI(I-1,I-1) / NORM
40303 WI(I-1) = XI
40304 HR(I-1,I-1) = NORM
40305 HI(I-1,I-1) = 0.0D0
40306 HI(I,I-1) = SR / NORM
40307C
40308 DO 230 J = I, EN
40309 YR = HR(I-1,J)
40310 YI = HI(I-1,J)
40311 ZZR = HR(I,J)
40312 ZZI = HI(I,J)
40313 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
40314 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
40315 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
40316 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
40317 230 CONTINUE
40318C
40319 240 CONTINUE
40320C
40321 SI = HI(EN,EN)
40322 IF (SI .EQ. 0.0D0) GOTO 250
40323 NORM = PYTHAG(HR(EN,EN),SI)
40324 SR = HR(EN,EN) / NORM
40325 SI = SI / NORM
40326 HR(EN,EN) = NORM
40327 HI(EN,EN) = 0.0D0
40328C .......... INVERSE OPERATION (COLUMNS) ..........
40329 250 DO 280 J = LP1, EN
40330 XR = WR(J-1)
40331 XI = WI(J-1)
40332C
40333 DO 270 I = L, J
40334 YR = HR(I,J-1)
40335 YI = 0.0D0
40336 ZZR = HR(I,J)
40337 ZZI = HI(I,J)
40338 IF (I .EQ. J) GOTO 260
40339 YI = HI(I,J-1)
40340 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
40341 260 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
40342 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
40343 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
40344 270 CONTINUE
40345C
40346 280 CONTINUE
40347C
40348 IF (SI .EQ. 0.0D0) GOTO 160
40349C
40350 DO 290 I = L, EN
40351 YR = HR(I,EN)
40352 YI = HI(I,EN)
40353 HR(I,EN) = SR * YR - SI * YI
40354 HI(I,EN) = SR * YI + SI * YR
40355 290 CONTINUE
40356C
40357 GOTO 160
40358C .......... A ROOT FOUND ..........
40359 300 WR(EN) = HR(EN,EN) + TR
40360 WI(EN) = HI(EN,EN) + TI
40361 EN = ENM1
40362 GOTO 150
40363C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
40364C CONVERGED AFTER 30*N ITERATIONS ..........
40365 310 IERR = EN
40366 320 RETURN
40367 END
40368
40369C*********************************************************************
40370
40371C...PYCMQ2
40372C...Auxiliary to PYEICG.
40373C
40374C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
40375C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
40376C AND WILKINSON.
40377C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
40378C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
40379C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
40380C
40381C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
40382C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
40383C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
40384C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE
40385C THIS GENERAL MATRIX TO HESSENBERG FORM.
40386C
40387C ON INPUT
40388C
40389C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
40390C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
40391C DIMENSION STATEMENT.
40392C
40393C N IS THE ORDER OF THE MATRIX.
40394C
40395C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
40396C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
40397C SET LOW=1, IGH=N.
40398C
40399C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
40400C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED.
40401C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS
40402C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
40403C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
40404C
40405C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
40406C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
40407C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
40408C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
40409C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF
40410C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
40411C ARBITRARY.
40412C
40413C ON OUTPUT
40414C
40415C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
40416C HAVE BEEN DESTROYED.
40417C
40418C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
40419C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
40420C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
40421C FOR INDICES IERR+1,...,N.
40422C
40423C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
40424C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS
40425C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF
40426C THE EIGENVECTORS HAS BEEN FOUND.
40427C
40428C IERR IS SET TO
40429C ZERO FOR NORMAL RETURN,
40430C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
40431C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
40432C
40433C CALLS PYCDIV FOR COMPLEX DIVISION.
40434C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
40435C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
40436C
40437C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
40438C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
40439C
40440C THIS VERSION DATED OCTOBER 1989.
40441C
40442C MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG)
40443C MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG)
40444C
40445
40446 SUBROUTINE PYCMQ2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
40447
40448 INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
40449 X ITN,ITS,LOW,LP1,ENM1,IEND,IERR
40450 DOUBLE PRECISION HR(4,4),HI(4,4),WR(4),WI(4),ZR(4,4),ZI(4,4),
40451 X ORTR(4),ORTI(4)
40452 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
40453 X PYTHAG
40454
40455 IERR = 0
40456C .......... INITIALIZE EIGENVECTOR MATRIX ..........
40457 DO 110 J = 1, N
40458C
40459 DO 100 I = 1, N
40460 ZR(I,J) = 0.0D0
40461 ZI(I,J) = 0.0D0
40462 100 CONTINUE
40463 ZR(J,J) = 1.0D0
40464 110 CONTINUE
40465C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
40466C FROM THE INFORMATION LEFT BY CORTH ..........
40467 IEND = IGH - LOW - 1
40468 IF (IEND.LT.0) GOTO 220
40469 IF (IEND.EQ.0) GOTO 170
40470C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
40471 DO 160 II = 1, IEND
40472 I = IGH - II
40473 IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GOTO 160
40474 IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GOTO 160
40475C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
40476 NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I)
40477 IP1 = I + 1
40478C
40479 DO 120 K = IP1, IGH
40480 ORTR(K) = HR(K,I-1)
40481 ORTI(K) = HI(K,I-1)
40482 120 CONTINUE
40483C
40484 DO 150 J = I, IGH
40485 SR = 0.0D0
40486 SI = 0.0D0
40487C
40488 DO 130 K = I, IGH
40489 SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J)
40490 SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J)
40491 130 CONTINUE
40492C
40493 SR = SR / NORM
40494 SI = SI / NORM
40495C
40496 DO 140 K = I, IGH
40497 ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K)
40498 ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K)
40499 140 CONTINUE
40500C
40501 150 CONTINUE
40502C
40503 160 CONTINUE
40504C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
40505 170 L = LOW + 1
40506C
40507 DO 210 I = L, IGH
40508 LL = MIN0(I+1,IGH)
40509 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 210
40510 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
40511 YR = HR(I,I-1) / NORM
40512 YI = HI(I,I-1) / NORM
40513 HR(I,I-1) = NORM
40514 HI(I,I-1) = 0.0D0
40515C
40516 DO 180 J = I, N
40517 SI = YR * HI(I,J) - YI * HR(I,J)
40518 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
40519 HI(I,J) = SI
40520 180 CONTINUE
40521C
40522 DO 190 J = 1, LL
40523 SI = YR * HI(J,I) + YI * HR(J,I)
40524 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
40525 HI(J,I) = SI
40526 190 CONTINUE
40527C
40528 DO 200 J = LOW, IGH
40529 SI = YR * ZI(J,I) + YI * ZR(J,I)
40530 ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I)
40531 ZI(J,I) = SI
40532 200 CONTINUE
40533C
40534 210 CONTINUE
40535C .......... STORE ROOTS ISOLATED BY CBAL ..........
40536 220 DO 230 I = 1, N
40537 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 230
40538 WR(I) = HR(I,I)
40539 WI(I) = HI(I,I)
40540 230 CONTINUE
40541C
40542 EN = IGH
40543 TR = 0.0D0
40544 TI = 0.0D0
40545 ITN = 30*N
40546C .......... SEARCH FOR NEXT EIGENVALUE ..........
40547 240 IF (EN .LT. LOW) GOTO 430
40548 ITS = 0
40549 ENM1 = EN - 1
40550C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
40551C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
40552 250 DO 260 LL = LOW, EN
40553 L = EN + LOW - LL
40554 IF (L .EQ. LOW) GOTO 270
40555 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
40556 X + DABS(HR(L,L)) + DABS(HI(L,L))
40557 TST2 = TST1 + DABS(HR(L,L-1))
40558 IF (TST2 .EQ. TST1) GOTO 270
40559 260 CONTINUE
40560C .......... FORM SHIFT ..........
40561 270 IF (L .EQ. EN) GOTO 420
40562 IF (ITN .EQ. 0) GOTO 550
40563 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 290
40564 SR = HR(EN,EN)
40565 SI = HI(EN,EN)
40566 XR = HR(ENM1,EN) * HR(EN,ENM1)
40567 XI = HI(ENM1,EN) * HR(EN,ENM1)
40568 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 300
40569 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
40570 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
40571 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
40572 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 280
40573 ZZR = -ZZR
40574 ZZI = -ZZI
40575 280 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
40576 SR = SR - XR
40577 SI = SI - XI
40578 GOTO 300
40579C .......... FORM EXCEPTIONAL SHIFT ..........
40580 290 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
40581 SI = 0.0D0
40582C
40583 300 DO 310 I = LOW, EN
40584 HR(I,I) = HR(I,I) - SR
40585 HI(I,I) = HI(I,I) - SI
40586 310 CONTINUE
40587C
40588 TR = TR + SR
40589 TI = TI + SI
40590 ITS = ITS + 1
40591 ITN = ITN - 1
40592C .......... REDUCE TO TRIANGLE (ROWS) ..........
40593 LP1 = L + 1
40594C
40595 DO 330 I = LP1, EN
40596 SR = HR(I,I-1)
40597 HR(I,I-1) = 0.0D0
40598 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
40599 XR = HR(I-1,I-1) / NORM
40600 WR(I-1) = XR
40601 XI = HI(I-1,I-1) / NORM
40602 WI(I-1) = XI
40603 HR(I-1,I-1) = NORM
40604 HI(I-1,I-1) = 0.0D0
40605 HI(I,I-1) = SR / NORM
40606C
40607 DO 320 J = I, N
40608 YR = HR(I-1,J)
40609 YI = HI(I-1,J)
40610 ZZR = HR(I,J)
40611 ZZI = HI(I,J)
40612 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
40613 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
40614 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
40615 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
40616 320 CONTINUE
40617C
40618 330 CONTINUE
40619C
40620 SI = HI(EN,EN)
40621 IF (SI .EQ. 0.0D0) GOTO 350
40622 NORM = PYTHAG(HR(EN,EN),SI)
40623 SR = HR(EN,EN) / NORM
40624 SI = SI / NORM
40625 HR(EN,EN) = NORM
40626 HI(EN,EN) = 0.0D0
40627 IF (EN .EQ. N) GOTO 350
40628 IP1 = EN + 1
40629C
40630 DO 340 J = IP1, N
40631 YR = HR(EN,J)
40632 YI = HI(EN,J)
40633 HR(EN,J) = SR * YR + SI * YI
40634 HI(EN,J) = SR * YI - SI * YR
40635 340 CONTINUE
40636C .......... INVERSE OPERATION (COLUMNS) ..........
40637 350 DO 390 J = LP1, EN
40638 XR = WR(J-1)
40639 XI = WI(J-1)
40640C
40641 DO 370 I = 1, J
40642 YR = HR(I,J-1)
40643 YI = 0.0D0
40644 ZZR = HR(I,J)
40645 ZZI = HI(I,J)
40646 IF (I .EQ. J) GOTO 360
40647 YI = HI(I,J-1)
40648 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
40649 360 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
40650 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
40651 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
40652 370 CONTINUE
40653C
40654 DO 380 I = LOW, IGH
40655 YR = ZR(I,J-1)
40656 YI = ZI(I,J-1)
40657 ZZR = ZR(I,J)
40658 ZZI = ZI(I,J)
40659 ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
40660 ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
40661 ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
40662 ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
40663 380 CONTINUE
40664C
40665 390 CONTINUE
40666C
40667 IF (SI .EQ. 0.0D0) GOTO 250
40668C
40669 DO 400 I = 1, EN
40670 YR = HR(I,EN)
40671 YI = HI(I,EN)
40672 HR(I,EN) = SR * YR - SI * YI
40673 HI(I,EN) = SR * YI + SI * YR
40674 400 CONTINUE
40675C
40676 DO 410 I = LOW, IGH
40677 YR = ZR(I,EN)
40678 YI = ZI(I,EN)
40679 ZR(I,EN) = SR * YR - SI * YI
40680 ZI(I,EN) = SR * YI + SI * YR
40681 410 CONTINUE
40682C
40683 GOTO 250
40684C .......... A ROOT FOUND ..........
40685 420 HR(EN,EN) = HR(EN,EN) + TR
40686 WR(EN) = HR(EN,EN)
40687 HI(EN,EN) = HI(EN,EN) + TI
40688 WI(EN) = HI(EN,EN)
40689 EN = ENM1
40690 GOTO 240
40691C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
40692C VECTORS OF UPPER TRIANGULAR FORM ..........
40693 430 NORM = 0.0D0
40694C
40695 DO 440 I = 1, N
40696C
40697 DO 440 J = I, N
40698 TR = DABS(HR(I,J)) + DABS(HI(I,J))
40699 IF (TR .GT. NORM) NORM = TR
40700 440 CONTINUE
40701C
40702 IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GOTO 560
40703C .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
40704 DO 500 NN = 2, N
40705 EN = N + 2 - NN
40706 XR = WR(EN)
40707 XI = WI(EN)
40708 HR(EN,EN) = 1.0D0
40709 HI(EN,EN) = 0.0D0
40710 ENM1 = EN - 1
40711C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
40712 DO 490 II = 1, ENM1
40713 I = EN - II
40714 ZZR = 0.0D0
40715 ZZI = 0.0D0
40716 IP1 = I + 1
40717C
40718 DO 450 J = IP1, EN
40719 ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
40720 ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
40721 450 CONTINUE
40722C
40723 YR = XR - WR(I)
40724 YI = XI - WI(I)
40725 IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GOTO 470
40726 TST1 = NORM
40727 YR = TST1
40728 460 YR = 0.01D0 * YR
40729 TST2 = NORM + YR
40730 IF (TST2 .GT. TST1) GOTO 460
40731 470 CONTINUE
40732 CALL PYCDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
40733C .......... OVERFLOW CONTROL ..........
40734 TR = DABS(HR(I,EN)) + DABS(HI(I,EN))
40735 IF (TR .EQ. 0.0D0) GOTO 490
40736 TST1 = TR
40737 TST2 = TST1 + 1.0D0/TST1
40738 IF (TST2 .GT. TST1) GOTO 490
40739 DO 480 J = I, EN
40740 HR(J,EN) = HR(J,EN)/TR
40741 HI(J,EN) = HI(J,EN)/TR
40742 480 CONTINUE
40743C
40744 490 CONTINUE
40745C
40746 500 CONTINUE
40747C .......... END BACKSUBSTITUTION ..........
40748C .......... VECTORS OF ISOLATED ROOTS ..........
40749 DO 520 I = 1, N
40750 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 520
40751C
40752 DO 510 J = I, N
40753 ZR(I,J) = HR(I,J)
40754 ZI(I,J) = HI(I,J)
40755 510 CONTINUE
40756C
40757 520 CONTINUE
40758C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
40759C VECTORS OF ORIGINAL FULL MATRIX.
40760C FOR J=N STEP -1 UNTIL LOW DO -- ..........
40761 DO 540 JJ = LOW, N
40762 J = N + LOW - JJ
40763 M = MIN0(J,IGH)
40764C
40765 DO 540 I = LOW, IGH
40766 ZZR = 0.0D0
40767 ZZI = 0.0D0
40768C
40769 DO 530 K = LOW, M
40770 ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
40771 ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
40772 530 CONTINUE
40773C
40774 ZR(I,J) = ZZR
40775 ZI(I,J) = ZZI
40776 540 CONTINUE
40777C
40778 GOTO 560
40779C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
40780C CONVERGED AFTER 30*N ITERATIONS ..........
40781 550 IERR = EN
40782 560 RETURN
40783 END
40784
40785C*********************************************************************
40786
40787C...PYCDIV
40788C...Auxiliary to PYCMQR
40789C
40790C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
40791C
40792
40793 SUBROUTINE PYCDIV(AR,AI,BR,BI,CR,CI)
40794
40795 DOUBLE PRECISION AR,AI,BR,BI,CR,CI
40796 DOUBLE PRECISION S,ARS,AIS,BRS,BIS
40797
40798 S = DABS(BR) + DABS(BI)
40799 ARS = AR/S
40800 AIS = AI/S
40801 BRS = BR/S
40802 BIS = BI/S
40803 S = BRS**2 + BIS**2
40804 CR = (ARS*BRS + AIS*BIS)/S
40805 CI = (AIS*BRS - ARS*BIS)/S
40806 RETURN
40807 END
40808
40809C*********************************************************************
40810
40811C...PYCSRT
40812C...Auxiliary to PYCMQR
40813C
40814C (YR,YI) = COMPLEX DSQRT(XR,XI)
40815C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
40816C
40817
40818 SUBROUTINE PYCSRT(XR,XI,YR,YI)
40819
40820 DOUBLE PRECISION XR,XI,YR,YI
40821 DOUBLE PRECISION S,TR,TI,PYTHAG
40822
40823 TR = XR
40824 TI = XI
40825 S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR)))
40826 IF (TR .GE. 0.0D0) YR = S
40827 IF (TI .LT. 0.0D0) S = -S
40828 IF (TR .LE. 0.0D0) YI = S
40829 IF (TR .LT. 0.0D0) YR = 0.5D0*(TI/YI)
40830 IF (TR .GT. 0.0D0) YI = 0.5D0*(TI/YR)
40831 RETURN
40832 END
40833
40834 DOUBLE PRECISION FUNCTION PYTHAG(A,B)
40835 DOUBLE PRECISION A,B
40836C
40837C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
40838C
40839 DOUBLE PRECISION P,R,S,T,U
40840 P = DMAX1(DABS(A),DABS(B))
40841 IF (P .EQ. 0.0D0) GOTO 110
40842 R = (DMIN1(DABS(A),DABS(B))/P)**2
40843 100 CONTINUE
40844 T = 4.0D0 + R
40845 IF (T .EQ. 4.0D0) GOTO 110
40846 S = R/T
40847 U = 1.0D0 + 2.0D0*S
40848 P = U*P
40849 R = (S/U)**2 * R
40850 GOTO 100
40851 110 PYTHAG = P
40852 RETURN
40853 END
40854
40855C*********************************************************************
40856
40857C...PYCBAL
40858C...Auxiliary to PYEICG
40859C
40860C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
40861C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
40862C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
40863C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
40864C
40865C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
40866C EIGENVALUES WHENEVER POSSIBLE.
40867C
40868C ON INPUT
40869C
40870C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
40871C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
40872C DIMENSION STATEMENT.
40873C
40874C N IS THE ORDER OF THE MATRIX.
40875C
40876C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
40877C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
40878C
40879C ON OUTPUT
40880C
40881C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
40882C RESPECTIVELY, OF THE BALANCED MATRIX.
40883C
40884C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
40885C ARE EQUAL TO ZERO IF
40886C (1) I IS GREATER THAN J AND
40887C (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
40888C
40889C SCALE CONTAINS INFORMATION DETERMINING THE
40890C PERMUTATIONS AND SCALING FACTORS USED.
40891C
40892C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
40893C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
40894C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
40895C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN
40896C SCALE(J) = P(J), FOR J = 1,...,LOW-1
40897C = D(J,J) J = LOW,...,IGH
40898C = P(J) J = IGH+1,...,N.
40899C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
40900C THEN 1 TO LOW-1.
40901C
40902C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
40903C
40904C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
40905C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
40906C K,L HAVE BEEN REVERSED.)
40907C
40908C ARITHMETIC IS REAL THROUGHOUT.
40909C
40910C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
40911C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
40912C
40913C THIS VERSION DATED AUGUST 1983.
40914C
40915
40916 SUBROUTINE PYCBAL(NM,N,AR,AI,LOW,IGH,SCALE)
40917
40918 INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
40919 DOUBLE PRECISION AR(4,4),AI(4,4),SCALE(4)
40920 DOUBLE PRECISION C,F,G,R,S,B2,RADIX
40921 LOGICAL NOCONV
40922
40923 RADIX = 16.0D0
40924C
40925 B2 = RADIX * RADIX
40926 K = 1
40927 L = N
40928 GOTO 150
40929C .......... IN-LINE PROCEDURE FOR ROW AND
40930C COLUMN EXCHANGE ..........
40931 100 SCALE(M) = J
40932 IF (J .EQ. M) GOTO 130
40933C
40934 DO 110 I = 1, L
40935 F = AR(I,J)
40936 AR(I,J) = AR(I,M)
40937 AR(I,M) = F
40938 F = AI(I,J)
40939 AI(I,J) = AI(I,M)
40940 AI(I,M) = F
40941 110 CONTINUE
40942C
40943 DO 120 I = K, N
40944 F = AR(J,I)
40945 AR(J,I) = AR(M,I)
40946 AR(M,I) = F
40947 F = AI(J,I)
40948 AI(J,I) = AI(M,I)
40949 AI(M,I) = F
40950 120 CONTINUE
40951C
40952 130 IF(IEXC.EQ.1) GOTO 140
40953 IF(IEXC.EQ.2) GOTO 180
40954C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
40955C AND PUSH THEM DOWN ..........
40956 140 IF (L .EQ. 1) GOTO 320
40957 L = L - 1
40958C .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
40959 150 DO 170 JJ = 1, L
40960 J = L + 1 - JJ
40961C
40962 DO 160 I = 1, L
40963 IF (I .EQ. J) GOTO 160
40964 IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GOTO 170
40965 160 CONTINUE
40966C
40967 M = L
40968 IEXC = 1
40969 GOTO 100
40970 170 CONTINUE
40971C
40972 GOTO 190
40973C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
40974C AND PUSH THEM LEFT ..........
40975 180 K = K + 1
40976C
40977 190 DO 210 J = K, L
40978C
40979 DO 200 I = K, L
40980 IF (I .EQ. J) GOTO 200
40981 IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GOTO 210
40982 200 CONTINUE
40983C
40984 M = K
40985 IEXC = 2
40986 GOTO 100
40987 210 CONTINUE
40988C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
40989 DO 220 I = K, L
40990 220 SCALE(I) = 1.0D0
40991C .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
40992 230 NOCONV = .FALSE.
40993C
40994 DO 310 I = K, L
40995 C = 0.0D0
40996 R = 0.0D0
40997C
40998 DO 240 J = K, L
40999 IF (J .EQ. I) GOTO 240
41000 C = C + DABS(AR(J,I)) + DABS(AI(J,I))
41001 R = R + DABS(AR(I,J)) + DABS(AI(I,J))
41002 240 CONTINUE
41003C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
41004 IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GOTO 310
41005 G = R / RADIX
41006 F = 1.0D0
41007 S = C + R
41008 250 IF (C .GE. G) GOTO 260
41009 F = F * RADIX
41010 C = C * B2
41011 GOTO 250
41012 260 G = R * RADIX
41013 270 IF (C .LT. G) GOTO 280
41014 F = F / RADIX
41015 C = C / B2
41016 GOTO 270
41017C .......... NOW BALANCE ..........
41018 280 IF ((C + R) / F .GE. 0.95D0 * S) GOTO 310
41019 G = 1.0D0 / F
41020 SCALE(I) = SCALE(I) * F
41021 NOCONV = .TRUE.
41022C
41023 DO 290 J = K, N
41024 AR(I,J) = AR(I,J) * G
41025 AI(I,J) = AI(I,J) * G
41026 290 CONTINUE
41027C
41028 DO 300 J = 1, L
41029 AR(J,I) = AR(J,I) * F
41030 AI(J,I) = AI(J,I) * F
41031 300 CONTINUE
41032C
41033 310 CONTINUE
41034C
41035 IF (NOCONV) GOTO 230
41036C
41037 320 LOW = K
41038 IGH = L
41039 RETURN
41040 END
41041
41042C*********************************************************************
41043
41044C...PYCBA2
41045C...Auxiliary to PYEICG.
41046C
41047C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
41048C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
41049C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
41050C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
41051C
41052C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
41053C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
41054C BALANCED MATRIX DETERMINED BY CBAL.
41055C
41056C ON INPUT
41057C
41058C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
41059C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
41060C DIMENSION STATEMENT.
41061C
41062C N IS THE ORDER OF THE MATRIX.
41063C
41064C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL.
41065C
41066C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
41067C AND SCALING FACTORS USED BY CBAL.
41068C
41069C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
41070C
41071C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
41072C RESPECTIVELY, OF THE EIGENVECTORS TO BE
41073C BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
41074C
41075C ON OUTPUT
41076C
41077C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
41078C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
41079C IN THEIR FIRST M COLUMNS.
41080C
41081C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
41082C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
41083C
41084C THIS VERSION DATED AUGUST 1983.
41085C
41086
41087 SUBROUTINE PYCBA2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
41088
41089 INTEGER I,J,K,M,N,II,NM,IGH,LOW
41090 DOUBLE PRECISION SCALE(4),ZR(4,4),ZI(4,4)
41091 DOUBLE PRECISION S
41092
41093 IF (M .EQ. 0) GOTO 150
41094 IF (IGH .EQ. LOW) GOTO 120
41095C
41096 DO 110 I = LOW, IGH
41097 S = SCALE(I)
41098C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
41099C IF THE FOREGOING STATEMENT IS REPLACED BY
41100C S=1.0D0/SCALE(I). ..........
41101 DO 100 J = 1, M
41102 ZR(I,J) = ZR(I,J) * S
41103 ZI(I,J) = ZI(I,J) * S
41104 100 CONTINUE
41105C
41106 110 CONTINUE
41107C .......... FOR I=LOW-1 STEP -1 UNTIL 1,
41108C IGH+1 STEP 1 UNTIL N DO -- ..........
41109 120 DO 140 II = 1, N
41110 I = II
41111 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
41112 IF (I .LT. LOW) I = LOW - II
41113 K = SCALE(I)
41114 IF (K .EQ. I) GOTO 140
41115C
41116 DO 130 J = 1, M
41117 S = ZR(I,J)
41118 ZR(I,J) = ZR(K,J)
41119 ZR(K,J) = S
41120 S = ZI(I,J)
41121 ZI(I,J) = ZI(K,J)
41122 ZI(K,J) = S
41123 130 CONTINUE
41124C
41125 140 CONTINUE
41126C
41127 150 RETURN
41128 END
41129
41130C*********************************************************************
41131
41132C...PYCRTH
41133C...Auxiliary to PYEICG.
41134C
41135C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
41136C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
41137C BY MARTIN AND WILKINSON.
41138C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
41139C
41140C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
41141C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
41142C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
41143C UNITARY SIMILARITY TRANSFORMATIONS.
41144C
41145C ON INPUT
41146C
41147C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
41148C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
41149C DIMENSION STATEMENT.
41150C
41151C N IS THE ORDER OF THE MATRIX.
41152C
41153C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
41154C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
41155C SET LOW=1, IGH=N.
41156C
41157C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
41158C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
41159C
41160C ON OUTPUT
41161C
41162C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
41163C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION
41164C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
41165C IS STORED IN THE REMAINING TRIANGLES UNDER THE
41166C HESSENBERG MATRIX.
41167C
41168C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
41169C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED.
41170C
41171C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
41172C
41173C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
41174C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
41175C
41176C THIS VERSION DATED AUGUST 1983.
41177C
41178
41179 SUBROUTINE PYCRTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
41180
41181 INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
41182 DOUBLE PRECISION AR(4,4),AI(4,4),ORTR(4),ORTI(4)
41183 DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG
41184
41185 LA = IGH - 1
41186 KP1 = LOW + 1
41187 IF (LA .LT. KP1) GOTO 210
41188C
41189 DO 200 M = KP1, LA
41190 H = 0.0D0
41191 ORTR(M) = 0.0D0
41192 ORTI(M) = 0.0D0
41193 SCALE = 0.0D0
41194C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
41195 DO 100 I = M, IGH
41196 100 SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1))
41197C
41198 IF (SCALE .EQ. 0.0D0) GOTO 200
41199 MP = M + IGH
41200C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
41201 DO 110 II = M, IGH
41202 I = MP - II
41203 ORTR(I) = AR(I,M-1) / SCALE
41204 ORTI(I) = AI(I,M-1) / SCALE
41205 H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I)
41206 110 CONTINUE
41207C
41208 G = DSQRT(H)
41209 F = PYTHAG(ORTR(M),ORTI(M))
41210 IF (F .EQ. 0.0D0) GOTO 120
41211 H = H + F * G
41212 G = G / F
41213 ORTR(M) = (1.0D0 + G) * ORTR(M)
41214 ORTI(M) = (1.0D0 + G) * ORTI(M)
41215 GOTO 130
41216C
41217 120 ORTR(M) = G
41218 AR(M,M-1) = SCALE
41219C .......... FORM (I-(U*UT)/H) * A ..........
41220 130 DO 160 J = M, N
41221 FR = 0.0D0
41222 FI = 0.0D0
41223C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
41224 DO 140 II = M, IGH
41225 I = MP - II
41226 FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J)
41227 FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J)
41228 140 CONTINUE
41229C
41230 FR = FR / H
41231 FI = FI / H
41232C
41233 DO 150 I = M, IGH
41234 AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I)
41235 AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I)
41236 150 CONTINUE
41237C
41238 160 CONTINUE
41239C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
41240 DO 190 I = 1, IGH
41241 FR = 0.0D0
41242 FI = 0.0D0
41243C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
41244 DO 170 JJ = M, IGH
41245 J = MP - JJ
41246 FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J)
41247 FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J)
41248 170 CONTINUE
41249C
41250 FR = FR / H
41251 FI = FI / H
41252C
41253 DO 180 J = M, IGH
41254 AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J)
41255 AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J)
41256 180 CONTINUE
41257C
41258 190 CONTINUE
41259C
41260 ORTR(M) = SCALE * ORTR(M)
41261 ORTI(M) = SCALE * ORTI(M)
41262 AR(M,M-1) = -G * AR(M,M-1)
41263 AI(M,M-1) = -G * AI(M,M-1)
41264 200 CONTINUE
41265C
41266 210 RETURN
41267 END
41268
41269C*********************************************************************
41270
41271C...PYLDCM
41272C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
41273C...processes.
41274
41275 SUBROUTINE PYLDCM(A,N,NP,INDX,D)
41276 IMPLICIT NONE
41277 INTEGER N,NP,INDX(N)
41278 REAL*8 D,TINY
41279 COMPLEX*16 A(NP,NP)
41280 PARAMETER (TINY=1.0D-20)
41281 INTEGER I,IMAX,J,K
41282 REAL*8 AAMAX,VV(6),DUM
41283 COMPLEX*16 SUM,DUMC
41284
41285 D=1D0
41286 DO 110 I=1,N
41287 AAMAX=0D0
41288 DO 100 J=1,N
41289 IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
41290 100 CONTINUE
41291 IF (AAMAX.EQ.0D0) PAUSE 'SINGULAR MATRIX IN PYLDCM'
41292 VV(I)=1D0/AAMAX
41293 110 CONTINUE
41294 DO 180 J=1,N
41295 DO 130 I=1,J-1
41296 SUM=A(I,J)
41297 DO 120 K=1,I-1
41298 SUM=SUM-A(I,K)*A(K,J)
41299 120 CONTINUE
41300 A(I,J)=SUM
41301 130 CONTINUE
41302 AAMAX=0D0
41303 DO 150 I=J,N
41304 SUM=A(I,J)
41305 DO 140 K=1,J-1
41306 SUM=SUM-A(I,K)*A(K,J)
41307 140 CONTINUE
41308 A(I,J)=SUM
41309 DUM=VV(I)*ABS(SUM)
41310 IF (DUM.GE.AAMAX) THEN
41311 IMAX=I
41312 AAMAX=DUM
41313 ENDIF
41314 150 CONTINUE
41315 IF (J.NE.IMAX)THEN
41316 DO 160 K=1,N
41317 DUMC=A(IMAX,K)
41318 A(IMAX,K)=A(J,K)
41319 A(J,K)=DUMC
41320 160 CONTINUE
41321 D=-D
41322 VV(IMAX)=VV(J)
41323 ENDIF
41324 INDX(J)=IMAX
41325 IF(ABS(A(J,J)).EQ.0D0) A(J,J)=DCMPLX(TINY,0D0)
41326 IF(J.NE.N)THEN
41327 DO 170 I=J+1,N
41328 A(I,J)=A(I,J)/A(J,J)
41329 170 CONTINUE
41330 ENDIF
41331 180 CONTINUE
41332
41333 RETURN
41334 END
41335
41336C*********************************************************************
41337
41338C...PYBKSB
41339C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
41340C...processes.
41341
41342 SUBROUTINE PYBKSB(A,N,NP,INDX,B)
41343 IMPLICIT NONE
41344 INTEGER N,NP,INDX(N)
41345 COMPLEX*16 A(NP,NP),B(N)
41346 INTEGER I,II,J,LL
41347 COMPLEX*16 SUM
41348
41349 II=0
41350 DO 110 I=1,N
41351 LL=INDX(I)
41352 SUM=B(LL)
41353 B(LL)=B(I)
41354 IF (II.NE.0)THEN
41355 DO 100 J=II,I-1
41356 SUM=SUM-A(I,J)*B(J)
41357 100 CONTINUE
41358 ELSE IF (ABS(SUM).NE.0D0) THEN
41359 II=I
41360 ENDIF
41361 B(I)=SUM
41362 110 CONTINUE
41363 DO 130 I=N,1,-1
41364 SUM=B(I)
41365 DO 120 J=I+1,N
41366 SUM=SUM-A(I,J)*B(J)
41367 120 CONTINUE
41368 B(I)=SUM/A(I,I)
41369 130 CONTINUE
41370 RETURN
41371 END
41372
41373C***********************************************************************
41374
41375C...PYWIDX
41376C...Calculates full and partial widths of resonances.
41377C....copy of PYWIDT, used for techniparticle widths
41378
41379 SUBROUTINE PYWIDX(KFLR,SH,WDTP,WDTE)
41380
41381C...Double precision and integer declarations.
41382 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41383 IMPLICIT INTEGER(I-N)
41384 INTEGER PYK,PYCHGE,PYCOMP
41385C...Parameter statement to help give large particle numbers.
41386 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
41387 &KEXCIT=4000000,KDIMEN=5000000)
41388C...Commonblocks.
41389 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41390 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41391 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
41392 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
41393 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
41394 COMMON/PYINT1/MINT(400),VINT(400)
41395 COMMON/PYINT4/MWID(500),WIDS(500,5)
41396 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
41397 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
41398 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
41399 &/PYINT4/,/PYMSSM/,/PYTCSM/
41400C...Local arrays and saved variables.
41401 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
41402 &WID2SV(3,2)
41403 SAVE MOFSV,WIDWSV,WID2SV
41404 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
41405
41406C...Compressed code and sign; mass.
41407 KFLA=IABS(KFLR)
41408 KFLS=ISIGN(1,KFLR)
41409 KC=PYCOMP(KFLA)
41410 SHR=SQRT(SH)
41411 PMR=PMAS(KC,1)
41412
41413C...Reset width information.
41414 DO 110 I=0,200
41415 WDTP(I)=0D0
41416 DO 100 J=0,5
41417 WDTE(I,J)=0D0
41418 100 CONTINUE
41419 110 CONTINUE
41420
41421C...Common electroweak and strong constants.
41422 XW=PARU(102)
41423 XWV=XW
41424 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
41425 XW1=1D0-XW
41426 AEM=PYALEM(SH)
41427 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
41428 AS=PYALPS(SH)
41429 RADC=1D0+AS/PARU(1)
41430
41431 IF(KFLA.EQ.23) THEN
41432C...Z0:
41433 ICASE=1
41434 XWC=1D0/(16D0*XW*XW1)
41435 FAC=(AEM*XWC/3D0)*SHR
41436 120 CONTINUE
41437 DO 130 I=1,MDCY(KC,3)
41438 IDC=I+MDCY(KC,2)-1
41439 IF(MDME(IDC,1).LT.0) GOTO 130
41440 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
41441 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
41442 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130
41443 WID2=1D0
41444 IF(I.LE.8) THEN
41445C...Z0 -> q + qbar
41446 EF=KCHG(I,1)/3D0
41447 AF=SIGN(1D0,EF+0.1D0)
41448 VF=AF-4D0*EF*XWV
41449 FCOF=3D0*RADC
41450 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
41451 IF(I.EQ.6) WID2=WIDS(6,1)
41452 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
41453 ELSEIF(I.LE.16) THEN
41454C...Z0 -> l+ + l-, nu + nubar
41455 EF=KCHG(I+2,1)/3D0
41456 AF=SIGN(1D0,EF+0.1D0)
41457 VF=AF-4D0*EF*XWV
41458 FCOF=1D0
41459 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
41460 ENDIF
41461 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
41462 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
41463 & BE34
41464 WDTP(0)=WDTP(0)+WDTP(I)
41465 IF(MDME(IDC,1).GT.0) THEN
41466 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
41467 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
41468 & WDTE(I,MDME(IDC,1))
41469 WDTE(I,0)=WDTE(I,MDME(IDC,1))
41470 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
41471 ENDIF
41472 130 CONTINUE
41473
41474
41475 ELSEIF(KFLA.EQ.24) THEN
41476C...W+/-:
41477 FAC=(AEM/(24D0*XW))*SHR
41478 DO 140 I=1,MDCY(KC,3)
41479 IDC=I+MDCY(KC,2)-1
41480 IF(MDME(IDC,1).LT.0) GOTO 140
41481 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
41482 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
41483 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
41484 WID2=1D0
41485 IF(I.LE.16) THEN
41486C...W+/- -> q + qbar'
41487 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
41488 IF(KFLR.GT.0) THEN
41489 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
41490 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
41491 IF(I.GE.13) WID2=WID2*WIDS(7,3)
41492 ELSE
41493 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
41494 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
41495 IF(I.GE.13) WID2=WID2*WIDS(7,2)
41496 ENDIF
41497 ELSEIF(I.LE.20) THEN
41498C...W+/- -> l+/- + nu
41499 FCOF=1D0
41500 IF(KFLR.GT.0) THEN
41501 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
41502 ELSE
41503 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
41504 ENDIF
41505 ENDIF
41506 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
41507 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
41508 WDTP(0)=WDTP(0)+WDTP(I)
41509 IF(MDME(IDC,1).GT.0) THEN
41510 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
41511 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
41512 WDTE(I,0)=WDTE(I,MDME(IDC,1))
41513 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
41514 ENDIF
41515 140 CONTINUE
41516
41517C.....V8 -> quark anti-quark
41518 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
41519 FAC=AS/6D0*SHR
41520 TANT3=RTCM(21)
41521 IF(ITCM(2).EQ.0) THEN
41522 IMDL=1
41523 ELSEIF(ITCM(2).EQ.1) THEN
41524 IMDL=2
41525 ENDIF
41526 DO 150 I=1,MDCY(KC,3)
41527 IDC=I+MDCY(KC,2)-1
41528 IF(MDME(IDC,1).LT.0) GOTO 150
41529 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
41530 RM1=PM1**2/SH
41531 IF(RM1.GT.0.25D0) GOTO 150
41532 WID2=1D0
41533 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
41534 FMIX=1D0/TANT3**2
41535 ELSE
41536 FMIX=TANT3**2
41537 ENDIF
41538 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
41539 IF(I.EQ.6) WID2=WIDS(6,1)
41540 WDTP(0)=WDTP(0)+WDTP(I)
41541 IF(MDME(IDC,1).GT.0) THEN
41542 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
41543 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
41544 WDTE(I,0)=WDTE(I,MDME(IDC,1))
41545 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
41546 ENDIF
41547 150 CONTINUE
41548 ENDIF
41549
41550 RETURN
41551 END
41552
41553C*********************************************************************
41554
41555C...PYRVSF
41556C...Calculates R-violating decays of sfermions.
41557C...P. Z. Skands
41558
41559 SUBROUTINE PYRVSF(KFIN,XLAM,IDLAM,LKNT)
41560
41561C...Double precision and integer declarations.
41562 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41563 IMPLICIT INTEGER(I-N)
41564C...Parameter statement to help give large particle numbers.
41565 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
41566 &KEXCIT=4000000,KDIMEN=5000000)
41567C...Commonblocks.
41568 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41569 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
41570 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
41571 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
41572 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
41573C...Local variables.
41574 DOUBLE PRECISION XLAM(0:400)
41575 INTEGER IDLAM(400,3), PYCOMP
41576 SAVE /PYMSRV/,/PYSSMT/,/PYMSSM/,/PYDAT2/
41577
41578C...IS R-VIOLATION ON ?
41579 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
41580C...Mass eigenstate counter
41581 ICNT=INT(KFIN/KSUSY1)
41582C...SM KF code of SUSY particle
41583 KFSM=KFIN-ICNT*KSUSY1
41584C...Squared Sparticle Mass
41585 SM=PMAS(PYCOMP(KFIN),1)**2
41586C... Squared mass of top quark
41587 SMT=PMAS(PYCOMP(6),1)**2
41588C...IS L-VIOLATION ON ?
41589 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1)) THEN
41590C...SLEPTON -> NU(BAR) + LEPTON and UBAR + D
41591 IF(ICNT.NE.0.AND.(KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15))
41592 & THEN
41593 K=INT((KFSM-9)/2)
41594 DO 110 I=1,3
41595 DO 100 J=1,3
41596 IF(I.NE.J) THEN
41597C...~e,~mu,~tau -> nu_I + lepton-_J
41598 LKNT = LKNT+1
41599 IDLAM(LKNT,1)= 12 +2*(I-1)
41600 IDLAM(LKNT,2)= 11 +2*(J-1)
41601 IDLAM(LKNT,3)= 0
41602 XLAM(LKNT)=0D0
41603 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
41604 IF (IMSS(51).NE.0) XLAM(LKNT) =
41605 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41606C...KINEMATICS CHECK
41607 IF (XLAM(LKNT).EQ.0D0) THEN
41608 LKNT=LKNT-1
41609 ENDIF
41610 ENDIF
41611 100 CONTINUE
41612 110 CONTINUE
41613C...~e,~mu,~tau -> nu_Ibar + lepton-_K
41614 J=INT((KFSM-9)/2)
41615 DO 130 I=1,3
41616 IF(I.NE.J) THEN
41617 DO 120 K=1,3
41618 LKNT = LKNT+1
41619 IDLAM(LKNT,1)=-12 -2*(I-1)
41620 IDLAM(LKNT,2)= 11 +2*(K-1)
41621 IDLAM(LKNT,3)= 0
41622 XLAM(LKNT)=0D0
41623 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
41624 IF (IMSS(51).NE.0) XLAM(LKNT) =
41625 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41626C...KINEMATICS CHECK
41627 IF (XLAM(LKNT).EQ.0D0) THEN
41628 LKNT=LKNT-1
41629 ENDIF
41630 120 CONTINUE
41631 ENDIF
41632 130 CONTINUE
41633C...~e,~mu,~tau -> u_Jbar + d_K
41634 I=INT((KFSM-9)/2)
41635 DO 150 J=1,3
41636 DO 140 K=1,3
41637 LKNT = LKNT+1
41638 IDLAM(LKNT,1)=-2 -2*(J-1)
41639 IDLAM(LKNT,2)= 1 +2*(K-1)
41640 IDLAM(LKNT,3)= 0
41641 XLAM(LKNT)=0
41642 IF (IMSS(52).NE.0) THEN
41643C...Use massive top quark
41644 IF (IDLAM(LKNT,1).EQ.-6) THEN
41645 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2
41646 & * (SM-SMT)
41647 XLAM(LKNT) =
41648 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
41649C...If no top quark, all decay products massless
41650 ELSE
41651 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
41652 XLAM(LKNT) =
41653 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41654 ENDIF
41655C...KINEMATICS CHECK
41656 IF (XLAM(LKNT).EQ.0D0) THEN
41657 LKNT=LKNT-1
41658 ENDIF
41659 ENDIF
41660 140 CONTINUE
41661 150 CONTINUE
41662 ENDIF
41663C * SNEUTRINO -> LEPTON+ + LEPTON- and DBAR + D
41664C...No right-handed neutrinos
41665 IF(ICNT.EQ.1) THEN
41666 IF(KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16) THEN
41667 J=INT((KFSM-10)/2)
41668 DO 170 I=1,3
41669 DO 160 K=1,3
41670 IF (I.NE.J) THEN
41671C...~nu_J -> lepton+_I + lepton-_K
41672 LKNT = LKNT+1
41673 IDLAM(LKNT,1)=-11 -2*(I-1)
41674 IDLAM(LKNT,2)= 11 +2*(K-1)
41675 IDLAM(LKNT,3)= 0
41676 XLAM(LKNT)=0D0
41677 RM2=RVLAM(I,J,K)**2 * SM
41678 IF (IMSS(51).NE.0) XLAM(LKNT) =
41679 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41680C...KINEMATICS CHECK
41681 IF (XLAM(LKNT).EQ.0D0) THEN
41682 LKNT=LKNT-1
41683 ENDIF
41684 ENDIF
41685 160 CONTINUE
41686 170 CONTINUE
41687C...~nu_I -> dbar_J + d_K
41688 I=INT((KFSM-10)/2)
41689 DO 190 J=1,3
41690 DO 180 K=1,3
41691 LKNT = LKNT+1
41692 IDLAM(LKNT,1)=-1 -2*(J-1)
41693 IDLAM(LKNT,2)= 1 +2*(K-1)
41694 IDLAM(LKNT,3)= 0
41695 XLAM(LKNT)=0D0
41696 RM2=3*RVLAMP(I,J,K)**2 * SM
41697 IF (IMSS(52).NE.0) XLAM(LKNT) =
41698 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41699C...KINEMATICS CHECK
41700 IF (XLAM(LKNT).EQ.0D0) THEN
41701 LKNT=LKNT-1
41702 ENDIF
41703 180 CONTINUE
41704 190 CONTINUE
41705 ENDIF
41706 ENDIF
41707C * SDOWN -> NU(BAR) + D and LEPTON- + U
41708 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
41709 J=INT((KFSM+1)/2)
41710 DO 210 I=1,3
41711 DO 200 K=1,3
41712C...~d_J -> nu_Ibar + d_K
41713 LKNT = LKNT+1
41714 IDLAM(LKNT,1)=-12 -2*(I-1)
41715 IDLAM(LKNT,2)= 1 +2*(K-1)
41716 IDLAM(LKNT,3)= 0
41717 XLAM(LKNT)=0D0
41718 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
41719 IF (IMSS(52).NE.0) XLAM(LKNT) =
41720 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41721C...KINEMATICS CHECK
41722 IF (XLAM(LKNT).EQ.0D0) THEN
41723 LKNT=LKNT-1
41724 ENDIF
41725 200 CONTINUE
41726 210 CONTINUE
41727 K=INT((KFSM+1)/2)
41728 DO 240 I=1,3
41729 DO 230 J=1,3
41730C...~d_K -> nu_I + d_J
41731 LKNT = LKNT+1
41732 IDLAM(LKNT,1)= 12 +2*(I-1)
41733 IDLAM(LKNT,2)= 1 +2*(J-1)
41734 IDLAM(LKNT,3)= 0
41735 XLAM(LKNT)=0D0
41736 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
41737 IF (IMSS(52).NE.0) XLAM(LKNT) =
41738 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41739C...KINEMATICS CHECK
41740 IF (XLAM(LKNT).EQ.0D0) THEN
41741 LKNT=LKNT-1
41742 ENDIF
41743C...~d_K -> lepton_I- + u_J
41744 220 LKNT = LKNT+1
41745 IDLAM(LKNT,1)= 11 +2*(I-1)
41746 IDLAM(LKNT,2)= 2 +2*(J-1)
41747 IDLAM(LKNT,3)= 0
41748 XLAM(LKNT)=0D0
41749 IF (IMSS(52).NE.0) THEN
41750C...Use massive top quark
41751 IF (IDLAM(LKNT,2).EQ.6) THEN
41752 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT)
41753 XLAM(LKNT) =
41754 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,2)
41755C...If no top quark, all decay products massless
41756 ELSE
41757 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
41758 XLAM(LKNT) =
41759 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41760 ENDIF
41761C...KINEMATICS CHECK
41762 IF (XLAM(LKNT).EQ.0D0) THEN
41763 LKNT=LKNT-1
41764 ENDIF
41765 ENDIF
41766 230 CONTINUE
41767 240 CONTINUE
41768 ENDIF
41769C * SUP -> LEPTON+ + D
41770 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
41771 J=NINT(KFSM/2.)
41772 DO 260 I=1,3
41773 DO 250 K=1,3
41774C...~u_J -> lepton_I+ + d_K
41775 LKNT = LKNT+1
41776 IDLAM(LKNT,1)=-11 -2*(I-1)
41777 IDLAM(LKNT,2)= 1 +2*(K-1)
41778 IDLAM(LKNT,3)= 0
41779 XLAM(LKNT)=0D0
41780 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
41781 IF (IMSS(52).NE.0) XLAM(LKNT) =
41782 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41783C...KINEMATICS CHECK
41784 IF (XLAM(LKNT).EQ.0D0) THEN
41785 LKNT=LKNT-1
41786 ENDIF
41787 250 CONTINUE
41788 260 CONTINUE
41789 ENDIF
41790 ENDIF
41791C...BARYON NUMBER VIOLATING DECAYS
41792 IF (IMSS(53).GE.1) THEN
41793C * SUP -> DBAR + DBAR
41794 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
41795 I = KFSM/2
41796 DO 280 J=1,3
41797 DO 270 K=1,3
41798C...~u_I -> dbar_J + dbar_K
41799 IF (J.LT.K) THEN
41800C...(anti-) symmetry J <-> K.
41801 LKNT = LKNT + 1
41802 IDLAM(LKNT,1) = -1 -2*(J-1)
41803 IDLAM(LKNT,2) = -1 -2*(K-1)
41804 IDLAM(LKNT,3) = 0
41805 XLAM(LKNT) = 0D0
41806 RM2 = 2.*(RVLAMB(I,J,K)**2)
41807 & * SFMIX(KFSM,2*ICNT)**2 * SM
41808 XLAM(LKNT) =
41809 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41810C...KINEMATICS CHECK
41811 IF (XLAM(LKNT).EQ.0D0) THEN
41812 LKNT = LKNT-1
41813 ENDIF
41814 ENDIF
41815 270 CONTINUE
41816 280 CONTINUE
41817 ENDIF
41818C * SDOWN -> UBAR + DBAR
41819 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
41820 K=(KFSM+1)/2
41821 DO 300 I=1,3
41822 DO 290 J=1,3
41823C...LAMB coupling antisymmetric in J and K.
41824 IF (J.NE.K) THEN
41825C...~d_K -> ubar_I + dbar_K
41826 LKNT = LKNT + 1
41827 IDLAM(LKNT,1)= -2 -2*(I-1)
41828 IDLAM(LKNT,2)= -1 -2*(J-1)
41829 IDLAM(LKNT,3)= 0
41830 XLAM(LKNT)=0D0
41831C...Use massive top quark
41832 IF (IDLAM(LKNT,1).EQ.-6) THEN
41833 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT
41834 & )
41835 XLAM(LKNT) =
41836 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
41837C...If no top quark, all decay products massless
41838 ELSE
41839 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
41840 XLAM(LKNT) =
41841 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41842 ENDIF
41843C...KINEMATICS CHECK
41844 IF (XLAM(LKNT).EQ.0D0) THEN
41845 LKNT=LKNT-1
41846 ENDIF
41847 ENDIF
41848 290 CONTINUE
41849 300 CONTINUE
41850 ENDIF
41851 ENDIF
41852 ENDIF
41853
41854 RETURN
41855 END
41856
41857C*********************************************************************
41858
41859C...PYRVNE
41860C...Calculates R-violating neutralino decay widths (pure 1->3 parts).
41861C...P. Z. Skands
41862
41863 SUBROUTINE PYRVNE(KFIN,XLAM,IDLAM,LKNT)
41864
41865C...Double precision and integer declarations.
41866 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41867 IMPLICIT INTEGER(I-N)
41868C...Parameter statement to help give large particle numbers.
41869 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
41870 &KEXCIT=4000000,KDIMEN=5000000)
41871C...Commonblocks.
41872 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41873 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41874 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
41875 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
41876 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
41877 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
41878C...Local variables.
41879 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
41880 & ,DCMASS,KFR(3)
41881 DOUBLE PRECISION XLAM(0:400)
41882 DOUBLE PRECISION ZPMIX(4,4), NMIX(4,4), RMQ(6)
41883 INTEGER IDLAM(400,3), PYCOMP
41884 LOGICAL DCMASS
41885 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/
41886
41887C...R-VIOLATING DECAYS
41888 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
41889 KFSM=KFIN-KSUSY1
41890 IF(KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
41891C...WHICH NEUTRALINO ?
41892 NCHI=1
41893 IF (KFSM.EQ.23) NCHI=2
41894 IF (KFSM.EQ.25) NCHI=3
41895 IF (KFSM.EQ.35) NCHI=4
41896C...SIGN OF MASS (Opposite convention as HERWIG)
41897 ISM = 1
41898 IF (SMZ(NCHI).LT.0D0) ISM = -ISM
41899
41900C...Useful parameters for the calculation of the A and B constants.
41901 WMASS = PMAS(PYCOMP(24),1)
41902 ECHG = 2*SQRT(PARU(103)*PARU(1))
41903 COSB=1/(SQRT(1+RMSS(5)**2))
41904 SINB=RMSS(5)/SQRT(1+RMSS(5)**2)
41905 COSW=SQRT(1-PARU(102))
41906 SINW=SQRT(PARU(102))
41907 GW=2D0*SQRT(PARU(103)*PARU(1))/SINW
41908C...Run quark masses to neutralino mass squared (for Higgs-type
41909C...couplings)
41910 SQMCHI=PMAS(PYCOMP(KFIN),1)**2
41911 DO 100 I=1,6
41912 RMQ(I)=PYMRUN(I,SQMCHI)
41913 100 CONTINUE
41914C...EXPRESS NEUTRALINO MIXING IN (photino,Zino,~H_u,~H_d) BASIS
41915 DO 110 NCHJ=1,4
41916 ZPMIX(NCHJ,1)= ZMIX(NCHJ,1)*COSW+ZMIX(NCHJ,2)*SINW
41917 ZPMIX(NCHJ,2)=-ZMIX(NCHJ,1)*SINW+ZMIX(NCHJ,2)*COSW
41918 ZPMIX(NCHJ,3)= ZMIX(NCHJ,3)
41919 ZPMIX(NCHJ,4)= ZMIX(NCHJ,4)
41920 110 CONTINUE
41921 C1=GW*ZPMIX(NCHI,3)/(2D0*COSB*WMASS)
41922 C1U=GW*ZPMIX(NCHI,4)/(2D0*SINB*WMASS)
41923 C2=ECHG*ZPMIX(NCHI,1)
41924 C3=GW*ZPMIX(NCHI,2)/COSW
41925 EU=2D0/3D0
41926 ED=-1D0/3D0
41927C... AB(x,y,z):
41928C x=1-2 : Select A or B constant (1:A ; 2:B)
41929C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
41930C 11-16:e,nu_e,mu,...)
41931C z=1-2 : Mass eigenstate number
41932C...CALCULATE COUPLINGS
41933 DO 120 I = 11,15,2
41934 CMS=PMAS(PYCOMP(I),1)
41935C...Intermediate sleptons
41936 AB(1,I,1)=ISM*(CMS*C1*SFMIX(I,1) + SFMIX(I,2)
41937 & *(C2-C3*SINW**2))
41938 AB(1,I,2)=ISM*(CMS*C1*SFMIX(I,3) + SFMIX(I,4)
41939 & *(C2-C3*SINW**2))
41940 AB(2,I,1)= CMS*C1*SFMIX(I,2) - SFMIX(I,1)*(C2+C3*(5D-1-SINW
41941 & **2))
41942 AB(2,I,2)=CMS*C1*SFMIX(I,4) - SFMIX(I,3)*(C2+C3*(5D-1-SINW
41943 & **2))
41944C...Inermediate sneutrinos
41945 AB(1,I+1,1)=0D0
41946 AB(2,I+1,1)=5D-1*C3
41947 AB(1,I+1,2)=0D0
41948 AB(2,I+1,2)=0D0
41949C...Inermediate sdown
41950 J=I-10
41951 CMS=RMQ(J)
41952 AB(1,J,1)=ISM*(CMS*C1*SFMIX(J,1) - SFMIX(J,2)
41953 & *ED*(C2-C3*SINW**2))
41954 AB(1,J,2)=ISM*(CMS*C1*SFMIX(J,3) - SFMIX(J,4)
41955 & *ED*(C2-C3*SINW**2))
41956 AB(2,J,1)=CMS*C1*SFMIX(J,2) + SFMIX(J,1)
41957 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
41958 AB(2,J,2)=CMS*C1*SFMIX(J,4) + SFMIX(J,3)
41959 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
41960C...Inermediate sup
41961 J=J+1
41962 CMS=RMQ(J)
41963 AB(1,J,1)=ISM*(CMS*C1U*SFMIX(J,1) - SFMIX(J,2)
41964 & *EU*(C2-C3*SINW**2))
41965 AB(1,J,2)=ISM*(CMS*C1U*SFMIX(J,3) - SFMIX(J,4)
41966 & *EU*(C2-C3*SINW**2))
41967 AB(2,J,1)=CMS*C1U*SFMIX(J,2) + SFMIX(J,1)
41968 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
41969 AB(2,J,2)=CMS*C1U*SFMIX(J,4) + SFMIX(J,3)
41970 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
41971 120 CONTINUE
41972
41973 IF (IMSS(51).GE.1) THEN
41974C...LAMBDA COUPLINGS (LLE TYPE R-VIOLATION)
41975C * CHI0_I -> NUBAR_I + LEPTON+_J + lEPTON-_K.
41976C...STEP IN I,J,K USING SINGLE COUNTER
41977 DO 130 ISC=0,26
41978C...LAMBDA COUPLING ASYM IN I,J
41979 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
41980 LKNT = LKNT+1
41981 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
41982 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
41983 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
41984 XLAM(LKNT) = 0D0
41985C...Set coupling, and decay product masses on/off
41986 RVLAMC = RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
41987 & ,MOD(ISC,3)+1)**2
41988 DCMASS=.FALSE.
41989 IF (IDLAM(LKNT,2).EQ.-15.OR.IDLAM(LKNT,3).EQ.15)
41990 & DCMASS = .TRUE.
41991C...Resonance KF codes (1=I,2=J,3=K)
41992 KFR(1)=-IDLAM(LKNT,1)
41993 KFR(2)=-IDLAM(LKNT,2)
41994 KFR(3)=-IDLAM(LKNT,3)
41995C...Calculate width.
41996 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
41997 & IDLAM(LKNT,3),XLAM(LKNT))
41998 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
41999C...Charge conjugate mode.
42000 LKNT=LKNT+1
42001 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
42002 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
42003 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
42004 XLAM(LKNT)=XLAM(LKNT-1)
42005C...KINEMATICS CHECK
42006 IF (XLAM(LKNT).EQ.0D0) THEN
42007 LKNT=LKNT-2
42008 ENDIF
42009 ENDIF
42010 130 CONTINUE
42011 ENDIF
42012
42013 IF (IMSS(52).GE.1) THEN
42014C...LAMBDA' COUPLINGS. (LQD TYPE R-VIOLATION)
42015C * CHI0 -> NUBAR_I + DBAR_J + D_K
42016 DO 140 ISC=0,26
42017 LKNT = LKNT+1
42018 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
42019 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
42020 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
42021 XLAM(LKNT) = 0D0
42022C...Set coupling, and decay product masses on/off
42023 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
42024 & ,MOD(ISC,3)+1)**2
42025 DCMASS=.FALSE.
42026 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5)
42027 & DCMASS = .TRUE.
42028C...Resonance KF codes (1=I,2=J,3=K)
42029 KFR(1)=-IDLAM(LKNT,1)
42030 KFR(2)=-IDLAM(LKNT,2)
42031 KFR(3)=-IDLAM(LKNT,3)
42032C...Calculate width.
42033 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42034 & ,XLAM(LKNT))
42035 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42036C...Charge conjugate mode.
42037 LKNT=LKNT+1
42038 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
42039 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
42040 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
42041 XLAM(LKNT)=XLAM(LKNT-1)
42042C...KINEMATICS CHECK
42043 IF (XLAM(LKNT).EQ.0D0) THEN
42044 LKNT=LKNT-2
42045 ENDIF
42046
42047C * CHI0 -> LEPTON_I+ + UBAR_J + D_K
42048 LKNT = LKNT+1
42049 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
42050 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
42051 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
42052 XLAM(LKNT) = 0D0
42053C...Set coupling, and decay product masses on/off
42054 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
42055 & ,MOD(ISC,3)+1)**2
42056 DCMASS=.FALSE.
42057 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
42058 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
42059C...Resonance KF codes (1=I,2=J,3=K)
42060 KFR(1)=-IDLAM(LKNT,1)
42061 KFR(2)=-IDLAM(LKNT,2)
42062 KFR(3)=-IDLAM(LKNT,3)
42063C...Calculate width.
42064 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42065 & ,XLAM(LKNT))
42066 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42067C...Charge conjugate mode.
42068 LKNT=LKNT+1
42069 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
42070 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
42071 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
42072 XLAM(LKNT)=XLAM(LKNT-1)
42073C...KINEMATICS CHECK
42074 IF (XLAM(LKNT).EQ.0D0) THEN
42075 LKNT=LKNT-2
42076 ENDIF
42077 140 CONTINUE
42078 ENDIF
42079
42080 IF (IMSS(53).GE.1) THEN
42081C...LAMBDA'' COUPLINGS. (UDD TYPE R-VIOLATION)
42082C * CHI0 -> UBAR_I + DBAR_J + DBAR_K
42083 DO 150 ISC=0,26
42084C...Symmetry J<->K. Also, LAMB antisymmetric in J and K, so no J=K.
42085 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
42086 LKNT = LKNT+1
42087 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
42088 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
42089 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
42090 XLAM(LKNT) = 0D0
42091C...Set coupling, and decay product masses on/off
42092 RVLAMC = 6. * RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)
42093 & +1,MOD(ISC,3)+1)**2
42094 DCMASS=.FALSE.
42095 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
42096 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
42097C...Resonance KF codes (1=I,2=J,3=K)
42098 KFR(1) = IDLAM(LKNT,1)
42099 KFR(2) = IDLAM(LKNT,2)
42100 KFR(3) = IDLAM(LKNT,3)
42101C...Calculate width.
42102 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42103 & IDLAM(LKNT,3),XLAM(LKNT))
42104 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42105C...Charge conjugate mode.
42106 LKNT=LKNT+1
42107 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
42108 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
42109 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
42110 XLAM(LKNT)=XLAM(LKNT-1)
42111C...KINEMATICS CHECK
42112 IF (XLAM(LKNT).EQ.0D0) THEN
42113 LKNT=LKNT-2
42114 ENDIF
42115 ENDIF
42116 150 CONTINUE
42117 ENDIF
42118 ENDIF
42119 ENDIF
42120
42121 RETURN
42122 END
42123
42124C*********************************************************************
42125
42126C...PYRVCH
42127C...Calculates R-violating chargino decay widths.
42128C...P. Z. Skands
42129
42130 SUBROUTINE PYRVCH(KFIN,XLAM,IDLAM,LKNT)
42131
42132C...Double precision and integer declarations.
42133 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42134 IMPLICIT INTEGER(I-N)
42135C...Parameter statement to help give large particle numbers.
42136 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
42137 &KEXCIT=4000000,KDIMEN=5000000)
42138C...Commonblocks.
42139 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42140 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42141 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
42142 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
42143 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
42144 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
42145C...Local variables.
42146 DOUBLE PRECISION XLAM(0:400)
42147 INTEGER IDLAM(400,3), PYCOMP
42148C...Information from main routine to PYRVGW
42149 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
42150 & ,DCMASS,KFR(3)
42151C...Auxiliary variables needed for BV (RV Gauge STOre)
42152 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
42153 & ,RVLJKI,RVLJIK
42154C...Running quark masses
42155 DOUBLE PRECISION RMQ(6)
42156C...Decay product masses on/off
42157 LOGICAL DCMASS
42158 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
42159 & /RVGSTO/
42160
42161
42162C...IF R-VIOLATION ON.
42163 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
42164 KFSM=KFIN-KSUSY1
42165 IF(KFSM.EQ.24.OR.KFSM.EQ.37) THEN
42166C...WHICH CHARGINO ?
42167 NCHI = 1
42168 IF (KFSM.EQ.37) NCHI = 2
42169
42170C...Useful parameters for calculating the A and B constants.
42171C...SIGN OF MASS (Opposite convention as HERWIG)
42172 ISM = 1
42173 IF (SMW(NCHI).LT.0D0) ISM = -1
42174 WMASS = PMAS(PYCOMP(24),1)
42175 COSB = 1/(SQRT(1+RMSS(5)**2))
42176 SINB = RMSS(5)/SQRT(1+RMSS(5)**2)
42177 GW2 = 4*PARU(103)*PARU(1)/PARU(102)
42178 C1U = UMIX(NCHI,2)/(SQRT(2D0)*COSB*WMASS)
42179 C1V = VMIX(NCHI,2)/(SQRT(2D0)*SINB*WMASS)
42180 C2 = UMIX(NCHI,1)
42181 C3 = VMIX(NCHI,1)
42182C...Running masses at Q^2=MCHI^2.
42183 SQMCHI = PMAS(PYCOMP(KFSM),1)**2
42184 DO 100 I=1,6
42185 RMQ(I)=PYMRUN(I,SQMCHI)
42186 100 CONTINUE
42187
42188C... AB(x,y,z) coefficients:
42189C x=1-2 : A or B coefficient (1:A ; 2:B)
42190C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
42191C 11-16:e,nu_e,mu,...)
42192C z=1-2 : Mass eigenstate number
42193 DO 110 I = 11,15,2
42194C...Intermediate sleptons
42195 AB(1,I,1) = 0D0
42196 AB(1,I,2) = 0D0
42197 AB(2,I,1) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,2) +
42198 & SFMIX(I,1)*C2
42199 AB(2,I,2) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,4) +
42200 & SFMIX(I,3)*C2
42201C...Intermediate sneutrinos
42202 AB(1,I+1,1) = -PMAS(PYCOMP(I),1)*C1U
42203 AB(1,I+1,2) = 0D0
42204 AB(2,I+1,1) = ISM*C3
42205 AB(2,I+1,2) = 0D0
42206C...Intermediate sdown
42207 J=I-10
42208 AB(1,J,1) = -RMQ(J+1)*C1V*SFMIX(J,1)
42209 AB(1,J,2) = -RMQ(J+1)*C1V*SFMIX(J,3)
42210 AB(2,J,1) = -ISM*(RMQ(J)*C1U*SFMIX(J,2) - SFMIX(J,1)*C2)
42211 AB(2,J,2) = -ISM*(RMQ(J)*C1U*SFMIX(J,4) - SFMIX(J,3)*C2)
42212C...Intermediate sup
42213 J=J+1
42214 AB(1,J,1) = -RMQ(J-1)*C1U*SFMIX(J,1)
42215 AB(1,J,2) = -RMQ(J-1)*C1U*SFMIX(J,3)
42216 AB(2,J,1) = -ISM*(RMQ(J)*C1V*SFMIX(J,2) - SFMIX(J,1)*C3)
42217 AB(2,J,2) = -ISM*(RMQ(J)*C1V*SFMIX(J,4) - SFMIX(J,3)*C3)
42218 110 CONTINUE
42219
42220C...LLE TYPE R-VIOLATION
42221 IF (IMSS(51).GE.1) THEN
42222C...LOOP OVER DECAY MODES
42223 DO 140 ISC=0,26
42224
42225C...CHI+ -> NUBAR_I + LEPTON+_J + NU_K.
42226 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
42227 LKNT = LKNT+1
42228 IDLAM(LKNT,1) = -12 -2*MOD(ISC/9,3)
42229 IDLAM(LKNT,2) = -11 -2*MOD(ISC/3,3)
42230 IDLAM(LKNT,3) = 12 +2*MOD(ISC,3)
42231 XLAM(LKNT) = 0D0
42232C...Set coupling, and decay product masses on/off
42233 RVLAMC = GW2 * 5D-1 *
42234 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
42235 & **2
42236 DCMASS=.FALSE.
42237 IF (IDLAM(LKNT,2).EQ.-15) DCMASS = .TRUE.
42238C...Resonance KF codes (1=I,2=J,3=K).
42239 KFR(1) = 0
42240 KFR(2) = 0
42241 KFR(3) = -IDLAM(LKNT,3)+1
42242C...Calculate width.
42243 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42244 & IDLAM(LKNT,3),XLAM(LKNT))
42245 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42246C...KINEMATICS CHECK
42247 IF (XLAM(LKNT).EQ.0D0) THEN
42248 LKNT=LKNT-1
42249 ENDIF
42250
42251C * CHI+ -> NU_I + NU_J + LEPTON+_K. (NOTE: SYMM. IN I AND J)
42252 120 IF (MOD(ISC/9,3).LT.MOD(ISC/3,3)) THEN
42253 LKNT = LKNT+1
42254 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
42255 IDLAM(LKNT,2) = 12 +2*MOD(ISC/3,3)
42256 IDLAM(LKNT,3) =-11 -2*MOD(ISC,3)
42257 XLAM(LKNT) = 0D0
42258C...Set coupling, and decay product masses on/off
42259 RVLAMC = GW2 * 5D-1 *
42260 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
42261C...I,J SYMMETRY => FACTOR 2
42262 RVLAMC=2*RVLAMC
42263 DCMASS=.FALSE.
42264 IF (IDLAM(LKNT,3).EQ.-15) DCMASS = .TRUE.
42265C...Resonance KF codes (1=I,2=J,3=K)
42266 KFR(1)=IDLAM(LKNT,1)-1
42267 KFR(2)=IDLAM(LKNT,2)-1
42268 KFR(3)=0
42269C...Calculate width.
42270 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42271 & IDLAM(LKNT,3),XLAM(LKNT))
42272 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42273C...KINEMATICS CHECK
42274 IF (XLAM(LKNT).EQ.0D0) THEN
42275 LKNT=LKNT-1
42276 ENDIF
42277 130 ENDIF
42278
42279C * CHI+ -> LEPTON+_I + LEPTON+_J + LEPTON-_K
42280 LKNT = LKNT+1
42281 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
42282 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
42283 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
42284 XLAM(LKNT) = 0D0
42285C...Set coupling, and decay product masses on/off
42286 RVLAMC = GW2 * 5D-1 *
42287 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
42288C...I,J SYMMETRY => FACTOR 2
42289 RVLAMC=2*RVLAMC
42290 DCMASS=.FALSE.
42291 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-15
42292 & .OR.IDLAM(LKNT,3).EQ.15) DCMASS = .TRUE.
42293C...Resonance KF codes (1=I,2=J,3=K)
42294 KFR(1) =-IDLAM(LKNT,1)+1
42295 KFR(2) =-IDLAM(LKNT,2)+1
42296 KFR(3) = 0
42297C...Calculate width.
42298 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42299 & IDLAM(LKNT,3),XLAM(LKNT))
42300 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42301C...KINEMATICS CHECK
42302 IF (XLAM(LKNT).EQ.0D0) THEN
42303 LKNT=LKNT-1
42304 ENDIF
42305 ENDIF
42306 140 CONTINUE
42307 ENDIF
42308
42309C...LQD TYPE R-VIOLATION
42310 IF (IMSS(52).GE.1) THEN
42311C...LOOP OVER DECAY MODES
42312 DO 180 ISC=0,26
42313
42314C...CHI+ -> NUBAR_I + DBAR_J + U_K
42315 LKNT = LKNT+1
42316 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
42317 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
42318 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
42319 XLAM(LKNT) = 0D0
42320C...Set coupling, and decay product masses on/off
42321 RVLAMC = 3. * GW2 * 5D-1 *
42322 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
42323 DCMASS=.FALSE.
42324 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.6)
42325 & DCMASS = .TRUE.
42326C...Resonance KF codes (1=I,2=J,3=K)
42327 KFR(1)=0
42328 KFR(2)=0
42329 KFR(3)=-IDLAM(LKNT,3)+1
42330C...Calculate width.
42331 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42332 & ,XLAM(LKNT))
42333 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42334C...KINEMATICS CHECK
42335 IF (XLAM(LKNT).EQ.0D0) THEN
42336 LKNT=LKNT-1
42337 ENDIF
42338
42339C * CHI+ -> LEPTON+_I + UBAR_J + U_K.
42340 150 LKNT = LKNT+1
42341 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
42342 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
42343 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
42344 XLAM(LKNT) = 0D0
42345C...Set coupling, and decay product masses on/off
42346 RVLAMC = 3. * GW2 * 5D-1 *
42347 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
42348 DCMASS=.FALSE.
42349 IF (IDLAM(LKNT,1).EQ.-11.OR.IDLAM(LKNT,2).EQ.-6
42350 & .OR.IDLAM(LKNT,3).EQ.6) DCMASS = .TRUE.
42351C...Resonance KF codes (1=I,2=J,3=K)
42352 KFR(1)=0
42353 KFR(2)=0
42354 KFR(3)=-IDLAM(LKNT,3)+1
42355C...Calculate width.
42356 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42357 & ,XLAM(LKNT))
42358 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42359C...KINEMATICS CHECK
42360 IF (XLAM(LKNT).EQ.0D0) THEN
42361 LKNT=LKNT-1
42362 ENDIF
42363
42364C * CHI+ -> LEPTON+_I + DBAR_J + D_K.
42365 160 LKNT = LKNT+1
42366 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
42367 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
42368 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
42369 XLAM(LKNT) = 0D0
42370C...Set coupling, and decay product masses on/off
42371 RVLAMC = 3. * GW2 * 5D-1 *
42372 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
42373 DCMASS = .FALSE.
42374 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-5
42375 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
42376C...Resonance KF codes (1=I,2=J,3=K)
42377 KFR(1)=-IDLAM(LKNT,1)+1
42378 KFR(2)=-IDLAM(LKNT,2)+1
42379 KFR(3)=0
42380C...Calculate width.
42381 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42382 & ,XLAM(LKNT))
42383 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42384C...KINEMATICS CHECK
42385 IF (XLAM(LKNT).EQ.0D0) THEN
42386 LKNT=LKNT-1
42387 ENDIF
42388
42389C * CHI+ -> NU_I + U_J + DBAR_K.
42390 170 LKNT = LKNT+1
42391 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
42392 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
42393 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
42394 XLAM(LKNT) = 0D0
42395C...Set coupling, and decay product masses on/off
42396 DCMASS = .FALSE.
42397 RVLAMC = 3. * GW2 * 5D-1 *
42398 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
42399 IF (IDLAM(LKNT,2).EQ.6.OR.IDLAM(LKNT,3).EQ.-5)
42400 & DCMASS = .TRUE.
42401C...Resonance KF codes (1=I,2=J,3=K)
42402 KFR(1)=IDLAM(LKNT,1)-1
42403 KFR(2)=IDLAM(LKNT,2)-1
42404 KFR(3)=0
42405C...Calculate width.
42406 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42407 & ,XLAM(LKNT))
42408 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42409C...KINEMATICS CHECK
42410 IF (XLAM(LKNT).EQ.0D0) THEN
42411 LKNT=LKNT-1
42412 ENDIF
42413
42414 180 CONTINUE
42415 ENDIF
42416
42417C...UDD TYPE R-VIOLATION
42418C...These decays need special treatment since more than one BV coupling
42419C...contributes (with interference). Consider e.g. (symbolically)
42420C |M|^2 = |l''_{ijk}|^2*(PYRVI1(RES_I) + PYRVI2(RES_I))
42421C +|l''_{jik}|^2*(PYRVI1(RES_J) + PYRVI2(RES_J))
42422C +l''_{ijk}*l''_{jik}*PYRVI3(PYRVI4(RES_I,RES_J))
42423C...The problem is that a single call to PYRVGW would evaluate all
42424C...these terms and sum them, but without the different couplings. The
42425C...way out is to call PYRVGW three times, once for the first line, once
42426C...for the second line, and then once for all the lines (it is
42427C...impossible to get just the last line out) without multiplying by
42428C...couplings. The last line is then obtained as the result of the third
42429C...call minus the results of the two first calls. Each term is then
42430C...multiplied by its respective coupling before the whole thing is
42431C...summed up in XLAM.
42432C...Note that with three interfering resonances, this procedure becomes
42433C...more complicated, as can be seen in the CHI+ -> 3*DBAR mode.
42434
42435 IF (IMSS(53).GE.1) THEN
42436C...LOOP OVER DECAY MODES
42437 DO 190 ISC=1,25
42438
42439C...CHI+ -> U_I + U_J + D_K
42440C...Decay mode I<->J symmetric.
42441 IF (MOD(ISC/9,3).LE.MOD(ISC/3,3).AND.ISC.NE.13) THEN
42442 LKNT = LKNT+1
42443 IDLAM(LKNT,1) = 2 +2*MOD(ISC/9,3)
42444 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
42445 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
42446 XLAM(LKNT) = 0D0
42447C...Set coupling, and decay product masses on/off
42448 RVLAMC= 6. * GW2 * 5D-1
42449 RVLJIK= RVLAMB(MOD(ISC/3,3)+1,MOD(ISC/9,3)+1,MOD(ISC,3)
42450 & +1)
42451 RVLIJK= RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
42452 & +1)
42453 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3)) RVLAMC = 5D-1
42454 & * RVLAMC
42455 DCMASS=.FALSE.
42456 IF (IDLAM(LKNT,1).EQ.6.OR.IDLAM(LKNT,2).EQ.6
42457 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS =.TRUE.
42458C...Resonance KF codes (1=I,2=J,3=K)
42459 KFR(1) = -IDLAM(LKNT,1)+1
42460 KFR(2) = 0
42461 KFR(3) = 0
42462C...Calculate width.
42463 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42464 & IDLAM(LKNT,3),XRESI)
42465C...Resonance KF codes (1=I,2=J,3=K)
42466 KFR(1) = 0
42467 KFR(2) = -IDLAM(LKNT,2)+1
42468 KFR(3) = 0
42469C...Calculate width.
42470 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42471 & IDLAM(LKNT,3),XRESJ)
42472C...Resonance KF codes (1=I,2=J,3=K)
42473 KFR(1) = -IDLAM(LKNT,1)+1
42474 KFR(2) = -IDLAM(LKNT,2)+1
42475 KFR(3) = 0
42476C...Calculate width.
42477 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42478 & IDLAM(LKNT,3),XRESIJ)
42479 IF (ABS((XRESI+XRESJ)/XRESIJ-1.).GT.1D-4) THEN
42480 XRESIJ = XRESIJ-XRESI-XRESJ
42481 ELSE
42482 XRESIJ = 0D0
42483 ENDIF
42484C...CALCULATE TOTAL WIDTH
42485 XLAM(LKNT) = RVLJIK**2 * XRESI + RVLIJK**2 * XRESJ
42486 & + RVLJIK*RVLIJK * XRESIJ
42487 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42488C...KINEMATICS CHECK
42489 IF (XLAM(LKNT).EQ.0D0) THEN
42490 LKNT=LKNT-1
42491 ENDIF
42492 ENDIF
42493C...CHI+ -> DBAR_I + DBAR_J + DBAR_K
42494C...Symmetry I<->J<->K.
42495 IF ((MOD(ISC/9,3).LE.MOD(ISC/3,3)).AND.(MOD(ISC/3,3).LE
42496 & .MOD(ISC,3)).AND.ISC.NE.13) THEN
42497 LKNT = LKNT+1
42498 IDLAM(LKNT,1) = -1 -2*MOD(ISC/9,3)
42499 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
42500 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
42501 XLAM(LKNT) = 0D0
42502C...Set coupling, and decay product masses on/off
42503 RVLAMC = 6. * GW2 * 5D-1
42504 RVLIJK = RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
42505 & +1)
42506 RVLKIJ = RVLAMB(MOD(ISC,3)+1,MOD(ISC/9,3)+1,MOD(ISC/3,3)
42507 & +1)
42508 RVLJKI = RVLAMB(MOD(ISC/3,3)+1,MOD(ISC,3)+1,MOD(ISC/9,3)
42509 & +1)
42510 DCMASS = .FALSE.
42511 IF (IDLAM(LKNT,1).EQ.-5.OR.IDLAM(LKNT,2).EQ.-5
42512 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS = .TRUE.
42513C...Collect symmetry factors
42514 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3).OR.MOD(ISC/3,3).EQ
42515 & .MOD(ISC,3).OR.MOD(ISC/9,3).EQ.MOD(ISC,3))
42516 & RVLAMC = 5D-1 * RVLAMC
42517C...Resonance KF codes (1=I,2=J,3=K)
42518 KFR(1) = IDLAM(LKNT,1)-1
42519 KFR(2) = 0
42520 KFR(3) = 0
42521C...Calculate width.
42522 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42523 & IDLAM(LKNT,3),XRESI)
42524C...Resonance KF codes (1=I,2=J,3=K)
42525 KFR(1) = 0
42526 KFR(2) = IDLAM(LKNT,2)-1
42527 KFR(3) = 0
42528C...Calculate width.
42529 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42530 & IDLAM(LKNT,3),XRESJ)
42531C...Resonance KF codes (1=I,2=J,3=K)
42532 KFR(1) = 0
42533 KFR(2) = 0
42534 KFR(3) = IDLAM(LKNT,3)-1
42535C...Calculate width.
42536 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42537 & IDLAM(LKNT,3),XRESK)
42538C...Resonance KF codes (1=I,2=J,3=K)
42539 KFR(1) = IDLAM(LKNT,1)-1
42540 KFR(2) = IDLAM(LKNT,2)-1
42541 KFR(3) = 0
42542C...Calculate width.
42543 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42544 & IDLAM(LKNT,3),XRESIJ)
42545 IF (ABS(XRESIJ/(XRESI+XRESJ)-1.).GT.1D-4) THEN
42546 XRESIJ = XRESI+XRESJ-XRESIJ
42547 ELSE
42548 XRESIJ = 0D0
42549 ENDIF
42550C...Resonance KF codes (1=I,2=J,3=K)
42551 KFR(1) = 0
42552 KFR(2) = IDLAM(LKNT,2)-1
42553 KFR(3) = IDLAM(LKNT,3)-1
42554C...Calculate width.
42555 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42556 & IDLAM(LKNT,3),XRESJK)
42557 IF (ABS(XRESJK/(XRESJ+XRESK)-1.).GT.1D-4) THEN
42558 XRESJK = XRESJ+XRESK-XRESJK
42559 ELSE
42560 XRESJK = 0D0
42561 ENDIF
42562C...Resonance KF codes (1=I,2=J,3=K)
42563 KFR(1) = IDLAM(LKNT,1)-1
42564 KFR(2) = 0
42565 KFR(3) = IDLAM(LKNT,3)-1
42566C...Calculate width.
42567 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42568 & IDLAM(LKNT,3),XRESIK)
42569 IF (ABS(XRESIK/(XRESI+XRESK)-1.).GT.1D-4) THEN
42570 XRESIK = XRESI+XRESK-XRESIK
42571 ELSE
42572 XRESIK = 0D0
42573 ENDIF
42574C...CALCULATE TOTAL WIDTH
42575 XLAM(LKNT) =
42576 & RVLIJK**2 * XRESI
42577 & + RVLJKI**2 * XRESJ
42578 & + RVLKIJ**2 * XRESK
42579 & + RVLIJK*RVLJKI * XRESIJ
42580 & + RVLIJK*RVLKIJ * XRESIK
42581 & + RVLJKI*RVLKIJ * XRESJK
42582 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2.*PARU(1)*RMS(0))**3*32)
42583C...KINEMATICS CHECK
42584 IF (XLAM(LKNT).EQ.0D0) THEN
42585 LKNT=LKNT-1
42586 ENDIF
42587 ENDIF
42588 190 CONTINUE
42589 ENDIF
42590 ENDIF
42591 ENDIF
42592
42593 RETURN
42594 END
42595
42596C*********************************************************************
42597
42598C...PYRVGL
42599C...Calculates R-violating gluino decay widths.
42600C...See BV part of PYRVCH for comments about the way the BV decay width
42601C...is calculated. Same comments apply here.
42602C...P. Z. Skands
42603
42604 SUBROUTINE PYRVGL(KFIN,XLAM,IDLAM,LKNT)
42605
42606C...Double precision and integer declarations.
42607 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42608 IMPLICIT INTEGER(I-N)
42609C...Parameter statement to help give large particle numbers.
42610 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
42611 &KEXCIT=4000000,KDIMEN=5000000)
42612C...Commonblocks.
42613 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42614 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42615 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
42616 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
42617 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
42618 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
42619C...Local variables.
42620 DOUBLE PRECISION XLAM(0:400)
42621 INTEGER IDLAM(400,3), PYCOMP
42622C...Information from main routine to PYRVGW
42623 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
42624 & ,DCMASS,KFR(3)
42625C...Auxiliary variables needed for BV (RV Gauge STOre)
42626 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
42627 & ,RVLJKI,RVLJIK
42628C...Running quark masses
42629 DOUBLE PRECISION RMQ(6)
42630C...Decay product masses on/off
42631 LOGICAL DCMASS
42632 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
42633 & /RVGSTO/
42634
42635C...IF LQD OR UDD TYPE R-VIOLATION ON.
42636 IF (IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
42637 KFSM=KFIN-KSUSY1
42638
42639C... AB(x,y,z):
42640C x=1-2 : Select A or B coupling (1:A ; 2:B)
42641C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
42642C 11-16:e,nu_e,mu,... not used here)
42643C z=1-2 : Mass eigenstate number
42644 DO 100 I = 1,6
42645C...A Couplings
42646 AB(1,I,1) = SFMIX(I,2)
42647 AB(1,I,2) = SFMIX(I,4)
42648C...B Couplings
42649 AB(2,I,1) = -SFMIX(I,1)
42650 AB(2,I,2) = -SFMIX(I,3)
42651 100 CONTINUE
42652 GSTR2 = 4D0*PARU(1) * PYALPS(PMAS(PYCOMP(KFIN),1)**2)
42653C...LQD DECAYS.
42654 IF (IMSS(52).GE.1) THEN
42655C...STEP IN I,J,K USING SINGLE COUNTER
42656 DO 120 ISC=0,26
42657C * GLUINO -> NUBAR_I + DBAR_J + D_K.
42658 LKNT = LKNT+1
42659 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
42660 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
42661 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
42662 XLAM(LKNT)=0D0
42663C...Set coupling, and decay product masses on/off
42664 RVLAMC=RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
42665 & * 5D-1 * GSTR2
42666 DCMASS = .FALSE.
42667 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
42668C...Resonance KF codes (1=I,2=J,3=K)
42669 KFR(1) = 0
42670 KFR(2) = -IDLAM(LKNT,2)
42671 KFR(3) = -IDLAM(LKNT,3)
42672C...Calculate width.
42673 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42674 & ,XLAM(LKNT))
42675C...Normalize
42676 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42677C...Charge conjugate mode.
42678 110 LKNT = LKNT+1
42679 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
42680 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
42681 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
42682 XLAM(LKNT) = XLAM(LKNT-1)
42683C...KINEMATICS CHECK
42684 IF (XLAM(LKNT).EQ.0D0) THEN
42685 LKNT=LKNT-2
42686 ENDIF
42687
42688C * GLUINO -> LEPTON+_I + UBAR_J + D_K
42689 LKNT = LKNT+1
42690 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
42691 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
42692 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
42693 XLAM(LKNT)=0D0
42694C...Set coupling, and decay product masses on/off
42695 RVLAMC = RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
42696 & **2* 5D-1 * GSTR2
42697 DCMASS = .FALSE.
42698 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
42699 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
42700C...Resonance KF codes (1=I,2=J,3=K)
42701 KFR(1) = 0
42702 KFR(2) = -IDLAM(LKNT,2)
42703 KFR(3) = -IDLAM(LKNT,3)
42704C...Calculate width.
42705 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42706 & ,XLAM(LKNT))
42707 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42708C...Charge conjugate mode.
42709 LKNT=LKNT+1
42710 IDLAM(LKNT,1) = -IDLAM(LKNT-1,1)
42711 IDLAM(LKNT,2) = -IDLAM(LKNT-1,2)
42712 IDLAM(LKNT,3) = -IDLAM(LKNT-1,3)
42713 XLAM(LKNT) = XLAM(LKNT-1)
42714C...KINEMATICS CHECK
42715 IF (XLAM(LKNT).EQ.0D0) THEN
42716 LKNT=LKNT-2
42717 ENDIF
42718
42719 120 CONTINUE
42720 ENDIF
42721
42722C...UDD DECAYS.
42723 IF (IMSS(53).GE.1) THEN
42724C...STEP IN I,J,K USING SINGLE COUNTER
42725 DO 130 ISC=0,26
42726C * GLUINO -> UBAR_I + DBAR_J + DBAR_K.
42727 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
42728 LKNT = LKNT+1
42729 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
42730 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
42731 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
42732 XLAM(LKNT)=0D0
42733C...Set coupling, and decay product masses on/off. A factor of 2 for
42734C...(N_C-1) has been used to cancel a factor 0.5.
42735 RVLAMC=RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
42736 & **2 * GSTR2
42737 DCMASS = .FALSE.
42738 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
42739 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
42740C...Resonance KF codes (1=I,2=J,3=K)
42741 KFR(1) = IDLAM(LKNT,1)
42742 KFR(2) = 0
42743 KFR(3) = 0
42744C...Calculate width.
42745 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42746 & ,XRESI)
42747C...Resonance KF codes (1=I,2=J,3=K)
42748 KFR(1) = 0
42749 KFR(2) = IDLAM(LKNT,2)
42750 KFR(3) = 0
42751C...Calculate width.
42752 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42753 & ,XRESJ)
42754C...Resonance KF codes (1=I,2=J,3=K)
42755 KFR(1) = 0
42756 KFR(2) = 0
42757 KFR(3) = IDLAM(LKNT,3)
42758C...Calculate width.
42759 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42760 & ,XRESK)
42761C...Resonance KF codes (1=I,2=J,3=K)
42762 KFR(1) = IDLAM(LKNT,1)
42763 KFR(2) = IDLAM(LKNT,2)
42764 KFR(3) = 0
42765C...Calculate width.
42766 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42767 & ,XRESIJ)
42768C...Calculate interference function. (Factor -1/2 to make up for factor
42769C...-2 in PYRVGW.
42770 IF (ABS((XRESI+XRESJ)/XRESIJ-1D0).GT.1D-4) THEN
42771 XRESIJ = 5D-1 * (XRESI+XRESJ-XRESIJ)
42772 ELSE
42773 XRESIJ = 0D0
42774 ENDIF
42775C...Resonance KF codes (1=I,2=J,3=K)
42776 KFR(1) = 0
42777 KFR(2) = IDLAM(LKNT,2)
42778 KFR(3) = IDLAM(LKNT,3)
42779C...Calculate width.
42780 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42781 & ,XRESJK)
42782 IF (ABS((XRESJ+XRESK)/XRESJK-1).GT.1D-4) THEN
42783 XRESJK = 5D-1 * (XRESJ+XRESK-XRESJK)
42784 ELSE
42785 XRESJK = 0D0
42786 ENDIF
42787C...Resonance KF codes (1=I,2=J,3=K)
42788 KFR(1) = IDLAM(LKNT,1)
42789 KFR(2) = 0
42790 KFR(3) = IDLAM(LKNT,3)
42791C...Calculate width.
42792 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42793 & ,XRESIK)
42794 IF (ABS((XRESI+XRESK)/XRESIK-1).GT.1D-4) THEN
42795 XRESIK = 5D-1 * (XRESI+XRESK-XRESIK)
42796 ELSE
42797 XRESIK = 0D0
42798 ENDIF
42799C...Calculate total width (factor 1/2 from 1/(N_C-1))
42800 XLAM(LKNT) = XRESI + XRESJ + XRESK
42801 & + 5D-1 * (XRESIJ + XRESIK + XRESJK)
42802C...Normalize
42803 XLAM(LKNT) = XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42804C...Charge conjugate mode.
42805 LKNT = LKNT+1
42806 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
42807 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
42808 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
42809 XLAM(LKNT) = XLAM(LKNT-1)
42810C...KINEMATICS CHECK
42811 IF (XLAM(LKNT).EQ.0D0) THEN
42812 LKNT=LKNT-2
42813 ENDIF
42814 ENDIF
42815 130 CONTINUE
42816 ENDIF
42817 ENDIF
42818 RETURN
42819 END
42820
42821C*********************************************************************
42822
42823C...PYRVSB
42824C...Auxiliary function to PYRVSF for calculating R-Violating
42825C...sfermion widths. Though the decay products are most often treated
42826C...as massless in the calculation, the kinematical boundary of phase
42827C...space is tested using the true masses.
42828C...MODE = 1: All decay products massive
42829C...MODE = 2: Decay product 1 massless
42830C...MODE = 3: Decay product 2 massless
42831C...MODE = 4: All decay products massless
42832
42833 FUNCTION PYRVSB(KFIN,ID1,ID2,RM2,MODE)
42834
42835 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
42836 IMPLICIT INTEGER (I-N)
42837 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42838 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42839 SAVE /PYDAT1/,/PYDAT2/
42840 DOUBLE PRECISION SM(3)
42841 INTEGER PYCOMP, KC(3)
42842 KC(1)=PYCOMP(KFIN)
42843 KC(2)=PYCOMP(ID1)
42844 KC(3)=PYCOMP(ID2)
42845 SM(1)=PMAS(KC(1),1)**2
42846 SM(2)=PMAS(KC(2),1)**2
42847 SM(3)=PMAS(KC(3),1)**2
42848C...Kinematics check
42849 IF ((SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2).LE.0D0) THEN
42850 PYRVSB=0D0
42851 RETURN
42852 ENDIF
42853C...CM momenta squared
42854 IF (MODE.EQ.1) THEN
42855 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2)
42856 & * (SM(1)-(PMAS(KC(2),1)-PMAS(KC(3),1))**2)
42857 ELSE IF (MODE.EQ.2) THEN
42858 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(3),1))**2)**2
42859 ELSE IF (MODE.EQ.3) THEN
42860 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1))**2)**2
42861 ELSE
42862 P2CM=SM(1)/4.
42863 ENDIF
42864C...Calculate Width
42865 PYRVSB=RM2*SQRT(MAX(0D0,P2CM))/(8*PARU(1)*SM(1))
42866 RETURN
42867 END
42868
42869C*********************************************************************
42870
42871C...PYRVGW
42872C...Generalized Matrix Element for R-Violating 3-body widths.
42873C...P. Z. Skands
42874 SUBROUTINE PYRVGW(KFIN,ID1,ID2,ID3,XLAM)
42875
42876 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
42877 IMPLICIT INTEGER (I-N)
42878 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
42879 &KEXCIT=4000000,KDIMEN=5000000)
42880 PARAMETER (EPS=1D-4)
42881 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42882 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
42883 & ,DCMASS,KFR(3)
42884 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
42885 & SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
42886 DOUBLE PRECISION XLIM(3,3)
42887 INTEGER KC(0:3), PYCOMP
42888 LOGICAL DCMASS, DCHECK(6)
42889 SAVE /PYDAT2/,/PYRVNV/,/PYSSMT/
42890
42891 XLAM = 0D0
42892
42893 KC(0) = PYCOMP(KFIN)
42894 KC(1) = PYCOMP(ID1)
42895 KC(2) = PYCOMP(ID2)
42896 KC(3) = PYCOMP(ID3)
42897 RMS(0) = PMAS(KC(0),1)
42898 RMS(1) = PYMRUN(ID1,PMAS(KC(1),1)**2)
42899 RMS(2) = PYMRUN(ID2,PMAS(KC(2),1)**2)
42900 RMS(3) = PYMRUN(ID3,PMAS(KC(3),1)**2)
42901C...INITIALIZE OUTER INTEGRATION LIMITS AND KINEMATICS CHECK
42902 XLIM(1,1)=(RMS(1)+RMS(2))**2
42903 XLIM(1,2)=(RMS(0)-RMS(3))**2
42904 XLIM(1,3)=XLIM(1,2)-XLIM(1,1)
42905 XLIM(2,1)=(RMS(2)+RMS(3))**2
42906 XLIM(2,2)=(RMS(0)-RMS(1))**2
42907 XLIM(2,3)=XLIM(2,2)-XLIM(2,1)
42908 XLIM(3,1)=(RMS(1)+RMS(3))**2
42909 XLIM(3,2)=(RMS(0)-RMS(2))**2
42910 XLIM(3,3)=XLIM(3,2)-XLIM(3,1)
42911C...Check Phase Space
42912 IF (XLIM(1,3).LT.0D0.OR.XLIM(2,3).LT.0D0.OR.XLIM(3,3).LT.0D0) THEN
42913 RETURN
42914 ENDIF
42915
42916C...INITIALIZE RESONANCE INFORMATION
42917 DO 110 JRES = 1,3
42918 DO 100 IMASS = 1,2
42919 IRES = 2*(JRES-1)+IMASS
42920 INTRES(IRES,1) = 0
42921 DCHECK(IRES) =.FALSE.
42922C...NO RIGHT-HANDED NEUTRINOS
42923 IF (((IMASS.EQ.2).AND.((IABS(KFR(JRES)).EQ.12).OR
42924 & .(IABS(KFR(JRES)).EQ.14).OR.(IABS(KFR(JRES)).EQ.16))).OR
42925 & .KFR(JRES).EQ.0) GOTO 100
42926 RES(IRES,1) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),1)
42927 RES(IRES,2) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),2)
42928 INTRES(IRES,1) = IABS(KFR(JRES))
42929 INTRES(IRES,2) = IMASS
42930 IF (KFR(JRES).LT.0) INTRES(IRES,3) = 1
42931 IF (KFR(JRES).GT.0) INTRES(IRES,3) = 0
42932 100 CONTINUE
42933 110 CONTINUE
42934
42935C...SUM OVER DIAGRAMS AND INTEGRATE OVER PHASE SPACE
42936
42937C...RESONANCE CONTRIBUTIONS
42938C...(Only sum contributions where the resonance is off shell).
42939C...Store whether diagram on/off in DCHECK.
42940C...LOOP OVER MASS STATES
42941 DO 120 J=1,2
42942 IDR=J
42943 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
42944 IF ((RMS(0).LT.(RMS(1)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(2)
42945 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
42946 DCHECK(IDR) =.TRUE.
42947 XLAM = XLAM + TMIX * PYRVI1(2,3,1)
42948 ENDIF
42949
42950 IDR=J+2
42951 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
42952 IF ((RMS(0).LT.(RMS(2)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
42953 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
42954 DCHECK(IDR) =.TRUE.
42955 XLAM = XLAM + TMIX * PYRVI1(1,3,2)
42956 ENDIF
42957
42958 IDR=J+4
42959 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
42960 IF ((RMS(0).LT.(RMS(3)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
42961 & +RMS(2)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
42962 DCHECK(IDR) =.TRUE.
42963 XLAM = XLAM + TMIX * PYRVI1(1,2,3)
42964 ENDIF
42965 120 CONTINUE
42966C... L-R INTERFERENCES
42967C... (Only add contributions where both contributing diagrams
42968C... are non-resonant).
42969 IDR=1
42970 IF (DCHECK(1).AND.DCHECK(2)) THEN
42971C...Bug corrected 11/12 2001. Skands.
42972 XLAM = XLAM + 2D0 * PYRVI2(2,3,1)
42973 & * SFMIX(INTRES(1,1),2+INTRES(1,3)-1)
42974 & * SFMIX(INTRES(2,1),4+INTRES(2,3)-1)
42975 ENDIF
42976
42977 IDR=3
42978 IF (DCHECK(3).AND.DCHECK(4)) THEN
42979 XLAM = XLAM + 2D0 * PYRVI2(1,3,2)
42980 & * SFMIX(INTRES(3,1),2+INTRES(3,3)-1)
42981 & * SFMIX(INTRES(4,1),4+INTRES(4,3)-1)
42982 ENDIF
42983
42984 IDR=5
42985 IF (DCHECK(5).AND.DCHECK(6)) THEN
42986 XLAM = XLAM + 2D0 * PYRVI2(1,2,3)
42987 & * SFMIX(INTRES(5,1),2+INTRES(5,3)-1)
42988 & * SFMIX(INTRES(6,1),4+INTRES(6,3)-1)
42989 ENDIF
42990C... TRUE INTERFERENCES
42991C... (Only add contributions where both contributing diagrams
42992C... are non-resonant).
42993 PREF=-2D0
42994 IF ((KFIN-KSUSY1).EQ.24.OR.(KFIN-KSUSY1).EQ.37) PREF=2D0
42995 DO 140 IKR1 = 1,2
42996 DO 130 IKR2 = 1,2
42997 IDR = IKR1+2
42998 IDR2 = IKR2
42999 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
43000 XLAM = XLAM + PREF*PYRVI3(1,3,2) *
43001 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
43002 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
43003 ENDIF
43004
43005 IDR = IKR1+4
43006 IDR2 = IKR2
43007 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
43008 XLAM = XLAM + PREF*PYRVI3(1,2,3) *
43009 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
43010 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
43011 ENDIF
43012
43013 IDR = IKR1+4
43014 IDR2 = IKR2+2
43015 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
43016 XLAM = XLAM + PREF*PYRVI3(2,1,3) *
43017 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
43018 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
43019 ENDIF
43020 130 CONTINUE
43021 140 CONTINUE
43022
43023 RETURN
43024 END
43025
43026C*********************************************************************
43027
43028C...PYRVI1
43029C...Function to integrate resonance contributions
43030
43031 FUNCTION PYRVI1(ID1,ID2,ID3)
43032
43033 IMPLICIT NONE
43034 DOUBLE PRECISION LO,HI,PYRVI1,PYRVG1,PYGAUS
43035 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
43036 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
43037 LOGICAL MFLAG,DCMASS
43038 EXTERNAL PYRVG1,PYGAUS
43039 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
43040 & ,DCMASS,KFR(3)
43041 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
43042 SAVE/PYRVNV/,/PYRVPM/
43043C...Initialize mass and width information
43044 PYRVI1 = 0D0
43045 RM(0) = RMS(0)
43046 RM(1) = RMS(ID1)
43047 RM(2) = RMS(ID2)
43048 RM(3) = RMS(ID3)
43049 RESM(1)= RES(IDR,1)
43050 RESW(1)= RES(IDR,2)
43051C...A->B and B->A for antisparticles
43052 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
43053 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
43054C...Integration boundaries and mass flag
43055 LO = (RM(1)+RM(2))**2
43056 HI = (RM(0)-RM(3))**2
43057 MFLAG = DCMASS
43058 PYRVI1 = PYGAUS(PYRVG1,LO,HI,1D-3)
43059 RETURN
43060 END
43061
43062C*********************************************************************
43063
43064C...PYRVI2
43065C...Function to integrate L-R interference contributions
43066
43067 FUNCTION PYRVI2(ID1,ID2,ID3)
43068
43069 IMPLICIT NONE
43070 DOUBLE PRECISION LO,HI,PYRVI2, PYRVG2, PYGAUS
43071 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
43072 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
43073 LOGICAL MFLAG,DCMASS
43074 EXTERNAL PYRVG2,PYGAUS
43075 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
43076 & ,DCMASS,KFR(3)
43077 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
43078 SAVE/PYRVNV/,/PYRVPM/
43079C...Initialize mass and width information
43080 PYRVI2 = 0D0
43081 RM(0) = RMS(0)
43082 RM(1) = RMS(ID1)
43083 RM(2) = RMS(ID2)
43084 RM(3) = RMS(ID3)
43085 RESM(1)= RES(IDR,1)
43086 RESW(1)= RES(IDR,2)
43087 RESM(2)= RES(IDR+1,1)
43088 RESW(2)= RES(IDR+1,2)
43089C...A->B and B->A for antisparticles
43090 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
43091 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
43092 A(2) = AB(1+INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
43093 B(2) = AB(2-INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
43094C...Boundaries and mass flag
43095 LO = (RM(1)+RM(2))**2
43096 HI = (RM(0)-RM(3))**2
43097 MFLAG = DCMASS
43098 PYRVI2 = PYGAUS(PYRVG2,LO,HI,1D-3)
43099 RETURN
43100 END
43101
43102C*********************************************************************
43103
43104C...PYRVI3
43105C...Function to integrate true interference contributions
43106
43107 FUNCTION PYRVI3(ID1,ID2,ID3)
43108
43109 IMPLICIT NONE
43110 DOUBLE PRECISION LO,HI,PYRVI3, PYRVG3, PYGAUS
43111 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
43112 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
43113 LOGICAL MFLAG,DCMASS
43114 EXTERNAL PYRVG3,PYGAUS
43115 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
43116 & ,DCMASS,KFR(3)
43117 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
43118 SAVE/PYRVNV/,/PYRVPM/
43119C...Initialize mass and width information
43120 PYRVI3 = 0D0
43121 RM(0) = RMS(0)
43122 RM(1) = RMS(ID1)
43123 RM(2) = RMS(ID2)
43124 RM(3) = RMS(ID3)
43125 RESM(1)= RES(IDR,1)
43126 RESW(1)= RES(IDR,2)
43127 RESM(2)= RES(IDR2,1)
43128 RESW(2)= RES(IDR2,2)
43129C...A -> B and B -> A for antisparticles
43130 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
43131 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
43132 A(2) = AB(1+INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
43133 B(2) = AB(2-INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
43134C...Boundaries and mass flag
43135 LO = (RM(1)+RM(2))**2
43136 HI = (RM(0)-RM(3))**2
43137 MFLAG = DCMASS
43138 PYRVI3 = PYGAUS(PYRVG3,LO,HI,1D-3)
43139 RETURN
43140 END
43141
43142C*********************************************************************
43143
43144C...PYRVG1
43145C...Integrand for resonance contributions
43146
43147 FUNCTION PYRVG1(X)
43148
43149 IMPLICIT NONE
43150 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
43151 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY,PYRVR
43152 DOUBLE PRECISION RVR,PYRVG1,E2,E3,C1,SR1,SR2,A1,A2
43153 LOGICAL MFLAG
43154 SAVE/PYRVPM/
43155 RVR = PYRVR(X,RESM(1),RESW(1))
43156 C1 = 2D0*SQRT(MAX(0D0,X))
43157 IF (.NOT.MFLAG) THEN
43158 E2 = X/C1
43159 E3 = (RM(0)**2-X)/C1
43160 DELTAY = 4D0*E2*E3
43161 PYRVG1 = DELTAY*RVR*X*(A(1)**2+B(1)**2)*(RM(0)**2-X)
43162 ELSE
43163 E2 = (X-RM(1)**2+RM(2)**2)/C1
43164 E3 = (RM(0)**2-X-RM(3)**2)/C1
43165 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
43166 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
43167 DELTAY = 4D0*SR1*SR2
43168 A1 = 4.*A(1)*B(1)*RM(3)*RM(0)
43169 A2 = (A(1)**2+B(1)**2)*(RM(0)**2+RM(3)**2-X)
43170 PYRVG1 = DELTAY*RVR*(X-RM(1)**2-RM(2)**2)*(A1+A2)
43171 ENDIF
43172 RETURN
43173 END
43174
43175C*********************************************************************
43176
43177C...PYRVG2
43178C...Integrand for L-R interference contributions
43179
43180 FUNCTION PYRVG2(X)
43181
43182 IMPLICIT NONE
43183 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
43184 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY, PYRVS
43185 DOUBLE PRECISION RVS,PYRVG2,E2,E3,C1,SR1,SR2
43186 LOGICAL MFLAG
43187 SAVE/PYRVPM/
43188 C1 = 2D0*SQRT(MAX(0D0,X))
43189 RVS = PYRVS(X,X,RESM(1),RESW(1),RESM(2),RESW(2))
43190 IF (.NOT.MFLAG) THEN
43191 E2 = X/C1
43192 E3 = (RM(0)**2-X)/C1
43193 DELTAY = 4D0*E2*E3
43194 PYRVG2 = DELTAY*RVS*X*(A(1)*A(2)+B(1)*B(2))*(RM(0)**2-X)
43195 ELSE
43196 E2 = (X-RM(1)**2+RM(2)**2)/C1
43197 E3 = (RM(0)**2-X-RM(3)**2)/C1
43198 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
43199 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
43200 DELTAY = 4D0*SR1*SR2
43201 PYRVG2 = DELTAY*RVS*(X-RM(1)**2-RM(2)**2)*((A(1)*A(2)
43202 & + B(1)*B(2))*(RM(0)**2+RM(3)**2-X)
43203 & + 2D0*(A(1)*B(2)+A(2)*B(1))*RM(3)*RM(0))
43204 ENDIF
43205 RETURN
43206 END
43207
43208C*********************************************************************
43209
43210C...PYRVG3
43211C...Function to do Y integration over true interference contributions
43212
43213 FUNCTION PYRVG3(X)
43214
43215 IMPLICIT NONE
43216 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
43217C...Second Dalitz variable for PYRVG4
43218 COMMON/PYG2DX/X1
43219 DOUBLE PRECISION RM, A, B, RESM, RESW, X, X1
43220 DOUBLE PRECISION E2, E3, C1, SQ1, SR1, SR2, YMIN, YMAX
43221 DOUBLE PRECISION PYRVG3, PYRVG4, PYGAU2
43222 LOGICAL MFLAG
43223 EXTERNAL PYGAU2,PYRVG4
43224 SAVE/PYRVPM/,/PYG2DX/
43225 PYRVG3=0D0
43226 C1=2D0*SQRT(MAX(1D-9,X))
43227 X1=X
43228 IF (.NOT.MFLAG) THEN
43229 E2 = X/C1
43230 E3 = (RM(0)**2-X)/C1
43231 YMIN = 0D0
43232 YMAX = 4D0*E2*E3
43233 ELSE
43234 E2 = (X-RM(1)**2+RM(2)**2)/C1
43235 E3 = (RM(0)**2-X-RM(3)**2)/C1
43236 SQ1 = (E2+E3)**2
43237 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
43238 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
43239 YMIN = SQ1-(SR1+SR2)**2
43240 YMAX = SQ1-(SR1-SR2)**2
43241 ENDIF
43242 PYRVG3 = PYGAU2(PYRVG4,YMIN,YMAX,1D-3)
43243 RETURN
43244 END
43245
43246C*********************************************************************
43247
43248C...PYRVG4
43249C...Integrand for true intereference contributions
43250
43251 FUNCTION PYRVG4(Y)
43252
43253 IMPLICIT NONE
43254 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
43255 COMMON/PYG2DX/X
43256 DOUBLE PRECISION X, Y, PYRVG4, RM, A, B, RESM, RESW, RVS, PYRVS
43257 LOGICAL MFLAG
43258 SAVE /PYRVPM/,/PYG2DX/
43259 PYRVG4=0D0
43260 RVS=PYRVS(X,Y,RESM(1),RESW(1),RESM(2),RESW(2))
43261 IF (.NOT.MFLAG) THEN
43262 PYRVG4 = RVS*B(1)*B(2)*X*Y
43263 ELSE
43264 PYRVG4 = RVS*(RM(1)*RM(3)*A(1)*A(2)*(X+Y-RM(1)**2-RM(3)**2)
43265 & + RM(1)*RM(0)*B(1)*A(2)*(Y-RM(2)**2-RM(3)**2)
43266 & + RM(3)*RM(0)*A(1)*B(2)*(X-RM(1)**2-RM(2)**2)
43267 & + B(1)*B(2)*(X*Y-(RM(1)*RM(3))**2-(RM(0)*RM(2))**2))
43268 ENDIF
43269 RETURN
43270 END
43271
43272C*********************************************************************
43273
43274C...PYRVR
43275C...Breit-Wigner for resonance contributions
43276
43277 FUNCTION PYRVR(Mab2,RM,RW)
43278
43279 IMPLICIT NONE
43280 DOUBLE PRECISION Mab2,RM,RW,PYRVR
43281 PYRVR = 1D0/((Mab2-RM**2)**2+RM**2*RW**2)
43282 RETURN
43283 END
43284
43285C*********************************************************************
43286
43287C...PYRVS
43288C...Interference function
43289
43290 FUNCTION PYRVS(X,Y,M1,W1,M2,W2)
43291
43292 IMPLICIT NONE
43293 DOUBLE PRECISION X, Y, PYRVS, PYRVR, M1, M2, W1, W2
43294 PYRVS = PYRVR(X,M1,W1)*PYRVR(Y,M2,W2)*((X-M1**2)*(Y-M2**2)
43295 & +W1*W2*M1*M2)
43296 RETURN
43297 END
43298
43299C*********************************************************************
43300
43301C...PY1ENT
43302C...Stores one parton/particle in commonblock PYJETS.
43303
43304 SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
43305
43306C...Double precision and integer declarations.
43307 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43308 IMPLICIT INTEGER(I-N)
43309 INTEGER PYK,PYCHGE,PYCOMP
43310C...Commonblocks.
43311 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43312 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43313 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43314 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
43315
43316C...Standard checks.
43317 MSTU(28)=0
43318 IF(MSTU(12).GE.1) CALL PYLIST(0)
43319 IPA=MAX(1,IABS(IP))
43320 IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
43321 &'(PY1ENT:) writing outside PYJETS memory')
43322 KC=PYCOMP(KF)
43323 IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
43324
43325C...Find mass. Reset K, P and V vectors.
43326 PM=0D0
43327 IF(MSTU(10).EQ.1) PM=P(IPA,5)
43328 IF(MSTU(10).GE.2) PM=PYMASS(KF)
43329 DO 100 J=1,5
43330 K(IPA,J)=0
43331 P(IPA,J)=0D0
43332 V(IPA,J)=0D0
43333 100 CONTINUE
43334
43335C...Store parton/particle in K and P vectors.
43336 K(IPA,1)=1
43337 IF(IP.LT.0) K(IPA,1)=2
43338 K(IPA,2)=KF
43339 P(IPA,5)=PM
43340 P(IPA,4)=MAX(PE,PM)
43341 PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
43342 P(IPA,1)=PA*SIN(THE)*COS(PHI)
43343 P(IPA,2)=PA*SIN(THE)*SIN(PHI)
43344 P(IPA,3)=PA*COS(THE)
43345
43346C...Set N. Optionally fragment/decay.
43347 N=IPA
43348 IF(IP.EQ.0) CALL PYEXEC
43349
43350 RETURN
43351 END
43352
43353C*********************************************************************
43354
43355C...PY2ENT
43356C...Stores two partons/particles in their CM frame,
43357C...with the first along the +z axis.
43358
43359 SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
43360
43361C...Double precision and integer declarations.
43362 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43363 IMPLICIT INTEGER(I-N)
43364 INTEGER PYK,PYCHGE,PYCOMP
43365C...Commonblocks.
43366 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43367 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43368 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43369 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
43370
43371C...Standard checks.
43372 MSTU(28)=0
43373 IF(MSTU(12).GE.1) CALL PYLIST(0)
43374 IPA=MAX(1,IABS(IP))
43375 IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
43376 &'(PY2ENT:) writing outside PYJETS memory')
43377 KC1=PYCOMP(KF1)
43378 KC2=PYCOMP(KF2)
43379 IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
43380 &'(PY2ENT:) unknown flavour code')
43381
43382C...Find masses. Reset K, P and V vectors.
43383 PM1=0D0
43384 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
43385 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
43386 PM2=0D0
43387 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
43388 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
43389 DO 110 I=IPA,IPA+1
43390 DO 100 J=1,5
43391 K(I,J)=0
43392 P(I,J)=0D0
43393 V(I,J)=0D0
43394 100 CONTINUE
43395 110 CONTINUE
43396
43397C...Check flavours.
43398 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
43399 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
43400 IF(MSTU(19).EQ.1) THEN
43401 MSTU(19)=0
43402 ELSE
43403 IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
43404 & '(PY2ENT:) unphysical flavour combination')
43405 ENDIF
43406 K(IPA,2)=KF1
43407 K(IPA+1,2)=KF2
43408
43409C...Store partons/particles in K vectors for normal case.
43410 IF(IP.GE.0) THEN
43411 K(IPA,1)=1
43412 IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
43413 K(IPA+1,1)=1
43414
43415C...Store partons in K vectors for parton shower evolution.
43416 ELSE
43417 K(IPA,1)=3
43418 K(IPA+1,1)=3
43419 K(IPA,4)=MSTU(5)*(IPA+1)
43420 K(IPA,5)=K(IPA,4)
43421 K(IPA+1,4)=MSTU(5)*IPA
43422 K(IPA+1,5)=K(IPA+1,4)
43423 ENDIF
43424
43425C...Check kinematics and store partons/particles in P vectors.
43426 IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
43427 &'(PY2ENT:) energy smaller than sum of masses')
43428 PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/
43429 &(2D0*PECM)
43430 P(IPA,3)=PA
43431 P(IPA,4)=SQRT(PM1**2+PA**2)
43432 P(IPA,5)=PM1
43433 P(IPA+1,3)=-PA
43434 P(IPA+1,4)=SQRT(PM2**2+PA**2)
43435 P(IPA+1,5)=PM2
43436
43437C...Set N. Optionally fragment/decay.
43438 N=IPA+1
43439 IF(IP.EQ.0) CALL PYEXEC
43440
43441 RETURN
43442 END
43443
43444C*********************************************************************
43445
43446C...PY3ENT
43447C...Stores three partons or particles in their CM frame,
43448C...with the first along the +z axis and the third in the (x,z)
43449C...plane with x > 0.
43450
43451 SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
43452
43453C...Double precision and integer declarations.
43454 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43455 IMPLICIT INTEGER(I-N)
43456 INTEGER PYK,PYCHGE,PYCOMP
43457C...Commonblocks.
43458 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43459 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43460 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43461 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
43462
43463C...Standard checks.
43464 MSTU(28)=0
43465 IF(MSTU(12).GE.1) CALL PYLIST(0)
43466 IPA=MAX(1,IABS(IP))
43467 IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
43468 &'(PY3ENT:) writing outside PYJETS memory')
43469 KC1=PYCOMP(KF1)
43470 KC2=PYCOMP(KF2)
43471 KC3=PYCOMP(KF3)
43472 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
43473 &'(PY3ENT:) unknown flavour code')
43474
43475C...Find masses. Reset K, P and V vectors.
43476 PM1=0D0
43477 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
43478 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
43479 PM2=0D0
43480 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
43481 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
43482 PM3=0D0
43483 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
43484 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
43485 DO 110 I=IPA,IPA+2
43486 DO 100 J=1,5
43487 K(I,J)=0
43488 P(I,J)=0D0
43489 V(I,J)=0D0
43490 100 CONTINUE
43491 110 CONTINUE
43492
43493C...Check flavours.
43494 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
43495 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
43496 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
43497 IF(MSTU(19).EQ.1) THEN
43498 MSTU(19)=0
43499 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
43500 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
43501 & KQ1+KQ3.EQ.4)) THEN
43502 ELSE
43503 CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
43504 ENDIF
43505 K(IPA,2)=KF1
43506 K(IPA+1,2)=KF2
43507 K(IPA+2,2)=KF3
43508
43509C...Store partons/particles in K vectors for normal case.
43510 IF(IP.GE.0) THEN
43511 K(IPA,1)=1
43512 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
43513 K(IPA+1,1)=1
43514 IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
43515 K(IPA+2,1)=1
43516
43517C...Store partons in K vectors for parton shower evolution.
43518 ELSE
43519 K(IPA,1)=3
43520 K(IPA+1,1)=3
43521 K(IPA+2,1)=3
43522 KCS=4
43523 IF(KQ1.EQ.-1) KCS=5
43524 K(IPA,KCS)=MSTU(5)*(IPA+1)
43525 K(IPA,9-KCS)=MSTU(5)*(IPA+2)
43526 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
43527 K(IPA+1,9-KCS)=MSTU(5)*IPA
43528 K(IPA+2,KCS)=MSTU(5)*IPA
43529 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
43530 ENDIF
43531
43532C...Check kinematics.
43533 MKERR=0
43534 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR.
43535 &0.5D0*X3*PECM.LE.PM3) MKERR=1
43536 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
43537 PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2))
43538 PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2))
43539 CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2)
43540 CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3)
43541 IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1
43542 CTHE3=MAX(-1D0,MIN(1D0,CTHE3))
43543 IF(MKERR.NE.0) CALL PYERRM(13,
43544 &'(PY3ENT:) unphysical kinematical variable setup')
43545
43546C...Store partons/particles in P vectors.
43547 P(IPA,3)=PA1
43548 P(IPA,4)=SQRT(PA1**2+PM1**2)
43549 P(IPA,5)=PM1
43550 P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2)
43551 P(IPA+2,3)=PA3*CTHE3
43552 P(IPA+2,4)=SQRT(PA3**2+PM3**2)
43553 P(IPA+2,5)=PM3
43554 P(IPA+1,1)=-P(IPA+2,1)
43555 P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
43556 P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
43557 P(IPA+1,5)=PM2
43558
43559C...Set N. Optionally fragment/decay.
43560 N=IPA+2
43561 IF(IP.EQ.0) CALL PYEXEC
43562
43563 RETURN
43564 END
43565
43566C*********************************************************************
43567
43568C...PY4ENT
43569C...Stores four partons or particles in their CM frame, with
43570C...the first along the +z axis, the last in the xz plane with x > 0
43571C...and the second having y < 0 and y > 0 with equal probability.
43572
43573 SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
43574
43575C...Double precision and integer declarations.
43576 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43577 IMPLICIT INTEGER(I-N)
43578 INTEGER PYK,PYCHGE,PYCOMP
43579C...Commonblocks.
43580 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43581 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43582 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43583 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
43584
43585C...Standard checks.
43586 MSTU(28)=0
43587 IF(MSTU(12).GE.1) CALL PYLIST(0)
43588 IPA=MAX(1,IABS(IP))
43589 IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
43590 &'(PY4ENT:) writing outside PYJETS momory')
43591 KC1=PYCOMP(KF1)
43592 KC2=PYCOMP(KF2)
43593 KC3=PYCOMP(KF3)
43594 KC4=PYCOMP(KF4)
43595 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
43596 &'(PY4ENT:) unknown flavour code')
43597
43598C...Find masses. Reset K, P and V vectors.
43599 PM1=0D0
43600 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
43601 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
43602 PM2=0D0
43603 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
43604 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
43605 PM3=0D0
43606 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
43607 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
43608 PM4=0D0
43609 IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
43610 IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
43611 DO 110 I=IPA,IPA+3
43612 DO 100 J=1,5
43613 K(I,J)=0
43614 P(I,J)=0D0
43615 V(I,J)=0D0
43616 100 CONTINUE
43617 110 CONTINUE
43618
43619C...Check flavours.
43620 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
43621 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
43622 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
43623 KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
43624 IF(MSTU(19).EQ.1) THEN
43625 MSTU(19)=0
43626 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
43627 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
43628 & KQ1+KQ4.EQ.4)) THEN
43629 ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
43630 & THEN
43631 ELSE
43632 CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
43633 ENDIF
43634 K(IPA,2)=KF1
43635 K(IPA+1,2)=KF2
43636 K(IPA+2,2)=KF3
43637 K(IPA+3,2)=KF4
43638
43639C...Store partons/particles in K vectors for normal case.
43640 IF(IP.GE.0) THEN
43641 K(IPA,1)=1
43642 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
43643 K(IPA+1,1)=1
43644 IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
43645 & K(IPA+1,1)=2
43646 K(IPA+2,1)=1
43647 IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
43648 K(IPA+3,1)=1
43649
43650C...Store partons for parton shower evolution from q-g-g-qbar or
43651C...g-g-g-g event.
43652 ELSEIF(KQ1+KQ2.NE.0) THEN
43653 K(IPA,1)=3
43654 K(IPA+1,1)=3
43655 K(IPA+2,1)=3
43656 K(IPA+3,1)=3
43657 KCS=4
43658 IF(KQ1.EQ.-1) KCS=5
43659 K(IPA,KCS)=MSTU(5)*(IPA+1)
43660 K(IPA,9-KCS)=MSTU(5)*(IPA+3)
43661 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
43662 K(IPA+1,9-KCS)=MSTU(5)*IPA
43663 K(IPA+2,KCS)=MSTU(5)*(IPA+3)
43664 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
43665 K(IPA+3,KCS)=MSTU(5)*IPA
43666 K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
43667
43668C...Store partons for parton shower evolution from q-qbar-q-qbar event.
43669 ELSE
43670 K(IPA,1)=3
43671 K(IPA+1,1)=3
43672 K(IPA+2,1)=3
43673 K(IPA+3,1)=3
43674 K(IPA,4)=MSTU(5)*(IPA+1)
43675 K(IPA,5)=K(IPA,4)
43676 K(IPA+1,4)=MSTU(5)*IPA
43677 K(IPA+1,5)=K(IPA+1,4)
43678 K(IPA+2,4)=MSTU(5)*(IPA+3)
43679 K(IPA+2,5)=K(IPA+2,4)
43680 K(IPA+3,4)=MSTU(5)*(IPA+2)
43681 K(IPA+3,5)=K(IPA+3,4)
43682 ENDIF
43683
43684C...Check kinematics.
43685 MKERR=0
43686 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR.
43687 &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4)
43688 &MKERR=1
43689 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
43690 PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2))
43691 PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2))
43692 X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
43693 CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4)
43694 IF(ABS(CTHE4).GE.1.002D0) MKERR=1
43695 CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
43696 STHE4=SQRT(1D0-CTHE4**2)
43697 CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2)
43698 IF(ABS(CTHE2).GE.1.002D0) MKERR=1
43699 CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
43700 STHE2=SQRT(1D0-CTHE2**2)
43701 CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/
43702 &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4)
43703 IF(ABS(CPHI2).GE.1.05D0) MKERR=1
43704 CPHI2=MAX(-1D0,MIN(1D0,CPHI2))
43705 IF(MKERR.EQ.1) CALL PYERRM(13,
43706 &'(PY4ENT:) unphysical kinematical variable setup')
43707
43708C...Store partons/particles in P vectors.
43709 P(IPA,3)=PA1
43710 P(IPA,4)=SQRT(PA1**2+PM1**2)
43711 P(IPA,5)=PM1
43712 P(IPA+3,1)=PA4*STHE4
43713 P(IPA+3,3)=PA4*CTHE4
43714 P(IPA+3,4)=SQRT(PA4**2+PM4**2)
43715 P(IPA+3,5)=PM4
43716 P(IPA+1,1)=PA2*STHE2*CPHI2
43717 P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0)
43718 P(IPA+1,3)=PA2*CTHE2
43719 P(IPA+1,4)=SQRT(PA2**2+PM2**2)
43720 P(IPA+1,5)=PM2
43721 P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
43722 P(IPA+2,2)=-P(IPA+1,2)
43723 P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
43724 P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
43725 P(IPA+2,5)=PM3
43726
43727C...Set N. Optionally fragment/decay.
43728 N=IPA+3
43729 IF(IP.EQ.0) CALL PYEXEC
43730
43731 RETURN
43732 END
43733
43734C*********************************************************************
43735
43736C...PY2FRM
43737C...An interface from a two-fermion generator to include
43738C...parton showers and hadronization.
43739
43740 SUBROUTINE PY2FRM(IRAD,ITAU,ICOM)
43741
43742C...Double precision and integer declarations.
43743 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43744 IMPLICIT INTEGER(I-N)
43745 INTEGER PYK,PYCHGE,PYCOMP
43746C...Commonblocks.
43747 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43748 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43749 SAVE /PYJETS/,/PYDAT1/
43750C...Local arrays.
43751 DIMENSION IJOIN(2),INTAU(2)
43752
43753C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
43754 IF(ICOM.EQ.0) THEN
43755 MSTU(28)=0
43756 CALL PYHEPC(2)
43757 ENDIF
43758
43759C...Loop through entries and pick up all final fermions/antifermions.
43760 I1=0
43761 I2=0
43762 DO 100 I=1,N
43763 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
43764 KFA=IABS(K(I,2))
43765 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
43766 IF(K(I,2).GT.0) THEN
43767 IF(I1.EQ.0) THEN
43768 I1=I
43769 ELSE
43770 CALL PYERRM(16,'(PY2FRM:) more than one fermion')
43771 ENDIF
43772 ELSE
43773 IF(I2.EQ.0) THEN
43774 I2=I
43775 ELSE
43776 CALL PYERRM(16,'(PY2FRM:) more than one antifermion')
43777 ENDIF
43778 ENDIF
43779 ENDIF
43780 100 CONTINUE
43781
43782C...Check that event is arranged according to conventions.
43783 IF(I1.EQ.0.OR.I2.EQ.0) THEN
43784 CALL PYERRM(16,'(PY2FRM:) event contains too few fermions')
43785 ENDIF
43786 IF(I2.LT.I1) THEN
43787 CALL PYERRM(6,'(PY2FRM:) fermions arranged in wrong order')
43788 ENDIF
43789
43790C...Check whether fermion pair is quarks or leptons.
43791 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
43792 IQL12=1
43793 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
43794 IQL12=2
43795 ELSE
43796 CALL PYERRM(16,'(PY2FRM:) fermion pair inconsistent')
43797 ENDIF
43798
43799C...Decide whether to allow or not photon radiation in showers.
43800 MSTJ(41)=2
43801 IF(IRAD.EQ.0) MSTJ(41)=1
43802
43803C...Do colour joining and parton showers.
43804 IP1=I1
43805 IP2=I2
43806 IF(IQL12.EQ.1) THEN
43807 IJOIN(1)=IP1
43808 IJOIN(2)=IP2
43809 CALL PYJOIN(2,IJOIN)
43810 ENDIF
43811 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
43812 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
43813 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
43814 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
43815 ENDIF
43816
43817C...Do fragmentation and decays. Possibly except tau decay.
43818 IF(ITAU.EQ.0) THEN
43819 NTAU=0
43820 DO 110 I=1,N
43821 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
43822 NTAU=NTAU+1
43823 INTAU(NTAU)=I
43824 K(I,1)=11
43825 ENDIF
43826 110 CONTINUE
43827 ENDIF
43828 CALL PYEXEC
43829 IF(ITAU.EQ.0) THEN
43830 DO 120 I=1,NTAU
43831 K(INTAU(I),1)=1
43832 120 CONTINUE
43833 ENDIF
43834
43835C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
43836 IF(ICOM.EQ.0) THEN
43837 MSTU(28)=0
43838 CALL PYHEPC(1)
43839 ENDIF
43840
43841 END
43842
43843C*********************************************************************
43844
43845C...PY4FRM
43846C...An interface from a four-fermion generator to include
43847C...parton showers and hadronization.
43848
43849 SUBROUTINE PY4FRM(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)
43850
43851C...Double precision and integer declarations.
43852 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43853 IMPLICIT INTEGER(I-N)
43854 INTEGER PYK,PYCHGE,PYCOMP
43855C...Commonblocks.
43856 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43857 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43858 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
43859 COMMON/PYINT1/MINT(400),VINT(400)
43860 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
43861C...Local arrays.
43862 DIMENSION IJOIN(2),INTAU(4)
43863
43864C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
43865 IF(ICOM.EQ.0) THEN
43866 MSTU(28)=0
43867 CALL PYHEPC(2)
43868 ENDIF
43869
43870C...Loop through entries and pick up all final fermions/antifermions.
43871 I1=0
43872 I2=0
43873 I3=0
43874 I4=0
43875 DO 100 I=1,N
43876 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
43877 KFA=IABS(K(I,2))
43878 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
43879 IF(K(I,2).GT.0) THEN
43880 IF(I1.EQ.0) THEN
43881 I1=I
43882 ELSEIF(I3.EQ.0) THEN
43883 I3=I
43884 ELSE
43885 CALL PYERRM(16,'(PY4FRM:) more than two fermions')
43886 ENDIF
43887 ELSE
43888 IF(I2.EQ.0) THEN
43889 I2=I
43890 ELSEIF(I4.EQ.0) THEN
43891 I4=I
43892 ELSE
43893 CALL PYERRM(16,'(PY4FRM:) more than two antifermions')
43894 ENDIF
43895 ENDIF
43896 ENDIF
43897 100 CONTINUE
43898
43899C...Check that event is arranged according to conventions.
43900 IF(I3.EQ.0.OR.I4.EQ.0) THEN
43901 CALL PYERRM(16,'(PY4FRM:) event contains too few fermions')
43902 ENDIF
43903 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
43904 CALL PYERRM(6,'(PY4FRM:) fermions arranged in wrong order')
43905 ENDIF
43906
43907C...Check which fermion pairs are quarks and which leptons.
43908 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
43909 IQL12=1
43910 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
43911 IQL12=2
43912 ELSE
43913 CALL PYERRM(16,'(PY4FRM:) first fermion pair inconsistent')
43914 ENDIF
43915 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
43916 IQL34=1
43917 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
43918 IQL34=2
43919 ELSE
43920 CALL PYERRM(16,'(PY4FRM:) second fermion pair inconsistent')
43921 ENDIF
43922
43923C...Decide whether to allow or not photon radiation in showers.
43924 MSTJ(41)=2
43925 IF(IRAD.EQ.0) MSTJ(41)=1
43926
43927C...Decide on dipole pairing.
43928 IP1=I1
43929 IP2=I2
43930 IP3=I3
43931 IP4=I4
43932 IF(IQL12.EQ.IQL34) THEN
43933 R1SQ=A1SQ
43934 R2SQ=A2SQ
43935 DELTA=ATOTSQ-A1SQ-A2SQ
43936 IF(ISTRAT.EQ.1) THEN
43937 IF(DELTA.GT.0D0) R1SQ=R1SQ+DELTA
43938 IF(DELTA.LT.0D0) R2SQ=MAX(0D0,R2SQ+DELTA)
43939 ELSEIF(ISTRAT.EQ.2) THEN
43940 IF(DELTA.GT.0D0) R2SQ=R2SQ+DELTA
43941 IF(DELTA.LT.0D0) R1SQ=MAX(0D0,R1SQ+DELTA)
43942 ENDIF
43943 IF(R2SQ.GT.PYR(0)*(R1SQ+R2SQ)) THEN
43944 IP2=I4
43945 IP4=I2
43946 ENDIF
43947 ENDIF
43948
43949C...If colour reconnection then bookkeep W+W- or Z0Z0
43950C...and copy q qbar q qbar consecutively.
43951 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
43952 K(N+1,1)=11
43953 K(N+1,3)=IP1
43954 K(N+1,4)=N+3
43955 K(N+1,5)=N+4
43956 K(N+2,1)=11
43957 K(N+2,3)=IP3
43958 K(N+2,4)=N+5
43959 K(N+2,5)=N+6
43960 IF(K(IP1,2)+K(IP2,2).EQ.0) THEN
43961 K(N+1,2)=23
43962 K(N+2,2)=23
43963 MINT(1)=22
43964 ELSEIF(PYCHGE(K(IP1,2)).GT.0) THEN
43965 K(N+1,2)=24
43966 K(N+2,2)=-24
43967 MINT(1)=25
43968 ELSE
43969 K(N+1,2)=-24
43970 K(N+2,2)=24
43971 MINT(1)=25
43972 ENDIF
43973 DO 110 J=1,5
43974 K(N+3,J)=K(IP1,J)
43975 K(N+4,J)=K(IP2,J)
43976 K(N+5,J)=K(IP3,J)
43977 K(N+6,J)=K(IP4,J)
43978 P(N+1,J)=P(IP1,J)+P(IP2,J)
43979 P(N+2,J)=P(IP3,J)+P(IP4,J)
43980 P(N+3,J)=P(IP1,J)
43981 P(N+4,J)=P(IP2,J)
43982 P(N+5,J)=P(IP3,J)
43983 P(N+6,J)=P(IP4,J)
43984 V(N+1,J)=V(IP1,J)
43985 V(N+2,J)=V(IP3,J)
43986 V(N+3,J)=V(IP1,J)
43987 V(N+4,J)=V(IP2,J)
43988 V(N+5,J)=V(IP3,J)
43989 V(N+6,J)=V(IP4,J)
43990 110 CONTINUE
43991 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
43992 & P(N+1,3)**2))
43993 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
43994 & P(N+2,3)**2))
43995 K(N+3,3)=N+1
43996 K(N+4,3)=N+1
43997 K(N+5,3)=N+2
43998 K(N+6,3)=N+2
43999C...Remove original q qbar q qbar and update counters.
44000 K(IP1,1)=K(IP1,1)+10
44001 K(IP2,1)=K(IP2,1)+10
44002 K(IP3,1)=K(IP3,1)+10
44003 K(IP4,1)=K(IP4,1)+10
44004 IW1=N+1
44005 IW2=N+2
44006 NSD1=N+2
44007 IP1=N+3
44008 IP2=N+4
44009 IP3=N+5
44010 IP4=N+6
44011 N=N+6
44012 ENDIF
44013
44014C...Do colour joinings and parton showers.
44015 IF(IQL12.EQ.1) THEN
44016 IJOIN(1)=IP1
44017 IJOIN(2)=IP2
44018 CALL PYJOIN(2,IJOIN)
44019 ENDIF
44020 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
44021 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
44022 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
44023 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
44024 ENDIF
44025 NAFT1=N
44026 IF(IQL34.EQ.1) THEN
44027 IJOIN(1)=IP3
44028 IJOIN(2)=IP4
44029 CALL PYJOIN(2,IJOIN)
44030 ENDIF
44031 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
44032 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
44033 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
44034 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
44035 ENDIF
44036
44037C...Optionally do colour reconnection.
44038 MINT(32)=0
44039 MSTI(32)=0
44040 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
44041 CALL PYRECO(IW1,IW2,NSD1,NAFT1)
44042 MSTI(32)=MINT(32)
44043 ENDIF
44044
44045C...Do fragmentation and decays. Possibly except tau decay.
44046 IF(ITAU.EQ.0) THEN
44047 NTAU=0
44048 DO 120 I=1,N
44049 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
44050 NTAU=NTAU+1
44051 INTAU(NTAU)=I
44052 K(I,1)=11
44053 ENDIF
44054 120 CONTINUE
44055 ENDIF
44056 CALL PYEXEC
44057 IF(ITAU.EQ.0) THEN
44058 DO 130 I=1,NTAU
44059 K(INTAU(I),1)=1
44060 130 CONTINUE
44061 ENDIF
44062
44063C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
44064 IF(ICOM.EQ.0) THEN
44065 MSTU(28)=0
44066 CALL PYHEPC(1)
44067 ENDIF
44068
44069 END
44070
44071C*********************************************************************
44072
44073C...PY6FRM
44074C...An interface from a six-fermion generator to include
44075C...parton showers and hadronization.
44076
44077 SUBROUTINE PY6FRM(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)
44078
44079C...Double precision and integer declarations.
44080 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44081 IMPLICIT INTEGER(I-N)
44082 INTEGER PYK,PYCHGE,PYCOMP
44083C...Commonblocks.
44084 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
44085 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44086 SAVE /PYJETS/,/PYDAT1/
44087C...Local arrays.
44088 DIMENSION IJOIN(2),INTAU(6),BETA(3),BETAO(3),BETAN(3)
44089
44090C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
44091 IF(ICOM.EQ.0) THEN
44092 MSTU(28)=0
44093 CALL PYHEPC(2)
44094 ENDIF
44095
44096C...Loop through entries and pick up all final fermions/antifermions.
44097 I1=0
44098 I2=0
44099 I3=0
44100 I4=0
44101 I5=0
44102 I6=0
44103 DO 100 I=1,N
44104 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
44105 KFA=IABS(K(I,2))
44106 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
44107 IF(K(I,2).GT.0) THEN
44108 IF(I1.EQ.0) THEN
44109 I1=I
44110 ELSEIF(I3.EQ.0) THEN
44111 I3=I
44112 ELSEIF(I5.EQ.0) THEN
44113 I5=I
44114 ELSE
44115 CALL PYERRM(16,'(PY6FRM:) more than three fermions')
44116 ENDIF
44117 ELSE
44118 IF(I2.EQ.0) THEN
44119 I2=I
44120 ELSEIF(I4.EQ.0) THEN
44121 I4=I
44122 ELSEIF(I6.EQ.0) THEN
44123 I6=I
44124 ELSE
44125 CALL PYERRM(16,'(PY6FRM:) more than three antifermions')
44126 ENDIF
44127 ENDIF
44128 ENDIF
44129 100 CONTINUE
44130
44131C...Check that event is arranged according to conventions.
44132 IF(I5.EQ.0.OR.I6.EQ.0) THEN
44133 CALL PYERRM(16,'(PY6FRM:) event contains too few fermions')
44134 ENDIF
44135 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3.OR.I5.LT.I4.OR.I6.LT.I5) THEN
44136 CALL PYERRM(6,'(PY6FRM:) fermions arranged in wrong order')
44137 ENDIF
44138
44139C...Check which fermion pairs are quarks and which leptons.
44140 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
44141 IQL12=1
44142 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
44143 IQL12=2
44144 ELSE
44145 CALL PYERRM(16,'(PY6FRM:) first fermion pair inconsistent')
44146 ENDIF
44147 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
44148 IQL34=1
44149 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
44150 IQL34=2
44151 ELSE
44152 CALL PYERRM(16,'(PY6FRM:) second fermion pair inconsistent')
44153 ENDIF
44154 IF(IABS(K(I5,2)).LT.10.AND.IABS(K(I6,2)).LT.10) THEN
44155 IQL56=1
44156 ELSEIF(IABS(K(I5,2)).GT.10.AND.IABS(K(I6,2)).GT.10) THEN
44157 IQL56=2
44158 ELSE
44159 CALL PYERRM(16,'(PY6FRM:) third fermion pair inconsistent')
44160 ENDIF
44161
44162C...Decide whether to allow or not photon radiation in showers.
44163 MSTJ(41)=2
44164 IF(IRAD.EQ.0) MSTJ(41)=1
44165
44166C...Allow dipole pairings only among leptons and quarks separately.
44167 P12D=P12
44168 P13D=0D0
44169 IF(IQL34.EQ.IQL56) P13D=P13
44170 P21D=0D0
44171 IF(IQL12.EQ.IQL34) P21D=P21
44172 P23D=0D0
44173 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P23D=P23
44174 P31D=0D0
44175 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P31D=P31
44176 P32D=0D0
44177 IF(IQL12.EQ.IQL56) P32D=P32
44178
44179C...Decide whether t+tbar.
44180 ITOP=0
44181 IF(PYR(0).LT.PTOP) THEN
44182 ITOP=1
44183
44184C...If t+tbar: reconstruct t's.
44185 IT=N+1
44186 ITB=N+2
44187 DO 110 J=1,5
44188 K(IT,J)=0
44189 K(ITB,J)=0
44190 P(IT,J)=P(I1,J)+P(I3,J)+P(I4,J)
44191 P(ITB,J)=P(I2,J)+P(I5,J)+P(I6,J)
44192 V(IT,J)=0D0
44193 V(ITB,J)=0D0
44194 110 CONTINUE
44195 K(IT,1)=1
44196 K(ITB,1)=1
44197 K(IT,2)=6
44198 K(ITB,2)=-6
44199 P(IT,5)=SQRT(MAX(0D0,P(IT,4)**2-P(IT,1)**2-P(IT,2)**2-
44200 & P(IT,3)**2))
44201 P(ITB,5)=SQRT(MAX(0D0,P(ITB,4)**2-P(ITB,1)**2-P(ITB,2)**2-
44202 & P(ITB,3)**2))
44203 N=N+2
44204
44205C...If t+tbar: colour join t's and let them shower.
44206 IJOIN(1)=IT
44207 IJOIN(2)=ITB
44208 CALL PYJOIN(2,IJOIN)
44209 PMTTS=(P(IT,4)+P(ITB,4))**2-(P(IT,1)+P(ITB,1))**2-
44210 & (P(IT,2)+P(ITB,2))**2-(P(IT,3)+P(ITB,3))**2
44211 CALL PYSHOW(IT,ITB,SQRT(MAX(0D0,PMTTS)))
44212
44213C...If t+tbar: pick up the t's after shower.
44214 ITNEW=IT
44215 ITBNEW=ITB
44216 DO 120 I=ITB+1,N
44217 IF(K(I,2).EQ.6) ITNEW=I
44218 IF(K(I,2).EQ.-6) ITBNEW=I
44219 120 CONTINUE
44220
44221C...If t+tbar: loop over two top systems.
44222 DO 200 IT1=1,2
44223 IF(IT1.EQ.1) THEN
44224 ITO=IT
44225 ITN=ITNEW
44226 IBO=I1
44227 IW1=I3
44228 IW2=I4
44229 ELSE
44230 ITO=ITB
44231 ITN=ITBNEW
44232 IBO=I2
44233 IW1=I5
44234 IW2=I6
44235 ENDIF
44236 IF(IABS(K(IBO,2)).NE.5) CALL PYERRM(6,
44237 & '(PY6FRM:) not b in t decay')
44238
44239C...If t+tbar: find boost from original to new top frame.
44240 DO 130 J=1,3
44241 BETAO(J)=P(ITO,J)/P(ITO,4)
44242 BETAN(J)=P(ITN,J)/P(ITN,4)
44243 130 CONTINUE
44244
44245C...If t+tbar: boost copy of b by t shower and connect it in colour.
44246 N=N+1
44247 IB=N
44248 K(IB,1)=3
44249 K(IB,2)=K(IBO,2)
44250 K(IB,3)=ITN
44251 DO 140 J=1,5
44252 P(IB,J)=P(IBO,J)
44253 V(IB,J)=0D0
44254 140 CONTINUE
44255 CALL PYROBO(IB,IB,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
44256 CALL PYROBO(IB,IB,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
44257 K(IB,4)=MSTU(5)*ITN
44258 K(IB,5)=MSTU(5)*ITN
44259 K(ITN,4)=K(ITN,4)+IB
44260 K(ITN,5)=K(ITN,5)+IB
44261 K(ITN,1)=K(ITN,1)+10
44262 K(IBO,1)=K(IBO,1)+10
44263
44264C...If t+tbar: construct W recoiling against b.
44265 N=N+1
44266 IW=N
44267 DO 150 J=1,5
44268 K(IW,J)=0
44269 V(IW,J)=0D0
44270 150 CONTINUE
44271 K(IW,1)=1
44272 KCHW=PYCHGE(K(IW1,2))+PYCHGE(K(IW2,2))
44273 IF(IABS(KCHW).EQ.3) THEN
44274 K(IW,2)=ISIGN(24,KCHW)
44275 ELSE
44276 CALL PYERRM(16,'(PY6FRM:) fermion pair inconsistent with W')
44277 ENDIF
44278 K(IW,3)=IW1
44279
44280C...If t+tbar: construct W momentum, including boost by t shower.
44281 DO 160 J=1,4
44282 P(IW,J)=P(IW1,J)+P(IW2,J)
44283 160 CONTINUE
44284 P(IW,5)=SQRT(MAX(0D0,P(IW,4)**2-P(IW,1)**2-P(IW,2)**2-
44285 & P(IW,3)**2))
44286 CALL PYROBO(IW,IW,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
44287 CALL PYROBO(IW,IW,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
44288
44289C...If t+tbar: boost b and W to top rest frame.
44290 DO 170 J=1,3
44291 BETA(J)=(P(IB,J)+P(IW,J))/(P(IB,4)+P(IW,4))
44292 170 CONTINUE
44293 CALL PYROBO(IB,IB,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
44294 CALL PYROBO(IW,IW,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
44295
44296C...If t+tbar: let b shower and pick up modified W.
44297 PMTS=(P(IB,4)+P(IW,4))**2-(P(IB,1)+P(IW,1))**2-
44298 & (P(IB,2)+P(IW,2))**2-(P(IB,3)+P(IW,3))**2
44299 CALL PYSHOW(IB,IW,SQRT(MAX(0D0,PMTS)))
44300 DO 180 I=IW,N
44301 IF(IABS(K(I,2)).EQ.24) IWM=I
44302 180 CONTINUE
44303
44304C...If t+tbar: take copy of W decay products.
44305 DO 190 J=1,5
44306 K(N+1,J)=K(IW1,J)
44307 P(N+1,J)=P(IW1,J)
44308 V(N+1,J)=V(IW1,J)
44309 K(N+2,J)=K(IW2,J)
44310 P(N+2,J)=P(IW2,J)
44311 V(N+2,J)=V(IW2,J)
44312 190 CONTINUE
44313 K(IW1,1)=K(IW1,1)+10
44314 K(IW2,1)=K(IW2,1)+10
44315 K(IWM,1)=K(IWM,1)+10
44316 K(IWM,4)=N+1
44317 K(IWM,5)=N+2
44318 K(N+1,3)=IWM
44319 K(N+2,3)=IWM
44320 IF(IT1.EQ.1) THEN
44321 I3=N+1
44322 I4=N+2
44323 ELSE
44324 I5=N+1
44325 I6=N+2
44326 ENDIF
44327 N=N+2
44328
44329C...If t+tbar: boost W decay products, first by effects of t shower,
44330C...then by those of b shower. b and its shower simple boost back.
44331 CALL PYROBO(N-1,N,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
44332 CALL PYROBO(N-1,N,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
44333 CALL PYROBO(N-1,N,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
44334 CALL PYROBO(N-1,N,0D0,0D0,-P(IW,1)/P(IW,4),
44335 & -P(IW,2)/P(IW,4),-P(IW,3)/P(IW,4))
44336 CALL PYROBO(N-1,N,0D0,0D0,P(IWM,1)/P(IWM,4),
44337 & P(IWM,2)/P(IWM,4),P(IWM,3)/P(IWM,4))
44338 CALL PYROBO(IB,IB,0D0,0D0,BETA(1),BETA(2),BETA(3))
44339 CALL PYROBO(IW,N,0D0,0D0,BETA(1),BETA(2),BETA(3))
44340 200 CONTINUE
44341 ENDIF
44342
44343C...Decide on dipole pairing.
44344 IP1=I1
44345 IP3=I3
44346 IP5=I5
44347 PRN=PYR(0)*(P12D+P13D+P21D+P23D+P31D+P32D)
44348 IF(ITOP.EQ.1.OR.PRN.LT.P12D) THEN
44349 IP2=I2
44350 IP4=I4
44351 IP6=I6
44352 ELSEIF(PRN.LT.P12D+P13D) THEN
44353 IP2=I2
44354 IP4=I6
44355 IP6=I4
44356 ELSEIF(PRN.LT.P12D+P13D+P21D) THEN
44357 IP2=I4
44358 IP4=I2
44359 IP6=I6
44360 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D) THEN
44361 IP2=I4
44362 IP4=I6
44363 IP6=I2
44364 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D+P31D) THEN
44365 IP2=I6
44366 IP4=I2
44367 IP6=I4
44368 ELSE
44369 IP2=I6
44370 IP4=I4
44371 IP6=I2
44372 ENDIF
44373
44374C...Do colour joinings and parton showers
44375C...(except ones already made for t+tbar).
44376 IF(ITOP.EQ.0) THEN
44377 IF(IQL12.EQ.1) THEN
44378 IJOIN(1)=IP1
44379 IJOIN(2)=IP2
44380 CALL PYJOIN(2,IJOIN)
44381 ENDIF
44382 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
44383 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
44384 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
44385 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
44386 ENDIF
44387 ENDIF
44388 IF(IQL34.EQ.1) THEN
44389 IJOIN(1)=IP3
44390 IJOIN(2)=IP4
44391 CALL PYJOIN(2,IJOIN)
44392 ENDIF
44393 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
44394 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
44395 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
44396 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
44397 ENDIF
44398 IF(IQL56.EQ.1) THEN
44399 IJOIN(1)=IP5
44400 IJOIN(2)=IP6
44401 CALL PYJOIN(2,IJOIN)
44402 ENDIF
44403 IF(IQL56.EQ.1.OR.IRAD.EQ.1) THEN
44404 PM56S=(P(IP5,4)+P(IP6,4))**2-(P(IP5,1)+P(IP6,1))**2-
44405 & (P(IP5,2)+P(IP6,2))**2-(P(IP5,3)+P(IP6,3))**2
44406 CALL PYSHOW(IP5,IP6,SQRT(MAX(0D0,PM56S)))
44407 ENDIF
44408
44409C...Do fragmentation and decays. Possibly except tau decay.
44410 IF(ITAU.EQ.0) THEN
44411 NTAU=0
44412 DO 210 I=1,N
44413 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
44414 NTAU=NTAU+1
44415 INTAU(NTAU)=I
44416 K(I,1)=11
44417 ENDIF
44418 210 CONTINUE
44419 ENDIF
44420 CALL PYEXEC
44421 IF(ITAU.EQ.0) THEN
44422 DO 220 I=1,NTAU
44423 K(INTAU(I),1)=1
44424 220 CONTINUE
44425 ENDIF
44426
44427C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
44428 IF(ICOM.EQ.0) THEN
44429 MSTU(28)=0
44430 CALL PYHEPC(1)
44431 ENDIF
44432
44433 END
44434
44435C*********************************************************************
44436
44437C...PY4JET
44438C...An interface from a four-parton generator to include
44439C...parton showers and hadronization.
44440
44441 SUBROUTINE PY4JET(PMAX,IRAD,ICOM)
44442
44443C...Double precision and integer declarations.
44444 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44445 IMPLICIT INTEGER(I-N)
44446 INTEGER PYK,PYCHGE,PYCOMP
44447C...Commonblocks.
44448 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
44449 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44450 SAVE /PYJETS/,/PYDAT1/
44451C...Local arrays.
44452 DIMENSION IJOIN(2),PTOT(4),BETA(3)
44453
44454C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
44455 IF(ICOM.EQ.0) THEN
44456 MSTU(28)=0
44457 CALL PYHEPC(2)
44458 ENDIF
44459
44460C...Loop through entries and pick up all final partons.
44461 I1=0
44462 I2=0
44463 I3=0
44464 I4=0
44465 DO 100 I=1,N
44466 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
44467 KFA=IABS(K(I,2))
44468 IF((KFA.GE.1.AND.KFA.LE.6).OR.KFA.EQ.21) THEN
44469 IF(K(I,2).GT.0.AND.K(I,2).LE.6) THEN
44470 IF(I1.EQ.0) THEN
44471 I1=I
44472 ELSEIF(I3.EQ.0) THEN
44473 I3=I
44474 ELSE
44475 CALL PYERRM(16,'(PY4JET:) more than two quarks')
44476 ENDIF
44477 ELSEIF(K(I,2).LT.0) THEN
44478 IF(I2.EQ.0) THEN
44479 I2=I
44480 ELSEIF(I4.EQ.0) THEN
44481 I4=I
44482 ELSE
44483 CALL PYERRM(16,'(PY4JET:) more than two antiquarks')
44484 ENDIF
44485 ELSE
44486 IF(I3.EQ.0) THEN
44487 I3=I
44488 ELSEIF(I4.EQ.0) THEN
44489 I4=I
44490 ELSE
44491 CALL PYERRM(16,'(PY4JET:) more than two gluons')
44492 ENDIF
44493 ENDIF
44494 ENDIF
44495 100 CONTINUE
44496
44497C...Check that event is arranged according to conventions.
44498 IF(I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0.OR.I4.EQ.0) THEN
44499 CALL PYERRM(16,'(PY4JET:) event contains too few partons')
44500 ENDIF
44501 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
44502 CALL PYERRM(6,'(PY4JET:) partons arranged in wrong order')
44503 ENDIF
44504
44505C...Check whether second pair are quarks or gluons.
44506 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
44507 IQG34=1
44508 ELSEIF(K(I3,2).EQ.21.AND.K(I4,2).EQ.21) THEN
44509 IQG34=2
44510 ELSE
44511 CALL PYERRM(16,'(PY4JET:) second parton pair inconsistent')
44512 ENDIF
44513
44514C...Boost partons to their cm frame.
44515 DO 110 J=1,4
44516 PTOT(J)=P(I1,J)+P(I2,J)+P(I3,J)+P(I4,J)
44517 110 CONTINUE
44518 ECM=SQRT(MAX(0D0,PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2))
44519 DO 120 J=1,3
44520 BETA(J)=PTOT(J)/PTOT(4)
44521 120 CONTINUE
44522 CALL PYROBO(I1,I1,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
44523 CALL PYROBO(I2,I2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
44524 CALL PYROBO(I3,I3,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
44525 CALL PYROBO(I4,I4,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
44526 NSAV=N
44527
44528C...Decide and set up shower history for q qbar q' qbar' events.
44529 IF(IQG34.EQ.1) THEN
44530 W1=PY4JTW(0,I1,I3,I4)
44531 W2=PY4JTW(0,I2,I3,I4)
44532 IF(W1.GT.PYR(0)*(W1+W2)) THEN
44533 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
44534 ELSE
44535 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
44536 ENDIF
44537
44538C...Decide and set up shower history for q qbar g g events.
44539 ELSE
44540 W1=PY4JTW(I1,I3,I2,I4)
44541 W2=PY4JTW(I1,I4,I2,I3)
44542 W3=PY4JTW(0,I3,I1,I4)
44543 W4=PY4JTW(0,I4,I1,I3)
44544 W5=PY4JTW(0,I3,I2,I4)
44545 W6=PY4JTW(0,I4,I2,I3)
44546 W7=PY4JTW(0,I1,I3,I4)
44547 W8=PY4JTW(0,I2,I3,I4)
44548 WR=(W1+W2+W3+W4+W5+W6+W7+W8)*PYR(0)
44549 IF(W1.GT.WR) THEN
44550 CALL PY4JTS(I1,I3,I2,I4,0,QMAX)
44551 ELSEIF(W1+W2.GT.WR) THEN
44552 CALL PY4JTS(I1,I4,I2,I3,0,QMAX)
44553 ELSEIF(W1+W2+W3.GT.WR) THEN
44554 CALL PY4JTS(0,I3,I1,I4,I2,QMAX)
44555 ELSEIF(W1+W2+W3+W4.GT.WR) THEN
44556 CALL PY4JTS(0,I4,I1,I3,I2,QMAX)
44557 ELSEIF(W1+W2+W3+W4+W5.GT.WR) THEN
44558 CALL PY4JTS(0,I3,I2,I4,I1,QMAX)
44559 ELSEIF(W1+W2+W3+W4+W5+W6.GT.WR) THEN
44560 CALL PY4JTS(0,I4,I2,I3,I1,QMAX)
44561 ELSEIF(W1+W2+W3+W4+W5+W6+W7.GT.WR) THEN
44562 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
44563 ELSE
44564 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
44565 ENDIF
44566 ENDIF
44567
44568C...Boost back original partons and mark them as deleted.
44569 CALL PYROBO(I1,I1,0D0,0D0,BETA(1),BETA(2),BETA(3))
44570 CALL PYROBO(I2,I2,0D0,0D0,BETA(1),BETA(2),BETA(3))
44571 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
44572 CALL PYROBO(I4,I4,0D0,0D0,BETA(1),BETA(2),BETA(3))
44573 K(I1,1)=K(I1,1)+10
44574 K(I2,1)=K(I2,1)+10
44575 K(I3,1)=K(I3,1)+10
44576 K(I4,1)=K(I4,1)+10
44577
44578C...Rotate shower initiating partons to be along z axis.
44579 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
44580 CALL PYROBO(NSAV+1,NSAV+6,0D0,-PHI,0D0,0D0,0D0)
44581 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
44582 CALL PYROBO(NSAV+1,NSAV+6,-THE,0D0,0D0,0D0,0D0)
44583
44584C...Set up copy of shower initiating partons as on mass shell.
44585 DO 140 I=N+1,N+2
44586 DO 130 J=1,5
44587 K(I,J)=0
44588 P(I,J)=0D0
44589 V(I,J)=V(I1,J)
44590 130 CONTINUE
44591 K(I,1)=1
44592 K(I,2)=K(I-6,2)
44593 140 CONTINUE
44594 IF(K(NSAV+1,2).EQ.K(I1,2)) THEN
44595 K(N+1,3)=I1
44596 P(N+1,5)=P(I1,5)
44597 K(N+2,3)=I2
44598 P(N+2,5)=P(I2,5)
44599 ELSE
44600 K(N+1,3)=I2
44601 P(N+1,5)=P(I2,5)
44602 K(N+2,3)=I1
44603 P(N+2,5)=P(I1,5)
44604 ENDIF
44605 PABS=SQRT(MAX(0D0,(ECM**2-P(N+1,5)**2-P(N+2,5)**2)**2-
44606 &(2D0*P(N+1,5)*P(N+2,5))**2))/(2D0*ECM)
44607 P(N+1,3)=PABS
44608 P(N+1,4)=SQRT(PABS**2+P(N+1,5)**2)
44609 P(N+2,3)=-PABS
44610 P(N+2,4)=SQRT(PABS**2+P(N+2,5)**2)
44611 N=N+2
44612
44613C...Decide whether to allow or not photon radiation in showers.
44614C...Connect up colours.
44615 MSTJ(41)=2
44616 IF(IRAD.EQ.0) MSTJ(41)=1
44617 IJOIN(1)=N-1
44618 IJOIN(2)=N
44619 CALL PYJOIN(2,IJOIN)
44620
44621C...Decide on maximum virtuality and do parton shower.
44622 IF(PMAX.LT.PARJ(82)) THEN
44623 PQMAX=QMAX
44624 ELSE
44625 PQMAX=PMAX
44626 ENDIF
44627 CALL PYSHOW(NSAV+1,-8,PQMAX)
44628
44629C...Rotate and boost back system.
44630 CALL PYROBO(NSAV+1,N,THE,PHI,BETA(1),BETA(2),BETA(3))
44631
44632C...Do fragmentation and decays.
44633 CALL PYEXEC
44634
44635C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
44636 IF(ICOM.EQ.0) THEN
44637 MSTU(28)=0
44638 CALL PYHEPC(1)
44639 ENDIF
44640
44641 RETURN
44642 END
44643
44644C*********************************************************************
44645
44646C...PY4JTW
44647C...Auxiliary to PY4JET, to evaluate weight of configuration.
44648
44649 FUNCTION PY4JTW(IA1,IA2,IA3,IA4)
44650
44651C...Double precision and integer declarations.
44652 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44653 IMPLICIT INTEGER(I-N)
44654 INTEGER PYK,PYCHGE,PYCOMP
44655C...Commonblocks.
44656 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
44657 SAVE /PYJETS/
44658
44659C...First case: when both original partons radiate.
44660C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4.
44661 IF(IA1.NE.0) THEN
44662 DO 100 J=1,4
44663 P(N+1,J)=P(IA1,J)+P(IA2,J)
44664 P(N+2,J)=P(IA3,J)+P(IA4,J)
44665 100 CONTINUE
44666 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
44667 & P(N+1,3)**2))
44668 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
44669 & P(N+2,3)**2))
44670 Z1=P(IA1,4)/P(N+1,4)
44671 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-P(IA1,5)**2)
44672 Z2=P(IA3,4)/P(N+2,4)
44673 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-P(IA3,5)**2)
44674
44675C...Second case: when one original parton radiates to three.
44676C...IA1 = 0: N+1 -> IA2 + N+2, N+2 -> IA3 + IA4.
44677 ELSE
44678 DO 110 J=1,4
44679 P(N+2,J)=P(IA3,J)+P(IA4,J)
44680 P(N+1,J)=P(N+2,J)+P(IA2,J)
44681 110 CONTINUE
44682 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
44683 & P(N+1,3)**2))
44684 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
44685 & P(N+2,3)**2))
44686 IF(K(IA2,2).EQ.21) THEN
44687 Z1=P(N+2,4)/P(N+1,4)
44688 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
44689 & P(IA3,5)**2)
44690 ELSE
44691 Z1=P(IA2,4)/P(N+1,4)
44692 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
44693 & P(IA2,5)**2)
44694 ENDIF
44695 Z2=P(IA3,4)/P(N+2,4)
44696 IF(K(IA2,2).EQ.21) THEN
44697 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-
44698 & P(IA3,5)**2)
44699 ELSEIF(K(IA3,2).EQ.21) THEN
44700 WT2=3D0*((1D0-Z2*(1D0-Z2))**2/(Z2*(1D0-Z2)))/P(N+2,5)**2
44701 ELSE
44702 WT2=0.5D0*(Z2**2+(1D0-Z2)**2)
44703 ENDIF
44704 ENDIF
44705
44706C...Total weight.
44707 PY4JTW=WT1*WT2
44708
44709 RETURN
44710 END
44711
44712C*********************************************************************
44713
44714C...PY4JTS
44715C...Auxiliary to PY4JET, to set up chosen configuration.
44716
44717 SUBROUTINE PY4JTS(IA1,IA2,IA3,IA4,IA5,QMAX)
44718
44719C...Double precision and integer declarations.
44720 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44721 IMPLICIT INTEGER(I-N)
44722 INTEGER PYK,PYCHGE,PYCOMP
44723C...Commonblocks.
44724 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
44725 SAVE /PYJETS/
44726
44727C...Reset info.
44728 DO 110 I=N+1,N+6
44729 DO 100 J=1,5
44730 K(I,J)=0
44731 V(I,J)=V(IA2,J)
44732 100 CONTINUE
44733 K(I,1)=16
44734 110 CONTINUE
44735
44736C...First case: when both original partons radiate.
44737C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
44738 IF(IA1.NE.0) THEN
44739
44740C...Set up flavour and history pointers for new partons.
44741 K(N+1,2)=K(IA1,2)
44742 K(N+2,2)=K(IA3,2)
44743 K(N+3,2)=K(IA1,2)
44744 K(N+4,2)=K(IA2,2)
44745 K(N+5,2)=K(IA3,2)
44746 K(N+6,2)=K(IA4,2)
44747 K(N+1,3)=IA1
44748 K(N+1,4)=N+3
44749 K(N+1,5)=N+4
44750 K(N+2,3)=IA3
44751 K(N+2,4)=N+5
44752 K(N+2,5)=N+6
44753 K(N+3,3)=N+1
44754 K(N+4,3)=N+1
44755 K(N+5,3)=N+2
44756 K(N+6,3)=N+2
44757
44758C...Set up momenta for new partons.
44759 DO 120 J=1,5
44760 P(N+1,J)=P(IA1,J)+P(IA2,J)
44761 P(N+2,J)=P(IA3,J)+P(IA4,J)
44762 P(N+3,J)=P(IA1,J)
44763 P(N+4,J)=P(IA2,J)
44764 P(N+5,J)=P(IA3,J)
44765 P(N+6,J)=P(IA4,J)
44766 120 CONTINUE
44767 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
44768 & P(N+1,3)**2))
44769 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
44770 & P(N+2,3)**2))
44771 QMAX=MIN(P(N+1,5),P(N+2,5))
44772
44773C...Second case: q radiates twice.
44774C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
44775C...IA5=N+2 does not radiate.
44776 ELSEIF(K(IA2,2).EQ.21) THEN
44777
44778C...Set up flavour and history pointers for new partons.
44779 K(N+1,2)=K(IA3,2)
44780 K(N+2,2)=K(IA5,2)
44781 K(N+3,2)=K(IA3,2)
44782 K(N+4,2)=K(IA2,2)
44783 K(N+5,2)=K(IA3,2)
44784 K(N+6,2)=K(IA4,2)
44785 K(N+1,3)=IA3
44786 K(N+1,4)=N+3
44787 K(N+1,5)=N+4
44788 K(N+2,3)=IA5
44789 K(N+3,3)=N+1
44790 K(N+3,4)=N+5
44791 K(N+3,5)=N+6
44792 K(N+4,3)=N+1
44793 K(N+5,3)=N+3
44794 K(N+6,3)=N+3
44795
44796C...Set up momenta for new partons.
44797 DO 130 J=1,5
44798 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
44799 P(N+2,J)=P(IA5,J)
44800 P(N+3,J)=P(IA3,J)+P(IA4,J)
44801 P(N+4,J)=P(IA2,J)
44802 P(N+5,J)=P(IA3,J)
44803 P(N+6,J)=P(IA4,J)
44804 130 CONTINUE
44805 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
44806 & P(N+1,3)**2))
44807 P(N+3,5)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,1)**2-P(N+3,2)**2-
44808 & P(N+3,3)**2))
44809 QMAX=P(N+3,5)
44810
44811C...Third case: q radiates g, g branches.
44812C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
44813C...IA5=N+2 does not radiate.
44814 ELSE
44815
44816C...Set up flavour and history pointers for new partons.
44817 K(N+1,2)=K(IA2,2)
44818 K(N+2,2)=K(IA5,2)
44819 K(N+3,2)=K(IA2,2)
44820 K(N+4,2)=21
44821 K(N+5,2)=K(IA3,2)
44822 K(N+6,2)=K(IA4,2)
44823 K(N+1,3)=IA2
44824 K(N+1,4)=N+3
44825 K(N+1,5)=N+4
44826 K(N+2,3)=IA5
44827 K(N+3,3)=N+1
44828 K(N+4,3)=N+1
44829 K(N+4,4)=N+5
44830 K(N+4,5)=N+6
44831 K(N+5,3)=N+4
44832 K(N+6,3)=N+4
44833
44834C...Set up momenta for new partons.
44835 DO 140 J=1,5
44836 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
44837 P(N+2,J)=P(IA5,J)
44838 P(N+3,J)=P(IA2,J)
44839 P(N+4,J)=P(IA3,J)+P(IA4,J)
44840 P(N+5,J)=P(IA3,J)
44841 P(N+6,J)=P(IA4,J)
44842 140 CONTINUE
44843 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
44844 & P(N+1,3)**2))
44845 P(N+4,5)=SQRT(MAX(0D0,P(N+4,4)**2-P(N+4,1)**2-P(N+4,2)**2-
44846 & P(N+4,3)**2))
44847 QMAX=P(N+4,5)
44848
44849 ENDIF
44850 N=N+6
44851
44852 RETURN
44853 END
44854
44855C*********************************************************************
44856
44857C...PYJOIN
44858C...Connects a sequence of partons with colour flow indices,
44859C...as required for subsequent shower evolution (or other operations).
44860
44861 SUBROUTINE PYJOIN(NJOIN,IJOIN)
44862
44863C...Double precision and integer declarations.
44864 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44865 IMPLICIT INTEGER(I-N)
44866 INTEGER PYK,PYCHGE,PYCOMP
44867C...Commonblocks.
44868 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
44869 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44870 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
44871 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
44872C...Local array.
44873 DIMENSION IJOIN(*)
44874
44875C...Check that partons are of right types to be connected.
44876 IF(NJOIN.LT.2) GOTO 120
44877 KQSUM=0
44878 DO 100 IJN=1,NJOIN
44879 I=IJOIN(IJN)
44880 IF(I.LE.0.OR.I.GT.N) GOTO 120
44881 IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
44882 KC=PYCOMP(K(I,2))
44883 IF(KC.EQ.0) GOTO 120
44884 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
44885 IF(KQ.EQ.0) GOTO 120
44886 IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
44887 IF(KQ.NE.2) KQSUM=KQSUM+KQ
44888 IF(IJN.EQ.1) KQS=KQ
44889 100 CONTINUE
44890 IF(KQSUM.NE.0) GOTO 120
44891
44892C...Connect the partons sequentially (closing for gluon loop).
44893 KCS=(9-KQS)/2
44894 IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
44895 DO 110 IJN=1,NJOIN
44896 I=IJOIN(IJN)
44897 K(I,1)=3
44898 IF(IJN.NE.1) IP=IJOIN(IJN-1)
44899 IF(IJN.EQ.1) IP=IJOIN(NJOIN)
44900 IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
44901 IF(IJN.EQ.NJOIN) IN=IJOIN(1)
44902 K(I,KCS)=MSTU(5)*IN
44903 K(I,9-KCS)=MSTU(5)*IP
44904 IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
44905 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
44906 110 CONTINUE
44907
44908C...Error exit: no action taken.
44909 RETURN
44910 120 CALL PYERRM(12,
44911 &'(PYJOIN:) given entries can not be joined by one string')
44912
44913 RETURN
44914 END
44915
44916C*********************************************************************
44917
44918C...PYGIVE
44919C...Sets values of commonblock variables.
44920
44921 SUBROUTINE PYGIVE(CHIN)
44922
44923C...Double precision and integer declarations.
44924 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44925 IMPLICIT INTEGER(I-N)
44926 INTEGER PYK,PYCHGE,PYCOMP
44927C...Commonblocks.
44928 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
44929 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44930 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
44931 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
44932 COMMON/PYDAT4/CHAF(500,2)
44933 CHARACTER CHAF*16
44934 COMMON/PYDATR/MRPY(6),RRPY(100)
44935 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
44936 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
44937 COMMON/PYINT1/MINT(400),VINT(400)
44938 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
44939 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
44940 COMMON/PYINT4/MWID(500),WIDS(500,5)
44941 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
44942 COMMON/PYINT6/PROC(0:500)
44943 CHARACTER PROC*28
44944 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
44945 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
44946 &XPDIR(-6:6)
44947 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
44948 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
44949 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
44950 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
44951 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,
44952 &/PYINT5/,/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/,/PYMSRV/,/PYTCSM/
44953C...Local arrays and character variables.
44954 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
44955 &CHNEW2*28,CHNAM*6,CHVAR(54)*6,CHALP(2)*26,CHIND*8,CHINI*10,
44956 &CHINR*16
44957 DIMENSION MSVAR(54,8)
44958
44959C...For each variable to be translated give: name,
44960C...integer/real/character, no. of indices, lower&upper index bounds.
44961 DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
44962 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
44963 &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
44964 &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
44965 &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
44966 &'XPANH','XPBEH','XPDIR','IMSS','RMSS','RVLAM','RVLAMP','RVLAMB',
44967 &'ITCM','RTCM'/
44968 DATA ((MSVAR(I,J),J=1,8),I=1,54)/ 1,7*0, 1,2,1,4000,1,5,2*0,
44969 &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
44970 &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
44971 &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
44972 &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,8000,1,2,2*0,
44973 &2,1,1,8000,4*0, 1,2,1,8000,1,5,2*0, 3,2,1,500,1,2,2*0,
44974 &1,1,1,6,4*0, 2,1,1,100,4*0,
44975 &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
44976 &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
44977 &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
44978 &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
44979 &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
44980 &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
44981 &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
44982 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
44983 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0,
44984 &2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3,
44985 &1,1,0,99,4*0, 2,1,0,99,4*0/
44986 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
44987 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
44988
44989C...Length of character variable. Subdivide it into instructions.
44990 IF(MSTU(12).GE.1) CALL PYLIST(0)
44991 CHBIT=CHIN//' '
44992 LBIT=101
44993 100 LBIT=LBIT-1
44994 IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
44995 LTOT=0
44996 DO 110 LCOM=1,LBIT
44997 IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
44998 LTOT=LTOT+1
44999 CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
45000 110 CONTINUE
45001 LLOW=0
45002 120 LHIG=LLOW+1
45003 130 LHIG=LHIG+1
45004 IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
45005 LBIT=LHIG-LLOW-1
45006 CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
45007
45008C...Peel off any text following exclamation mark.
45009 LHIG2=LBIT
45010 DO 140 LLOW2=LHIG2,1,-1
45011 IF(CHBIT(LLOW2:LLOW2).EQ.'!') LBIT=LLOW2-1
45012 140 CONTINUE
45013 IF(LBIT.EQ.0) RETURN
45014
45015C...Identify commonblock variable.
45016 LNAM=1
45017 150 LNAM=LNAM+1
45018 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
45019 &LNAM.LE.6) GOTO 150
45020 CHNAM=CHBIT(1:LNAM-1)//' '
45021 DO 170 LCOM=1,LNAM-1
45022 DO 160 LALP=1,26
45023 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
45024 & CHALP(2)(LALP:LALP)
45025 160 CONTINUE
45026 170 CONTINUE
45027 IVAR=0
45028 DO 180 IV=1,54
45029 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
45030 180 CONTINUE
45031 IF(IVAR.EQ.0) THEN
45032 CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM)
45033 LLOW=LHIG
45034 IF(LLOW.LT.LTOT) GOTO 120
45035 RETURN
45036 ENDIF
45037
45038C...Identify any indices.
45039 I1=0
45040 I2=0
45041 I3=0
45042 NINDX=0
45043 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
45044 LIND=LNAM
45045 190 LIND=LIND+1
45046 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
45047 CHIND=' '
45048 IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c')
45049 & .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17.OR.
45050 & IVAR.EQ.37)) THEN
45051 CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
45052 READ(CHIND,'(I8)') KF
45053 I1=PYCOMP(KF)
45054 ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
45055 & 'c') THEN
45056 CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '//
45057 & CHNAM)
45058 LLOW=LHIG
45059 IF(LLOW.LT.LTOT) GOTO 120
45060 RETURN
45061 ELSE
45062 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
45063 READ(CHIND,'(I8)') I1
45064 ENDIF
45065 LNAM=LIND
45066 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
45067 NINDX=1
45068 ENDIF
45069 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
45070 LIND=LNAM
45071 200 LIND=LIND+1
45072 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
45073 CHIND=' '
45074 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
45075 READ(CHIND,'(I8)') I2
45076 LNAM=LIND
45077 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
45078 NINDX=2
45079 ENDIF
45080 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
45081 LIND=LNAM
45082 210 LIND=LIND+1
45083 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 210
45084 CHIND=' '
45085 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
45086 READ(CHIND,'(I8)') I3
45087 LNAM=LIND+1
45088 NINDX=3
45089 ENDIF
45090
45091C...Check that indices allowed.
45092 IERR=0
45093 IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
45094 IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
45095 &IERR=2
45096 IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
45097 &IERR=3
45098 IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
45099 &IERR=4
45100 IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
45101 IF(IERR.GE.1) THEN
45102 CALL PYERRM(18,'(PYGIVE:) unallowed indices for '//
45103 & CHBIT(1:LNAM-1))
45104 LLOW=LHIG
45105 IF(LLOW.LT.LTOT) GOTO 120
45106 RETURN
45107 ENDIF
45108
45109C...Save old value of variable.
45110 IF(IVAR.EQ.1) THEN
45111 IOLD=N
45112 ELSEIF(IVAR.EQ.2) THEN
45113 IOLD=K(I1,I2)
45114 ELSEIF(IVAR.EQ.3) THEN
45115 ROLD=P(I1,I2)
45116 ELSEIF(IVAR.EQ.4) THEN
45117 ROLD=V(I1,I2)
45118 ELSEIF(IVAR.EQ.5) THEN
45119 IOLD=MSTU(I1)
45120 ELSEIF(IVAR.EQ.6) THEN
45121 ROLD=PARU(I1)
45122 ELSEIF(IVAR.EQ.7) THEN
45123 IOLD=MSTJ(I1)
45124 ELSEIF(IVAR.EQ.8) THEN
45125 ROLD=PARJ(I1)
45126 ELSEIF(IVAR.EQ.9) THEN
45127 IOLD=KCHG(I1,I2)
45128 ELSEIF(IVAR.EQ.10) THEN
45129 ROLD=PMAS(I1,I2)
45130 ELSEIF(IVAR.EQ.11) THEN
45131 ROLD=PARF(I1)
45132 ELSEIF(IVAR.EQ.12) THEN
45133 ROLD=VCKM(I1,I2)
45134 ELSEIF(IVAR.EQ.13) THEN
45135 IOLD=MDCY(I1,I2)
45136 ELSEIF(IVAR.EQ.14) THEN
45137 IOLD=MDME(I1,I2)
45138 ELSEIF(IVAR.EQ.15) THEN
45139 ROLD=BRAT(I1)
45140 ELSEIF(IVAR.EQ.16) THEN
45141 IOLD=KFDP(I1,I2)
45142 ELSEIF(IVAR.EQ.17) THEN
45143 CHOLD=CHAF(I1,I2)
45144 ELSEIF(IVAR.EQ.18) THEN
45145 IOLD=MRPY(I1)
45146 ELSEIF(IVAR.EQ.19) THEN
45147 ROLD=RRPY(I1)
45148 ELSEIF(IVAR.EQ.20) THEN
45149 IOLD=MSEL
45150 ELSEIF(IVAR.EQ.21) THEN
45151 IOLD=MSUB(I1)
45152 ELSEIF(IVAR.EQ.22) THEN
45153 IOLD=KFIN(I1,I2)
45154 ELSEIF(IVAR.EQ.23) THEN
45155 ROLD=CKIN(I1)
45156 ELSEIF(IVAR.EQ.24) THEN
45157 IOLD=MSTP(I1)
45158 ELSEIF(IVAR.EQ.25) THEN
45159 ROLD=PARP(I1)
45160 ELSEIF(IVAR.EQ.26) THEN
45161 IOLD=MSTI(I1)
45162 ELSEIF(IVAR.EQ.27) THEN
45163 ROLD=PARI(I1)
45164 ELSEIF(IVAR.EQ.28) THEN
45165 IOLD=MINT(I1)
45166 ELSEIF(IVAR.EQ.29) THEN
45167 ROLD=VINT(I1)
45168 ELSEIF(IVAR.EQ.30) THEN
45169 IOLD=ISET(I1)
45170 ELSEIF(IVAR.EQ.31) THEN
45171 IOLD=KFPR(I1,I2)
45172 ELSEIF(IVAR.EQ.32) THEN
45173 ROLD=COEF(I1,I2)
45174 ELSEIF(IVAR.EQ.33) THEN
45175 IOLD=ICOL(I1,I2,I3)
45176 ELSEIF(IVAR.EQ.34) THEN
45177 ROLD=XSFX(I1,I2)
45178 ELSEIF(IVAR.EQ.35) THEN
45179 IOLD=ISIG(I1,I2)
45180 ELSEIF(IVAR.EQ.36) THEN
45181 ROLD=SIGH(I1)
45182 ELSEIF(IVAR.EQ.37) THEN
45183 IOLD=MWID(I1)
45184 ELSEIF(IVAR.EQ.38) THEN
45185 ROLD=WIDS(I1,I2)
45186 ELSEIF(IVAR.EQ.39) THEN
45187 IOLD=NGEN(I1,I2)
45188 ELSEIF(IVAR.EQ.40) THEN
45189 ROLD=XSEC(I1,I2)
45190 ELSEIF(IVAR.EQ.41) THEN
45191 CHOLD2=PROC(I1)
45192 ELSEIF(IVAR.EQ.42) THEN
45193 ROLD=SIGT(I1,I2,I3)
45194 ELSEIF(IVAR.EQ.43) THEN
45195 ROLD=XPVMD(I1)
45196 ELSEIF(IVAR.EQ.44) THEN
45197 ROLD=XPANL(I1)
45198 ELSEIF(IVAR.EQ.45) THEN
45199 ROLD=XPANH(I1)
45200 ELSEIF(IVAR.EQ.46) THEN
45201 ROLD=XPBEH(I1)
45202 ELSEIF(IVAR.EQ.47) THEN
45203 ROLD=XPDIR(I1)
45204 ELSEIF(IVAR.EQ.48) THEN
45205 IOLD=IMSS(I1)
45206 ELSEIF(IVAR.EQ.49) THEN
45207 ROLD=RMSS(I1)
45208 ELSEIF(IVAR.EQ.50) THEN
45209 ROLD=RVLAM(I1,I2,I3)
45210 ELSEIF(IVAR.EQ.51) THEN
45211 ROLD=RVLAMP(I1,I2,I3)
45212 ELSEIF(IVAR.EQ.52) THEN
45213 ROLD=RVLAMB(I1,I2,I3)
45214 ELSEIF(IVAR.EQ.53) THEN
45215 IOLD=ITCM(I1)
45216 ELSEIF(IVAR.EQ.54) THEN
45217 ROLD=RTCM(I1)
45218 ENDIF
45219
45220C...Print current value of variable. Loop back.
45221 IF(LNAM.GE.LBIT) THEN
45222 CHBIT(LNAM:14)=' '
45223 CHBIT(15:60)=' has the value '
45224 IF(MSVAR(IVAR,1).EQ.1) THEN
45225 WRITE(CHBIT(51:60),'(I10)') IOLD
45226 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
45227 WRITE(CHBIT(47:60),'(F14.5)') ROLD
45228 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
45229 CHBIT(53:60)=CHOLD
45230 ELSE
45231 CHBIT(33:60)=CHOLD
45232 ENDIF
45233 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
45234 LLOW=LHIG
45235 IF(LLOW.LT.LTOT) GOTO 120
45236 RETURN
45237 ENDIF
45238
45239C...Read in new variable value.
45240 IF(MSVAR(IVAR,1).EQ.1) THEN
45241 CHINI=' '
45242 CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
45243 READ(CHINI,'(I10)') INEW
45244 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
45245 CHINR=' '
45246 CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
45247 READ(CHINR,*) RNEW
45248 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
45249 CHNEW=CHBIT(LNAM+1:LBIT)//' '
45250 ELSE
45251 CHNEW2=CHBIT(LNAM+1:LBIT)//' '
45252 ENDIF
45253
45254C...Store new variable value.
45255 IF(IVAR.EQ.1) THEN
45256 N=INEW
45257 ELSEIF(IVAR.EQ.2) THEN
45258 K(I1,I2)=INEW
45259 ELSEIF(IVAR.EQ.3) THEN
45260 P(I1,I2)=RNEW
45261 ELSEIF(IVAR.EQ.4) THEN
45262 V(I1,I2)=RNEW
45263 ELSEIF(IVAR.EQ.5) THEN
45264 MSTU(I1)=INEW
45265 ELSEIF(IVAR.EQ.6) THEN
45266 PARU(I1)=RNEW
45267 ELSEIF(IVAR.EQ.7) THEN
45268 MSTJ(I1)=INEW
45269 ELSEIF(IVAR.EQ.8) THEN
45270 PARJ(I1)=RNEW
45271 ELSEIF(IVAR.EQ.9) THEN
45272 KCHG(I1,I2)=INEW
45273 ELSEIF(IVAR.EQ.10) THEN
45274 PMAS(I1,I2)=RNEW
45275 ELSEIF(IVAR.EQ.11) THEN
45276 PARF(I1)=RNEW
45277 ELSEIF(IVAR.EQ.12) THEN
45278 VCKM(I1,I2)=RNEW
45279 ELSEIF(IVAR.EQ.13) THEN
45280 MDCY(I1,I2)=INEW
45281 ELSEIF(IVAR.EQ.14) THEN
45282 MDME(I1,I2)=INEW
45283 ELSEIF(IVAR.EQ.15) THEN
45284 BRAT(I1)=RNEW
45285 ELSEIF(IVAR.EQ.16) THEN
45286 KFDP(I1,I2)=INEW
45287 ELSEIF(IVAR.EQ.17) THEN
45288 CHAF(I1,I2)=CHNEW
45289 ELSEIF(IVAR.EQ.18) THEN
45290 MRPY(I1)=INEW
45291 ELSEIF(IVAR.EQ.19) THEN
45292 RRPY(I1)=RNEW
45293 ELSEIF(IVAR.EQ.20) THEN
45294 MSEL=INEW
45295 ELSEIF(IVAR.EQ.21) THEN
45296 MSUB(I1)=INEW
45297 ELSEIF(IVAR.EQ.22) THEN
45298 KFIN(I1,I2)=INEW
45299 ELSEIF(IVAR.EQ.23) THEN
45300 CKIN(I1)=RNEW
45301 ELSEIF(IVAR.EQ.24) THEN
45302 MSTP(I1)=INEW
45303 ELSEIF(IVAR.EQ.25) THEN
45304 PARP(I1)=RNEW
45305 ELSEIF(IVAR.EQ.26) THEN
45306 MSTI(I1)=INEW
45307 ELSEIF(IVAR.EQ.27) THEN
45308 PARI(I1)=RNEW
45309 ELSEIF(IVAR.EQ.28) THEN
45310 MINT(I1)=INEW
45311 ELSEIF(IVAR.EQ.29) THEN
45312 VINT(I1)=RNEW
45313 ELSEIF(IVAR.EQ.30) THEN
45314 ISET(I1)=INEW
45315 ELSEIF(IVAR.EQ.31) THEN
45316 KFPR(I1,I2)=INEW
45317 ELSEIF(IVAR.EQ.32) THEN
45318 COEF(I1,I2)=RNEW
45319 ELSEIF(IVAR.EQ.33) THEN
45320 ICOL(I1,I2,I3)=INEW
45321 ELSEIF(IVAR.EQ.34) THEN
45322 XSFX(I1,I2)=RNEW
45323 ELSEIF(IVAR.EQ.35) THEN
45324 ISIG(I1,I2)=INEW
45325 ELSEIF(IVAR.EQ.36) THEN
45326 SIGH(I1)=RNEW
45327 ELSEIF(IVAR.EQ.37) THEN
45328 MWID(I1)=INEW
45329 ELSEIF(IVAR.EQ.38) THEN
45330 WIDS(I1,I2)=RNEW
45331 ELSEIF(IVAR.EQ.39) THEN
45332 NGEN(I1,I2)=INEW
45333 ELSEIF(IVAR.EQ.40) THEN
45334 XSEC(I1,I2)=RNEW
45335 ELSEIF(IVAR.EQ.41) THEN
45336 PROC(I1)=CHNEW2
45337 ELSEIF(IVAR.EQ.42) THEN
45338 SIGT(I1,I2,I3)=RNEW
45339 ELSEIF(IVAR.EQ.43) THEN
45340 XPVMD(I1)=RNEW
45341 ELSEIF(IVAR.EQ.44) THEN
45342 XPANL(I1)=RNEW
45343 ELSEIF(IVAR.EQ.45) THEN
45344 XPANH(I1)=RNEW
45345 ELSEIF(IVAR.EQ.46) THEN
45346 XPBEH(I1)=RNEW
45347 ELSEIF(IVAR.EQ.47) THEN
45348 XPDIR(I1)=RNEW
45349 ELSEIF(IVAR.EQ.48) THEN
45350 IMSS(I1)=INEW
45351 ELSEIF(IVAR.EQ.49) THEN
45352 RMSS(I1)=RNEW
45353 ELSEIF(IVAR.EQ.50) THEN
45354 RVLAM(I1,I2,I3)=RNEW
45355 ELSEIF(IVAR.EQ.51) THEN
45356 RVLAMP(I1,I2,I3)=RNEW
45357 ELSEIF(IVAR.EQ.52) THEN
45358 RVLAMB(I1,I2,I3)=RNEW
45359 ELSEIF(IVAR.EQ.53) THEN
45360 ITCM(I1)=INEW
45361 ELSEIF(IVAR.EQ.54) THEN
45362 RTCM(I1)=RNEW
45363 ENDIF
45364
45365C...Write old and new value. Loop back.
45366 CHBIT(LNAM:14)=' '
45367 CHBIT(15:60)=' changed from to '
45368 IF(MSVAR(IVAR,1).EQ.1) THEN
45369 WRITE(CHBIT(33:42),'(I10)') IOLD
45370 WRITE(CHBIT(51:60),'(I10)') INEW
45371 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
45372 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
45373 WRITE(CHBIT(29:42),'(F14.5)') ROLD
45374 WRITE(CHBIT(47:60),'(F14.5)') RNEW
45375 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
45376 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
45377 CHBIT(35:42)=CHOLD
45378 CHBIT(53:60)=CHNEW
45379 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
45380 ELSE
45381 CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
45382 IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
45383 ENDIF
45384 LLOW=LHIG
45385 IF(LLOW.LT.LTOT) GOTO 120
45386
45387C...Format statement for output on unit MSTU(11) (by default 6).
45388 5000 FORMAT(5X,A60)
45389 5100 FORMAT(5X,A88)
45390
45391 RETURN
45392 END
45393
45394C*********************************************************************
45395
45396C...PYEXEC
45397C...Administrates the fragmentation and decay chain.
45398
45399 SUBROUTINE PYEXEC
45400
45401C...Double precision and integer declarations.
45402 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45403 IMPLICIT INTEGER(I-N)
45404 INTEGER PYK,PYCHGE,PYCOMP
45405C...Commonblocks.
45406 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
45407 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45408 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45409 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
45410 COMMON/PYINT4/MWID(500),WIDS(500,5)
45411 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT4/
45412C...Local array.
45413 DIMENSION PS(2,6),IJOIN(100)
2dfa57d1 45414C...Initialize and reset.
45415 MSTU(24)=0
45416 IF(MSTU(12).GE.1) CALL PYLIST(0)
45417 MSTU(29)=0
45418 MSTU(31)=MSTU(31)+1
45419 MSTU(1)=0
45420 MSTU(2)=0
45421 MSTU(3)=0
45422 IF(MSTU(17).LE.0) MSTU(90)=0
45423 MCONS=1
45424
45425C...Sum up momentum, energy and charge for starting entries.
45426 NSAV=N
45427 DO 110 I=1,2
45428 DO 100 J=1,6
45429 PS(I,J)=0D0
45430 100 CONTINUE
45431 110 CONTINUE
45432 DO 130 I=1,N
45433 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
45434 DO 120 J=1,4
45435 PS(1,J)=PS(1,J)+P(I,J)
45436 120 CONTINUE
45437 PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
45438 130 CONTINUE
45439 PARU(21)=PS(1,4)
45440
45441C...Start by all decays of coloured resonances involved in shower.
45442 NORIG=N
45443 DO 140 I=1,NORIG
45444 IF(K(I,1).EQ.3) THEN
45445 KC=PYCOMP(K(I,2))
45446 IF(MWID(KC).NE.0.AND.KCHG(KC,2).NE.0) CALL PYRESD(I)
45447 ENDIF
45448 140 CONTINUE
45449
45450C...Prepare system for subsequent fragmentation/decay.
45451 CALL PYPREP(0)
45452
45453C...Loop through jet fragmentation and particle decays.
45454 MBE=0
45455 150 MBE=MBE+1
45456 IP=0
45457 160 IP=IP+1
45458 KC=0
45459 IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
45460 IF(KC.EQ.0) THEN
45461
45462C...Deal with any remaining undecayed resonance
45463C...(normally the task of PYEVNT, so seldom used).
45464 ELSEIF(MWID(KC).NE.0) THEN
45465 IBEG=IP
45466 IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
45467 IBEG=IP+1
45468 170 IBEG=IBEG-1
45469 IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 170
45470 IF(K(IBEG,1).NE.2) IBEG=IBEG+1
45471 IEND=IP-1
45472 180 IEND=IEND+1
45473 IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 180
45474 IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 180
45475 NJOIN=0
45476 DO 190 I=IBEG,IEND
45477 IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
45478 NJOIN=NJOIN+1
45479 IJOIN(NJOIN)=I
45480 ENDIF
45481 190 CONTINUE
45482 ENDIF
45483 CALL PYRESD(IP)
45484 CALL PYPREP(IBEG)
45485
45486C...Particle decay if unstable and allowed. Save long-lived particle
45487C...decays until second pass after Bose-Einstein effects.
45488 ELSEIF(KCHG(KC,2).EQ.0) THEN
45489 IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
45490 & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
45491 & CALL PYDECY(IP)
45492
45493C...Decay products may develop a shower.
45494 IF(MSTJ(92).GT.0) THEN
45495 IP1=MSTJ(92)
45496 QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
45497 & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
45498 CALL PYSHOW(IP1,IP1+1,QMAX)
45499 CALL PYPREP(IP1)
45500 MSTJ(92)=0
45501 ELSEIF(MSTJ(92).LT.0) THEN
45502 IP1=-MSTJ(92)
45503 CALL PYSHOW(IP1,-3,P(IP,5))
45504 CALL PYPREP(IP1)
45505 MSTJ(92)=0
45506 ENDIF
45507
45508C...Jet fragmentation: string or independent fragmentation.
45509 ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
45510 MFRAG=MSTJ(1)
45511 IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
45512 IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
45513 IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
45514 & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
45515 IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
45516 ENDIF
45517 ENDIF
45518 IF(MFRAG.EQ.1) CALL PYSTRF(IP)
45519 IF(MFRAG.EQ.2) CALL PYINDF(IP)
45520 IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
45521 IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
45522 ENDIF
45523
45524C...Loop back if enough space left in PYJETS and no error abort.
45525 IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
45526 ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
45527 GOTO 160
45528 ELSEIF(IP.LT.N) THEN
45529 CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
45530 ENDIF
45531
45532C...Include simple Bose-Einstein effect parametrization if desired.
45533 IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
45534 CALL PYBOEI(NSAV)
45535 GOTO 150
45536 ENDIF
45537
45538C...Check that momentum, energy and charge were conserved.
45539 DO 210 I=1,N
45540 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 210
45541 DO 200 J=1,4
45542 PS(2,J)=PS(2,J)+P(I,J)
45543 200 CONTINUE
45544 PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
45545 210 CONTINUE
45546 PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
45547 &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
45548 IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
45549 &'(PYEXEC:) four-momentum was not conserved')
45550 IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
45551 &'(PYEXEC:) charge was not conserved')
45552
45553 RETURN
45554 END
45555
45556C*********************************************************************
45557
45558C...PYPREP
45559C...Rearranges partons along strings.
45560C...Special considerations for systems with junctions, with
45561C...possibility of junction-antijunction annihilation.
45562C...Allows small systems to collapse into one or two particles.
45563C...Checks flavours and colour singlet invariant masses.
45564
45565 SUBROUTINE PYPREP(IP)
45566
45567C...Double precision and integer declarations.
45568 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45569 INTEGER PYK,PYCHGE,PYCOMP
45570C...Commonblocks.
45571 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
45572 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45573 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45574 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
45575 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
45576C...Local arrays.
45577 DIMENSION DPS(5),DPC(5),UE(3),PG(5),E1(3),E2(3),E3(3),E4(3),
45578 &ECL(3),IJUNC(10,0:4),IPIECE(30,0:4),KFEND(4),KFQ(4),
45579 &IJUR(4),PJU(4,6),IRNG(4,2),TJJ(2,5),T(5),PUL(3,5),
45580 &IJCP(0:6),TJUOLD(5)
45581
45582C...Function to give four-product.
45583 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)
45584
45585C...Rearrange parton shower product listing along strings: begin loop.
45586 NOLD=N
45587 I1=N
45588 NJUNC=0
45589 NPIECE=0
45590 NJJSTR=0
45591 MSTU32=MSTU(32)+1
45592 DO 170 MQGST=1,3
45593 DO 160 I=MAX(1,IP),N
45594
45595C...Special treatment for junctions
45596 IF(K(I,1).EQ.42) THEN
45597C...First, just store positions
45598 IF (MQGST.EQ.1) THEN
45599 NJUNC=NJUNC+1
45600 IJUNC(NJUNC,0)=I
45601 IJUNC(NJUNC,4)=0
45602C...Then look for junction-junction strings (not detected in the
45603C...main search below).
45604 ELSE IF (MQGST.EQ.2.AND.NPIECE.NE.3*NJUNC) THEN
45605 IF (NJJSTR.EQ.0) THEN
45606 NJJSTR = (3*NJUNC-NPIECE)/2
45607 ENDIF
45608C...Check how many already identified strings end on this junction
45609 ILC=0
45610 DO 100 J=1,NPIECE
45611 IF (IPIECE(J,4).EQ.I) ILC=ILC+1
45612 100 CONTINUE
45613C...If only 2, third one must be to another junction
45614 IF (ILC.EQ.2) THEN
45615C...The colour information in the junction is unreadable for the
45616C...colour space search further down in this routine, so we must
45617C...start on the colour mother of this junction and then "artificially"
45618C...prevent the colour mother from connecting here again.
45619 IA=MOD(K(I,4),MSTU(5))
45620 KCS=4
45621 IF (MOD(MOD(K(I,4)/MSTU(5),MSTU(5)),2).EQ.1) KCS=5
45622 K(IA,KCS) = K(IA,KCS) + MSTU(5)**2
45623 K(I,KCS) = K(I,KCS) + 2*MSTU(5)**2
45624 I1BEG = I1
45625 NSTP = 0
45626 GOTO 150
45627 ELSE IF (ILC.NE.3) THEN
45628C...This could happen if 2 legs of a junction connect to other
45629C...junctions.
45630 CALL PYERRM(12,
45631 & '(PYPREP:) Too many junction-junction strings.')
45632 ENDIF
45633 ENDIF
45634 ENDIF
45635
45636C...Look for coloured string endpoint, or (later) leftover gluon.
45637 IF(K(I,1).NE.3) GOTO 160
45638 KC=PYCOMP(K(I,2))
45639 IF(KC.EQ.0) GOTO 160
45640 KQ=KCHG(KC,2)
45641 IF(KQ.EQ.0.OR.(MQGST.LE.2.AND.KQ.EQ.2)) GOTO 160
45642
45643C...Pick up loose string end.
45644 KCS=4
45645 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
45646 IA=I
45647 IB=I
45648 I1BEG=I1
45649 NSTP=0
45650 110 NSTP=NSTP+1
45651 IF(NSTP.GT.4*N) THEN
45652 CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
45653 RETURN
45654 ENDIF
45655
45656C...Copy undecayed parton. Finished if reached string endpoint.
45657 IF(K(IA,1).EQ.3) THEN
45658 IF(I1.GE.MSTU(4)-MSTU32-5) THEN
45659 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
45660 RETURN
45661 ENDIF
45662 I1=I1+1
45663 K(I1,1)=2
45664 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1
45665 K(I1,2)=K(IA,2)
45666 K(I1,3)=IA
45667 K(I1,4)=0
45668 K(I1,5)=0
45669 DO 120 J=1,5
45670 P(I1,J)=P(IA,J)
45671 V(I1,J)=V(IA,J)
45672 120 CONTINUE
45673 K(IA,1)=K(IA,1)+10
45674 IF(K(I1,1).EQ.1) GOTO 160
45675 ENDIF
45676
45677C...Also finished (for now) if reached junction; then copy to end.
45678 IF(K(IA,1).EQ.42) THEN
45679 NCOPY=I1-I1BEG
45680 IF(I1.GE.MSTU(4)-MSTU32-NCOPY-5) THEN
45681 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
45682 RETURN
45683 ENDIF
45684 IF (MQGST.LE.2.AND.NCOPY.NE.0) THEN
45685 DO 140 ICOPY=1,NCOPY
45686 DO 130 J=1,5
45687 K(MSTU(4)-MSTU32-ICOPY,J)=K(I1BEG+ICOPY,J)
45688 P(MSTU(4)-MSTU32-ICOPY,J)=P(I1BEG+ICOPY,J)
45689 V(MSTU(4)-MSTU32-ICOPY,J)=V(I1BEG+ICOPY,J)
45690 130 CONTINUE
45691 140 CONTINUE
45692 ENDIF
45693 NPIECE=NPIECE+1
45694 IPIECE(NPIECE,0)=I
45695 IPIECE(NPIECE,1)=MSTU32+1
45696 IPIECE(NPIECE,2)=MSTU32+NCOPY
45697 IPIECE(NPIECE,3)=IB
45698 IPIECE(NPIECE,4)=IA
45699 MSTU32=MSTU32+NCOPY
45700 I1=I1BEG
45701 GOTO 160
45702 ENDIF
45703
45704C...GOTO next parton in colour space.
45705 150 IB=IA
45706 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
45707 & .NE.0) THEN
45708 IA=MOD(K(IB,KCS),MSTU(5))
45709 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
45710 MREV=0
45711 ELSE
45712 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
45713 & MSTU(5)).EQ.0) KCS=9-KCS
45714 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
45715 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
45716 MREV=1
45717 ENDIF
45718 IF(IA.LE.0.OR.IA.GT.N) THEN
45719 CALL PYERRM(12,'(PYPREP:) colour rearrangement failed')
45720 RETURN
45721 ENDIF
45722 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
45723 & MSTU(5)).EQ.IB) THEN
45724 IF(MREV.EQ.1) KCS=9-KCS
45725 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
45726 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
45727 ELSE
45728 IF(MREV.EQ.0) KCS=9-KCS
45729 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
45730 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
45731 ENDIF
45732 IF(IA.NE.I) GOTO 110
45733 K(I1,1)=1
45734 160 CONTINUE
45735 170 CONTINUE
45736
45737C...Junction systems remain.
45738 IJU=0
45739 IJUS=0
45740 IJUCNT=0
45741 MREV=0
45742 IJJSTR=0
45743 180 IJUCNT=IJUCNT+1
45744 IF (IJUCNT.LE.NJUNC) THEN
45745C...If we are not processing a j-j string, treat this junction as new.
45746 IF (IJJSTR.EQ.0) THEN
45747 IJU=IJUNC(IJUCNT,0)
45748 MREV=0
45749C...If junction has already been read, ignore it.
45750 IF (IJUNC(IJUCNT,4).EQ.1) GOTO 180
45751C...If we are on a j-j string, goto second j-j junction.
45752 ELSE
45753 IJUCNT=IJUCNT-1
45754 IJU=IJUS
45755 ENDIF
45756C...Mark selected junction read.
45757 DO 190 J=1,NJUNC
45758 IF (IJUNC(J,0).EQ.IJU) IJUNC(J,4)=1
45759 190 CONTINUE
45760
45761C...Determine junction type
45762 ITJUNC = MOD(K(IJU,4)/MSTU(5),MSTU(5))
45763C...Type 1 and 2 junctions: ~chi -> q q q, ~chi -> qbar,qbar,qbar
45764C...Type 3 and 4 junctions: ~qbar -> q q , ~q -> qbar qbar
45765C...Type 5 and 6 junctions: ~g -> q q q, ~g -> qbar qbar qbar
45766 IF (ITJUNC.GE.1.AND.ITJUNC.LE.6) THEN
45767 IHK=0
45768 200 IHK=IHK+1
45769C...Find which quarks belong to given junction.
45770 IF(IHK.EQ.1) IEND=MOD(K(IJU,5),MSTU(5))
45771 IF(IHK.EQ.2) IEND=MOD(K(IJU,5)/MSTU(5),MSTU(5))
45772C...IHK = 3 is special. Either normal string piece, or j-j string.
45773 IF(IHK.EQ.3) THEN
45774 IEND=MOD(K(IJU,4),MSTU(5))
45775 IF (MREV.NE.1) THEN
45776 DO 210 IPC=1,NPIECE
45777C...If there is a j-j string starting on the present junction which has
45778C...zero length, insert next junction immediately.
45779 IF (IPIECE(IPC,0).EQ.IJU.AND.K(IPIECE(IPC,4),1)
45780 & .EQ.42.AND.IPIECE(IPC,1)-1-IPIECE(IPC,2).EQ.0) THEN
45781 IJJSTR = 1
45782 GOTO 250
45783 ENDIF
45784 210 CONTINUE
45785 MREV = 1
45786C...If MREV is 1 and IHK is 3 we are finished with this system.
45787 ELSE
45788 MREV=0
45789 GOTO 180
45790 ENDIF
45791 ENDIF
45792
45793C...If we've gotten this far, then either IHK < 3, or
45794C...an interjunction string exists, or just a third normal string.
45795 IJUNC(IJUCNT,IHK)=0
45796 IJJSTR = 0
45797C..Order pieces belonging to this junction. Also look for j-j.
45798 DO 220 IPC=1,NPIECE
45799 IF (IPIECE(IPC,3).EQ.IEND) IJUNC(IJUCNT,IHK)=IPC
45800 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJUNC(IJUCNT,0)
45801 & .AND.K(IPIECE(IPC,4),1).EQ.42) THEN
45802 IJUNC(IJUCNT,IHK)=IPC
45803 IJJSTR = 1
45804 MREV = 0
45805 ENDIF
45806 220 CONTINUE
45807C...Copy back chains in proper order. MREV=0/1 : descending/ascending
45808 IPC=IJUNC(IJUCNT,IHK)
45809 DO 240 ICP=IPIECE(IPC,1+MREV),IPIECE(IPC,2-MREV),1-2*MREV
45810 I1=I1+1
45811 DO 230 J=1,5
45812 K(I1,J)=K(MSTU(4)-ICP,J)
45813 P(I1,J)=P(MSTU(4)-ICP,J)
45814 V(I1,J)=V(MSTU(4)-ICP,J)
45815 230 CONTINUE
45816 240 CONTINUE
45817 K(I1,1)=2
45818C...Mark last quark.
45819 IF (MREV.EQ.1.AND.IHK.GE.2) K(I1,1)=1
45820C...Do not insert junctions at wrong places.
45821 IF(IHK.LT.2.OR.MREV.NE.0) GOTO 270
45822C...Insert junction.
45823 250 IJUS = IJU
45824 IF (IHK.EQ.3) THEN
45825C...Shift to end junction if a j-j string has been processed.
45826 IF (IJJSTR.NE.0) IJUS = IPIECE(IPC,4)
45827 MREV= 1
45828 ENDIF
45829 I1=I1+1
45830 DO 260 J=1,5
45831 K(I1,J)=0
45832 P(I1,J)=0.
45833 V(I1,J)=0.
45834 260 CONTINUE
45835 K(I1,1)=41
45836 K(IJUS,1)=K(IJUS,1)+10
45837 K(I1,2)=K(IJUS,2)
45838 K(I1,3)=K(IJUS,3)
45839 270 IF (IHK.LT.3) GOTO 200
45840 ELSE
45841 CALL PYERRM(12,'(PYPREP:) Unknown junction type')
45842 ENDIF
45843 IF (IJUCNT.NE.NJUNC) GOTO 180
45844 ENDIF
45845 N=I1
45846
45847C...Rearrange three strings from junction, e.g. in case one has been
45848C...shortened by shower, so the last is the largest-energy one.
45849 IF(NJUNC.GE.1) THEN
45850C...Find systems with exactly one junction.
45851 MJUN1=0
45852 NBEG=NOLD+1
45853 DO 380 I=NOLD+1,N
45854 IF(K(I,1).NE.1.AND.K(I,1).NE.41) THEN
45855 ELSEIF(K(I,1).EQ.41) THEN
45856 MJUN1=MJUN1+1
45857 ELSEIF(K(I,1).EQ.1.AND.MJUN1.NE.1) THEN
45858 MJUN1=0
45859 NBEG=I+1
45860 ELSE
45861 NEND=I
45862C...Sum up energy-momentum in each junction string.
45863 DO 280 J=1,5
45864 PJU(1,J)=0D0
45865 PJU(2,J)=0D0
45866 PJU(3,J)=0D0
45867 280 CONTINUE
45868 NJU=0
45869 DO 300 I1=NBEG,NEND
45870 IF(K(I1,2).NE.21) THEN
45871 NJU=NJU+1
45872 IJUR(NJU)=I1
45873 ENDIF
45874 DO 290 J=1,5
45875 PJU(MIN(NJU,3),J)=PJU(MIN(NJU,3),J)+P(I1,J)
45876 290 CONTINUE
45877 300 CONTINUE
45878C...Find which of them has highest energy (minus mass) in rest frame.
45879 DO 310 J=1,5
45880 PJU(4,J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
45881 310 CONTINUE
45882 PMJU=SQRT(MAX(0D0,PJU(4,4)**2-PJU(4,1)**2-PJU(4,2)**2-
45883 & PJU(4,3)**2))
45884 DO 320 I2=1,3
45885 PJU(I2,6)=(PJU(4,4)*PJU(I2,4)-PJU(4,1)*PJU(I2,1)-
45886 & PJU(4,2)*PJU(I2,2)-PJU(4,3)*PJU(I2,3))/PMJU-PJU(I2,5)
45887 320 CONTINUE
45888 IF(PJU(3,6).LT.MIN(PJU(1,6),PJU(2,6))) THEN
45889C...Decide how to rearrange so that new last has highest energy.
45890 IF(PJU(1,6).LT.PJU(2,6)) THEN
45891 IRNG(1,1)=IJUR(1)
45892 IRNG(1,2)=IJUR(2)-1
45893 IRNG(2,1)=IJUR(4)
45894 IRNG(2,2)=IJUR(3)+1
45895 IRNG(4,1)=IJUR(3)-1
45896 IRNG(4,2)=IJUR(2)
45897 ELSE
45898 IRNG(1,1)=IJUR(4)
45899 IRNG(1,2)=IJUR(3)+1
45900 IRNG(2,1)=IJUR(2)
45901 IRNG(2,2)=IJUR(3)-1
45902 IRNG(4,1)=IJUR(2)-1
45903 IRNG(4,2)=IJUR(1)
45904 ENDIF
45905 IRNG(3,1)=IJUR(3)
45906 IRNG(3,2)=IJUR(3)
45907C...Copy in correct order below bottom of current event record.
45908 I2=N
45909 DO 350 II=1,4
45910 DO 340 I1=IRNG(II,1),IRNG(II,2),
45911 & ISIGN(1,IRNG(II,2)-IRNG(II,1))
45912 I2=I2+1
45913 DO 330 J=1,5
45914 K(I2,J)=K(I1,J)
45915 P(I2,J)=P(I1,J)
45916 V(I2,J)=V(I1,J)
45917 330 CONTINUE
45918 IF(K(I2,1).EQ.1) K(I2,1)=2
45919 340 CONTINUE
45920 350 CONTINUE
45921 K(I2,1)=1
45922C...Copy back up, overwriting but now in correct order.
45923 DO 370 I1=NBEG,NEND
45924 I2=I1-NBEG+N+1
45925 DO 360 J=1,5
45926 K(I1,J)=K(I2,J)
45927 P(I1,J)=P(I2,J)
45928 V(I1,J)=V(I2,J)
45929 360 CONTINUE
45930 370 CONTINUE
45931 ENDIF
45932 MJUN1=0
45933 NBEG=I+1
45934 ENDIF
45935 380 CONTINUE
45936C++SKANDS
45937C...Check whether q-q-j-j-qbar-qbar systems should be collapsed
45938C...to two q-qbar systems.
45939C...(MSTJ(19)=1 forces q-q-j-j-qbar-qbar.)
45940 IF (MSTJ(19).NE.1) THEN
45941 MJUN1 = 0
45942 JJGLUE = 0
45943 NBEG = NOLD+1
45944C...Force collapse when MSTJ(19)=2.
45945 IF (MSTJ(19).EQ.2) THEN
45946 DELMJJ = 1D9
45947 DELMQQ = 0D0
45948 ENDIF
45949C...Find systems with exactly two junctions.
45950 DO 610 I=NOLD+1,N
45951C...Count junctions
45952 IF (K(I,1).EQ.41) THEN
45953 MJUN1 = MJUN1+1
45954C...Check for interjunction gluons
45955 IF (MJUN1.EQ.2.AND.K(I-1,1).NE.41) THEN
45956 JJGLUE = 1
45957 ENDIF
45958 ELSEIF(K(I,1).EQ.1.AND.(MJUN1.NE.2)) THEN
45959C...If end of system reached with either zero or one junction, restart
45960C...with next system.
45961 MJUN1 = 0
45962 JJGLUE = 0
45963 NBEG = I+1
45964 ELSEIF(K(I,1).EQ.1) THEN
45965C...If end of system reached with exactly two junctions, compute string
45966C...length measure for the (q-q-j-j-qbar-qbar) topology and compare with
45967C...length measure for the (q-qbar)(q-qbar) topology.
45968 NEND=I
45969C...Loop down through chain.
45970 ISID=0
45971 DO 390 I1=NBEG,NEND
45972C...Store string piece division locations in event record
45973 IF (K(I1,2).NE.21) THEN
45974 ISID = ISID+1
45975 IJCP(ISID) = I1
45976 ENDIF
45977 390 CONTINUE
45978C...Randomly choose between (1,3)(2,4) and (1,4)(2,3) topologies.
45979 ISW=0
45980 IF (PYR(0).LT.0.5D0) ISW=1
45981C...Randomly choose which qqbar string gets the jj gluons.
45982 IGS=1
45983 IF (PYR(0).GT.0.5D0) IGS=2
45984C...Only compute string lengths when no topology forced.
45985 IF (MSTJ(19).EQ.0) THEN
45986C...Repeat following for each junction
45987 DO 480 IJU=1,2
45988C...Initialize iterative procedure for finding JRF
45989 IJRFIT=0
45990 DO 400 IX=1,3
45991 TJUOLD(IX)=0D0
45992 400 CONTINUE
45993 TJUOLD(4)=1D0
45994C...Start iteration. Sum up momenta in string pieces
45995 410 DO 450 IJS=1,3
45996C...JD=-1 for first junction, +1 for second junction.
45997C...Find out where piece starts and ends and which direction to go.
45998 JD=2*IJU-3
45999 IF (IJS.LE.2) THEN
46000 IA = IJCP((IJU-1)*7 - JD*(IJS+1)) + JD
46001 IB = IJCP((IJU-1)*7 - JD*IJS)
46002 ELSEIF (IJS.EQ.3) THEN
46003 JD =-JD
46004 IA = IJCP((IJU-1)*7 + JD*(IJS)) + JD
46005 IB = IJCP((IJU-1)*7 + JD*(IJS+3))
46006 ENDIF
46007C...Initialize junction pull 4-vector.
46008 DO 420 J=1,5
46009 PUL(IJS,J)=0D0
46010 420 CONTINUE
46011C...Initialize weight
46012 PWT = 0D0
46013 PWTOLD = 0D0
46014C...Sum up (weighted) momenta along each string piece
46015 DO 440 ISP=IA,IB,JD
46016C...If present parton not last in chain
46017 IF (ISP.NE.IA.AND.ISP.NE.IB) THEN
46018C...If last parton was a junction, store present weight
46019 IF (K(ISP-JD,2).EQ.88) THEN
46020 PWTOLD = PWT
46021C...If last parton was a quark, reset to stored weight.
46022 ELSEIF (K(ISP-JD,2).NE.21) THEN
46023 PWT = PWTOLD
46024 ENDIF
46025 ENDIF
46026C...Skip next parton if weight already large
46027 IF (PWT.GT.10D0) GOTO 440
46028C...Compute momentum in TJUOLD frame:
46029 TDP=TJUOLD(1)*P(ISP,1)+TJUOLD(2)*P(ISP,2)+TJUOLD(3
46030 & )*P(ISP,3)
46031 BFC=TDP/(1D0+TJUOLD(4))+P(ISP,4)
46032 DO 430 J=1,3
46033 TMP=P(ISP,J)+TJUOLD(J)*BFC
46034 PUL(IJS,J)=PUL(IJS,J)+TMP*EXP(-PWT)
46035 430 CONTINUE
46036C...Boosted energy
46037 TMP=TJUOLD(4)*P(ISP,4)+TDP
46038 PUL(IJS,4)=PUL(IJS,J)+TMP*EXP(-PWT)
46039C...Update weight
46040 PWT=PWT+TMP/PARJ(48)
46041C...Put |p| rather than m in 5th slot
46042 PUL(IJS,5)=SQRT(PUL(IJS,1)**2+PUL(IJS,2)**2
46043 & +PUL(IJS,3)**2)
46044 440 CONTINUE
46045 450 CONTINUE
46046C...Compute boost
46047 IJRFIT=IJRFIT+1
46048 CALL PYJURF(PUL,T)
46049C...Combine new boost (T) with old boost (TJUOLD)
46050 TMP=T(1)*TJUOLD(1)+T(2)*TJUOLD(2)+T(3)*TJUOLD(3)
46051 DO 460 IX=1,3
46052 TJUOLD(IX)=T(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+T(4
46053 & ))
46054 460 CONTINUE
46055 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)
46056 & **2)
46057C...If last boost small, accept JRF, else iterate.
46058C...Also prevent possibility of infinite loop.
46059 IF (ABS((T(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
46060 & IJRFIT.LT.MSTJ(18))THEN
46061 GOTO 410
46062 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
46063 CALL PYERRM(1,'(PYPREP:) failed to converge on JRF')
46064 ENDIF
46065C...Store final boost, with change of sign since TJJ motion vector.
46066 DO 470 IX=1,3
46067 TJJ(IJU,IX)=-TJUOLD(IX)
46068 470 CONTINUE
46069 TJJ(IJU,4)=SQRT(1D0+TJJ(IJU,1)**2+TJJ(IJU,2)**2
46070 & +TJJ(IJU,3)**2)
46071 480 CONTINUE
46072C...String length measure for (q-qbar)(q-qbar) topology.
46073C...Note only momenta of nearest partons used (since rest of system
46074C...identical).
46075 IF (JJGLUE.EQ.0) THEN
46076 DELMQQ=4D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)*FOUR(IJCP(3)
46077 & -1,IJCP(5-ISW)+1)
46078 ELSE
46079C...Put jj gluons on selected string (IGS selected randomly above).
46080 IF (IGS.EQ.1) THEN
46081 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
46082 & ,IJCP(4+ISW)+1)*FOUR(IJCP(3)-1,IJCP(5-ISW)+1)
46083 ELSE
46084 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)
46085 & *FOUR(IJCP(3)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
46086 & ,IJCP(5-ISW)+1)
46087 ENDIF
46088 ENDIF
46089C...String length measure for q-q-j-j-q-q topology.
46090 T1G1=0D0
46091 T2G2=0D0
46092 T1T2=0D0
46093 T1P1=0D0
46094 T1P2=0D0
46095 T2P3=0D0
46096 T2P4=0D0
46097 ISGN=-1
46098C...Note only momenta of nearest partons used (since rest of system
46099C...identical).
46100 DO 490 IX=1,4
46101 IF (IX.EQ.4) ISGN=1
46102 T1P1=T1P1+ISGN*TJJ(1,IX)*P(IJCP(2)-1,IX)
46103 T1P2=T1P2+ISGN*TJJ(1,IX)*P(IJCP(3)-1,IX)
46104 T2P3=T2P3+ISGN*TJJ(2,IX)*P(IJCP(4)+1,IX)
46105 T2P4=T2P4+ISGN*TJJ(2,IX)*P(IJCP(5)+1,IX)
46106 IF (JJGLUE.EQ.0) THEN
46107C...Junction motion vector dot product gives length when inter-junction
46108C...gluons absent.
46109 T1T2=T1T2+ISGN*TJJ(1,IX)*TJJ(2,IX)
46110 ELSE
46111C...Junction motion vector dot products with gluon momenta give length
46112C...when inter-junction gluons present.
46113 T1G1=T1G1+ISGN*TJJ(1,IX)*P(IJCP(3)+1,IX)
46114 T2G2=T2G2+ISGN*TJJ(2,IX)*P(IJCP(4)-1,IX)
46115 ENDIF
46116 490 CONTINUE
46117 DELMJJ=16D0*T1P1*T1P2*T2P3*T2P4
46118 IF (JJGLUE.EQ.0) THEN
46119 DELMJJ=DELMJJ*(T1T2+SQRT(T1T2**2-1))
46120 ELSE
46121 DELMJJ=DELMJJ*4D0*T1G1*T2G2
46122 ENDIF
46123 ENDIF
46124C...If delmjj > delmqq collapse string system to q-qbar q-qbar
46125C...(Always the case for MSTJ(19)=2 due to initialization above)
46126 IF (DELMJJ.GT.DELMQQ) THEN
46127C...Put new system at end of event record
46128 NCOP=N
46129 DO 560 IST=1,2
46130 DO 510 ICOP=IJCP(IST),IJCP(IST+1)-1
46131 NCOP=NCOP+1
46132 DO 500 IX=1,5
46133 P(NCOP,IX)=P(ICOP,IX)
46134 K(NCOP,IX)=K(ICOP,IX)
46135 500 CONTINUE
46136 510 CONTINUE
46137 IF (JJGLUE.NE.0.AND.IST.EQ.IGS) THEN
46138C...Insert inter-junction gluon string piece (reversed)
46139 NJJGL=0
46140 DO 530 ICOP=IJCP(4)-1,IJCP(3)+1,-1
46141 NJJGL=NJJGL+1
46142 NCOP=NCOP+1
46143 DO 520 IX=1,5
46144 P(NCOP,IX)=P(ICOP,IX)
46145 K(NCOP,IX)=K(ICOP,IX)
46146 520 CONTINUE
46147 530 CONTINUE
46148 ENDIF
46149 IFC=-2*IST+3
46150 DO 550 ICOP=IJCP(IST+IFC*ISW+3)+1,IJCP(IST+IFC*ISW+4)
46151 NCOP=NCOP+1
46152 DO 540 IX=1,5
46153 P(NCOP,IX)=P(ICOP,IX)
46154 K(NCOP,IX)=K(ICOP,IX)
46155 540 CONTINUE
46156 550 CONTINUE
46157 K(NCOP,1)=1
46158 560 CONTINUE
46159C...Copy system back in right order
46160 DO 580 ICOP=NBEG,NEND-2
46161 DO 570 IX=1,5
46162 P(ICOP,IX)=P(N+ICOP-NBEG+1,IX)
46163 K(ICOP,IX)=K(N+ICOP-NBEG+1,IX)
46164 570 CONTINUE
46165 580 CONTINUE
46166C...Shift down rest of event record
46167 DO 600 ICOP=NEND+1,N
46168 DO 590 IX=1,5
46169 P(ICOP-2,IX)=P(ICOP,IX)
46170 K(ICOP-2,IX)=K(ICOP,IX)
46171 590 CONTINUE
46172 600 CONTINUE
46173C...Update length of event record.
46174 N=N-2
46175 ENDIF
46176 MJUN1=0
46177 NBEG=I+1
46178 ENDIF
46179 610 CONTINUE
46180 ENDIF
46181 ENDIF
46182
46183C...Done if no checks on small-mass systems.
46184 IF(MSTJ(14).LT.0) RETURN
46185 IF(MSTJ(14).EQ.0) GOTO 1050
46186
46187C...Find lowest-mass colour singlet jet system.
46188 NS=N
46189 620 NSIN=N-NS
46190 PDMIN=1D0+PARJ(32)
46191 IC=0
46192 DO 680 I=MAX(1,IP),N
46193 IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
46194 ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
46195 NSIN=NSIN+1
46196 IC=I
46197 DO 630 J=1,4
46198 DPS(J)=P(I,J)
46199 630 CONTINUE
46200 MSTJ(93)=1
46201 DPS(5)=PYMASS(K(I,2))
46202 ELSEIF(K(I,1).EQ.2.AND.K(I,2).NE.21) THEN
46203 DO 640 J=1,4
46204 DPS(J)=DPS(J)+P(I,J)
46205 640 CONTINUE
46206 MSTJ(93)=1
46207 DPS(5)=DPS(5)+PYMASS(K(I,2))
46208 ELSEIF(K(I,1).EQ.2) THEN
46209 DO 650 J=1,4
46210 DPS(J)=DPS(J)+P(I,J)
46211 650 CONTINUE
46212 ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
46213 DO 660 J=1,4
46214 DPS(J)=DPS(J)+P(I,J)
46215 660 CONTINUE
46216 MSTJ(93)=1
46217 DPS(5)=DPS(5)+PYMASS(K(I,2))
46218 PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-
46219 & DPS(5)
46220 IF(PD.LT.PDMIN) THEN
46221 PDMIN=PD
46222 DO 670 J=1,5
46223 DPC(J)=DPS(J)
46224 670 CONTINUE
46225 IC1=IC
46226 IC2=I
46227 ENDIF
46228 IC=0
46229 ELSE
46230 NSIN=NSIN+1
46231 ENDIF
46232 680 CONTINUE
46233
46234C...Done if lowest-mass system above threshold for string frag.
46235 IF(PDMIN.GE.PARJ(32)) GOTO 1050
46236
46237C...Fill small-mass system as cluster.
46238 NSAV=N
46239 PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
46240 K(N+1,1)=11
46241 K(N+1,2)=91
46242 K(N+1,3)=IC1
46243 P(N+1,1)=DPC(1)
46244 P(N+1,2)=DPC(2)
46245 P(N+1,3)=DPC(3)
46246 P(N+1,4)=DPC(4)
46247 P(N+1,5)=PECM
46248
46249C...Set up history, assuming cluster -> 2 hadrons.
46250 NBODY=2
46251 K(N+1,4)=N+2
46252 K(N+1,5)=N+3
46253 K(N+2,1)=1
46254 K(N+3,1)=1
46255 IF(MSTU(16).NE.2) THEN
46256 K(N+2,3)=N+1
46257 K(N+3,3)=N+1
46258 ELSE
46259 K(N+2,3)=IC1
46260 K(N+3,3)=IC2
46261 ENDIF
46262 K(N+2,4)=0
46263 K(N+3,4)=0
46264 K(N+2,5)=0
46265 K(N+3,5)=0
46266 V(N+1,5)=0D0
46267 V(N+2,5)=0D0
46268 V(N+3,5)=0D0
46269
46270C...Find total flavour content - complicated by presence of junctions.
46271 NQ=0
46272 NDIQ=0
46273 DO 690 I=IC1,IC2
46274 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.K(I,2).NE.21) THEN
46275 NQ=NQ+1
46276 KFQ(NQ)=K(I,2)
46277 IF(IABS(K(I,2)).GT.1000) NDIQ=NDIQ+1
46278 ENDIF
46279 690 CONTINUE
46280
46281C...If several diquarks, split up one to give even number of flavours.
46282 IF(NQ.EQ.3.AND.NDIQ.GE.2) THEN
46283 I1=3
46284 IF(IABS(KFQ(3)).LT.1000) I1=1
46285 KFQ(4)=ISIGN(MOD(IABS(KFQ(I1))/100,10),KFQ(I1))
46286 KFQ(I1)=KFQ(I1)/1000
46287 NQ=4
46288 NDIQ=NDIQ-1
46289 ENDIF
46290
46291C...If four quark ends, join two to diquark.
46292 IF(NQ.EQ.4.AND.NDIQ.EQ.0) THEN
46293 I1=1
46294 I2=2
46295 IF(KFQ(I1)*KFQ(I2).LT.0) I2=3
46296 IF(I2.EQ.3.AND.KFQ(I1)*KFQ(I2).LT.0) I2=4
46297 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
46298 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
46299 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
46300 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
46301 KFQ(I2)=KFQ(4)
46302 NQ=3
46303 NDIQ=1
46304 ENDIF
46305
46306C...If two quark ends, plus quark or diquark, join quarks to diquark.
46307 IF(NQ.EQ.3) THEN
46308 I1=1
46309 I2=2
46310 IF(IABS(KFQ(I1)).GT.1000) I1=3
46311 IF(IABS(KFQ(I2)).GT.1000) I2=3
46312 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
46313 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
46314 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
46315 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
46316 KFQ(I2)=KFQ(3)
46317 NQ=2
46318 NDIQ=NDIQ+1
46319 ENDIF
46320
46321C...Form two particles from flavours of lowest-mass system, if feasible.
46322 NTRY = 0
46323 700 NTRY = NTRY + 1
46324
46325C...Open string with two specified endpoint flavours.
46326 IF(NQ.EQ.2) THEN
46327 KC1=PYCOMP(KFQ(1))
46328 KC2=PYCOMP(KFQ(2))
46329 IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 1050
46330 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
46331 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
46332 IF(KQ1+KQ2.NE.0) GOTO 1050
46333C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
46334 710 K1=KFQ(1)
46335 IF(IABS(KFQ(2)).GT.1000) K1=KFQ(2)
46336 MSTU(125)=0
46337 CALL PYDCYK(K1,0,KFLN,K(N+2,2))
46338 CALL PYDCYK(KFQ(1)+KFQ(2)-K1,-KFLN,KFLDMP,K(N+3,2))
46339 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 710
46340
46341C...Open string with four specified flavours.
46342 ELSEIF(NQ.EQ.4) THEN
46343 KC1=PYCOMP(KFQ(1))
46344 KC2=PYCOMP(KFQ(2))
46345 KC3=PYCOMP(KFQ(3))
46346 KC4=PYCOMP(KFQ(4))
46347 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) GOTO 1050
46348 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
46349 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
46350 KQ3=KCHG(KC3,2)*ISIGN(1,KFQ(3))
46351 KQ4=KCHG(KC4,2)*ISIGN(1,KFQ(4))
46352 IF(KQ1+KQ2+KQ3+KQ4.NE.0) GOTO 1050
46353C...Combine flavours pairwise to form two hadrons.
46354 720 I1=1
46355 I2=2
46356 IF(KQ1*KQ2.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
46357 & IABS(KFQ(2)).GT.1000)) I2=3
46358 IF(I2.EQ.3.AND.(KQ1*KQ3.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
46359 & IABS(KFQ(3)).GT.1000))) I2=4
46360 I3=3
46361 IF(I2.EQ.3) I3=2
46362 I4=10-I1-I2-I3
46363 CALL PYDCYK(KFQ(I1),KFQ(I2),KFLDMP,K(N+2,2))
46364 CALL PYDCYK(KFQ(I3),KFQ(I4),KFLDMP,K(N+3,2))
46365 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 720
46366
46367C...Closed string.
46368 ELSE
46369 IF(IABS(K(IC2,2)).NE.21) GOTO 1050
46370C...No room for popcorn mesons in closed string -> 2 hadrons.
46371 MSTU(125)=0
46372 730 CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
46373 CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
46374 CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
46375 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 730
46376 ENDIF
46377 P(N+2,5)=PYMASS(K(N+2,2))
46378 P(N+3,5)=PYMASS(K(N+3,2))
46379
46380C...If it does not work: try again (a number of times), give up (if no
46381C...place to shuffle momentum or too many flavours), or form one hadron.
46382 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) THEN
46383 IF(NTRY.LT.MSTJ(17).OR.(NQ.EQ.4.AND.NTRY.LT.5*MSTJ(17))) THEN
46384 GOTO 700
46385 ELSEIF(NSIN.EQ.1.OR.NQ.EQ.4) THEN
46386 GOTO 1050
46387 ELSE
46388 GOTO 800
46389 END IF
46390 END IF
46391
46392C...Perform two-particle decay of jet system.
46393C...First step: find reference axis in decaying system rest frame.
46394C...(Borrow slot N+2 for temporary direction.)
46395 DO 740 J=1,4
46396 P(N+2,J)=P(IC1,J)
46397 740 CONTINUE
46398 DO 760 I=IC1+1,IC2-1
46399 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
46400 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
46401 FRAC1=FOUR(IC2,I)/(FOUR(IC1,I)+FOUR(IC2,I))
46402 DO 750 J=1,4
46403 P(N+2,J)=P(N+2,J)+FRAC1*P(I,J)
46404 750 CONTINUE
46405 ENDIF
46406 760 CONTINUE
46407 CALL PYROBO(N+2,N+2,0D0,0D0,-DPC(1)/DPC(4),-DPC(2)/DPC(4),
46408 &-DPC(3)/DPC(4))
46409 THE1=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
46410 PHI1=PYANGL(P(N+2,1),P(N+2,2))
46411
46412C...Second step: generate isotropic/anisotropic decay.
46413 PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
46414 &(P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
46415 770 UE(3)=PYR(0)
46416 IF(PARJ(21).LE.0.01D0) UE(3)=1D0
46417 PT2=(1D0-UE(3)**2)*PA**2
46418 IF(MSTJ(16).LE.0) THEN
46419 PREV=0.5D0
46420 ELSE
46421 IF(EXP(-PT2/(2D0*MAX(0.01D0,PARJ(21))**2)).LT.PYR(0)) GOTO 770
46422 PR1=P(N+2,5)**2+PT2
46423 PR2=P(N+3,5)**2+PT2
46424 ALAMBD=SQRT(MAX(0D0,(PECM**2-PR1-PR2)**2-4D0*PR1*PR2))
46425 PREVCF=PARJ(42)
46426 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
46427 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*ALAMBD*PARJ(40))))
46428 ENDIF
46429 IF(PYR(0).LT.PREV) UE(3)=-UE(3)
46430 PHI=PARU(2)*PYR(0)
46431 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
46432 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
46433 DO 780 J=1,3
46434 P(N+2,J)=PA*UE(J)
46435 P(N+3,J)=-PA*UE(J)
46436 780 CONTINUE
46437 P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
46438 P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
46439
46440C...Third step: move back to event frame and set production vertex.
46441 CALL PYROBO(N+2,N+3,THE1,PHI1,DPC(1)/DPC(4),DPC(2)/DPC(4),
46442 &DPC(3)/DPC(4))
46443 DO 790 J=1,4
46444 V(N+1,J)=V(IC1,J)
46445 V(N+2,J)=V(IC1,J)
46446 V(N+3,J)=V(IC2,J)
46447 790 CONTINUE
46448 N=N+3
46449 GOTO 1030
46450
46451C...Else form one particle, if possible.
46452 800 NBODY=1
46453 K(N+1,5)=N+2
46454 DO 810 J=1,4
46455 V(N+1,J)=V(IC1,J)
46456 V(N+2,J)=V(IC1,J)
46457 810 CONTINUE
46458
46459C...Select hadron flavour from available quark flavours.
46460 820 IF(NQ.EQ.2.AND.IABS(KFQ(1)).GT.100.AND.IABS(KFQ(2)).GT.100) THEN
46461 GOTO 1050
46462 ELSEIF(NQ.EQ.2) THEN
46463 CALL PYKFDI(KFQ(1),KFQ(2),KFLDMP,K(N+2,2))
46464 ELSE
46465 KFLN=1+INT((2D0+PARJ(2))*PYR(0))
46466 CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
46467 ENDIF
46468 IF(K(N+2,2).EQ.0) GOTO 820
46469 P(N+2,5)=PYMASS(K(N+2,2))
46470
46471C...Use old algorithm for E/p conservation? (EN)
46472 IF (MSTJ(16).LE.0) GOTO 990
46473
46474C...Find the string piece closest to the cluster by a loop
46475C...over the undecayed partons not in present cluster. (EN)
46476 DGLOMI=1D30
46477 IBEG=0
46478 I0=0
46479 NJUNC=0
46480 DO 850 I1=MAX(1,IP),N-1
46481 IF(K(I,1).EQ.1) NJUNC=0
46482 IF(K(I,1).EQ.41) NJUNC=NJUNC+1
46483 IF(I1.GE.IC1-1.AND.I1.LE.IC2) THEN
46484 I0=0
46485 ELSEIF(K(I1,1).EQ.2) THEN
46486 IF(I0.EQ.0) I0=I1
46487 I2=I1
46488 830 I2=I2+1
46489 IF(K(I2,1).EQ.41) GOTO 850
46490 IF(K(I2,1).GT.10) GOTO 830
46491 IF(KCHG(PYCOMP(K(I2,2)),2).EQ.0) GOTO 830
46492 IF(K(I1,2).EQ.21.AND.K(I2,2).NE.21.AND.K(I2,1).NE.1.AND.
46493 & NJUNC.EQ.0) GOTO 850
46494 IF(K(I1,2).NE.21.AND.K(I2,2).EQ.21.AND.NJUNC.NE.0) GOTO 850
46495
46496C...Define velocity vectors e1, e2, ecl and differences e3, e4.
46497 DO 840 J=1,3
46498 E1(J)=P(I1,J)/P(I1,4)
46499 E2(J)=P(I2,J)/P(I2,4)
46500 ECL(J)=P(N+1,J)/P(N+1,4)
46501 E3(J)=E2(J)-E1(J)
46502 E4(J)=ECL(J)-E1(J)
46503 840 CONTINUE
46504
46505C...Calculate minimal D=(e4-alpha*e3)**2 for 0<alpha<1.
46506 E3S=E3(1)**2+E3(2)**2+E3(3)**2
46507 E4S=E4(1)**2+E4(2)**2+E4(3)**2
46508 E34=E3(1)*E4(1)+E3(2)*E4(2)+E3(3)*E4(3)
46509 IF(E34.LE.0D0) THEN
46510 DDMIN=E4S
46511 ELSEIF(E34.LT.E3S) THEN
46512 DDMIN=E4S-E34**2/E3S
46513 ELSE
46514 DDMIN=E4S-2D0*E34+E3S
46515 ENDIF
46516
46517C...Is this the smallest so far?
46518 IF(DDMIN.LT.DGLOMI) THEN
46519 DGLOMI=DDMIN
46520 IBEG=I0
46521 IPCS=I1
46522 ENDIF
46523 ELSEIF(K(I1,1).EQ.1.AND.KCHG(PYCOMP(K(I1,2)),2).NE.0) THEN
46524 I0=0
46525 ENDIF
46526 850 CONTINUE
46527
46528C... Check if there are any strings to connect to the new gluon. (EN)
46529 IF (IBEG.EQ.0) GOTO 990
46530
46531C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
46532 IF (P(N+1,5).GE.P(N+2,5)) THEN
46533
46534C...Construct 'gluon' that is needed to put hadron on the mass shell.
46535 FRAC=P(N+2,5)/P(N+1,5)
46536 DO 860 J=1,5
46537 P(N+2,J)=FRAC*P(N+1,J)
46538 PG(J)=(1D0-FRAC)*P(N+1,J)
46539 860 CONTINUE
46540
46541C... Copy string with new gluon put in.
46542 N=N+2
46543 I=IBEG-1
46544 870 I=I+1
46545 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 870
46546 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 870
46547 N=N+1
46548 DO 880 J=1,5
46549 K(N,J)=K(I,J)
46550 P(N,J)=P(I,J)
46551 V(N,J)=V(I,J)
46552 880 CONTINUE
46553 K(I,1)=K(I,1)+10
46554 K(I,4)=N
46555 K(I,5)=N
46556 K(N,3)=I
46557 IF(I.EQ.IPCS) THEN
46558 N=N+1
46559 DO 890 J=1,5
46560 K(N,J)=K(N-1,J)
46561 P(N,J)=PG(J)
46562 V(N,J)=V(N-1,J)
46563 890 CONTINUE
46564 K(N,2)=21
46565 K(N,3)=NSAV+1
46566 ENDIF
46567 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 870
46568 GOTO 1030
46569
46570C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
46571C...from string piece endpoints.
46572 ELSE
46573
46574C...Begin by copying string that should give energy to cluster.
46575 N=N+2
46576 I=IBEG-1
46577 900 I=I+1
46578 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 900
46579 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 900
46580 N=N+1
46581 DO 910 J=1,5
46582 K(N,J)=K(I,J)
46583 P(N,J)=P(I,J)
46584 V(N,J)=V(I,J)
46585 910 CONTINUE
46586 K(I,1)=K(I,1)+10
46587 K(I,4)=N
46588 K(I,5)=N
46589 K(N,3)=I
46590 IF(I.EQ.IPCS) I1=N
46591 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 900
46592 I2=I1+1
46593
46594C...Set initial Phad.
46595 DO 920 J=1,4
46596 P(NSAV+2,J)=P(NSAV+1,J)
46597 920 CONTINUE
46598
46599C...Calculate Pg, a part of which will be added to Phad later. (EN)
46600 930 IF(MSTJ(16).EQ.1) THEN
46601 ALPHA=1D0
46602 BETA=1D0
46603 ELSE
46604 ALPHA=FOUR(NSAV+1,I2)/FOUR(I1,I2)
46605 BETA=FOUR(NSAV+1,I1)/FOUR(I1,I2)
46606 ENDIF
46607 DO 940 J=1,4
46608 PG(J)=ALPHA*P(I1,J)+BETA*P(I2,J)
46609 940 CONTINUE
46610 PG(5)=SQRT(MAX(1D-20,PG(4)**2-PG(1)**2-PG(2)**2-PG(3)**2))
46611
46612C..Solve 2nd order equation, use the best (smallest) solution. (EN)
46613 PMSCOL=P(NSAV+2,4)**2-P(NSAV+2,1)**2-P(NSAV+2,2)**2-
46614 & P(NSAV+2,3)**2
46615 PCLPG=(P(NSAV+2,4)*PG(4)-P(NSAV+2,1)*PG(1)-
46616 & P(NSAV+2,2)*PG(2)-P(NSAV+2,3)*PG(3))/PG(5)**2
46617 DELTA=SQRT(PCLPG**2+(P(NSAV+2,5)**2-PMSCOL)/PG(5)**2)-PCLPG
46618
46619C...If all gluon energy eaten, zero it and take a step back.
46620 ITER=0
46621 IF(DELTA*ALPHA.GT.1D0.AND.I1.GT.NSAV+3) THEN
46622 ITER=1
46623 DO 950 J=1,4
46624 P(NSAV+2,J)=P(NSAV+2,J)+P(I1,J)
46625 P(I1,J)=0D0
46626 950 CONTINUE
46627 P(I1,5)=0D0
46628 K(I1,1)=K(I1,1)+10
46629 I1=I1-1
46630 IF(K(I1,1).EQ.41) ITER=-1
46631 ENDIF
46632 IF(DELTA*BETA.GT.1D0.AND.I2.LT.N) THEN
46633 ITER=1
46634 DO 960 J=1,4
46635 P(NSAV+2,J)=P(NSAV+2,J)+P(I2,J)
46636 P(I2,J)=0D0
46637 960 CONTINUE
46638 P(I2,5)=0D0
46639 K(I2,1)=K(I2,1)+10
46640 I2=I2+1
46641 IF(K(I2,1).EQ.41) ITER=-1
46642 ENDIF
46643 IF(ITER.EQ.1) GOTO 930
46644
46645C...If also all endpoint energy eaten, revert to old procedure.
46646 IF((1D0-DELTA*ALPHA)*P(I1,4).LT.P(I1,5).OR.
46647 & (1D0-DELTA*BETA)*P(I2,4).LT.P(I2,5).OR.ITER.EQ.-1) THEN
46648 DO 970 I=NSAV+3,N
46649 IM=K(I,3)
46650 K(IM,1)=K(IM,1)-10
46651 K(IM,4)=0
46652 K(IM,5)=0
46653 970 CONTINUE
46654 N=NSAV
46655 GOTO 990
46656 ENDIF
46657
46658C... Construct the collapsed hadron and modified string partons.
46659 DO 980 J=1,4
46660 P(NSAV+2,J)=P(NSAV+2,J)+DELTA*PG(J)
46661 P(I1,J)=(1D0-DELTA*ALPHA)*P(I1,J)
46662 P(I2,J)=(1D0-DELTA*BETA)*P(I2,J)
46663 980 CONTINUE
46664 P(I1,5)=(1D0-DELTA*ALPHA)*P(I1,5)
46665 P(I2,5)=(1D0-DELTA*BETA)*P(I2,5)
46666
46667C...Finished with string collapse in new scheme.
46668 GOTO 1030
46669 ENDIF
46670
46671C... Use old algorithm; by choice or when in trouble.
46672 990 CONTINUE
46673C...Find parton/particle which combines to largest extra mass.
46674 IR=0
46675 HA=0D0
46676 HSM=0D0
46677 DO 1010 MCOMB=1,3
46678 IF(IR.NE.0) GOTO 1010
46679 DO 1000 I=MAX(1,IP),N
46680 IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
46681 & .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 1000
46682 IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
46683 IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 1000
46684 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 1000
46685 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
46686 & GOTO 1000
46687 HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
46688 HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5)
46689 IF(HSR.GT.HSM) THEN
46690 IR=I
46691 HA=HCR
46692 HSM=HSR
46693 ENDIF
46694 1000 CONTINUE
46695 1010 CONTINUE
46696
46697C...Shuffle energy and momentum to put new particle on mass shell.
46698 IF(IR.NE.0) THEN
46699 HB=PECM**2+HA
46700 HC=P(N+2,5)**2+HA
46701 HD=P(IR,5)**2+HA
46702 HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/
46703 & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
46704 HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
46705 DO 1020 J=1,4
46706 P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J)
46707 P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J)
46708 1020 CONTINUE
46709 N=N+2
46710 ELSE
46711 CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
46712 RETURN
46713 ENDIF
46714
46715C...Mark collapsed system and store daughter pointers. Iterate.
46716 1030 DO 1040 I=IC1,IC2
46717 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
46718 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
46719 K(I,1)=K(I,1)+10
46720 IF(MSTU(16).NE.2) THEN
46721 K(I,4)=NSAV+1
46722 K(I,5)=NSAV+1
46723 ELSE
46724 K(I,4)=NSAV+2
46725 K(I,5)=NSAV+1+NBODY
46726 ENDIF
46727 ENDIF
46728 IF(K(I,1).EQ.41) K(I,1)=K(I,1)+10
46729 1040 CONTINUE
46730 IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 620
46731
46732C...Check flavours and invariant masses in parton systems.
46733 1050 NP=0
46734 KFN=0
46735 KQS=0
46736 NJU=0
46737 DO 1060 J=1,5
46738 DPS(J)=0D0
46739 1060 CONTINUE
46740 DO 1090 I=MAX(1,IP),N
46741 IF(K(I,1).EQ.41) NJU=NJU+1
46742 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 1090
46743 KC=PYCOMP(K(I,2))
46744 IF(KC.EQ.0) GOTO 1090
46745 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
46746 IF(KQ.EQ.0) GOTO 1090
46747 NP=NP+1
46748 IF(KQ.NE.2) THEN
46749 KFN=KFN+1
46750 KQS=KQS+KQ
46751 MSTJ(93)=1
46752 DPS(5)=DPS(5)+PYMASS(K(I,2))
46753 ENDIF
46754 DO 1070 J=1,4
46755 DPS(J)=DPS(J)+P(I,J)
46756 1070 CONTINUE
46757 IF(K(I,1).EQ.1) THEN
46758 NFERR=0
46759 IF(NJU.EQ.0.AND.NP.NE.1) THEN
46760 IF(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0) NFERR=1
46761 ELSEIF(NJU.EQ.1) THEN
46762 IF(KFN.NE.3.OR.IABS(KQS).NE.3) NFERR=1
46763 ELSEIF(NJU.EQ.2) THEN
46764 IF(KFN.NE.4.OR.KQS.NE.0) NFERR=1
46765 ELSEIF(NJU.GE.3) THEN
46766 NFERR=1
46767 ENDIF
46768 IF(NFERR.EQ.1) CALL
46769 & PYERRM(2,'(PYPREP:) unphysical flavour combination')
46770 IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
46771 & (0.9D0*PARJ(32)+DPS(5))**2) CALL PYERRM(3,
46772 & '(PYPREP:) too small mass in jet system')
46773 NP=0
46774 KFN=0
46775 KQS=0
46776 NJU=0
46777 DO 1080 J=1,5
46778 DPS(J)=0D0
46779 1080 CONTINUE
46780 ENDIF
46781 1090 CONTINUE
46782
46783 RETURN
46784 END
46785
46786C*********************************************************************
46787
46788C...PYSTRF
46789C...Handles the fragmentation of an arbitrary colour singlet
46790C...jet system according to the Lund string fragmentation model.
46791
46792 SUBROUTINE PYSTRF(IP)
46793
46794C...Double precision and integer declarations.
46795 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46796 IMPLICIT INTEGER(I-N)
46797 INTEGER PYK,PYCHGE,PYCOMP
46798C...Commonblocks.
46799 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
46800 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46801 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46802 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
46803C...Local arrays. All MOPS variables ends with MO
46804 DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
46805 &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(6),PJU(5,5),
46806 &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
46807 &INMO(9),PM2QMO(2),XTMO(2),EJSTR(2),IJUORI(2),IBARRK(2),
46808 &PBST(3,5),TJUOLD(5)
46809
46810C...Function: four-product of two vectors.
46811 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)
46812 DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
46813 &DP(I,3)*DP(J,3)
46814
46815C...Reset counters.
46816 MSTJ(91)=0
46817 NSAV=N
46818 MSTU90=MSTU(90)
46819 NP=0
46820 KQSUM=0
46821 DO 100 J=1,5
46822 DPS(J)=0D0
46823 100 CONTINUE
46824 MJU(1)=0
46825 MJU(2)=0
46826 NTRYFN=0
46827 IJUORI(1)=0
46828 IJUORI(2)=0
46829
46830C...Identify parton system.
46831 I=IP-1
46832 110 I=I+1
46833 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
46834 CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
46835 IF(MSTU(21).GE.1) RETURN
46836 ENDIF
46837 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
46838 KC=PYCOMP(K(I,2))
46839 IF(KC.EQ.0) GOTO 110
46840 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
46841 IF(KQ.EQ.0.AND.K(I,1).NE.41) GOTO 110
46842 IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
46843 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
46844 IF(MSTU(21).GE.1) RETURN
46845 ENDIF
46846
46847C...Take copy of partons to be considered. Check flavour sum.
46848 NP=NP+1
46849 DO 120 J=1,5
46850 K(N+NP,J)=K(I,J)
46851 P(N+NP,J)=P(I,J)
46852 IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
46853 120 CONTINUE
46854 DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
46855 K(N+NP,3)=I
46856 IF(KQ.NE.2) KQSUM=KQSUM+KQ
46857 IF(K(I,1).EQ.41) THEN
46858 IF(MOD(KQSUM,2).EQ.0.AND.MJU(1).EQ.0) THEN
46859 MJU(1)=N+NP
46860 IJUORI(1)=I
46861 ELSE
46862 MJU(2)=N+NP
46863 IJUORI(2)=I
46864 ENDIF
46865 ENDIF
46866 IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
46867 IF(MOD(KQSUM,3).NE.0) THEN
46868 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
46869 IF(MSTU(21).GE.1) RETURN
46870 ENDIF
46871 IF(MJU(1).GT.0.OR.MJU(2).GT.0) MSTU(29)=1
46872
46873C...Boost copied system to CM frame (for better numerical precision).
46874 IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
46875 MBST=0
46876 MSTU(33)=1
46877 CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
46878 & -DPS(3)/DPS(4))
46879 ELSE
46880 MBST=1
46881 HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
46882 DO 130 I=N+1,N+NP
46883 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
46884 IF(P(I,3).GT.0D0) THEN
46885 HHPEZ=MAX(1D-10,(P(I,4)+P(I,3))/HHBZ)
46886 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
46887 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
46888 ELSE
46889 HHPEZ=MAX(1D-10,(P(I,4)-P(I,3))*HHBZ)
46890 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
46891 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
46892 ENDIF
46893 130 CONTINUE
46894 ENDIF
46895
46896C...Search for very nearby partons that may be recombined.
46897 NTRYR=0
46898 NTRYWR=0
46899 PARU12=PARU(12)
46900 PARU13=PARU(13)
46901 MJU(3)=MJU(1)
46902 MJU(4)=MJU(2)
46903 NR=NP
46904 140 IF(NR.GE.3) THEN
46905 PDRMIN=2D0*PARU12
46906 DO 150 I=N+1,N+NR
46907 IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
46908 I1=I+1
46909 IF(I.EQ.N+NR) I1=N+1
46910 IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
46911 IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
46912 & GOTO 150
46913 IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
46914 & GOTO 150
46915 PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
46916 & P(I1,2)**2+P(I1,3)**2))
46917 PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
46918 PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP))
46919 IF(PDR.LT.PDRMIN) THEN
46920 IR=I
46921 PDRMIN=PDR
46922 ENDIF
46923 150 CONTINUE
46924
46925C...Recombine very nearby partons to avoid machine precision problems.
46926 IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
46927 DO 160 J=1,4
46928 P(N+1,J)=P(N+1,J)+P(N+NR,J)
46929 160 CONTINUE
46930 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
46931 & P(N+1,3)**2))
46932 NR=NR-1
46933 GOTO 140
46934 ELSEIF(PDRMIN.LT.PARU12) THEN
46935 DO 170 J=1,4
46936 P(IR,J)=P(IR,J)+P(IR+1,J)
46937 170 CONTINUE
46938 P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
46939 & P(IR,3)**2))
46940 IF(MJU(2).NE.0.AND.IR.GT.MJU(2)) K(IR,2)=K(IR+1,2)
46941 DO 190 I=IR+1,N+NR-1
46942 K(I,1)=K(I+1,1)
46943 K(I,2)=K(I+1,2)
46944 DO 180 J=1,5
46945 P(I,J)=P(I+1,J)
46946 180 CONTINUE
46947 190 CONTINUE
46948 IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
46949 NR=NR-1
46950 IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
46951 IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
46952 GOTO 140
46953 ENDIF
46954 ENDIF
46955 NTRYR=NTRYR+1
46956
46957C...Reset particle counter. Skip ahead if no junctions are present;
46958C...this is usually the case!
46959 NRS=MAX(5*NR+11,NP)
46960 NTRY=0
46961 200 NTRY=NTRY+1
46962 IF(NTRY.GT.100.AND.NTRYR.LE.8) THEN
46963 PARU12=4D0*PARU12
46964 PARU13=2D0*PARU13
46965 GOTO 140
46966 ELSEIF(NTRY.GT.100) THEN
46967 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
46968 IF(MSTU(21).GE.1) RETURN
46969 ENDIF
46970 I=N+NRS
46971 MSTU(90)=MSTU90
46972 IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 640
46973 IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
46974 & ' junction strings not handled by MSTJ(12)>3 options')
46975 DO 630 JT=1,2
46976 NJS(JT)=0
46977 IF(MJU(JT).EQ.0) GOTO 630
46978 JS=3-2*JT
46979
46980C++SKANDS
46981C...Find and sum up momentum on three sides of junction.
46982C...Begin with previous boost = zero.
46983 IJRFIT=0
46984 DO 210 IX=1,3
46985 TJUOLD(IX)=0D0
46986 210 CONTINUE
46987 TJUOLD(4)=1D0
46988 220 IU=0
46989C...Beginning and end of string system in event record.
46990 I1BEG=N+1+(JT-1)*(NR-1)
46991 I1END=N+NR+(JT-1)*(1-NR)
46992C...Look for junction string piece end points
46993 DO 230 I1=I1BEG,I1END,JS
46994 IF(K(I1,2).NE.21.AND.IU.LE.5.AND.IJRFIT.EQ.0) THEN
46995C...Store junction string piece end points.
46996C 1-junction systems 2-junction systems
46997C IU : 1 2 3 4 1 2 3 4 5 6
46998C IJU(IU): q-g-g-q-g-g-j-g-q q-g-g-q-g-j-g-g-j-g-q-g-g-q
46999 IU=IU+1
47000 IJU(IU)=I1
47001 ENDIF
47002C...Sum over momenta, from junction outwards.
47003 230 CONTINUE
47004 DO 280 IU=1,3
47005 PWT=0D0
47006C...Initialize junction drag and string piece 4-vectors.
47007 DO 240 J=1,5
47008 PBST(IU,J)=0D0
47009 PJU(IU,J)=0D0
47010 240 CONTINUE
47011C...First two branches. Inwards out means opposite direction to JS.
47012C...(JS is 1 for JT=1, -1 for JT=2)
47013 IF (IU.LT.3) THEN
47014 I1A=IJU(IU+1)-JS
47015 I1B=IJU(IU)
47016 IDIR=-JS
47017C...Last branch (gq or gjgqgq). Direction now reversed.
47018 ELSE
47019 I1A=IJU(IU)+JS
47020 I1B=I1END
47021 IDIR=JS
47022 ENDIF
47023 DO 270 I1=I1A,I1B,IDIR
47024C...Sum up momentum directions with exponential suppression
47025C...for use in finding junction rest frame below.
47026 IF (K(I1,2).EQ.88) THEN
47027C...gjgqgq type system encountered. Use current PWT as start
47028C...for both strings.
47029 PWTOLD=PWT
47030 ELSE
47031 IF (I1.EQ.IJU(5)+IDIR) PWT=PWTOLD
47032C...Sum up string piece (boosted) 4-momenta.
47033 DO 250 J=1,4
47034 PJU(IU,J)=PJU(IU,J)+P(I1,J)
47035 250 CONTINUE
47036C...Compute "junction drag" vectors from (boosted) 4-momenta (initial
47037C...boost is zero, see above). Skip parton if suppression factor large.
47038 IF (PWT.GT.10D0) GOTO 270
47039C...Compute momentum in current frame:
47040 TDP=TJUOLD(1)*P(I1,1)+TJUOLD(2)*P(I1,2)+TJUOLD(3)*P(I1,3)
47041 BFC=TDP/(1D0+TJUOLD(4))+P(I1,4)
47042 DO 260 J=1,3
47043 PTMP=P(I1,J)+TJUOLD(J)*BFC
47044 PBST(IU,J)=PBST(IU,J)+PTMP*EXP(-PWT)
47045 260 CONTINUE
47046C...Boosted energy
47047 PTMP=TJUOLD(4)*P(I1,4)+TDP
47048 PBST(IU,4)=PBST(IU,J)+PTMP*EXP(-PWT)
47049 PWT=PWT+PTMP/PARJ(48)
47050 ENDIF
47051 270 CONTINUE
47052C...Put |p| rather than m in 5th slot.
47053 PBST(IU,5)=SQRT(PBST(IU,1)**2+PBST(IU,2)**2+PBST(IU,3)**2)
47054 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
47055 280 CONTINUE
47056
47057C...Calculate boost from present frame to next JRF candidate.
47058 IJRFIT=IJRFIT+1
47059 CALL PYJURF(PBST,TJU)
47060
47061C...Combine new boost (TJU) with old boost (TJUOLD)
47062 TMP=TJU(1)*TJUOLD(1)+TJU(2)*TJUOLD(2)+TJU(3)*TJUOLD(3)
47063 DO 290 IX=1,3
47064 TJUOLD(IX)=TJU(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+TJU(4))
47065 290 CONTINUE
47066 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)**2)
47067
47068C...If last boost small, accept JRF, else iterate.
47069C...Also prevent possibility of infinite loop.
47070 IF (ABS((TJU(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
47071 & IJRFIT.LT.MSTJ(18)) THEN
47072 GOTO 220
47073 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
47074 CALL PYERRM(1,'(PYSTRF:) failed to converge on JRF')
47075 ENDIF
47076
47077C...Now store total boost in TJU and change perception.
47078C...TJUOLD = boost vector from CM of string syst -> JRF. Henceforth,
47079C...TJU = junction motion vector in string CM, so the sign changes.
47080 DO 300 J=1,3
47081 TJU(J)=-TJUOLD(J)
47082 300 CONTINUE
47083 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
47084
47085C--SKANDS
47086
47087C...Calculate string piece energies in junction rest frame.
47088 DO 310 IU=1,3
47089 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
47090 & TJU(3)*PJU(IU,3)
47091 PBST(IU,5)=TJU(4)*PBST(IU,4)-TJU(1)*PBST(IU,1)-
47092 & TJU(2)*PBST(IU,2)-TJU(3)*PBST(IU,3)
47093 310 CONTINUE
47094
47095C...Start preparing for fragmentation of two strings from junction.
47096 ISTA=I
47097 NTRYER=0
47098 320 NTRYER=NTRYER+1
47099 I=ISTA
47100 DO 610 IU=1,2
47101 NS=IABS(IJU(IU+1)-IJU(IU))
47102
47103C...Junction strings: find longitudinal string directions.
47104 DO 350 IS=1,NS
47105 IS1=IJU(IU)+JS*(IS-1)
47106 IS2=IJU(IU)+JS*IS
47107 DO 330 J=1,5
47108 DP(1,J)=0.5D0*P(IS1,J)
47109 IF(IS.EQ.1) DP(1,J)=P(IS1,J)
47110 DP(2,J)=0.5D0*P(IS2,J)
47111 IF(IS.EQ.NS) DP(2,J)=(-PBST(IU,J)+2D0*PBST(IU,5)*TJU(J))*
47112 & (PJU(IU,5)/PBST(IU,5))
47113 330 CONTINUE
47114 IF(IS.EQ.NS) DP(2,5)=SQRT(MAX(0D0,PJU(IU,4)**2-
47115 & PJU(IU,1)**2-PJU(IU,2)**2-PJU(IU,3)**2))
47116 DP(3,5)=DFOUR(1,1)
47117 DP(4,5)=DFOUR(2,2)
47118 DHKC=DFOUR(1,2)
47119 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
47120 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
47121 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
47122 DP(3,5)=0D0
47123 DP(4,5)=0D0
47124 DHKC=DFOUR(1,2)
47125 ENDIF
47126 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
47127 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
47128 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
47129 IN1=N+NR+4*IS-3
47130 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
47131 DO 340 J=1,4
47132 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
47133 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
47134 340 CONTINUE
47135 350 CONTINUE
47136
47137C...Junction strings: initialize flavour, momentum and starting pos.
47138 ISAV=I
47139 MSTU91=MSTU(90)
47140 360 NTRY=NTRY+1
47141 IF(NTRY.GT.100.AND.NTRYR.LE.8) THEN
47142 PARU12=4D0*PARU12
47143 PARU13=2D0*PARU13
47144 GOTO 140
47145 ELSEIF(NTRY.GT.100) THEN
47146 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
47147 IF(MSTU(21).GE.1) RETURN
47148 ENDIF
47149 I=ISAV
47150 MSTU(90)=MSTU91
47151 IRANKJ=0
47152 IE(1)=K(N+1+(JT/2)*(NP-1),3)
47153 IN(4)=N+NR+1
47154 IN(5)=IN(4)+1
47155 IN(6)=N+NR+4*NS+1
47156 DO 380 JQ=1,2
47157 DO 370 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
47158 P(IN1,1)=2-JQ
47159 P(IN1,2)=JQ-1
47160 P(IN1,3)=1D0
47161 370 CONTINUE
47162 380 CONTINUE
47163 KFL(1)=K(IJU(IU),2)
47164 PX(1)=0D0
47165 PY(1)=0D0
47166 GAM(1)=0D0
47167 DO 390 J=1,5
47168 PJU(IU+3,J)=0D0
47169 390 CONTINUE
47170
47171C...Junction strings: find initial transverse directions.
47172 DO 400 J=1,4
47173 DP(1,J)=P(IN(4),J)
47174 DP(2,J)=P(IN(4)+1,J)
47175 DP(3,J)=0D0
47176 DP(4,J)=0D0
47177 400 CONTINUE
47178 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
47179 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
47180 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
47181 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
47182 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
47183 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
47184 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
47185 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
47186 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
47187 DHC12=DFOUR(1,2)
47188 DHCX1=DFOUR(3,1)/DHC12
47189 DHCX2=DFOUR(3,2)/DHC12
47190 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
47191 DHCY1=DFOUR(4,1)/DHC12
47192 DHCY2=DFOUR(4,2)/DHC12
47193 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
47194 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
47195 DO 410 J=1,4
47196 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
47197 P(IN(6),J)=DP(3,J)
47198 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
47199 & DHCYX*DP(3,J))
47200 410 CONTINUE
47201
47202C...Junction strings: produce new particle, origin.
47203 420 I=I+1
47204 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
47205 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
47206 IF(MSTU(21).GE.1) RETURN
47207 ENDIF
47208 IRANKJ=IRANKJ+1
47209 K(I,1)=1
47210 K(I,3)=IE(1)
47211 K(I,4)=0
47212 K(I,5)=0
47213
47214C...Junction strings: generate flavour, hadron, pT, z and Gamma.
47215 430 CALL PYKFDI(KFL(1),0,KFL(3),K(I,2))
47216 IF(K(I,2).EQ.0) GOTO 360
47217 IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
47218 & IABS(KFL(3)).GT.10) THEN
47219 IF(PYR(0).GT.PARJ(19)) GOTO 430
47220 ENDIF
47221 P(I,5)=PYMASS(K(I,2))
47222 CALL PYPTDI(KFL(1),PX(3),PY(3))
47223 PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
47224 CALL PYZDIS(KFL(1),KFL(3),PR(1),Z)
47225 IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
47226 & MSTU(90).LT.8) THEN
47227 MSTU(90)=MSTU(90)+1
47228 MSTU(90+MSTU(90))=I
47229 PARU(90+MSTU(90))=Z
47230 ENDIF
47231 GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z)
47232 DO 440 J=1,3
47233 IN(J)=IN(3+J)
47234 440 CONTINUE
47235
47236C...Junction strings: stepping within 'low' string region.
47237 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
47238 & P(IN(1),5)**2.GE.PR(1)) THEN
47239 P(IN(1)+2,4)=Z*P(IN(1)+2,3)
47240 P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
47241 DO 450 J=1,4
47242 P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
47243 450 CONTINUE
47244 GOTO 550
47245C...Has used up energy of junction string, i.e. no more hadrons in it.
47246 ELSEIF(IN(1)+1.EQ.IN(2).AND.IN(1).EQ.N+NR+4*NS-3) THEN
47247 DO 460 J=1,5
47248 P(I,J)=0D0
47249 460 CONTINUE
47250 GOTO 590
47251C...Stepping from 'low' string region
47252 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
47253 P(IN(2)+2,4)=P(IN(2)+2,3)
47254 P(IN(2)+2,1)=1D0
47255 IN(2)=IN(2)+4
47256 IF(IN(2).GT.N+NR+4*NS) GOTO 360
47257 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
47258 P(IN(1)+2,4)=P(IN(1)+2,3)
47259 P(IN(1)+2,1)=0D0
47260 IN(1)=IN(1)+4
47261 ENDIF
47262 ENDIF
47263
47264C...Junction strings: find new transverse directions.
47265 470 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
47266 & IN(1).GT.IN(2)) GOTO 360
47267 IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
47268 DO 480 J=1,4
47269 DP(1,J)=P(IN(1),J)
47270 DP(2,J)=P(IN(2),J)
47271 DP(3,J)=0D0
47272 DP(4,J)=0D0
47273 480 CONTINUE
47274 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
47275 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
47276 DHC12=DFOUR(1,2)
47277 IF(DHC12.LE.1D-2) THEN
47278 P(IN(1)+2,4)=P(IN(1)+2,3)
47279 P(IN(1)+2,1)=0D0
47280 IN(1)=IN(1)+4
47281 GOTO 470
47282 ENDIF
47283 IN(3)=N+NR+4*NS+5
47284 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
47285 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
47286 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
47287 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
47288 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
47289 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
47290 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
47291 DHCX1=DFOUR(3,1)/DHC12
47292 DHCX2=DFOUR(3,2)/DHC12
47293 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
47294 DHCY1=DFOUR(4,1)/DHC12
47295 DHCY2=DFOUR(4,2)/DHC12
47296 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
47297 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
47298 DO 490 J=1,4
47299 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
47300 P(IN(3),J)=DP(3,J)
47301 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
47302 & DHCYX*DP(3,J))
47303 490 CONTINUE
47304C...Express pT with respect to new axes, if sensible.
47305 PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
47306 PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
47307 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
47308 PX(3)=PXP
47309 PY(3)=PYP
47310 ENDIF
47311 ENDIF
47312
47313C...Junction strings: sum up known four-momentum, coefficients for m2.
47314 DO 520 J=1,4
47315 DHG(J)=0D0
47316 P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
47317 & PY(3)*P(IN(3)+1,J)
47318 DO 500 IN1=IN(4),IN(1)-4,4
47319 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
47320 500 CONTINUE
47321 DO 510 IN2=IN(5),IN(2)-4,4
47322 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
47323 510 CONTINUE
47324 520 CONTINUE
47325 DHM(1)=FOUR(I,I)
47326 DHM(2)=2D0*FOUR(I,IN(1))
47327 DHM(3)=2D0*FOUR(I,IN(2))
47328 DHM(4)=2D0*FOUR(IN(1),IN(2))
47329
47330C...Junction strings: find coefficients for Gamma expression.
47331 DO 540 IN2=IN(1)+1,IN(2),4
47332 DO 530 IN1=IN(1),IN2-1,4
47333 DHC=2D0*FOUR(IN1,IN2)
47334 DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
47335 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
47336 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
47337 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
47338 530 CONTINUE
47339 540 CONTINUE
47340
47341C...Junction strings: solve (m2, Gamma) equation system for energies.
47342 DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
47343 IF(ABS(DHS1).LT.1D-4) GOTO 360
47344 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
47345 & (P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
47346 DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
47347 P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
47348 & ABS(DHS1)-DHS2/DHS1)
47349 IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 360
47350 P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
47351 & (DHM(2)+DHM(4)*P(IN(2)+2,4))
47352
47353C...Junction strings: step to new region if necessary.
47354 IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
47355 P(IN(2)+2,4)=P(IN(2)+2,3)
47356 P(IN(2)+2,1)=1D0
47357 IN(2)=IN(2)+4
47358 IF(IN(2).GT.N+NR+4*NS) GOTO 360
47359 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
47360 P(IN(1)+2,4)=P(IN(1)+2,3)
47361 P(IN(1)+2,1)=0D0
47362 IN(1)=IN(1)+4
47363 ENDIF
47364 GOTO 470
47365 ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
47366 P(IN(1)+2,4)=P(IN(1)+2,3)
47367 P(IN(1)+2,1)=0D0
47368 IN(1)=IN(1)+4
47369 GOTO 470
47370 ENDIF
47371
47372C...Junction strings: particle four-momentum, remainder, loop back.
47373 550 DO 560 J=1,4
47374 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+
47375 & P(IN(2)+2,4)*P(IN(2),J)
47376 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
47377 560 CONTINUE
47378 IF(P(I,4).LT.P(I,5)) GOTO 360
47379 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
47380 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
47381 IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
47382 KFL(1)=-KFL(3)
47383 PX(1)=-PX(3)
47384 PY(1)=-PY(3)
47385 GAM(1)=GAM(3)
47386 IF(IN(3).NE.IN(6)) THEN
47387 DO 570 J=1,4
47388 P(IN(6),J)=P(IN(3),J)
47389 P(IN(6)+1,J)=P(IN(3)+1,J)
47390 570 CONTINUE
47391 ENDIF
47392 DO 580 JQ=1,2
47393 IN(3+JQ)=IN(JQ)
47394 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
47395 P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
47396 580 CONTINUE
47397 GOTO 420
47398 ENDIF
47399
47400C...Junction strings: save quantities left after each string.
47401 IF(IABS(KFL(1)).GT.10) GOTO 360
47402 590 I=I-1
47403 KFJH(IU)=KFL(1)
47404 DO 600 J=1,4
47405 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
47406 600 CONTINUE
47407
47408C...Junction strings: loopback if much unused energy in both strings.
47409 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
47410 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
47411 EJSTR(IU)=PJU(IU,5)-PJU(IU+3,5)
47412 610 CONTINUE
47413 IF((MIN(EJSTR(1),EJSTR(2)).GT.PARJ(49).OR.
47414 & EJSTR(1).GT.PARJ(49)+PYR(0)*PARJ(50).OR.
47415 & EJSTR(2).GT.PARJ(49)+PYR(0)*PARJ(50))
47416 & .AND.NTRYER.LT.10) GOTO 320
47417
47418C...Junction strings: put together to new effective string endpoint.
47419 NJS(JT)=I-ISTA
47420 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
47421 IF(KFJH(1).EQ.KFJH(2)) KFLS=3
47422 KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),IABS(KFJH(2)))+
47423 & 100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+KFLS,KFJH(1))
47424 DO 620 J=1,4
47425 PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
47426 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
47427 620 CONTINUE
47428 PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
47429 & PJS(JT,3)**2))
47430 PJS(JT+2,5)=0D0
47431 630 CONTINUE
47432
47433C...Open versus closed strings. Choose breakup region for latter.
47434 640 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
47435 NS=MJU(2)-MJU(1)
47436 NB=MJU(1)-N
47437 ELSEIF(MJU(1).NE.0) THEN
47438 NS=N+NR-MJU(1)
47439 NB=MJU(1)-N
47440 ELSEIF(MJU(2).NE.0) THEN
47441 NS=MJU(2)-N
47442 NB=1
47443 ELSEIF(IABS(K(N+1,2)).NE.21) THEN
47444 NS=NR-1
47445 NB=1
47446 ELSE
47447 NS=NR+1
47448 W2SUM=0D0
47449 DO 650 IS=1,NR
47450 P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR))
47451 W2SUM=W2SUM+P(N+NR+IS,1)
47452 650 CONTINUE
47453 W2RAN=PYR(0)*W2SUM
47454 NB=0
47455 660 NB=NB+1
47456 W2SUM=W2SUM-P(N+NR+NB,1)
47457 IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 660
47458 ENDIF
47459
47460C...Find longitudinal string directions (i.e. lightlike four-vectors).
47461 DO 690 IS=1,NS
47462 IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
47463 IS2=N+IS+NB-NR*((IS+NB-1)/NR)
47464 DO 670 J=1,5
47465 DP(1,J)=P(IS1,J)
47466 IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J)
47467 IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
47468 DP(2,J)=P(IS2,J)
47469 IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J)
47470 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
47471 670 CONTINUE
47472 IF(IS1.EQ.MJU(1)) DP(1,5)=SQRT(MAX(0D0,DP(1,4)**2-DP(1,1)**2-
47473 & DP(1,2)**2-DP(1,3)**2))
47474 IF(IS2.EQ.MJU(2)) DP(2,5)=SQRT(MAX(0D0,DP(2,4)**2-DP(2,1)**2-
47475 & DP(2,2)**2-DP(2,3)**2))
47476 DP(3,5)=DFOUR(1,1)
47477 DP(4,5)=DFOUR(2,2)
47478 DHKC=DFOUR(1,2)
47479 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) GOTO 200
47480 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
47481 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
47482 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
47483 IN1=N+NR+4*IS-3
47484 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
47485 DO 680 J=1,4
47486 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
47487 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
47488 680 CONTINUE
47489 690 CONTINUE
47490
47491C...Begin initialization: sum up energy, set starting position.
47492 ISAV=I
47493 MSTU91=MSTU(90)
47494 700 NTRY=NTRY+1
47495 IF(NTRY.GT.100.AND.NTRYR.LE.8) THEN
47496 PARU12=4D0*PARU12
47497 PARU13=2D0*PARU13
47498 GOTO 140
47499 ELSEIF(NTRY.GT.100) THEN
47500 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
47501 IF(MSTU(21).GE.1) RETURN
47502 ENDIF
47503 I=ISAV
47504 MSTU(90)=MSTU91
47505 DO 720 J=1,4
47506 P(N+NRS,J)=0D0
47507 DO 710 IS=1,NR
47508 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
47509 710 CONTINUE
47510 720 CONTINUE
47511 DO 740 JT=1,2
47512 IRANK(JT)=0
47513 IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
47514 IF(NS.GT.NR) IRANK(JT)=1
47515 IBARRK(JT)=0
47516 IE(JT)=K(N+1+(JT/2)*(NP-1),3)
47517 IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
47518 IN(3*JT+2)=IN(3*JT+1)+1
47519 IN(3*JT+3)=N+NR+4*NS+2*JT-1
47520 DO 730 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
47521 P(IN1,1)=2-JT
47522 P(IN1,2)=JT-1
47523 P(IN1,3)=1D0
47524 730 CONTINUE
47525 740 CONTINUE
47526
47527C.. MOPS variables and switches
47528 NRVMO=0
47529 XBMO=1D0
47530 MSTU(121)=0
47531 MSTU(122)=0
47532
47533C...Initialize flavour and pT variables for open string.
47534 IF(NS.LT.NR) THEN
47535 PX(1)=0D0
47536 PY(1)=0D0
47537 IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1))
47538 PX(2)=-PX(1)
47539 PY(2)=-PY(1)
47540 DO 750 JT=1,2
47541 KFL(JT)=K(IE(JT),2)
47542 IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
47543 IF(MJU(JT).NE.0.AND.IABS(KFL(JT)).GT.1000) IBARRK(JT)=1
47544 MSTJ(93)=1
47545 PMQ(JT)=PYMASS(KFL(JT))
47546 GAM(JT)=0D0
47547 750 CONTINUE
47548
47549C...Closed string: random initial breakup flavour, pT and vertex.
47550 ELSE
47551 KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
47552 IBMO=0
47553 760 CALL PYKFDI(KFL(3),0,KFL(1),KDUMP)
47554C.. Closed string: first vertex diq attempt => enforced second
47555C.. vertex diq
47556 IF(IABS(KFL(1)).GT.10)THEN
47557 IBMO=1
47558 MSTU(121)=0
47559 GOTO 760
47560 ENDIF
47561 IF(IBMO.EQ.1) MSTU(121)=-1
47562 KFL(2)=-KFL(1)
47563 CALL PYPTDI(KFL(1),PX(1),PY(1))
47564 PX(2)=-PX(1)
47565 PY(2)=-PY(1)
47566 PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2)
47567 770 CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
47568 ZR=PR3/(Z*P(N+NR+1,5)**2)
47569 IF(ZR.GE.1D0) GOTO 770
47570 DO 780 JT=1,2
47571 MSTJ(93)=1
47572 PMQ(JT)=PYMASS(KFL(JT))
47573 GAM(JT)=PR3*(1D0-Z)/Z
47574 IN1=N+NR+3+4*(JT/2)*(NS-1)
47575 P(IN1,JT)=1D0-Z
47576 P(IN1,3-JT)=JT-1
47577 P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z
47578 P(IN1+1,JT)=ZR
47579 P(IN1+1,3-JT)=2-JT
47580 P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR
47581 780 CONTINUE
47582 ENDIF
47583C.. MOPS variables
47584 DO 790 JT=1,2
47585 XTMO(JT)=1D0
47586 PM2QMO(JT)=PMQ(JT)**2
47587 IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
47588 790 CONTINUE
47589
47590C...Find initial transverse directions (i.e. spacelike four-vectors).
47591 DO 830 JT=1,2
47592 IF(JT.EQ.1.OR.NS.EQ.NR-1.OR.MJU(1)+MJU(2).NE.0) THEN
47593 IN1=IN(3*JT+1)
47594 IN3=IN(3*JT+3)
47595 DO 800 J=1,4
47596 DP(1,J)=P(IN1,J)
47597 DP(2,J)=P(IN1+1,J)
47598 DP(3,J)=0D0
47599 DP(4,J)=0D0
47600 800 CONTINUE
47601 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
47602 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
47603 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
47604 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
47605 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
47606 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
47607 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
47608 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
47609 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
47610 DHC12=DFOUR(1,2)
47611 DHCX1=DFOUR(3,1)/DHC12
47612 DHCX2=DFOUR(3,2)/DHC12
47613 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
47614 DHCY1=DFOUR(4,1)/DHC12
47615 DHCY2=DFOUR(4,2)/DHC12
47616 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
47617 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
47618 DO 810 J=1,4
47619 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
47620 P(IN3,J)=DP(3,J)
47621 P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
47622 & DHCYX*DP(3,J))
47623 810 CONTINUE
47624 ELSE
47625 DO 820 J=1,4
47626 P(IN3+2,J)=P(IN3,J)
47627 P(IN3+3,J)=P(IN3+1,J)
47628 820 CONTINUE
47629 ENDIF
47630 830 CONTINUE
47631
47632C...Remove energy used up in junction string fragmentation.
47633 IF(MJU(1)+MJU(2).GT.0) THEN
47634 DO 850 JT=1,2
47635 IF(NJS(JT).EQ.0) GOTO 850
47636 DO 840 J=1,4
47637 P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
47638 840 CONTINUE
47639 850 CONTINUE
47640 PARJST=PARJ(33)
47641 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
47642 WMIN=PARJST+PMQ(1)+PMQ(2)
47643 WREM2=FOUR(N+NRS,N+NRS)
47644 IF(P(N+NRS,4).LT.0D0.OR.WREM2.LT.WMIN**2) THEN
47645 NTRYWR=NTRYWR+1
47646 IF(MOD(NTRYWR,20).NE.0) NTRYR=NTRYR-1
47647 GOTO 140
47648 ENDIF
47649 ENDIF
47650
47651C...Produce new particle: side, origin.
47652 860 I=I+1
47653 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
47654 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
47655 IF(MSTU(21).GE.1) RETURN
47656 ENDIF
47657C.. New side priority for popcorn systems
47658 IF(MSTU(121).LE.0)THEN
47659 JT=1.5D0+PYR(0)
47660 IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
47661 IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
47662 ENDIF
47663 JR=3-JT
47664 JS=3-2*JT
47665 IRANK(JT)=IRANK(JT)+1
47666 K(I,1)=1
47667 K(I,4)=0
47668 K(I,5)=0
47669
47670C...Generate flavour, hadron and pT.
47671 870 K(I,3)=IE(JT)
47672 CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
47673 IF(K(I,2).EQ.0) GOTO 700
47674 MU90MO=MSTU(90)
47675 IF(MSTU(121).EQ.-1) GOTO 900
47676 IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
47677 &IABS(KFL(3)).GT.10) THEN
47678 IF(PYR(0).GT.PARJ(19)) GOTO 870
47679 ENDIF
47680 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
47681 &K(I,3)=IJUORI(JT)
47682 P(I,5)=PYMASS(K(I,2))
47683 CALL PYPTDI(KFL(JT),PX(3),PY(3))
47684 PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
47685
47686C...Final hadrons for small invariant mass.
47687 MSTJ(93)=1
47688 PMQ(3)=PYMASS(KFL(3))
47689 PARJST=PARJ(33)
47690 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
47691 WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
47692 IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
47693 &WMIN-0.5D0*PARJ(36)*PMQ(3)
47694 WREM2=FOUR(N+NRS,N+NRS)
47695 IF(WREM2.LT.0.10D0) GOTO 700
47696 IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)),
47697 &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1070
47698
47699C...Choose z, which gives Gamma. Shift z for heavy flavours.
47700 CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z)
47701 IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
47702 &MSTU(90).LT.8) THEN
47703 MSTU(90)=MSTU(90)+1
47704 MSTU(90+MSTU(90))=I
47705 PARU(90+MSTU(90))=Z
47706 ENDIF
47707 KFL1A=IABS(KFL(1))
47708 KFL2A=IABS(KFL(2))
47709 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
47710 &MOD(KFL2A/1000,10)).GE.4) THEN
47711 PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
47712 PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2)))
47713 Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2)
47714 PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
47715 IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1070
47716 ENDIF
47717 GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z)
47718
47719C.. MOPS baryon model modification
47720 XTMO3=(1D0-Z)*XTMO(JT)
47721 IF(IABS(KFL(3)).LE.10) NRVMO=0
47722 IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN
47723 GTSTMO=1D0
47724 PTSTMO=1D0
47725 RTSTMO=PYR(0)
47726 IF(IABS(KFL(JT)).LE.10)THEN
47727 XBMO=MIN(XTMO3,1D0-(2D-10))
47728 GBMO=GAM(3)
47729 PMMO=0D0
47730 PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT)
47731 GTSTMO=1D0-PARF(192)**PGMO
47732 ELSE
47733 IF(IRANK(JT).EQ.1) THEN
47734 GBMO=GAM(JT)
47735 PMMO=0D0
47736 XBMO=1D0
47737 ENDIF
47738 IF(XBMO.LT.1D0-(1D-10))THEN
47739 PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3)
47740 GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO)
47741 PGMO=PGNMO
47742 ENDIF
47743 IF(MSTJ(12).GE.5)THEN
47744 PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO))
47745 PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3)
47746 PTSTMO=EXP((PMMO-PMNMO)*PARF(193))
47747 PMMO=PMNMO
47748 ENDIF
47749 ENDIF
47750
47751C.. MOPS Accepting popcorn system hadron.
47752 IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN
47753 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN
47754 NRVMO=I-N-NR
47755 IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN
47756 CALL PYERRM(11,
47757 & '(PYSTRF:) no more memory left in PYJETS')
47758 IF(MSTU(21).GE.1) RETURN
47759 ENDIF
47760 IMO=I
47761 KFLMO=KFL(JT)
47762 PMQMO=PMQ(JT)
47763 PXMO=PX(JT)
47764 PYMO=PY(JT)
47765 GAMMO=GAM(JT)
47766 IRMO=IRANK(JT)
47767 XMO=XTMO(JT)
47768 DO 890 J=1,9
47769 IF(J.LE.5) THEN
47770 DO 880 LINE=1,I-N-NR
47771 P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J)
47772 K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J)
47773 880 CONTINUE
47774 ENDIF
47775 INMO(J)=IN(J)
47776 890 CONTINUE
47777 ENDIF
47778 ELSE
47779C..Reject popcorn system, flag=-1 if enforcing new one
47780 MSTU(121)=-1
47781 IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2
47782 ENDIF
47783 ENDIF
47784
47785
47786C..Lift restoring string outside MOPS block
47787 900 IF(MSTU(121).LT.0) THEN
47788 IF(MSTU(121).EQ.-2) MSTU(121)=0
47789 MSTU(90)=MU90MO
47790 NRVMO=0
47791 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 870
47792 I=IMO
47793 KFL(JT)=KFLMO
47794 PMQ(JT)=PMQMO
47795 PX(JT)=PXMO
47796 PY(JT)=PYMO
47797 GAM(JT)=GAMMO
47798 IRANK(JT)=IRMO
47799 XTMO(JT)=XMO
47800 DO 920 J=1,9
47801 IF(J.LE.5) THEN
47802 DO 910 LINE=1,I-N-NR
47803 P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J)
47804 K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J)
47805 910 CONTINUE
47806 ENDIF
47807 IN(J)=INMO(J)
47808 920 CONTINUE
47809 GOTO 870
47810 ENDIF
47811 XTMO(JT)=XTMO3
47812C.. MOPS end of modification
47813
47814 DO 930 J=1,3
47815 IN(J)=IN(3*JT+J)
47816 930 CONTINUE
47817
47818C...Stepping within or from 'low' string region easy.
47819 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
47820 &P(IN(1),5)**2.GE.PR(JT)) THEN
47821 P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
47822 P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
47823 DO 940 J=1,4
47824 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
47825 940 CONTINUE
47826 GOTO 1030
47827 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
47828 P(IN(JR)+2,4)=P(IN(JR)+2,3)
47829 P(IN(JR)+2,JT)=1D0
47830 IN(JR)=IN(JR)+4*JS
47831 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 700
47832 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
47833 P(IN(JT)+2,4)=P(IN(JT)+2,3)
47834 P(IN(JT)+2,JT)=0D0
47835 IN(JT)=IN(JT)+4*JS
47836 ENDIF
47837 ENDIF
47838
47839C...Find new transverse directions (i.e. spacelike string vectors).
47840 950 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
47841 &IN(1).GT.IN(2)) GOTO 700
47842 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
47843 DO 960 J=1,4
47844 DP(1,J)=P(IN(1),J)
47845 DP(2,J)=P(IN(2),J)
47846 DP(3,J)=0D0
47847 DP(4,J)=0D0
47848 960 CONTINUE
47849 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
47850 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
47851 DHC12=DFOUR(1,2)
47852 IF(DHC12.LE.1D-2) THEN
47853 P(IN(JT)+2,4)=P(IN(JT)+2,3)
47854 P(IN(JT)+2,JT)=0D0
47855 IN(JT)=IN(JT)+4*JS
47856 GOTO 950
47857 ENDIF
47858 IN(3)=N+NR+4*NS+5
47859 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
47860 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
47861 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
47862 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
47863 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
47864 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
47865 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
47866 DHCX1=DFOUR(3,1)/DHC12
47867 DHCX2=DFOUR(3,2)/DHC12
47868 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
47869 DHCY1=DFOUR(4,1)/DHC12
47870 DHCY2=DFOUR(4,2)/DHC12
47871 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
47872 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
47873 DO 970 J=1,4
47874 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
47875 P(IN(3),J)=DP(3,J)
47876 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
47877 & DHCYX*DP(3,J))
47878 970 CONTINUE
47879C...Express pT with respect to new axes, if sensible.
47880 PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
47881 & FOUR(IN(3*JT+3)+1,IN(3)))
47882 PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
47883 & FOUR(IN(3*JT+3)+1,IN(3)+1))
47884 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
47885 PX(3)=PXP
47886 PY(3)=PYP
47887 ENDIF
47888 ENDIF
47889
47890C...Sum up known four-momentum. Gives coefficients for m2 expression.
47891 DO 1000 J=1,4
47892 DHG(J)=0D0
47893 P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
47894 & PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
47895 DO 980 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
47896 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
47897 980 CONTINUE
47898 DO 990 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
47899 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
47900 990 CONTINUE
47901 1000 CONTINUE
47902 DHM(1)=FOUR(I,I)
47903 DHM(2)=2D0*FOUR(I,IN(1))
47904 DHM(3)=2D0*FOUR(I,IN(2))
47905 DHM(4)=2D0*FOUR(IN(1),IN(2))
47906
47907C...Find coefficients for Gamma expression.
47908 DO 1020 IN2=IN(1)+1,IN(2),4
47909 DO 1010 IN1=IN(1),IN2-1,4
47910 DHC=2D0*FOUR(IN1,IN2)
47911 DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
47912 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
47913 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
47914 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
47915 1010 CONTINUE
47916 1020 CONTINUE
47917
47918C...Solve (m2, Gamma) equation system for energies taken.
47919 DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
47920 IF(ABS(DHS1).LT.1D-4) GOTO 700
47921 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
47922 &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
47923 DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
47924 P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
47925 &ABS(DHS1)-DHS2/DHS1)
47926 IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 700
47927 P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
47928 &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
47929
47930C...Step to new region if necessary.
47931 IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
47932 P(IN(JR)+2,4)=P(IN(JR)+2,3)
47933 P(IN(JR)+2,JT)=1D0
47934 IN(JR)=IN(JR)+4*JS
47935 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 700
47936 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
47937 P(IN(JT)+2,4)=P(IN(JT)+2,3)
47938 P(IN(JT)+2,JT)=0D0
47939 IN(JT)=IN(JT)+4*JS
47940 ENDIF
47941 GOTO 950
47942 ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
47943 P(IN(JT)+2,4)=P(IN(JT)+2,3)
47944 P(IN(JT)+2,JT)=0D0
47945 IN(JT)=IN(JT)+4*JS
47946 GOTO 950
47947 ENDIF
47948
47949C...Four-momentum of particle. Remaining quantities. Loop back.
47950 1030 DO 1040 J=1,4
47951 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
47952 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
47953 1040 CONTINUE
47954 IF(P(I,4).LT.P(I,5)) GOTO 700
47955 KFL(JT)=-KFL(3)
47956 PMQ(JT)=PMQ(3)
47957 PX(JT)=-PX(3)
47958 PY(JT)=-PY(3)
47959 GAM(JT)=GAM(3)
47960 IF(IN(3).NE.IN(3*JT+3)) THEN
47961 DO 1050 J=1,4
47962 P(IN(3*JT+3),J)=P(IN(3),J)
47963 P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
47964 1050 CONTINUE
47965 ENDIF
47966 DO 1060 JQ=1,2
47967 IN(3*JT+JQ)=IN(JQ)
47968 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
47969 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
47970 1060 CONTINUE
47971 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
47972 &IBARRK(JT)=0
47973 GOTO 860
47974
47975C...Final hadron: side, flavour, hadron, mass.
47976 1070 I=I+1
47977 K(I,1)=1
47978 K(I,3)=IE(JR)
47979 K(I,4)=0
47980 K(I,5)=0
47981 CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
47982 IF(K(I,2).EQ.0) GOTO 700
47983 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I-1,2)),10000).GT.1000)
47984 &IBARRK(JT)=0
47985 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
47986 &K(I,3)=IJUORI(JT)
47987 IF(IBARRK(JR).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
47988 &K(I,3)=IJUORI(JR)
47989 P(I,5)=PYMASS(K(I,2))
47990 PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
47991
47992C...Final two hadrons: find common setup of four-vectors.
47993 JQ=1
47994 IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.
47995 &P(IN(7)+2,3)*P(IN(8)+2,3)*FOUR(IN(7),IN(8))) JQ=2
47996 DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
47997 DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
47998 DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
47999 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
48000 PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
48001 PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
48002 PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
48003 & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
48004 ENDIF
48005
48006C...Solve kinematics for final two hadrons, if possible.
48007 WREM2=2D0*DHR1*DHR2*DHC12
48008 FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
48009 IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200
48010 IF(FD.GE.1D0) GOTO 700
48011 FA=WREM2+PR(JT)-PR(JR)
48012 FB=SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT)))
48013 PREVCF=PARJ(42)
48014 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
48015 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*FB*PARJ(40))))
48016 FB=SIGN(FB,JS*(PYR(0)-PREV))
48017 KFL1A=IABS(KFL(1))
48018 KFL2A=IABS(KFL(2))
48019 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
48020 &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2-
48021 &4D0*WREM2*PR(JT))),DBLE(JS))
48022 DO 1080 J=1,4
48023 P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
48024 & P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
48025 & DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
48026 P(I,J)=P(N+NRS,J)-P(I-1,J)
48027 1080 CONTINUE
48028 IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 700
48029 DM2F1=P(I-1,4)**2-P(I-1,1)**2-P(I-1,2)**2-P(I-1,3)**2-P(I-1,5)**2
48030 DM2F2=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
48031 IF(DM2F1.GT.1D-10*P(I-1,4)**2.OR.DM2F2.GT.1D-10*P(I,4)**2) THEN
48032 NTRYFN=NTRYFN+1
48033 IF(NTRYFN.LT.100) GOTO 140
48034 CALL PYERRM(13,'(PYSTRF:) bad energies for final two hadrons')
48035 ENDIF
48036
48037C...Mark jets as fragmented and give daughter pointers.
48038 N=I-NRS+1
48039 DO 1090 I=NSAV+1,NSAV+NP
48040 IM=K(I,3)
48041 K(IM,1)=K(IM,1)+10
48042 IF(MSTU(16).NE.2) THEN
48043 K(IM,4)=NSAV+1
48044 K(IM,5)=NSAV+1
48045 ELSE
48046 K(IM,4)=NSAV+2
48047 K(IM,5)=N
48048 ENDIF
48049 1090 CONTINUE
48050
48051C...Document string system. Move up particles.
48052 NSAV=NSAV+1
48053 K(NSAV,1)=11
48054 K(NSAV,2)=92
48055 K(NSAV,3)=IP
48056 K(NSAV,4)=NSAV+1
48057 K(NSAV,5)=N
48058 DO 1100 J=1,4
48059 P(NSAV,J)=DPS(J)
48060 V(NSAV,J)=V(IP,J)
48061 1100 CONTINUE
48062 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
48063 V(NSAV,5)=0D0
48064 DO 1120 I=NSAV+1,N
48065 DO 1110 J=1,5
48066 K(I,J)=K(I+NRS-1,J)
48067 P(I,J)=P(I+NRS-1,J)
48068 V(I,J)=0D0
48069 1110 CONTINUE
48070 1120 CONTINUE
48071 MSTU91=MSTU(90)
48072 DO 1130 IZ=MSTU90+1,MSTU91
48073 MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
48074 PARU9T(IZ)=PARU(90+IZ)
48075 1130 CONTINUE
48076 MSTU(90)=MSTU90
48077
48078C...Order particles in rank along the chain. Update mother pointer.
48079 DO 1150 I=NSAV+1,N
48080 DO 1140 J=1,5
48081 K(I-NSAV+N,J)=K(I,J)
48082 P(I-NSAV+N,J)=P(I,J)
48083 1140 CONTINUE
48084 1150 CONTINUE
48085 I1=NSAV
48086 DO 1180 I=N+1,2*N-NSAV
48087 IF(K(I,3).NE.IE(1).AND.K(I,3).NE.IJUORI(1)) GOTO 1180
48088 I1=I1+1
48089 DO 1160 J=1,5
48090 K(I1,J)=K(I,J)
48091 P(I1,J)=P(I,J)
48092 1160 CONTINUE
48093 IF(MSTU(16).NE.2) K(I1,3)=NSAV
48094 DO 1170 IZ=MSTU90+1,MSTU91
48095 IF(MSTU9T(IZ).EQ.I) THEN
48096 MSTU(90)=MSTU(90)+1
48097 MSTU(90+MSTU(90))=I1
48098 PARU(90+MSTU(90))=PARU9T(IZ)
48099 ENDIF
48100 1170 CONTINUE
48101 1180 CONTINUE
48102 DO 1210 I=2*N-NSAV,N+1,-1
48103 IF(K(I,3).EQ.IE(1).OR.K(I,3).EQ.IJUORI(1)) GOTO 1210
48104 I1=I1+1
48105 DO 1190 J=1,5
48106 K(I1,J)=K(I,J)
48107 P(I1,J)=P(I,J)
48108 1190 CONTINUE
48109 IF(MSTU(16).NE.2) K(I1,3)=NSAV
48110 DO 1200 IZ=MSTU90+1,MSTU91
48111 IF(MSTU9T(IZ).EQ.I) THEN
48112 MSTU(90)=MSTU(90)+1
48113 MSTU(90+MSTU(90))=I1
48114 PARU(90+MSTU(90))=PARU9T(IZ)
48115 ENDIF
48116 1200 CONTINUE
48117 1210 CONTINUE
48118
48119C...Boost back particle system. Set production vertices.
48120 IF(MBST.EQ.0) THEN
48121 MSTU(33)=1
48122 CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),
48123 & DPS(3)/DPS(4))
48124 ELSE
48125 DO 1220 I=NSAV+1,N
48126 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
48127 IF(P(I,3).GT.0D0) THEN
48128 HHPEZ=(P(I,4)+P(I,3))*HHBZ
48129 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
48130 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
48131 ELSE
48132 HHPEZ=(P(I,4)-P(I,3))/HHBZ
48133 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
48134 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
48135 ENDIF
48136 1220 CONTINUE
48137 ENDIF
48138 DO 1240 I=NSAV+1,N
48139 DO 1230 J=1,4
48140 V(I,J)=V(IP,J)
48141 1230 CONTINUE
48142 1240 CONTINUE
48143
48144 RETURN
48145 END
48146
48147C*********************************************************************
48148
48149C...PYJURF
48150C...From three given input vectors in PJU the boost VJU from
48151C...the "lab frame" to the junction rest frame is constructed.
48152
48153 SUBROUTINE PYJURF(PJU,VJU)
48154
48155C...Double precision and integer declarations.
48156 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48157 IMPLICIT INTEGER(I-N)
48158
48159C...Input, output and local arrays.
48160 DIMENSION PJU(3,5),VJU(5),PSUM(5),A(3,3),PENEW(3),PCM(5,5)
48161 DATA TWOPI/6.283186D0/
48162
48163C...Calculate masses and other invariants.
48164 DO 100 J=1,4
48165 PSUM(J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
48166 100 CONTINUE
48167 PSUM2=PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2
48168 PSUM(5)=SQRT(PSUM2)
48169 DO 120 I=1,3
48170 DO 110 J=1,3
48171 A(I,J)=PJU(I,4)*PJU(J,4)-PJU(I,1)*PJU(J,1)-
48172 & PJU(I,2)*PJU(J,2)-PJU(I,3)*PJU(J,3)
48173 110 CONTINUE
48174 120 CONTINUE
48175
48176C...Pick I to be most massive parton and J to be the one closest to I.
48177 ITRY=0
48178 I=1
48179 IF(A(2,2).GT.A(1,1)) I=2
48180 IF(A(3,3).GT.MAX(A(1,1),A(2,2))) I=3
48181 130 ITRY=ITRY+1
48182 J=1+MOD(I,3)
48183 K=1+MOD(J,3)
48184 IF(A(I,K)**2*A(J,J).LT.A(I,J)**2*A(K,K)) THEN
48185 K=1+MOD(I,3)
48186 J=1+MOD(K,3)
48187 ENDIF
48188 PMI2=A(I,I)
48189 PMJ2=A(J,J)
48190 PMK2=A(K,K)
48191 AIJ=A(I,J)
48192 AIK=A(I,K)
48193 AJK=A(J,K)
48194
48195C...Trivial find new parton energies if all three partons are massless.
48196 IF(PMI2.LT.1D-4) THEN
48197 PEI=SQRT(2D0*AIK*AIJ/(3D0*AJK))
48198 PEJ=SQRT(2D0*AJK*AIJ/(3D0*AIK))
48199 PEK=SQRT(2D0*AIK*AJK/(3D0*AIJ))
48200
48201C...Else find momentum range for parton I and values at extremes.
48202 ELSE
48203 PAIMIN=0D0
48204 PEIMIN=SQRT(PMI2)
48205 PEJMIN=AIJ/PEIMIN
48206 PEKMIN=AIK/PEIMIN
48207 PAJMIN=SQRT(MAX(0D0,PEJMIN**2-PMJ2))
48208 PAKMIN=SQRT(MAX(0D0,PEKMIN**2-PMK2))
48209 FMIN=PEJMIN*PEKMIN+0.5D0*PAJMIN*PAKMIN-AJK
48210 PEIMAX=(AIJ+AIK)/SQRT(PMJ2+PMK2+2D0*AJK)
48211 IF(PMJ2.GT.1D-4) PEIMAX=AIJ/SQRT(PMJ2)
48212 PAIMAX=SQRT(MAX(0D0,PEIMAX**2-PMI2))
48213 HI=PEIMAX**2-0.25D0*PAIMAX**2
48214 PAJMAX=(PEIMAX*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-
48215 & 0.5D0*PAIMAX*AIJ)/HI
48216 PAKMAX=(PEIMAX*SQRT(MAX(0D0,AIK**2-PMK2*HI))-
48217 & 0.5D0*PAIMAX*AIK)/HI
48218 PEJMAX=SQRT(PAJMAX**2+PMJ2)
48219 PEKMAX=SQRT(PAKMAX**2+PMK2)
48220 FMAX=PEJMAX*PEKMAX+0.5D0*PAJMAX*PAKMAX-AJK
48221
48222C...If unexpected values at upper endpoint then pick another parton.
48223 IF(FMAX.GT.0D0.AND.ITRY.LE.2) THEN
48224 I1=1+MOD(I,3)
48225 IF(A(I1,I1).GE.1D-4) THEN
48226 I=I1
48227 GOTO 130
48228 ENDIF
48229 ITRY=ITRY+1
48230 I1=1+MOD(I,3)
48231 IF(ITRY.LE.2.AND.A(I1,I1).GE.1D-4) THEN
48232 I=I1
48233 GOTO 130
48234 ENDIF
48235 ENDIF
48236
48237C..Start binary + linear search to find solution inside range.
48238 ITER=0
48239 ITMIN=0
48240 ITMAX=0
48241 PAI=0.5D0*(PAIMIN+PAIMAX)
48242 140 ITER=ITER+1
48243
48244C...Derive momentum of other two partons and distance to root.
48245 PEI=SQRT(PAI**2+PMI2)
48246 HI=PEI**2-0.25D0*PAI**2
48247 PAJ=(PEI*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-0.5D0*PAI*AIJ)/HI
48248 PEJ=SQRT(PAJ**2+PMJ2)
48249 PAK=(PEI*SQRT(MAX(0D0,AIK**2-PMK2*HI))-0.5D0*PAI*AIK)/HI
48250 PEK=SQRT(PAK**2+PMK2)
48251 FNOW=PEJ*PEK+0.5D0*PAJ*PAK-AJK
48252
48253C...Pick next I momentum to explore, hopefully closer to root.
48254 IF(FNOW.GT.0D0) THEN
48255 PAIMIN=PAI
48256 FMIN=FNOW
48257 ITMIN=ITMIN+1
48258 ELSE
48259 PAIMAX=PAI
48260 FMAX=FNOW
48261 ITMAX=ITMAX+1
48262 ENDIF
48263 IF((ITER.LT.10.OR.ITMIN.LE.1.OR.ITMAX.LE.1).AND.ITER.LT.20)
48264 & THEN
48265 PAI=0.5D0*(PAIMIN+PAIMAX)
48266 GOTO 140
48267 ELSEIF(ITER.LT.40.AND.FMIN.GT.0D0.AND.FMAX.LT.0D0.AND.
48268 & ABS(FNOW).GT.1D-12*PSUM2) THEN
48269 PAI=PAIMIN+(PAIMAX-PAIMIN)*FMIN/(FMIN-FMAX)
48270 GOTO 140
48271 ENDIF
48272 ENDIF
48273
48274C...Now know energies in junction rest frame.
48275 PENEW(I)=PEI
48276 PENEW(J)=PEJ
48277 PENEW(K)=PEK
48278
48279C...Boost (copy of) partons to their rest frame.
48280 VXCM=-PSUM(1)/PSUM(5)
48281 VYCM=-PSUM(2)/PSUM(5)
48282 VZCM=-PSUM(3)/PSUM(5)
48283 GAMCM=SQRT(1D0+VXCM**2+VYCM**2+VZCM**2)
48284 DO 150 I=1,3
48285 FAC1=PJU(I,1)*VXCM+PJU(I,2)*VYCM+PJU(I,3)*VZCM
48286 FAC2=FAC1/(1D0+GAMCM)+PJU(I,4)
48287 PCM(I,1)=PJU(I,1)+FAC2*VXCM
48288 PCM(I,2)=PJU(I,2)+FAC2*VYCM
48289 PCM(I,3)=PJU(I,3)+FAC2*VZCM
48290 PCM(I,4)=PJU(I,4)*GAMCM+FAC1
48291 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
48292 150 CONTINUE
48293
48294C...Construct difference vectors and boost to junction rest frame.
48295 DO 160 J=1,3
48296 PCM(4,J)=PCM(1,J)/PCM(1,4)-PCM(2,J)/PCM(2,4)
48297 PCM(5,J)=PCM(1,J)/PCM(1,4)-PCM(3,J)/PCM(3,4)
48298 160 CONTINUE
48299 PCM(4,4)=PENEW(1)/PCM(1,4)-PENEW(2)/PCM(2,4)
48300 PCM(5,4)=PENEW(1)/PCM(1,4)-PENEW(3)/PCM(3,4)
48301 PCM4S=PCM(4,1)**2+PCM(4,2)**2+PCM(4,3)**2
48302 PCM5S=PCM(5,1)**2+PCM(5,2)**2+PCM(5,3)**2
48303 PCM45=PCM(4,1)*PCM(5,1)+PCM(4,2)*PCM(5,2)+PCM(4,3)*PCM(5,3)
48304 C4=(PCM5S*PCM(4,4)-PCM45*PCM(5,4))/(PCM4S*PCM5S-PCM45**2)
48305 C5=(PCM4S*PCM(5,4)-PCM45*PCM(4,4))/(PCM4S*PCM5S-PCM45**2)
48306 VXJU=C4*PCM(4,1)+C5*PCM(5,1)
48307 VYJU=C4*PCM(4,2)+C5*PCM(5,2)
48308 VZJU=C4*PCM(4,3)+C5*PCM(5,3)
48309 GAMJU=SQRT(1D0+VXJU**2+VYJU**2+VZJU**2)
48310
48311C...Add two boosts, giving final result.
48312 FCM=(VXJU*VXCM+VYJU*VYCM+VZJU*VZCM)/(1+GAMCM)+GAMJU
48313 VJU(1)=VXJU+FCM*VXCM
48314 VJU(2)=VYJU+FCM*VYCM
48315 VJU(3)=VZJU+FCM*VZCM
48316 VJU(4)=SQRT(1D0+VJU(1)**2+VJU(2)**2+VJU(3)**2)
48317 VJU(5)=1D0
48318
48319C...In case of error in reconstruction: revert to CM frame of system.
48320 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
48321 &(PCM(1,5)*PCM(2,5))
48322 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
48323 &(PCM(1,5)*PCM(3,5))
48324 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
48325 &(PCM(2,5)*PCM(3,5))
48326 ERRCCM=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
48327 ERRTCM=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
48328 DO 170 I=1,3
48329 FAC1=PJU(I,1)*VJU(1)+PJU(I,2)*VJU(2)+PJU(I,3)*VJU(3)
48330 FAC2=FAC1/(1D0+VJU(4))+PJU(I,4)
48331 PCM(I,1)=PJU(I,1)+FAC2*VJU(1)
48332 PCM(I,2)=PJU(I,2)+FAC2*VJU(2)
48333 PCM(I,3)=PJU(I,3)+FAC2*VJU(3)
48334 PCM(I,4)=PJU(I,4)*VJU(4)+FAC1
48335 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
48336 170 CONTINUE
48337 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
48338 &(PCM(1,5)*PCM(2,5))
48339 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
48340 &(PCM(1,5)*PCM(3,5))
48341 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
48342 &(PCM(2,5)*PCM(3,5))
48343 ERRCJU=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
48344 ERRTJU=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
48345 IF(ERRCJU+ERRTJU.GT.ERRCCM+ERRTCM) THEN
48346 VJU(1)=VXCM
48347 VJU(2)=VYCM
48348 VJU(3)=VZCM
48349 VJU(4)=GAMCM
48350 ENDIF
48351
48352 RETURN
48353 END
48354
48355C*********************************************************************
48356
48357C...PYINDF
48358C...Handles the fragmentation of a jet system (or a single
48359C...jet) according to independent fragmentation models.
48360
48361 SUBROUTINE PYINDF(IP)
48362
48363C...Double precision and integer declarations.
48364 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48365 IMPLICIT INTEGER(I-N)
48366 INTEGER PYK,PYCHGE,PYCOMP
48367C...Commonblocks.
48368 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
48369 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48370 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48371 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
48372C...Local arrays.
48373 DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
48374 &KFLO(2),PXO(2),PYO(2),WO(2)
48375
48376C.. MOPS error message
48377 IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
48378 &' are not treated as expected in independent fragmentation')
48379
48380C...Reset counters. Identify parton system and take copy. Check flavour.
48381 NSAV=N
48382 MSTU90=MSTU(90)
48383 NJET=0
48384 KQSUM=0
48385 DO 100 J=1,5
48386 DPS(J)=0D0
48387 100 CONTINUE
48388 I=IP-1
48389 110 I=I+1
48390 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
48391 CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
48392 IF(MSTU(21).GE.1) RETURN
48393 ENDIF
48394 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
48395 KC=PYCOMP(K(I,2))
48396 IF(KC.EQ.0) GOTO 110
48397 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
48398 IF(KQ.EQ.0) GOTO 110
48399 NJET=NJET+1
48400 IF(KQ.NE.2) KQSUM=KQSUM+KQ
48401 DO 120 J=1,5
48402 K(NSAV+NJET,J)=K(I,J)
48403 P(NSAV+NJET,J)=P(I,J)
48404 DPS(J)=DPS(J)+P(I,J)
48405 120 CONTINUE
48406 K(NSAV+NJET,3)=I
48407 IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
48408 &K(I+1,1).EQ.2)) GOTO 110
48409 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
48410 CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
48411 IF(MSTU(21).GE.1) RETURN
48412 ENDIF
48413
48414C...Boost copied system to CM frame. Find CM energy and sum flavours.
48415 IF(NJET.NE.1) THEN
48416 MSTU(33)=1
48417 CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
48418 & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
48419 ENDIF
48420 PECM=0D0
48421 DO 130 J=1,3
48422 NFI(J)=0
48423 130 CONTINUE
48424 DO 140 I=NSAV+1,NSAV+NJET
48425 PECM=PECM+P(I,4)
48426 KFA=IABS(K(I,2))
48427 IF(KFA.LE.3) THEN
48428 NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
48429 ELSEIF(KFA.GT.1000) THEN
48430 KFLA=MOD(KFA/1000,10)
48431 KFLB=MOD(KFA/100,10)
48432 IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
48433 IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
48434 ENDIF
48435 140 CONTINUE
48436
48437C...Loop over attempts made. Reset counters.
48438 NTRY=0
48439 150 NTRY=NTRY+1
48440 IF(NTRY.GT.200) THEN
48441 CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
48442 IF(MSTU(21).GE.1) RETURN
48443 ENDIF
48444 N=NSAV+NJET
48445 MSTU(90)=MSTU90
48446 DO 160 J=1,3
48447 NFL(J)=NFI(J)
48448 IFET(J)=0
48449 KFLF(J)=0
48450 160 CONTINUE
48451
48452C...Loop over jets to be fragmented.
48453 DO 230 IP1=NSAV+1,NSAV+NJET
48454 MSTJ(91)=0
48455 NSAV1=N
48456 MSTU91=MSTU(90)
48457
48458C...Initial flavour and momentum values. Jet along +z axis.
48459 KFLH=IABS(K(IP1,2))
48460 IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
48461 KFLO(2)=0
48462 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
48463
48464C...Initial values for quark or diquark jet.
48465 170 IF(IABS(K(IP1,2)).NE.21) THEN
48466 NSTR=1
48467 KFLO(1)=K(IP1,2)
48468 CALL PYPTDI(0,PXO(1),PYO(1))
48469 WO(1)=WF
48470
48471C...Initial values for gluon treated like random quark jet.
48472 ELSEIF(MSTJ(2).LE.2) THEN
48473 NSTR=1
48474 IF(MSTJ(2).EQ.2) MSTJ(91)=1
48475 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
48476 CALL PYPTDI(0,PXO(1),PYO(1))
48477 WO(1)=WF
48478
48479C...Initial values for gluon treated like quark-antiquark jet pair,
48480C...sharing energy according to Altarelli-Parisi splitting function.
48481 ELSE
48482 NSTR=2
48483 IF(MSTJ(2).EQ.4) MSTJ(91)=1
48484 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
48485 KFLO(2)=-KFLO(1)
48486 CALL PYPTDI(0,PXO(1),PYO(1))
48487 PXO(2)=-PXO(1)
48488 PYO(2)=-PYO(1)
48489 WO(1)=WF*PYR(0)**(1D0/3D0)
48490 WO(2)=WF-WO(1)
48491 ENDIF
48492
48493C...Initial values for rank, flavour, pT and W+.
48494 DO 220 ISTR=1,NSTR
48495 180 I=N
48496 MSTU(90)=MSTU91
48497 IRANK=0
48498 KFL1=KFLO(ISTR)
48499 PX1=PXO(ISTR)
48500 PY1=PYO(ISTR)
48501 W=WO(ISTR)
48502
48503C...New hadron. Generate flavour and hadron species.
48504 190 I=I+1
48505 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
48506 CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS')
48507 IF(MSTU(21).GE.1) RETURN
48508 ENDIF
48509 IRANK=IRANK+1
48510 K(I,1)=1
48511 K(I,3)=IP1
48512 K(I,4)=0
48513 K(I,5)=0
48514 200 CALL PYKFDI(KFL1,0,KFL2,K(I,2))
48515 IF(K(I,2).EQ.0) GOTO 180
48516 IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN
48517 IF(PYR(0).GT.PARJ(19)) GOTO 200
48518 ENDIF
48519
48520C...Find hadron mass. Generate four-momentum.
48521 P(I,5)=PYMASS(K(I,2))
48522 CALL PYPTDI(KFL1,PX2,PY2)
48523 P(I,1)=PX1+PX2
48524 P(I,2)=PY1+PY2
48525 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
48526 CALL PYZDIS(KFL1,KFL2,PR,Z)
48527 MZSAV=0
48528 IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
48529 MZSAV=1
48530 MSTU(90)=MSTU(90)+1
48531 MSTU(90+MSTU(90))=I
48532 PARU(90+MSTU(90))=Z
48533 ENDIF
48534 P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W))
48535 P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W))
48536 IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
48537 & P(I,3).LE.0.001D0) THEN
48538 IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180
48539 P(I,3)=0.0001D0
48540 P(I,4)=SQRT(PR)
48541 Z=P(I,4)/W
48542 ENDIF
48543
48544C...Remaining flavour and momentum.
48545 KFL1=-KFL2
48546 PX1=-PX2
48547 PY1=-PY2
48548 W=(1D0-Z)*W
48549 DO 210 J=1,5
48550 V(I,J)=0D0
48551 210 CONTINUE
48552
48553C...Check if pL acceptable. Go back for new hadron if enough energy.
48554 IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN
48555 I=I-1
48556 IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
48557 ENDIF
48558 IF(W.GT.PARJ(31)) GOTO 190
48559 N=I
48560 220 CONTINUE
48561 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32)
48562 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
48563
48564C...Rotate jet to new direction.
48565 THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
48566 PHI=PYANGL(P(IP1,1),P(IP1,2))
48567 MSTU(33)=1
48568 CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
48569 K(K(IP1,3),4)=NSAV1+1
48570 K(K(IP1,3),5)=N
48571
48572C...End of jet generation loop. Skip conservation in some cases.
48573 230 CONTINUE
48574 IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
48575 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
48576
48577C...Subtract off produced hadron flavours, finished if zero.
48578 DO 240 I=NSAV+NJET+1,N
48579 KFA=IABS(K(I,2))
48580 KFLA=MOD(KFA/1000,10)
48581 KFLB=MOD(KFA/100,10)
48582 KFLC=MOD(KFA/10,10)
48583 IF(KFLA.EQ.0) THEN
48584 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
48585 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
48586 ELSE
48587 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
48588 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
48589 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
48590 ENDIF
48591 240 CONTINUE
48592 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
48593 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
48594 IF(NREQ.EQ.0) GOTO 320
48595
48596C...Take away flavour of low-momentum particles until enough freedom.
48597 NREM=0
48598 250 IREM=0
48599 P2MIN=PECM**2
48600 DO 260 I=NSAV+NJET+1,N
48601 P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
48602 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
48603 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
48604 260 CONTINUE
48605 IF(IREM.EQ.0) GOTO 150
48606 K(IREM,1)=7
48607 KFA=IABS(K(IREM,2))
48608 KFLA=MOD(KFA/1000,10)
48609 KFLB=MOD(KFA/100,10)
48610 KFLC=MOD(KFA/10,10)
48611 IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
48612 IF(K(IREM,1).EQ.8) GOTO 250
48613 IF(KFLA.EQ.0) THEN
48614 ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
48615 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
48616 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
48617 ELSE
48618 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
48619 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
48620 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
48621 ENDIF
48622 NREM=NREM+1
48623 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
48624 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
48625 IF(NREQ.GT.NREM) GOTO 250
48626 DO 270 I=NSAV+NJET+1,N
48627 IF(K(I,1).EQ.8) K(I,1)=1
48628 270 CONTINUE
48629
48630C...Find combination of existing and new flavours for hadron.
48631 280 NFET=2
48632 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
48633 IF(NREQ.LT.NREM) NFET=1
48634 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
48635 DO 290 J=1,NFET
48636 IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0)
48637 KFLF(J)=ISIGN(1,NFL(1))
48638 IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
48639 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
48640 290 CONTINUE
48641 IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
48642 &GOTO 280
48643 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
48644 &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
48645 &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
48646 IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0))
48647 IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
48648 IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1))
48649 IF(NFET.LE.2) KFLF(3)=0
48650 IF(KFLF(3).NE.0) THEN
48651 KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
48652 & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
48653 IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0)
48654 & KFLFC=KFLFC+ISIGN(2,KFLFC)
48655 ELSE
48656 KFLFC=KFLF(1)
48657 ENDIF
48658 CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
48659 IF(KF.EQ.0) GOTO 280
48660 DO 300 J=1,MAX(2,NFET)
48661 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
48662 300 CONTINUE
48663
48664C...Store hadron at random among free positions.
48665 NPOS=MIN(1+INT(PYR(0)*NREM),NREM)
48666 DO 310 I=NSAV+NJET+1,N
48667 IF(K(I,1).EQ.7) NPOS=NPOS-1
48668 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
48669 K(I,1)=1
48670 K(I,2)=KF
48671 P(I,5)=PYMASS(K(I,2))
48672 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
48673 310 CONTINUE
48674 NREM=NREM-1
48675 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
48676 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
48677 IF(NREM.GT.0) GOTO 280
48678
48679C...Compensate for missing momentum in global scheme (3 options).
48680 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
48681 DO 340 J=1,3
48682 PSI(J)=0D0
48683 DO 330 I=NSAV+NJET+1,N
48684 PSI(J)=PSI(J)+P(I,J)
48685 330 CONTINUE
48686 340 CONTINUE
48687 PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
48688 PWS=0D0
48689 DO 350 I=NSAV+NJET+1,N
48690 IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
48691 IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
48692 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
48693 IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0
48694 350 CONTINUE
48695 DO 370 I=NSAV+NJET+1,N
48696 IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
48697 IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
48698 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
48699 IF(MOD(MSTJ(3),5).EQ.3) PW=1D0
48700 DO 360 J=1,3
48701 P(I,J)=P(I,J)-PSI(J)*PW/PWS
48702 360 CONTINUE
48703 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
48704 370 CONTINUE
48705
48706C...Compensate for missing momentum withing each jet separately.
48707 ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
48708 DO 390 I=N+1,N+NJET
48709 K(I,1)=0
48710 DO 380 J=1,5
48711 P(I,J)=0D0
48712 380 CONTINUE
48713 390 CONTINUE
48714 DO 410 I=NSAV+NJET+1,N
48715 IR1=K(I,3)
48716 IR2=N+IR1-NSAV
48717 K(IR2,1)=K(IR2,1)+1
48718 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
48719 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
48720 DO 400 J=1,3
48721 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
48722 400 CONTINUE
48723 P(IR2,4)=P(IR2,4)+P(I,4)
48724 P(IR2,5)=P(IR2,5)+PLS
48725 410 CONTINUE
48726 PSS=0D0
48727 DO 420 I=N+1,N+NJET
48728 IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0))
48729 420 CONTINUE
48730 DO 440 I=NSAV+NJET+1,N
48731 IR1=K(I,3)
48732 IR2=N+IR1-NSAV
48733 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
48734 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
48735 DO 430 J=1,3
48736 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)*
48737 & PLS*P(IR1,J)
48738 430 CONTINUE
48739 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
48740 440 CONTINUE
48741 ENDIF
48742
48743C...Scale momenta for energy conservation.
48744 IF(MOD(MSTJ(3),5).NE.0) THEN
48745 PMS=0D0
48746 PES=0D0
48747 PQS=0D0
48748 DO 450 I=NSAV+NJET+1,N
48749 PMS=PMS+P(I,5)
48750 PES=PES+P(I,4)
48751 PQS=PQS+P(I,5)**2/P(I,4)
48752 450 CONTINUE
48753 IF(PMS.GE.PECM) GOTO 150
48754 NECO=0
48755 460 NECO=NECO+1
48756 PFAC=(PECM-PQS)/(PES-PQS)
48757 PES=0D0
48758 PQS=0D0
48759 DO 480 I=NSAV+NJET+1,N
48760 DO 470 J=1,3
48761 P(I,J)=PFAC*P(I,J)
48762 470 CONTINUE
48763 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
48764 PES=PES+P(I,4)
48765 PQS=PQS+P(I,5)**2/P(I,4)
48766 480 CONTINUE
48767 IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
48768 ENDIF
48769
48770C...Origin of produced particles and parton daughter pointers.
48771 490 DO 500 I=NSAV+NJET+1,N
48772 IF(MSTU(16).NE.2) K(I,3)=NSAV+1
48773 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
48774 500 CONTINUE
48775 DO 510 I=NSAV+1,NSAV+NJET
48776 I1=K(I,3)
48777 K(I1,1)=K(I1,1)+10
48778 IF(MSTU(16).NE.2) THEN
48779 K(I1,4)=NSAV+1
48780 K(I1,5)=NSAV+1
48781 ELSE
48782 K(I1,4)=K(I1,4)-NJET+1
48783 K(I1,5)=K(I1,5)-NJET+1
48784 IF(K(I1,5).LT.K(I1,4)) THEN
48785 K(I1,4)=0
48786 K(I1,5)=0
48787 ENDIF
48788 ENDIF
48789 510 CONTINUE
48790
48791C...Document independent fragmentation system. Remove copy of jets.
48792 NSAV=NSAV+1
48793 K(NSAV,1)=11
48794 K(NSAV,2)=93
48795 K(NSAV,3)=IP
48796 K(NSAV,4)=NSAV+1
48797 K(NSAV,5)=N-NJET+1
48798 DO 520 J=1,4
48799 P(NSAV,J)=DPS(J)
48800 V(NSAV,J)=V(IP,J)
48801 520 CONTINUE
48802 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
48803 V(NSAV,5)=0D0
48804 DO 540 I=NSAV+NJET,N
48805 DO 530 J=1,5
48806 K(I-NJET+1,J)=K(I,J)
48807 P(I-NJET+1,J)=P(I,J)
48808 V(I-NJET+1,J)=V(I,J)
48809 530 CONTINUE
48810 540 CONTINUE
48811 N=N-NJET+1
48812 DO 550 IZ=MSTU90+1,MSTU(90)
48813 MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
48814 550 CONTINUE
48815
48816C...Boost back particle system. Set production vertices.
48817 IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
48818 &DPS(2)/DPS(4),DPS(3)/DPS(4))
48819 DO 570 I=NSAV+1,N
48820 DO 560 J=1,4
48821 V(I,J)=V(IP,J)
48822 560 CONTINUE
48823 570 CONTINUE
48824
48825 RETURN
48826 END
48827
48828C*********************************************************************
48829
48830C...PYDECY
48831C...Handles the decay of unstable particles.
48832
48833 SUBROUTINE PYDECY(IP)
48834
48835C...Double precision and integer declarations.
48836 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48837 IMPLICIT INTEGER(I-N)
48838 INTEGER PYK,PYCHGE,PYCOMP
48839C...Commonblocks.
48840 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
48841 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48842 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48843 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
48844 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
48845C...Local arrays.
48846 DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
48847 &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
48848 CHARACTER CIDC*4
48849 DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
48850
48851C...Functions: momentum in two-particle decays and four-product.
48852 PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
48853 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)
48854
48855C...Initial values.
48856 NTRY=0
48857 NSAV=N
48858 KFA=IABS(K(IP,2))
48859 KFS=ISIGN(1,K(IP,2))
48860 KC=PYCOMP(KFA)
48861 MSTJ(92)=0
48862
48863C...Choose lifetime and determine decay vertex.
48864 IF(K(IP,1).EQ.5) THEN
48865 V(IP,5)=0D0
48866 ELSEIF(K(IP,1).NE.4) THEN
48867 V(IP,5)=-PMAS(KC,4)*LOG(PYR(0))
48868 ENDIF
48869 DO 100 J=1,4
48870 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
48871 100 CONTINUE
48872
48873C...Determine whether decay allowed or not.
48874 MOUT=0
48875 IF(MSTJ(22).EQ.2) THEN
48876 IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
48877 ELSEIF(MSTJ(22).EQ.3) THEN
48878 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
48879 ELSEIF(MSTJ(22).EQ.4) THEN
48880 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
48881 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
48882 ENDIF
48883 IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
48884 K(IP,1)=4
48885 RETURN
48886 ENDIF
48887
48888C...Interface to external tau decay library (for tau polarization).
48889 IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
48890
48891C...Starting values for pointers and momenta.
48892 ITAU=IP
48893 DO 110 J=1,4
48894 PTAU(J)=P(ITAU,J)
48895 PCMTAU(J)=P(ITAU,J)
48896 110 CONTINUE
48897
48898C...Iterate to find position and code of mother of tau.
48899 IMTAU=ITAU
48900 120 IMTAU=K(IMTAU,3)
48901
48902 IF(IMTAU.EQ.0) THEN
48903C...If no known origin then impossible to do anything further.
48904 KFORIG=0
48905 IORIG=0
48906
48907 ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
48908C...If tau -> tau + gamma then add gamma energy and loop.
48909 IF(K(K(IMTAU,4),2).EQ.22) THEN
48910 DO 130 J=1,4
48911 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
48912 130 CONTINUE
48913 ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
48914 DO 140 J=1,4
48915 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
48916 140 CONTINUE
48917 ENDIF
48918 GOTO 120
48919
48920 ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
48921C...If coming from weak decay of hadron then W is not stored in record,
48922C...but can be reconstructed by adding neutrino momentum.
48923 KFORIG=-ISIGN(24,K(ITAU,2))
48924 IORIG=0
48925 DO 160 II=K(IMTAU,4),K(IMTAU,5)
48926 IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
48927 DO 150 J=1,4
48928 PCMTAU(J)=PCMTAU(J)+P(II,J)
48929 150 CONTINUE
48930 ENDIF
48931 160 CONTINUE
48932
48933 ELSE
48934C...If coming from resonance decay then find latest copy of this
48935C...resonance (may not completely agree).
48936 KFORIG=K(IMTAU,2)
48937 IORIG=IMTAU
48938 DO 170 II=IMTAU+1,IP-1
48939 IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
48940 & ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II
48941 170 CONTINUE
48942 DO 180 J=1,4
48943 PCMTAU(J)=P(IORIG,J)
48944 180 CONTINUE
48945 ENDIF
48946
48947C...Boost tau to rest frame of production process (where known)
48948C...and rotate it to sit along +z axis.
48949 DO 190 J=1,3
48950 DBETAU(J)=PCMTAU(J)/PCMTAU(4)
48951 190 CONTINUE
48952 IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1),
48953 & -DBETAU(2),-DBETAU(3))
48954 PHITAU=PYANGL(P(ITAU,1),P(ITAU,2))
48955 CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0)
48956 THETAU=PYANGL(P(ITAU,3),P(ITAU,1))
48957 CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0)
48958
48959C...Call tau decay routine (if meaningful) and fill extra info.
48960 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
48961 CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
48962 DO 200 II=NSAV+1,NSAV+NDECAY
48963 K(II,1)=1
48964 K(II,3)=IP
48965 K(II,4)=0
48966 K(II,5)=0
48967 200 CONTINUE
48968 N=NSAV+NDECAY
48969 ENDIF
48970
48971C...Boost back decay tau and decay products.
48972 DO 210 J=1,4
48973 P(ITAU,J)=PTAU(J)
48974 210 CONTINUE
48975 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
48976 CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
48977 IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1),
48978 & DBETAU(2),DBETAU(3))
48979
48980C...Skip past ordinary tau decay treatment.
48981 MMAT=0
48982 MBST=0
48983 ND=0
48984 GOTO 630
48985 ENDIF
48986 ENDIF
48987
48988C...B-Bbar mixing: flip sign of meson appropriately.
48989 MMIX=0
48990 IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
48991 XBBMIX=PARJ(76)
48992 IF(KFA.EQ.531) XBBMIX=PARJ(77)
48993 IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1
48994 IF(MMIX.EQ.1) KFS=-KFS
48995 ENDIF
48996
48997C...Check existence of decay channels. Particle/antiparticle rules.
48998 KCA=KC
48999 IF(MDCY(KC,2).GT.0) THEN
49000 MDMDCY=MDME(MDCY(KC,2),2)
49001 IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
49002 ENDIF
49003 IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
49004 CALL PYERRM(9,'(PYDECY:) no decay channel defined')
49005 RETURN
49006 ENDIF
49007 IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS
49008 IF(KCHG(KC,3).EQ.0) THEN
49009 KFSP=1
49010 KFSN=0
49011 IF(PYR(0).GT.0.5D0) KFS=-KFS
49012 ELSEIF(KFS.GT.0) THEN
49013 KFSP=1
49014 KFSN=0
49015 ELSE
49016 KFSP=0
49017 KFSN=1
49018 ENDIF
49019
49020C...Sum branching ratios of allowed decay channels.
49021 220 NOPE=0
49022 BRSU=0D0
49023 DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
49024 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
49025 & KFSN*MDME(IDL,1).NE.3) GOTO 230
49026 IF(MDME(IDL,2).GT.100) GOTO 230
49027 NOPE=NOPE+1
49028 BRSU=BRSU+BRAT(IDL)
49029 230 CONTINUE
49030 IF(NOPE.EQ.0) THEN
49031 CALL PYERRM(2,'(PYDECY:) all decay channels closed by user')
49032 RETURN
49033 ENDIF
49034
49035C...Select decay channel among allowed ones.
49036 240 RBR=BRSU*PYR(0)
49037 IDL=MDCY(KCA,2)-1
49038 250 IDL=IDL+1
49039 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
49040 &KFSN*MDME(IDL,1).NE.3) THEN
49041 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
49042 ELSEIF(MDME(IDL,2).GT.100) THEN
49043 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
49044 ELSE
49045 IDC=IDL
49046 RBR=RBR-BRAT(IDL)
49047 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250
49048 ENDIF
49049
49050C...Start readout of decay channel: matrix element, reset counters.
49051 MMAT=MDME(IDC,2)
49052 260 NTRY=NTRY+1
49053 IF(MOD(NTRY,200).EQ.0) THEN
49054 WRITE(CIDC,'(I4)') IDC
49055C...Do not print warning for some well-known special cases.
49056 IF(KFA.NE.113.AND.KFA.NE.115.AND.KFA.NE.215)
49057 & CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'//
49058 & CIDC)
49059 GOTO 240
49060 ENDIF
49061 IF(NTRY.GT.1000) THEN
49062 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
49063 IF(MSTU(21).GE.1) RETURN
49064 ENDIF
49065 I=N
49066 NP=0
49067 NQ=0
49068 MBST=0
49069 IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1
49070 DO 270 J=1,4
49071 PV(1,J)=0D0
49072 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
49073 270 CONTINUE
49074 IF(MBST.EQ.1) PV(1,4)=P(IP,5)
49075 PV(1,5)=P(IP,5)
49076 PS=0D0
49077 PSQ=0D0
49078 MREM=0
49079 MHADDY=0
49080 IF(KFA.GT.80) MHADDY=1
49081C.. Random flavour and popcorn system memory.
49082 IRNDMO=0
49083 JTMO=0
49084 MSTU(121)=0
49085 MSTU(125)=10
49086
49087C...Read out decay products. Convert to standard flavour code.
49088 JTMAX=5
49089 IF(MDME(IDC+1,2).EQ.101) JTMAX=10
49090 DO 280 JT=1,JTMAX
49091 IF(JT.LE.5) KP=KFDP(IDC,JT)
49092 IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
49093 IF(KP.EQ.0) GOTO 280
49094 KPA=IABS(KP)
49095 KCP=PYCOMP(KPA)
49096 IF(KPA.GT.80) MHADDY=1
49097 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
49098 KFP=KP
49099 ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
49100 KFP=KFS*KP
49101 ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
49102 KFP=-KFS*MOD(KFA/10,10)
49103 ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
49104 KFP=KFS*(100*MOD(KFA/10,100)+3)
49105 ELSEIF(KPA.EQ.81) THEN
49106 KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
49107 ELSEIF(KP.EQ.82) THEN
49108 CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP)
49109 IF(KFP.EQ.0) GOTO 260
49110 KFP=-KFP
49111 IRNDMO=1
49112 MSTJ(93)=1
49113 IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260
49114 ELSEIF(KP.EQ.-82) THEN
49115 KFP=MSTU(124)
49116 ENDIF
49117 IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP)
49118
49119C...Add decay product to event record or to quark flavour list.
49120 KFPA=IABS(KFP)
49121 KQP=KCHG(KCP,2)
49122 IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
49123 NQ=NQ+1
49124 KFLO(NQ)=KFP
49125C...set rndmflav popcorn system pointer
49126 IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ
49127 MSTJ(93)=2
49128 PSQ=PSQ+PYMASS(KFLO(NQ))
49129 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
49130 & MOD(NQ,2).EQ.1) THEN
49131 NQ=NQ-1
49132 PS=PS-P(I,5)
49133 K(I,1)=1
49134 KFI=K(I,2)
49135 CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2))
49136 IF(K(I,2).EQ.0) GOTO 260
49137 MSTJ(93)=1
49138 P(I,5)=PYMASS(K(I,2))
49139 PS=PS+P(I,5)
49140 ELSE
49141 I=I+1
49142 NP=NP+1
49143 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
49144 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
49145 K(I,1)=1+MOD(NQ,2)
49146 IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
49147 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
49148 K(I,2)=KFP
49149 K(I,3)=IP
49150 K(I,4)=0
49151 K(I,5)=0
49152 P(I,5)=PYMASS(KFP)
49153 PS=PS+P(I,5)
49154 ENDIF
49155 280 CONTINUE
49156
49157C...Check masses for resonance decays.
49158 IF(MHADDY.EQ.0) THEN
49159 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
49160 ENDIF
49161
49162C...Choose decay multiplicity in phase space model.
49163 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
49164 PSP=PS
49165 CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0))
49166 IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
49167 300 NTRY=NTRY+1
49168C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
49169 IF(IRNDMO.EQ.0) THEN
49170 MSTU(121)=0
49171 JTMO=0
49172 ELSEIF(IRNDMO.EQ.1) THEN
49173 IRNDMO=2
49174 ELSE
49175 GOTO 260
49176 ENDIF
49177 IF(NTRY.GT.1000) THEN
49178 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
49179 IF(MSTU(21).GE.1) RETURN
49180 ENDIF
49181 IF(MMAT.LE.20) THEN
49182 GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))*
49183 & SIN(PARU(2)*PYR(0))
49184 ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS
49185 IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
49186 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
49187 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
49188 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
49189 ELSE
49190 ND=MMAT-20
49191 ENDIF
49192C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
49193 MSTU(125)=ND-NQ/2
49194 IF(MSTU(121).GT.MSTU(125)) GOTO 300
49195
49196C...Form hadrons from flavour content.
49197 DO 310 JT=1,NQ
49198 KFL1(JT)=KFLO(JT)
49199 310 CONTINUE
49200 IF(ND.EQ.NP+NQ/2) GOTO 330
49201 DO 320 I=N+NP+1,N+ND-NQ/2
49202C.. Stick to started popcorn system, else pick side at random
49203 JT=JTMO
49204 IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0))
49205 CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2))
49206 IF(K(I,2).EQ.0) GOTO 300
49207 MSTU(125)=MSTU(125)-1
49208 JTMO=0
49209 IF(MSTU(121).GT.0) JTMO=JT
49210 KFL1(JT)=-KFL2
49211 320 CONTINUE
49212 330 JT=2
49213 JT2=3
49214 JT3=4
49215 IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4
49216 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
49217 & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
49218 IF(JT.EQ.3) JT2=2
49219 IF(JT.EQ.4) JT3=2
49220 CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
49221 IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
49222 IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
49223 IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
49224
49225C...Check that sum of decay product masses not too large.
49226 PS=PSP
49227 DO 340 I=N+NP+1,N+ND
49228 K(I,1)=1
49229 K(I,3)=IP
49230 K(I,4)=0
49231 K(I,5)=0
49232 P(I,5)=PYMASS(K(I,2))
49233 PS=PS+P(I,5)
49234 340 CONTINUE
49235 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
49236
49237C...Rescale energy to subtract off spectator quark mass.
49238 ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44)
49239 & .AND.NP.GE.3) THEN
49240 PS=PS-P(N+NP,5)
49241 PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
49242 DO 350 J=1,5
49243 P(N+NP,J)=PQT*PV(1,J)
49244 PV(1,J)=(1D0-PQT)*PV(1,J)
49245 350 CONTINUE
49246 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
49247 ND=NP-1
49248 MREM=1
49249
49250C...Fully specified final state: check mass broadening effects.
49251 ELSE
49252 IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
49253 ND=NP
49254 ENDIF
49255
49256C...Determine position of grandmother, number of sisters.
49257 NM=0
49258 KFAS=0
49259 MSGN=0
49260 IF(MMAT.EQ.3) THEN
49261 IM=K(IP,3)
49262 IF(IM.LT.0.OR.IM.GE.IP) IM=0
49263 IF(IM.NE.0) KFAM=IABS(K(IM,2))
49264 IF(IM.NE.0) THEN
49265 DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
49266 IF(K(IL,3).EQ.IM) NM=NM+1
49267 IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
49268 360 CONTINUE
49269 IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
49270 & MOD(KFAM/1000,10).NE.0) NM=0
49271 IF(NM.EQ.2) THEN
49272 KFAS=IABS(K(ISIS,2))
49273 IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
49274 & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
49275 ENDIF
49276 ENDIF
49277 ENDIF
49278
49279C...Kinematics of one-particle decays.
49280 IF(ND.EQ.1) THEN
49281 DO 370 J=1,4
49282 P(N+1,J)=P(IP,J)
49283 370 CONTINUE
49284 GOTO 630
49285 ENDIF
49286
49287C...Calculate maximum weight ND-particle decay.
49288 PV(ND,5)=P(N+ND,5)
49289 IF(ND.GE.3) THEN
49290 WTMAX=1D0/WTCOR(ND-2)
49291 PMAX=PV(1,5)-PS+P(N+ND,5)
49292 PMIN=0D0
49293 DO 380 IL=ND-1,1,-1
49294 PMAX=PMAX+P(N+IL,5)
49295 PMIN=PMIN+P(N+IL+1,5)
49296 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
49297 380 CONTINUE
49298 ENDIF
49299
49300C...Find virtual gamma mass in Dalitz decay.
49301 390 IF(ND.EQ.2) THEN
49302 ELSEIF(MMAT.EQ.2) THEN
49303 PMES=4D0*PMAS(11,1)**2
49304 PMRHO2=PMAS(131,1)**2
49305 PGRHO2=PMAS(131,2)**2
49306 400 PMST=PMES*(P(IP,5)**2/PMES)**PYR(0)
49307 WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))*
49308 & (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/
49309 & ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
49310 IF(WT.LT.PYR(0)) GOTO 400
49311 PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST))
49312
49313C...M-generator gives weight. If rejected, try again.
49314 ELSE
49315 410 RORD(1)=1D0
49316 DO 440 IL1=2,ND-1
49317 RSAV=PYR(0)
49318 DO 420 IL2=IL1-1,1,-1
49319 IF(RSAV.LE.RORD(IL2)) GOTO 430
49320 RORD(IL2+1)=RORD(IL2)
49321 420 CONTINUE
49322 430 RORD(IL2+1)=RSAV
49323 440 CONTINUE
49324 RORD(ND)=0D0
49325 WT=1D0
49326 DO 450 IL=ND-1,1,-1
49327 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
49328 & (PV(1,5)-PS)
49329 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
49330 450 CONTINUE
49331 IF(WT.LT.PYR(0)*WTMAX) GOTO 410
49332 ENDIF
49333
49334C...Perform two-particle decays in respective CM frame.
49335 460 DO 480 IL=1,ND-1
49336 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
49337 UE(3)=2D0*PYR(0)-1D0
49338 PHI=PARU(2)*PYR(0)
49339 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
49340 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
49341 DO 470 J=1,3
49342 P(N+IL,J)=PA*UE(J)
49343 PV(IL+1,J)=-PA*UE(J)
49344 470 CONTINUE
49345 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
49346 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
49347 480 CONTINUE
49348
49349C...Lorentz transform decay products to lab frame.
49350 DO 490 J=1,4
49351 P(N+ND,J)=PV(ND,J)
49352 490 CONTINUE
49353 DO 530 IL=ND-1,1,-1
49354 DO 500 J=1,3
49355 BE(J)=PV(IL,J)/PV(IL,4)
49356 500 CONTINUE
49357 GA=PV(IL,4)/PV(IL,5)
49358 DO 520 I=N+IL,N+ND
49359 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
49360 DO 510 J=1,3
49361 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
49362 510 CONTINUE
49363 P(I,4)=GA*(P(I,4)+BEP)
49364 520 CONTINUE
49365 530 CONTINUE
49366
49367C...Check that no infinite loop in matrix element weight.
49368 NTRY=NTRY+1
49369 IF(NTRY.GT.800) GOTO 560
49370
49371C...Matrix elements for omega and phi decays.
49372 IF(MMAT.EQ.1) THEN
49373 WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
49374 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
49375 & +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
49376 IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390
49377
49378C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
49379 ELSEIF(MMAT.EQ.2) THEN
49380 FOUR12=FOUR(N+1,N+2)
49381 FOUR13=FOUR(N+1,N+3)
49382 WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+
49383 & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
49384 IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460
49385
49386C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
49387C...V vector), of form cos**2(theta02) in V1 rest frame, and for
49388C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
49389 ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
49390 FOUR10=FOUR(IP,IM)
49391 FOUR12=FOUR(IP,N+1)
49392 FOUR02=FOUR(IM,N+1)
49393 PMS1=P(IP,5)**2
49394 PMS0=P(IM,5)**2
49395 PMS2=P(N+1,5)**2
49396 IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
49397 IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02-
49398 & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
49399 HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM)
49400 HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
49401 IF(HNUM.LT.PYR(0)*HDEN) GOTO 460
49402
49403C...Matrix element for "onium" -> g + g + g or gamma + g + g.
49404 ELSEIF(MMAT.EQ.4) THEN
49405 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
49406 HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2
49407 HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2
49408 WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+
49409 & ((1D0-HX3)/(HX1*HX2))**2
49410 IF(WT.LT.2D0*PYR(0)) GOTO 390
49411 IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2)
49412 & GOTO 390
49413
49414C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
49415 ELSEIF(MMAT.EQ.41) THEN
49416 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
49417 HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5)))
49418 IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390
49419
49420C...Matrix elements for weak decays (only semileptonic for c and b)
49421 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
49422 & .AND.ND.EQ.3) THEN
49423 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
49424 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
49425 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
49426 ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN
49427 DO 550 J=1,4
49428 P(N+NP+1,J)=0D0
49429 DO 540 IS=N+3,N+NP
49430 P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
49431 540 CONTINUE
49432 550 CONTINUE
49433 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
49434 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
49435 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
49436 ENDIF
49437
49438C...Scale back energy and reattach spectator.
49439 560 IF(MREM.EQ.1) THEN
49440 DO 570 J=1,5
49441 PV(1,J)=PV(1,J)/(1D0-PQT)
49442 570 CONTINUE
49443 ND=ND+1
49444 MREM=0
49445 ENDIF
49446
49447C...Low invariant mass for system with spectator quark gives particle,
49448C...not two jets. Readjust momenta accordingly.
49449 IF(MMAT.EQ.31.AND.ND.EQ.3) THEN
49450 MSTJ(93)=1
49451 PM2=PYMASS(K(N+2,2))
49452 MSTJ(93)=1
49453 PM3=PYMASS(K(N+3,2))
49454 IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE.
49455 & (PARJ(32)+PM2+PM3)**2) GOTO 630
49456 K(N+2,1)=1
49457 KFTEMP=K(N+2,2)
49458 CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
49459 IF(K(N+2,2).EQ.0) GOTO 260
49460 P(N+2,5)=PYMASS(K(N+2,2))
49461 PS=P(N+1,5)+P(N+2,5)
49462 PV(2,5)=P(N+2,5)
49463 MMAT=0
49464 ND=2
49465 GOTO 460
49466 ELSEIF(MMAT.EQ.44) THEN
49467 MSTJ(93)=1
49468 PM3=PYMASS(K(N+3,2))
49469 MSTJ(93)=1
49470 PM4=PYMASS(K(N+4,2))
49471 IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE.
49472 & (PARJ(32)+PM3+PM4)**2) GOTO 600
49473 K(N+3,1)=1
49474 KFTEMP=K(N+3,2)
49475 CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
49476 IF(K(N+3,2).EQ.0) GOTO 260
49477 P(N+3,5)=PYMASS(K(N+3,2))
49478 DO 580 J=1,3
49479 P(N+3,J)=P(N+3,J)+P(N+4,J)
49480 580 CONTINUE
49481 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)
49482 HA=P(N+1,4)**2-P(N+2,4)**2
49483 HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
49484 HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
49485 & (P(N+1,3)-P(N+2,3))**2
49486 HD=(PV(1,4)-P(N+3,4))**2
49487 HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
49488 HF=HD*HC-HB**2
49489 HG=HD*HC-HA*HB
49490 HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF)
49491 DO 590 J=1,3
49492 PCOR=HH*(P(N+1,J)-P(N+2,J))
49493 P(N+1,J)=P(N+1,J)+PCOR
49494 P(N+2,J)=P(N+2,J)-PCOR
49495 590 CONTINUE
49496 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)
49497 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)
49498 ND=ND-1
49499 ENDIF
49500
49501C...Check invariant mass of W jets. May give one particle or start over.
49502 600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
49503 &.AND.IABS(K(N+1,2)).LT.10) THEN
49504 PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2)))
49505 MSTJ(93)=1
49506 PM1=PYMASS(K(N+1,2))
49507 MSTJ(93)=1
49508 PM2=PYMASS(K(N+2,2))
49509 IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610
49510 KFLDUM=INT(1.5D0+PYR(0))
49511 CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
49512 CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
49513 IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260
49514 PSM=PYMASS(KF1)+PYMASS(KF2)
49515 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610
49516 IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610
49517 IF(MMAT.EQ.48) GOTO 390
49518 IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260
49519 K(N+1,1)=1
49520 KFTEMP=K(N+1,2)
49521 CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
49522 IF(K(N+1,2).EQ.0) GOTO 260
49523 P(N+1,5)=PYMASS(K(N+1,2))
49524 K(N+2,2)=K(N+3,2)
49525 P(N+2,5)=P(N+3,5)
49526 PS=P(N+1,5)+P(N+2,5)
49527 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
49528 PV(2,5)=P(N+3,5)
49529 MMAT=0
49530 ND=2
49531 GOTO 460
49532 ENDIF
49533
49534C...Phase space decay of partons from W decay.
49535 610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN
49536 KFLO(1)=K(N+1,2)
49537 KFLO(2)=K(N+2,2)
49538 K(N+1,1)=K(N+3,1)
49539 K(N+1,2)=K(N+3,2)
49540 DO 620 J=1,5
49541 PV(1,J)=P(N+1,J)+P(N+2,J)
49542 P(N+1,J)=P(N+3,J)
49543 620 CONTINUE
49544 PV(1,5)=PMR
49545 N=N+1
49546 NP=0
49547 NQ=2
49548 PS=0D0
49549 MSTJ(93)=2
49550 PSQ=PYMASS(KFLO(1))
49551 MSTJ(93)=2
49552 PSQ=PSQ+PYMASS(KFLO(2))
49553 MMAT=11
49554 GOTO 290
49555 ENDIF
49556
49557C...Boost back for rapidly moving particle.
49558 630 N=N+ND
49559 IF(MBST.EQ.1) THEN
49560 DO 640 J=1,3
49561 BE(J)=P(IP,J)/P(IP,4)
49562 640 CONTINUE
49563 GA=P(IP,4)/P(IP,5)
49564 DO 660 I=NSAV+1,N
49565 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
49566 DO 650 J=1,3
49567 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
49568 650 CONTINUE
49569 P(I,4)=GA*(P(I,4)+BEP)
49570 660 CONTINUE
49571 ENDIF
49572
49573C...Fill in position of decay vertex.
49574 DO 680 I=NSAV+1,N
49575 DO 670 J=1,4
49576 V(I,J)=VDCY(J)
49577 670 CONTINUE
49578 V(I,5)=0D0
49579 680 CONTINUE
49580
49581C...Set up for parton shower evolution from jets.
49582 IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
49583 K(NSAV+1,1)=3
49584 K(NSAV+2,1)=3
49585 K(NSAV+3,1)=3
49586 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
49587 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
49588 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
49589 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
49590 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
49591 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
49592 MSTJ(92)=-(NSAV+1)
49593 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
49594 K(NSAV+2,1)=3
49595 K(NSAV+3,1)=3
49596 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
49597 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
49598 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
49599 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
49600 MSTJ(92)=NSAV+2
49601 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
49602 & IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
49603 K(NSAV+1,1)=3
49604 K(NSAV+2,1)=3
49605 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
49606 K(NSAV+1,5)=MSTU(5)*(NSAV+2)
49607 K(NSAV+2,4)=MSTU(5)*(NSAV+1)
49608 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
49609 MSTJ(92)=NSAV+1
49610 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
49611 & IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
49612 MSTJ(92)=NSAV+1
49613 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
49614 & THEN
49615 K(NSAV+1,1)=3
49616 K(NSAV+2,1)=3
49617 K(NSAV+3,1)=3
49618 KCP=PYCOMP(K(NSAV+1,2))
49619 KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
49620 JCON=4
49621 IF(KQP.LT.0) JCON=5
49622 K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
49623 K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
49624 K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
49625 K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
49626 MSTJ(92)=NSAV+1
49627 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
49628 K(NSAV+1,1)=3
49629 K(NSAV+3,1)=3
49630 K(NSAV+1,4)=MSTU(5)*(NSAV+3)
49631 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
49632 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
49633 K(NSAV+3,5)=MSTU(5)*(NSAV+1)
49634 MSTJ(92)=NSAV+1
49635 ENDIF
49636
49637C...Mark decayed particle; special option for B-Bbar mixing.
49638 IF(K(IP,1).EQ.5) K(IP,1)=15
49639 IF(K(IP,1).LE.10) K(IP,1)=11
49640 IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
49641 K(IP,4)=NSAV+1
49642 K(IP,5)=N
49643
49644 RETURN
49645 END
49646
49647
49648C*********************************************************************
49649
49650C...PYDCYK
49651C...Handles flavour production in the decay of unstable particles
49652C...and small string clusters.
49653
49654 SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF)
49655
49656C...Double precision and integer declarations.
49657 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49658 IMPLICIT INTEGER(I-N)
49659 INTEGER PYK,PYCHGE,PYCOMP
49660C...Commonblocks.
49661 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49662 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49663 SAVE /PYDAT1/,/PYDAT2/
49664
49665
49666C.. Call PYKFDI directly if no popcorn option is on
49667 IF(MSTJ(12).LT.2) THEN
49668 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
49669 MSTU(124)=KFL3
49670 RETURN
49671 ENDIF
49672
49673 KFL3=0
49674 KF=0
49675 IF(KFL1.EQ.0) RETURN
49676 KF1A=IABS(KFL1)
49677 KF2A=IABS(KFL2)
49678
49679 NSTO=130
49680 NMAX=MIN(MSTU(125),10)
49681
49682C.. Identify rank 0 cluster qq
49683 IRANK=1
49684 IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0
49685
49686 IF(KF2A.GT.0)THEN
49687C.. Join jets: Fails if store not empty
49688 IF(MSTU(121).GT.0) THEN
49689 MSTU(121)=0
49690 RETURN
49691 ENDIF
49692 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
49693 ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN
49694C.. Pick popcorn meson from store, return same qq, decrease store
49695 KF=MSTU(NSTO+MSTU(121))
49696 KFL3=-KFL1
49697 MSTU(121)=MSTU(121)-1
49698 ELSE
49699C.. Generate new flavour. Then done if no diquark is generated
49700 100 CALL PYKFDI(KFL1,0,KFL3,KF)
49701 IF(MSTU(121).EQ.-1) GOTO 100
49702 MSTU(124)=KFL3
49703 IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN
49704
49705C.. Simple case if no dynamical popcorn suppressions are considered
49706 IF(MSTJ(12).LT.4) THEN
49707 IF(MSTU(121).EQ.0) RETURN
49708 NMES=1
49709 KFPREV=-KFL3
49710 CALL PYKFDI(KFPREV,0,KFL3,KFM)
49711C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
49712 IF(IABS(KFL3).LE.10)THEN
49713 KFL3=-KFPREV
49714 RETURN
49715 ENDIF
49716 GOTO 120
49717 ENDIF
49718
49719C test output qq against fake Gamma, then return if no popcorn.
49720 GB=2D0
49721 IF(IRANK.NE.0)THEN
49722 CALL PYZDIS(1,2103,5D0,Z)
49723 GB=5D0*(1D0-Z)/Z
49724 IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN
49725 MSTU(121)=0
49726 GOTO 100
49727 ENDIF
49728 ENDIF
49729 IF(MSTU(121).EQ.0) RETURN
49730
49731C..Set store size memory. Pick fake dynamical variables of qq.
49732 NMES=MSTU(121)
49733 CALL PYPTDI(1,PX3,PY3)
49734 X=1D0
49735 POPM=0D0
49736 G=GB
49737 POPG=GB
49738
49739C.. Pick next popcorn meson, test with fake dynamical variables
49740 110 KFPREV=-KFL3
49741 PX1=-PX3
49742 PY1=-PY3
49743 CALL PYKFDI(KFPREV,0,KFL3,KFM)
49744 IF(MSTU(121).EQ.-1) GOTO 100
49745 CALL PYPTDI(KFL3,PX3,PY3)
49746 PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2
49747 CALL PYZDIS(KFPREV,KFL3,PM,Z)
49748 G=(1D0-Z)*(G+PM/Z)
49749 X=(1D0-Z)*X
49750
49751 PTST=1D0
49752 GTST=1D0
49753 RTST=PYR(0)
49754 IF(MSTJ(12).GT.4)THEN
49755 POPMN=SQRT((1D0-X)*(G/X-GB))
49756 POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
49757 PTST=EXP((POPM-POPMN)*PARF(193))
49758 POPM=POPMN
49759 ENDIF
49760 IF(IRANK.NE.0)THEN
49761 POPGN=X*GB
49762 GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG)
49763 POPG=POPGN
49764 ENDIF
49765 IF(RTST.GT.PTST*GTST)THEN
49766 MSTU(121)=0
49767 IF(RTST.GT.PTST) MSTU(121)=-1
49768 GOTO 100
49769 ENDIF
49770
49771C.. Store meson
49772 120 IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM
49773 IF(MSTU(121).GT.0) GOTO 110
49774
49775C.. Test accepted system size. If OK set global popcorn size variable.
49776 IF(NMES.GT.NMAX)THEN
49777 KF=0
49778 KFL3=0
49779 RETURN
49780 ENDIF
49781 MSTU(121)=NMES
49782 ENDIF
49783
49784 RETURN
49785 END
49786
49787C********************************************************************
49788
49789C...PYKFDI
49790C...Generates a new flavour pair and combines off a hadron
49791
49792 SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF)
49793
49794C...Double precision and integer declarations.
49795 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49796 IMPLICIT INTEGER(I-N)
49797 INTEGER PYK,PYCHGE,PYCOMP
49798C...Commonblocks.
49799 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49800 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49801 SAVE /PYDAT1/,/PYDAT2/
49802C...Local arrays.
49803 DIMENSION PD(7)
49804
49805 IF(MSTU(123).EQ.0.AND.MSTJ(12).GE.0) CALL PYKFIN
49806
49807C...Default flavour values. Input consistency checks.
49808 KF1A=IABS(KFL1)
49809 KF2A=IABS(KFL2)
49810 KFL3=0
49811 KF=0
49812 IF(KF1A.EQ.0) RETURN
49813 IF(KF2A.NE.0)THEN
49814 IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
49815 IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
49816 IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
49817 ENDIF
49818
49819C...Check if tabulated flavour probabilities are to be used.
49820 IF(MSTJ(15).EQ.1) THEN
49821 IF(MSTJ(12).GE.5) CALL PYERRM(29,
49822 & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
49823 & ' together with MSTJ(12)>=5 modification')
49824 KTAB1=-1
49825 IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
49826 KFL1A=MOD(KF1A/1000,10)
49827 KFL1B=MOD(KF1A/100,10)
49828 KFL1S=MOD(KF1A,10)
49829 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
49830 & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
49831 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
49832 IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
49833 KTAB2=0
49834 IF(KF2A.NE.0) THEN
49835 KTAB2=-1
49836 IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
49837 KFL2A=MOD(KF2A/1000,10)
49838 KFL2B=MOD(KF2A/100,10)
49839 KFL2S=MOD(KF2A,10)
49840 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
49841 & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
49842 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
49843 ENDIF
49844 IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
49845 ENDIF
49846
49847C.. Recognize rank 0 diquark case
49848 100 IRANK=1
49849 KFDIQ=MAX(KF1A,KF2A)
49850 IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0
49851
49852C.. Join two flavours to meson or baryon. Test for popcorn.
49853 IF(KF2A.GT.0)THEN
49854 MBARY=0
49855 IF(KFDIQ.GT.10) THEN
49856 IF(IRANK.EQ.0.AND.MSTJ(12).LT.5)
49857 & CALL PYNMES(KFDIQ)
49858 IF(MSTU(121).NE.0) THEN
49859 MSTU(121)=0
49860 RETURN
49861 ENDIF
49862 MBARY=2
49863 ENDIF
49864 KFQOLD=KF1A
49865 KFQVER=KF2A
49866 GOTO 130
49867 ENDIF
49868
49869C.. Separate incoming flavours, curtain flavour consistency check
49870 KFIN=KFL1
49871 KFQOLD=KF1A
49872 KFQPOP=KF1A/10000
49873 IF(KF1A.GT.10)THEN
49874 KFIN=-KFL1
49875 KFL1A=MOD(KF1A/1000,10)
49876 KFL1B=MOD(KF1A/100,10)
49877 IF(IRANK.EQ.0)THEN
49878 QAWT=1D0
49879 IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4)
49880 IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4)
49881 KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0))
49882 ENDIF
49883 IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) THEN
49884 MSTU(121)=0
49885 RETURN
49886 ENDIF
49887 KFQOLD=KFL1A+KFL1B-KFQPOP
49888 ENDIF
49889
49890C...Meson/baryon choice. Set number of mesons if starting a popcorn
49891C...system.
49892 110 MBARY=0
49893 IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN
49894 IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN
49895 MBARY=1
49896 CALL PYNMES(0)
49897 ENDIF
49898 ELSEIF(KF1A.GT.10)THEN
49899 MBARY=2
49900 IF(IRANK.EQ.0) CALL PYNMES(KF1A)
49901 IF(MSTU(121).GT.0) MBARY=-1
49902 ENDIF
49903
49904C..x->H+q: Choose single vertex quark. Jump to form hadron.
49905 IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN
49906 KFQVER=1+INT((2D0+PARJ(2))*PYR(0))
49907 KFL3=ISIGN(KFQVER,-KFIN)
49908 GOTO 130
49909 ENDIF
49910
49911C..x->H+qq: (IDW=proper PARF position for diquark weights)
49912 IDW=160
49913 IF(MBARY.EQ.1)THEN
49914 IF(MSTU(121).EQ.0) IDW=150
49915 SQWT=PARF(IDW+1)
49916 IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121)
49917 KFQPOP=1+INT((2D0+SQWT)*PYR(0))
49918C.. Shift to s-curtain parameters if needed
49919 IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN
49920 PARF(194)=PARF(138)*PARF(139)
49921 PARF(193)=PARJ(8)+PARJ(9)
49922 ENDIF
49923 ENDIF
49924
49925C.. x->H+qq: Get vertex quark
49926 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
49927 IDW=MSTU(122)
49928 MSTU(121)=MSTU(121)-1
49929 IF(IDW.EQ.170) THEN
49930 IF(MSTU(121).EQ.0)THEN
49931 IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2)
49932 ELSE
49933 IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
49934 ENDIF
49935 ELSE
49936 IF(MSTU(121).EQ.0)THEN
49937 IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
49938 ELSE
49939 IPOS=3*5+5*4+MIN(KFQOLD-1,4)
49940 ENDIF
49941 ENDIF
49942 IPOS=200+30*IPOS+1
49943
49944 IMES=-1
49945 RMES=PYR(0)*PARF(194)
49946 120 IMES=IMES+1
49947 RMES=RMES-PARF(IPOS+IMES)
49948 IF(IMES.EQ.30) THEN
49949 MSTU(121)=-1
49950 KF=-111
49951 RETURN
49952 ENDIF
49953 IF(RMES.GT.0D0) GOTO 120
49954 KMUL=IMES/5
49955 KFJ=2*KMUL+1
49956 IF(KMUL.EQ.2) KFJ=10003
49957 IF(KMUL.EQ.3) KFJ=10001
49958 IF(KMUL.EQ.4) KFJ=20003
49959 IF(KMUL.EQ.5) KFJ=5
49960 IDIAG=0
49961 KFQVER=MOD(IMES,5)+1
49962 IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1
49963 IF(KFQVER.GT.3)THEN
49964 IDIAG=KFQVER-3
49965 KFQVER=KFQOLD
49966 ENDIF
49967 ELSE
49968 IF(MBARY.EQ.-1) IDW=170
49969 SQWT=PARF(IDW+2)
49970 IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3)
49971 IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0
49972 KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0)))
49973 IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN
49974 KFQVER=KFQPOP
49975 IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP
49976 ENDIF
49977 ENDIF
49978
49979C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
49980 KFLDS=3
49981 IF(KFQPOP.NE.KFQVER)THEN
49982 SWT=PARF(IDW+7)
49983 IF(KFQVER.EQ.3) SWT=PARF(IDW+6)
49984 IF(KFQPOP.GE.3) SWT=PARF(IDW+5)
49985 IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1
49986 ENDIF
49987 KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS
49988 & +10000*KFQPOP
49989 KFL3=ISIGN(KFDIQ,KFIN)
49990
49991C..x->M+y: flavour for meson.
49992 130 IF(MBARY.LE.0)THEN
49993 KFLA=MAX(KFQOLD,KFQVER)
49994 KFLB=MIN(KFQOLD,KFQVER)
49995 KFS=ISIGN(1,KFL1)
49996 IF(KFLA.NE.KFQOLD) KFS=-KFS
49997C... Form meson, with spin and flavour mixing for diagonal states.
49998 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
49999 IF(IDIAG.GT.0) KF=110*IDIAG+KFJ
50000 IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA
50001 RETURN
50002 ENDIF
50003 IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0))
50004 IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0))
50005 IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0))
50006 IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN
50007 IF(PYR(0).LT.PARJ(14)) KMUL=2
50008 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN
50009 RMUL=PYR(0)
50010 IF(RMUL.LT.PARJ(15)) KMUL=3
50011 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
50012 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
50013 ENDIF
50014 KFLS=3
50015 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
50016 IF(KMUL.EQ.5) KFLS=5
50017 IF(KFLA.NE.KFLB)THEN
50018 KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
50019 ELSE
50020 RMIX=PYR(0)
50021 IMIX=2*KFLA+10*KMUL
50022 IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
50023 & INT(RMIX+PARF(IMIX)))+KFLS
50024 IF(KFLA.GE.4) KF=110*KFLA+KFLS
50025 ENDIF
50026 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
50027 IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
50028
50029C..Optional extra suppression of eta and eta'.
50030C..Allow shift to qq->B+q in old version (set IRANK to 0)
50031 IF(KF.EQ.221.OR.KF.EQ.331)THEN
50032 IF(PYR(0).GT.PARJ(25+KF/300))THEN
50033 IF(KF2A.GT.0) GOTO 130
50034 IF(MSTJ(12).LT.4) IRANK=0
50035 GOTO 110
50036 ENDIF
50037 ENDIF
50038 MSTU(121)=0
50039
50040C.. x->B+y: Flavour for baryon
50041 ELSE
50042 KFLA=KFQVER
50043 IF(KF1A.LE.10) KFLA=KFQOLD
50044 KFLB=MOD(KFDIQ/1000,10)
50045 KFLC=MOD(KFDIQ/100,10)
50046 KFLDS=MOD(KFDIQ,10)
50047 KFLD=MAX(KFLA,KFLB,KFLC)
50048 KFLF=MIN(KFLA,KFLB,KFLC)
50049 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
50050
50051C... SU(6) factors for formation of baryon.
50052 KBARY=3
50053 KDMAX=5
50054 KFLG=KFLB
50055 IF(KFLB.NE.KFLC)THEN
50056 KBARY=2*KFLDS-1
50057 KDMAX=1+KFLDS/2
50058 IF(KFLB.GT.2) KDMAX=KDMAX+2
50059 ENDIF
50060 IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN
50061 KBARY=KBARY+1
50062 KFLG=KFLA
50063 ENDIF
50064
50065 SU6MAX=PARF(140+KDMAX)
50066 SU6DEC=PARJ(18)
50067 SU6S =PARF(146)
50068 IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN
50069 SU6MAX=1D0
50070 SU6DEC=1D0
50071 SU6S =1D0
50072 ENDIF
50073 SU6OCT=PARF(60+KBARY)
50074 IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN
50075 SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1)
50076 IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1)
50077 ELSE
50078 IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1)
50079 ENDIF
50080 SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY)
50081
50082C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
50083 IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN
50084 MSTU(121)=0
50085 IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1
50086 GOTO 110
50087 ENDIF
50088
50089C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
50090 KSIG=1
50091 KFLS=2
50092 IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4
50093 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN
50094 KSIG=KFLDS/3
50095 IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0))
50096 ENDIF
50097 KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
50098 IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
50099 ENDIF
aabcdb29 50100C -------------------------------------------------------------------------
50101C Extracted from a private e-mail exchange with Torbjorn Sjostrand
50102C
50103C No, Lambda(1520) is not included and not foreseen.
50104C So if you want it in Pythia, it would have to be a hack.
50105C What you could do is:
50106C 1) In PYKFDI, just before the RETURN above label 140, you could check if
50107C a Lambda, Sigma0 or Sigma*0 has been produced, and with some small
50108C probability switch such a particle to the Lambda(1520) code. That is,
50109C if KF = 3122, 3212, or 3214 and a random number below some number, switch
50110C to KF = 3124. (And correspondingly for anticparticles.)
50111C 2) Use the PYUPDA routine (see manual) to include particle and decay data
50112C for the Lambda(1520).
50113C -------------------------------------------------------------------------
50114
7f9bf696 50115C IF (IABS(KF).EQ.3122) THEN
aabcdb29 50116C Converting a fraction (0.20) of Lambda0 to Lambda(1520) + c.c.
50117C This fraction is based on the experimental measurement at ISR
50118C Bobbink 83, NP B217,11 (1983)
50119C The region 0.5 < XF < 1.0 has been extrapolated to XF=0
7f9bf696 50120C IF(PYR(0).LE.0.20) KF=ISIGN(3124,KF)
50121C ENDIF
aabcdb29 50122
7f9bf696 50123C IF(IABS(KF).EQ.3212) THEN
aabcdb29 50124C Converting a fraction (0.20) of Sigma0 to Lambda(1520) + c.c.
50125C We suppose the same fraction as for Lambda0
7f9bf696 50126C IF(PYR(0).LE.0.20) KF=ISIGN(3124,KF)
50127C ENDIF
aabcdb29 50128
7f9bf696 50129C IF (IABS(KF).EQ.3214) THEN
aabcdb29 50130C Converting a fraction (0.30) of Sigma0(1385) to Lambda(1520) + c.c.
50131C This is conservative extimate supposing that the ratio
50132C scales as (M_Sigma1385/M_Lambda0)^2 ~ 1.5
7f9bf696 50133C IF(PYR(0).LE.0.30) KF=ISIGN(3124,KF)
50134C ENDIF
2dfa57d1 50135 RETURN
50136
50137C...Use tabulated probabilities to select new flavour and hadron.
50138 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
50139 KT3L=1
50140 KT3U=6
50141 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
50142 KT3L=1
50143 KT3U=6
50144 ELSEIF(KTAB2.EQ.0) THEN
50145 KT3L=1
50146 KT3U=22
50147 ELSE
50148 KT3L=KTAB2
50149 KT3U=KTAB2
50150 ENDIF
50151 RFL=0D0
50152 DO 160 KTS=0,2
50153 DO 150 KT3=KT3L,KT3U
50154 RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
50155 150 CONTINUE
50156 160 CONTINUE
50157 RFL=PYR(0)*RFL
50158 DO 180 KTS=0,2
50159 KTABS=KTS
50160 DO 170 KT3=KT3L,KT3U
50161 KTAB3=KT3
50162 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
50163 IF(RFL.LE.0D0) GOTO 190
50164 170 CONTINUE
50165 180 CONTINUE
50166 190 CONTINUE
50167
50168C...Reconstruct flavour of produced quark/diquark.
50169 IF(KTAB3.LE.6) THEN
50170 KFL3A=KTAB3
50171 KFL3B=0
50172 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
50173 ELSE
50174 KFL3A=1
50175 IF(KTAB3.GE.8) KFL3A=2
50176 IF(KTAB3.GE.11) KFL3A=3
50177 IF(KTAB3.GE.16) KFL3A=4
50178 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
50179 KFL3=1000*KFL3A+100*KFL3B+1
50180 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
50181 & KFL3+2
50182 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
50183 ENDIF
50184
50185C...Reconstruct meson code.
50186 IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
50187 &KFL3B.NE.0)) THEN
50188 RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
50189 & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
50190 KF=110+2*KTABS+1
50191 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
50192 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
50193 & 25*KTABS)) KF=330+2*KTABS+1
50194 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
50195 KFLA=MAX(KTAB1,KTAB3)
50196 KFLB=MIN(KTAB1,KTAB3)
50197 KFS=ISIGN(1,KFL1)
50198 IF(KFLA.NE.KF1A) KFS=-KFS
50199 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
50200 ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
50201 KFS=ISIGN(1,KFL1)
50202 IF(KFL1A.EQ.KFL3A) THEN
50203 KFLA=MAX(KFL1B,KFL3B)
50204 KFLB=MIN(KFL1B,KFL3B)
50205 IF(KFLA.NE.KFL1B) KFS=-KFS
50206 ELSEIF(KFL1A.EQ.KFL3B) THEN
50207 KFLA=KFL3A
50208 KFLB=KFL1B
50209 KFS=-KFS
50210 ELSEIF(KFL1B.EQ.KFL3A) THEN
50211 KFLA=KFL1A
50212 KFLB=KFL3B
50213 ELSEIF(KFL1B.EQ.KFL3B) THEN
50214 KFLA=MAX(KFL1A,KFL3A)
50215 KFLB=MIN(KFL1A,KFL3A)
50216 IF(KFLA.NE.KFL1A) KFS=-KFS
50217 ELSE
50218 CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq')
50219 GOTO 100
50220 ENDIF
50221 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
50222
50223C...Reconstruct baryon code.
50224 ELSE
50225 IF(KTAB1.GE.7) THEN
50226 KFLA=KFL3A
50227 KFLB=KFL1A
50228 KFLC=KFL1B
50229 ELSE
50230 KFLA=KFL1A
50231 KFLB=KFL3A
50232 KFLC=KFL3B
50233 ENDIF
50234 KFLD=MAX(KFLA,KFLB,KFLC)
50235 KFLF=MIN(KFLA,KFLB,KFLC)
50236 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
50237 IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
50238 IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
50239 ENDIF
50240
50241C...Check that constructed flavour code is an allowed one.
50242 IF(KFL2.NE.0) KFL3=0
50243 KC=PYCOMP(KF)
50244 IF(KC.EQ.0) THEN
50245 CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '//
50246 & 'failed')
50247 GOTO 100
50248 ENDIF
50249
50250 RETURN
50251 END
50252
50253C*********************************************************************
50254
50255C...PYNMES
50256C...Generates number of popcorn mesons and stores some relevant
50257C...parameters.
50258
50259 SUBROUTINE PYNMES(KFDIQ)
50260
50261C...Double precision and integer declarations.
50262 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50263 IMPLICIT INTEGER(I-N)
50264 INTEGER PYK,PYCHGE,PYCOMP
50265C...Commonblocks.
50266 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50267 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50268 SAVE /PYDAT1/,/PYDAT2/
50269
50270 MSTU(121)=0
50271 IF(MSTJ(12).LT.2) RETURN
50272
50273C..Old version: Get 1 or 0 popcorn mesons
50274 IF(MSTJ(12).LT.5)THEN
50275 POPWT=PARF(131)
50276 IF(KFDIQ.NE.0) THEN
50277 KFDIQA=IABS(KFDIQ)
50278 KFA=MOD(KFDIQA/1000,10)
50279 KFB=MOD(KFDIQA/100,10)
50280 KFS=MOD(KFDIQA,10)
50281 POPWT=PARF(132)
50282 IF(KFA.EQ.3) POPWT=PARF(133)
50283 IF(KFB.EQ.3) POPWT=PARF(134)
50284 IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4))
50285 ENDIF
50286 MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0))
50287 RETURN
50288 ENDIF
50289
50290C..New version: Store popcorn- or rank 0 diquark parameters
50291 MSTU(122)=170
50292 PARF(193)=PARJ(8)
50293 PARF(194)=PARF(139)
50294 IF(KFDIQ.NE.0) THEN
50295 MSTU(122)=180
50296 PARF(193)=PARJ(10)
50297 PARF(194)=PARF(140)
50298 ENDIF
50299 IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN
50300 IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9,
50301 & '(PYNMES:) Neglecting too large popcorn possibility')
50302 RETURN
50303 ENDIF
50304
50305C..New version: Get number of popcorn mesons
50306 100 RTST=PYR(0)
50307 MSTU(121)=-1
50308 110 MSTU(121)=MSTU(121)+1
50309 RTST=RTST/PARF(194)
50310 IF(RTST.LT.1D0) GOTO 110
50311 IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)*PARF(161)).GT.
50312 & (2D0+PARF(135)*PARF(161)*PARF(138)**MSTU(121))) GOTO 100
50313 RETURN
50314 END
50315
50316C***************************************************************
50317
50318C...PYKFIN
50319C...Precalculates a set of diquark and popcorn weights.
50320
50321 SUBROUTINE PYKFIN
50322
50323C...Double precision and integer declarations.
50324 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50325 IMPLICIT INTEGER(I-N)
50326 INTEGER PYK,PYCHGE,PYCOMP
50327C...Commonblocks.
50328 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50329 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50330 SAVE /PYDAT1/,/PYDAT2/
50331
50332 DIMENSION SU6(12),SU6M(7),QBB(7),QBM(7),DMB(14)
50333
50334
50335 MSTU(123)=1
50336C..Diquark indices for dimensional variables
50337 IUD1=1
50338 IUU1=2
50339 IUS0=3
50340 ISU0=4
50341 IUS1=5
50342 ISU1=6
50343 ISS1=7
50344
50345C.. *** SU(6) factors **
50346C..Modify with decuplet- (and Sigma/Lambda-) suppression.
50347 PARF(146)=1D0
50348 IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0)
50349 IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9,
50350 & '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
50351 DO 100 I=1,6
50352 SU6(I)=PARF(60+I)
50353 SU6(6+I)=SU6(I)*4*PARF(146)/(3*PARF(146)+1)
50354 100 CONTINUE
50355 SU6(8)=SU6(2)*4/(3*PARF(146)+1)
50356 SU6(6)=SU6(6)*(3+PARF(146))/(3*PARF(146)+1)
50357 DO 110 I=1,6
50358 SU6(I)=SU6(I)+PARJ(18)*PARF(70+I)
50359 SU6(6+I)=SU6(6+I)+PARJ(18)*PARF(70+I)
50360 110 CONTINUE
50361
50362C..SU(6)max q q' s,c,b
50363 SU6MUD =MAX(SU6(1) , SU6(8) )
50364 SU6M(IUD1)=MAX(SU6(5) , SU6(12))
50365 SU6M(ISU0)=MAX(SU6(7) ,SU6(2),SU6MUD )
50366 SU6M(IUU1)=MAX(SU6(3) ,SU6(4),SU6(10))
50367 SU6M(ISU1)=MAX(SU6(11),SU6(6),SU6M(IUD1))
50368 SU6M(IUS0)=SU6M(ISU0)
50369 SU6M(ISS1)=SU6M(IUU1)
50370 SU6M(IUS1)=SU6M(ISU1)
50371
50372C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
50373 PARF(141)=SU6MUD
50374 PARF(142)=SU6M(IUD1)
50375 PARF(143)=SU6M(ISU0)
50376 PARF(144)=SU6M(ISU1)
50377 PARF(145)=SU6M(ISS1)
50378
50379C..diquark SU(6) survival =
50380C..sum over quark (quark tunnel weight)*(SU(6)).
50381 PUD0=(2D0*SU6(1)+PARJ(2)*SU6(8))
50382 DMB(ISU0)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
50383 DMB(IUS0)=DMB(ISU0)
50384 DMB(ISS1)=(2D0*SU6(4)+PARJ(2)*SU6(3))/PUD0
50385 DMB(IUU1)=(SU6(3)+SU6(4)+PARJ(2)*SU6(10))/PUD0
50386 DMB(ISU1)=(SU6(11)+SU6(6)+PARJ(2)*SU6(5))/PUD0
50387 DMB(IUS1)=DMB(ISU1)
50388 DMB(IUD1)=(2D0*SU6(5)+PARJ(2)*SU6(12))/PUD0
50389
50390C.. *** Tunneling factors for Diquark production***
50391C.. T: half a curtain pair = sqrt(curtain pair factor)
50392 IF(MSTJ(12).GE.5) THEN
50393 PMUD0=PYMASS(2101)
50394 PMUD1=PYMASS(2103)-PMUD0
50395 PMUS0=PYMASS(3201)-PMUD0
50396 PMUS1=PYMASS(3203)-PMUS0-PMUD0
50397 PMSS1=PYMASS(3303)-PMUS0-PMUD0
50398 QBB(ISU0)=EXP(-(PARJ(9)+PARJ(8))*PMUS0-PARJ(9)*PARF(191))
50399 QBB(IUS0)=EXP(-PARJ(8)*PMUS0)
50400 QBB(ISS1)=EXP(-(PARJ(9)+PARJ(8))*PMSS1)*QBB(ISU0)
50401 QBB(IUU1)=EXP(-PARJ(8)*PMUD1)
50402 QBB(ISU1)=EXP(-(PARJ(9)+PARJ(8))*PMUS1)*QBB(ISU0)
50403 QBB(IUS1)=EXP(-PARJ(8)*PMUS1)*QBB(IUS0)
50404 QBB(IUD1)=QBB(IUU1)
50405 ELSE
50406 PAR2M=SQRT(PARJ(2))
50407 PAR3M=SQRT(PARJ(3))
50408 PAR4M=SQRT(PARJ(4))
50409 QBB(ISU0)=PAR2M*PAR3M
50410 QBB(IUS0)=PAR3M
50411 QBB(ISS1)=PAR2M*PARJ(3)*PAR4M
50412 QBB(IUU1)=PAR4M
50413 QBB(ISU1)=PAR4M*QBB(ISU0)
50414 QBB(IUS1)=PAR4M*QBB(IUS0)
50415 QBB(IUD1)=PAR4M
50416 ENDIF
50417
50418C.. tau: spin*(vertex factor)*(T = half-curtain factor)
50419 QBM(ISU0)=QBB(ISU0)
50420 QBM(IUS0)=PARJ(2)*QBB(IUS0)
50421 QBM(ISS1)=PARJ(2)*6D0*QBB(ISS1)
50422 QBM(IUU1)=6D0*QBB(IUU1)
50423 QBM(ISU1)=3D0*QBB(ISU1)
50424 QBM(IUS1)=PARJ(2)*3D0*QBB(IUS1)
50425 QBM(IUD1)=3D0*QBB(IUD1)
50426
50427C.. Combine T and tau to diquark weight for q-> B+B+..
50428 DO 120 I=1,7
50429 QBB(I)=QBB(I)*QBM(I)
50430 120 CONTINUE
50431
50432 IF(MSTJ(12).GE.5)THEN
50433C..New version: tau for rank 0 diquark.
50434 DMB(7+ISU0)=EXP(-PARJ(10)*PMUS0)
50435 DMB(7+IUS0)=PARJ(2)*DMB(7+ISU0)
50436 DMB(7+ISS1)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*DMB(7+ISU0)
50437 DMB(7+IUU1)=6D0*EXP(-PARJ(10)*PMUD1)
50438 DMB(7+ISU1)=3D0*EXP(-PARJ(10)*PMUS1)*DMB(7+ISU0)
50439 DMB(7+IUS1)=PARJ(2)*DMB(7+ISU1)
50440 DMB(7+IUD1)=DMB(7+IUU1)/2D0
50441
50442C..New version: curtain flavour ratios.
50443C.. s/u for q->B+M+...
50444C.. s/u for rank 0 diquark: su -> ...M+B+...
50445C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
50446 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
50447 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
50448 WU=1D0+DMB(7+IUD1)+DMB(7+IUS0)+DMB(7+IUS1)+DMB(7+IUU1)
50449 PARF(136)=(2D0*(DMB(7+ISU0)+DMB(7+ISU1))+DMB(7+ISS1))/WU
50450 PARF(137)=(DMB(7+ISU0)+DMB(7+ISU1))*
50451 & (2D0+DMB(7+ISS1)/(2D0*DMB(7+ISU1)))/WU
50452 ELSE
50453C..Old version: reset unused rank 0 diquark weights and
50454C.. unused diquark SU(6) survival weights
50455 DO 130 I=1,7
50456 IF(MSTJ(12).LT.3) DMB(I)=1D0
50457 DMB(7+I)=1D0
50458 130 CONTINUE
50459
50460C..Old version: Shuffle PARJ(7) into tau
50461 QBM(IUS0)=QBM(IUS0)*PARJ(7)
50462 QBM(ISS1)=QBM(ISS1)*PARJ(7)
50463 QBM(IUS1)=QBM(IUS1)*PARJ(7)
50464
50465C..Old version: curtain flavour ratios.
50466C.. s/u for q->B+M+...
50467C.. s/u for rank 0 diquark: su -> ...M+B+...
50468C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
50469 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
50470 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
50471 PARF(136)=PARF(135)*PARJ(6)*QBM(ISU0)/QBM(IUS0)
50472 PARF(137)=(1D0+QBM(IUD1))*(2D0+QBM(IUS0))/WU
50473 ENDIF
50474
50475C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for:
50476C.. rank0 D->M+B+..; D->M+B+..; q->B+M+..; q->B+B..
50477 DO 140 I=1,7
50478 DMB(7+I)=DMB(7+I)*DMB(I)
50479 DMB(I)=DMB(I)*QBM(I)
50480 QBM(I)=QBM(I)*SU6M(I)/SU6MUD
50481 QBB(I)=QBB(I)*SU6M(I)/SU6MUD
50482 140 CONTINUE
50483
50484C.. *** Popcorn factors ***
50485
50486 IF(MSTJ(12).LT.5)THEN
50487C.. Old version: Resulting popcorn weights.
50488 PARF(138)=PARJ(6)
50489 WS=PARF(135)*PARF(138)
50490 WQ=WU*PARJ(5)/3D0
50491 PARF(132)=WQ*QBM(IUD1)/QBB(IUD1)
50492 PARF(133)=WQ*
50493 & (QBM(IUS1)/QBB(IUS1)+WS*QBM(ISU1)/QBB(ISU1))/2D0
50494 PARF(134)=WQ*WS*QBM(ISS1)/QBB(ISS1)
50495 PARF(131)=WQ*(1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1)+
50496 & WS*(QBM(ISU0)+QBM(ISU1)+QBM(ISS1)/2D0))/
50497 & (1D0+QBB(IUD1)+QBB(IUU1)+
50498 & 2D0*(QBB(IUS0)+QBB(IUS1))+QBB(ISS1)/2D0)
50499 ELSE
50500C..New version: Store weights for popcorn mesons,
50501C..get prel. popcorn weights.
50502 DO 150 IPOS=201,1400
50503 PARF(IPOS)=0D0
50504 150 CONTINUE
50505 DO 160 I=138,140
50506 PARF(I)=0D0
50507 160 CONTINUE
50508 IPOS=200
50509 PARF(193)=PARJ(8)
50510 DO 240 MR=0,7,7
50511 IF(MR.EQ.7) PARF(193)=PARJ(10)
50512 SQWT=2D0*(DMB(MR+IUS0)+DMB(MR+IUS1))/
50513 & (1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
50514 QQWT=DMB(MR+IUU1)/(1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
50515 DO 230 NMES=0,1
50516 IF(NMES.EQ.1) SQWT=PARJ(2)
50517 DO 220 KFQPOP=1,4
50518 IF(MR.EQ.0.AND.KFQPOP.GT.3) GOTO 220
50519 IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN
50520 SQWT=DMB(MR+ISS1)/(DMB(MR+ISU0)+DMB(MR+ISU1))
50521 QQWT=0.5D0
50522 IF(MR.EQ.0) PARF(193)=PARJ(8)+PARJ(9)
50523 IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/DMB(7+ISU1)+1D0)/2D0
50524 ENDIF
50525 DO 210 KFQOLD =1,5
50526 IF(MR.EQ.0.AND.KFQOLD.GT.3) GOTO 210
50527 IF(NMES.EQ.1) THEN
50528 IF(MR.EQ.0.AND.KFQPOP.EQ.1) GOTO 210
50529 IF(MR.EQ.7.AND.KFQPOP.NE.1) GOTO 210
50530 ENDIF
50531 WTTOT=0D0
50532 WTFAIL=0D0
50533 DO 190 KMUL=0,5
50534 PJWT=PARJ(12+KMUL)
50535 IF(KMUL.EQ.0) PJWT=1D0-PARJ(14)
50536 IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17)
50537 IF(PJWT.LE.0D0) GOTO 190
50538 IF(PJWT.GT.1D0) PJWT=1D0
50539 IMES=5*KMUL
50540 IMIX=2*KFQOLD+10*KMUL
50541 KFJ=2*KMUL+1
50542 IF(KMUL.EQ.2) KFJ=10003
50543 IF(KMUL.EQ.3) KFJ=10001
50544 IF(KMUL.EQ.4) KFJ=20003
50545 IF(KMUL.EQ.5) KFJ=5
50546 DO 180 KFQVER =1,3
50547 KFLA=MAX(KFQOLD,KFQVER)
50548 KFLB=MIN(KFQOLD,KFQVER)
50549 SWT=PARJ(11+KFLA/3+KFLA/4)
50550 IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT
50551 SWT=SWT*PJWT
50552 QWT=SQWT/(2D0+SQWT)
50553 IF(KFQVER.LT.3)THEN
50554 IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT
50555 IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT)
50556 ENDIF
50557 IF(KFQVER.NE.KFQOLD)THEN
50558 IMES=IMES+1
50559 KFM=100*KFLA+10*KFLB+KFJ
50560 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
50561 PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM)
50562 WTTOT=WTTOT+PARF(IPOS+IMES)
50563 ELSE
50564 DO 170 ID=3,5
50565 IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1)
50566 IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX)
50567 IF(ID.EQ.5) DWT=PARF(IMIX)
50568 KFM=110*(ID-2)+KFJ
50569 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
50570 PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM)
50571 IF(KMUL.EQ.0.AND.ID.GT.3) THEN
50572 WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID))
50573 PARF(IPOS+5*KMUL+ID)=
50574 & PARF(IPOS+5*KMUL+ID)*PARJ(21+ID)
50575 ENDIF
50576 WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID)
50577 170 CONTINUE
50578 ENDIF
50579 180 CONTINUE
50580 190 CONTINUE
50581 DO 200 IMES=1,30
50582 PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL)
50583 200 CONTINUE
50584 IF(MR.EQ.7) PARF(140)=
50585 & MAX(PARF(140),WTTOT/(1D0-WTFAIL))
50586 IF(MR.EQ.0) PARF(139-KFQPOP/3)=
50587 & MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL))
50588 IPOS=IPOS+30
50589 210 CONTINUE
50590 220 CONTINUE
50591 230 CONTINUE
50592 240 CONTINUE
50593 IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139)
50594 MSTU(121)=0
50595
50596 ENDIF
50597
50598C..Recombine diquark weights to flavour and spin ratios
50599 PARF(151)=(2D0*(QBB(ISU0)+QBB(ISU1))+QBB(ISS1))/
50600 & (1D0+QBB(IUD1)+QBB(IUU1)+QBB(IUS0)+QBB(IUS1))
50601 PARF(152)=2D0*(QBB(IUS0)+QBB(IUS1))/(1D0+QBB(IUD1)+QBB(IUU1))
50602 PARF(153)=QBB(ISS1)/(QBB(ISU0)+QBB(ISU1))
50603 PARF(154)=QBB(IUU1)/(1D0+QBB(IUD1)+QBB(IUU1))
50604 PARF(155)=QBB(ISU1)/QBB(ISU0)
50605 PARF(156)=QBB(IUS1)/QBB(IUS0)
50606 PARF(157)=QBB(IUD1)
50607
50608 PARF(161)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/
50609 & (1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1))
50610 PARF(162)=2D0*(QBM(IUS0)+QBM(IUS1))/(1D0+QBM(IUD1)+QBM(IUU1))
50611 PARF(163)=QBM(ISS1)/(QBM(ISU0)+QBM(ISU1))
50612 PARF(164)=QBM(IUU1)/(1D0+QBM(IUD1)+QBM(IUU1))
50613 PARF(165)=QBM(ISU1)/QBM(ISU0)
50614 PARF(166)=QBM(IUS1)/QBM(IUS0)
50615 PARF(167)=QBM(IUD1)
50616
50617 PARF(171)=(2D0*(DMB(ISU0)+DMB(ISU1))+DMB(ISS1))/
50618 & (1D0+DMB(IUD1)+DMB(IUU1)+DMB(IUS0)+DMB(IUS1))
50619 PARF(172)=2D0*(DMB(IUS0)+DMB(IUS1))/(1D0+DMB(IUD1)+DMB(IUU1))
50620 PARF(173)=DMB(ISS1)/(DMB(ISU0)+DMB(ISU1))
50621 PARF(174)=DMB(IUU1)/(1D0+DMB(IUD1)+DMB(IUU1))
50622 PARF(175)=DMB(ISU1)/DMB(ISU0)
50623 PARF(176)=DMB(IUS1)/DMB(IUS0)
50624 PARF(177)=DMB(IUD1)
50625
50626 PARF(185)=DMB(7+ISU1)/DMB(7+ISU0)
50627 PARF(186)=DMB(7+IUS1)/DMB(7+IUS0)
50628 PARF(187)=DMB(7+IUD1)
50629
50630 RETURN
50631 END
50632
50633
50634C*********************************************************************
50635
50636C...PYPTDI
50637C...Generates transverse momentum according to a Gaussian.
50638
50639 SUBROUTINE PYPTDI(KFL,PX,PY)
50640
50641C...Double precision and integer declarations.
50642 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50643 IMPLICIT INTEGER(I-N)
50644 INTEGER PYK,PYCHGE,PYCOMP
50645C...Commonblocks.
50646 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50647 SAVE /PYDAT1/
50648
50649C...Generate p_T and azimuthal angle, gives p_x and p_y.
50650 KFLA=IABS(KFL)
50651 PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0))))
50652 IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT
50653 IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
50654 IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0
50655 PHI=PARU(2)*PYR(0)
50656 PX=PT*COS(PHI)
50657 PY=PT*SIN(PHI)
50658
50659 RETURN
50660 END
50661
50662C*********************************************************************
50663
50664C...PYZDIS
50665C...Generates the longitudinal splitting variable z.
50666
50667 SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z)
50668
50669C...Double precision and integer declarations.
50670 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50671 IMPLICIT INTEGER(I-N)
50672 INTEGER PYK,PYCHGE,PYCOMP
50673C...Commonblocks.
50674 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50675 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50676 SAVE /PYDAT1/,/PYDAT2/
50677
50678C...Check if heavy flavour fragmentation.
50679 KFLA=IABS(KFL1)
50680 KFLB=IABS(KFL2)
50681 KFLH=KFLA
50682 IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
50683
50684C...Lund symmetric scaling function: determine parameters of shape.
50685 IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
50686 &MSTJ(11).GE.4) THEN
50687 FA=PARJ(41)
50688 IF(MSTJ(91).EQ.1) FA=PARJ(43)
50689 IF(KFLB.GE.10) FA=FA+PARJ(45)
50690 FBB=PARJ(42)
50691 IF(MSTJ(91).EQ.1) FBB=PARJ(44)
50692 FB=FBB*PR
50693 FC=1D0
50694 IF(KFLA.GE.10) FC=FC-PARJ(45)
50695 IF(KFLB.GE.10) FC=FC+PARJ(45)
50696 IF(MSTJ(11).GE.4.AND.(KFLH.EQ.4.OR.KFLH.EQ.5)) THEN
50697 FRED=PARJ(46)
50698 IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
50699 FC=FC+FRED*FBB*PARF(100+KFLH)**2
50700 ENDIF
50701 MC=1
50702 IF(ABS(FC-1D0).GT.0.01D0) MC=2
50703
50704C...Determine position of maximum. Special cases for a = 0 or a = c.
50705 IF(FA.LT.0.02D0) THEN
50706 MA=1
50707 ZMAX=1D0
50708 IF(FC.GT.FB) ZMAX=FB/FC
50709 ELSEIF(ABS(FC-FA).LT.0.01D0) THEN
50710 MA=2
50711 ZMAX=FB/(FB+FC)
50712 ELSE
50713 MA=3
50714 ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA)
50715 IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB)
50716 ENDIF
50717
50718C...Subdivide z range if distribution very peaked near endpoint.
50719 MMAX=2
50720 IF(ZMAX.LT.0.1D0) THEN
50721 MMAX=1
50722 ZDIV=2.75D0*ZMAX
50723 IF(MC.EQ.1) THEN
50724 FINT=1D0-LOG(ZDIV)
50725 ELSE
50726 ZDIVC=ZDIV**(1D0-FC)
50727 FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0)
50728 ENDIF
50729 ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN
50730 MMAX=3
50731 FSCB=SQRT(4D0+(FC/FB)**2)
50732 ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB))
50733 IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX)
50734 ZDIV=MIN(ZMAX,MAX(0D0,ZDIV))
50735 FINT=1D0+FB*(1D0-ZDIV)
50736 ENDIF
50737
50738C...Choice of z, preweighted for peaks at low or high z.
50739 100 Z=PYR(0)
50740 FPRE=1D0
50741 IF(MMAX.EQ.1) THEN
50742 IF(FINT*PYR(0).LE.1D0) THEN
50743 Z=ZDIV*Z
50744 ELSEIF(MC.EQ.1) THEN
50745 Z=ZDIV**Z
50746 FPRE=ZDIV/Z
50747 ELSE
50748 Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC))
50749 FPRE=(ZDIV/Z)**FC
50750 ENDIF
50751 ELSEIF(MMAX.EQ.3) THEN
50752 IF(FINT*PYR(0).LE.1D0) THEN
50753 Z=ZDIV+LOG(Z)/FB
50754 FPRE=EXP(FB*(Z-ZDIV))
50755 ELSE
50756 Z=ZDIV+Z*(1D0-ZDIV)
50757 ENDIF
50758 ENDIF
50759
50760C...Weighting according to correct formula.
50761 IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100
50762 FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z)
50763 IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX))
50764 FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP)))
50765 IF(FVAL.LT.PYR(0)*FPRE) GOTO 100
50766
50767C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
50768 ELSE
50769 FC=PARJ(50+MAX(1,KFLH))
50770 IF(MSTJ(91).EQ.1) FC=PARJ(59)
50771 110 Z=PYR(0)
50772 IF(FC.GE.0D0.AND.FC.LE.1D0) THEN
50773 IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0)
50774 ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN
50775 IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2)
50776 & GOTO 110
50777 ELSE
50778 IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
50779 IF(FC.LT.0D0) Z=Z**(-1D0/FC)
50780 ENDIF
50781 ENDIF
50782
50783 RETURN
50784 END
50785
50786C*********************************************************************
50787
50788C...PYSHOW
50789C...Generates timelike parton showers from given partons.
50790
50791 SUBROUTINE PYSHOW(IP1,IP2,QMAX)
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...Parameter statement to help give large particle numbers.
50798 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50799 &KEXCIT=4000000,KDIMEN=5000000)
50800C...Commonblocks.
50801 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
50802 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50803 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50804 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
50805C...Local arrays.
50806 DIMENSION PMTH(5,50),PS(5),PMA(19),PMSD(10),IEP(10),IPA(10),
50807 &KFLA(10),KFLD(10),KFL(10),ITRY(10),ISI(10),ISL(10),DP(10),
50808 &DPT(5,4),KSH(0:40),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),
50809 &PHIIIS(2,2),ISII(2),ISSET(3),ISCOL(0:40),ISCHG(0:40),
50810 &IREF(1000)
50811
50812C...Check that QMAX not too low.
50813 IF(MSTJ(41).LE.0) THEN
50814 RETURN
50815 ELSEIF(MSTJ(41).EQ.1) THEN
50816 IF(QMAX.LE.PARJ(82).AND.IP2.GT.-8) RETURN
50817 ELSE
50818 IF(QMAX.LE.MIN(PARJ(82),PARJ(83),PARJ(90)).AND.IP2.GT.-8)
50819 & RETURN
50820 ENDIF
50821
50822C...Initialization of cutoff masses etc.
50823 DO 100 IFL=0,40
50824 ISCOL(IFL)=0
50825 ISCHG(IFL)=0
50826 KSH(IFL)=0
50827 100 CONTINUE
50828 ISCOL(21)=1
50829 KSH(21)=1
50830 PMTH(1,21)=PYMASS(21)
50831 PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2)
50832 PMTH(3,21)=2D0*PMTH(2,21)
50833 PMTH(4,21)=PMTH(3,21)
50834 PMTH(5,21)=PMTH(3,21)
50835 PMTH(1,22)=PYMASS(22)
50836 PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2)
50837 PMTH(3,22)=2D0*PMTH(2,22)
50838 PMTH(4,22)=PMTH(3,22)
50839 PMTH(5,22)=PMTH(3,22)
50840 PMQTH1=PARJ(82)
50841 IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
50842 PMQT1E=MIN(PMQTH1,PARJ(90))
50843 PMQTH2=PMTH(2,21)
50844 IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
50845 PMQT2E=MIN(PMQTH2,0.5D0*PARJ(90))
50846 DO 110 IFL=1,5
50847 ISCOL(IFL)=1
50848 IF(MSTJ(41).GE.2) ISCHG(IFL)=1
50849 KSH(IFL)=1
50850 PMTH(1,IFL)=PYMASS(IFL)
50851 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2)
50852 PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
50853 PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
50854 PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
50855 110 CONTINUE
50856 DO 120 IFL=11,15,2
50857 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IFL)=1
50858 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) KSH(IFL)=1
50859 PMTH(1,IFL)=PYMASS(IFL)
50860 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(90)**2)
50861 PMTH(3,IFL)=PMTH(2,IFL)+0.5D0*PARJ(90)
50862 PMTH(4,IFL)=PMTH(3,IFL)
50863 PMTH(5,IFL)=PMTH(3,IFL)
50864 120 CONTINUE
50865 PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2
50866 ALAMS=PARJ(81)**2
50867 ALFM=LOG(PT2MIN/ALAMS)
50868
50869C...Store positions of shower initiating partons.
50870 MPSPD=0
50871 IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
50872 NPA=1
50873 IPA(1)=IP1
50874 ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
50875 & MSTU(32))) THEN
50876 NPA=2
50877 IPA(1)=IP1
50878 IPA(2)=IP2
50879 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
50880 & .AND.IP2.GE.-7) THEN
50881 NPA=IABS(IP2)
50882 DO 130 I=1,NPA
50883 IPA(I)=IP1+I-1
50884 130 CONTINUE
50885 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.
50886 &IP2.EQ.-8) THEN
50887 MPSPD=1
50888 NPA=2
50889 IPA(1)=IP1+6
50890 IPA(2)=IP1+7
50891 ELSE
50892 CALL PYERRM(12,
50893 & '(PYSHOW:) failed to reconstruct showering system')
50894 IF(MSTU(21).GE.1) RETURN
50895 ENDIF
50896
50897C...Check on phase space available for emission.
50898 IREJ=0
50899 DO 140 J=1,5
50900 PS(J)=0D0
50901 140 CONTINUE
50902 PM=0D0
50903 KFLA(2)=0
50904 DO 160 I=1,NPA
50905 KFLA(I)=IABS(K(IPA(I),2))
50906 PMA(I)=P(IPA(I),5)
50907C...Special cutoff masses for initial partons (may be a heavy quark,
50908C...squark, ..., and need not be on the mass shell).
50909 IR=30+I
50910 IF(NPA.LE.1) IREF(I)=IR
50911 IF(NPA.GE.2) IREF(I+1)=IR
50912 IF(KFLA(I).LE.8) THEN
50913 ISCOL(IR)=1
50914 IF(MSTJ(41).GE.2) ISCHG(IR)=1
50915 ELSEIF(KFLA(I).EQ.11.OR.KFLA(I).EQ.13.OR.KFLA(I).EQ.15.OR.
50916 & KFLA(I).EQ.17) THEN
50917 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IR)=1
50918 ELSEIF(KFLA(I).EQ.21) THEN
50919 ISCOL(IR)=1
50920 ELSEIF((KFLA(I).GE.KSUSY1+1.AND.KFLA(I).LE.KSUSY1+8).OR.
50921 & (KFLA(I).GE.KSUSY2+1.AND.KFLA(I).LE.KSUSY2+8)) THEN
50922 ISCOL(IR)=1
50923 ELSEIF(KFLA(I).EQ.KSUSY1+21) THEN
50924 ISCOL(IR)=1
50925 ENDIF
50926 IF(ISCOL(IR).EQ.1.OR.ISCHG(IR).EQ.1) KSH(IR)=1
50927 PMTH(1,IR)=PMA(I)
50928 IF(ISCOL(IR).EQ.1.AND.ISCHG(IR).EQ.1) THEN
50929 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PMQTH1**2)
50930 PMTH(3,IR)=PMTH(2,IR)+PMQTH2
50931 PMTH(4,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
50932 PMTH(5,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
50933 ELSEIF(ISCOL(IR).EQ.1) THEN
50934 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)
50935 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(82)
50936 PMTH(4,IR)=PMTH(3,IR)
50937 PMTH(5,IR)=PMTH(3,IR)
50938 ELSEIF(ISCHG(IR).EQ.1) THEN
50939 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(90)**2)
50940 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(90)
50941 PMTH(4,IR)=PMTH(3,IR)
50942 PMTH(5,IR)=PMTH(3,IR)
50943 ENDIF
50944 IF(KSH(IR).EQ.1) PMA(I)=PMTH(3,IR)
50945 PM=PM+PMA(I)
50946 IF(KSH(IR).EQ.0.OR.PMA(I).GT.10D0*QMAX) IREJ=IREJ+1
50947 DO 150 J=1,4
50948 PS(J)=PS(J)+P(IPA(I),J)
50949 150 CONTINUE
50950 160 CONTINUE
50951 IF(IREJ.EQ.NPA.AND.IP2.GE.-7) RETURN
50952 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
50953 IF(NPA.EQ.1) PS(5)=PS(4)
50954 IF(PS(5).LE.PM+PMQT1E) RETURN
50955
50956C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
50957 KFSRCE=0
50958 IF(IP2.LE.0) THEN
50959 ELSEIF(K(IP1,3).EQ.K(IP2,3).AND.K(IP1,3).GT.0) THEN
50960 KFSRCE=IABS(K(K(IP1,3),2))
50961 ELSE
50962 IPAR1=MAX(1,K(IP1,3))
50963 IPAR2=MAX(1,K(IP2,3))
50964 IF(K(IPAR1,3).EQ.K(IPAR2,3).AND.K(IPAR1,3).GT.0)
50965 & KFSRCE=IABS(K(K(IPAR1,3),2))
50966 ENDIF
50967 ITYPES=0
50968 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
50969 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
50970 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
50971 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
50972 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
50973 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
50974 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
50975 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
50976
50977C...Identify two primary showerers.
50978 ITYPE1=0
50979 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8) ITYPE1=1
50980 IF(KFLA(1).GE.KSUSY1+1.AND.KFLA(1).LE.KSUSY1+8) ITYPE1=2
50981 IF(KFLA(1).GE.KSUSY2+1.AND.KFLA(1).LE.KSUSY2+8) ITYPE1=2
50982 IF(KFLA(1).GE.21.AND.KFLA(1).LE.24) ITYPE1=3
50983 IF(KFLA(1).GE.32.AND.KFLA(1).LE.34) ITYPE1=3
50984 IF(KFLA(1).EQ.25.OR.(KFLA(1).GE.35.AND.KFLA(1).LE.37)) ITYPE1=4
50985 IF(KFLA(1).GE.KSUSY1+22.AND.KFLA(1).LE.KSUSY1+37) ITYPE1=5
50986 IF(KFLA(1).EQ.KSUSY1+21) ITYPE1=6
50987 ITYPE2=0
50988 IF(KFLA(2).GE.1.AND.KFLA(2).LE.8) ITYPE2=1
50989 IF(KFLA(2).GE.KSUSY1+1.AND.KFLA(2).LE.KSUSY1+8) ITYPE2=2
50990 IF(KFLA(2).GE.KSUSY2+1.AND.KFLA(2).LE.KSUSY2+8) ITYPE2=2
50991 IF(KFLA(2).GE.21.AND.KFLA(2).LE.24) ITYPE2=3
50992 IF(KFLA(2).GE.32.AND.KFLA(2).LE.34) ITYPE2=3
50993 IF(KFLA(2).EQ.25.OR.(KFLA(2).GE.35.AND.KFLA(2).LE.37)) ITYPE2=4
50994 IF(KFLA(2).GE.KSUSY1+22.AND.KFLA(2).LE.KSUSY1+37) ITYPE2=5
50995 IF(KFLA(2).EQ.KSUSY1+21) ITYPE2=6
50996
50997C...Order of showerers. Presence of gluino.
50998 ITYPMN=MIN(ITYPE1,ITYPE2)
50999 ITYPMX=MAX(ITYPE1,ITYPE2)
51000 IORD=1
51001 IF(ITYPE1.GT.ITYPE2) IORD=2
51002 IGLUI=0
51003 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
51004
51005C...Check if 3-jet matrix elements to be used.
51006 M3JC=0
51007 ALPHA=0.5D0
51008 IF(NPA.EQ.2.AND.MSTJ(47).GE.1.AND.MPSPD.EQ.0) THEN
51009 IF(MSTJ(38).NE.0) THEN
51010 M3JC=MSTJ(38)
51011 ALPHA=PARJ(80)
51012 MSTJ(38)=0
51013 ELSEIF(MSTJ(47).GE.6) THEN
51014 M3JC=MSTJ(47)
51015 ELSE
51016 ICLASS=1
51017 ICOMBI=4
51018
51019C...Vector/axial vector -> q + qbar; q -> q + V.
51020 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
51021 & ITYPES.EQ.3)) THEN
51022 ICLASS=2
51023 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
51024 ICOMBI=1
51025 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
51026 & K(IP1,2)+K(IP2,2).EQ.0)) THEN
51027C...gamma*/Z0: assume e+e- initial state if unknown.
51028 EI=-1D0
51029 IF(KFSRCE.EQ.23) THEN
51030 IANNFL=K(K(IP1,3),3)
51031 IF(IANNFL.NE.0) THEN
51032 KANNFL=IABS(K(IANNFL,2))
51033 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
51034 ENDIF
51035 ENDIF
51036 AI=SIGN(1D0,EI+0.1D0)
51037 VI=AI-4D0*EI*PARU(102)
51038 EF=KCHG(KFLA(1),1)/3D0
51039 AF=SIGN(1D0,EF+0.1D0)
51040 VF=AF-4D0*EF*PARU(102)
51041 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
51042 SH=PS(5)**2
51043 SQMZ=PMAS(23,1)**2
51044 SQWZ=PS(5)*PMAS(23,2)
51045 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
51046 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
51047 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
51048 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
51049 ICOMBI=3
51050 ALPHA=VECT/(VECT+AXIV)
51051 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
51052 ICOMBI=4
51053 ENDIF
51054C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
51055 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
51056 ICLASS=2
51057 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
51058 & ITYPES.EQ.1)) THEN
51059 ICLASS=3
51060
51061C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
51062 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
51063 ICLASS=4
51064 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
51065 ICOMBI=1
51066 ELSEIF(KFSRCE.EQ.36) THEN
51067 ICOMBI=2
51068 ENDIF
51069 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
51070 & ITYPES.EQ.1)) THEN
51071 ICLASS=5
51072
51073C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
51074 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
51075 & ITYPES.EQ.3)) THEN
51076 ICLASS=6
51077 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
51078 & ITYPES.EQ.2)) THEN
51079 ICLASS=7
51080 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
51081 ICLASS=8
51082 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
51083 & ITYPES.EQ.2)) THEN
51084 ICLASS=9
51085
51086C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
51087 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
51088 & ITYPES.EQ.5)) THEN
51089 ICLASS=10
51090 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
51091 & ITYPES.EQ.2)) THEN
51092 ICLASS=11
51093 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
51094 & ITYPES.EQ.1)) THEN
51095 ICLASS=12
51096
51097C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
51098 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
51099 ICLASS=13
51100 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
51101 & ITYPES.EQ.2)) THEN
51102 ICLASS=14
51103 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
51104 & ITYPES.EQ.1)) THEN
51105 ICLASS=15
51106
51107C...g -> ~g + ~g (eikonal approximation).
51108 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
51109 ICLASS=16
51110 ENDIF
51111 M3JC=5*ICLASS+ICOMBI
51112 ENDIF
51113 ENDIF
51114
51115C...Find if interference with initial state partons.
51116 MIIS=0
51117 IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2.AND.KFSRCE.EQ.0
51118 &.AND.MPSPD.EQ.0) MIIS=MSTJ(50)
51119 IF(MSTJ(50).GE.4.AND.MSTJ(50).LE.6.AND.NPA.EQ.2.AND.MPSPD.EQ.0)
51120 &MIIS=MSTJ(50)-3
51121 IF(MIIS.NE.0) THEN
51122 DO 180 I=1,2
51123 KCII(I)=0
51124 KCA=PYCOMP(KFLA(I))
51125 IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
51126 NIIS(I)=0
51127 IF(KCII(I).NE.0) THEN
51128 DO 170 J=1,2
51129 ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5))
51130 IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND.
51131 & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN
51132 NIIS(I)=NIIS(I)+1
51133 IIIS(I,NIIS(I))=ICSI
51134 ENDIF
51135 170 CONTINUE
51136 ENDIF
51137 180 CONTINUE
51138 IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
51139 ENDIF
51140
51141C...Boost interfering initial partons to rest frame
51142C...and reconstruct their polar and azimuthal angles.
51143 IF(MIIS.NE.0) THEN
51144 DO 200 I=1,2
51145 DO 190 J=1,5
51146 K(N+I,J)=K(IPA(I),J)
51147 P(N+I,J)=P(IPA(I),J)
51148 V(N+I,J)=0D0
51149 190 CONTINUE
51150 200 CONTINUE
51151 DO 220 I=3,2+NIIS(1)
51152 DO 210 J=1,5
51153 K(N+I,J)=K(IIIS(1,I-2),J)
51154 P(N+I,J)=P(IIIS(1,I-2),J)
51155 V(N+I,J)=0D0
51156 210 CONTINUE
51157 220 CONTINUE
51158 DO 240 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
51159 DO 230 J=1,5
51160 K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J)
51161 P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J)
51162 V(N+I,J)=0D0
51163 230 CONTINUE
51164 240 CONTINUE
51165 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4),
51166 & -PS(2)/PS(4),-PS(3)/PS(4))
51167 PHI=PYANGL(P(N+1,1),P(N+1,2))
51168 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0)
51169 THE=PYANGL(P(N+1,3),P(N+1,1))
51170 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0)
51171 DO 250 I=3,2+NIIS(1)
51172 THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2))
51173 PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2))
51174 250 CONTINUE
51175 DO 260 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
51176 THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3),
51177 & SQRT(P(N+I,1)**2+P(N+I,2)**2))
51178 PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2))
51179 260 CONTINUE
51180 ENDIF
51181
51182C...Boost 3 or more partons to their rest frame.
51183 IF(NPA.GE.3) CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,-PS(1)/PS(4),
51184 &-PS(2)/PS(4),-PS(3)/PS(4))
51185
51186C...Define imagined single initiator of shower for parton system.
51187 NS=N
51188 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
51189 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
51190 IF(MSTU(21).GE.1) RETURN
51191 ENDIF
51192 270 N=NS
51193 IF(NPA.GE.2) THEN
51194 K(N+1,1)=11
51195 K(N+1,2)=21
51196 K(N+1,3)=0
51197 K(N+1,4)=0
51198 K(N+1,5)=0
51199 P(N+1,1)=0D0
51200 P(N+1,2)=0D0
51201 P(N+1,3)=0D0
51202 P(N+1,4)=PS(5)
51203 P(N+1,5)=PS(5)
51204 V(N+1,5)=PS(5)**2
51205 N=N+1
51206 IREF(1)=21
51207 ENDIF
51208
51209C...Loop over partons that may branch.
51210 NEP=NPA
51211 IM=NS
51212 IF(NPA.EQ.1) IM=NS-1
51213 280 IM=IM+1
51214 IF(N.GT.NS) THEN
51215 IF(IM.GT.N) GOTO 590
51216 KFLM=IABS(K(IM,2))
51217 IR=IREF(IM-NS)
51218 IF(KSH(IR).EQ.0) GOTO 280
51219 IF(P(IM,5).LT.PMTH(2,IR)) GOTO 280
51220 IGM=K(IM,3)
51221 ELSE
51222 IGM=-1
51223 ENDIF
51224 IF(N+NEP.GT.MSTU(4)-MSTU(32)-10) THEN
51225 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
51226 IF(MSTU(21).GE.1) RETURN
51227 ENDIF
51228
51229C...Position of aunt (sister to branching parton).
51230C...Origin and flavour of daughters.
51231 IAU=0
51232 IF(IGM.GT.0) THEN
51233 IF(K(IM-1,3).EQ.IGM) IAU=IM-1
51234 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
51235 ENDIF
51236 IF(IGM.GE.0) THEN
51237 K(IM,4)=N+1
51238 DO 290 I=1,NEP
51239 K(N+I,3)=IM
51240 290 CONTINUE
51241 ELSE
51242 K(N+1,3)=IPA(1)
51243 ENDIF
51244 IF(IGM.LE.0) THEN
51245 DO 300 I=1,NEP
51246 K(N+I,2)=K(IPA(I),2)
51247 300 CONTINUE
51248 ELSEIF(KFLM.NE.21) THEN
51249 K(N+1,2)=K(IM,2)
51250 K(N+2,2)=K(IM,5)
51251 IREF(N+1-NS)=IREF(IM-NS)
51252 IREF(N+2-NS)=IABS(K(N+2,2))
51253 ELSEIF(K(IM,5).EQ.21) THEN
51254 K(N+1,2)=21
51255 K(N+2,2)=21
51256 IREF(N+1-NS)=21
51257 IREF(N+2-NS)=21
51258 ELSE
51259 K(N+1,2)=K(IM,5)
51260 K(N+2,2)=-K(IM,5)
51261 IREF(N+1-NS)=IABS(K(N+1,2))
51262 IREF(N+2-NS)=IABS(K(N+2,2))
51263 ENDIF
51264
51265C...Reset flags on daughters and tries made.
51266 DO 310 IP=1,NEP
51267 K(N+IP,1)=3
51268 K(N+IP,4)=0
51269 K(N+IP,5)=0
51270 KFLD(IP)=IABS(K(N+IP,2))
51271 IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
51272 ITRY(IP)=0
51273 ISL(IP)=0
51274 ISI(IP)=0
51275 IF(KSH(IREF(N+IP-NS)).EQ.1) ISI(IP)=1
51276 310 CONTINUE
51277 ISLM=0
51278
51279C...Maximum virtuality of daughters.
51280 IF(IGM.LE.0) THEN
51281 DO 320 I=1,NPA
51282 IF(NPA.GE.3) P(N+I,4)=P(IPA(I),4)
51283 P(N+I,5)=MIN(QMAX,PS(5))
51284 IR=IREF(N+I-NS)
51285 IF(IP2.LE.-8) P(N+I,5)=MAX(P(N+I,5),2D0*PMTH(3,IR))
51286 IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
51287 320 CONTINUE
51288 ELSE
51289 IF(MSTJ(43).LE.2) PEM=V(IM,2)
51290 IF(MSTJ(43).GE.3) PEM=P(IM,4)
51291 P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
51292 P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM)
51293 IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
51294 ENDIF
51295 DO 330 I=1,NEP
51296 PMSD(I)=P(N+I,5)
51297 IF(ISI(I).EQ.1) THEN
51298 IR=IREF(N+I-NS)
51299 IF(P(N+I,5).LE.PMTH(3,IR)) P(N+I,5)=PMTH(1,IR)
51300 ENDIF
51301 V(N+I,5)=P(N+I,5)**2
51302 330 CONTINUE
51303
51304C...Choose one of the daughters for evolution.
51305 340 INUM=0
51306 IF(NEP.EQ.1) INUM=1
51307 DO 350 I=1,NEP
51308 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
51309 350 CONTINUE
51310 DO 360 I=1,NEP
51311 IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
51312 IR=IREF(N+I-NS)
51313 IF(P(N+I,5).GE.PMTH(2,IR)) INUM=I
51314 ENDIF
51315 360 CONTINUE
51316 IF(INUM.EQ.0) THEN
51317 RMAX=0D0
51318 DO 370 I=1,NEP
51319 IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQT2E) THEN
51320 RPM=P(N+I,5)/PMSD(I)
51321 IR=IREF(N+I-NS)
51322 IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IR)) THEN
51323 RMAX=RPM
51324 INUM=I
51325 ENDIF
51326 ENDIF
51327 370 CONTINUE
51328 ENDIF
51329
51330C...Cancel choice of predetermined daughter already treated.
51331 INUM=MAX(1,INUM)
51332 INUMT=INUM
51333 IF(MPSPD.EQ.1.AND.IGM.EQ.0.AND.ITRY(INUMT).GE.1) THEN
51334 IF(K(IP1-1+INUM,4).GT.0) INUM=3-INUM
51335 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2.AND.ITRY(INUMT).GE.1) THEN
51336 IF(KFLD(INUMT).NE.21.AND.K(IP1+2,4).GT.0) INUM=3-INUM
51337 IF(KFLD(INUMT).EQ.21.AND.K(IP1+3,4).GT.0) INUM=3-INUM
51338 ENDIF
51339
51340C...Store information on choice of evolving daughter.
51341 IEP(1)=N+INUM
51342 DO 380 I=2,NEP
51343 IEP(I)=IEP(I-1)+1
51344 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
51345 380 CONTINUE
51346 DO 390 I=1,NEP
51347 KFL(I)=IABS(K(IEP(I),2))
51348 390 CONTINUE
51349 ITRY(INUM)=ITRY(INUM)+1
51350 IF(ITRY(INUM).GT.200) THEN
51351 CALL PYERRM(14,'(PYSHOW:) caught in infinite loop')
51352 IF(MSTU(21).GE.1) RETURN
51353 ENDIF
51354 Z=0.5D0
51355 IR=IREF(IEP(1)-NS)
51356 IF(KSH(IR).EQ.0) GOTO 440
51357 IF(P(IEP(1),5).LT.PMTH(2,IR)) GOTO 440
51358
51359C...Check if evolution already predetermined for daughter.
51360 IPSPD=0
51361 IF(MPSPD.EQ.1.AND.IGM.EQ.0) THEN
51362 IF(K(IP1-1+INUM,4).GT.0) IPSPD=IP1-1+INUM
51363 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2) THEN
51364 IF(KFL(1).NE.21.AND.K(IP1+2,4).GT.0) IPSPD=IP1+2
51365 IF(KFL(1).EQ.21.AND.K(IP1+3,4).GT.0) IPSPD=IP1+3
51366 ENDIF
51367 ISSET(INUM)=0
51368 IF(IPSPD.NE.0) ISSET(INUM)=1
51369
51370C...Select side for interference with initial state partons.
51371 IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
51372 III=IEP(1)-NS-1
51373 ISII(III)=0
51374 IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
51375 ISII(III)=1
51376 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
51377 IF(PYR(0).GT.0.5D0) ISII(III)=1
51378 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
51379 ISII(III)=1
51380 IF(PYR(0).GT.0.5D0) ISII(III)=2
51381 ENDIF
51382 ENDIF
51383
51384C...Calculate allowed z range.
51385 IF(NEP.EQ.1) THEN
51386 PMED=PS(4)
51387 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
51388 PMED=P(IM,5)
51389 ELSE
51390 IF(INUM.EQ.1) PMED=V(IM,1)*PEM
51391 IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM
51392 ENDIF
51393 IF(MOD(MSTJ(43),2).EQ.1) THEN
51394 ZC=PMTH(2,21)/PMED
51395 ZCE=PMTH(2,22)/PMED
51396 IF(ISCOL(IR).EQ.0) ZCE=0.5D0*PARJ(90)/PMED
51397 ELSE
51398 ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2)))
51399 IF(ZC.LT.1D-6) ZC=(PMTH(2,21)/PMED)**2
51400 PMTMPE=PMTH(2,22)
51401 IF(ISCOL(IR).EQ.0) PMTMPE=0.5D0*PARJ(90)
51402 ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTMPE/PMED)**2)))
51403 IF(ZCE.LT.1D-6) ZCE=(PMTMPE/PMED)**2
51404 ENDIF
51405 ZC=MIN(ZC,0.491D0)
51406 ZCE=MIN(ZCE,0.49991D0)
51407 IF(((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND.
51408 &MIN(ZC,ZCE).GT.0.4999D0)).AND.IPSPD.EQ.0) THEN
51409 P(IEP(1),5)=PMTH(1,IR)
51410 V(IEP(1),5)=P(IEP(1),5)**2
51411 GOTO 440
51412 ENDIF
51413
51414C...Integral of Altarelli-Parisi z kernel for QCD.
51415C...(Includes squark and gluino; with factor N_C/C_F extra for latter).
7f9bf696 51416
3a709cfa 51417 FMED = PARJ(200)
2dfa57d1 51418 IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
3a709cfa 51419C Nestor
51420 FBR=(1.D0+FMED)*6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*0.5D0
2dfa57d1 51421 ELSEIF(MSTJ(49).EQ.0) THEN
3a709cfa 51422C Nestor
51423 FBR=(1.D0+FMED)*(8D0/3D0)*LOG((1D0-ZC)/ZC)
2dfa57d1 51424 IF(IGLUI.EQ.1.AND.IR.GE.31) FBR=FBR*(9D0/4D0)
51425
51426C...Integral of Altarelli-Parisi z kernel for scalar gluon.
51427 ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
51428 FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC)
51429 ELSEIF(MSTJ(49).EQ.1) THEN
51430 FBR=(1D0-2D0*ZC)/3D0
51431 IF(IGM.EQ.0.AND.M3JC.GE.1) FBR=4D0*FBR
51432
51433C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
51434 ELSEIF(KFL(1).EQ.21) THEN
3a709cfa 51435 FBR=(1.D0+FMED)*6D0*MSTJ(45)*(0.5D0-ZC)
2dfa57d1 51436 ELSE
3a709cfa 51437 FBR=(1.D0+FMED)*2D0*LOG((1D0-ZC)/ZC)
2dfa57d1 51438 ENDIF
51439
51440C...Reset QCD probability for colourless.
51441 IF(ISCOL(IR).EQ.0) FBR=0D0
51442
51443C...Integral of Altarelli-Parisi kernel for photon emission.
51444 FBRE=0D0
51445 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1) THEN
51446 IF(KFL(1).LE.18) THEN
51447 FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE)
51448 ENDIF
51449 IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE
51450 ENDIF
51451
51452C...Inner veto algorithm starts. Find maximum mass for evolution.
51453 400 PMS=V(IEP(1),5)
51454 IF(IGM.GE.0) THEN
51455 PM2=0D0
51456 DO 410 I=2,NEP
51457 PM=P(IEP(I),5)
51458 IRI=IREF(IEP(I)-NS)
51459 IF(KSH(IRI).EQ.1) PM=PMTH(2,IRI)
51460 PM2=PM2+PM
51461 410 CONTINUE
51462 PMS=MIN(PMS,(P(IM,5)-PM2)**2)
51463 ENDIF
51464
51465C...Select mass for daughter in QCD evolution.
51466 B0=27D0/6D0
51467 DO 420 IFF=4,MSTJ(45)
51468 IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0
51469 420 CONTINUE
51470C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
51471 PMSC=MAX(0.5D0*PARJ(82),PMS-PMTH(1,IR)**2)
51472C...Already predetermined choice.
51473 IF(IPSPD.NE.0) THEN
51474 PMSQCD=P(IPSPD,5)**2
51475 ELSEIF(FBR.LT.1D-3) THEN
51476 PMSQCD=0D0
51477 ELSEIF(MSTJ(44).LE.0) THEN
51478 PMSQCD=PMSC*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR)))
51479 ELSEIF(MSTJ(44).EQ.1) THEN
51480 PMSQCD=4D0*ALAMS*(0.25D0*PMSC/ALAMS)**(PYR(0)**(B0/FBR))
51481 ELSE
51482 PMSQCD=PMSC*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR))
51483 ENDIF
51484C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
51485 IF(IPSPD.EQ.0) PMSQCD=PMSQCD+PMTH(1,IR)**2
51486 IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IR)**2) PMSQCD=PMTH(2,IR)**2
51487 V(IEP(1),5)=PMSQCD
51488 MCE=1
51489
51490C...Select mass for daughter in QED evolution.
51491 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1.AND.IPSPD.EQ.0) THEN
51492C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
51493 PMSE=MAX(0.5D0*PARJ(83),PMS-PMTH(1,IR)**2)
51494 IF(FBRE.LT.1D-3) THEN
51495 PMSQED=0D0
51496 ELSE
51497 PMSQED=PMSE*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
51498 & (PARU(101)*FBRE)))
51499 ENDIF
51500C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
51501 PMSQED=PMSQED+PMTH(1,IR)**2
51502 IF(ZCE.GT.0.4999D0.OR.PMSQED.LE.PMTH(5,IR)**2) PMSQED=
51503 & PMTH(2,IR)**2
51504 IF(PMSQED.GT.PMSQCD) THEN
51505 V(IEP(1),5)=PMSQED
51506 MCE=2
51507 ENDIF
51508 ENDIF
51509
51510C...Check whether daughter mass below cutoff.
51511 P(IEP(1),5)=SQRT(V(IEP(1),5))
51512 IF(P(IEP(1),5).LE.PMTH(3,IR)) THEN
51513 P(IEP(1),5)=PMTH(1,IR)
51514 V(IEP(1),5)=P(IEP(1),5)**2
51515 GOTO 440
51516 ENDIF
51517
51518C...Already predetermined choice of z, and flavour in g -> qqbar.
51519 IF(IPSPD.NE.0) THEN
51520 IPSGD1=K(IPSPD,4)
51521 IPSGD2=K(IPSPD,5)
51522 PMSGD1=P(IPSGD1,5)**2
51523 PMSGD2=P(IPSGD2,5)**2
51524 ALAMPS=SQRT(MAX(1D-10,(PMSQCD-PMSGD1-PMSGD2)**2-
51525 & 4D0*PMSGD1*PMSGD2))
51526 Z=0.5D0*(PMSQCD*(2D0*P(IPSGD1,4)/P(IPSPD,4)-1D0)+ALAMPS-
51527 & PMSGD1+PMSGD2)/ALAMPS
51528 Z=MAX(0.00001D0,MIN(0.99999D0,Z))
51529 IF(KFL(1).NE.21) THEN
51530 K(IEP(1),5)=21
51531 ELSE
51532 K(IEP(1),5)=IABS(K(IPSGD1,2))
51533 ENDIF
51534
51535C...Select z value of branching: q -> qgamma.
51536 ELSEIF(MCE.EQ.2) THEN
51537 Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0)
51538 IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 400
51539 K(IEP(1),5)=22
51540
51541C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
51542 ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
51543 Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
51544C...Only do z weighting when no ME correction afterwards.
51545 IF(M3JC.EQ.0.AND.1D0+Z**2.LT.2D0*PYR(0)) GOTO 400
51546 K(IEP(1),5)=21
51547 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*0.5D0.LT.PYR(0)*FBR) THEN
51548 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
51549 IF(PYR(0).GT.0.5D0) Z=1D0-Z
51550 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 400
51551 K(IEP(1),5)=21
51552 ELSEIF(MSTJ(49).NE.1) THEN
51553 Z=PYR(0)
51554 IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 400
51555 KFLB=1+INT(MSTJ(45)*PYR(0))
51556 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
51557 IF(PMQ.GE.1D0) GOTO 400
51558 IF(MSTJ(44).LE.2.OR.MSTJ(44).EQ.4) THEN
51559 IF(Z.LT.ZC.OR.Z.GT.1D0-ZC) GOTO 400
51560 PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5)
51561 IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ)
51562 & .LT.PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 400
51563 ELSE
51564 IF((1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.PYR(0)) GOTO 400
51565 ENDIF
51566 K(IEP(1),5)=KFLB
51567
51568C...Ditto for scalar gluon model.
51569 ELSEIF(KFL(1).NE.21) THEN
51570 Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC))
51571 K(IEP(1),5)=21
51572 ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
51573 Z=ZC+(1D0-2D0*ZC)*PYR(0)
51574 K(IEP(1),5)=21
51575 ELSE
51576 Z=ZC+(1D0-2D0*ZC)*PYR(0)
51577 KFLB=1+INT(MSTJ(45)*PYR(0))
51578 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
51579 IF(PMQ.GE.1D0) GOTO 400
51580 K(IEP(1),5)=KFLB
51581 ENDIF
51582
51583C...Correct to alpha_s(pT^2) (optionally m^2/4 for g -> q qbar).
51584 IF(MCE.EQ.1.AND.MSTJ(44).GE.2.AND.IPSPD.EQ.0) THEN
51585 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
51586 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
51587 IF(ALFM/LOG(V(IEP(1),5)*0.25D0/ALAMS).LT.PYR(0)) GOTO 400
51588 ELSE
51589 PT2APP=Z*(1D0-Z)*V(IEP(1),5)
51590 IF(MSTJ(44).GE.4) PT2APP=PT2APP*
51591 & (1D0-PMTH(1,IR)**2/V(IEP(1),5))**2
51592 IF(PT2APP.LT.PT2MIN) GOTO 400
51593 IF(ALFM/LOG(PT2APP/ALAMS).LT.PYR(0)) GOTO 400
51594 ENDIF
51595 ENDIF
51596
51597C...Check if z consistent with chosen m.
51598 IF(KFL(1).EQ.21) THEN
51599 IRGD1=IABS(K(IEP(1),5))
51600 IRGD2=IRGD1
51601 ELSE
51602 IRGD1=IR
51603 IRGD2=IABS(K(IEP(1),5))
51604 ENDIF
51605 IF(NEP.EQ.1) THEN
51606 PED=PS(4)
51607 ELSEIF(NEP.GE.3) THEN
51608 PED=P(IEP(1),4)
51609 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
51610 PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
51611 ELSE
51612 IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
51613 IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM
51614 ENDIF
51615 IF(MOD(MSTJ(43),2).EQ.1) THEN
51616 PMQTH3=0.5D0*PARJ(82)
51617 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
51618 IF(IRGD2.EQ.22.AND.ISCOL(IR).EQ.0) PMQTH3=0.5D0*PARJ(90)
51619 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(IEP(1),5)
51620 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(IEP(1),5)
51621 ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
51622 & 4D0*PMQ1*PMQ2)))
51623 ZH=1D0+PMQ1-PMQ2
51624 ELSE
51625 ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2))
51626 ZH=1D0
51627 ENDIF
51628 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
51629 &(MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
51630 ELSEIF(IPSPD.NE.0) THEN
51631 ELSE
51632 ZL=0.5D0*(ZH-ZD)
51633 ZU=0.5D0*(ZH+ZD)
51634 IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 400
51635 ENDIF
51636 IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL*
51637 &(1D0-ZU)))
51638 IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
51639
51640C...Width suppression for q -> q + g.
51641 IF(MSTJ(40).NE.0.AND.KFL(1).NE.21.AND.IPSPD.EQ.0) THEN
51642 IF(IGM.EQ.0) THEN
51643 EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5))
51644 ELSE
51645 EGLU=PMED*(1D0-Z)
51646 ENDIF
51647 CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2)
51648 IF(MSTJ(40).EQ.1) THEN
51649 IF(CHI.LT.PYR(0)) GOTO 400
51650 ELSEIF(MSTJ(40).EQ.2) THEN
51651 IF(1D0-CHI.LT.PYR(0)) GOTO 400
51652 ENDIF
51653 ENDIF
51654
51655C...Three-jet matrix element correction.
51656 IF(M3JC.GE.1) THEN
51657 WME=1D0
51658 WSHOW=1D0
51659
51660C...QED matrix elements: only for massless case so far.
51661 IF(MCE.EQ.2.AND.IGM.EQ.0) THEN
51662 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
51663 X2=1D0-V(IEP(1),5)/V(NS+1,5)
51664 X3=(1D0-X1)+(1D0-X2)
51665 KI1=K(IPA(INUM),2)
51666 KI2=K(IPA(3-INUM),2)
51667 QF1=KCHG(PYCOMP(KI1),1)*ISIGN(1,KI1)/3D0
51668 QF2=KCHG(PYCOMP(KI2),1)*ISIGN(1,KI2)/3D0
51669 WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+
51670 & QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2)
51671 WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2)
51672 ELSEIF(MCE.EQ.2) THEN
51673
51674C...QCD matrix elements, including mass effects.
51675 ELSEIF(MSTJ(49).NE.1.AND.K(IEP(1),2).NE.21) THEN
51676 PS1ME=V(IEP(1),5)
51677 PM1ME=PMTH(1,IR)
51678 M3JCC=M3JC
51679 IF(IR.GE.31.AND.IGM.EQ.0) THEN
51680C...QCD ME: original parton, first branching.
51681 PM2ME=PMTH(1,63-IR)
51682 ECMME=PS(5)
51683 ELSEIF(IR.GE.31) THEN
51684C...QCD ME: original parton, subsequent branchings.
51685 PM2ME=PMTH(1,63-IR)
51686 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
51687 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
51688 ELSEIF(K(IM,2).EQ.21) THEN
51689C...QCD ME: secondary partons, first branching.
51690 PM2ME=PM1ME
51691 ZMME=V(IM,1)
51692 IF(IEP(1).GT.IEP(2)) ZMME=1D0-ZMME
51693 PMLME=SQRT(MAX(0D0,(V(IM,5)-PS1ME-PM2ME**2)**2-
51694 & 4D0*PS1ME*PM2ME**2))
51695 PEDME=PEM*(0.5D0*(V(IM,5)-PMLME+PS1ME-PM2ME**2)+PMLME*ZMME)/
51696 & V(IM,5)
51697 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
51698 M3JCC=66
51699 ELSE
51700C...QCD ME: secondary partons, subsequent branchings.
51701 PM2ME=PM1ME
51702 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
51703 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
51704 M3JCC=66
51705 ENDIF
51706C...Construct ME variables.
51707 R1ME=PM1ME/ECMME
51708 R2ME=PM2ME/ECMME
51709 X1=(1D0+PS1ME/ECMME**2-R2ME**2)*(Z+(1D0-Z)*PM1ME**2/PS1ME)
51710 X2=1D0+R2ME**2-PS1ME/ECMME**2
51711C...Call ME, with right order important for two inequivalent showerers.
51712 IF(IR.EQ.IORD+30) THEN
51713 WME=PYMAEL(M3JCC,X1,X2,R1ME,R2ME,ALPHA)
51714 ELSE
51715 WME=PYMAEL(M3JCC,X2,X1,R2ME,R1ME,ALPHA)
51716 ENDIF
51717C...Split up total ME when two radiating partons.
51718 ISPRAD=1
51719 IF((M3JCC.GE.16.AND.M3JCC.LE.19).OR.
51720 & (M3JCC.GE.26.AND.M3JCC.LE.29).OR.
51721 & (M3JCC.GE.36.AND.M3JCC.LE.39).OR.
51722 & (M3JCC.GE.46.AND.M3JCC.LE.49).OR.
51723 & (M3JCC.GE.56.AND.M3JCC.LE.64)) ISPRAD=0
51724 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
51725 & MAX(1D-10,2D0-X1-X2)
51726C...Evaluate shower rate to be compared with.
51727 WSHOW=2D0/(MAX(1D-10,2D0-X1-X2)*
51728 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
51729 IF(IGLUI.EQ.1.AND.IR.GE.31) WSHOW=(9D0/4D0)*WSHOW
51730 ELSEIF(MSTJ(49).NE.1) THEN
51731
51732C...Toy model scalar theory matrix elements; no mass effects.
51733 ELSE
51734 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
51735 X2=1D0-V(IEP(1),5)/V(NS+1,5)
51736 X3=(1D0-X1)+(1D0-X2)
51737 WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2)
51738 WME=X3**2
51739 IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*
51740 & PARJ(171)
51741 ENDIF
51742
51743 IF(WME.LT.PYR(0)*WSHOW) GOTO 400
51744 ENDIF
51745
51746C...Impose angular ordering by rejection of nonordered emission.
51747 IF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2.AND.IPSPD.EQ.0) THEN
51748 PEMAO=V(IM,1)*P(IM,4)
51749 IF(IEP(1).EQ.N+2) PEMAO=(1D0-V(IM,1))*P(IM,4)
51750 IF(IR.GE.31.AND.MSTJ(42).GE.5) THEN
51751 MAOD=0
51752 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.4
51753 & .OR.MSTJ(42).EQ.7)) THEN
51754 MAOD=0
51755 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.3
51756 & .OR.MSTJ(42).EQ.6)) THEN
51757 MAOD=1
51758 PMDAO=PMTH(2,K(IEP(1),5))
51759 THE2ID=Z*(1D0-Z)*PEMAO**2/(V(IEP(1),5)-4D0*PMDAO**2)
51760 ELSE
51761 MAOD=1
51762 THE2ID=Z*(1D0-Z)*PEMAO**2/V(IEP(1),5)
51763 IF(MSTJ(42).GE.3.AND.MSTJ(42).NE.5) THE2ID=THE2ID*
51764 & (1D0+PMTH(1,IR)**2*(1D0-Z)/(V(IEP(1),5)*Z))**2
51765 ENDIF
51766 MAOM=1
51767 IAOM=IM
51768 430 IF(K(IAOM,5).EQ.22) THEN
51769 IAOM=K(IAOM,3)
51770 IF(K(IAOM,3).LE.NS) MAOM=0
51771 IF(MAOM.EQ.1) GOTO 430
51772 ENDIF
51773 IF(MAOM.EQ.1.AND.MAOD.EQ.1) THEN
51774 THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
51775 IF(THE2ID.LT.THE2IM) GOTO 400
51776 ENDIF
51777 ENDIF
51778
51779C...Impose user-defined maximum angle at first branching.
51780 IF(MSTJ(48).EQ.1.AND.IPSPD.EQ.0) THEN
51781 IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
51782 THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5)
51783 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 400
51784 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
51785 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
51786 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 400
51787 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
51788 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
51789 IF(PARJ(86)**2*THE2ID.LT.1D0) GOTO 400
51790 ENDIF
51791 ENDIF
51792
51793C...Impose angular constraint in first branching from interference
51794C...with initial state partons.
51795 IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN
51796 THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2
51797 IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN
51798 IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 400
51799 ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN
51800 IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 400
51801 ENDIF
51802 ENDIF
51803
51804C...End of inner veto algorithm. Check if only one leg evolved so far.
51805 440 V(IEP(1),1)=Z
51806 ISL(1)=0
51807 ISL(2)=0
51808 IF(NEP.EQ.1) GOTO 480
51809 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 340
51810 DO 450 I=1,NEP
51811 IR=IREF(N+I-NS)
51812 IF(ITRY(I).EQ.0.AND.KSH(IR).EQ.1) THEN
51813 IF(P(N+I,5).GE.PMTH(2,IR)) GOTO 340
51814 ENDIF
51815 450 CONTINUE
51816
51817C...Check if chosen multiplet m1,m2,z1,z2 is physical.
51818 IF(NEP.GE.3) THEN
51819 PMSUM=0D0
51820 DO 460 I=1,NEP
51821 PMSUM=PMSUM+P(N+I,5)
51822 460 CONTINUE
51823 IF(PMSUM.GE.PS(5)) GOTO 340
51824 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
51825 DO 470 I1=N+1,N+2
51826 IRDA=IREF(I1-NS)
51827 IF(KSH(IRDA).EQ.0) GOTO 470
51828 IF(P(I1,5).LT.PMTH(2,IRDA)) GOTO 470
51829 IF(IRDA.EQ.21) THEN
51830 IRGD1=IABS(K(I1,5))
51831 IRGD2=IRGD1
51832 ELSE
51833 IRGD1=IRDA
51834 IRGD2=IABS(K(I1,5))
51835 ENDIF
51836 I2=2*N+3-I1
51837 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
51838 PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
51839 ELSE
51840 IF(I1.EQ.N+1) ZM=V(IM,1)
51841 IF(I1.EQ.N+2) ZM=1D0-V(IM,1)
51842 PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
51843 & 4D0*V(N+1,5)*V(N+2,5))
51844 PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/
51845 & V(IM,5)
51846 ENDIF
51847 IF(MOD(MSTJ(43),2).EQ.1) THEN
51848 PMQTH3=0.5D0*PARJ(82)
51849 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
51850 IF(IRGD2.EQ.22.AND.ISCOL(IRDA).EQ.0) PMQTH3=0.5D0*PARJ(90)
51851 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(I1,5)
51852 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(I1,5)
51853 ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
51854 & 4D0*PMQ1*PMQ2)))
51855 ZH=1D0+PMQ1-PMQ2
51856 ELSE
51857 ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2))
51858 ZH=1D0
51859 ENDIF
51860 IF(IRDA.EQ.21.AND.IRGD1.LT.10.AND.
51861 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
51862 ELSE
51863 ZL=0.5D0*(ZH-ZD)
51864 ZU=0.5D0*(ZH+ZD)
51865 IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
51866 & ISSET(1).EQ.0) THEN
51867 ISL(1)=1
51868 ELSEIF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
51869 & ISSET(2).EQ.0) THEN
51870 ISL(2)=1
51871 ENDIF
51872 ENDIF
51873 IF(IRDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20,
51874 & ZL*(1D0-ZU)))
51875 IF(IRDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
51876 470 CONTINUE
51877 IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
51878 ISL(3-ISLM)=0
51879 ISLM=3-ISLM
51880 ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
51881 ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0)
51882 ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0)
51883 IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0
51884 IF(ISL(1).EQ.1) ISL(2)=0
51885 IF(ISL(1).EQ.0) ISLM=1
51886 IF(ISL(2).EQ.0) ISLM=2
51887 ENDIF
51888 IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 340
51889 ENDIF
51890 IRD1=IREF(N+1-NS)
51891 IRD2=IREF(N+2-NS)
51892 IF(IGM.GT.0) THEN
51893 IF(MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
51894 & PMTH(2,IRD1).OR.P(N+2,5).GE.PMTH(2,IRD2))) THEN
51895 PMQ1=V(N+1,5)/V(IM,5)
51896 PMQ2=V(N+2,5)/V(IM,5)
51897 ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2-
51898 & 4D0*PMQ1*PMQ2)))
51899 ZH=1D0+PMQ1-PMQ2
51900 ZL=0.5D0*(ZH-ZD)
51901 ZU=0.5D0*(ZH+ZD)
51902 IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 340
51903 ENDIF
51904 ENDIF
51905
51906C...Accepted branch. Construct four-momentum for initial partons.
51907 480 MAZIP=0
51908 MAZIC=0
51909 IF(NEP.EQ.1) THEN
51910 P(N+1,1)=0D0
51911 P(N+1,2)=0D0
51912 P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
51913 & P(N+1,5))))
51914 P(N+1,4)=P(IPA(1),4)
51915 V(N+1,2)=P(N+1,4)
51916 ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
51917 PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
51918 P(N+1,1)=0D0
51919 P(N+1,2)=0D0
51920 P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
51921 P(N+1,4)=PED1
51922 P(N+2,1)=0D0
51923 P(N+2,2)=0D0
51924 P(N+2,3)=-P(N+1,3)
51925 P(N+2,4)=P(IM,5)-PED1
51926 V(N+1,2)=P(N+1,4)
51927 V(N+2,2)=P(N+2,4)
51928 ELSEIF(NEP.GE.3) THEN
51929C...Rescale all momenta for energy conservation.
51930 LOOP=0
51931 PES=0D0
51932 PQS=0D0
51933 DO 500 I=1,NEP
51934 DO 490 J=1,4
51935 P(N+I,J)=P(IPA(I),J)
51936 490 CONTINUE
51937 PES=PES+P(N+I,4)
51938 PQS=PQS+P(N+I,5)**2/P(N+I,4)
51939 500 CONTINUE
51940 510 LOOP=LOOP+1
51941 FAC=(PS(5)-PQS)/(PES-PQS)
51942 PES=0D0
51943 PQS=0D0
51944 DO 530 I=1,NEP
51945 DO 520 J=1,3
51946 P(N+I,J)=FAC*P(N+I,J)
51947 520 CONTINUE
51948 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)
51949 V(N+I,2)=P(N+I,4)
51950 PES=PES+P(N+I,4)
51951 PQS=PQS+P(N+I,5)**2/P(N+I,4)
51952 530 CONTINUE
51953 IF(LOOP.LT.10.AND.ABS(PES-PS(5)).GT.1D-12*PS(5)) GOTO 510
51954
51955C...Construct transverse momentum for ordinary branching in shower.
51956 ELSE
51957 ZM=V(IM,1)
51958 LOOPPT=0
51959 540 LOOPPT=LOOPPT+1
51960 PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5))))
51961 PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5)
51962 IF(PZM.LE.0D0) THEN
51963 PTS=0D0
51964 ELSEIF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
51965 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
51966 PTS=PMLS*ZM*(1D0-ZM)/V(IM,5)
51967 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
51968 PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)-
51969 & ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2
51970 ELSE
51971 PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2
51972 ENDIF
51973 IF(PTS.LT.0D0.AND.LOOPPT.LT.10) THEN
51974 ZM=0.05D0+0.9D0*ZM
51975 GOTO 540
51976 ELSEIF(PTS.LT.0D0) THEN
51977 GOTO 270
51978 ENDIF
51979 PT=SQRT(MAX(0D0,PTS))
51980
51981C...Find coefficient of azimuthal asymmetry due to gluon polarization.
51982 HAZIP=0D0
51983 IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21
51984 & .AND.IAU.NE.0) THEN
51985 IF(K(IGM,3).NE.0) MAZIP=1
51986 ZAU=V(IGM,1)
51987 IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1)
51988 IF(MAZIP.EQ.0) ZAU=0D0
51989 IF(K(IGM,2).NE.21) THEN
51990 HAZIP=2D0*ZAU/(1D0+ZAU**2)
51991 ELSE
51992 HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2
51993 ENDIF
51994 IF(K(N+1,2).NE.21) THEN
51995 HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM))
51996 ELSE
51997 HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2
51998 ENDIF
51999 ENDIF
52000
52001C...Find coefficient of azimuthal asymmetry due to soft gluon
52002C...interference.
52003 HAZIC=0D0
52004 IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
52005 & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
52006 IF(K(IGM,3).NE.0) MAZIC=N+1
52007 IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
52008 IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
52009 & ZM.GT.0.5D0) MAZIC=N+2
52010 IF(K(IAU,2).EQ.22) MAZIC=0
52011 ZS=ZM
52012 IF(MAZIC.EQ.N+2) ZS=1D0-ZM
52013 ZGM=V(IGM,1)
52014 IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1)
52015 IF(MAZIC.EQ.0) ZGM=1D0
52016 IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))*
52017 & SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM))
52018 HAZIC=MIN(0.95D0,HAZIC)
52019 ENDIF
52020 ENDIF
52021
52022C...Construct energies for ordinary branching in shower.
52023 550 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
52024 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
52025 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
52026 P(N+1,4)=0.5D0*(PEM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
52027 & PZM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
52028 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
52029 P(N+1,4)=PEM*V(IM,1)
52030 ELSE
52031 P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
52032 & SQRT(PMLS)*ZM)/V(IM,5)
52033 ENDIF
52034
52035C...Already predetermined choice of phi angle or not
52036 PHI=PARU(2)*PYR(0)
52037 IF(MPSPD.EQ.1.AND.IGM.EQ.NS+1) THEN
52038 IPSPD=IP1+IM-NS-2
52039 IF(K(IPSPD,4).GT.0) THEN
52040 IPSGD1=K(IPSPD,4)
52041 IF(IM.EQ.NS+2) THEN
52042 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
52043 ELSE
52044 PHI=PYANGL(-P(IPSGD1,1),P(IPSGD1,2))
52045 ENDIF
52046 ENDIF
52047 ELSEIF(MPSPD.EQ.1.AND.IGM.EQ.NS+2) THEN
52048 IPSPD=IP1+IM-NS-2
52049 IF(K(IPSPD,4).GT.0) THEN
52050 IPSGD1=K(IPSPD,4)
52051 PHIPSM=PYANGL(P(IPSPD,1),P(IPSPD,2))
52052 THEPSM=PYANGL(P(IPSPD,3),SQRT(P(IPSPD,1)**2+P(IPSPD,2)**2))
52053 CALL PYROBO(IPSGD1,IPSGD1,0D0,-PHIPSM,0D0,0D0,0D0)
52054 CALL PYROBO(IPSGD1,IPSGD1,-THEPSM,0D0,0D0,0D0,0D0)
52055 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
52056 CALL PYROBO(IPSGD1,IPSGD1,THEPSM,PHIPSM,0D0,0D0,0D0)
52057 ENDIF
52058 ENDIF
52059
52060C...Construct momenta for ordinary branching in shower.
52061 P(N+1,1)=PT*COS(PHI)
52062 P(N+1,2)=PT*SIN(PHI)
52063 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
52064 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
52065 P(N+1,3)=0.5D0*(PZM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
52066 & PEM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
52067 ELSEIF(PZM.GT.0D0) THEN
52068 P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+
52069 & 2D0*PEM*P(N+1,4))/PZM
52070 ELSE
52071 P(N+1,3)=0D0
52072 ENDIF
52073 P(N+2,1)=-P(N+1,1)
52074 P(N+2,2)=-P(N+1,2)
52075 P(N+2,3)=PZM-P(N+1,3)
52076 P(N+2,4)=PEM-P(N+1,4)
52077 IF(MSTJ(43).LE.2) THEN
52078 V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
52079 V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
52080 ENDIF
52081 ENDIF
52082
52083C...Rotate and boost daughters.
52084 IF(IGM.GT.0) THEN
52085 IF(MSTJ(43).LE.2) THEN
52086 BEX=P(IGM,1)/P(IGM,4)
52087 BEY=P(IGM,2)/P(IGM,4)
52088 BEZ=P(IGM,3)/P(IGM,4)
52089 GA=P(IGM,4)/P(IGM,5)
52090 GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)-
52091 & P(IM,4))
52092 ELSE
52093 BEX=0D0
52094 BEY=0D0
52095 BEZ=0D0
52096 GA=1D0
52097 GABEP=0D0
52098 ENDIF
52099 PTIMB=SQRT((P(IM,1)+GABEP*BEX)**2+(P(IM,2)+GABEP*BEY)**2)
52100 THE=PYANGL(P(IM,3)+GABEP*BEZ,PTIMB)
52101 IF(PTIMB.GT.1D-4) THEN
52102 PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
52103 ELSE
52104 PHI=0D0
52105 ENDIF
52106 DO 560 I=N+1,N+2
52107 DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
52108 & SIN(THE)*COS(PHI)*P(I,3)
52109 DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
52110 & SIN(THE)*SIN(PHI)*P(I,3)
52111 DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
52112 DP(4)=P(I,4)
52113 DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
52114 DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
52115 P(I,1)=DP(1)+DGABP*BEX
52116 P(I,2)=DP(2)+DGABP*BEY
52117 P(I,3)=DP(3)+DGABP*BEZ
52118 P(I,4)=GA*(DP(4)+DBP)
52119 560 CONTINUE
52120 ENDIF
52121
52122C...Weight with azimuthal distribution, if required.
52123 IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
52124 DO 570 J=1,3
52125 DPT(1,J)=P(IM,J)
52126 DPT(2,J)=P(IAU,J)
52127 DPT(3,J)=P(N+1,J)
52128 570 CONTINUE
52129 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
52130 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
52131 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
52132 DO 580 J=1,3
52133 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
52134 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
52135 580 CONTINUE
52136 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
52137 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
52138 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
52139 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
52140 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
52141 IF(MAZIP.NE.0) THEN
52142 IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP)))
52143 & GOTO 550
52144 ENDIF
52145 IF(MAZIC.NE.0) THEN
52146 IF(MAZIC.EQ.N+2) CAD=-CAD
52147 IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD)
52148 & .LT.PYR(0)) GOTO 550
52149 ENDIF
52150 ENDIF
52151 ENDIF
52152
52153C...Azimuthal anisotropy due to interference with initial state partons.
52154 IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR.
52155 &K(N+2,2).EQ.21)) THEN
52156 III=IM-NS-1
52157 IF(ISII(III).GE.1) THEN
52158 IAZIID=N+1
52159 IF(K(N+1,2).NE.21) IAZIID=N+2
52160 IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
52161 & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2
52162 THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2))
52163 IF(III.EQ.2) THEIID=PARU(1)-THEIID
52164 PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2))
52165 HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III)))
52166 CAD=COS(PHIIID-PHIIIS(III,ISII(III)))
52167 PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III)))
52168 IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL
52169 IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD)
52170 & .LT.PYR(0)) GOTO 550
52171 ENDIF
52172 ENDIF
52173
52174C...Continue loop over partons that may branch, until none left.
52175 IF(IGM.GE.0) K(IM,1)=14
52176 N=N+NEP
52177 NEP=2
52178 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
52179 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
52180 IF(MSTU(21).GE.1) N=NS
52181 IF(MSTU(21).GE.1) RETURN
52182 ENDIF
52183 GOTO 280
52184
52185C...Set information on imagined shower initiator.
52186 590 IF(NPA.GE.2) THEN
52187 K(NS+1,1)=11
52188 K(NS+1,2)=94
52189 K(NS+1,3)=IP1
52190 IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
52191 K(NS+1,4)=NS+2
52192 K(NS+1,5)=NS+1+NPA
52193 IIM=1
52194 ELSE
52195 IIM=0
52196 ENDIF
52197
52198C...Reconstruct string drawing information.
52199 DO 600 I=NS+1+IIM,N
52200 KQ=KCHG(PYCOMP(K(I,2)),2)
52201 IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
52202 K(I,1)=1
52203 ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
52204 & IABS(K(I,2)).LE.18) THEN
52205 K(I,1)=1
52206 ELSEIF(K(I,1).LE.10) THEN
52207 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
52208 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
52209 ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
52210 ID1=MOD(K(I,4),MSTU(5))
52211 IF(KQ.EQ.1.AND.K(I,2).GT.0) ID1=MOD(K(I,4),MSTU(5))+1
52212 IF(KQ.EQ.2.AND.(K(ID1,2).EQ.21.OR.K(ID1+1,2).EQ.21).AND.
52213 & PYR(0).GT.0.5D0) ID1=MOD(K(I,4),MSTU(5))+1
52214 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
52215 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
52216 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
52217 K(ID1,4)=K(ID1,4)+MSTU(5)*I
52218 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
52219 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
52220 K(ID2,5)=K(ID2,5)+MSTU(5)*I
52221 ELSE
52222 ID1=MOD(K(I,4),MSTU(5))
52223 ID2=ID1+1
52224 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
52225 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
52226 IF(KQ.EQ.1.OR.K(ID1,1).GE.11) THEN
52227 K(ID1,4)=K(ID1,4)+MSTU(5)*I
52228 K(ID1,5)=K(ID1,5)+MSTU(5)*I
52229 ELSE
52230 K(ID1,4)=0
52231 K(ID1,5)=0
52232 ENDIF
52233 K(ID2,4)=0
52234 K(ID2,5)=0
52235 ENDIF
52236 600 CONTINUE
52237
52238C...Transformation from CM frame.
52239 IF(NPA.EQ.1) THEN
52240 THE=PYANGL(P(IPA(1),3),SQRT(P(IPA(1),1)**2+P(IPA(1),2)**2))
52241 PHI=PYANGL(P(IPA(1),1),P(IPA(1),2))
52242 MSTU(33)=1
52243 CALL PYROBO(NS+1,N,THE,PHI,0D0,0D0,0D0)
52244 ELSEIF(NPA.EQ.2) THEN
52245 BEX=PS(1)/PS(4)
52246 BEY=PS(2)/PS(4)
52247 BEZ=PS(3)/PS(4)
52248 GA=PS(4)/PS(5)
52249 GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
52250 & /(1D0+GA)-P(IPA(1),4))
52251 THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
52252 & +GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
52253 PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
52254 MSTU(33)=1
52255 CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ)
52256 ELSE
52257 CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),
52258 & PS(3)/PS(4))
52259 MSTU(33)=1
52260 CALL PYROBO(NS+1,N,0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),PS(3)/PS(4))
52261 ENDIF
52262
52263C...Decay vertex of shower.
52264 DO 620 I=NS+1,N
52265 DO 610 J=1,5
52266 V(I,J)=V(IP1,J)
52267 610 CONTINUE
52268 620 CONTINUE
52269
52270C...Delete trivial shower, else connect initiators.
52271 IF(N.LE.NS+NPA+IIM) THEN
52272 N=NS
52273 ELSE
52274 DO 630 IP=1,NPA
52275 K(IPA(IP),1)=14
52276 K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
52277 K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
52278 K(NS+IIM+IP,3)=IPA(IP)
52279 IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
52280 IF(K(NS+IIM+IP,1).NE.1) THEN
52281 K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
52282 K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
52283 ENDIF
52284 630 CONTINUE
52285 ENDIF
52286
52287 RETURN
52288 END
52289
52290C*********************************************************************
52291
52292C...PYMAEL
52293C...Auxiliary to PYSHOW.
52294C...Matrix elements for gluon (or photon) emission from
52295C...a two-body state; to be used by the parton shower routine.
52296C...Here X_i = 2 E_i/E_cm, R_i = m_i/E_cm and
52297C...1/sigma_0 d(sigma)/d(x_1)d(x_2) =
52298C... = (alpha-strong/2 pi) * CF * PYMAEL,
52299C...i.e. normalization is such that one recovers the familiar
52300C...(X1**2+X2**2)/((1-X1)*(1-X2)) for the massless case.
52301C...Coupling structure:
52302C...NI = 6- 9 : eikonal soft-gluon expression (spin-independent)
52303C... = 11-14 : V -> q qbar (V = vector/axial vector colour singlet)
52304C... = 16-19 : q -> q V
52305C... = 21-24 : S -> q qbar (S = scalar/pseudoscalar colour singlet)
52306C... = 26-29 : q -> q S
52307C... = 31-34 : V -> ~q ~qbar (~q = squark)
52308C... = 36-39 : ~q -> ~q V
52309C... = 41-44 : S -> ~q ~qbar
52310C... = 46-49 : ~q -> ~q S
52311C... = 51-54 : chi -> q ~qbar (chi = neutralino/chargino)
52312C... = 56-59 : ~q -> q chi
52313C... = 61-64 : q -> ~q chi
52314C... = 66-69 : ~g -> q ~qbar
52315C... = 71-74 : ~q -> q ~g
52316C... = 76-79 : q -> ~q ~g
52317C... = 81-84 : (9/4)*(eikonal) for gg -> ~g ~g
52318C...Note that the order of the decay products is important.
52319C...In each set of four, the variants are ordered as:
52320C...ICOMBI = 1 : pure non-gamma5, i.e. vector/scalar/...
52321C... = 2 : pure gamma5, i.e. axial vector/pseudoscalar/....
52322C... = 3 : mixture alpha*(ICOMBI=1) + (1-alpha)*(ICOMBI=2)
52323C... = 4 : mixture (ICOMBI=1) +- (ICOMBI=2)
52324
52325 FUNCTION PYMAEL(NI,X1,X2,R1,R2,ALPHA)
52326
52327C...Double precision and integer declarations.
52328 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52329 IMPLICIT INTEGER(I-N)
52330
52331C...Check input values. Return zero outside allowed phase space.
52332 PYMAEL=0D0
52333 IF(X1.LE.2D0*R1.OR.X1.GE.1D0+R1**2-R2**2) RETURN
52334 IF(X2.LE.2D0*R2.OR.X2.GE.1D0+R2**2-R1**2) RETURN
52335 IF(X1+X2.LE.1D0+(R1+R2)**2) RETURN
52336 IF((2D0-2D0*X1-2D0*X2+X1*X2+2D0*R1**2+2D0*R2**2)**2.GE.
52337 &(X1**2-4D0*R1**2)*(X2**2-4D0*R2**2)) RETURN
52338 ALPCOR=MAX(0D0,MIN(1D0,ALPHA))
52339
52340C...Initial values and flags.
52341 ICLASS=NI/5
52342 ICOMBI=NI-5*ICLASS
52343 ISSET1=0
52344 ISSET2=0
52345 ISSET4=0
52346
52347C... Phase space.
52348 PS=SQRT((1D0-(R1+R2)**2)*(1D0-(R1-R2)**2))
52349
52350C...Eikonal expression; also acts as default.
52351 IF(ICLASS.LE.1.OR.ICLASS.GE.17.OR.ICOMBI.EQ.0) THEN
52352 RLO=PS
52353 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
52354 ANUM=0D0
52355 ELSEIF(ICOMBI.EQ.2) THEN
52356 ANUM=(2D0-X1-X2)**2
52357 ELSEIF(ICOMBI.EQ.3) THEN
52358 ANUM=ALPCOR*(2D0-X1-X2)**2
52359 ELSE
52360 ANUM=0.5D0*(2D0-X1-X2)**2
52361 ENDIF
52362 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
52363 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
52364 & R1**2/(1D0+R2**2-R1**2-X2)**2-
52365 & R2**2/(1D0+R1**2-R2**2-X1)**2)
52366 ICOMBI=0
52367
52368C...V -> q qbar (V = gamma*/Z0/W+-/...).
52369 ELSEIF(ICLASS.EQ.2) THEN
52370 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52371 RLO1=PS*(2-R1**2-R1**4+6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
52372 RFO1=-1.D0*(3+6*R1**2+R1**4-6*R1*R2+6*R1**3*R2-2*R2**2
52373 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-3*X1+6*R1*R2*X1
52374 & +2*R2**2*X1+X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)
52375 & +6*R1*R2*(2-X1-X2)-R2**2*(2-X1-X2)-2*X1*(2-X1-X2)
52376 & -5*R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
52377 & -3*(2-X1-X2)**2-3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2
52378 & +2*X1*(2-X1-X2)**2+(2-X1-X2)**3-X2)/
52379 & (-1+R1**2-R2**2+X2)**2
52380 RFO1=RFO1-2*(-3+R1**2-6*R1*R2+6*R1**3*R2+3*R2**2-4*R1**2*R2**2
52381 & +6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
52382 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)+3*R1*R2*(2-X1
52383 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
52384 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2+R1*R2*(2
52385 & -X1-X2)**2+X1*(2-X1-X2)**2)/
52386 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52387 RFO1=RFO1-1.D0*(-1+2*R1**2+R1**4+6*R1*R2+6*R1**3*R2-2*R2**2
52388 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-X1-2*R1**2*X1-6*R1*R2*X1
52389 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2
52390 & -X1-X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*
52391 & (2-X1-X2)+X2)/(-1-R1**2+R2**2+X1)**2
52392 RFO1=RFO1/2.D0
52393 ISSET1=1
52394 ENDIF
52395 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52396 RLO2=PS*(2-R1**2-R1**4-6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
52397 RFO2=-1*(3+6*R1**2+R1**4+6*R1*R2-6*R1**3*R2-2*R2**2
52398 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-3*X1-6*R1*R2*X1+2*R2**2*X1
52399 & +X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)-6*R1*R2*(2-X1-X2)
52400 & -R2**2*(2-X1-X2)-2*X1*(2-X1-X2)-5*R1**2*X1*(2-X1-X2)
52401 & +R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)-3*(2-X1-X2)**2
52402 & -3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2+2*X1*(2-X1-X2)**2
52403 & +(2-X1-X2)**3-X2)/(-1+R1**2-R2**2+X2)**2
52404 RFO2=RFO2-2*(-3+R1**2+6*R1*R2-6*R1**3*R2+3*R2**2-4*R1**2*R2**2
52405 & -6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
52406 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)-3*R1*R2*(2-X1
52407 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
52408 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2-R1*R2*(2
52409 & -X1-X2)**2+X1*(2-X1-X2)**2)/
52410 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52411 RFO2=RFO2-1*(-1+2*R1**2+R1**4-6*R1*R2-6*R1**3*R2-2*R2**2
52412 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-X1-2*R1**2*X1+6*R1*R2*X1
52413 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2-X1
52414 & -X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
52415 & +X2)/(-1-R1**2+R2**2+X1)**2
52416 RFO2=RFO2/2.D0
52417 ISSET2=1
52418 ENDIF
52419 IF(ICOMBI.EQ.4) THEN
52420 RLO4=PS*(2D0-R1**2-R1**4-R2**2+2D0*R1**2*R2**2-R2**4)/2D0
52421 RFO4=(1-R1**4+6*R1**2*R2**2-R2**4+X1+3*R1**2*X1-9*R2**2*X1
52422 & -3*X1**2-R1**2*X1**2+3*R2**2*X1**2+X1**3-X2-R1**2*X2
52423 & +R2**2*X2-R1**2*X1*X2+R2**2*X1*X2+X1**2*X2)/
52424 & (-1-R1**2+R2**2+X1)**2
52425 RFO4=RFO4
52426 & -2*(1+R1**2+R2**2-4*R1**2*R2**2+R1**2*X1+2*R2**2*X1-X1**2
52427 & -R2**2*X1**2+2*R1**2*X2+R2**2*X2-3*X1*X2+X1**2*X2-X2**2
52428 & -R1**2*X2**2+X1*X2**2)/
52429 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52430 RFO4=RFO4+(1-R1**4+6*R1**2*R2**2-R2**4-X1+R1**2*X1-R2**2*X1+X2
52431 & -9*R1**2*X2+3*R2**2*X2+R1**2*X1*X2-R2**2*X1*X2-3*X2**2
52432 & +3*R1**2*X2**2-R2**2*X2**2+X1*X2**2+X2**3)/
52433 & (-1+R1**2-R2**2+X2)**2
52434 RFO4=RFO4/2.D0
52435 ISSET4=1
52436 ENDIF
52437
52438C...q -> q V.
52439 ELSEIF(ICLASS.EQ.3) THEN
52440 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52441 RLO1=PS*(1D0-2D0*R1**2+R1**4+R2**2-6D0*R1*R2**2
52442 & +R1**2*R2**2-2D0*R2**4)
52443 RFO1=2*(-1+R1-2*R1**2+2*R1**3-R1**4+R1**5-R2**2+R1*R2**2
52444 & -5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4+2*X1-2*R1*X1
52445 & +2*R1**2*X1-2*R1**3*X1+2*R2**2*X1+5*R1*R2**2*X1
52446 & +R1**2*R2**2*X1+2*R2**4*X1-X1**2+R1*X1**2-R2**2*X1**2+3*X2
52447 & +4*R1**2*X2+R1**4*X2+2*R2**2*X2+2*R1**2*R2**2*X2-4*X1*X2
52448 & -2*R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-2*X2**2
52449 & -2*R1**2*X2**2+X1*X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
52450 RFO1=RFO1+(2*R2**2+6*R1*R2**2-6*R1**2*R2**2+6*R1**3*R2**2
52451 & +2*R2**4+6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
52452 & -R1**4*X2-3*R2**2*X2-6*R1*R2**2*X2+9*R1**2*R2**2*X2
52453 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
52454 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
52455 RFO1=RFO1+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4
52456 & +9*X1+10*R1**2*X1+R1**4*X1-3*R2**2*X1+6*R1*R2**2*X1
52457 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
52458 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2+6*R1*R2**2*X2
52459 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
52460 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2
52461 & +2*R2**2*X2**2+X1*X2**2)/(-2+X1+X2)**2
52462 ISSET1=1
52463 ENDIF
52464 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52465 RLO2=PS*(1D0-2D0*R1**2+R1**4+R2**2+6D0*R1*R2**2
52466 & +R1**2*R2**2-2D0*R2**4)
52467 RFO2=2*(1+R1+2*R1**2+2*R1**3+R1**4+R1**5+R2**2+R1*R2**2
52468 & +5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4-2*X1-2*R1*X1
52469 & -2*R1**2*X1-2*R1**3*X1-2*R2**2*X1+5*R1*R2**2*X1
52470 & -R1**2*R2**2*X1-2*R2**4*X1+X1**2+R1*X1**2+R2**2*X1**2-3*X2
52471 & -4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2+4*X1*X2
52472 & +2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2+2*R1**2*X2**2
52473 & -X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
52474 RFO2=RFO2+(2*R2**2-6*R1*R2**2-6*R1**2*R2**2-6*R1**3*R2**2
52475 & +2*R2**4-6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
52476 & -R1**4*X2-3*R2**2*X2+6*R1*R2**2*X2+9*R1**2*R2**2*X2
52477 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
52478 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
52479 RFO2=RFO2+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
52480 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1-6*R1*R2**2*X1
52481 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
52482 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2-6*R1*R2**2*X2
52483 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
52484 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
52485 & +X1*X2**2)/(-2+X1+X2)**2
52486 ISSET2=1
52487 ENDIF
52488 IF(ICOMBI.EQ.4) THEN
52489 RLO4=PS*(1.D0-2.D0*R1**2+R1**4+R2**2+R1**2*R2**2-2.D0*R2**4)
52490 RFO4=2*(1+2*R1**2+R1**4+R2**2+5*R1**2*R2**2-2*X1-2*R1**2*X1
52491 & -2*R2**2*X1-R1**2*R2**2*X1-2*R2**4*X1+X1**2+R2**2*X1**2
52492 & -3*X2-4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2
52493 & +4*X1*X2+2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2
52494 & +2*R1**2*X2**2-X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
52495 RFO4=RFO4+(2*R2**2-6*R1**2*R2**2+2*R2**4-R2**2*X1+R1**2*R2**2*X1
52496 & -R2**4*X1+X2-R1**4*X2-3*R2**2*X2+9*R1**2*R2**2*X2
52497 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
52498 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
52499 RFO4=RFO4+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
52500 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1+R1**2*R2**2*X1-2*R2**4*X1
52501 & -6*X1**2-2*R1**2*X1**2+X1**3+7*X2+8*R1**2*X2+R1**4*X2
52502 & -7*R2**2*X2+R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
52503 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
52504 & +X1*X2**2)/(2-X1-X2)**2
52505 ISSET4=1
52506 ENDIF
52507
52508C...S -> q qbar (S = h0/H0/A0/H+-/...).
52509 ELSEIF(ICLASS.EQ.4) THEN
52510 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52511 RLO1=PS*(1D0-R1**2-R2**2-2D0*R1*R2)
52512 RFO1=-(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
52513 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
52514 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
52515 & -2*(R1**2+R1**4-2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3
52516 & +R2**4-R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2
52517 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52518 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
52519 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
52520 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
52521 ISSET1=1
52522 ENDIF
52523 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52524 RLO2=PS*(1D0-R1**2-R2**2+2D0*R1*R2)
52525 RFO2=-(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
52526 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
52527 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
52528 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
52529 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
52530 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
52531 & +2*(-R1**2-R1**4-2*R1**3*R2-R2**2+6*R1**2*R2**2
52532 & -2*R1*R2**3-R2**4+R1**2*X1+R1*R2*X1-2*R2**2*X1
52533 & -2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
52534 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52535 ISSET2=1
52536 ENDIF
52537 IF(ICOMBI.EQ.4) THEN
52538 RLO4=PS*(1D0-R1**2-R2**2)
52539 RFO4=-(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
52540 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
52541 & -2*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
52542 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
52543 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52544 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1
52545 & +X2+3*R1**2*X2-R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
52546 ISSET4=1
52547 ENDIF
52548
52549C...q -> q S.
52550 ELSEIF(ICLASS.EQ.5) THEN
52551 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52552 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
52553 RFO1=(4-4*R1**2+4*R2**2-3*X1-2*R1*X1+R1**2*X1-R2**2*X1-5*X2
52554 & -2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
52555 & +2*(3-R1-5*R1**2-R1**3+3*R2**2+R1*R2**2-2*X1-R1*X1
52556 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52557 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
52558 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
52559 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52560 & (-1+R1**2-R2**2+X2)**2
52561 ISSET1=1
52562 ENDIF
52563 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52564 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
52565 RFO2=(4-4*R1**2+4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2
52566 & +2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
52567 & +2*(3+R1-5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1
52568 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52569 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
52570 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
52571 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52572 & (-1+R1**2-R2**2+X2)**2
52573 ISSET2=1
52574 ENDIF
52575 IF(ICOMBI.EQ.4) THEN
52576 RLO4=PS*(1D0+R1**2-R2**2)
52577 RFO4=(4-4*R1**2+4*R2**2-3*X1+R1**2*X1-R2**2*X1-5*X2+R1**2*X2
52578 & -R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
52579 & +2*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2+2*R1**2*X2
52580 & -R2**2*X2+X1*X2+X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
52581 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
52582 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
52583 ISSET4=1
52584 ENDIF
52585
52586C...V -> ~q ~qbar (~q = squark).
52587 ELSEIF(ICLASS.EQ.6) THEN
52588 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
52589 RFO1=2D0*3D0+(1+R1**2+R2**2-X1)*(4*R1**2-X1**2)/
52590 & (-1-R1**2+R2**2+X1)**2
52591 & -2D0*(-1-3*R1**2-R2**2+X1+X1**2/2+X2-X1*X2/2)/
52592 & (-1-R1**2+R2**2+X1)
52593 & +(1+R1**2+R2**2-X2)*(4*R2**2-X2**2)
52594 & /(-1+R1**2-R2**2+X2)**2
52595 & -2D0*(-1-R1**2-3*R2**2+X1+X2-X1*X2/2+X2**2/2)/
52596 & (-1+R1**2-R2**2+X2)
52597 & -(-4*R1**2-4*R1**4-4*R2**2-8*R1**2*R2**2-4*R2**4+2*X1
52598 & +6*R1**2*X1+6*R2**2*X1-2*X1**2+2*X2+6*R1**2*X2+6*R2**2*X2
52599 & -4*X1*X2-2*R1**2*X1*X2-2*R2**2*X1*X2+X1**2*X2-2*X2**2
52600 & +X1*X2**2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52601 ISSET1=1
52602
52603C...~q -> ~q V.
52604 ELSEIF(ICLASS.EQ.7) THEN
52605 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
52606 RFO1=16*R2**2+8*(4*R2**2+2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2
52607 & -2*X2**2)/(3*(-1+R1**2-R2**2+X2))+8*(1+R1**2+R2**2-X2)*
52608 & (4*R2**2-X2**2)/(3*(-1+R1**2-R2**2+X2)**2)+8*(X1+X2)*
52609 & (-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
52610 & +2*R1**2*X1+2*R2**2*X1-X1**2+2*X2+2*R1**2*X2+2*R2**2*X2
52611 & -2*X1*X2-X2**2)/(3*(-2+X1+X2)**2)+8*(-1-R1**2+R2**2-X1)*
52612 & (2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2-X2**2)/
52613 & (3*(-1+R1**2-R2**2+X2)*(-2+X1+X2))+8*(1+2*R1**2+R1**4
52614 & +2*R2**2-2*R1**2*R2**2+R2**4-2*X1-2*R1**2*X1-4*R2**2*X1
52615 & +X1**2-3*X2-3*R1**2*X2-3*R2**2*X2+3*X1*X2+2*X2**2)/
52616 & (3*(-2+X1+X2))
52617 RFO1=3D0*RFO1/8D0
52618 ISSET1=1
52619
52620C...S -> ~q ~qbar.
52621 ELSEIF(ICLASS.EQ.8) THEN
52622 RLO1=PS
52623 RFO1=(-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
52624 & +2*R1**2*X1+2*R2**2*X1-X1**2-R2**2*X1**2+2*X2+2*R1**2*X2
52625 & +2*R2**2*X2-3*X1*X2-R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-X2**2
52626 & -R1**2*X2**2+X1*X2**2)/
52627 & (1+R1**2-R2**2-X1)**2/(-1+R1**2-R2**2+X2)**2
52628 RFO1=2D0*RFO1
52629 ISSET1=1
52630
52631C...~q -> ~q S.
52632 ELSEIF(ICLASS.EQ.9) THEN
52633 RLO1=PS
52634 RFO1=(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
52635 & +(1+R1**2-R2**2+X1)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
52636 & -(X1+X2)/(-2+X1+X2)**2
52637 ISSET1=1
52638
52639C...chi -> q ~qbar (chi = neutralino/chargino).
52640 ELSEIF(ICLASS.EQ.10) THEN
52641 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52642 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
52643 RFO1=(2*R1+X1)*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
52644 & +2*(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1
52645 & -R1**2*X1/2-R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
52646 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52647 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
52648 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52649 & (-1+R1**2-R2**2+X2)**2
52650 ISSET1=1
52651 ENDIF
52652 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52653 RLO2=PS*(1D0-2D0*R1+R1**2-R2**2)
52654 RFO2=(2*R1-X1)*(1+R1**2+R2**2-X1)/(-1-R1**2+R2**2+X1)**2
52655 & +2*(-1-R1**2+2*R1**3-R2**2+2*R1*R2**2+3*X1/2-R1*X1
52656 & -R1**2*X1/2-R2**2*X1/2+X2-R1*X2+R1**2*X2-X1*X2/2)/
52657 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52658 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
52659 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52660 & (-1+R1**2-R2**2+X2)**2
52661 ISSET2=1
52662 ENDIF
52663 IF(ICOMBI.EQ.4) THEN
52664 RLO4=PS*(1+R1**2-R2**2)
52665 RFO4=X1*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
52666 & +2D0*(-1-R1**2-R2**2+3*X1/2-R1**2*X1/2-R2**2*X1/2
52667 & +X2+R1**2*X2-X1*X2/2)/
52668 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52669 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
52670 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
52671 ISSET4=1
52672 ENDIF
52673
52674C...~q -> q chi.
52675 ELSEIF(ICLASS.EQ.11) THEN
52676 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52677 RLO1=PS*(1D0-(R1+R2)**2)
52678 RFO1=(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
52679 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
52680 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
52681 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
52682 & +(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
52683 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
52684 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
52685 ISSET1=1
52686 ENDIF
52687 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52688 RLO2=PS*(1D0-(R1-R2)**2)
52689 RFO2=(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/
52690 & (-2+X1+X2)**2
52691 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
52692 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
52693 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
52694 & +(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3+R2**4
52695 & +X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
52696 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
52697 ISSET2=1
52698 ENDIF
52699 IF(ICOMBI.EQ.4) THEN
52700 RLO4=PS*(1D0-R1**2-R2**2)
52701 RFO4=(1+R1**2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
52702 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2
52703 & +3*R1**2*X2-R2**2*X2-X1*X2)/
52704 & (-1+R1**2-R2**2+X2)**2
52705 & -(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
52706 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
52707 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
52708 ISSET4=1
52709 ENDIF
52710
52711C...q -> ~q chi.
52712 ELSEIF(ICLASS.EQ.12) THEN
52713 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52714 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
52715 RFO1=(2*R2+X2)*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
52716 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1-2*R2*X1+R2**2*X1+X1**2
52717 & -3*X2-R1**2*X2-2*R2*X2+R2**2*X2+X1*X2)/
52718 & (-2+X1+X2)**2-2*(-1-R1**2+R2+R1**2*R2-R2**2-R2**3+X1
52719 & +R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
52720 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
52721 ISSET1=1
52722 END IF
52723 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52724 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
52725 RFO2=(2*R2-X2)*(1+R1**2+R2**2-X2)/(-1+R1**2-R2**2+X2)**2
52726 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1+X1**2
52727 & -3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
52728 & (-2+X1+X2)**2-2*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
52729 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
52730 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
52731 ISSET2=1
52732 END IF
52733 IF(ICOMBI.EQ.4) THEN
52734 RLO4=PS*(1D0-R1**2+R2**2)
52735 RFO4=X2*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
52736 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2
52737 & -3*X2-R1**2*X2+R2**2*X2+X1*X2)/
52738 & (-2+X1+X2)**2-2*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2
52739 & +R1**2*X2-X1*X2/2-X2**2/2)/
52740 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
52741 ISSET4=1
52742 END IF
52743
52744C...~g -> q ~qbar.
52745 ELSEIF(ICLASS.EQ.13) THEN
52746 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52747 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
52748 RFO1=4*(2*R1+X1)*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)
52749 & -(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1-R1**2*X1/2
52750 & -R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/(3*(-1-R1**2+R2**2
52751 & +X1)*(-1+R1**2-R2**2+X2))-3*(-1+R1-R1**2-R1**3-R2**2
52752 & +R1*R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
52753 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+3*(4-4*R1**2+4*R2**2-3*X1
52754 & -2*R1*X1+R1**2*X1-R2**2*X1-5*X2-2*R1*X2+R1**2*X2-R2**2*X2
52755 & +X1*X2+X2**2)/(-2+X1+X2)**2+3*(3-R1-5*R1**2-R1**3+3*R2**2
52756 & +R1*R2**2-2*X1-R1*X1+R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2
52757 & +X1*X2+X2**2)/((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2-2*R1
52758 & -6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1-R2**2*X1
52759 & -3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52760 & (3*(-1+R1**2-R2**2+X2)**2)
52761 RFO1=3D0*RFO1/4D0
52762 ISSET1=1
52763 ENDIF
52764 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52765 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
52766 RFO2=4*(2*R1-X1)*(1+R1**2+R2**2-X1)/(3*(-1-R1**2+R2**2+X1)**2)
52767 & -3*(-1-R1-R1**2+R1**3-R2**2-R1*R2**2+2*X1+R2**2*X1-X1**2/2
52768 & +X2-R1*X2+R1**2*X2-X1*X2/2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
52769 & +(2+2*R1**2-4*R1**3+2*R2**2-4*R1*R2**2-3*X1+2*R1*X1
52770 & +R1**2*X1+R2**2*X1-2*X2+2*R1*X2-2*R1**2*X2+X1*X2)/
52771 & (6*(-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+3*(4-4*R1**2
52772 & +4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2+2*R1*X2
52773 & +R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2+3*(3+R1
52774 & -5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1+R1**2*X1-4*X2
52775 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52776 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2+2*R1-6*R1**2+2*R1**3
52777 & +2*R2**2+2*R1*R2**2-X1+R1**2*X1-R2**2*X1-3*X2-2*R1*X2
52778 & +3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52779 & (3*(-1+R1**2-R2**2+X2)**2)
52780 RFO2=3D0*RFO2/4D0
52781 ISSET2=1
52782 ENDIF
52783 IF(ICOMBI.EQ.4) THEN
52784 RLO4=PS*(1D0+R1**2-R2**2)
52785 RFO4=8*X1*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)-6*(-1
52786 & -R1**2-R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1**2*X2-X1*X2/2)/
52787 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+(2+2*R1**2+2*R2**2-3*X1
52788 & +R1**2*X1+R2**2*X1-2*X2-2*R1**2*X2+X1*X2)/(3*(-1-R1**2
52789 & +R2**2+X1)*(-1+R1**2-R2**2+X2))+6*(4-4*R1**2+4*R2**2-3*X1
52790 & +R1**2*X1-R2**2*X1-5*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52791 & (-2+X1+X2)**2+6*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2
52792 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52793 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+8*(2-6*R1**2+2*R2**2-X1
52794 & +R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52795 & (3*(-1+R1**2-R2**2+X2)**2)
52796 RFO4=3D0*RFO4/8D0
52797 ISSET4=1
52798 ENDIF
52799
52800C...~q -> q ~g.
52801 ELSEIF(ICLASS.EQ.14) THEN
52802 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52803 RLO1=PS*(1-R1**2-R2**2-2D0*R1*R2)
52804 RFO1=64*(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
52805 & -16*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
52806 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
52807 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-16*(R1**2+R1**4
52808 & -2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3+R2**4
52809 & -R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2-R2**2*X2
52810 & -X1*X2)/((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
52811 & -64*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
52812 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
52813 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
52814 & +8*(-1+R1**4-2*R1*R2+2*R1**3*R2-2*R2**2-2*R1*R2**3-R2**4
52815 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2-2*R1*R2*X2
52816 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
52817 RFO1=RFO1
52818 & +8*(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
52819 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
52820 & +X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
52821 RFO1=9D0*RFO1/64D0
52822 ISSET1=1
52823 ENDIF
52824 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52825 RLO2=PS*(1-R1**2-R2**2+2D0*R1*R2)
52826 RFO2=64*(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
52827 & -16*(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
52828 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
52829 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-64*(-1+R1**4
52830 & +2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3+R2**4+X1
52831 & -R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2-R2**2*X2
52832 & -X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)+16*(-R1**2-R1**4
52833 & -2*R1**3*R2-R2**2+6*R1**2*R2**2-2*R1*R2**3-R2**4+R1**2*X1
52834 & +R1*R2*X1-2*R2**2*X1-2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
52835 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
52836 RFO2=RFO2
52837 & +8*(-1+R1**4+2*R1*R2-2*R1**3*R2-2*R2**2+2*R1*R2**3-R2**4
52838 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2+2*R1*R2*X2
52839 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
52840 & +8*(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3
52841 & +R2**4+X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2
52842 & -2*R2**2*X2+X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
52843 RFO2=9D0*RFO2/64D0
52844 ISSET2=1
52845 ENDIF
52846 IF(ICOMBI.EQ.4) THEN
52847 RLO4=PS*(1-R1**2-R2**2)
52848 RFO4=128*(1+R1**2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)-32*(-1
52849 & +R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
52850 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
52851 & -32*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
52852 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
52853 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))-128*(-1+R1**4
52854 & -6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2
52855 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
52856 & +16*(-1+R1**4-2*R2**2-R2**4-2*R1**2*X1+2*R2**2*X1+X1**2
52857 & +X2-3*R1**2*X2+R2**2*X2+X1*X2)/
52858 & ((-1-R1**2+R2**2+X1)*(-2+X1+ X2))
52859 RFO4=RFO4+16*(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
52860 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
52861 & (9*(1-R1**2+R2**2-X2)*(-2+X1+X2))
52862 RFO4=9D0*RFO4/128D0
52863 ISSET4=1
52864 ENDIF
52865
52866C...q -> ~q ~g.
52867 ELSEIF(ICLASS.EQ.15) THEN
52868 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52869 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
52870 RFO1=32*(2*R2+X2)*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
52871 & +8*(-1-R1**2-2*R1**2*R2-R2**2-2*R2**3+X1+R2*X1+R2**2*X1
52872 & +3*X2/2-R1**2*X2/2+R2*X2-R2**2*X2/2-X1*X2/2)/
52873 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2-2*R2
52874 & -2*R1**2*R2-6*R2**2-2*R2**3-3*X1-R1**2*X1+2*R2*X1
52875 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
52876 & (-1-R1**2+R2**2+X1)**2+32*(4+4*R1**2-4*R2**2-5*X1
52877 & -R1**2*X1-2*R2*X1+R2**2*X1+X1**2-3*X2-R1**2*X2-2*R2*X2
52878 & +R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
52879 RFO1=RFO1+8*(3+3*R1**2-R2+R1**2*R2-5*R2**2-R2**3-4*X1-R1**2*X1
52880 & +2*R2**2*X1+X1**2-2*X2-R2*X2+R2**2*X2+X1*X2)/
52881 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+8*(-1-R1**2+R2+R1**2*R2
52882 & -R2**2-R2**3+X1+R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
52883 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
52884 RFO1=9D0*RFO1/32D0
52885 ISSET1=1
52886 END IF
52887 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52888 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
52889 RFO2=32*(2*R2-X2)*(1+R1**2+R2**2-X2)/(9*(-1+R1**2-R2**2+X2)**2)
52890 & +8*(-1-R1**2+2*R1**2*R2-R2**2+2*R2**3+X1-R2*X1+R2**2*X1
52891 & +3*X2/2-R1**2*X2/2-R2*X2-R2**2*X2/2-X1*X2/2)/
52892 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2+2*R2
52893 & +2*R1**2*R2-6*R2**2+2*R2**3-3*X1-R1**2*X1-2*R2*X1
52894 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
52895 & (-1-R1**2+R2**2+X1)**2+8*(3+3*R1**2+R2-R1**2*R2-5*R2**2
52896 & +R2**3-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2*X2+R2**2*X2
52897 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
52898 RFO2=RFO2+32*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1
52899 & +X1**2-3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
52900 & (9*(-2+X1+X2)**2)+8*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
52901 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
52902 & (9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
52903 RFO2=9D0*RFO2/32D0
52904 ISSET2=1
52905 END IF
52906 IF(ICOMBI.EQ.4) THEN
52907 RLO4=PS*(1D0-R1**2+R2**2)
52908 RFO4=64*X2*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
52909 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+3*X2/2-R1**2*X2/2
52910 & -R2**2*X2/2-X1*X2/2)/
52911 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+16*(3+3*R1**2
52912 & -5*R2**2-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2**2*X2
52913 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
52914 & +64*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2-3*X2
52915 & -R1**2*X2+R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
52916 RFO4=RFO4+16*(2+2*R1**2-6*R2**2-3*X1-R1**2*X1+3*R2**2*X1+X1**2
52917 & -X2-R1**2*X2+R2**2*X2+X1*X2)/(-1-R1**2+R2**2+X1)**2
52918 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
52919 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
52920 RFO4=9D0*RFO4/64D0
52921 ISSET4=1
52922 END IF
52923
52924C...g -> ~g ~g. Use (9/4)*eikonal. May be changed in the future.
52925 ELSEIF(ICLASS.EQ.16) THEN
52926 RLO=PS
52927 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
52928 ANUM=0D0
52929 ELSEIF(ICOMBI.EQ.2) THEN
52930 ANUM=(2D0-X1-X2)**2
52931 ELSEIF(ICOMBI.EQ.3) THEN
52932 ANUM=ALPCOR*(2D0-X1-X2)**2
52933 ELSE
52934 ANUM=0.5D0*(2D0-X1-X2)**2
52935 ENDIF
52936 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
52937 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
52938 & R1**2/(1D0+R2**2-R1**2-X2)**2-
52939 & R2**2/(1D0+R1**2-R2**2-X1)**2)
52940 RFO=9D0*RFO/4D0
52941 ICOMBI=0
52942 ENDIF
52943
52944C...Find relevant LO and FO expression.
52945 IF(ICOMBI.EQ.0) THEN
52946 ELSEIF(ICOMBI.EQ.1.AND.ISSET1.EQ.1) THEN
52947 RLO=RLO1
52948 RFO=RFO1
52949 ELSEIF(ICOMBI.EQ.2.AND.ISSET2.EQ.1) THEN
52950 RLO=RLO2
52951 RFO=RFO2
52952 ELSEIF(ICOMBI.EQ.3.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
52953 RLO=ALPCOR*RLO1+(1D0-ALPCOR)*RLO2
52954 RFO=ALPCOR*RFO1+(1D0-ALPCOR)*RFO2
52955 ELSEIF(ISSET4.EQ.1) THEN
52956 RLO=RLO4
52957 RFO=RFO4
52958 ELSEIF(ICOMBI.EQ.4.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
52959 RLO=0.5D0*(RLO1+RLO2)
52960 RFO=0.5D0*(RFO1+RFO2)
52961 ELSEIF(ISSET1.EQ.1) THEN
52962 RLO=RLO1
52963 RFO=RFO1
52964 ELSE
52965 CALL PYERRM(16,'(PYMAEL:) not implemented ME code')
52966 RLO=1D0
52967 RFO=0D0
52968 ENDIF
52969
52970C...Output.
52971 PYMAEL=RFO/RLO
52972
52973 RETURN
52974 END
52975
52976C*********************************************************************
52977
52978C...PYBOEI
52979C...Modifies an event so as to approximately take into account
52980C...Bose-Einstein effects according to a simple phenomenological
52981C...parametrization.
52982
52983 SUBROUTINE PYBOEI(NSAV)
52984
52985C...Double precision and integer declarations.
52986 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52987 IMPLICIT INTEGER(I-N)
52988 INTEGER PYK,PYCHGE,PYCOMP
52989C...Parameter statement to help give large particle numbers.
52990 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52991 &KEXCIT=4000000,KDIMEN=5000000)
52992C...Commonblocks.
52993 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
52994 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52995 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52996 COMMON/PYINT1/MINT(400),VINT(400)
52997 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/
52998C...Local arrays and data.
52999 DIMENSION DPS(4),KFBE(9),NBE(0:10),BEI(100),BEI3(100),
53000 &BEIW(100),BEI3W(100)
53001 DATA KFBE/211,-211,111,321,-321,130,310,221,331/
53002C...Statement function: squared invariant mass.
53003 SDIP(I,J)=((P(I,4)+P(J,4))**2-(P(I,3)+P(J,3))**2-
53004 &(P(I,2)+P(J,2))**2-(P(I,1)+P(J,1))**2)
53005
53006C...Boost event to overall CM frame. Calculate CM energy.
53007 IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
53008 DO 100 J=1,4
53009 DPS(J)=0D0
53010 100 CONTINUE
53011 DO 120 I=1,N
53012 KFA=IABS(K(I,2))
53013 IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22)
53014 & .AND.K(I,3).GT.0) THEN
53015 KFMA=IABS(K(K(I,3),2))
53016 IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
53017 ENDIF
53018 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
53019 DO 110 J=1,4
53020 DPS(J)=DPS(J)+P(I,J)
53021 110 CONTINUE
53022 120 CONTINUE
53023 CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
53024 &-DPS(3)/DPS(4))
53025 PECM=0D0
53026 DO 130 I=1,N
53027 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
53028 130 CONTINUE
53029
53030C...Check if we have separated strings
53031
53032C...Reserve copy of particles by species at end of record.
53033 IWP=0
53034 IWN=0
53035 NBE(0)=N+MSTU(3)
53036 NMAX=NBE(0)
53037 SMMIN=PECM
53038 DO 190 IBE=1,MIN(10,MSTJ(52)+1)
53039 NBE(IBE)=NBE(IBE-1)
53040 DO 180 I=NSAV+1,N
53041 IF(IBE.EQ.MIN(10,MSTJ(52)+1)) THEN
53042 DO 140 IIBE=1,IBE-1
53043 IF(K(I,2).EQ.KFBE(IIBE)) GOTO 180
53044 140 CONTINUE
53045 ELSE
53046 IF(K(I,2).NE.KFBE(IBE)) GOTO 180
53047 ENDIF
53048 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 180
53049 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
53050 CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS')
53051 RETURN
53052 ENDIF
53053 NBE(IBE)=NBE(IBE)+1
53054 NMAX=NBE(IBE)
53055 K(NBE(IBE),1)=I
53056 K(NBE(IBE),2)=0
53057 K(NBE(IBE),3)=0
53058 K(NBE(IBE),4)=0
53059 K(NBE(IBE),5)=0
53060 P(NBE(IBE),1)=0.0D0
53061 P(NBE(IBE),2)=0.0D0
53062 P(NBE(IBE),3)=0.0D0
53063 P(NBE(IBE),4)=0.0D0
53064 P(NBE(IBE),5)=0.0D0
53065 SMMIN=MIN(SMMIN,P(I,5))
53066C...Check if particles comes from different W's or Z's
53067 IF((MSTJ(53).NE.0.OR.MSTJ(56).GT.0).AND.MINT(32).EQ.0) THEN
53068 IM=I
53069 150 IF(K(IM,3).GT.0) THEN
53070 IM=K(IM,3)
53071 IF(ABS(K(IM,2)).NE.24.AND.K(IM,2).NE.23) GOTO 150
53072 K(NBE(IBE),5)=IM
53073 IF(IWP.EQ.0.AND.K(IM,2).EQ.24) IWP=IM
53074 IF(IWN.EQ.0.AND.K(IM,2).EQ.-24) IWN=IM
53075 IF(IWP.EQ.0.AND.K(IM,2).EQ.23) IWP=IM
53076 IF(IWN.EQ.0.AND.K(IM,2).EQ.23.AND.IM.NE.IWP) IWN=IM
53077 ENDIF
53078 ENDIF
53079C...Check if particles comes from different strings.
53080 IF(PARJ(94).GT.0.0D0) THEN
53081 IM=I
53082 160 IF(K(IM,3).GT.0) THEN
53083 IM=K(IM,3)
53084 IF(K(IM,2).NE.92.AND.K(IM,2).NE.91) GOTO 160
53085 K(NBE(IBE),5)=IM
53086 ENDIF
53087 ENDIF
53088 DO 170 J=1,3
53089 P(NBE(IBE),J)=0D0
53090 V(NBE(IBE),J)=0D0
53091 170 CONTINUE
53092 P(NBE(IBE),5)=-1.0D0
53093 180 CONTINUE
53094 190 CONTINUE
53095 IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 510
53096
53097C...Calculate separation between W+ and W- or between two Z0's.
53098C...No separation if there has been re-connections.
53099 SIGW=PARJ(93)
53100 IF(IWP.GT.0.AND.IWN.GT.0.AND.MSTJ(56).GT.0.AND.MINT(32).EQ.0) THEN
53101 IF(K(IWP,2).EQ.23) THEN
53102 DMW=PMAS(23,1)
53103 DGW=PMAS(23,2)
53104 ELSE
53105 DMW=PMAS(24,1)
53106 DGW=PMAS(24,2)
53107 ENDIF
53108 DMP=P(IWP,5)
53109 DMN=P(IWN,5)
53110 TAUPD=DMP/SQRT((DMP**2-DMW**2)**2+(DGW*(DMP**2)/DMW)**2)
53111 TAUND=DMN/SQRT((DMN**2-DMW**2)**2+(DGW*(DMN**2)/DMW)**2)
53112 TAUP=-TAUPD*LOG(PYR(IDUM))
53113 TAUN=-TAUND*LOG(PYR(IDUM))
53114 DXP=TAUP*PYP(IWP,8)/DMP
53115 DXN=TAUN*PYP(IWN,8)/DMN
53116 DX=DXP+DXN
53117 SIGW=1.0D0/(1.0D0/PARJ(93)+REAL(MSTJ(56))*DX)
53118 IF(PARJ(94).LT.0.0D0) SIGW=1.0D0/(1.0D0/SIGW-1.0D0/PARJ(94))
53119 ENDIF
53120
53121C...Add separation between strings.
53122 IF(PARJ(94).GT.0.0D0) THEN
53123 SIGW=1.0D0/(1.0D0/SIGW+1.0D0/PARJ(94))
53124 IWP=-1
53125 IWN=-1
53126 ENDIF
53127
53128 IF(MSTJ(57).EQ.1.AND.MSTJ(54).LT.0) THEN
53129 DO 220 IBE=1,MIN(9,MSTJ(52))
53130 DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)
53131 Q2MIN=PECM**2
53132 I1=K(I1M,1)
53133 DO 200 I2M=NBE(IBE-1)+1,NBE(IBE)
53134 IF(I2M.EQ.I1M) GOTO 200
53135 I2=K(I2M,1)
53136 Q2=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-
53137 & (P(I1,2)+P(I2,2))**2-(P(I1,3)+P(I2,3))**2-
53138 & (P(I1,5)+P(I2,5))**2
53139 IF(Q2.GT.0.0D0.AND.Q2.LT.Q2MIN) THEN
53140 Q2MIN=Q2
53141 ENDIF
53142 200 CONTINUE
53143 P(I1M,5)=Q2MIN
53144 210 CONTINUE
53145 220 CONTINUE
53146 ENDIF
53147
53148C...Tabulate integral for subsequent momentum shift.
53149 DO 400 IBE=1,MIN(9,MSTJ(52))
53150 IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 270
53151 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
53152 & .LE.1) GOTO 270
53153 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
53154 & NBE(7)-NBE(6)).LE.1) GOTO 270
53155 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 270
53156 IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211)
53157 IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321)
53158 IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221)
53159 IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331)
53160 QDEL=0.1D0*MIN(PMHQ,PARJ(93))
53161 QDEL3=0.1D0*MIN(PMHQ,PARJ(93)*3.0D0)
53162 QDELW=0.1D0*MIN(PMHQ,SIGW)
53163 QDEL3W=0.1D0*MIN(PMHQ,SIGW*3.0D0)
53164 IF(MSTJ(51).EQ.1) THEN
53165 NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL))
53166 NBIN3=MIN(100,NINT(27D0*PARJ(93)/QDEL3))
53167 NBINW=MIN(100,NINT(9D0*SIGW/QDELW))
53168 NBIN3W=MIN(100,NINT(27D0*SIGW/QDEL3W))
53169 BEEX=EXP(0.5D0*QDEL/PARJ(93))
53170 BEEX3=EXP(0.5D0*QDEL3/(3.0D0*PARJ(93)))
53171 BEEXW=EXP(0.5D0*QDELW/SIGW)
53172 BEEX3W=EXP(0.5D0*QDEL3W/(3.0D0*SIGW))
53173 BERT=EXP(-QDEL/PARJ(93))
53174 BERT3=EXP(-QDEL3/(3.0D0*PARJ(93)))
53175 BERTW=EXP(-QDELW/SIGW)
53176 BERT3W=EXP(-QDEL3W/(3.0D0*SIGW))
53177 ELSE
53178 NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL))
53179 NBIN3=MIN(100,NINT(9D0*PARJ(93)/QDEL3))
53180 NBINW=MIN(100,NINT(3D0*SIGW/QDELW))
53181 NBIN3W=MIN(100,NINT(9D0*SIGW/QDEL3W))
53182 ENDIF
53183 DO 230 IBIN=1,NBIN
53184 QBIN=QDEL*(IBIN-0.5D0)
53185 BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2)
53186 IF(MSTJ(51).EQ.1) THEN
53187 BEEX=BEEX*BERT
53188 BEI(IBIN)=BEI(IBIN)*BEEX
53189 ELSE
53190 BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
53191 ENDIF
53192 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
53193 230 CONTINUE
53194 DO 240 IBIN=1,NBIN3
53195 QBIN=QDEL3*(IBIN-0.5D0)
53196 BEI3(IBIN)=QDEL3*(QBIN**2+QDEL3**2/12D0)/SQRT(QBIN**2+PMHQ**2)
53197 IF(MSTJ(51).EQ.1) THEN
53198 BEEX3=BEEX3*BERT3
53199 BEI3(IBIN)=BEI3(IBIN)*BEEX3
53200 ELSE
53201 BEI3(IBIN)=BEI3(IBIN)*EXP(-(QBIN/(3.0D0*PARJ(93)))**2)
53202 ENDIF
53203 IF(IBIN.GE.2) BEI3(IBIN)=BEI3(IBIN)+BEI3(IBIN-1)
53204 240 CONTINUE
53205 DO 250 IBIN=1,NBINW
53206 QBIN=QDELW*(IBIN-0.5D0)
53207 BEIW(IBIN)=QDELW*(QBIN**2+QDELW**2/12D0)/SQRT(QBIN**2+PMHQ**2)
53208 IF(MSTJ(51).EQ.1) THEN
53209 BEEXW=BEEXW*BERTW
53210 BEIW(IBIN)=BEIW(IBIN)*BEEXW
53211 ELSE
53212 BEIW(IBIN)=BEIW(IBIN)*EXP(-(QBIN/SIGW)**2)
53213 ENDIF
53214 IF(IBIN.GE.2) BEIW(IBIN)=BEIW(IBIN)+BEIW(IBIN-1)
53215 250 CONTINUE
53216 DO 260 IBIN=1,NBIN3W
53217 QBIN=QDEL3W*(IBIN-0.5D0)
53218 BEI3W(IBIN)=QDEL3W*(QBIN**2+QDEL3W**2/12D0)/
53219 & SQRT(QBIN**2+PMHQ**2)
53220 IF(MSTJ(51).EQ.1) THEN
53221 BEEX3W=BEEX3W*BERT3W
53222 BEI3W(IBIN)=BEI3W(IBIN)*BEEX3W
53223 ELSE
53224 BEI3W(IBIN)=BEI3W(IBIN)*EXP(-(QBIN/(3.0D0*SIGW))**2)
53225 ENDIF
53226 IF(IBIN.GE.2) BEI3W(IBIN)=BEI3W(IBIN)+BEI3W(IBIN-1)
53227 260 CONTINUE
53228
53229C...Loop through particle pairs and find old relative momentum.
53230 270 DO 390 I1M=NBE(IBE-1)+1,NBE(IBE)-1
53231 I1=K(I1M,1)
53232 DO 380 I2M=I1M+1,NBE(IBE)
53233 IF(MSTJ(53).EQ.1.AND.K(I1M,5).NE.K(I2M,5)) GOTO 380
53234 IF(MSTJ(53).EQ.2.AND.K(I1M,5).EQ.K(I2M,5)) GOTO 380
53235 I2=K(I2M,1)
53236 Q2OLD=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
53237 & P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2
53238 IF(Q2OLD.LE.0.0D0) GOTO 380
53239 QOLD=SQRT(Q2OLD)
53240
53241C...Calculate new relative momentum.
53242 QMOV=0.0D0
53243 QMOV3=0.0D0
53244 QMOVW=0.0D0
53245 QMOV3W=0.0D0
53246 IF(QOLD.LT.1D-3*QDEL) THEN
53247 GOTO 280
53248 ELSEIF(QOLD.LE.QDEL) THEN
53249 QMOV=QOLD/3D0
53250 ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN
53251 RBIN=QOLD/QDEL
53252 IBIN=RBIN
53253 RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
53254 QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
53255 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
53256 ELSE
53257 QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
53258 ENDIF
53259 280 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0)
53260 IF(QOLD.LT.1D-3*QDEL3) THEN
53261 GOTO 290
53262 ELSEIF(QOLD.LE.QDEL3) THEN
53263 QMOV3=QOLD/3D0
53264 ELSEIF(QOLD.LT.(NBIN3-0.1D0)*QDEL3) THEN
53265 RBIN3=QOLD/QDEL3
53266 IBIN3=RBIN3
53267 RINP3=(RBIN3**3-IBIN3**3)/(3*IBIN3*(IBIN3+1)+1)
53268 QMOV3=(BEI3(IBIN3)+RINP3*(BEI3(IBIN3+1)-BEI3(IBIN3)))*
53269 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
53270 ELSE
53271 QMOV3=BEI3(NBIN3)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
53272 ENDIF
53273 290 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3))**(2D0/3D0)
53274 RSCALE=1.0D0
53275 IF(MSTJ(54).EQ.2)
53276 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*PARJ(93)))**2)
53277 IF((IWP.NE.-1.AND.MSTJ(56).LE.0).OR.IWP.EQ.0.OR.IWN.EQ.0.OR.
53278 & K(I1M,5).EQ.K(I2M,5)) GOTO 320
53279
53280 IF(QOLD.LT.1D-3*QDELW) THEN
53281 GOTO 300
53282 ELSEIF(QOLD.LE.QDELW) THEN
53283 QMOVW=QOLD/3D0
53284 ELSEIF(QOLD.LT.(NBINW-0.1D0)*QDELW) THEN
53285 RBINW=QOLD/QDELW
53286 IBINW=RBINW
53287 RINPW=(RBINW**3-IBINW**3)/(3*IBINW*(IBINW+1)+1)
53288 QMOVW=(BEIW(IBINW)+RINPW*(BEIW(IBINW+1)-BEIW(IBINW)))*
53289 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
53290 ELSE
53291 QMOVW=BEIW(NBINW)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
53292 ENDIF
53293 300 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOVW))**(2D0/3D0)
53294 IF(QOLD.LT.1D-3*QDEL3W) THEN
53295 GOTO 310
53296 ELSEIF(QOLD.LE.QDEL3W) THEN
53297 QMOV3W=QOLD/3D0
53298 ELSEIF(QOLD.LT.(NBIN3W-0.1D0)*QDEL3W) THEN
53299 RBIN3W=QOLD/QDEL3W
53300 IBIN3W=RBIN3W
53301 RINP3W=(RBIN3W**3-IBIN3W**3)/(3*IBIN3W*(IBIN3W+1)+1)
53302 QMOV3W=(BEI3W(IBIN3W)+RINP3W*(BEI3W(IBIN3W+1)-
53303 & BEI3W(IBIN3W)))*SQRT(Q2OLD+PMHQ**2)/Q2OLD
53304 ELSE
53305 QMOV3W=BEI3W(NBIN3W)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
53306 ENDIF
53307 310 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3W))**(2D0/3D0)
53308 IF(MSTJ(54).EQ.2)
53309 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*SIGW))**2)
53310
53311 320 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW)
53312 DO 330 J=1,3
53313 P(I1M,J)=P(I1M,J)+P(NMAX+1,J)
53314 P(I2M,J)=P(I2M,J)+P(NMAX+2,J)
53315 330 CONTINUE
53316 IF(MSTJ(54).GE.1) THEN
53317 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW3)
53318 DO 340 J=1,3
53319 V(I1M,J)=V(I1M,J)+P(NMAX+1,J)*RSCALE
53320 V(I2M,J)=V(I2M,J)+P(NMAX+2,J)*RSCALE
53321 340 CONTINUE
53322 ELSEIF(MSTJ(54).LE.-1) THEN
53323 EDEL=P(I1,4)+P(I2,4)-
53324 & SQRT(MAX(Q2NEW-Q2OLD+(P(I1,4)+P(I2,4))**2,0.0D0))
53325 A2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
53326 & (P(I1,3)-P(I2,3))**2
53327 WMAX=-1.0D20
53328 MI3=0
53329 MI4=0
53330 S12=SDIP(I1,I2)
53331 SM1=(P(I1,5)+SMMIN)**2
53332 DO 360 I3M=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
53333 IF(I3M.EQ.I1M.OR.I3M.EQ.I2M) GOTO 360
53334 IF(MSTJ(53).EQ.1.AND.K(I3M,5).NE.K(I1M,5)) GOTO 360
53335 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
53336 & K(I3M,5).NE.K(I1M,5)) GOTO 360
53337 I3=K(I3M,1)
53338 IF(K(I3,2).EQ.K(I1,2)) GOTO 360
53339 S13=SDIP(I1,I3)
53340 S23=SDIP(I2,I3)
53341 SM3=(P(I3,5)+SMMIN)**2
53342 IF(MSTJ(54).EQ.-2) THEN
53343 WI=(MIN(S12*SM3,S13*MIN(SM1,SM3),
53344 & S23*MIN(SM1,SM3))*SM1)
53345 ELSE
53346 WI=((P(I1,4)+P(I2,4)+P(I3,4))**2-
53347 & (P(I1,3)+P(I2,3)+P(I3,3))**2-
53348 & (P(I1,2)+P(I2,2)+P(I3,2))**2-
53349 & (P(I1,1)+P(I2,1)+P(I3,1))**2)
53350 ENDIF
53351 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0) THEN
53352 IF (WMAX*WI.GE.(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2))))
53353 & GOTO 360
53354 ELSE
53355 IF(WMAX*WI.GE.1.0) GOTO 360
53356 ENDIF
53357 DO 350 I4M=I3M+1,NBE(MIN(10,MSTJ(52)+1))
53358 IF(I4M.EQ.I1M.OR.I4M.EQ.I2M) GOTO 350
53359 IF(MSTJ(53).EQ.1.AND.K(I4M,5).NE.K(I1M,5)) GOTO 350
53360 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
53361 & K(I4M,5).NE.K(I1M,5)) GOTO 350
53362 I4=K(I4M,1)
53363 IF(K(I3,2).EQ.K(I4,2).OR.K(I4,2).EQ.K(I1,2))
53364 & GOTO 350
53365 IF((P(I3,4)+P(I4,4)+EDEL)**2.LT.
53366 & (P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
53367 & (P(I3,3)+P(I4,3))**2+(P(I3,5)+P(I4,5))**2)
53368 & GOTO 350
53369 IF(MSTJ(54).EQ.-2) THEN
53370 S14=SDIP(I1,I4)
53371 S24=SDIP(I2,I4)
53372 S34=SDIP(I3,I4)
53373 W=S12*MIN(MIN(S23,S24),MIN(S13,S14))*S34
53374 W=MIN(W,S13*MIN(MIN(S23,S34),S12)*S24)
53375 W=MIN(W,S14*MIN(MIN(S24,S34),S12)*S23)
53376 W=MIN(W,MIN(S23,S24)*S13*S14)
53377 W=1.0D0/W
53378 ELSE
53379C...weight=1-cos(theta)/mtot2
53380 S1234=(P(I1,4)+P(I2,4)+P(I3,4)+P(I4,4))**2-
53381 & (P(I1,3)+P(I2,3)+P(I3,3)+P(I4,3))**2-
53382 & (P(I1,2)+P(I2,2)+P(I3,2)+P(I4,2))**2-
53383 & (P(I1,1)+P(I2,1)+P(I3,1)+P(I4,1))**2
53384 W=1.0D0/S1234
53385 IF(W.LE.WMAX) GOTO 350
53386 ENDIF
53387 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0)
53388 & W=W*(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2)))
53389 IF(MSTJ(57).EQ.1.AND.P(I4M,5).GT.0)
53390 & W=W*(1.0D0-EXP(-P(I4M,5)/(PARJ(93)**2)))
53391 IF(W.LE.WMAX) GOTO 350
53392 MI3=I3M
53393 MI4=I4M
53394 WMAX=W
53395 350 CONTINUE
53396 360 CONTINUE
53397 IF(MI4.EQ.0) GOTO 380
53398 I3=K(MI3,1)
53399 I4=K(MI4,1)
53400 EOLD=P(I3,4)+P(I4,4)
53401 ENEW=EOLD+EDEL
53402 P2=(P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
53403 & (P(I3,3)+P(I4,3))**2
53404 Q2NEWP=MAX(0.0D0,ENEW**2-P2-(P(I3,5)+P(I4,5))**2)
53405 Q2OLDP=MAX(0.0D0,EOLD**2-P2-(P(I3,5)+P(I4,5))**2)
53406 CALL PYBESQ(I3,I4,NMAX,Q2OLDP,Q2NEWP)
53407 DO 370 J=1,3
53408 V(MI3,J)=V(MI3,J)+P(NMAX+1,J)
53409 V(MI4,J)=V(MI4,J)+P(NMAX+2,J)
53410 370 CONTINUE
53411 ENDIF
53412 380 CONTINUE
53413 390 CONTINUE
53414 400 CONTINUE
53415
53416C...Shift momenta and recalculate energies.
53417 ESUMP=0.0D0
53418 ESUM=0.0D0
53419 PROD=0.0D0
53420 DO 430 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
53421 I=K(IM,1)
53422 ESUMP=ESUMP+P(I,4)
53423 DO 410 J=1,3
53424 P(I,J)=P(I,J)+P(IM,J)
53425 410 CONTINUE
53426 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
53427 ESUM=ESUM+P(I,4)
53428 DO 420 J=1,3
53429 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
53430 420 CONTINUE
53431 430 CONTINUE
53432
53433 PARJ(96)=0.0D0
53434 IF(MSTJ(54).NE.0.AND.PROD.NE.0.0D0) THEN
53435 440 ALPHA=(ESUMP-ESUM)/PROD
53436 PARJ(96)=PARJ(96)+ALPHA
53437 PROD=0.0D0
53438 ESUM=0.0D0
53439 DO 470 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
53440 I=K(IM,1)
53441 DO 450 J=1,3
53442 P(I,J)=P(I,J)+ALPHA*V(IM,J)
53443 450 CONTINUE
53444 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
53445 ESUM=ESUM+P(I,4)
53446 DO 460 J=1,3
53447 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
53448 460 CONTINUE
53449 470 CONTINUE
53450 IF(PROD.NE.0.0D0.AND.ABS(ESUMP-ESUM)/PECM.GT.0.00001D0)
53451 & GOTO 440
53452 ENDIF
53453
53454C...Rescale all momenta for energy conservation.
53455 PES=0D0
53456 PQS=0D0
53457 DO 480 I=1,N
53458 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 480
53459 PES=PES+P(I,4)
53460 PQS=PQS+P(I,5)**2/P(I,4)
53461 480 CONTINUE
53462 PARJ(95)=PES-PECM
53463 FAC=(PECM-PQS)/(PES-PQS)
53464 DO 500 I=1,N
53465 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 500
53466 DO 490 J=1,3
53467 P(I,J)=FAC*P(I,J)
53468 490 CONTINUE
53469 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
53470 500 CONTINUE
53471
53472C...Boost back to correct reference frame.
53473 510 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
53474 DO 520 I=1,N
53475 IF(K(I,1).LT.0) K(I,1)=-K(I,1)
53476 520 CONTINUE
53477
53478 RETURN
53479 END
53480
53481C*********************************************************************
53482
53483C...PYBESQ
53484C...Calculates the momentum shift in a system of two particles assuming
53485C...the relative momentum squared should be shifted to Q2NEW. NI is the
53486C...last position occupied in /PYJETS/.
53487
53488 SUBROUTINE PYBESQ(I1,I2,NI,Q2OLD,Q2NEW)
53489
53490C...Double precision and integer declarations.
53491 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53492 IMPLICIT INTEGER(I-N)
53493 INTEGER PYK,PYCHGE,PYCOMP
53494C...Parameter statement to help give large particle numbers.
53495 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
53496 &KEXCIT=4000000,KDIMEN=5000000)
53497C...Commonblocks.
53498 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
53499 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53500 SAVE /PYJETS/,/PYDAT1/
53501C...Local arrays and data.
53502 DIMENSION DP(5)
53503 SAVE HC1
53504
53505 IF(MSTJ(55).EQ.0) THEN
53506 DQ2=Q2NEW-Q2OLD
53507 DP2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
53508 & (P(I1,3)-P(I2,3))**2
53509 DP12=P(I1,1)**2+P(I1,2)**2+P(I1,3)**2
53510 & -P(I2,1)**2-P(I2,2)**2-P(I2,3)**2
53511 SE=P(I1,4)+P(I2,4)
53512 DE=P(I1,4)-P(I2,4)
53513 DQ2SE=DQ2+SE**2
53514 DA=SE*DE*DP12-DP2*DQ2SE
53515 DB=DP2*DQ2SE-DP12**2
53516 HA=(DA+SQRT(MAX(DA**2+DQ2*(DQ2+SE**2-DE**2)*DB,0D0)))/(2D0*DB)
53517 DO 100 J=1,3
53518 PD=HA*(P(I1,J)-P(I2,J))
53519 P(NI+1,J)=PD
53520 P(NI+2,J)=-PD
53521 100 CONTINUE
53522 RETURN
53523 ENDIF
53524
53525 K(NI+1,1)=1
53526 K(NI+2,1)=1
53527 DO 110 J=1,5
53528 P(NI+1,J)=P(I1,J)
53529 P(NI+2,J)=P(I2,J)
53530 DP(J)=P(I1,J)+P(I2,J)
53531 110 CONTINUE
53532
53533C...Boost to cms and rotate first particle to z-axis
53534 CALL PYROBO(NI+1,NI+2,0.0D0,0.0D0,
53535 &-DP(1)/DP(4),-DP(2)/DP(4),-DP(3)/DP(4))
53536 PHI=PYANGL(P(NI+1,1),P(NI+1,2))
53537 THE=PYANGL(P(NI+1,3),SQRT(P(NI+1,1)**2+P(NI+1,2)**2))
53538 S=Q2NEW+(P(I1,5)+P(I2,5))**2
53539 PZ=0.5D0*SQRT(Q2NEW*(S-(P(I1,5)-P(I2,5))**2)/S)
53540 P(NI+1,1)=0.0D0
53541 P(NI+1,2)=0.0D0
53542 P(NI+1,3)=PZ
53543 P(NI+1,4)=SQRT(PZ**2+P(I1,5)**2)
53544 P(NI+2,1)=0.0D0
53545 P(NI+2,2)=0.0D0
53546 P(NI+2,3)=-PZ
53547 P(NI+2,4)=SQRT(PZ**2+P(I2,5)**2)
53548 DP(4)=SQRT(DP(1)**2+DP(2)**2+DP(3)**2+S)
53549 CALL PYROBO(NI+1,NI+2,THE,PHI,
53550 &DP(1)/DP(4),DP(2)/DP(4),DP(3)/DP(4))
53551
53552 DO 120 J=1,3
53553 P(NI+1,J)=P(NI+1,J)-P(I1,J)
53554 P(NI+2,J)=P(NI+2,J)-P(I2,J)
53555 120 CONTINUE
53556
53557 RETURN
53558 END
53559
53560C*********************************************************************
53561
53562C...PYMASS
53563C...Gives the mass of a particle/parton.
53564
53565 FUNCTION PYMASS(KF)
53566
53567C...Double precision and integer declarations.
53568 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53569 IMPLICIT INTEGER(I-N)
53570 INTEGER PYK,PYCHGE,PYCOMP
53571C...Commonblocks.
53572 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53573 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53574 SAVE /PYDAT1/,/PYDAT2/
53575
53576C...Reset variables. Compressed code. Special case for popcorn diquarks.
53577 PYMASS=0D0
53578 KFA=IABS(KF)
53579 KC=PYCOMP(KF)
53580 IF(KC.EQ.0) THEN
53581 MSTJ(93)=0
53582 RETURN
53583 ENDIF
53584
53585C...Guarantee use of constituent masses for internal checks.
53586 IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.
53587 &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN
53588 IF(KFA.LE.5) THEN
53589 PYMASS=PARF(100+KFA)
53590 IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121))
53591 ELSEIF(KFA.LE.10) THEN
53592 PYMASS=PMAS(KFA,1)
53593 ELSEIF(MSTJ(93).EQ.1) THEN
53594 PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10))
53595 ELSE
53596 PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0)
53597 ENDIF
53598
53599C...Other masses can be read directly off table.
53600 ELSE
53601 PYMASS=PMAS(KC,1)
53602 ENDIF
53603
53604C...Optional mass broadening according to truncated Breit-Wigner
53605C...(either in m or in m^2).
53606 IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN
53607 IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
53608 PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)*
53609 & ATAN(2D0*PMAS(KC,3)/PMAS(KC,2)))
53610 ELSE
53611 PM0=PYMASS
53612 PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/
53613 & (PM0*PMAS(KC,2)))
53614 PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
53615 PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
53616 & (PMUPP-PMLOW)*PYR(0))))
53617 ENDIF
53618 ENDIF
53619 MSTJ(93)=0
53620
53621 RETURN
53622 END
53623
53624C*********************************************************************
53625
53626C...PYMRUN
53627C...Gives the running, current-algebra mass of a d, u, s, c or b quark,
53628C...for Higgs couplings. Everything else sent on to PYMASS.
53629
53630 FUNCTION PYMRUN(KF,Q2)
53631
53632C...Double precision and integer declarations.
53633 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53634 IMPLICIT INTEGER(I-N)
53635 INTEGER PYK,PYCHGE,PYCOMP
53636C...Commonblocks.
53637 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53638 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53639 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
53640 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/
53641
53642C...Most masses not handled here.
53643 KFA=IABS(KF)
53644 IF(KFA.EQ.0.OR.KFA.GT.6) THEN
53645 PYMRUN=PYMASS(KF)
53646
53647C...Current-algebra masses, but no Q2 dependence.
53648 ELSEIF(MSTP(37).NE.1.OR.MSTP(2).LE.0) THEN
53649 PYMRUN=PARF(90+KFA)
53650
53651C...Running current-algebra masses.
53652 ELSE
53653 AS=PYALPS(Q2)
53654 PYMRUN=PARF(90+KFA)*
53655 & (LOG(MAX(4D0,PARP(37)**2*PARF(90+KFA)**2/PARU(117)**2))/
53656 & LOG(MAX(4D0,Q2/PARU(117)**2)))**(12D0/(33D0-2D0*MSTU(118)))
53657 ENDIF
53658
53659 RETURN
53660 END
53661
53662C*********************************************************************
53663
53664C...PYNAME
53665C...Gives the particle/parton name as a character string.
53666
53667 SUBROUTINE PYNAME(KF,CHAU)
53668
53669C...Double precision and integer declarations.
53670 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53671 IMPLICIT INTEGER(I-N)
53672 INTEGER PYK,PYCHGE,PYCOMP
53673C...Commonblocks.
53674 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53675 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53676 COMMON/PYDAT4/CHAF(500,2)
53677 CHARACTER CHAF*16
53678 SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/
53679C...Local character variable.
53680 CHARACTER CHAU*16
53681
53682C...Read out code with distinction particle/antiparticle.
53683 CHAU=' '
53684 KC=PYCOMP(KF)
53685 IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2)
53686
53687
53688 RETURN
53689 END
53690
53691C*********************************************************************
53692
53693C...PYCHGE
53694C...Gives three times the charge for a particle/parton.
53695
53696 FUNCTION PYCHGE(KF)
53697
53698C...Double precision and integer declarations.
53699 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53700 IMPLICIT INTEGER(I-N)
53701 INTEGER PYK,PYCHGE,PYCOMP
53702C...Commonblocks.
53703 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53704 SAVE /PYDAT2/
53705
53706C...Read out charge and change sign for antiparticle.
53707 PYCHGE=0
53708 KC=PYCOMP(KF)
53709 IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF)
53710
53711 RETURN
53712 END
53713
53714C*********************************************************************
53715
53716C...PYCOMP
53717C...Compress the standard KF codes for use in mass and decay arrays;
53718C...also checks whether a given code actually is defined.
53719
53720 FUNCTION PYCOMP(KF)
53721
53722C...Double precision and integer declarations.
53723 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53724 IMPLICIT INTEGER(I-N)
53725 INTEGER PYK,PYCHGE,PYCOMP
53726C...Commonblocks.
53727 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53728 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53729 SAVE /PYDAT1/,/PYDAT2/
53730C...Local arrays and saved data.
53731 DIMENSION KFORD(100:500),KCORD(101:500)
53732 SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST
53733
53734C...Whenever necessary reorder codes for faster search.
53735 IF(MSTU(20).EQ.0) THEN
53736 NFORD=100
53737 KFORD(100)=0
53738 DO 120 I=101,500
53739 KFA=KCHG(I,4)
53740 IF(KFA.LE.100) GOTO 120
53741 NFORD=NFORD+1
53742 DO 100 I1=NFORD-1,0,-1
53743 IF(KFA.GE.KFORD(I1)) GOTO 110
53744 KFORD(I1+1)=KFORD(I1)
53745 KCORD(I1+1)=KCORD(I1)
53746 100 CONTINUE
53747 110 KFORD(I1+1)=KFA
53748 KCORD(I1+1)=I
53749 120 CONTINUE
53750 MSTU(20)=1
53751 KFLAST=0
53752 KCLAST=0
53753 ENDIF
53754
53755C...Fast action if same code as in latest call.
53756 IF(KF.EQ.KFLAST) THEN
53757 PYCOMP=KCLAST
53758 RETURN
53759 ENDIF
53760
53761C...Starting values. Remove internal diquark flags.
53762 PYCOMP=0
53763 KFA=IABS(KF)
53764 IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000
53765 & .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000)
53766
53767C...Simple cases: direct translation.
53768 IF(KFA.GT.KFORD(NFORD)) THEN
53769 ELSEIF(KFA.LE.100) THEN
53770 PYCOMP=KFA
53771
53772C...Else binary search.
53773 ELSE
53774 IMIN=100
53775 IMAX=NFORD+1
53776 130 IAVG=(IMIN+IMAX)/2
53777 IF(KFORD(IAVG).GT.KFA) THEN
53778 IMAX=IAVG
53779 IF(IMAX.GT.IMIN+1) GOTO 130
53780 ELSEIF(KFORD(IAVG).LT.KFA) THEN
53781 IMIN=IAVG
53782 IF(IMAX.GT.IMIN+1) GOTO 130
53783 ELSE
53784 PYCOMP=KCORD(IAVG)
53785 ENDIF
53786 ENDIF
53787
53788C...Check if antiparticle allowed.
53789 IF(PYCOMP.NE.0.AND.KF.LT.0) THEN
53790 IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0
53791 ENDIF
53792
53793C...Save codes for possible future fast action.
53794 KFLAST=KF
53795 KCLAST=PYCOMP
53796
53797 RETURN
53798 END
53799
53800C*********************************************************************
53801
53802C...PYERRM
53803C...Informs user of errors in program execution.
53804
53805 SUBROUTINE PYERRM(MERR,CHMESS)
53806
53807C...Double precision and integer declarations.
53808 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53809 IMPLICIT INTEGER(I-N)
53810 INTEGER PYK,PYCHGE,PYCOMP
53811C...Commonblocks.
53812 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
53813 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53814 SAVE /PYJETS/,/PYDAT1/
53815C...Local character variable.
53816 CHARACTER CHMESS*(*)
53817
53818C...Write first few warnings, then be silent.
53819 IF(MERR.LE.10) THEN
53820 MSTU(27)=MSTU(27)+1
53821 MSTU(28)=MERR
53822 IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
53823 & MERR,MSTU(31),CHMESS
53824
53825C...Write first few errors, then be silent or stop program.
53826 ELSEIF(MERR.LE.20) THEN
53827 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)+1
53828 MSTU(24)=MERR-10
53829 IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
53830 & MERR-10,MSTU(31),CHMESS
53831 IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
53832 WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
53833 WRITE(MSTU(11),5200)
53834 IF(MERR.NE.17) CALL PYLIST(2)
53835 STOP
53836 ENDIF
53837
53838C...Stop program in case of irreparable error.
53839 ELSE
53840 WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
53841 STOP
53842 ENDIF
53843
53844C...Formats for output.
53845 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9,
53846 &' PYEXEC calls:'/5X,A)
53847 5100 FORMAT(/5X,'Error type',I2,' has occured after',I9,
53848 &' PYEXEC calls:'/5X,A)
53849 5200 FORMAT(5X,'Execution will be stopped after listing of last ',
53850 &'event!')
53851 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9,
53852 &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
53853
53854 RETURN
53855 END
53856
53857C*********************************************************************
53858
53859C...PYALEM
53860C...Calculates the running alpha_electromagnetic.
53861
53862 FUNCTION PYALEM(Q2)
53863
53864C...Double precision and integer declarations.
53865 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53866 IMPLICIT INTEGER(I-N)
53867 INTEGER PYK,PYCHGE,PYCOMP
53868C...Commonblocks.
53869 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53870 SAVE /PYDAT1/
53871
53872C...Calculate real part of photon vacuum polarization.
53873C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
53874C...For hadrons use parametrization of H. Burkhardt et al.
53875C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
53876 AEMPI=PARU(101)/(3D0*PARU(1))
53877 IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
53878 RPIGG=0D0
53879 ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
53880 RPIGG=0D0
53881 ELSEIF(MSTU(101).EQ.2) THEN
53882 RPIGG=1D0-PARU(101)/PARU(103)
53883 ELSEIF(Q2.LT.0.09D0) THEN
53884 RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2)
53885 ELSEIF(Q2.LT.9D0) THEN
53886 RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+
53887 & 0.00238D0*LOG(1D0+3.927D0*Q2)
53888 ELSEIF(Q2.LT.1D4) THEN
53889 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+
53890 & 0.00299D0*LOG(1D0+Q2)
53891 ELSE
53892 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+
53893 & 0.00293D0*LOG(1D0+Q2)
53894 ENDIF
53895
53896C...Calculate running alpha_em.
53897 PYALEM=PARU(101)/(1D0-RPIGG)
53898 PARU(108)=PYALEM
53899
53900 RETURN
53901 END
53902
53903C*********************************************************************
53904
53905C...PYALPS
53906C...Gives the value of alpha_strong.
53907
53908 FUNCTION PYALPS(Q2)
53909
53910C...Double precision and integer declarations.
53911 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53912 IMPLICIT INTEGER(I-N)
53913 INTEGER PYK,PYCHGE,PYCOMP
53914C...Commonblocks.
53915 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53916 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53917 SAVE /PYDAT1/,/PYDAT2/
53918
53919C...Constant alpha_strong trivial. Pick artificial Lambda.
53920 IF(MSTU(111).LE.0) THEN
53921 PYALPS=PARU(111)
53922 MSTU(118)=MSTU(112)
53923 PARU(117)=0.2D0
53924 IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/
53925 & ((33D0-2D0*MSTU(112))*PARU(111)))
53926 PARU(118)=PARU(111)
53927 RETURN
53928 ENDIF
53929
53930C...Find effective Q2, number of flavours and Lambda.
53931 Q2EFF=Q2
53932 IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
53933 NF=MSTU(112)
53934 ALAM2=PARU(112)**2
53935 100 IF(NF.GT.MAX(2,MSTU(113))) THEN
53936 Q2THR=PARU(113)*PMAS(NF,1)**2
53937 IF(Q2EFF.LT.Q2THR) THEN
53938 NF=NF-1
53939 ALAM2=ALAM2*(Q2THR/ALAM2)**(2D0/(33D0-2D0*NF))
53940 GOTO 100
53941 ENDIF
53942 ENDIF
53943 110 IF(NF.LT.MIN(8,MSTU(114))) THEN
53944 Q2THR=PARU(113)*PMAS(NF+1,1)**2
53945 IF(Q2EFF.GT.Q2THR) THEN
53946 NF=NF+1
53947 ALAM2=ALAM2*(ALAM2/Q2THR)**(2D0/(33D0-2D0*NF))
53948 GOTO 110
53949 ENDIF
53950 ENDIF
53951 IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
53952 PARU(117)=SQRT(ALAM2)
53953
53954C...Evaluate first or second order alpha_strong.
53955 B0=(33D0-2D0*NF)/6D0
53956 ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2))
53957 IF(MSTU(111).EQ.1) THEN
53958 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
53959 ELSE
53960 B1=(153D0-19D0*NF)/6D0
53961 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/
53962 & (B0**2*ALGQ)))
53963 ENDIF
53964 MSTU(118)=NF
53965 PARU(118)=PYALPS
53966
53967 RETURN
53968 END
53969
53970C*********************************************************************
53971
53972C...PYANGL
53973C...Reconstructs an angle from given x and y coordinates.
53974
53975 FUNCTION PYANGL(X,Y)
53976
53977C...Double precision and integer declarations.
53978 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53979 IMPLICIT INTEGER(I-N)
53980 INTEGER PYK,PYCHGE,PYCOMP
53981C...Commonblocks.
53982 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53983 SAVE /PYDAT1/
53984
53985 PYANGL=0D0
53986 R=SQRT(X**2+Y**2)
53987 IF(R.LT.1D-20) RETURN
53988 IF(ABS(X)/R.LT.0.8D0) THEN
53989 PYANGL=SIGN(ACOS(X/R),Y)
53990 ELSE
53991 PYANGL=ASIN(Y/R)
53992 IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN
53993 PYANGL=PARU(1)-PYANGL
53994 ELSEIF(X.LT.0D0) THEN
53995 PYANGL=-PARU(1)-PYANGL
53996 ENDIF
53997 ENDIF
53998
53999 RETURN
54000 END
54001
54002C*********************************************************************
54003
54004C...PYROBO
54005C...Performs rotations and boosts.
54006
54007 SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
54008
54009C...Double precision and integer declarations.
54010 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54011 IMPLICIT INTEGER(I-N)
54012 INTEGER PYK,PYCHGE,PYCOMP
54013C...Commonblocks.
54014 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
54015 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54016 SAVE /PYJETS/,/PYDAT1/
54017C...Local arrays.
54018 DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
54019
54020C...Find and check range of rotation/boost.
54021 IMIN=IMI
54022 IF(IMIN.LE.0) IMIN=1
54023 IF(MSTU(1).GT.0) IMIN=MSTU(1)
54024 IMAX=IMA
54025 IF(IMAX.LE.0) IMAX=N
54026 IF(MSTU(2).GT.0) IMAX=MSTU(2)
54027 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
54028 CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory')
54029 RETURN
54030 ENDIF
54031
54032C...Optional resetting of V (when not set before.)
54033 IF(MSTU(33).NE.0) THEN
54034 DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
54035 DO 100 J=1,5
54036 V(I,J)=0D0
54037 100 CONTINUE
54038 110 CONTINUE
54039 MSTU(33)=0
54040 ENDIF
54041
54042C...Rotate, typically from z axis to direction (theta,phi).
54043 IF(THE**2+PHI**2.GT.1D-20) THEN
54044 ROT(1,1)=COS(THE)*COS(PHI)
54045 ROT(1,2)=-SIN(PHI)
54046 ROT(1,3)=SIN(THE)*COS(PHI)
54047 ROT(2,1)=COS(THE)*SIN(PHI)
54048 ROT(2,2)=COS(PHI)
54049 ROT(2,3)=SIN(THE)*SIN(PHI)
54050 ROT(3,1)=-SIN(THE)
54051 ROT(3,2)=0D0
54052 ROT(3,3)=COS(THE)
54053 DO 140 I=IMIN,IMAX
54054 IF(K(I,1).LE.0) GOTO 140
54055 DO 120 J=1,3
54056 PR(J)=P(I,J)
54057 VR(J)=V(I,J)
54058 120 CONTINUE
54059 DO 130 J=1,3
54060 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
54061 V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
54062 130 CONTINUE
54063 140 CONTINUE
54064 ENDIF
54065
54066C...Boost, typically from rest to momentum/energy=beta.
54067 IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN
54068 DBX=BEX
54069 DBY=BEY
54070 DBZ=BEZ
54071 DB=SQRT(DBX**2+DBY**2+DBZ**2)
54072 EPS1=1D0-1D-12
54073 IF(DB.GT.EPS1) THEN
54074C...Rescale boost vector if too close to unity.
54075 CALL PYERRM(3,'(PYROBO:) boost vector too large')
54076 DBX=DBX*(EPS1/DB)
54077 DBY=DBY*(EPS1/DB)
54078 DBZ=DBZ*(EPS1/DB)
54079 DB=EPS1
54080 ENDIF
54081 DGA=1D0/SQRT(1D0-DB**2)
54082 DO 160 I=IMIN,IMAX
54083 IF(K(I,1).LE.0) GOTO 160
54084 DO 150 J=1,4
54085 DP(J)=P(I,J)
54086 DV(J)=V(I,J)
54087 150 CONTINUE
54088 DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
54089 DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
54090 P(I,1)=DP(1)+DGABP*DBX
54091 P(I,2)=DP(2)+DGABP*DBY
54092 P(I,3)=DP(3)+DGABP*DBZ
54093 P(I,4)=DGA*(DP(4)+DBP)
54094 DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
54095 DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
54096 V(I,1)=DV(1)+DGABV*DBX
54097 V(I,2)=DV(2)+DGABV*DBY
54098 V(I,3)=DV(3)+DGABV*DBZ
54099 V(I,4)=DGA*(DV(4)+DBV)
54100 160 CONTINUE
54101 ENDIF
54102
54103 RETURN
54104 END
54105
54106C*********************************************************************
54107
54108C...PYEDIT
54109C...Performs global manipulations on the event record, in particular
54110C...to exclude unstable or undetectable partons/particles.
54111
54112 SUBROUTINE PYEDIT(MEDIT)
54113
54114C...Double precision and integer declarations.
54115 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54116 IMPLICIT INTEGER(I-N)
54117 INTEGER PYK,PYCHGE,PYCOMP
54118C...Commonblocks.
54119 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
54120 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54121 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54122 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
54123C...Local arrays.
54124 DIMENSION NS(2),PTS(2),PLS(2)
54125
54126C...Remove unwanted partons/particles.
54127 IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
54128 IMAX=N
54129 IF(MSTU(2).GT.0) IMAX=MSTU(2)
54130 I1=MAX(1,MSTU(1))-1
54131 DO 110 I=MAX(1,MSTU(1)),IMAX
54132 IF(K(I,1).EQ.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40)) GOTO 110
54133 IF(MEDIT.EQ.1) THEN
54134 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
54135 ELSEIF(MEDIT.EQ.2) THEN
54136 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
54137 KC=PYCOMP(K(I,2))
54138 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.KC.EQ.18)
54139 & GOTO 110
54140 ELSEIF(MEDIT.EQ.3) THEN
54141 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
54142 KC=PYCOMP(K(I,2))
54143 IF(KC.EQ.0) GOTO 110
54144 IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110
54145 ELSEIF(MEDIT.EQ.5) THEN
54146 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.K(I,1).EQ.52) GOTO 110
54147 KC=PYCOMP(K(I,2))
54148 IF(KC.EQ.0) GOTO 110
54149 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42.AND.
54150 & KCHG(KC,2).EQ.0) GOTO 110
54151 ENDIF
54152
54153C...Pack remaining partons/particles. Origin no longer known.
54154 I1=I1+1
54155 DO 100 J=1,5
54156 K(I1,J)=K(I,J)
54157 P(I1,J)=P(I,J)
54158 V(I1,J)=V(I,J)
54159 100 CONTINUE
54160 K(I1,3)=0
54161 110 CONTINUE
54162 IF(I1.LT.N) MSTU(3)=0
54163 IF(I1.LT.N) MSTU(70)=0
54164 N=I1
54165
54166C...Selective removal of class of entries. New position of retained.
54167 ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
54168 I1=0
54169 DO 120 I=1,N
54170 K(I,3)=MOD(K(I,3),MSTU(5))
54171 IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
54172 IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
54173 IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
54174 & K(I,1).EQ.15.OR.K(I,1).EQ.51).AND.K(I,2).NE.94) GOTO 120
54175 IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
54176 & K(I,1).EQ.52.OR.K(I,2).EQ.94)) GOTO 120
54177 IF(MEDIT.EQ.15.AND.K(I,1).GE.21.AND.K(I,1).LE.40) GOTO 120
54178 I1=I1+1
54179 K(I,3)=K(I,3)+MSTU(5)*I1
54180 120 CONTINUE
54181
54182C...Find new event history information and replace old.
54183 DO 140 I=1,N
54184 IF(K(I,1).LE.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40).OR.
54185 & K(I,3)/MSTU(5).EQ.0) GOTO 140
54186 ID=I
54187 130 IM=MOD(K(ID,3),MSTU(5))
54188 IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
54189 IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15.OR.
54190 & K(IM,1).EQ.51).AND.K(IM,2).NE.94) THEN
54191 ID=IM
54192 GOTO 130
54193 ENDIF
54194 ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
54195 IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,1).EQ.52.OR.
54196 & K(IM,2).EQ.94) THEN
54197 ID=IM
54198 GOTO 130
54199 ENDIF
54200 ENDIF
54201 K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
54202 IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
54203 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14.AND.
54204 & K(I,1).NE.42.AND.K(I,1).NE.52) THEN
54205 IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
54206 & K(K(I,4),3)/MSTU(5)
54207 IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
54208 & K(K(I,5),3)/MSTU(5)
54209 ELSE
54210 KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
54211 IF(KCM.GT.0.AND.KCM.LE.MSTU(4).AND.K(I,1).NE.42.AND.
54212 & K(I,1).NE.52) KCM=K(KCM,3)/MSTU(5)
54213 KCD=MOD(K(I,4),MSTU(5))
54214 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
54215 K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
54216 KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
54217 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
54218 KCD=MOD(K(I,5),MSTU(5))
54219 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
54220 K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
54221 ENDIF
54222 140 CONTINUE
54223
54224C...Pack remaining entries.
54225 I1=0
54226 MSTU90=MSTU(90)
54227 MSTU(90)=0
54228 DO 170 I=1,N
54229 IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
54230 I1=I1+1
54231 DO 150 J=1,5
54232 K(I1,J)=K(I,J)
54233 P(I1,J)=P(I,J)
54234 V(I1,J)=V(I,J)
54235 150 CONTINUE
54236 K(I1,3)=MOD(K(I1,3),MSTU(5))
54237 DO 160 IZ=1,MSTU90
54238 IF(I.EQ.MSTU(90+IZ)) THEN
54239 MSTU(90)=MSTU(90)+1
54240 MSTU(90+MSTU(90))=I1
54241 PARU(90+MSTU(90))=PARU(90+IZ)
54242 ENDIF
54243 160 CONTINUE
54244 170 CONTINUE
54245 IF(I1.LT.N) MSTU(3)=0
54246 IF(I1.LT.N) MSTU(70)=0
54247 N=I1
54248
54249C...Fill in some missing daughter pointers (lost in colour flow).
54250 ELSEIF(MEDIT.EQ.16) THEN
54251 DO 220 I=1,N
54252 IF(K(I,1).LE.10.OR.(K(I,1).GE.21.AND.K(I,1).LE.50)) GOTO 220
54253 IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220
54254C...Find daughters who point to mother.
54255 DO 180 I1=I+1,N
54256 IF(K(I1,3).NE.I) THEN
54257 ELSEIF(K(I,4).EQ.0) THEN
54258 K(I,4)=I1
54259 ELSE
54260 K(I,5)=I1
54261 ENDIF
54262 180 CONTINUE
54263 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
54264 IF(K(I,4).NE.0) GOTO 220
54265C...Find daughters who point to documentation version of mother.
54266 IM=K(I,3)
54267 IF(IM.LE.0.OR.IM.GE.I) GOTO 220
54268 IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220
54269 IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220
54270 DO 190 I1=I+1,N
54271 IF(K(I1,3).NE.IM) THEN
54272 ELSEIF(K(I,4).EQ.0) THEN
54273 K(I,4)=I1
54274 ELSE
54275 K(I,5)=I1
54276 ENDIF
54277 190 CONTINUE
54278 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
54279 IF(K(I,4).NE.0) GOTO 220
54280C...Find daughters who point to documentation daughters who,
54281C...in their turn, point to documentation mother.
54282 ID1=IM
54283 ID2=IM
54284 DO 200 I1=IM+1,I-1
54285 IF(K(I1,3).EQ.IM.AND.K(I1,1).GE.21.AND.K(I1,1).LE.30) THEN
54286 ID2=I1
54287 IF(ID1.EQ.IM) ID1=I1
54288 ENDIF
54289 200 CONTINUE
54290 DO 210 I1=I+1,N
54291 IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
54292 ELSEIF(K(I,4).EQ.0) THEN
54293 K(I,4)=I1
54294 ELSE
54295 K(I,5)=I1
54296 ENDIF
54297 210 CONTINUE
54298 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
54299 220 CONTINUE
54300
54301C...Save top entries at bottom of PYJETS commonblock.
54302 ELSEIF(MEDIT.EQ.21) THEN
54303 IF(2*N.GE.MSTU(4)) THEN
54304 CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS')
54305 RETURN
54306 ENDIF
54307 DO 240 I=1,N
54308 DO 230 J=1,5
54309 K(MSTU(4)-I,J)=K(I,J)
54310 P(MSTU(4)-I,J)=P(I,J)
54311 V(MSTU(4)-I,J)=V(I,J)
54312 230 CONTINUE
54313 240 CONTINUE
54314 MSTU(32)=N
54315
54316C...Restore bottom entries of commonblock PYJETS to top.
54317 ELSEIF(MEDIT.EQ.22) THEN
54318 DO 260 I=1,MSTU(32)
54319 DO 250 J=1,5
54320 K(I,J)=K(MSTU(4)-I,J)
54321 P(I,J)=P(MSTU(4)-I,J)
54322 V(I,J)=V(MSTU(4)-I,J)
54323 250 CONTINUE
54324 260 CONTINUE
54325 N=MSTU(32)
54326
54327C...Mark primary entries at top of commonblock PYJETS as untreated.
54328 ELSEIF(MEDIT.EQ.23) THEN
54329 I1=0
54330 DO 270 I=1,N
54331 KH=K(I,3)
54332 IF(KH.GE.1) THEN
54333 IF(K(KH,1).GE.21.AND.K(KH,1).LE.30) KH=0
54334 ENDIF
54335 IF(KH.NE.0) GOTO 280
54336 I1=I1+1
54337 IF(K(I,1).GE.11.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
54338 IF(K(I,1).GE.51.AND.K(I,1).LE.60) K(I,1)=K(I,1)-10
54339 270 CONTINUE
54340 280 N=I1
54341
54342C...Place largest axis along z axis and second largest in xy plane.
54343 ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
54344 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1),
54345 & P(MSTU(61),2)),0D0,0D0,0D0)
54346 CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3),
54347 & P(MSTU(61),1)),0D0,0D0,0D0,0D0)
54348 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1),
54349 & P(MSTU(61)+1,2)),0D0,0D0,0D0)
54350 IF(MEDIT.EQ.31) RETURN
54351
54352C...Rotate to put slim jet along +z axis.
54353 DO 290 IS=1,2
54354 NS(IS)=0
54355 PTS(IS)=0D0
54356 PLS(IS)=0D0
54357 290 CONTINUE
54358 DO 300 I=1,N
54359 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300
54360 IF(MSTU(41).GE.2) THEN
54361 KC=PYCOMP(K(I,2))
54362 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
54363 & KC.EQ.18) GOTO 300
54364 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
54365 & .EQ.0) GOTO 300
54366 ENDIF
54367 IS=2D0-SIGN(0.5D0,P(I,3))
54368 NS(IS)=NS(IS)+1
54369 PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
54370 300 CONTINUE
54371 IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
54372 & CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0)
54373
54374C...Rotate to put second largest jet into -z,+x quadrant.
54375 DO 310 I=1,N
54376 IF(P(I,3).GE.0D0) GOTO 310
54377 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310
54378 IF(MSTU(41).GE.2) THEN
54379 KC=PYCOMP(K(I,2))
54380 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
54381 & KC.EQ.18) GOTO 310
54382 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
54383 & .EQ.0) GOTO 310
54384 ENDIF
54385 IS=2D0-SIGN(0.5D0,P(I,1))
54386 PLS(IS)=PLS(IS)-P(I,3)
54387 310 CONTINUE
54388 IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1),
54389 & 0D0,0D0,0D0)
54390 ENDIF
54391
54392 RETURN
54393 END
54394
54395C*********************************************************************
54396
54397C...PYLIST
54398C...Gives program heading, or lists an event, or particle
54399C...data, or current parameter values.
54400
54401 SUBROUTINE PYLIST(MLIST)
54402
54403C...Double precision and integer declarations.
54404 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54405 IMPLICIT INTEGER(I-N)
54406 INTEGER PYK,PYCHGE,PYCOMP
54407C...Parameter statement to help give large particle numbers.
54408 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
54409 &KEXCIT=4000000,KDIMEN=5000000)
54410
54411C...HEPEVT commonblock.
54412 PARAMETER (NMXHEP=4000)
54413 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
54414 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
54415 DOUBLE PRECISION PHEP,VHEP
54416 SAVE /HEPEVT/
54417
54418C...User process event common block.
54419 INTEGER MAXNUP
54420 PARAMETER (MAXNUP=500)
54421 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
54422 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
54423 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
54424 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
54425 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
54426 SAVE /HEPEUP/
54427
54428C...Commonblocks.
54429 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
54430 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54431 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54432 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
54433 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
54434C...Local arrays, character variables and data.
54435 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
54436 DIMENSION PS(6)
54437 DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/
54438
54439C...Initialization printout: version number and date of last change.
54440 IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
54441 CALL PYLOGO
54442 MSTU(12)=0
54443 IF(MLIST.EQ.0) RETURN
54444 ENDIF
54445
54446C...List event data, including additional lines after N.
54447 IF(MLIST.GE.1.AND.MLIST.LE.3) THEN
54448 IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
54449 IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
54450 IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
54451 LMX=12
54452 IF(MLIST.GE.2) LMX=16
54453 ISTR=0
54454 IMAX=N
54455 IF(MSTU(2).GT.0) IMAX=MSTU(2)
54456 DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
54457 IF(I.GT.IMAX.AND.I.LE.N) GOTO 120
54458 IF(MSTU(15).EQ.0.AND.K(I,1).LE.0) GOTO 120
54459 IF(MSTU(15).EQ.1.AND.K(I,1).LT.0) GOTO 120
54460
54461C...Get particle name, pad it and check it is not too long.
54462 CALL PYNAME(K(I,2),CHAP)
54463 LEN=0
54464 DO 100 LEM=1,16
54465 IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
54466 100 CONTINUE
54467 MDL=(K(I,1)+19)/10
54468 LDL=0
54469 IF(MDL.EQ.2.OR.MDL.GE.8) THEN
54470 CHAC=CHAP
54471 IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
54472 ELSE
54473 LDL=1
54474 IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
54475 IF(LEN.EQ.0) THEN
54476 CHAC=CHDL(MDL)(1:2*LDL)//' '
54477 ELSE
54478 CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
54479 & CHDL(MDL)(LDL+1:2*LDL)//' '
54480 IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
54481 ENDIF
54482 ENDIF
54483
54484C...Add information on string connection.
54485 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
54486 & THEN
54487 KC=PYCOMP(K(I,2))
54488 KCC=0
54489 IF(KC.NE.0) KCC=KCHG(KC,2)
54490 IF(IABS(K(I,2)).EQ.39) THEN
54491 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
54492 ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
54493 ISTR=1
54494 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
54495 ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
54496 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
54497 ELSEIF(KCC.NE.0) THEN
54498 ISTR=0
54499 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
54500 ENDIF
54501 ENDIF
54502 IF((K(I,1).EQ.41.OR.K(I,1).EQ.51).AND.LEN+2*LDL+3.LE.LMX)
54503 & CHAC(LMX-1:LMX-1)='I'
54504
54505C...Write data for particle/jet.
54506 IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) THEN
54507 WRITE(MSTU(11),5400) I,CHAC(1:12),(K(I,J1),J1=1,3),
54508 & (P(I,J2),J2=1,5)
54509 ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999D0) THEN
54510 WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
54511 & (P(I,J2),J2=1,5)
54512 ELSEIF(MLIST.EQ.1) THEN
54513 WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
54514 & (P(I,J2),J2=1,5)
54515 ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
54516 & K(I,1).EQ.14.OR.K(I,1).EQ.42.OR.K(I,1).EQ.52)) THEN
54517 WRITE(MSTU(11),5700) I,CHAC,(K(I,J1),J1=1,3),
54518 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
54519 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
54520 & (P(I,J2),J2=1,5)
54521 ELSE
54522 WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,5),
54523 & (P(I,J2),J2=1,5)
54524 ENDIF
54525 IF(MLIST.EQ.3) WRITE(MSTU(11),5900) (V(I,J),J=1,5)
54526
54527C...Insert extra separator lines specified by user.
54528 IF(MSTU(70).GE.1) THEN
54529 ISEP=0
54530 DO 110 J=1,MIN(10,MSTU(70))
54531 IF(I.EQ.MSTU(70+J)) ISEP=1
54532 110 CONTINUE
54533 IF(ISEP.EQ.1.AND.MLIST.EQ.1) WRITE(MSTU(11),6000)
54534 IF(ISEP.EQ.1.AND.MLIST.GE.2) WRITE(MSTU(11),6100)
54535 ENDIF
54536 120 CONTINUE
54537
54538C...Sum of charges and momenta.
54539 DO 130 J=1,6
54540 PS(J)=PYP(0,J)
54541 130 CONTINUE
54542 IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999D0) THEN
54543 WRITE(MSTU(11),6200) PS(6),(PS(J),J=1,5)
54544 ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN
54545 WRITE(MSTU(11),6300) PS(6),(PS(J),J=1,5)
54546 ELSEIF(MLIST.EQ.1) THEN
54547 WRITE(MSTU(11),6400) PS(6),(PS(J),J=1,5)
54548 ELSE
54549 WRITE(MSTU(11),6500) PS(6),(PS(J),J=1,5)
54550 ENDIF
54551
54552C...Simple listing of HEPEVT entries (mainly for test purposes).
54553 ELSEIF(MLIST.EQ.5) THEN
54554 WRITE(MSTU(11),7500)
54555 DO 140 I=1,NHEP
54556 IF(ISTHEP(I).EQ.0) GOTO 140
54557 WRITE(MSTU(11),7600) I,ISTHEP(I),IDHEP(I),JMOHEP(1,I),
54558 & JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),(PHEP(J,I),J=1,5)
54559 140 CONTINUE
54560
54561
54562C...Simple listing of user-process entries (mainly for test purposes).
54563 ELSEIF(MLIST.EQ.7) THEN
54564 WRITE(MSTU(11),7300)
54565 DO 150 I=1,NUP
54566 WRITE(MSTU(11),7400) I,ISTUP(I),IDUP(I),MOTHUP(1,I),
54567 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5)
54568 150 CONTINUE
54569
54570C...Give simple list of KF codes defined in program.
54571 ELSEIF(MLIST.EQ.11) THEN
54572 WRITE(MSTU(11),6600)
54573 DO 160 KF=1,80
54574 CALL PYNAME(KF,CHAP)
54575 CALL PYNAME(-KF,CHAN)
54576 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
54577 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
54578 160 CONTINUE
54579 DO 190 KFLS=1,3,2
54580 DO 180 KFLA=1,5
54581 DO 170 KFLB=1,KFLA-(3-KFLS)/2
54582 KF=1000*KFLA+100*KFLB+KFLS
54583 CALL PYNAME(KF,CHAP)
54584 CALL PYNAME(-KF,CHAN)
54585 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
54586 170 CONTINUE
54587 180 CONTINUE
54588 190 CONTINUE
54589 DO 220 KMUL=0,5
54590 KFLS=3
54591 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
54592 IF(KMUL.EQ.5) KFLS=5
54593 KFLR=0
54594 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
54595 IF(KMUL.EQ.4) KFLR=2
54596 DO 210 KFLB=1,5
54597 DO 200 KFLC=1,KFLB-1
54598 KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
54599 CALL PYNAME(KF,CHAP)
54600 CALL PYNAME(-KF,CHAN)
54601 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
54602 IF(KF.EQ.311) THEN
54603 KFK=130
54604 CALL PYNAME(KFK,CHAP)
54605 WRITE(MSTU(11),6700) KFK,CHAP
54606 KFK=310
54607 CALL PYNAME(KFK,CHAP)
54608 WRITE(MSTU(11),6700) KFK,CHAP
54609 ENDIF
54610 200 CONTINUE
54611 KF=10000*KFLR+110*KFLB+KFLS
54612 CALL PYNAME(KF,CHAP)
54613 WRITE(MSTU(11),6700) KF,CHAP
54614 210 CONTINUE
54615 220 CONTINUE
54616 KF=100443
54617 CALL PYNAME(KF,CHAP)
54618 WRITE(MSTU(11),6700) KF,CHAP
54619 KF=100553
54620 CALL PYNAME(KF,CHAP)
54621 WRITE(MSTU(11),6700) KF,CHAP
54622 DO 260 KFLSP=1,3
54623 KFLS=2+2*(KFLSP/3)
54624 DO 250 KFLA=1,5
54625 DO 240 KFLB=1,KFLA
54626 DO 230 KFLC=1,KFLB
54627 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC))
54628 & GOTO 230
54629 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 230
54630 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
54631 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
54632 CALL PYNAME(KF,CHAP)
54633 CALL PYNAME(-KF,CHAN)
54634 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
54635 230 CONTINUE
54636 240 CONTINUE
54637 250 CONTINUE
54638 260 CONTINUE
54639 DO 270 KC=1,500
54640 KF=KCHG(KC,4)
54641 IF(KF.LT.1000000) GOTO 270
54642 CALL PYNAME(KF,CHAP)
54643 CALL PYNAME(-KF,CHAN)
54644 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
54645 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
54646 270 CONTINUE
54647
54648C...List parton/particle data table. Check whether to be listed.
54649 ELSEIF(MLIST.EQ.12) THEN
54650 WRITE(MSTU(11),6800)
54651 DO 300 KC=1,MSTU(6)
54652 KF=KCHG(KC,4)
54653 IF(KF.EQ.0) GOTO 300
54654 IF(KF.LT.MSTU(1).OR.(MSTU(2).GT.0.AND.KF.GT.MSTU(2)))
54655 & GOTO 300
54656
54657C...Find particle name and mass. Print information.
54658 CALL PYNAME(KF,CHAP)
54659 IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 300
54660 CALL PYNAME(-KF,CHAN)
54661 WRITE(MSTU(11),6900) KF,KC,CHAP,CHAN,(KCHG(KC,J1),J1=1,3),
54662 & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
54663
54664C...Particle decay: channel number, branching ratios, matrix element,
54665C...decay products.
54666 DO 290 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
54667 DO 280 J=1,5
54668 CALL PYNAME(KFDP(IDC,J),CHAD(J))
54669 280 CONTINUE
54670 WRITE(MSTU(11),7000) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
54671 & (CHAD(J),J=1,5)
54672 290 CONTINUE
54673 300 CONTINUE
54674
54675C...List parameter value table.
54676 ELSEIF(MLIST.EQ.13) THEN
54677 WRITE(MSTU(11),7100)
54678 DO 310 I=1,200
54679 WRITE(MSTU(11),7200) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
54680 310 CONTINUE
54681 ENDIF
54682
54683C...Format statements for output on unit MSTU(11) (by default 6).
54684 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
54685 &5X,'KF orig p_x p_y p_z E m'/)
54686 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet',
54687 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
54688 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
54689 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j',
54690 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
54691 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X,
54692 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
54693 5400 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3)
54694 5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2)
54695 5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1)
54696 5700 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5)
54697 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5)
54698 5900 FORMAT(66X,5(1X,F12.3))
54699 6000 FORMAT(1X,78('='))
54700 6100 FORMAT(1X,130('='))
54701 6200 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
54702 6300 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
54703 6400 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
54704 6500 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
54705 &5F13.5)
54706 6600 FORMAT(///20X,'List of KF codes in program'/)
54707 6700 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16)
54708 6800 FORMAT(///30X,'Particle/parton data table'//8X,'KF',5X,'KC',4X,
54709 &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X,
54710 &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
54711 &1X,'ME',3X,'Br.rat.',4X,'decay products')
54712 6900 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
54713 &1X,1P,E13.5,3X,I2)
54714 7000 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16)
54715 7100 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
54716 &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
54717 7200 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
54718 7300 FORMAT(/10X,'Event listing of user process at input (simplified)'
54719 &//' I IST ID Mothers Colours p_x p_y p_z',
54720 &' E m')
54721 7400 FORMAT(1X,I3,I3,I8,2I4,2I5,5F9.3)
54722 7500 FORMAT(/10X,'Event listing of HEPEVT common block (simplified)'
54723 &//' I IST ID Mothers Daughters p_x p_y p_z',
54724 &' E m')
54725 7600 FORMAT(1X,I4,I2,I8,4I5,5F9.3)
54726
54727 RETURN
54728 END
54729
54730C*********************************************************************
54731
54732C...PYLOGO
54733C...Writes a logo for the program.
54734
54735 SUBROUTINE PYLOGO
54736
54737C...Double precision and integer declarations.
54738 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54739 IMPLICIT INTEGER(I-N)
54740 INTEGER PYK,PYCHGE,PYCOMP
54741C...Parameter for length of information block.
54742 PARAMETER (IREFER=24)
54743C...Commonblocks.
54744 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54745 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54746 SAVE /PYDAT1/,/PYPARS/
54747C...Local arrays and character variables.
54748 INTEGER IDATI(6)
54749 CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79,
54750 &VERS*1, SUBV*3, DATE*2, YEAR*4, HOUR*2, MINU*2, SECO*2
54751
54752C...Data on months, logo, titles, and references.
54753 DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
54754 &'Oct','Nov','Dec'/
54755 DATA (LOGO(J),J=1,19)/
54756 &' *......* ',
54757 &' *:::!!:::::::::::* ',
54758 &' *::::::!!::::::::::::::* ',
54759 &' *::::::::!!::::::::::::::::* ',
54760 &' *:::::::::!!:::::::::::::::::* ',
54761 &' *:::::::::!!:::::::::::::::::* ',
54762 &' *::::::::!!::::::::::::::::*! ',
54763 &' *::::::!!::::::::::::::* !! ',
54764 &' !! *:::!!:::::::::::* !! ',
54765 &' !! !* -><- * !! ',
54766 &' !! !! !! ',
54767 &' !! !! !! ',
54768 &' !! !! ',
54769 &' !! lh !! ',
54770 &' !! !! ',
54771 &' !! hh !! ',
54772 &' !! ll !! ',
54773 &' !! !! ',
54774 &' !! '/
54775 DATA (LOGO(J),J=20,38)/
54776 &'Welcome to the Lund Monte Carlo!',
54777 &' ',
54778 &'PPP Y Y TTTTT H H III A ',
54779 &'P P Y Y T H H I A A ',
54780 &'PPP Y T HHHHH I AAAAA',
54781 &'P Y T H H I A A',
54782 &'P Y T H H III A A',
54783 &' ',
54784 &'This is PYTHIA version x.xxx ',
54785 &'Last date of change: xx xxx 199x',
54786 &' ',
54787 &'Now is xx xxx 199x at xx:xx:xx ',
54788 &' ',
54789 &'Disclaimer: this program comes ',
54790 &'without any guarantees. Beware ',
54791 &'of errors and use common sense ',
54792 &'when interpreting results. ',
54793 &' ',
54794 &'Copyright T. Sjostrand (2003) '/
54795 DATA (REFER(J),J=1,18)/
54796 &'An archive of program versions and d',
54797 &'ocumentation is found on the web: ',
54798 &'http://www.thep.lu.se/~torbjorn/Pyth',
54799 &'ia.html ',
54800 &' ',
54801 &' ',
54802 &'When you cite this program, currentl',
54803 &'y the official reference is ',
54804 &'T. Sjostrand, P. Eden, C. Friberg, L',
54805 &'. Lonnblad, G. Miu, S. Mrenna and ',
54806 &'E. Norrbin, Computer Physics Commun.',
54807 &' 135 (2001) 238. ',
54808 &'The large manual is ',
54809 &' ',
54810 &'T. Sjostrand, L. Lonnblad and S. Mre',
54811 &'nna, LU TP 01-21 [hep-ph/0108264]. ',
54812 &'Also remember that the program, to a',
54813 &' large extent, represents original '/
54814 DATA (REFER(J),J=19,36)/
54815 &'physics research. Other publications',
54816 &' of special relevance to your ',
54817 &'studies may therefore deserve separa',
54818 &'te mention. ',
54819 &' ',
54820 &' ',
54821 &'Main author: Torbjorn Sjostrand; Dep',
54822 &'artment of Theoretical Physics 2, ',
54823 &' Lund University, Solvegatan 14A, S',
54824 &'-223 62 Lund, Sweden; ',
54825 &' phone: + 46 - 46 - 222 48 16; e-ma',
54826 &'il: torbjorn@thep.lu.se ',
54827 &'Author: Leif Lonnblad; Department of',
54828 &' Theoretical Physics 2, ',
54829 &' Lund University, Solvegatan 14A, S',
54830 &'-223 62 Lund, Sweden; ',
54831 &' phone: + 46 - 46 - 222 77 80; e-ma',
54832 &'il: leif@thep.lu.se '/
54833 DATA (REFER(J),J=37,2*IREFER)/
54834 &'Author: Stephen Mrenna; Computing Di',
54835 &'vision, Simulations Group, ',
54836 &' Fermi National Accelerator Laborat',
54837 &'ory, MS 234, Batavia, IL 60510, USA;',
54838 &' phone: + 1 - 630 - 840 - 2556; e-m',
54839 &'ail: mrenna@fnal.gov ',
54840 &'Author: Peter Skands; Department of ',
54841 &'Theoretical Physics 2, ',
54842 &' Lund University, Solvegatan 14A, S',
54843 &'-223 62 Lund, Sweden; ',
54844 &' phone: + 46 - 46 - 222 31 92; e-ma',
54845 &'il: zeiler@thep.lu.se '/
54846
54847C...Check that PYDATA linked.
54848 IF(MSTP(183)/10.NE.199.AND.MSTP(183)/10.NE.200) THEN
54849 WRITE(*,'(1X,A)')
54850 & 'Error: PYDATA has not been linked.'
54851 WRITE(*,'(1X,A)') 'Execution stopped!'
54852 STOP
54853
54854C...Write current version number and current date+time.
54855 ELSE
54856 WRITE(VERS,'(I1)') MSTP(181)
54857 LOGO(28)(24:24)=VERS
54858 WRITE(SUBV,'(I3)') MSTP(182)
54859 LOGO(28)(26:28)=SUBV
54860 IF(MSTP(182).LT.100) LOGO(28)(26:26)='0'
54861 WRITE(DATE,'(I2)') MSTP(185)
54862 LOGO(29)(22:23)=DATE
54863 LOGO(29)(25:27)=MONTH(MSTP(184))
54864 WRITE(YEAR,'(I4)') MSTP(183)
54865 LOGO(29)(29:32)=YEAR
54866 CALL PYTIME(IDATI)
54867 IF(IDATI(1).LE.0) THEN
54868 LOGO(31)=' '
54869 ELSE
54870 WRITE(DATE,'(I2)') IDATI(3)
54871 LOGO(31)(8:9)=DATE
54872 LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2))))
54873 WRITE(YEAR,'(I4)') IDATI(1)
54874 LOGO(31)(15:18)=YEAR
54875 WRITE(HOUR,'(I2)') IDATI(4)
54876 LOGO(31)(23:24)=HOUR
54877 WRITE(MINU,'(I2)') IDATI(5)
54878 LOGO(31)(26:27)=MINU
54879 IF(IDATI(5).LT.10) LOGO(31)(26:26)='0'
54880 WRITE(SECO,'(I2)') IDATI(6)
54881 LOGO(31)(29:30)=SECO
54882 IF(IDATI(6).LT.10) LOGO(31)(29:29)='0'
54883 ENDIF
54884 ENDIF
54885
54886C...Loop over lines in header. Define page feed and side borders.
54887 DO 100 ILIN=1,29+IREFER
54888 LINE=' '
54889 IF(ILIN.EQ.1) THEN
54890 LINE(1:1)='1'
54891 ELSE
54892 LINE(2:3)='**'
54893 LINE(78:79)='**'
54894 ENDIF
54895
54896C...Separator lines and logos.
54897 IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN
54898 LINE(4:77)='***********************************************'//
54899 & '***************************'
54900 ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN
54901 LINE(6:37)=LOGO(ILIN-5)
54902 LINE(44:75)=LOGO(ILIN+14)
54903 ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN
54904 LINE(5:40)=REFER(2*ILIN-51)
54905 LINE(41:76)=REFER(2*ILIN-50)
54906 ENDIF
54907
54908C...Write lines to appropriate unit.
54909 WRITE(MSTU(11),'(A79)') LINE
54910 100 CONTINUE
54911
54912 RETURN
54913 END
54914
54915C*********************************************************************
54916
54917C...PYUPDA
54918C...Facilitates the updating of particle and decay data
54919C...by allowing it to be done in an external file.
54920
54921 SUBROUTINE PYUPDA(MUPDA,LFN)
54922
54923C...Double precision and integer declarations.
54924 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54925 IMPLICIT INTEGER(I-N)
54926 INTEGER PYK,PYCHGE,PYCOMP
54927C...Commonblocks.
54928 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54929 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54930 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
54931 COMMON/PYDAT4/CHAF(500,2)
54932 CHARACTER CHAF*16
54933 COMMON/PYINT4/MWID(500),WIDS(500,5)
54934 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/
54935C...Local arrays, character variables and data.
54936 CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72,
54937 &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24
54938 DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
54939 &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
54940 &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
54941 &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
54942 &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
54943
54944C...Write header if not yet done.
54945 IF(MSTU(12).GE.1) CALL PYLIST(0)
54946
54947C...Write information on file for editing.
54948 IF(MUPDA.EQ.1) THEN
54949 DO 110 KC=1,500
54950 WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
54951 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
54952 & MWID(KC),MDCY(KC,1)
54953 DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
54954 WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
54955 & (KFDP(IDC,J),J=1,5)
54956 100 CONTINUE
54957 110 CONTINUE
54958
54959C...Read complete set of information from edited file or
54960C...read partial set of new or updated information from edited file.
54961 ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN
54962
54963C...Reset counters.
54964 KCC=100
54965 NDC=0
54966 CHKF=' '
54967 IF(MUPDA.EQ.2) THEN
54968 DO 120 I=1,MSTU(6)
54969 KCHG(I,4)=0
54970 120 CONTINUE
54971 ELSE
54972 DO 130 KC=1,MSTU(6)
54973 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
54974 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
54975 130 CONTINUE
54976 ENDIF
54977
54978C...Begin of loop: read new line; unknown whether particle or
54979C...decay data.
54980 140 READ(LFN,5200,END=190) CHINL
54981
54982C...Identify particle code and whether already defined (for MUPDA=3).
54983 IF(CHINL(2:10).NE.' ') THEN
54984 CHKF=CHINL(2:10)
54985 READ(CHKF,5300) KF
54986 IF(MUPDA.EQ.2) THEN
54987 IF(KF.LE.100) THEN
54988 KC=KF
54989 ELSE
54990 KCC=KCC+1
54991 KC=KCC
54992 ENDIF
54993 ELSE
54994 KCREP=0
54995 IF(KF.LE.100) THEN
54996 KCREP=KF
54997 ELSE
54998 DO 150 KCR=101,KCC
54999 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
55000 150 CONTINUE
55001 ENDIF
55002C...Remove duplicate old decay data.
5d3dd6f6 55003 IF(KCREP.NE.0) THEN
55004 IF(MDCY(KCREP,3).GT.0) THEN
55005 IDCREP=MDCY(KCREP,2)
55006 NDCREP=MDCY(KCREP,3)
55007 DO 160 I=1,KCC
55008 IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP
55009 160 CONTINUE
55010 DO 180 I=IDCREP,NDC-NDCREP
55011 MDME(I,1)=MDME(I+NDCREP,1)
55012 MDME(I,2)=MDME(I+NDCREP,2)
55013 BRAT(I)=BRAT(I+NDCREP)
55014 DO 170 J=1,5
55015 KFDP(I,J)=KFDP(I+NDCREP,J)
55016 170 CONTINUE
55017 180 CONTINUE
55018 NDC=NDC-NDCREP
55019 KC=KCREP
55020 ELSE
55021 KC=KCREP
55022 ENDIF
2dfa57d1 55023 ELSE
55024 KCC=KCC+1
55025 KC=KCC
55026 ENDIF
55027 ENDIF
55028
55029C...Study line with particle data.
55030 IF(KC.GT.MSTU(6)) CALL PYERRM(27,
55031 & '(PYUPDA:) Particle arrays full by KF ='//CHKF)
55032 READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
55033 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
55034 & MWID(KC),MDCY(KC,1)
55035 MDCY(KC,2)=0
55036 MDCY(KC,3)=0
55037
55038C...Study line with decay data.
55039 ELSE
55040 NDC=NDC+1
55041 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
55042 & '(PYUPDA:) Decay data arrays full by KF ='//CHKF)
55043 IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC
55044 MDCY(KC,3)=MDCY(KC,3)+1
55045 READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC),
55046 & (KFDP(NDC,J),J=1,5)
55047 ENDIF
55048
55049C...End of loop; ensure that PYCOMP tables are updated.
55050 GOTO 140
55051 190 CONTINUE
55052 MSTU(20)=0
55053
55054C...Perform possible tests that new information is consistent.
55055 DO 220 KC=1,MSTU(6)
55056 KF=KCHG(KC,4)
55057 IF(KF.EQ.0) GOTO 220
55058 WRITE(CHKF,5300) KF
55059 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
55060 & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17,
55061 & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF)
55062 BRSUM=0D0
55063 DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
55064 IF(MDME(IDC,2).GT.80) GOTO 210
55065 KQ=KCHG(KC,1)
55066 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
55067 MERR=0
55068 DO 200 J=1,5
55069 KP=KFDP(IDC,J)
55070 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
55071 IF(KP.EQ.81) KQ=0
55072 ELSEIF(PYCOMP(KP).EQ.0) THEN
55073 MERR=3
55074 ELSE
55075 KQ=KQ-PYCHGE(KP)
55076 KPC=PYCOMP(KP)
55077 PMS=PMS-PMAS(KPC,1)
55078 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
55079 & PMAS(KPC,3))
55080 ENDIF
55081 200 CONTINUE
55082 IF(KQ.NE.0) MERR=MAX(2,MERR)
55083 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
55084 & MERR=MAX(1,MERR)
55085 IF(MERR.EQ.3) CALL PYERRM(17,
55086 & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF)
55087 IF(MERR.EQ.2) CALL PYERRM(17,
55088 & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF)
55089 IF(MERR.EQ.1) CALL PYERRM(7,
55090 & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF)
55091 BRSUM=BRSUM+BRAT(IDC)
55092 210 CONTINUE
55093 WRITE(CHTMP,5500) BRSUM
55094 IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0)
55095 & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '//
55096 & CHTMP(9:16)//' for KF ='//CHKF)
55097 220 CONTINUE
55098
55099C...Write DATA statements for inclusion in program.
55100 ELSEIF(MUPDA.EQ.4) THEN
55101
55102C...Find out how many codes and decay channels are actually used.
55103 KCC=0
55104 NDC=0
55105 DO 230 I=1,MSTU(6)
55106 IF(KCHG(I,4).NE.0) THEN
55107 KCC=I
55108 NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1)
55109 ENDIF
55110 230 CONTINUE
55111
55112C...Initialize writing of DATA statements for inclusion in program.
55113 DO 300 IVAR=1,22
55114 NDIM=MSTU(6)
55115 IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7)
55116 NLIN=1
55117 CHLIN=' '
55118 CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/'
55119 LLIN=35
55120 CHOLD='START'
55121
55122C...Loop through variables for conversion to characters.
55123 DO 280 IDIM=1,NDIM
55124 IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
55125 IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
55126 IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
55127 IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4)
55128 IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1)
55129 IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2)
55130 IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3)
55131 IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4)
55132 IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1)
55133 IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2)
55134 IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3)
55135 IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1)
55136 IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2)
55137 IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM)
55138 IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1)
55139 IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2)
55140 IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3)
55141 IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4)
55142 IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5)
55143 IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1)
55144 IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2)
55145 IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM)
55146
55147C...Replace variables beyond what is properly defined.
55148 IF(IVAR.LE.4) THEN
55149 IF(IDIM.GT.KCC) CHTMP=' 0'
55150 ELSEIF(IVAR.LE.8) THEN
55151 IF(IDIM.GT.KCC) CHTMP=' 0.0'
55152 ELSEIF(IVAR.LE.11) THEN
55153 IF(IDIM.GT.KCC) CHTMP=' 0'
55154 ELSEIF(IVAR.LE.13) THEN
55155 IF(IDIM.GT.NDC) CHTMP=' 0'
55156 ELSEIF(IVAR.LE.14) THEN
55157 IF(IDIM.GT.NDC) CHTMP=' 0.0'
55158 ELSEIF(IVAR.LE.19) THEN
55159 IF(IDIM.GT.NDC) CHTMP=' 0'
55160 ELSEIF(IVAR.LE.21) THEN
55161 IF(IDIM.GT.KCC) CHTMP=' '
55162 ELSE
55163 IF(IDIM.GT.KCC) CHTMP=' 0'
55164 ENDIF
55165
55166C...Length of variable, trailing decimal zeros, quotation marks.
55167 LLOW=1
55168 LHIG=1
55169 DO 240 LL=1,16
55170 IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL
55171 IF(CHTMP(LL:LL).NE.' ') LHIG=LL
55172 240 CONTINUE
55173 CHNEW=CHTMP(LLOW:LHIG)//' '
55174 LNEW=1+LHIG-LLOW
55175 IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN
55176 LNEW=LNEW+1
55177 250 LNEW=LNEW-1
55178 IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250
55179 IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1
55180 IF(LNEW.EQ.0) THEN
55181 CHNEW(1:3)='0D0'
55182 LNEW=3
55183 ELSE
55184 CHNEW(LNEW+1:LNEW+2)='D0'
55185 LNEW=LNEW+2
55186 ENDIF
55187 ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN
55188 DO 260 LL=LNEW,1,-1
55189 IF(CHNEW(LL:LL).EQ.'''') THEN
55190 CHTMP=CHNEW
55191 CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
55192 LNEW=LNEW+1
55193 ENDIF
55194 260 CONTINUE
55195 LNEW=MIN(14,LNEW)
55196 CHTMP=CHNEW
55197 CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
55198 LNEW=LNEW+2
55199 ENDIF
55200
55201C...Form composite character string, often including repetition counter.
55202 IF(CHNEW.NE.CHOLD) THEN
55203 NRPT=1
55204 CHOLD=CHNEW
55205 CHCOM=CHNEW
55206 LCOM=LNEW
55207 ELSE
55208 LRPT=LNEW+1
55209 IF(NRPT.GE.2) LRPT=LNEW+3
55210 IF(NRPT.GE.10) LRPT=LNEW+4
55211 IF(NRPT.GE.100) LRPT=LNEW+5
55212 IF(NRPT.GE.1000) LRPT=LNEW+6
55213 LLIN=LLIN-LRPT
55214 NRPT=NRPT+1
55215 WRITE(CHTMP,5400) NRPT
55216 LRPT=1
55217 IF(NRPT.GE.10) LRPT=2
55218 IF(NRPT.GE.100) LRPT=3
55219 IF(NRPT.GE.1000) LRPT=4
55220 CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW)
55221 LCOM=LRPT+1+LNEW
55222 ENDIF
55223
55224C...Add characters to end of line, to new line (after storing old line),
55225C...or to new block of lines (after writing old block).
55226 IF(LLIN+LCOM.LE.70) THEN
55227 CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
55228 LLIN=LLIN+LCOM+1
55229 ELSEIF(NLIN.LE.19) THEN
55230 CHLIN(LLIN+1:72)=' '
55231 CHBLK(NLIN)=CHLIN
55232 NLIN=NLIN+1
55233 CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
55234 LLIN=6+LCOM+1
55235 ELSE
55236 CHLIN(LLIN:72)='/'//' '
55237 CHBLK(NLIN)=CHLIN
55238 WRITE(CHTMP,5400) IDIM-NRPT
55239 CHBLK(1)(30:33)=CHTMP(13:16)
55240 DO 270 ILIN=1,NLIN
55241 WRITE(LFN,5700) CHBLK(ILIN)
55242 270 CONTINUE
55243 NLIN=1
55244 CHLIN=' '
55245 CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//
55246 & ',I= , )/'//CHCOM(1:LCOM)//','
55247 WRITE(CHTMP,5400) IDIM-NRPT+1
55248 CHLIN(25:28)=CHTMP(13:16)
55249 LLIN=35+LCOM+1
55250 ENDIF
55251 280 CONTINUE
55252
55253C...Write final block of lines.
55254 CHLIN(LLIN:72)='/'//' '
55255 CHBLK(NLIN)=CHLIN
55256 WRITE(CHTMP,5400) NDIM
55257 CHBLK(1)(30:33)=CHTMP(13:16)
55258 DO 290 ILIN=1,NLIN
55259 WRITE(LFN,5700) CHBLK(ILIN)
55260 290 CONTINUE
55261 300 CONTINUE
55262 ENDIF
55263
55264C...Formats for reading and writing particle data.
55265 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3)
55266 5100 FORMAT(10X,2I5,F12.6,5I10)
55267 5200 FORMAT(A120)
55268 5300 FORMAT(I9)
55269 5400 FORMAT(I16)
55270 5500 FORMAT(F16.5)
55271 5600 FORMAT(F16.6)
55272 5700 FORMAT(A72)
55273
55274 RETURN
55275 END
55276
55277C*********************************************************************
55278
55279C...PYK
55280C...Provides various integer-valued event related data.
55281
55282 FUNCTION PYK(I,J)
55283
55284C...Double precision and integer declarations.
55285 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55286 IMPLICIT INTEGER(I-N)
55287 INTEGER PYK,PYCHGE,PYCOMP
55288C...Commonblocks.
55289 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
55290 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55291 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55292 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
55293
55294C...Default value. For I=0 number of entries, number of stable entries
55295C...or 3 times total charge.
55296 PYK=0
55297 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
55298 ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
55299 PYK=N
55300 ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
55301 DO 100 I1=1,N
55302 IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1
55303 IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+
55304 & PYCHGE(K(I1,2))
55305 100 CONTINUE
55306 ELSEIF(I.EQ.0) THEN
55307
55308C...For I > 0 direct readout of K matrix or charge.
55309 ELSEIF(J.LE.5) THEN
55310 PYK=K(I,J)
55311 ELSEIF(J.EQ.6) THEN
55312 PYK=PYCHGE(K(I,2))
55313
55314C...Status (existing/fragmented/decayed), parton/hadron separation.
55315 ELSEIF(J.LE.8) THEN
55316 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1
55317 IF(J.EQ.8) PYK=PYK*K(I,2)
55318 ELSEIF(J.LE.12) THEN
55319 KFA=IABS(K(I,2))
55320 KC=PYCOMP(KFA)
55321 KQ=0
55322 IF(KC.NE.0) KQ=KCHG(KC,2)
55323 IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2)
55324 IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2)
55325 IF(J.EQ.11) PYK=KC
55326 IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2))
55327
55328C...Heaviest flavour in hadron/diquark.
55329 ELSEIF(J.EQ.13) THEN
55330 KFA=IABS(K(I,2))
55331 PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
55332 IF(KFA.LT.10) PYK=KFA
55333 IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10)
55334 PYK=PYK*ISIGN(1,K(I,2))
55335
55336C...Particle history: generation, ancestor, rank.
55337 ELSEIF(J.LE.15) THEN
55338 I2=I
55339 I1=I
55340 110 PYK=PYK+1
55341 I2=I1
55342 I1=K(I1,3)
55343 IF(I1.GT.0) THEN
55344 IF(K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
55345 ENDIF
55346 IF(J.EQ.15) PYK=I2
55347 ELSEIF(J.EQ.16) THEN
55348 KFA=IABS(K(I,2))
55349 IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
55350 & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
55351 I1=I
55352 120 I2=I1
55353 I1=K(I1,3)
55354 IF(I1.GT.0) THEN
55355 KFAM=IABS(K(I1,2))
55356 ILP=1
55357 IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
55358 IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
55359 & ILP=0
55360 IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
55361 IF(ILP.EQ.1) GOTO 120
55362 ENDIF
55363 IF(K(I1,1).EQ.12) THEN
55364 DO 130 I3=I1+1,I2
55365 IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
55366 & .AND.K(I3,2).NE.93) PYK=PYK+1
55367 130 CONTINUE
55368 ELSE
55369 I3=I2
55370 140 PYK=PYK+1
55371 I3=I3+1
55372 IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
55373 ENDIF
55374 ENDIF
55375
55376C...Particle coming from collapsing jet system or not.
55377 ELSEIF(J.EQ.17) THEN
55378 I1=I
55379 150 PYK=PYK+1
55380 I3=I1
55381 I1=K(I1,3)
55382 I0=MAX(1,I1)
55383 KC=PYCOMP(K(I0,2))
55384 IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
55385 IF(PYK.EQ.1) PYK=-1
55386 IF(PYK.GT.1) PYK=0
55387 RETURN
55388 ENDIF
55389 IF(KCHG(KC,2).EQ.0) GOTO 150
55390 IF(K(I1,1).NE.12) PYK=0
55391 IF(K(I1,1).NE.12) RETURN
55392 I2=I1
55393 160 I2=I2+1
55394 IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
55395 K3M=K(I3-1,3)
55396 IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0
55397 K3P=K(I3+1,3)
55398 IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0
55399
55400C...Number of decay products. Colour flow.
55401 ELSEIF(J.EQ.18) THEN
55402 IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1)
55403 IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0
55404 ELSEIF(J.LE.22) THEN
55405 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
55406 IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5))
55407 IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5))
55408 IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5))
55409 IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5))
55410 ELSE
55411 ENDIF
55412
55413 RETURN
55414 END
55415
55416C*********************************************************************
55417
55418C...PYP
55419C...Provides various real-valued event related data.
55420
55421 FUNCTION PYP(I,J)
55422
55423C...Double precision and integer declarations.
55424 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55425 IMPLICIT INTEGER(I-N)
55426 INTEGER PYK,PYCHGE,PYCOMP
55427C...Commonblocks.
55428 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
55429 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55430 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55431 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
55432C...Local array.
55433 DIMENSION PSUM(4)
55434
55435C...Set default value. For I = 0 sum of momenta or charges,
55436C...or invariant mass of system.
55437 PYP=0D0
55438 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
55439 ELSEIF(I.EQ.0.AND.J.LE.4) THEN
55440 DO 100 I1=1,N
55441 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J)
55442 100 CONTINUE
55443 ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
55444 DO 120 J1=1,4
55445 PSUM(J1)=0D0
55446 DO 110 I1=1,N
55447 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+
55448 & P(I1,J1)
55449 110 CONTINUE
55450 120 CONTINUE
55451 PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
55452 ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
55453 DO 130 I1=1,N
55454 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0
55455 130 CONTINUE
55456 ELSEIF(I.EQ.0) THEN
55457
55458C...Direct readout of P matrix.
55459 ELSEIF(J.LE.5) THEN
55460 PYP=P(I,J)
55461
55462C...Charge, total momentum, transverse momentum, transverse mass.
55463 ELSEIF(J.LE.12) THEN
55464 IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0
55465 IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2
55466 IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2
55467 IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2
55468 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP)
55469
55470C...Theta and phi angle in radians or degrees.
55471 ELSEIF(J.LE.16) THEN
55472 IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
55473 IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2))
55474 IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1)
55475
55476C...True rapidity, rapidity with pion mass, pseudorapidity.
55477 ELSEIF(J.LE.19) THEN
55478 PMR=0D0
55479 IF(J.EQ.17) PMR=P(I,5)
55480 IF(J.EQ.18) PMR=PYMASS(211)
55481 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
55482 PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
55483 & 1D20)),P(I,3))
55484
55485C...Energy and momentum fractions (only to be used in CM frame).
55486 ELSEIF(J.LE.25) THEN
55487 IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
55488 IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21)
55489 IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
55490 IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21)
55491 IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21)
55492 IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21)
55493 ENDIF
55494
55495 RETURN
55496 END
55497
55498C*********************************************************************
55499
55500C...PYSPHE
55501C...Performs sphericity tensor analysis to give sphericity,
55502C...aplanarity and the related event axes.
55503
55504 SUBROUTINE PYSPHE(SPH,APL)
55505
55506C...Double precision and integer declarations.
55507 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55508 IMPLICIT INTEGER(I-N)
55509 INTEGER PYK,PYCHGE,PYCOMP
55510C...Commonblocks.
55511 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
55512 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55513 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55514 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
55515C...Local arrays.
55516 DIMENSION SM(3,3),SV(3,3)
55517
55518C...Calculate matrix to be diagonalized.
55519 NP=0
55520 DO 110 J1=1,3
55521 DO 100 J2=J1,3
55522 SM(J1,J2)=0D0
55523 100 CONTINUE
55524 110 CONTINUE
55525 PS=0D0
55526 DO 140 I=1,N
55527 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
55528 IF(MSTU(41).GE.2) THEN
55529 KC=PYCOMP(K(I,2))
55530 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
55531 & KC.EQ.18) GOTO 140
55532 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
55533 & GOTO 140
55534 ENDIF
55535 NP=NP+1
55536 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
55537 PWT=1D0
55538 IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT=
55539 & MAX(1D-10,PA)**(PARU(41)-2D0)
55540 DO 130 J1=1,3
55541 DO 120 J2=J1,3
55542 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
55543 120 CONTINUE
55544 130 CONTINUE
55545 PS=PS+PWT*PA**2
55546 140 CONTINUE
55547
55548C...Very low multiplicities (0 or 1) not considered.
55549 IF(NP.LE.1) THEN
55550 CALL PYERRM(8,'(PYSPHE:) too few particles for analysis')
55551 SPH=-1D0
55552 APL=-1D0
55553 RETURN
55554 ENDIF
55555 DO 160 J1=1,3
55556 DO 150 J2=J1,3
55557 SM(J1,J2)=SM(J1,J2)/PS
55558 150 CONTINUE
55559 160 CONTINUE
55560
55561C...Find eigenvalues to matrix (third degree equation).
55562 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
55563 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
55564 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
55565 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
55566 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
55567 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
55568 P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
55569 P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP)
55570 P(N+2,4)=1D0-P(N+1,4)-P(N+3,4)
55571 IF(P(N+2,4).LT.1D-5) THEN
55572 CALL PYERRM(8,'(PYSPHE:) all particles back-to-back')
55573 SPH=-1D0
55574 APL=-1D0
55575 RETURN
55576 ENDIF
55577
55578C...Find first and last eigenvector by solving equation system.
55579 DO 240 I=1,3,2
55580 DO 180 J1=1,3
55581 SV(J1,J1)=SM(J1,J1)-P(N+I,4)
55582 DO 170 J2=J1+1,3
55583 SV(J1,J2)=SM(J1,J2)
55584 SV(J2,J1)=SM(J1,J2)
55585 170 CONTINUE
55586 180 CONTINUE
55587 SMAX=0D0
55588 DO 200 J1=1,3
55589 DO 190 J2=1,3
55590 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
55591 JA=J1
55592 JB=J2
55593 SMAX=ABS(SV(J1,J2))
55594 190 CONTINUE
55595 200 CONTINUE
55596 SMAX=0D0
55597 DO 220 J3=JA+1,JA+2
55598 J1=J3-3*((J3-1)/3)
55599 RL=SV(J1,JB)/SV(JA,JB)
55600 DO 210 J2=1,3
55601 SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
55602 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
55603 JC=J1
55604 SMAX=ABS(SV(J1,J2))
55605 210 CONTINUE
55606 220 CONTINUE
55607 JB1=JB+1-3*(JB/3)
55608 JB2=JB+2-3*((JB+1)/3)
55609 P(N+I,JB1)=-SV(JC,JB2)
55610 P(N+I,JB2)=SV(JC,JB1)
55611 P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
55612 & SV(JA,JB)
55613 PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
55614 SGN=(-1D0)**INT(PYR(0)+0.5D0)
55615 DO 230 J=1,3
55616 P(N+I,J)=SGN*P(N+I,J)/PA
55617 230 CONTINUE
55618 240 CONTINUE
55619
55620C...Middle axis orthogonal to other two. Fill other codes.
55621 SGN=(-1D0)**INT(PYR(0)+0.5D0)
55622 P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
55623 P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
55624 P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
55625 DO 260 I=1,3
55626 K(N+I,1)=31
55627 K(N+I,2)=95
55628 K(N+I,3)=I
55629 K(N+I,4)=0
55630 K(N+I,5)=0
55631 P(N+I,5)=0D0
55632 DO 250 J=1,5
55633 V(I,J)=0D0
55634 250 CONTINUE
55635 260 CONTINUE
55636
55637C...Calculate sphericity and aplanarity. Select storing option.
55638 SPH=1.5D0*(P(N+2,4)+P(N+3,4))
55639 APL=1.5D0*P(N+3,4)
55640 MSTU(61)=N+1
55641 MSTU(62)=NP
55642 IF(MSTU(43).LE.1) MSTU(3)=3
55643 IF(MSTU(43).GE.2) N=N+3
55644
55645 RETURN
55646 END
55647
55648C*********************************************************************
55649
55650C...PYTHRU
55651C...Performs thrust analysis to give thrust, oblateness
55652C...and the related event axes.
55653
55654 SUBROUTINE PYTHRU(THR,OBL)
55655
55656C...Double precision and integer declarations.
55657 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55658 IMPLICIT INTEGER(I-N)
55659 INTEGER PYK,PYCHGE,PYCOMP
55660C...Commonblocks.
55661 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
55662 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55663 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55664 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
55665C...Local arrays.
55666 DIMENSION TDI(3),TPR(3)
55667
55668C...Take copy of particles that are to be considered in thrust analysis.
55669 NP=0
55670 PS=0D0
55671 DO 100 I=1,N
55672 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
55673 IF(MSTU(41).GE.2) THEN
55674 KC=PYCOMP(K(I,2))
55675 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
55676 & KC.EQ.18) GOTO 100
55677 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
55678 & GOTO 100
55679 ENDIF
55680 IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
55681 CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS')
55682 THR=-2D0
55683 OBL=-2D0
55684 RETURN
55685 ENDIF
55686 NP=NP+1
55687 K(N+NP,1)=23
55688 P(N+NP,1)=P(I,1)
55689 P(N+NP,2)=P(I,2)
55690 P(N+NP,3)=P(I,3)
55691 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
55692 P(N+NP,5)=1D0
55693 IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)=
55694 & P(N+NP,4)**(PARU(42)-1D0)
55695 PS=PS+P(N+NP,4)*P(N+NP,5)
55696 100 CONTINUE
55697
55698C...Very low multiplicities (0 or 1) not considered.
55699 IF(NP.LE.1) THEN
55700 CALL PYERRM(8,'(PYTHRU:) too few particles for analysis')
55701 THR=-1D0
55702 OBL=-1D0
55703 RETURN
55704 ENDIF
55705
55706C...Loop over thrust and major. T axis along z direction in latter case.
55707 DO 320 ILD=1,2
55708 IF(ILD.EQ.2) THEN
55709 K(N+NP+1,1)=31
55710 PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2))
55711 MSTU(33)=1
55712 CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0)
55713 THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1))
55714 CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0)
55715 ENDIF
55716
55717C...Find and order particles with highest p (pT for major).
55718 DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
55719 P(ILF,4)=0D0
55720 110 CONTINUE
55721 DO 160 I=N+1,N+NP
55722 IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
55723 DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
55724 IF(P(I,4).LE.P(ILF,4)) GOTO 140
55725 DO 120 J=1,5
55726 P(ILF+1,J)=P(ILF,J)
55727 120 CONTINUE
55728 130 CONTINUE
55729 ILF=N+NP+3
55730 140 DO 150 J=1,5
55731 P(ILF+1,J)=P(I,J)
55732 150 CONTINUE
55733 160 CONTINUE
55734
55735C...Find and order initial axes with highest thrust (major).
55736 DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
55737 P(ILG,4)=0D0
55738 170 CONTINUE
55739 NC=2**(MIN(MSTU(44),NP)-1)
55740 DO 250 ILC=1,NC
55741 DO 180 J=1,3
55742 TDI(J)=0D0
55743 180 CONTINUE
55744 DO 200 ILF=1,MIN(MSTU(44),NP)
55745 SGN=P(N+NP+ILF+3,5)
55746 IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
55747 DO 190 J=1,4-ILD
55748 TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
55749 190 CONTINUE
55750 200 CONTINUE
55751 TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
55752 DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
55753 IF(TDS.LE.P(ILG,4)) GOTO 230
55754 DO 210 J=1,4
55755 P(ILG+1,J)=P(ILG,J)
55756 210 CONTINUE
55757 220 CONTINUE
55758 ILG=N+NP+MSTU(44)+4
55759 230 DO 240 J=1,3
55760 P(ILG+1,J)=TDI(J)
55761 240 CONTINUE
55762 P(ILG+1,4)=TDS
55763 250 CONTINUE
55764
55765C...Iterate direction of axis until stable maximum.
55766 P(N+NP+ILD,4)=0D0
55767 ILG=0
55768 260 ILG=ILG+1
55769 THP=0D0
55770 270 THPS=THP
55771 DO 280 J=1,3
55772 IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
55773 IF(THP.GT.1D-10) TDI(J)=TPR(J)
55774 TPR(J)=0D0
55775 280 CONTINUE
55776 DO 300 I=N+1,N+NP
55777 SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
55778 DO 290 J=1,4-ILD
55779 TPR(J)=TPR(J)+SGN*P(I,J)
55780 290 CONTINUE
55781 300 CONTINUE
55782 THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
55783 IF(THP.GE.THPS+PARU(48)) GOTO 270
55784
55785C...Save good axis. Try new initial axis until a number of tries agree.
55786 IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260
55787 IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
55788 IAGR=0
55789 SGN=(-1D0)**INT(PYR(0)+0.5D0)
55790 DO 310 J=1,3
55791 P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
55792 310 CONTINUE
55793 P(N+NP+ILD,4)=THP
55794 P(N+NP+ILD,5)=0D0
55795 ENDIF
55796 IAGR=IAGR+1
55797 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
55798 320 CONTINUE
55799
55800C...Find minor axis and value by orthogonality.
55801 SGN=(-1D0)**INT(PYR(0)+0.5D0)
55802 P(N+NP+3,1)=-SGN*P(N+NP+2,2)
55803 P(N+NP+3,2)=SGN*P(N+NP+2,1)
55804 P(N+NP+3,3)=0D0
55805 THP=0D0
55806 DO 330 I=N+1,N+NP
55807 THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
55808 330 CONTINUE
55809 P(N+NP+3,4)=THP/PS
55810 P(N+NP+3,5)=0D0
55811
55812C...Fill axis information. Rotate back to original coordinate system.
55813 DO 350 ILD=1,3
55814 K(N+ILD,1)=31
55815 K(N+ILD,2)=96
55816 K(N+ILD,3)=ILD
55817 K(N+ILD,4)=0
55818 K(N+ILD,5)=0
55819 DO 340 J=1,5
55820 P(N+ILD,J)=P(N+NP+ILD,J)
55821 V(N+ILD,J)=0D0
55822 340 CONTINUE
55823 350 CONTINUE
55824 CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0)
55825
55826C...Calculate thrust and oblateness. Select storing option.
55827 THR=P(N+1,4)
55828 OBL=P(N+2,4)-P(N+3,4)
55829 MSTU(61)=N+1
55830 MSTU(62)=NP
55831 IF(MSTU(43).LE.1) MSTU(3)=3
55832 IF(MSTU(43).GE.2) N=N+3
55833
55834 RETURN
55835 END
55836
55837C*********************************************************************
55838
55839C...PYCLUS
55840C...Subdivides the particle content of an event into jets/clusters.
55841
55842 SUBROUTINE PYCLUS(NJET)
55843
55844C...Double precision and integer declarations.
55845 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55846 IMPLICIT INTEGER(I-N)
55847 INTEGER PYK,PYCHGE,PYCOMP
55848C...Commonblocks.
55849 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
55850 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55851 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55852 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
55853C...Local arrays and saved variables.
55854 DIMENSION PS(5)
55855 SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
55856
55857C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
55858 R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
55859 &P(I1,3)*P(I2,3))*2D0*P(I1,5)*P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2
55860 R2M(I1,I2)=2D0*P(I1,4)*P(I2,4)*(1D0-(P(I1,1)*P(I2,1)+P(I1,2)*
55861 &P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
55862 R2D(I1,I2)=2D0*MIN(P(I1,4),P(I2,4))**2*(1D0-(P(I1,1)*P(I2,1)+
55863 &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
55864
55865C...If first time, reset. If reentering, skip preliminaries.
55866 IF(MSTU(48).LE.0) THEN
55867 NP=0
55868 DO 100 J=1,5
55869 PS(J)=0D0
55870 100 CONTINUE
55871 PSS=0D0
55872 PIMASS=PMAS(PYCOMP(211),1)
55873 ELSE
55874 NJET=NSAV
55875 IF(MSTU(43).GE.2) N=N-NJET
55876 DO 110 I=N+1,N+NJET
55877 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
55878 110 CONTINUE
55879 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
55880 R2ACC=PARU(44)**2
55881 ELSE
55882 R2ACC=PARU(45)*PS(5)**2
55883 ENDIF
55884 NLOOP=0
55885 GOTO 300
55886 ENDIF
55887
55888C...Find which particles are to be considered in cluster search.
55889 DO 140 I=1,N
55890 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
55891 IF(MSTU(41).GE.2) THEN
55892 KC=PYCOMP(K(I,2))
55893 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
55894 & KC.EQ.18) GOTO 140
55895 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
55896 & GOTO 140
55897 ENDIF
55898 IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
55899 CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS')
55900 NJET=-1
55901 RETURN
55902 ENDIF
55903
55904C...Take copy of these particles, with space left for jets later on.
55905 NP=NP+1
55906 K(N+NP,3)=I
55907 DO 120 J=1,5
55908 P(N+NP,J)=P(I,J)
55909 120 CONTINUE
55910 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
55911 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
55912 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
55913 P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
55914 DO 130 J=1,4
55915 PS(J)=PS(J)+P(N+NP,J)
55916 130 CONTINUE
55917 PSS=PSS+P(N+NP,5)
55918 140 CONTINUE
55919 DO 160 I=N+1,N+NP
55920 K(I+NP,3)=K(I,3)
55921 DO 150 J=1,5
55922 P(I+NP,J)=P(I,J)
55923 150 CONTINUE
55924 160 CONTINUE
55925 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
55926
55927C...Very low multiplicities not considered.
55928 IF(NP.LT.MSTU(47)) THEN
55929 CALL PYERRM(8,'(PYCLUS:) too few particles for analysis')
55930 NJET=-1
55931 RETURN
55932 ENDIF
55933
55934C...Find precluster configuration. If too few jets, make harder cuts.
55935 NLOOP=0
55936 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
55937 R2ACC=PARU(44)**2
55938 ELSE
55939 R2ACC=PARU(45)*PS(5)**2
55940 ENDIF
55941 RINIT=1.25D0*PARU(43)
55942 IF(NP.LE.MSTU(47)+2) RINIT=0D0
55943 170 RINIT=0.8D0*RINIT
55944 NPRE=0
55945 NREM=NP
55946 DO 180 I=N+NP+1,N+2*NP
55947 K(I,4)=0
55948 180 CONTINUE
55949
55950C...Sum up small momentum region. Jet if enough absolute momentum.
55951 IF(MSTU(46).LE.2) THEN
55952 DO 190 J=1,4
55953 P(N+1,J)=0D0
55954 190 CONTINUE
55955 DO 210 I=N+NP+1,N+2*NP
55956 IF(P(I,5).GT.2D0*RINIT) GOTO 210
55957 NREM=NREM-1
55958 K(I,4)=1
55959 DO 200 J=1,4
55960 P(N+1,J)=P(N+1,J)+P(I,J)
55961 200 CONTINUE
55962 210 CONTINUE
55963 P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
55964 IF(P(N+1,5).GT.2D0*RINIT) NPRE=1
55965 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
55966 IF(NREM.EQ.0) GOTO 170
55967 ENDIF
55968
55969C...Find fastest remaining particle.
55970 220 NPRE=NPRE+1
55971 PMAX=0D0
55972 DO 230 I=N+NP+1,N+2*NP
55973 IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230
55974 IMAX=I
55975 PMAX=P(I,5)
55976 230 CONTINUE
55977 DO 240 J=1,5
55978 P(N+NPRE,J)=P(IMAX,J)
55979 240 CONTINUE
55980 NREM=NREM-1
55981 K(IMAX,4)=NPRE
55982
55983C...Sum up precluster around it according to pT separation.
55984 IF(MSTU(46).LE.2) THEN
55985 DO 260 I=N+NP+1,N+2*NP
55986 IF(K(I,4).NE.0) GOTO 260
55987 R2=R2T(I,IMAX)
55988 IF(R2.GT.RINIT**2) GOTO 260
55989 NREM=NREM-1
55990 K(I,4)=NPRE
55991 DO 250 J=1,4
55992 P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
55993 250 CONTINUE
55994 260 CONTINUE
55995 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
55996
55997C...Sum up precluster around it according to mass or
55998C...Durham pT separation.
55999 ELSE
56000 270 IMIN=0
56001 R2MIN=RINIT**2
56002 DO 280 I=N+NP+1,N+2*NP
56003 IF(K(I,4).NE.0) GOTO 280
56004 IF(MSTU(46).LE.4) THEN
56005 R2=R2M(I,N+NPRE)
56006 ELSE
56007 R2=R2D(I,N+NPRE)
56008 ENDIF
56009 IF(R2.GE.R2MIN) GOTO 280
56010 IMIN=I
56011 R2MIN=R2
56012 280 CONTINUE
56013 IF(IMIN.NE.0) THEN
56014 DO 290 J=1,4
56015 P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
56016 290 CONTINUE
56017 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
56018 NREM=NREM-1
56019 K(IMIN,4)=NPRE
56020 GOTO 270
56021 ENDIF
56022 ENDIF
56023
56024C...Check if more preclusters to be found. Start over if too few.
56025 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
56026 IF(NREM.GT.0) GOTO 220
56027 NJET=NPRE
56028
56029C...Reassign all particles to nearest jet. Sum up new jet momenta.
56030 300 TSAV=0D0
56031 PSJT=0D0
56032 310 IF(MSTU(46).LE.1) THEN
56033 DO 330 I=N+1,N+NJET
56034 DO 320 J=1,4
56035 V(I,J)=0D0
56036 320 CONTINUE
56037 330 CONTINUE
56038 DO 360 I=N+NP+1,N+2*NP
56039 R2MIN=PSS**2
56040 DO 340 IJET=N+1,N+NJET
56041 IF(P(IJET,5).LT.RINIT) GOTO 340
56042 R2=R2T(I,IJET)
56043 IF(R2.GE.R2MIN) GOTO 340
56044 IMIN=IJET
56045 R2MIN=R2
56046 340 CONTINUE
56047 K(I,4)=IMIN-N
56048 DO 350 J=1,4
56049 V(IMIN,J)=V(IMIN,J)+P(I,J)
56050 350 CONTINUE
56051 360 CONTINUE
56052 PSJT=0D0
56053 DO 380 I=N+1,N+NJET
56054 DO 370 J=1,4
56055 P(I,J)=V(I,J)
56056 370 CONTINUE
56057 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
56058 PSJT=PSJT+P(I,5)
56059 380 CONTINUE
56060 ENDIF
56061
56062C...Find two closest jets.
56063 R2MIN=2D0*MAX(R2ACC,PS(5)**2)
56064 DO 400 ITRY1=N+1,N+NJET-1
56065 DO 390 ITRY2=ITRY1+1,N+NJET
56066 IF(MSTU(46).LE.2) THEN
56067 R2=R2T(ITRY1,ITRY2)
56068 ELSEIF(MSTU(46).LE.4) THEN
56069 R2=R2M(ITRY1,ITRY2)
56070 ELSE
56071 R2=R2D(ITRY1,ITRY2)
56072 ENDIF
56073 IF(R2.GE.R2MIN) GOTO 390
56074 IMIN1=ITRY1
56075 IMIN2=ITRY2
56076 R2MIN=R2
56077 390 CONTINUE
56078 400 CONTINUE
56079
56080C...If allowed, join two closest jets and start over.
56081 IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
56082 IREC=MIN(IMIN1,IMIN2)
56083 IDEL=MAX(IMIN1,IMIN2)
56084 DO 410 J=1,4
56085 P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
56086 410 CONTINUE
56087 P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
56088 DO 430 I=IDEL+1,N+NJET
56089 DO 420 J=1,5
56090 P(I-1,J)=P(I,J)
56091 420 CONTINUE
56092 430 CONTINUE
56093 IF(MSTU(46).GE.2) THEN
56094 DO 440 I=N+NP+1,N+2*NP
56095 IORI=N+K(I,4)
56096 IF(IORI.EQ.IDEL) K(I,4)=IREC-N
56097 IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
56098 440 CONTINUE
56099 ENDIF
56100 NJET=NJET-1
56101 GOTO 300
56102
56103C...Divide up broad jet if empty cluster in list of final ones.
56104 ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
56105 DO 450 I=N+1,N+NJET
56106 K(I,5)=0
56107 450 CONTINUE
56108 DO 460 I=N+NP+1,N+2*NP
56109 K(N+K(I,4),5)=K(N+K(I,4),5)+1
56110 460 CONTINUE
56111 IEMP=0
56112 DO 470 I=N+1,N+NJET
56113 IF(K(I,5).EQ.0) IEMP=I
56114 470 CONTINUE
56115 IF(IEMP.NE.0) THEN
56116 NLOOP=NLOOP+1
56117 ISPL=0
56118 R2MAX=0D0
56119 DO 480 I=N+NP+1,N+2*NP
56120 IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
56121 IJET=N+K(I,4)
56122 R2=R2T(I,IJET)
56123 IF(R2.LE.R2MAX) GOTO 480
56124 ISPL=I
56125 R2MAX=R2
56126 480 CONTINUE
56127 IF(ISPL.NE.0) THEN
56128 IJET=N+K(ISPL,4)
56129 DO 490 J=1,4
56130 P(IEMP,J)=P(ISPL,J)
56131 P(IJET,J)=P(IJET,J)-P(ISPL,J)
56132 490 CONTINUE
56133 P(IEMP,5)=P(ISPL,5)
56134 P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
56135 IF(NLOOP.LE.2) GOTO 300
56136 ENDIF
56137 ENDIF
56138 ENDIF
56139
56140C...If generalized thrust has not yet converged, continue iteration.
56141 IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
56142 &THEN
56143 TSAV=PSJT/PSS
56144 GOTO 310
56145 ENDIF
56146
56147C...Reorder jets according to energy.
56148 DO 510 I=N+1,N+NJET
56149 DO 500 J=1,5
56150 V(I,J)=P(I,J)
56151 500 CONTINUE
56152 510 CONTINUE
56153 DO 540 INEW=N+1,N+NJET
56154 PEMAX=0D0
56155 DO 520 ITRY=N+1,N+NJET
56156 IF(V(ITRY,4).LE.PEMAX) GOTO 520
56157 IMAX=ITRY
56158 PEMAX=V(ITRY,4)
56159 520 CONTINUE
56160 K(INEW,1)=31
56161 K(INEW,2)=97
56162 K(INEW,3)=INEW-N
56163 K(INEW,4)=0
56164 DO 530 J=1,5
56165 P(INEW,J)=V(IMAX,J)
56166 530 CONTINUE
56167 V(IMAX,4)=-1D0
56168 K(IMAX,5)=INEW
56169 540 CONTINUE
56170
56171C...Clean up particle-jet assignments and jet information.
56172 DO 550 I=N+NP+1,N+2*NP
56173 IORI=K(N+K(I,4),5)
56174 K(I,4)=IORI-N
56175 IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
56176 K(IORI,4)=K(IORI,4)+1
56177 550 CONTINUE
56178 IEMP=0
56179 PSJT=0D0
56180 DO 570 I=N+1,N+NJET
56181 K(I,5)=0
56182 PSJT=PSJT+P(I,5)
56183 P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0))
56184 DO 560 J=1,5
56185 V(I,J)=0D0
56186 560 CONTINUE
56187 IF(K(I,4).EQ.0) IEMP=I
56188 570 CONTINUE
56189
56190C...Select storing option. Output variables. Check for failure.
56191 MSTU(61)=N+1
56192 MSTU(62)=NP
56193 MSTU(63)=NPRE
56194 PARU(61)=PS(5)
56195 PARU(62)=PSJT/PSS
56196 PARU(63)=SQRT(R2MIN)
56197 IF(NJET.LE.1) PARU(63)=0D0
56198 IF(IEMP.NE.0) THEN
56199 CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested')
56200 NJET=-1
56201 RETURN
56202 ENDIF
56203 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
56204 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
56205 NSAV=NJET
56206
56207 RETURN
56208 END
56209
56210C*********************************************************************
56211
56212C...PYCELL
56213C...Provides a simple way of jet finding in eta-phi-ET coordinates,
56214C...as used for calorimeters at hadron colliders.
56215
56216 SUBROUTINE PYCELL(NJET)
56217
56218C...Double precision and integer declarations.
56219 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56220 IMPLICIT INTEGER(I-N)
56221 INTEGER PYK,PYCHGE,PYCOMP
56222C...Commonblocks.
56223 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56224 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56225 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56226 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
56227
56228C...Loop over all particles. Find cell that was hit by given particle.
56229 PTLRAT=1D0/SINH(PARU(51))**2
56230 NP=0
56231 NC=N
56232 DO 110 I=1,N
56233 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
56234 IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
56235 IF(MSTU(41).GE.2) THEN
56236 KC=PYCOMP(K(I,2))
56237 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
56238 & KC.EQ.18) GOTO 110
56239 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
56240 & GOTO 110
56241 ENDIF
56242 NP=NP+1
56243 PT=SQRT(P(I,1)**2+P(I,2)**2)
56244 ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
56245 IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0*
56246 & (ETA/PARU(51)+1D0))))
56247 PHI=PYANGL(P(I,1),P(I,2))
56248 IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0*
56249 & (PHI/PARU(1)+1D0))))
56250 IETPH=MSTU(52)*IETA+IPHI
56251
56252C...Add to cell already hit, or book new cell.
56253 DO 100 IC=N+1,NC
56254 IF(IETPH.EQ.K(IC,3)) THEN
56255 K(IC,4)=K(IC,4)+1
56256 P(IC,5)=P(IC,5)+PT
56257 GOTO 110
56258 ENDIF
56259 100 CONTINUE
56260 IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
56261 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
56262 NJET=-2
56263 RETURN
56264 ENDIF
56265 NC=NC+1
56266 K(NC,3)=IETPH
56267 K(NC,4)=1
56268 K(NC,5)=2
56269 P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
56270 P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
56271 P(NC,5)=PT
56272 110 CONTINUE
56273
56274C...Smear true bin content by calorimeter resolution.
56275 IF(MSTU(53).GE.1) THEN
56276 DO 130 IC=N+1,NC
56277 PEI=P(IC,5)
56278 IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1))
56279 120 PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)*
56280 & COS(PARU(2)*PYR(0))
56281 IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120
56282 P(IC,5)=PEF
56283 IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
56284 130 CONTINUE
56285 ENDIF
56286
56287C...Remove cells below threshold.
56288 IF(PARU(58).GT.0D0) THEN
56289 NCC=NC
56290 NC=N
56291 DO 140 IC=N+1,NCC
56292 IF(P(IC,5).GT.PARU(58)) THEN
56293 NC=NC+1
56294 K(NC,3)=K(IC,3)
56295 K(NC,4)=K(IC,4)
56296 K(NC,5)=K(IC,5)
56297 P(NC,1)=P(IC,1)
56298 P(NC,2)=P(IC,2)
56299 P(NC,5)=P(IC,5)
56300 ENDIF
56301 140 CONTINUE
56302 ENDIF
56303
56304C...Find initiator cell: the one with highest pT of not yet used ones.
56305 NJ=NC
56306 150 ETMAX=0D0
56307 DO 160 IC=N+1,NC
56308 IF(K(IC,5).NE.2) GOTO 160
56309 IF(P(IC,5).LE.ETMAX) GOTO 160
56310 ICMAX=IC
56311 ETA=P(IC,1)
56312 PHI=P(IC,2)
56313 ETMAX=P(IC,5)
56314 160 CONTINUE
56315 IF(ETMAX.LT.PARU(52)) GOTO 220
56316 IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
56317 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
56318 NJET=-2
56319 RETURN
56320 ENDIF
56321 K(ICMAX,5)=1
56322 NJ=NJ+1
56323 K(NJ,4)=0
56324 K(NJ,5)=1
56325 P(NJ,1)=ETA
56326 P(NJ,2)=PHI
56327 P(NJ,3)=0D0
56328 P(NJ,4)=0D0
56329 P(NJ,5)=0D0
56330
56331C...Sum up unused cells within required distance of initiator.
56332 DO 170 IC=N+1,NC
56333 IF(K(IC,5).EQ.0) GOTO 170
56334 IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
56335 DPHIA=ABS(P(IC,2)-PHI)
56336 IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
56337 PHIC=P(IC,2)
56338 IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
56339 IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170
56340 K(IC,5)=-K(IC,5)
56341 K(NJ,4)=K(NJ,4)+K(IC,4)
56342 P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
56343 P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
56344 P(NJ,5)=P(NJ,5)+P(IC,5)
56345 170 CONTINUE
56346
56347C...Reject cluster below minimum ET, else accept.
56348 IF(P(NJ,5).LT.PARU(53)) THEN
56349 NJ=NJ-1
56350 DO 180 IC=N+1,NC
56351 IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
56352 180 CONTINUE
56353 ELSEIF(MSTU(54).LE.2) THEN
56354 P(NJ,3)=P(NJ,3)/P(NJ,5)
56355 P(NJ,4)=P(NJ,4)/P(NJ,5)
56356 IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
56357 & P(NJ,4))
56358 DO 190 IC=N+1,NC
56359 IF(K(IC,5).LT.0) K(IC,5)=0
56360 190 CONTINUE
56361 ELSE
56362 DO 200 J=1,4
56363 P(NJ,J)=0D0
56364 200 CONTINUE
56365 DO 210 IC=N+1,NC
56366 IF(K(IC,5).GE.0) GOTO 210
56367 P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
56368 P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
56369 P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
56370 P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
56371 K(IC,5)=0
56372 210 CONTINUE
56373 ENDIF
56374 GOTO 150
56375
56376C...Arrange clusters in falling ET sequence.
56377 220 DO 250 I=1,NJ-NC
56378 ETMAX=0D0
56379 DO 230 IJ=NC+1,NJ
56380 IF(K(IJ,5).EQ.0) GOTO 230
56381 IF(P(IJ,5).LT.ETMAX) GOTO 230
56382 IJMAX=IJ
56383 ETMAX=P(IJ,5)
56384 230 CONTINUE
56385 K(IJMAX,5)=0
56386 K(N+I,1)=31
56387 K(N+I,2)=98
56388 K(N+I,3)=I
56389 K(N+I,4)=K(IJMAX,4)
56390 K(N+I,5)=0
56391 DO 240 J=1,5
56392 P(N+I,J)=P(IJMAX,J)
56393 V(N+I,J)=0D0
56394 240 CONTINUE
56395 250 CONTINUE
56396 NJET=NJ-NC
56397
56398C...Convert to massless or massive four-vectors.
56399 IF(MSTU(54).EQ.2) THEN
56400 DO 260 I=N+1,N+NJET
56401 ETA=P(I,3)
56402 P(I,1)=P(I,5)*COS(P(I,4))
56403 P(I,2)=P(I,5)*SIN(P(I,4))
56404 P(I,3)=P(I,5)*SINH(ETA)
56405 P(I,4)=P(I,5)*COSH(ETA)
56406 P(I,5)=0D0
56407 260 CONTINUE
56408 ELSEIF(MSTU(54).GE.3) THEN
56409 DO 270 I=N+1,N+NJET
56410 P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
56411 270 CONTINUE
56412 ENDIF
56413
56414C...Information about storage.
56415 MSTU(61)=N+1
56416 MSTU(62)=NP
56417 MSTU(63)=NC-N
56418 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
56419 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
56420
56421 RETURN
56422 END
56423
56424C*********************************************************************
56425
56426C...PYJMAS
56427C...Determines, approximately, the two jet masses that minimize
56428C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
56429
56430 SUBROUTINE PYJMAS(PMH,PML)
56431
56432C...Double precision and integer declarations.
56433 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56434 IMPLICIT INTEGER(I-N)
56435 INTEGER PYK,PYCHGE,PYCOMP
56436C...Commonblocks.
56437 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56438 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56439 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56440 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
56441C...Local arrays.
56442 DIMENSION SM(3,3),SAX(3),PS(3,5)
56443
56444C...Reset.
56445 NP=0
56446 DO 120 J1=1,3
56447 DO 100 J2=J1,3
56448 SM(J1,J2)=0D0
56449 100 CONTINUE
56450 DO 110 J2=1,4
56451 PS(J1,J2)=0D0
56452 110 CONTINUE
56453 120 CONTINUE
56454 PSS=0D0
56455 PIMASS=PMAS(PYCOMP(211),1)
56456
56457C...Take copy of particles that are to be considered in mass analysis.
56458 DO 170 I=1,N
56459 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
56460 IF(MSTU(41).GE.2) THEN
56461 KC=PYCOMP(K(I,2))
56462 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
56463 & KC.EQ.18) GOTO 170
56464 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
56465 & GOTO 170
56466 ENDIF
56467 IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
56468 CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS')
56469 PMH=-2D0
56470 PML=-2D0
56471 RETURN
56472 ENDIF
56473 NP=NP+1
56474 DO 130 J=1,5
56475 P(N+NP,J)=P(I,J)
56476 130 CONTINUE
56477 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
56478 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
56479 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
56480
56481C...Fill information in sphericity tensor and total momentum vector.
56482 DO 150 J1=1,3
56483 DO 140 J2=J1,3
56484 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
56485 140 CONTINUE
56486 150 CONTINUE
56487 PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
56488 DO 160 J=1,4
56489 PS(3,J)=PS(3,J)+P(N+NP,J)
56490 160 CONTINUE
56491 170 CONTINUE
56492
56493C...Very low multiplicities (0 or 1) not considered.
56494 IF(NP.LE.1) THEN
56495 CALL PYERRM(8,'(PYJMAS:) too few particles for analysis')
56496 PMH=-1D0
56497 PML=-1D0
56498 RETURN
56499 ENDIF
56500 PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-
56501 &PS(3,3)**2))
56502
56503C...Find largest eigenvalue to matrix (third degree equation).
56504 DO 190 J1=1,3
56505 DO 180 J2=J1,3
56506 SM(J1,J2)=SM(J1,J2)/PSS
56507 180 CONTINUE
56508 190 CONTINUE
56509 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
56510 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
56511 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
56512 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
56513 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
56514 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
56515 SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
56516
56517C...Find largest eigenvector by solving equation system.
56518 DO 210 J1=1,3
56519 SM(J1,J1)=SM(J1,J1)-SMA
56520 DO 200 J2=J1+1,3
56521 SM(J2,J1)=SM(J1,J2)
56522 200 CONTINUE
56523 210 CONTINUE
56524 SMAX=0D0
56525 DO 230 J1=1,3
56526 DO 220 J2=1,3
56527 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
56528 JA=J1
56529 JB=J2
56530 SMAX=ABS(SM(J1,J2))
56531 220 CONTINUE
56532 230 CONTINUE
56533 SMAX=0D0
56534 DO 250 J3=JA+1,JA+2
56535 J1=J3-3*((J3-1)/3)
56536 RL=SM(J1,JB)/SM(JA,JB)
56537 DO 240 J2=1,3
56538 SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
56539 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
56540 JC=J1
56541 SMAX=ABS(SM(J1,J2))
56542 240 CONTINUE
56543 250 CONTINUE
56544 JB1=JB+1-3*(JB/3)
56545 JB2=JB+2-3*((JB+1)/3)
56546 SAX(JB1)=-SM(JC,JB2)
56547 SAX(JB2)=SM(JC,JB1)
56548 SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
56549
56550C...Divide particles into two initial clusters by hemisphere.
56551 DO 270 I=N+1,N+NP
56552 PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
56553 IS=1
56554 IF(PSAX.LT.0D0) IS=2
56555 K(I,3)=IS
56556 DO 260 J=1,4
56557 PS(IS,J)=PS(IS,J)+P(I,J)
56558 260 CONTINUE
56559 270 CONTINUE
56560 PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
56561 &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
56562
56563C...Reassign one particle at a time; find maximum decrease of m^2 sum.
56564 280 PMD=0D0
56565 IM=0
56566 DO 290 J=1,4
56567 PS(3,J)=PS(1,J)-PS(2,J)
56568 290 CONTINUE
56569 DO 300 I=N+1,N+NP
56570 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)
56571 IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS)
56572 IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS)
56573 IF(PMDI.LT.PMD) THEN
56574 PMD=PMDI
56575 IM=I
56576 ENDIF
56577 300 CONTINUE
56578
56579C...Loop back if significant reduction in sum of m^2.
56580 IF(PMD.LT.-PARU(48)*PMS) THEN
56581 PMS=PMS+PMD
56582 IS=K(IM,3)
56583 DO 310 J=1,4
56584 PS(IS,J)=PS(IS,J)-P(IM,J)
56585 PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
56586 310 CONTINUE
56587 K(IM,3)=3-IS
56588 GOTO 280
56589 ENDIF
56590
56591C...Final masses and output.
56592 MSTU(61)=N+1
56593 MSTU(62)=NP
56594 PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
56595 PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
56596 PMH=MAX(PS(1,5),PS(2,5))
56597 PML=MIN(PS(1,5),PS(2,5))
56598
56599 RETURN
56600 END
56601
56602C*********************************************************************
56603
56604C...PYFOWO
56605C...Calculates the first few Fox-Wolfram moments.
56606
56607 SUBROUTINE PYFOWO(H10,H20,H30,H40)
56608
56609C...Double precision and integer declarations.
56610 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56611 IMPLICIT INTEGER(I-N)
56612 INTEGER PYK,PYCHGE,PYCOMP
56613C...Commonblocks.
56614 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56615 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56616 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56617 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
56618
56619C...Copy momenta for particles and calculate H0.
56620 NP=0
56621 H0=0D0
56622 HD=0D0
56623 DO 110 I=1,N
56624 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
56625 IF(MSTU(41).GE.2) THEN
56626 KC=PYCOMP(K(I,2))
56627 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
56628 & KC.EQ.18) GOTO 110
56629 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
56630 & GOTO 110
56631 ENDIF
56632 IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
56633 CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS')
56634 H10=-1D0
56635 H20=-1D0
56636 H30=-1D0
56637 H40=-1D0
56638 RETURN
56639 ENDIF
56640 NP=NP+1
56641 DO 100 J=1,3
56642 P(N+NP,J)=P(I,J)
56643 100 CONTINUE
56644 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
56645 H0=H0+P(N+NP,4)
56646 HD=HD+P(N+NP,4)**2
56647 110 CONTINUE
56648 H0=H0**2
56649
56650C...Very low multiplicities (0 or 1) not considered.
56651 IF(NP.LE.1) THEN
56652 CALL PYERRM(8,'(PYFOWO:) too few particles for analysis')
56653 H10=-1D0
56654 H20=-1D0
56655 H30=-1D0
56656 H40=-1D0
56657 RETURN
56658 ENDIF
56659
56660C...Calculate H1 - H4.
56661 H10=0D0
56662 H20=0D0
56663 H30=0D0
56664 H40=0D0
56665 DO 130 I1=N+1,N+NP
56666 DO 120 I2=I1+1,N+NP
56667 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
56668 & (P(I1,4)*P(I2,4))
56669 H10=H10+P(I1,4)*P(I2,4)*CTHE
56670 H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0)
56671 H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE)
56672 H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+
56673 & 0.375D0)
56674 120 CONTINUE
56675 130 CONTINUE
56676
56677C...Calculate H1/H0 - H4/H0. Output.
56678 MSTU(61)=N+1
56679 MSTU(62)=NP
56680 H10=(HD+2D0*H10)/H0
56681 H20=(HD+2D0*H20)/H0
56682 H30=(HD+2D0*H30)/H0
56683 H40=(HD+2D0*H40)/H0
56684
56685 RETURN
56686 END
56687
56688C*********************************************************************
56689
56690C...PYTABU
56691C...Evaluates various properties of an event, with statistics
56692C...accumulated during the course of the run and
56693C...printed at the end.
56694
56695 SUBROUTINE PYTABU(MTABU)
56696
56697C...Double precision and integer declarations.
56698 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56699 IMPLICIT INTEGER(I-N)
56700 INTEGER PYK,PYCHGE,PYCOMP
56701C...Commonblocks.
56702 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56703 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56704 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56705 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
56706 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
56707C...Local arrays, character variables, saved variables and data.
56708 DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
56709 &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
56710 &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
56711 &KFDM(8),KFDC(200,0:8),NPDC(200)
56712 SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
56713 &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
56714 &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
56715 CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
56716 DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
56717 &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/,
56718 &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/,
56719 &NEVDC/0/,NKFDC/0/,NREDC/0/
56720
56721C...Reset statistics on initial parton state.
56722 IF(MTABU.EQ.10) THEN
56723 NEVIS=0
56724 NKFIS=0
56725
56726C...Identify and order flavour content of initial state.
56727 ELSEIF(MTABU.EQ.11) THEN
56728 NEVIS=NEVIS+1
56729 KFM1=2*IABS(MSTU(161))
56730 IF(MSTU(161).GT.0) KFM1=KFM1-1
56731 KFM2=2*IABS(MSTU(162))
56732 IF(MSTU(162).GT.0) KFM2=KFM2-1
56733 KFMN=MIN(KFM1,KFM2)
56734 KFMX=MAX(KFM1,KFM2)
56735 DO 100 I=1,NKFIS
56736 IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
56737 IKFIS=-I
56738 GOTO 110
56739 ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
56740 & KFMX.LT.KFIS(I,2))) THEN
56741 IKFIS=I
56742 GOTO 110
56743 ENDIF
56744 100 CONTINUE
56745 IKFIS=NKFIS+1
56746 110 IF(IKFIS.LT.0) THEN
56747 IKFIS=-IKFIS
56748 ELSE
56749 IF(NKFIS.GE.100) RETURN
56750 DO 130 I=NKFIS,IKFIS,-1
56751 KFIS(I+1,1)=KFIS(I,1)
56752 KFIS(I+1,2)=KFIS(I,2)
56753 DO 120 J=0,10
56754 NPIS(I+1,J)=NPIS(I,J)
56755 120 CONTINUE
56756 130 CONTINUE
56757 NKFIS=NKFIS+1
56758 KFIS(IKFIS,1)=KFMN
56759 KFIS(IKFIS,2)=KFMX
56760 DO 140 J=0,10
56761 NPIS(IKFIS,J)=0
56762 140 CONTINUE
56763 ENDIF
56764 NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
56765
56766C...Count number of partons in initial state.
56767 NP=0
56768 DO 160 I=1,N
56769 IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
56770 ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
56771 ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
56772 & THEN
56773 ELSE
56774 IM=I
56775 150 IM=K(IM,3)
56776 IF(IM.LE.0.OR.IM.GT.N) THEN
56777 NP=NP+1
56778 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
56779 NP=NP+1
56780 ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
56781 ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10)
56782 & .NE.0) THEN
56783 ELSE
56784 GOTO 150
56785 ENDIF
56786 ENDIF
56787 160 CONTINUE
56788 NPCO=MAX(NP,1)
56789 IF(NP.GE.6) NPCO=6
56790 IF(NP.GE.8) NPCO=7
56791 IF(NP.GE.11) NPCO=8
56792 IF(NP.GE.16) NPCO=9
56793 IF(NP.GE.26) NPCO=10
56794 NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
56795 MSTU(62)=NP
56796
56797C...Write statistics on initial parton state.
56798 ELSEIF(MTABU.EQ.12) THEN
56799 FAC=1D0/MAX(1,NEVIS)
56800 WRITE(MSTU(11),5000) NEVIS
56801 DO 170 I=1,NKFIS
56802 KFMN=KFIS(I,1)
56803 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
56804 KFM1=(KFMN+1)/2
56805 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
56806 CALL PYNAME(KFM1,CHAU)
56807 CHIS(1)=CHAU(1:12)
56808 IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
56809 KFMX=KFIS(I,2)
56810 IF(KFIS(I,1).EQ.0) KFMX=0
56811 KFM2=(KFMX+1)/2
56812 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
56813 CALL PYNAME(KFM2,CHAU)
56814 CHIS(2)=CHAU(1:12)
56815 IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
56816 WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
56817 & (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10)
56818 170 CONTINUE
56819
56820C...Copy statistics on initial parton state into /PYJETS/.
56821 ELSEIF(MTABU.EQ.13) THEN
56822 FAC=1D0/MAX(1,NEVIS)
56823 DO 190 I=1,NKFIS
56824 KFMN=KFIS(I,1)
56825 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
56826 KFM1=(KFMN+1)/2
56827 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
56828 KFMX=KFIS(I,2)
56829 IF(KFIS(I,1).EQ.0) KFMX=0
56830 KFM2=(KFMX+1)/2
56831 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
56832 K(I,1)=32
56833 K(I,2)=99
56834 K(I,3)=KFM1
56835 K(I,4)=KFM2
56836 K(I,5)=NPIS(I,0)
56837 DO 180 J=1,5
56838 P(I,J)=FAC*NPIS(I,J)
56839 V(I,J)=FAC*NPIS(I,J+5)
56840 180 CONTINUE
56841 190 CONTINUE
56842 N=NKFIS
56843 DO 200 J=1,5
56844 K(N+1,J)=0
56845 P(N+1,J)=0D0
56846 V(N+1,J)=0D0
56847 200 CONTINUE
56848 K(N+1,1)=32
56849 K(N+1,2)=99
56850 K(N+1,5)=NEVIS
56851 MSTU(3)=1
56852
56853C...Reset statistics on number of particles/partons.
56854 ELSEIF(MTABU.EQ.20) THEN
56855 NEVFS=0
56856 NPRFS=0
56857 NFIFS=0
56858 NCHFS=0
56859 NKFFS=0
56860
56861C...Identify whether particle/parton is primary or not.
56862 ELSEIF(MTABU.EQ.21) THEN
56863 NEVFS=NEVFS+1
56864 MSTU(62)=0
56865 DO 260 I=1,N
56866 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260
56867 MSTU(62)=MSTU(62)+1
56868 KC=PYCOMP(K(I,2))
56869 MPRI=0
56870 IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
56871 MPRI=1
56872 ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
56873 MPRI=1
56874 ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
56875 MPRI=1
56876 ELSEIF(KC.EQ.0) THEN
56877 ELSEIF(K(K(I,3),1).EQ.13) THEN
56878 IM=K(K(I,3),3)
56879 IF(IM.LE.0.OR.IM.GT.N) THEN
56880 MPRI=1
56881 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
56882 MPRI=1
56883 ENDIF
56884 ELSEIF(KCHG(KC,2).EQ.0) THEN
56885 KCM=PYCOMP(K(K(I,3),2))
56886 IF(KCM.NE.0) THEN
56887 IF(KCHG(KCM,2).NE.0) MPRI=1
56888 ENDIF
56889 ENDIF
56890 IF(KC.NE.0.AND.MPRI.EQ.1) THEN
56891 IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
56892 ENDIF
56893 IF(K(I,1).LE.10) THEN
56894 NFIFS=NFIFS+1
56895 IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
56896 ENDIF
56897
56898C...Fill statistics on number of particles/partons in event.
56899 KFA=IABS(K(I,2))
56900 KFS=3-ISIGN(1,K(I,2))-MPRI
56901 DO 210 IP=1,NKFFS
56902 IF(KFA.EQ.KFFS(IP)) THEN
56903 IKFFS=-IP
56904 GOTO 220
56905 ELSEIF(KFA.LT.KFFS(IP)) THEN
56906 IKFFS=IP
56907 GOTO 220
56908 ENDIF
56909 210 CONTINUE
56910 IKFFS=NKFFS+1
56911 220 IF(IKFFS.LT.0) THEN
56912 IKFFS=-IKFFS
56913 ELSE
56914 IF(NKFFS.GE.400) RETURN
56915 DO 240 IP=NKFFS,IKFFS,-1
56916 KFFS(IP+1)=KFFS(IP)
56917 DO 230 J=1,4
56918 NPFS(IP+1,J)=NPFS(IP,J)
56919 230 CONTINUE
56920 240 CONTINUE
56921 NKFFS=NKFFS+1
56922 KFFS(IKFFS)=KFA
56923 DO 250 J=1,4
56924 NPFS(IKFFS,J)=0
56925 250 CONTINUE
56926 ENDIF
56927 NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
56928 260 CONTINUE
56929
56930C...Write statistics on particle/parton composition of events.
56931 ELSEIF(MTABU.EQ.22) THEN
56932 FAC=1D0/MAX(1,NEVFS)
56933 WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
56934 DO 270 I=1,NKFFS
56935 CALL PYNAME(KFFS(I),CHAU)
56936 KC=PYCOMP(KFFS(I))
56937 MDCYF=0
56938 IF(KC.NE.0) MDCYF=MDCY(KC,1)
56939 WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
56940 & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
56941 270 CONTINUE
56942
56943C...Copy particle/parton composition information into /PYJETS/.
56944 ELSEIF(MTABU.EQ.23) THEN
56945 FAC=1D0/MAX(1,NEVFS)
56946 DO 290 I=1,NKFFS
56947 K(I,1)=32
56948 K(I,2)=99
56949 K(I,3)=KFFS(I)
56950 K(I,4)=0
56951 K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
56952 DO 280 J=1,4
56953 P(I,J)=FAC*NPFS(I,J)
56954 V(I,J)=0D0
56955 280 CONTINUE
56956 P(I,5)=FAC*K(I,5)
56957 V(I,5)=0D0
56958 290 CONTINUE
56959 N=NKFFS
56960 DO 300 J=1,5
56961 K(N+1,J)=0
56962 P(N+1,J)=0D0
56963 V(N+1,J)=0D0
56964 300 CONTINUE
56965 K(N+1,1)=32
56966 K(N+1,2)=99
56967 K(N+1,5)=NEVFS
56968 P(N+1,1)=FAC*NPRFS
56969 P(N+1,2)=FAC*NFIFS
56970 P(N+1,3)=FAC*NCHFS
56971 MSTU(3)=1
56972
56973C...Reset factorial moments statistics.
56974 ELSEIF(MTABU.EQ.30) THEN
56975 NEVFM=0
56976 NMUFM=0
56977 DO 330 IM=1,3
56978 DO 320 IB=1,10
56979 DO 310 IP=1,4
56980 FM1FM(IM,IB,IP)=0D0
56981 FM2FM(IM,IB,IP)=0D0
56982 310 CONTINUE
56983 320 CONTINUE
56984 330 CONTINUE
56985
56986C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
56987 ELSEIF(MTABU.EQ.31) THEN
56988 NEVFM=NEVFM+1
56989 NLOW=N+MSTU(3)
56990 NUPP=NLOW
56991 DO 410 I=1,N
56992 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410
56993 IF(MSTU(41).GE.2) THEN
56994 KC=PYCOMP(K(I,2))
56995 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
56996 & KC.EQ.18) GOTO 410
56997 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
56998 & PYCHGE(K(I,2)).EQ.0) GOTO 410
56999 ENDIF
57000 PMR=0D0
57001 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
57002 IF(MSTU(42).GE.2) PMR=P(I,5)
57003 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
57004 YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
57005 & 1D20)),P(I,3))
57006 IF(ABS(YETA).GT.PARU(57)) GOTO 410
57007 PHI=PYANGL(P(I,1),P(I,2))
57008 IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57))
57009 IYETA=MAX(0,MIN(511,IYETA))
57010 IPHI=512D0*(PHI+PARU(1))/PARU(2)
57011 IPHI=MAX(0,MIN(511,IPHI))
57012 IYEP=0
57013 DO 340 IB=0,9
57014 IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
57015 340 CONTINUE
57016
57017C...Order particles in (pseudo)rapidity and/or azimuth.
57018 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
57019 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
57020 RETURN
57021 ENDIF
57022 NUPP=NUPP+1
57023 IF(NUPP.EQ.NLOW+1) THEN
57024 K(NUPP,1)=IYETA
57025 K(NUPP,2)=IPHI
57026 K(NUPP,3)=IYEP
57027 ELSE
57028 DO 350 I1=NUPP-1,NLOW+1,-1
57029 IF(IYETA.GE.K(I1,1)) GOTO 360
57030 K(I1+1,1)=K(I1,1)
57031 350 CONTINUE
57032 360 K(I1+1,1)=IYETA
57033 DO 370 I1=NUPP-1,NLOW+1,-1
57034 IF(IPHI.GE.K(I1,2)) GOTO 380
57035 K(I1+1,2)=K(I1,2)
57036 370 CONTINUE
57037 380 K(I1+1,2)=IPHI
57038 DO 390 I1=NUPP-1,NLOW+1,-1
57039 IF(IYEP.GE.K(I1,3)) GOTO 400
57040 K(I1+1,3)=K(I1,3)
57041 390 CONTINUE
57042 400 K(I1+1,3)=IYEP
57043 ENDIF
57044 410 CONTINUE
57045 K(NUPP+1,1)=2**10
57046 K(NUPP+1,2)=2**10
57047 K(NUPP+1,3)=4**10
57048
57049C...Calculate sum of factorial moments in event.
57050 DO 480 IM=1,3
57051 DO 430 IB=1,10
57052 DO 420 IP=1,4
57053 FEVFM(IB,IP)=0D0
57054 420 CONTINUE
57055 430 CONTINUE
57056 DO 450 IB=1,10
57057 IF(IM.LE.2) IBIN=2**(10-IB)
57058 IF(IM.EQ.3) IBIN=4**(10-IB)
57059 IAGR=K(NLOW+1,IM)/IBIN
57060 NAGR=1
57061 DO 440 I=NLOW+2,NUPP+1
57062 ICUT=K(I,IM)/IBIN
57063 IF(ICUT.EQ.IAGR) THEN
57064 NAGR=NAGR+1
57065 ELSE
57066 IF(NAGR.EQ.1) THEN
57067 ELSEIF(NAGR.EQ.2) THEN
57068 FEVFM(IB,1)=FEVFM(IB,1)+2D0
57069 ELSEIF(NAGR.EQ.3) THEN
57070 FEVFM(IB,1)=FEVFM(IB,1)+6D0
57071 FEVFM(IB,2)=FEVFM(IB,2)+6D0
57072 ELSEIF(NAGR.EQ.4) THEN
57073 FEVFM(IB,1)=FEVFM(IB,1)+12D0
57074 FEVFM(IB,2)=FEVFM(IB,2)+24D0
57075 FEVFM(IB,3)=FEVFM(IB,3)+24D0
57076 ELSE
57077 FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0)
57078 FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0)
57079 FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
57080 & (NAGR-3D0)
57081 FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
57082 & (NAGR-3D0)*(NAGR-4D0)
57083 ENDIF
57084 IAGR=ICUT
57085 NAGR=1
57086 ENDIF
57087 440 CONTINUE
57088 450 CONTINUE
57089
57090C...Add results to total statistics.
57091 DO 470 IB=10,1,-1
57092 DO 460 IP=1,4
57093 IF(FEVFM(1,IP).LT.0.5D0) THEN
57094 FEVFM(IB,IP)=0D0
57095 ELSEIF(IM.LE.2) THEN
57096 FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
57097 ELSE
57098 FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
57099 ENDIF
57100 FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
57101 FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
57102 460 CONTINUE
57103 470 CONTINUE
57104 480 CONTINUE
57105 NMUFM=NMUFM+(NUPP-NLOW)
57106 MSTU(62)=NUPP-NLOW
57107
57108C...Write accumulated statistics on factorial moments.
57109 ELSEIF(MTABU.EQ.32) THEN
57110 FAC=1D0/MAX(1,NEVFM)
57111 IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
57112 IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
57113 IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y '
57114 DO 510 IM=1,3
57115 WRITE(MSTU(11),5500)
57116 DO 500 IB=1,10
57117 BYETA=2D0*PARU(57)
57118 IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
57119 BPHI=PARU(2)
57120 IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
57121 IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1))
57122 IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1))
57123 DO 490 IP=1,4
57124 FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
57125 FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
57126 & FMOMA(IP)**2)))
57127 490 CONTINUE
57128 WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
57129 & IP=1,4)
57130 500 CONTINUE
57131 510 CONTINUE
57132
57133C...Copy statistics on factorial moments into /PYJETS/.
57134 ELSEIF(MTABU.EQ.33) THEN
57135 FAC=1D0/MAX(1,NEVFM)
57136 DO 540 IM=1,3
57137 DO 530 IB=1,10
57138 I=10*(IM-1)+IB
57139 K(I,1)=32
57140 K(I,2)=99
57141 K(I,3)=1
57142 IF(IM.NE.2) K(I,3)=2**(IB-1)
57143 K(I,4)=1
57144 IF(IM.NE.1) K(I,4)=2**(IB-1)
57145 K(I,5)=0
57146 P(I,1)=2D0*PARU(57)/K(I,3)
57147 V(I,1)=PARU(2)/K(I,4)
57148 DO 520 IP=1,4
57149 P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
57150 V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
57151 & P(I,IP+1)**2)))
57152 520 CONTINUE
57153 530 CONTINUE
57154 540 CONTINUE
57155 N=30
57156 DO 550 J=1,5
57157 K(N+1,J)=0
57158 P(N+1,J)=0D0
57159 V(N+1,J)=0D0
57160 550 CONTINUE
57161 K(N+1,1)=32
57162 K(N+1,2)=99
57163 K(N+1,5)=NEVFM
57164 MSTU(3)=1
57165
57166C...Reset statistics on Energy-Energy Correlation.
57167 ELSEIF(MTABU.EQ.40) THEN
57168 NEVEE=0
57169 DO 560 J=1,25
57170 FE1EC(J)=0D0
57171 FE2EC(J)=0D0
57172 FE1EC(51-J)=0D0
57173 FE2EC(51-J)=0D0
57174 FE1EA(J)=0D0
57175 FE2EA(J)=0D0
57176 560 CONTINUE
57177
57178C...Find particles to include, with proper assumed mass.
57179 ELSEIF(MTABU.EQ.41) THEN
57180 NEVEE=NEVEE+1
57181 NLOW=N+MSTU(3)
57182 NUPP=NLOW
57183 ECM=0D0
57184 DO 570 I=1,N
57185 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570
57186 IF(MSTU(41).GE.2) THEN
57187 KC=PYCOMP(K(I,2))
57188 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
57189 & KC.EQ.18) GOTO 570
57190 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
57191 & PYCHGE(K(I,2)).EQ.0) GOTO 570
57192 ENDIF
57193 PMR=0D0
57194 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
57195 IF(MSTU(42).GE.2) PMR=P(I,5)
57196 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
57197 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
57198 RETURN
57199 ENDIF
57200 NUPP=NUPP+1
57201 P(NUPP,1)=P(I,1)
57202 P(NUPP,2)=P(I,2)
57203 P(NUPP,3)=P(I,3)
57204 P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
57205 P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
57206 ECM=ECM+P(NUPP,4)
57207 570 CONTINUE
57208 IF(NUPP.EQ.NLOW) RETURN
57209
57210C...Analyze Energy-Energy Correlation in event.
57211 FAC=(2D0/ECM**2)*50D0/PARU(1)
57212 DO 580 J=1,50
57213 FEVEE(J)=0D0
57214 580 CONTINUE
57215 DO 600 I1=NLOW+2,NUPP
57216 DO 590 I2=NLOW+1,I1-1
57217 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
57218 & (P(I1,5)*P(I2,5))
57219 THE=ACOS(MAX(-1D0,MIN(1D0,CTHE)))
57220 ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1))))
57221 FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
57222 590 CONTINUE
57223 600 CONTINUE
57224 DO 610 J=1,25
57225 FE1EC(J)=FE1EC(J)+FEVEE(J)
57226 FE2EC(J)=FE2EC(J)+FEVEE(J)**2
57227 FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
57228 FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
57229 FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
57230 FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
57231 610 CONTINUE
57232 MSTU(62)=NUPP-NLOW
57233
57234C...Write statistics on Energy-Energy Correlation.
57235 ELSEIF(MTABU.EQ.42) THEN
57236 FAC=1D0/MAX(1,NEVEE)
57237 WRITE(MSTU(11),5700) NEVEE
57238 DO 620 J=1,25
57239 FEEC1=FAC*FE1EC(J)
57240 FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2)))
57241 FEEC2=FAC*FE1EC(51-J)
57242 FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
57243 FEECA=FAC*FE1EA(J)
57244 FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2)))
57245 WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1,
57246 & FEEC2,FEES2,FEECA,FEESA
57247 620 CONTINUE
57248
57249C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
57250 ELSEIF(MTABU.EQ.43) THEN
57251 FAC=1D0/MAX(1,NEVEE)
57252 DO 630 I=1,25
57253 K(I,1)=32
57254 K(I,2)=99
57255 K(I,3)=0
57256 K(I,4)=0
57257 K(I,5)=0
57258 P(I,1)=FAC*FE1EC(I)
57259 V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
57260 P(I,2)=FAC*FE1EC(51-I)
57261 V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
57262 P(I,3)=FAC*FE1EA(I)
57263 V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
57264 P(I,4)=PARU(1)*(I-1)/50D0
57265 P(I,5)=PARU(1)*I/50D0
57266 V(I,4)=3.6D0*(I-1)
57267 V(I,5)=3.6D0*I
57268 630 CONTINUE
57269 N=25
57270 DO 640 J=1,5
57271 K(N+1,J)=0
57272 P(N+1,J)=0D0
57273 V(N+1,J)=0D0
57274 640 CONTINUE
57275 K(N+1,1)=32
57276 K(N+1,2)=99
57277 K(N+1,5)=NEVEE
57278 MSTU(3)=1
57279
57280C...Reset statistics on decay channels.
57281 ELSEIF(MTABU.EQ.50) THEN
57282 NEVDC=0
57283 NKFDC=0
57284 NREDC=0
57285
57286C...Identify and order flavour content of final state.
57287 ELSEIF(MTABU.EQ.51) THEN
57288 NEVDC=NEVDC+1
57289 NDS=0
57290 DO 670 I=1,N
57291 IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
57292 NDS=NDS+1
57293 IF(NDS.GT.8) THEN
57294 NREDC=NREDC+1
57295 RETURN
57296 ENDIF
57297 KFM=2*IABS(K(I,2))
57298 IF(K(I,2).LT.0) KFM=KFM-1
57299 DO 650 IDS=NDS-1,1,-1
57300 IIN=IDS+1
57301 IF(KFM.LT.KFDM(IDS)) GOTO 660
57302 KFDM(IDS+1)=KFDM(IDS)
57303 650 CONTINUE
57304 IIN=1
57305 660 KFDM(IIN)=KFM
57306 670 CONTINUE
57307
57308C...Find whether old or new final state.
57309 DO 690 IDC=1,NKFDC
57310 IF(NDS.LT.KFDC(IDC,0)) THEN
57311 IKFDC=IDC
57312 GOTO 700
57313 ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
57314 DO 680 I=1,NDS
57315 IF(KFDM(I).LT.KFDC(IDC,I)) THEN
57316 IKFDC=IDC
57317 GOTO 700
57318 ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
57319 GOTO 690
57320 ENDIF
57321 680 CONTINUE
57322 IKFDC=-IDC
57323 GOTO 700
57324 ENDIF
57325 690 CONTINUE
57326 IKFDC=NKFDC+1
57327 700 IF(IKFDC.LT.0) THEN
57328 IKFDC=-IKFDC
57329 ELSEIF(NKFDC.GE.200) THEN
57330 NREDC=NREDC+1
57331 RETURN
57332 ELSE
57333 DO 720 IDC=NKFDC,IKFDC,-1
57334 NPDC(IDC+1)=NPDC(IDC)
57335 DO 710 I=0,8
57336 KFDC(IDC+1,I)=KFDC(IDC,I)
57337 710 CONTINUE
57338 720 CONTINUE
57339 NKFDC=NKFDC+1
57340 KFDC(IKFDC,0)=NDS
57341 DO 730 I=1,NDS
57342 KFDC(IKFDC,I)=KFDM(I)
57343 730 CONTINUE
57344 NPDC(IKFDC)=0
57345 ENDIF
57346 NPDC(IKFDC)=NPDC(IKFDC)+1
57347
57348C...Write statistics on decay channels.
57349 ELSEIF(MTABU.EQ.52) THEN
57350 FAC=1D0/MAX(1,NEVDC)
57351 WRITE(MSTU(11),5900) NEVDC
57352 DO 750 IDC=1,NKFDC
57353 DO 740 I=1,KFDC(IDC,0)
57354 KFM=KFDC(IDC,I)
57355 KF=(KFM+1)/2
57356 IF(2*KF.NE.KFM) KF=-KF
57357 CALL PYNAME(KF,CHAU)
57358 CHDC(I)=CHAU(1:12)
57359 IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
57360 740 CONTINUE
57361 WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
57362 750 CONTINUE
57363 IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
57364
57365C...Copy statistics on decay channels into /PYJETS/.
57366 ELSEIF(MTABU.EQ.53) THEN
57367 FAC=1D0/MAX(1,NEVDC)
57368 DO 780 IDC=1,NKFDC
57369 K(IDC,1)=32
57370 K(IDC,2)=99
57371 K(IDC,3)=0
57372 K(IDC,4)=0
57373 K(IDC,5)=KFDC(IDC,0)
57374 DO 760 J=1,5
57375 P(IDC,J)=0D0
57376 V(IDC,J)=0D0
57377 760 CONTINUE
57378 DO 770 I=1,KFDC(IDC,0)
57379 KFM=KFDC(IDC,I)
57380 KF=(KFM+1)/2
57381 IF(2*KF.NE.KFM) KF=-KF
57382 IF(I.LE.5) P(IDC,I)=KF
57383 IF(I.GE.6) V(IDC,I-5)=KF
57384 770 CONTINUE
57385 V(IDC,5)=FAC*NPDC(IDC)
57386 780 CONTINUE
57387 N=NKFDC
57388 DO 790 J=1,5
57389 K(N+1,J)=0
57390 P(N+1,J)=0D0
57391 V(N+1,J)=0D0
57392 790 CONTINUE
57393 K(N+1,1)=32
57394 K(N+1,2)=99
57395 K(N+1,5)=NEVDC
57396 V(N+1,5)=FAC*NREDC
57397 MSTU(3)=1
57398 ENDIF
57399
57400C...Format statements for output on unit MSTU(11) (default 6).
57401 5000 FORMAT(///20X,'Event statistics - initial state'/
57402 &20X,'based on an analysis of ',I6,' events'//
57403 &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
57404 &'according to fragmenting system multiplicity'/
57405 &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
57406 &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
57407 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
57408 5200 FORMAT(///20X,'Event statistics - final state'/
57409 &20X,'based on an analysis of ',I7,' events'//
57410 &5X,'Mean primary multiplicity =',F10.4/
57411 &5X,'Mean final multiplicity =',F10.4/
57412 &5X,'Mean charged multiplicity =',F10.4//
57413 &5X,'Number of particles produced per event (directly and via ',
57414 &'decays/branchings)'/
57415 &8X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles',
57416 &8X,'Total'/35X,'prim seco prim seco'/)
57417 5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6))
57418 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
57419 &20X,'based on an analysis of ',I6,' events'//
57420 &3X,'delta-',A3,' delta-phi <n>/bin',10X,'<F2>',18X,'<F3>',
57421 &18X,'<F4>',18X,'<F5>'/35X,4(' value error '))
57422 5500 FORMAT(10X)
57423 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
57424 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
57425 &20X,'based on an analysis of ',I6,' events'//
57426 &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
57427 &'EECA(theta)'/2X,'in degrees ',3(' value error')/)
57428 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
57429 5900 FORMAT(///20X,'Decay channel analysis - final state'/
57430 &20X,'based on an analysis of ',I6,' events'//
57431 &2X,'Probability',10X,'Complete final state'/)
57432 6000 FORMAT(2X,F9.5,5X,8(A12,1X))
57433 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
57434 &'or table overflow)')
57435
57436 RETURN
57437 END
57438
57439C*********************************************************************
57440
57441C...PYEEVT
57442C...Handles the generation of an e+e- annihilation jet event.
57443
57444 SUBROUTINE PYEEVT(KFL,ECM)
57445
57446C...Double precision and integer declarations.
57447 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57448 IMPLICIT INTEGER(I-N)
57449 INTEGER PYK,PYCHGE,PYCOMP
57450C...Commonblocks.
57451 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
57452 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57453 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57454 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
57455
57456C...Check input parameters.
57457 IF(MSTU(12).GE.1) CALL PYLIST(0)
57458 IF(KFL.LT.0.OR.KFL.GT.8) THEN
57459 CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code')
57460 IF(MSTU(21).GE.1) RETURN
57461 ENDIF
57462 IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL))
57463 IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1)
57464 IF(ECM.LT.ECMMIN) THEN
57465 CALL PYERRM(16,'(PYEEVT:) called with too small CM energy')
57466 IF(MSTU(21).GE.1) RETURN
57467 ENDIF
57468
57469C...Check consistency of MSTJ options set.
57470 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
57471 CALL PYERRM(6,
57472 & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
57473 MSTJ(110)=1
57474 ENDIF
57475 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
57476 CALL PYERRM(6,
57477 & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
57478 MSTJ(111)=0
57479 ENDIF
57480
57481C...Initialize alpha_strong and total cross-section.
57482 MSTU(111)=MSTJ(108)
57483 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
57484 &MSTU(111)=1
57485 PARU(112)=PARJ(121)
57486 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
57487 IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
57488 &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM,
57489 &XTOT)
57490 IF(MSTJ(116).GE.3) MSTJ(116)=1
57491 PARJ(171)=0D0
57492
57493C...Add initial e+e- to event record (documentation only).
57494 NTRY=0
57495 100 NTRY=NTRY+1
57496 IF(NTRY.GT.100) THEN
57497 CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop')
57498 RETURN
57499 ENDIF
57500 MSTU(24)=0
57501 NC=0
57502 IF(MSTJ(115).GE.2) THEN
57503 NC=NC+2
57504 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
57505 K(NC-1,1)=21
57506 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
57507 K(NC,1)=21
57508 ENDIF
57509
57510C...Radiative photon (in initial state).
57511 MK=0
57512 ECMC=ECM
57513 IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK,
57514 &THEK,PHIK,ALPK)
57515 IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2D0*PAK))
57516 IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
57517 NC=NC+1
57518 CALL PY1ENT(NC,22,PAK,THEK,PHIK)
57519 K(NC,3)=MIN(MSTJ(115)/2,1)
57520 ENDIF
57521
57522C...Virtual exchange boson (gamma or Z0).
57523 IF(MSTJ(115).GE.3) THEN
57524 NC=NC+1
57525 KF=22
57526 IF(MSTJ(102).EQ.2) KF=23
57527 MSTU10=MSTU(10)
57528 MSTU(10)=1
57529 P(NC,5)=ECMC
57530 CALL PY1ENT(NC,KF,ECMC,0D0,0D0)
57531 K(NC,1)=21
57532 K(NC,3)=1
57533 MSTU(10)=MSTU10
57534 ENDIF
57535
57536C...Choice of flavour and jet configuration.
57537 CALL PYXKFL(KFL,ECM,ECMC,KFLC)
57538 IF(KFLC.EQ.0) GOTO 100
57539 CALL PYXJET(ECMC,NJET,CUT)
57540 KFLN=21
57541 IF(NJET.EQ.4) CALL PYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
57542 &X12,X14)
57543 IF(NJET.EQ.3) CALL PYX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
57544 IF(NJET.EQ.2) MSTJ(120)=1
57545
57546C...Fill jet configuration and origin.
57547 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL PY2ENT(NC+1,KFLC,-KFLC,ECMC)
57548 IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL PY2ENT(-(NC+1),KFLC,-KFLC,
57549 &ECMC)
57550 IF(NJET.EQ.3) CALL PY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
57551 IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,
57552 &-KFLC,ECMC,X1,X2,X4,X12,X14)
57553 IF(NJET.EQ.4.AND.KFLN.NE.21) CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,
57554 &-KFLC,ECMC,X1,X2,X4,X12,X14)
57555 IF(MSTU(24).NE.0) GOTO 100
57556 DO 110 IP=NC+1,N
57557 K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
57558 110 CONTINUE
57559
57560C...Angular orientation according to matrix element.
57561 IF(MSTJ(106).EQ.1) THEN
57562 CALL PYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
57563 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
57564 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
57565 ENDIF
57566
57567C...Rotation and boost from radiative photon.
57568 IF(MK.EQ.1) THEN
57569 DBEK=-PAK/(ECM-PAK)
57570 NMIN=NC+1-MSTJ(115)/3
57571 CALL PYROBO(NMIN,N,0D0,-PHIK,0D0,0D0,0D0)
57572 CALL PYROBO(NMIN,N,ALPK,0D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
57573 CALL PYROBO(NMIN,N,0D0,PHIK,0D0,0D0,0D0)
57574 ENDIF
57575
57576C...Generate parton shower. Rearrange along strings and check.
57577 IF(MSTJ(101).EQ.5) THEN
57578 CALL PYSHOW(N-1,N,ECMC)
57579 MSTJ14=MSTJ(14)
57580 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
57581 IF(MSTJ(105).GE.0) MSTU(28)=0
57582 CALL PYPREP(0)
57583 MSTJ(14)=MSTJ14
57584 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
57585 ENDIF
57586
57587C...Fragmentation/decay generation. Information for PYTABU.
57588 IF(MSTJ(105).EQ.1) CALL PYEXEC
57589 MSTU(161)=KFLC
57590 MSTU(162)=-KFLC
57591
57592 RETURN
57593 END
57594
57595C*********************************************************************
57596
57597C...PYXTEE
57598C...Calculates total cross-section, including initial state
57599C...radiation effects.
57600
57601 SUBROUTINE PYXTEE(KFL,ECM,XTOT)
57602
57603C...Double precision and integer declarations.
57604 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57605 IMPLICIT INTEGER(I-N)
57606 INTEGER PYK,PYCHGE,PYCOMP
57607C...Commonblocks.
57608 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57609 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57610 SAVE /PYDAT1/,/PYDAT2/
57611
57612C...Status, (optimized) Q^2 scale, alpha_strong.
57613 PARJ(151)=ECM
57614 MSTJ(119)=10*MSTJ(102)+KFL
57615 IF(MSTJ(111).EQ.0) THEN
57616 Q2R=ECM**2
57617 ELSEIF(MSTU(111).EQ.0) THEN
57618 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
57619 & ((33D0-2D0*MSTU(112))*PARU(111)))))
57620 Q2R=PARJ(168)*ECM**2
57621 ELSE
57622 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
57623 & (2D0*PARU(112)/ECM)**2))
57624 Q2R=PARJ(168)*ECM**2
57625 ENDIF
57626 ALSPI=PYALPS(Q2R)/PARU(1)
57627
57628C...QCD corrections factor in R.
57629 IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
57630 RQCD=1D0
57631 ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
57632 RQCD=1D0+ALSPI
57633 ELSEIF(MSTJ(109).EQ.0) THEN
57634 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
57635 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0*
57636 & LOG(PARJ(168))*ALSPI**2)
57637 ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
57638 RQCD=1D0+(3D0/4D0)*ALSPI
57639 ELSE
57640 RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2
57641 ENDIF
57642
57643C...Calculate Z0 width if default value not acceptable.
57644 IF(MSTJ(102).GE.3) THEN
57645 RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+
57646 & (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2)
57647 DO 100 KFLC=5,6
57648 VQ=1D0
57649 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-
57650 & (2D0*PYMASS(KFLC)/ ECM)**2))
57651 IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0
57652 IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0
57653 RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3)
57654 100 CONTINUE
57655 PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)*
57656 & (1D0-PARU(102)))
57657 ENDIF
57658
57659C...Calculate propagator and related constants for QFD case.
57660 POLL=1D0-PARJ(131)*PARJ(132)
57661 IF(MSTJ(102).GE.2) THEN
57662 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
57663 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
57664 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
57665 VE=4D0*PARU(102)-1D0
57666 SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
57667 SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
57668 HF1I=SFI*SF1I
57669 HF1W=SFW*SF1W
57670 ENDIF
57671
57672C...Loop over different flavours: charge, velocity.
57673 RTOT=0D0
57674 RQQ=0D0
57675 RQV=0D0
57676 RVA=0D0
57677 DO 110 KFLC=1,MAX(MSTJ(104),KFL)
57678 IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
57679 MSTJ(93)=1
57680 PMQ=PYMASS(KFLC)
57681 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110
57682 QF=KCHG(KFLC,1)/3D0
57683 VQ=1D0
57684 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2)
57685
57686C...Calculate R and sum of charges for QED or QFD case.
57687 RQQ=RQQ+3D0*QF**2*POLL
57688 IF(MSTJ(102).LE.1) THEN
57689 RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL
57690 ELSE
57691 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
57692 RQV=RQV-6D0*QF*VF*SF1I
57693 RVA=RVA+3D0*(VF**2+1D0)*SF1W
57694 RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-
57695 & 2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W)
57696 ENDIF
57697 110 CONTINUE
57698 RSUM=RQQ
57699 IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
57700
57701C...Calculate cross-section, including QCD corrections.
57702 PARJ(141)=RQQ
57703 PARJ(142)=RTOT
57704 PARJ(143)=RTOT*RQCD
57705 PARJ(144)=PARJ(143)
57706 PARJ(145)=PARJ(141)*86.8D0/ECM**2
57707 PARJ(146)=PARJ(142)*86.8D0/ECM**2
57708 PARJ(147)=PARJ(143)*86.8D0/ECM**2
57709 PARJ(148)=PARJ(147)
57710 PARJ(157)=RSUM*RQCD
57711 PARJ(158)=0D0
57712 PARJ(159)=0D0
57713 XTOT=PARJ(147)
57714 IF(MSTJ(107).LE.0) RETURN
57715
57716C...Virtual cross-section.
57717 XKL=PARJ(135)
57718 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
57719 ALE=2D0*LOG(ECM/PYMASS(11))-1D0
57720 SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+
57721 &1.526D0*LOG(ECM**2/0.932D0)
57722
57723C...Soft and hard radiative cross-section in QED case.
57724 IF(MSTJ(102).LE.1) THEN
57725 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV
57726 SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL)
57727 SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL))
57728
57729C...Soft and hard radiative cross-section in QFD case.
57730 ELSE
57731 SZM=1D0-(PARJ(123)/ECM)**2
57732 SZW=PARJ(123)*PARJ(124)/ECM**2
57733 PARJ(161)=-RQQ/RSUM
57734 PARJ(162)=-(RQQ+RQV+RVA)/RSUM
57735 PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM
57736 PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2-
57737 & 4D0+3D0*SZM-SZM**2))/(SZW*RSUM)
57738 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/
57739 & RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0
57740 SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+
57741 & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
57742 & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
57743 SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/
57744 & (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)*
57745 & LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+
57746 & PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW)))
57747 ENDIF
57748
57749C...Total cross-section and fraction of hard photon events.
57750 PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
57751 PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
57752 PARJ(144)=PARJ(157)
57753 PARJ(148)=PARJ(144)*86.8D0/ECM**2
57754 XTOT=PARJ(148)
57755
57756 RETURN
57757 END
57758
57759C*********************************************************************
57760
57761C...PYRADK
57762C...Generates initial state photon radiation.
57763
57764 SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
57765
57766C...Double precision and integer declarations.
57767 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57768 IMPLICIT INTEGER(I-N)
57769 INTEGER PYK,PYCHGE,PYCOMP
57770C...Commonblocks.
57771 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57772 SAVE /PYDAT1/
57773
57774C...Function: cumulative hard photon spectrum in QFD case.
57775 FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+
57776 &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
57777
57778C...Determine whether radiative photon or not.
57779 MK=0
57780 PAK=0D0
57781 IF(PARJ(160).LT.PYR(0)) RETURN
57782 MK=1
57783
57784C...Photon energy range. Find photon momentum in QED case.
57785 XKL=PARJ(135)
57786 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
57787 IF(MSTJ(102).LE.1) THEN
57788 100 XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0))
57789 IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100
57790
57791C...Ditto in QFD case, by numerical inversion of integrated spectrum.
57792 ELSE
57793 SZM=1D0-(PARJ(123)/ECM)**2
57794 SZW=PARJ(123)*PARJ(124)/ECM**2
57795 FXKL=FXK(XKL)
57796 FXKU=FXK(XKU)
57797 FXKD=1D-4*(FXKU-FXKL)
57798 FXKR=FXKL+PYR(0)*(FXKU-FXKL)
57799 NXK=0
57800 110 NXK=NXK+1
57801 XK=0.5D0*(XKL+XKU)
57802 FXKV=FXK(XK)
57803 IF(FXKV.GT.FXKR) THEN
57804 XKU=XK
57805 FXKU=FXKV
57806 ELSE
57807 XKL=XK
57808 FXKL=FXKV
57809 ENDIF
57810 IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
57811 XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
57812 ENDIF
57813 PAK=0.5D0*ECM*XK
57814
57815C...Photon polar and azimuthal angle.
57816 PME=2D0*(PYMASS(11)/ECM)**2
57817 120 CTHM=PME*(2D0/PME)**PYR(0)
57818 IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME,
57819 &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120
57820 CTHE=1D0-CTHM
57821 IF(PYR(0).GT.0.5D0) CTHE=-CTHE
57822 STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM)))
57823 THEK=PYANGL(CTHE,STHE)
57824 PHIK=PARU(2)*PYR(0)
57825
57826C...Rotation angle for hadronic system.
57827 SGN=1D0
57828 IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT.
57829 &PYR(0)) SGN=-1D0
57830 ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/
57831 &(2D0-XK*(1D0-SGN*CTHE)))
57832
57833 RETURN
57834 END
57835
57836C*********************************************************************
57837
57838C...PYXKFL
57839C...Selects flavour for produced qqbar pair.
57840
57841 SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC)
57842
57843C...Double precision and integer declarations.
57844 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57845 IMPLICIT INTEGER(I-N)
57846 INTEGER PYK,PYCHGE,PYCOMP
57847C...Commonblocks.
57848 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57849 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57850 SAVE /PYDAT1/,/PYDAT2/
57851
57852C...Calculate maximum weight in QED or QFD case.
57853 IF(MSTJ(102).LE.1) THEN
57854 RFMAX=4D0/9D0
57855 ELSE
57856 POLL=1D0-PARJ(131)*PARJ(132)
57857 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
57858 SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
57859 SFI=SFW*(1D0-(PARJ(123)/ECMC)**2)
57860 VE=4D0*PARU(102)-1D0
57861 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
57862 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
57863 RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+
57864 & ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0*
57865 & (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+
57866 & 1D0)*HF1W)
57867 ENDIF
57868
57869C...Choose flavour. Gives charge and velocity.
57870 NTRY=0
57871 100 NTRY=NTRY+1
57872 IF(NTRY.GT.100) THEN
57873 CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop')
57874 KFLC=0
57875 RETURN
57876 ENDIF
57877 KFLC=KFL
57878 IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0))
57879 MSTJ(93)=1
57880 PMQ=PYMASS(KFLC)
57881 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100
57882 QF=KCHG(KFLC,1)/3D0
57883 VQ=1D0
57884 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2))
57885
57886C...Calculate weight in QED or QFD case.
57887 IF(MSTJ(102).LE.1) THEN
57888 RF=QF**2
57889 RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2
57890 ELSE
57891 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
57892 RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W
57893 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+
57894 & VQ**3*HF1W
57895 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
57896 ENDIF
57897
57898C...Weighting or new event (radiative photon). Cross-section update.
57899 IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100
57900 PARJ(158)=PARJ(158)+1D0
57901 IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0
57902 IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
57903 IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0
57904 PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
57905 PARJ(148)=PARJ(144)*86.8D0/ECM**2
57906
57907 RETURN
57908 END
57909
57910C*********************************************************************
57911
57912C...PYXJET
57913C...Selects number of jets in matrix element approach.
57914
57915 SUBROUTINE PYXJET(ECM,NJET,CUT)
57916
57917C...Double precision and integer declarations.
57918 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57919 IMPLICIT INTEGER(I-N)
57920 INTEGER PYK,PYCHGE,PYCOMP
57921C...Commonblocks.
57922 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57923 SAVE /PYDAT1/
57924C...Local array and data.
57925 DIMENSION ZHUT(5)
57926 DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/
57927
57928C...Trivial result for two-jets only, including parton shower.
57929 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
57930 CUT=0D0
57931
57932C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
57933 ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
57934 CF=4D0/3D0
57935 IF(MSTJ(109).EQ.2) CF=1D0
57936 IF(MSTJ(111).EQ.0) THEN
57937 Q2=ECM**2
57938 Q2R=ECM**2
57939 ELSEIF(MSTU(111).EQ.0) THEN
57940 PARJ(169)=MIN(1D0,PARJ(129))
57941 Q2=PARJ(169)*ECM**2
57942 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
57943 & ((33D0-2D0*MSTU(112))*PARU(111)))))
57944 Q2R=PARJ(168)*ECM**2
57945 ELSE
57946 PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2))
57947 Q2=PARJ(169)*ECM**2
57948 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
57949 & (2D0*PARU(112)/ECM)**2))
57950 Q2R=PARJ(168)*ECM**2
57951 ENDIF
57952
57953C...alpha_strong for R and R itself.
57954 ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1)
57955 IF(IABS(MSTJ(101)).EQ.1) THEN
57956 RQCD=1D0+ALSPI
57957 ELSEIF(MSTJ(109).EQ.0) THEN
57958 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
57959 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+
57960 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2)
57961 ELSE
57962 RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2
57963 ENDIF
57964
57965C...alpha_strong for jet rate. Initial value for y cut.
57966 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
57967 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2)
57968 IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
57969 & CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0)
57970 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
57971
57972C...Parametrization of first order three-jet cross-section.
57973 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN
57974 PARJ(152)=0D0
57975 ELSE
57976 PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))*
57977 & LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)*
57978 & (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0*
57979 & (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD
57980 IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
57981 & PARJ(152)=0D0
57982 ENDIF
57983
57984C...Parametrization of second order three-jet cross-section.
57985 IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
57986 & CUT.GE.0.25D0) THEN
57987 PARJ(153)=0D0
57988 ELSEIF(MSTJ(110).LE.1) THEN
57989 CT=LOG(1D0/CUT-2D0)
57990 PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2-
57991 & 0.2661D0*CT**3+0.01159D0*CT**4)/RQCD
57992
57993C...Interpolation in second/first order ratio for Zhu parametrization.
57994 ELSEIF(MSTJ(110).EQ.2) THEN
57995 IZA=0
57996 DO 110 IY=1,5
57997 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
57998 110 CONTINUE
57999 IF(IZA.NE.0) THEN
58000 ZHURAT=ZHUT(IZA)
58001 ELSE
58002 IZ=100D0*CUT
58003 ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
58004 ENDIF
58005 PARJ(153)=ALSPI*PARJ(152)*ZHURAT
58006 ENDIF
58007
58008C...Shift in second order three-jet cross-section with optimized Q^2.
58009 IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3
58010 & .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+
58011 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152)
58012
58013C...Parametrization of second order four-jet cross-section.
58014 IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN
58015 PARJ(154)=0D0
58016 ELSE
58017 CT=LOG(1D0/CUT-5D0)
58018 IF(CUT.LE.0.018D0) THEN
58019 XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2
58020 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+
58021 & 0.4059D0*CT**2)
58022 XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2)
58023 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
58024 ELSE
58025 XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3
58026 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+
58027 & 0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3)
58028 XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+
58029 & 0.002093D0*CT**3)
58030 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
58031 ENDIF
58032 PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
58033 PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
58034 ENDIF
58035
58036C...If negative three-jet rate, change y' optimization parameter.
58037 IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND.
58038 & PARJ(169).LT.0.99D0) THEN
58039 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
58040 Q2=PARJ(169)*ECM**2
58041 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
58042 GOTO 100
58043 ENDIF
58044
58045C...If too high cross-section, use harder cuts, or fail.
58046 IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
58047 IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND.
58048 & PARJ(169).LT.0.99D0) THEN
58049 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
58050 Q2=PARJ(169)*ECM**2
58051 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
58052 GOTO 100
58053 ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN
58054 CALL PYERRM(26,
58055 & '(PYXJET:) no allowed y cut value for Zhu parametrization')
58056 ENDIF
58057 CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+
58058 & PARJ(154))**(-1D0/3D0)
58059 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
58060 GOTO 100
58061 ENDIF
58062
58063C...Scalar gluon (first order only).
58064 ELSE
58065 ALSPI=PYALPS(ECM**2)/PARU(1)
58066 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI))
58067 PARJ(152)=0D0
58068 IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)*
58069 & LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0))
58070 PARJ(153)=0D0
58071 PARJ(154)=0D0
58072 ENDIF
58073
58074C...Select number of jets.
58075 PARJ(150)=CUT
58076 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
58077 NJET=2
58078 ELSEIF(MSTJ(101).LE.0) THEN
58079 NJET=MIN(4,2-MSTJ(101))
58080 ELSE
58081 RNJ=PYR(0)
58082 NJET=2
58083 IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
58084 IF(PARJ(154).GT.RNJ) NJET=4
58085 ENDIF
58086
58087 RETURN
58088 END
58089
58090C*********************************************************************
58091
58092C...PYX3JT
58093C...Selects the kinematical variables of three-jet events.
58094
58095 SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2)
58096
58097C...Double precision and integer declarations.
58098 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58099 IMPLICIT INTEGER(I-N)
58100 INTEGER PYK,PYCHGE,PYCOMP
58101C...Commonblocks.
58102 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58103 SAVE /PYDAT1/
58104C...Local array.
58105 DIMENSION ZHUP(5,12)
58106
58107C...Coefficients of Zhu second order parametrization.
58108 DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
58109 &18.29D0, 89.56D0, 4.541D0, -52.09D0, -109.8D0, 24.90D0,
58110 &11.63D0, 3.683D0, 17.50D0,0.002440D0, -1.362D0,-0.3537D0,
58111 &11.42D0, 6.299D0, -22.55D0, -8.915D0, 59.25D0, -5.855D0,
58112 &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0,
58113 &7.847D0, -3.964D0, -35.83D0, 1.178D0, 29.39D0, 0.2806D0,
58114 &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0,
58115 &5.441D0, -56.89D0, -50.27D0, 15.13D0, 114.3D0, -18.19D0,
58116 &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0,
58117 &-17.65D0, 51.44D0, -58.32D0, 70.95D0, -255.7D0, -78.99D0,
58118 &476.9D0, 29.65D0, -239.3D0, 0.4745D0, -1.174D0, 6.081D0/
58119
58120C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
58121 DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+
58122 &X**7/49D0
58123
58124C...Event type. Mass effect factors and other common constants.
58125 MSTJ(120)=2
58126 MSTJ(121)=0
58127 PMQ=PYMASS(KFL)
58128 QME=(2D0*PMQ/ECM)**2
58129 IF(MSTJ(109).NE.1) THEN
58130 CUTL=LOG(CUT)
58131 CUTD=LOG(1D0/CUT-2D0)
58132 IF(MSTJ(109).EQ.0) THEN
58133 CF=4D0/3D0
58134 CN=3D0
58135 TR=2D0
58136 WTMX=MIN(20D0,37D0-6D0*CUTD)
58137 IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT)
58138 ELSE
58139 CF=1D0
58140 CN=0D0
58141 TR=12D0
58142 WTMX=0D0
58143 ENDIF
58144
58145C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
58146 ALS2PI=PARU(118)/PARU(2)
58147 WTOPT=0D0
58148 IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0*
58149 & LOG(PARJ(169))*ALS2PI
58150 WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX)
58151
58152C...Choose three-jet events in allowed region.
58153 100 NJET=3
58154 110 Y13L=CUTL+CUTD*PYR(0)
58155 Y23L=CUTL+CUTD*PYR(0)
58156 Y13=EXP(Y13L)
58157 Y23=EXP(Y23L)
58158 Y12=1D0-Y13-Y23
58159 IF(Y12.LE.CUT) GOTO 110
58160 IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110
58161
58162C...Second order corrections.
58163 IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
58164 Y12L=LOG(Y12)
58165 Y13M=LOG(1D0-Y13)
58166 Y23M=LOG(1D0-Y23)
58167 Y12M=LOG(1D0-Y12)
58168 IF(Y13.LE.0.5D0) Y13I=DILOG(Y13)
58169 IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13)
58170 IF(Y23.LE.0.5D0) Y23I=DILOG(Y23)
58171 IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23)
58172 IF(Y12.LE.0.5D0) Y12I=DILOG(Y12)
58173 IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12)
58174 WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23)
58175 WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+
58176 & 2D0*(2D0*CUTL-Y12L)*CUT/Y12)+
58177 & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-
58178 & 11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+
58179 & (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+
58180 & TR*(2D0*CUTL/3D0-10D0/9D0)+
58181 & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
58182 & Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/
58183 & (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+
58184 & Y13*Y23)/(Y12+Y13)**2)/WT1+
58185 & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)*
58186 & ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
58187 & Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
58188 & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/
58189 & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
58190 & 2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1-
58191 & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I)
58192 IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1
58193 IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
58194 PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2)
58195
58196 ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
58197C...Second order corrections; Zhu parametrization of ERT.
58198 ZX=(Y23-Y13)**2
58199 ZY=1D0-Y12
58200 IZA=0
58201 DO 120 IY=1,5
58202 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
58203 120 CONTINUE
58204 IF(IZA.NE.0) THEN
58205 IZ=IZA
58206 WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
58207 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
58208 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
58209 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
58210 ELSE
58211 IZ=100D0*CUT
58212 WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
58213 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
58214 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
58215 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
58216 IZ=IZ+1
58217 WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
58218 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
58219 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
58220 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
58221 WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ)
58222 ENDIF
58223 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1
58224 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
58225 PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2)
58226 ENDIF
58227
58228C...Impose mass cuts (gives two jets). For fixed jet number new try.
58229 X1=1D0-Y23
58230 X2=1D0-Y13
58231 X3=1D0-Y12
58232 IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
58233 IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
58234 & 0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+
58235 & (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2
58236 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
58237
58238C...Scalar gluon model (first order only, no mass effects).
58239 ELSE
58240 130 NJET=3
58241 140 X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2))
58242 IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140
58243 YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0)
58244 X1=1D0-0.5D0*(X3+YD)
58245 X2=1D0-0.5D0*(X3-YD)
58246 IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2
58247 IF(MSTJ(102).GE.2) THEN
58248 IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT.
58249 & X3**2*PYR(0)) NJET=2
58250 ENDIF
58251 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
58252 ENDIF
58253
58254 RETURN
58255 END
58256
58257C*********************************************************************
58258
58259C...PYX4JT
58260C...Selects the kinematical variables of four-jet events.
58261
58262 SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
58263
58264C...Double precision and integer declarations.
58265 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58266 IMPLICIT INTEGER(I-N)
58267 INTEGER PYK,PYCHGE,PYCOMP
58268C...Commonblocks.
58269 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58270 SAVE /PYDAT1/
58271C...Local arrays.
58272 DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
58273
58274C...Common constants. Colour factors for QCD and Abelian gluon theory.
58275 PMQ=PYMASS(KFL)
58276 QME=(2D0*PMQ/ECM)**2
58277 CT=LOG(1D0/CUT-5D0)
58278 IF(MSTJ(109).EQ.0) THEN
58279 CF=4D0/3D0
58280 CN=3D0
58281 TR=2.5D0
58282 ELSE
58283 CF=1D0
58284 CN=0D0
58285 TR=15D0
58286 ENDIF
58287
58288C...Choice of process (qqbargg or qqbarqqbar).
58289 100 NJET=4
58290 IT=1
58291 IF(PARJ(155).GT.PYR(0)) IT=2
58292 IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
58293 IF(IT.EQ.1) WTMX=0.7D0/CUT**2
58294 IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2
58295 IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2
58296 ID=1
58297
58298C...Sample the five kinematical variables (for qqgg preweighted in y34).
58299 110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
58300 Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
58301 IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0))
58302 IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0)
58303 IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110
58304 VT=PYR(0)
58305 CP=COS(PARU(1)*PYR(0))
58306 Y14=(Y134-Y34)*VT
58307 Y13=Y134-Y14-Y34
58308 VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
58309 Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)*
58310 &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB))
58311 Y23=Y234-Y34-Y24
58312 Y12=1D0-Y134-Y23-Y24
58313 IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
58314 Y123=Y12+Y13+Y23
58315 Y124=Y12+Y14+Y24
58316
58317C...Calculate matrix elements for qqgg or qqqq process.
58318 IC=0
58319 WTTOT=0D0
58320 120 IC=IC+1
58321 IF(IT.EQ.1) THEN
58322 WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+
58323 & 3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24-
58324 & Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12*
58325 & Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+
58326 & 2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/
58327 & (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-
58328 & Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/
58329 & (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24)
58330 WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12*
58331 & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14*
58332 & Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+
58333 & Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24)
58334 WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+
58335 & 2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+
58336 & Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-
58337 & 3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-
58338 & 3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+
58339 & (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+
58340 & 3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+
58341 & 2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24-
58342 & 2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+
58343 & 3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+
58344 & 2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2-
58345 & 2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34)
58346 WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+
58347 & 4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34-
58348 & Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+
58349 & 4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+
58350 & 2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+
58351 & 4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/
58352 & (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34-
58353 & 2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+
58354 & 2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24-
58355 & 4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-
58356 & Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2-
58357 & 4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34-
58358 & 4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34-
58359 & 2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23-
58360 & 2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14-
58361 & Y12*Y13**2)/(4D0*Y34**2*Y134**2)
58362 WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+
58363 & CN*WTC(IC))/8D0
58364 ELSE
58365 WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12*
58366 & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
58367 & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
58368 & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
58369 & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
58370 & Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
58371 & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
58372 & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
58373 & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
58374 WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
58375 & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
58376 & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
58377 & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
58378 & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
58379 & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
58380 & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
58381 & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
58382 WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0
58383 ENDIF
58384
58385C...Permutations of momenta in matrix element. Weighting.
58386 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
58387 YSAV=Y13
58388 Y13=Y14
58389 Y14=YSAV
58390 YSAV=Y23
58391 Y23=Y24
58392 Y24=YSAV
58393 YSAV=Y123
58394 Y123=Y124
58395 Y124=YSAV
58396 ENDIF
58397 IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
58398 YSAV=Y13
58399 Y13=Y23
58400 Y23=YSAV
58401 YSAV=Y14
58402 Y14=Y24
58403 Y24=YSAV
58404 YSAV=Y134
58405 Y134=Y234
58406 Y234=YSAV
58407 ENDIF
58408 IF(IC.LE.3) GOTO 120
58409 IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110
58410 IC=5
58411
58412C...qqgg events: string configuration and event type.
58413 IF(IT.EQ.1) THEN
58414 IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
58415 PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+
58416 & WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT)
58417 IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+
58418 & WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
58419 IF(ID.EQ.2) GOTO 130
58420 ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
58421 PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT)
58422 IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
58423 IF(ID.EQ.2) GOTO 130
58424 ENDIF
58425 MSTJ(120)=3
58426 IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+
58427 & WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4
58428 KFLN=21
58429
58430C...Mass cuts. Kinematical variables out.
58431 IF(Y12.LE.CUT+QME) NJET=2
58432 IF(NJET.EQ.2) GOTO 150
58433 Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12))
58434 X1=1D0-(1D0-Q12)*Y234-Q12*Y134
58435 X4=1D0-(1D0-Q12)*Y134-Q12*Y234
58436 X2=1D0-Y124
58437 X12=(1D0-Q12)*Y13+Q12*Y23
58438 X14=Y12-0.5D0*QME
58439 IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
58440
58441C...qqbarqqbar events: string configuration, choose new flavour.
58442 ELSE
58443 IF(ID.EQ.1) THEN
58444 WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
58445 IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
58446 IF(WTR.LT.WTD(3)+WTD(4)) ID=3
58447 IF(WTR.LT.WTD(4)) ID=4
58448 IF(ID.GE.2) GOTO 130
58449 ENDIF
58450 MSTJ(120)=5
58451 PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT)
58452 140 KFLN=1+INT(5D0*PYR(0))
58453 IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140
58454 IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140
58455 IF(KFLN.GT.MSTJ(104)) NJET=2
58456 PMQN=PYMASS(KFLN)
58457 QMEN=(2D0*PMQN/ECM)**2
58458
58459C...Mass cuts. Kinematical variables out.
58460 IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2
58461 IF(NJET.EQ.2) GOTO 150
58462 Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24))
58463 Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13))
58464 X1=1D0-(1D0-Q24)*Y123-Q24*Y134
58465 X4=1D0-(1D0-Q24)*Y134-Q24*Y123
58466 X2=1D0-(1D0-Q13)*Y234-Q13*Y124
58467 X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+
58468 & Q13*Y23)
58469 X14=Y24-0.5D0*QME
58470 X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+
58471 & Q13*Y14)
58472 IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
58473 & (PARJ(127)+PMQ+PMQN)**2) NJET=2
58474 IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
58475 ENDIF
58476 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
58477
58478 RETURN
58479 END
58480
58481C*********************************************************************
58482
58483C...PYXDIF
58484C...Gives the angular orientation of events.
58485
58486 SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
58487
58488C...Double precision and integer declarations.
58489 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58490 IMPLICIT INTEGER(I-N)
58491 INTEGER PYK,PYCHGE,PYCOMP
58492C...Commonblocks.
58493 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58494 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58495 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58496 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58497
58498C...Charge. Factors depending on polarization for QED case.
58499 QF=KCHG(KFL,1)/3D0
58500 POLL=1D0-PARJ(131)*PARJ(132)
58501 POLD=PARJ(132)-PARJ(131)
58502 IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
58503 HF1=POLL
58504 HF2=0D0
58505 HF3=PARJ(133)**2
58506 HF4=0D0
58507
58508C...Factors depending on flavour, energy and polarization for QFD case.
58509 ELSE
58510 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
58511 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
58512 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
58513 AE=-1D0
58514 VE=4D0*PARU(102)-1D0
58515 AF=SIGN(1D0,QF)
58516 VF=AF-4D0*QF*PARU(102)
58517 HF1=QF**2*POLL-2D0*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
58518 & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2D0*VE*AE*POLD)
58519 HF2=-2D0*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2D0*VF*AF*SFW*SFF**2*
58520 & (2D0*VE*AE*POLL-(VE**2+AE**2)*POLD)
58521 HF3=PARJ(133)**2*(QF**2-2D0*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
58522 & SFW*SFF**2*(VE**2-AE**2))
58523 HF4=-PARJ(133)**2*2D0*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
58524 & SFF*AE
58525 ENDIF
58526
58527C...Mass factor. Differential cross-sections for two-jet events.
58528 SQ2=SQRT(2D0)
58529 QME=0D0
58530 IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
58531 &MSTJ(109).NE.1) QME=(2D0*PYMASS(KFL)/ECM)**2
58532 IF(NJET.EQ.2) THEN
58533 SIGU=4D0*SQRT(1D0-QME)
58534 SIGL=2D0*QME*SQRT(1D0-QME)
58535 SIGT=0D0
58536 SIGI=0D0
58537 SIGA=0D0
58538 SIGP=4D0
58539
58540C...Kinematical variables. Reduce four-jet event to three-jet one.
58541 ELSE
58542 IF(NJET.EQ.3) THEN
58543 X1=2D0*P(NC+1,4)/ECM
58544 X2=2D0*P(NC+3,4)/ECM
58545 ELSE
58546 ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
58547 & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
58548 X1=2D0*P(NC+1,4)/ECMR
58549 X2=2D0*P(NC+4,4)/ECMR
58550 ENDIF
58551
58552C...Differential cross-sections for three-jet (or reduced four-jet).
58553 XQ=(1D0-X1)/(1D0-X2)
58554 CT12=(X1*X2-2D0*X1-2D0*X2+2D0+QME)/SQRT((X1**2-QME)*(X2**2-QME))
58555 ST12=SQRT(1D0-CT12**2)
58556 IF(MSTJ(109).NE.1) THEN
58557 SIGU=2D0*X1**2+X2**2*(1D0+CT12**2)-QME*(3D0+CT12**2-X1-X2)-
58558 & QME*X1/XQ+0.5D0*QME*((X2**2-QME)*ST12**2-2D0*X2)*XQ
58559 SIGL=(X2*ST12)**2-QME*(3D0-CT12**2-2.5D0*(X1+X2)+X1*X2+QME)+
58560 & 0.5D0*QME*(X1**2-X1-QME)/XQ+0.5D0*QME*((X2**2-QME)*CT12**2-
58561 & X2)*XQ
58562 SIGT=0.5D0*(X2**2-QME-0.5D0*QME*(X2**2-QME)/XQ)*ST12**2
58563 SIGI=((1D0-0.5D0*QME*XQ)*(X2**2-QME)*ST12*CT12+
58564 & QME*(1D0-X1-X2+0.5D0*X1*X2+0.5D0*QME)*ST12/CT12)/SQ2
58565 SIGA=X2**2*ST12/SQ2
58566 SIGP=2D0*(X1**2-X2**2*CT12)
58567
58568C...Differential cross-sect for scalar gluons (no mass effects).
58569 ELSE
58570 X3=2D0-X1-X2
58571 XT=X2*ST12
58572 CT13=SQRT(MAX(0D0,1D0-(XT/X3)**2))
58573 SIGU=(1D0-PARJ(171))*(X3**2-0.5D0*XT**2)+
58574 & PARJ(171)*(X3**2-0.5D0*XT**2-4D0*(1D0-X1)*(1D0-X2)**2/X1)
58575 SIGL=(1D0-PARJ(171))*0.5D0*XT**2+
58576 & PARJ(171)*0.5D0*(1D0-X1)**2*XT**2
58577 SIGT=(1D0-PARJ(171))*0.25D0*XT**2+
58578 & PARJ(171)*0.25D0*XT**2*(1D0-2D0*X1)
58579 SIGI=-(0.5D0/SQ2)*((1D0-PARJ(171))*XT*X3*CT13+
58580 & PARJ(171)*XT*((1D0-2D0*X1)*X3*CT13-X1*(X1-X2)))
58581 SIGA=(0.25D0/SQ2)*XT*(2D0*(1D0-X1)-X1*X3)
58582 SIGP=X3**2-2D0*(1D0-X1)*(1D0-X2)/X1
58583 ENDIF
58584 ENDIF
58585
58586C...Upper bounds for differential cross-section.
58587 HF1A=ABS(HF1)
58588 HF2A=ABS(HF2)
58589 HF3A=ABS(HF3)
58590 HF4A=ABS(HF4)
58591 SIGMAX=(2D0*HF1A+HF3A+HF4A)*ABS(SIGU)+2D0*(HF1A+HF3A+HF4A)*
58592 &ABS(SIGL)+2D0*(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGT)+2D0*SQ2*
58593 &(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGI)+4D0*SQ2*HF2A*ABS(SIGA)+
58594 &2D0*HF2A*ABS(SIGP)
58595
58596C...Generate angular orientation according to differential cross-sect.
58597 100 CHI=PARU(2)*PYR(0)
58598 CTHE=2D0*PYR(0)-1D0
58599 PHI=PARU(2)*PYR(0)
58600 CCHI=COS(CHI)
58601 SCHI=SIN(CHI)
58602 C2CHI=COS(2D0*CHI)
58603 S2CHI=SIN(2D0*CHI)
58604 THE=ACOS(CTHE)
58605 STHE=SIN(THE)
58606 C2PHI=COS(2D0*(PHI-PARJ(134)))
58607 S2PHI=SIN(2D0*(PHI-PARJ(134)))
58608 SIG=((1D0+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
58609 &2D0*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
58610 &2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*C2CHI*C2PHI-2D0*CTHE*S2CHI*
58611 &S2PHI)*HF3-((1D0+CTHE**2)*C2CHI*S2PHI+2D0*CTHE*S2CHI*C2PHI)*HF4)*
58612 &SIGT-2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*(CTHE*CCHI*C2PHI-
58613 &SCHI*S2PHI)*HF3+2D0*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
58614 &4D0*SQ2*STHE*CCHI*HF2*SIGA+2D0*CTHE*HF2*SIGP
58615 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100
58616
58617 RETURN
58618 END
58619
58620C*********************************************************************
58621
58622C...PYONIA
58623C...Generates Upsilon and toponium decays into three gluons
58624C...or two gluons and a photon.
58625
58626 SUBROUTINE PYONIA(KFL,ECM)
58627
58628C...Double precision and integer declarations.
58629 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58630 IMPLICIT INTEGER(I-N)
58631 INTEGER PYK,PYCHGE,PYCOMP
58632C...Commonblocks.
58633 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58634 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58635 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58636 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58637
58638C...Printout. Check input parameters.
58639 IF(MSTU(12).GE.1) CALL PYLIST(0)
58640 IF(KFL.LT.0.OR.KFL.GT.8) THEN
58641 CALL PYERRM(16,'(PYONIA:) called with unknown flavour code')
58642 IF(MSTU(21).GE.1) RETURN
58643 ENDIF
58644 IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN
58645 CALL PYERRM(16,'(PYONIA:) called with too small CM energy')
58646 IF(MSTU(21).GE.1) RETURN
58647 ENDIF
58648
58649C...Initial e+e- and onium state (optional).
58650 NC=0
58651 IF(MSTJ(115).GE.2) THEN
58652 NC=NC+2
58653 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
58654 K(NC-1,1)=21
58655 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
58656 K(NC,1)=21
58657 ENDIF
58658 KFLC=IABS(KFL)
58659 IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
58660 NC=NC+1
58661 KF=110*KFLC+3
58662 MSTU10=MSTU(10)
58663 MSTU(10)=1
58664 P(NC,5)=ECM
58665 CALL PY1ENT(NC,KF,ECM,0D0,0D0)
58666 K(NC,1)=21
58667 K(NC,3)=1
58668 MSTU(10)=MSTU10
58669 ENDIF
58670
58671C...Choose x1 and x2 according to matrix element.
58672 NTRY=0
58673 100 X1=PYR(0)
58674 X2=PYR(0)
58675 X3=2D0-X1-X2
58676 IF(X3.GE.1D0.OR.((1D0-X1)/(X2*X3))**2+((1D0-X2)/(X1*X3))**2+
58677 &((1D0-X3)/(X1*X2))**2.LE.2D0*PYR(0)) GOTO 100
58678 NTRY=NTRY+1
58679 NJET=3
58680 IF(MSTJ(101).LE.4) CALL PY3ENT(NC+1,21,21,21,ECM,X1,X3)
58681 IF(MSTJ(101).GE.5) CALL PY3ENT(-(NC+1),21,21,21,ECM,X1,X3)
58682
58683C...Photon-gluon-gluon events. Small system modifications. Jet origin.
58684 MSTU(111)=MSTJ(108)
58685 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
58686 &MSTU(111)=1
58687 PARU(112)=PARJ(121)
58688 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
58689 QF=0D0
58690 IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3D0
58691 RGAM=7.2D0*QF**2*PARU(101)/PYALPS(ECM**2)
58692 MK=0
58693 ECMC=ECM
58694 IF(PYR(0).GT.RGAM/(1D0+RGAM)) THEN
58695 IF(1D0-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
58696 & NJET=2
58697 IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL PY2ENT(NC+1,21,21,ECM)
58698 IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL PY2ENT(-(NC+1),21,21,ECM)
58699 ELSE
58700 MK=1
58701 ECMC=SQRT(1D0-X1)*ECM
58702 IF(ECMC.LT.2D0*PARJ(127)) GOTO 100
58703 K(NC+1,1)=1
58704 K(NC+1,2)=22
58705 K(NC+1,4)=0
58706 K(NC+1,5)=0
58707 IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
58708 IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
58709 IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
58710 IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
58711 NJET=2
58712 IF(ECMC.LT.4D0*PARJ(127)) THEN
58713 MSTU10=MSTU(10)
58714 MSTU(10)=1
58715 P(NC+2,5)=ECMC
58716 CALL PY1ENT(NC+2,83,0.5D0*(X2+X3)*ECM,PARU(1),0D0)
58717 MSTU(10)=MSTU10
58718 NJET=0
58719 ENDIF
58720 ENDIF
58721 DO 110 IP=NC+1,N
58722 K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
58723 110 CONTINUE
58724
58725C...Differential cross-sections. Upper limit for cross-section.
58726 IF(MSTJ(106).EQ.1) THEN
58727 SQ2=SQRT(2D0)
58728 HF1=1D0-PARJ(131)*PARJ(132)
58729 HF3=PARJ(133)**2
58730 CT13=(X1*X3-2D0*X1-2D0*X3+2D0)/(X1*X3)
58731 ST13=SQRT(1D0-CT13**2)
58732 SIGL=0.5D0*X3**2*((1D0-X2)**2+(1D0-X3)**2)*ST13**2
58733 SIGU=(X1*(1D0-X1))**2+(X2*(1D0-X2))**2+(X3*(1D0-X3))**2-SIGL
58734 SIGT=0.5D0*SIGL
58735 SIGI=(SIGL*CT13/ST13+0.5D0*X1*X3*(1D0-X2)**2*ST13)/SQ2
58736 SIGMAX=(2D0*HF1+HF3)*ABS(SIGU)+2D0*(HF1+HF3)*ABS(SIGL)+2D0*(HF1+
58737 & 2D0*HF3)*ABS(SIGT)+2D0*SQ2*(HF1+2D0*HF3)*ABS(SIGI)
58738
58739C...Angular orientation of event.
58740 120 CHI=PARU(2)*PYR(0)
58741 CTHE=2D0*PYR(0)-1D0
58742 PHI=PARU(2)*PYR(0)
58743 CCHI=COS(CHI)
58744 SCHI=SIN(CHI)
58745 C2CHI=COS(2D0*CHI)
58746 S2CHI=SIN(2D0*CHI)
58747 THE=ACOS(CTHE)
58748 STHE=SIN(THE)
58749 C2PHI=COS(2D0*(PHI-PARJ(134)))
58750 S2PHI=SIN(2D0*(PHI-PARJ(134)))
58751 SIG=((1D0+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2D0*(STHE**2*HF1-
58752 & STHE**2*C2PHI*HF3)*SIGL+2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*
58753 & C2CHI*C2PHI-2D0*CTHE*S2CHI*S2PHI)*HF3)*SIGT-
58754 & 2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*
58755 & (CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
58756 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 120
58757 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
58758 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
58759 ENDIF
58760
58761C...Generate parton shower. Rearrange along strings and check.
58762 IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
58763 CALL PYSHOW(NC+MK+1,-NJET,ECMC)
58764 MSTJ14=MSTJ(14)
58765 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
58766 IF(MSTJ(105).GE.0) MSTU(28)=0
58767 CALL PYPREP(0)
58768 MSTJ(14)=MSTJ14
58769 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
58770 ENDIF
58771
58772C...Generate fragmentation. Information for PYTABU:
58773 IF(MSTJ(105).EQ.1) CALL PYEXEC
58774 MSTU(161)=110*KFLC+3
58775 MSTU(162)=0
58776
58777 RETURN
58778 END
58779
58780C*********************************************************************
58781
58782C...PYBOOK
58783C...Books a histogram.
58784
58785 SUBROUTINE PYBOOK(ID,TITLE,NX,XL,XU)
58786
58787C...Double precision declaration.
58788 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58789 IMPLICIT INTEGER(I-N)
58790C...Commonblock.
58791 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
58792 SAVE /PYBINS/
58793C...Local character variables.
58794 CHARACTER TITLE*(*), TITFX*60
58795
58796C...Check that input is sensible. Find initial address in memory.
58797 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
58798 &'(PYBOOK:) not allowed histogram number')
58799 IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28,
58800 &'(PYBOOK:) not allowed number of bins')
58801 IF(XL.GE.XU) CALL PYERRM(28,
58802 &'(PYBOOK:) x limits in wrong order')
58803 INDX(ID)=IHIST(4)
58804 IHIST(4)=IHIST(4)+28+NX
58805 IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28,
58806 &'(PYBOOK:) out of histogram space')
58807 IS=INDX(ID)
58808
58809C...Store histogram size and reset contents.
58810 BIN(IS+1)=NX
58811 BIN(IS+2)=XL
58812 BIN(IS+3)=XU
58813 BIN(IS+4)=(XU-XL)/NX
58814 CALL PYNULL(ID)
58815
58816C...Store title by conversion to integer to double precision.
58817 TITFX=TITLE//' '
58818 DO 100 IT=1,20
58819 BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+
58820 & 256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT))
58821 100 CONTINUE
58822
58823 RETURN
58824 END
58825
58826C*********************************************************************
58827
58828C...PYFILL
58829C...Fills entry in histogram.
58830
58831 SUBROUTINE PYFILL(ID,X,W)
58832
58833C...Double precision declaration.
58834 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58835 IMPLICIT INTEGER(I-N)
58836C...Commonblock.
58837 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
58838 SAVE /PYBINS/
58839
58840C...Find initial address in memory. Increase number of entries.
58841 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
58842 &'(PYFILL:) not allowed histogram number')
58843 IS=INDX(ID)
58844 IF(IS.EQ.0) CALL PYERRM(28,
58845 &'(PYFILL:) filling unbooked histogram')
58846 BIN(IS+5)=BIN(IS+5)+1D0
58847
58848C...Find bin in x, including under/overflow, and fill.
58849 IF(X.LT.BIN(IS+2)) THEN
58850 BIN(IS+6)=BIN(IS+6)+W
58851 ELSEIF(X.GE.BIN(IS+3)) THEN
58852 BIN(IS+8)=BIN(IS+8)+W
58853 ELSE
58854 BIN(IS+7)=BIN(IS+7)+W
58855 IX=(X-BIN(IS+2))/BIN(IS+4)
58856 IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX))
58857 BIN(IS+9+IX)=BIN(IS+9+IX)+W
58858 ENDIF
58859
58860 RETURN
58861 END
58862
58863C*********************************************************************
58864
58865C...PYFACT
58866C...Multiplies histogram contents by factor.
58867
58868 SUBROUTINE PYFACT(ID,F)
58869
58870C...Double precision declaration.
58871 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58872 IMPLICIT INTEGER(I-N)
58873C...Commonblock.
58874 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
58875 SAVE /PYBINS/
58876
58877C...Find initial address in memory. Multiply all contents bins.
58878 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
58879 &'(PYFACT:) not allowed histogram number')
58880 IS=INDX(ID)
58881 IF(IS.EQ.0) CALL PYERRM(28,
58882 &'(PYFACT:) scaling unbooked histogram')
58883 DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1))
58884 BIN(IX)=F*BIN(IX)
58885 100 CONTINUE
58886
58887 RETURN
58888 END
58889
58890C*********************************************************************
58891
58892C...PYOPER
58893C...Performs operations between histograms.
58894
58895 SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2)
58896
58897C...Double precision declaration.
58898 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58899 IMPLICIT INTEGER(I-N)
58900C...Commonblock.
58901 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
58902 SAVE /PYBINS/
58903C...Character variable.
58904 CHARACTER OPER*(*)
58905
58906C...Find initial addresses in memory, and histogram size.
58907 IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28,
58908 &'(PYFACT:) not allowed histogram number')
58909 IS1=INDX(ID1)
58910 IS2=INDX(MIN(IHIST(1),MAX(1,ID2)))
58911 IS3=INDX(MIN(IHIST(1),MAX(1,ID3)))
58912 NX=NINT(BIN(IS3+1))
58913 IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1))
58914
58915C...Update info on number of histogram entries.
58916 IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN
58917 BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5)
58918 ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN
58919 BIN(IS3+5)=BIN(IS1+5)
58920 ENDIF
58921
58922C...Operations on pair of histograms: addition, subtraction,
58923C...multiplication, division.
58924 IF(OPER.EQ.'+') THEN
58925 DO 100 IX=6,8+NX
58926 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX)
58927 100 CONTINUE
58928 ELSEIF(OPER.EQ.'-') THEN
58929 DO 110 IX=6,8+NX
58930 BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX)
58931 110 CONTINUE
58932 ELSEIF(OPER.EQ.'*') THEN
58933 DO 120 IX=6,8+NX
58934 BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX)
58935 120 CONTINUE
58936 ELSEIF(OPER.EQ.'/') THEN
58937 DO 130 IX=6,8+NX
58938 FA2=F2*BIN(IS2+IX)
58939 IF(ABS(FA2).LE.1D-20) THEN
58940 BIN(IS3+IX)=0D0
58941 ELSE
58942 BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2
58943 ENDIF
58944 130 CONTINUE
58945
58946C...Operations on single histogram: multiplication+addition,
58947C...square root+addition, logarithm+addition.
58948 ELSEIF(OPER.EQ.'A') THEN
58949 DO 140 IX=6,8+NX
58950 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2
58951 140 CONTINUE
58952 ELSEIF(OPER.EQ.'S') THEN
58953 DO 150 IX=6,8+NX
58954 BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2
58955 150 CONTINUE
58956 ELSEIF(OPER.EQ.'L') THEN
58957 ZMIN=1D20
58958 DO 160 IX=9,8+NX
58959 IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20)
58960 & ZMIN=0.8D0*BIN(IS1+IX)
58961 160 CONTINUE
58962 DO 170 IX=6,8+NX
58963 BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2
58964 170 CONTINUE
58965
58966C...Operation on two or three histograms: average and
58967C...standard deviation.
58968 ELSEIF(OPER.EQ.'M') THEN
58969 DO 180 IX=6,8+NX
58970 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
58971 BIN(IS2+IX)=0D0
58972 ELSE
58973 BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX)
58974 ENDIF
58975 IF(ID3.NE.0) THEN
58976 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
58977 BIN(IS3+IX)=0D0
58978 ELSE
58979 BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)-
58980 & BIN(IS2+IX)**2))
58981 ENDIF
58982 ENDIF
58983 BIN(IS1+IX)=F1*BIN(IS1+IX)
58984 180 CONTINUE
58985 ENDIF
58986
58987 RETURN
58988 END
58989
58990C*********************************************************************
58991
58992C...PYHIST
58993C...Prints and resets all histograms.
58994
58995 SUBROUTINE PYHIST
58996
58997C...Double precision declaration.
58998 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58999 IMPLICIT INTEGER(I-N)
59000C...Commonblock.
59001 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
59002 SAVE /PYBINS/
59003
59004C...Loop over histograms, print and reset used ones.
59005 DO 100 ID=1,IHIST(1)
59006 IS=INDX(ID)
59007 IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN
59008 CALL PYPLOT(ID)
59009 CALL PYNULL(ID)
59010 ENDIF
59011 100 CONTINUE
59012
59013 RETURN
59014 END
59015
59016C*********************************************************************
59017
59018C...PYPLOT
59019C...Prints a histogram (but does not reset it).
59020
59021 SUBROUTINE PYPLOT(ID)
59022
59023C...Double precision declaration.
59024 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59025 IMPLICIT INTEGER(I-N)
59026C...Commonblocks.
59027 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59028 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
59029 SAVE /PYDAT1/,/PYBINS/
59030C...Local arrays and character variables.
59031 DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10)
59032 CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
59033
59034C...Steps in histogram scale. Character sequence.
59035 DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
59036 DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/
59037
59038C...Find initial address in memory; skip if empty histogram.
59039 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
59040 IS=INDX(ID)
59041 IF(IS.EQ.0) RETURN
59042 IF(NINT(BIN(IS+5)).LE.0) THEN
59043 WRITE(MSTU(11),5000) ID
59044 RETURN
59045 ENDIF
59046
59047C...Number of histogram lines and x bins.
59048 LIN=IHIST(3)-18
59049 NX=NINT(BIN(IS+1))
59050
59051C...Extract title by conversion from double precision via integer.
59052 DO 100 IT=1,20
59053 IEQ=NINT(BIN(IS+8+NX+IT))
59054 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256)
59055 & //CHAR(MOD(IEQ,256))
59056 100 CONTINUE
59057
59058C...Find time; print title.
59059 CALL PYTIME(IDATI)
59060 IF(IDATI(1).GT.0) THEN
59061 WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5)
59062 ELSE
59063 WRITE(MSTU(11),5200) ID, TITLE
59064 ENDIF
59065
59066C...Find minimum and maximum bin content.
59067 YMIN=BIN(IS+9)
59068 YMAX=BIN(IS+9)
59069 DO 110 IX=IS+10,IS+8+NX
59070 IF(BIN(IX).LT.YMIN) YMIN=BIN(IX)
59071 IF(BIN(IX).GT.YMAX) YMAX=BIN(IX)
59072 110 CONTINUE
59073
59074C...Determine scale and step size for y axis.
59075 IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN
59076 IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0
59077 IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0
59078 IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10
59079 IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1
59080 IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1
59081 DELY=DYAC(1)
59082 DO 120 IDEL=1,9
59083 IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1)
59084 120 CONTINUE
59085 DY=DELY*10D0**IPOT
59086
59087C...Convert bin contents to integer form; fractional fill in top row.
59088 DO 130 IX=1,NX
59089 CTA=ABS(BIN(IS+8+IX))/DY
59090 IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX))
59091 IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0)))
59092 130 CONTINUE
59093 IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN)
59094 IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX)
59095
59096C...Print histogram row by row.
59097 DO 150 IR=IRMA,IRMI,-1
59098 IF(IR.EQ.0) GOTO 150
59099 OUT=' '
59100 DO 140 IX=1,NX
59101 IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX))
59102 IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10)
59103 140 CONTINUE
59104 WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT
59105 150 CONTINUE
59106
59107C...Print sign and value of bin contents.
59108 IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10
59109 OUT=' '
59110 DO 160 IX=1,NX
59111 IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11)
59112 IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX)))
59113 160 CONTINUE
59114 WRITE(MSTU(11),5400) OUT
59115 DO 180 IR=4,1,-1
59116 DO 170 IX=1,NX
59117 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
59118 170 CONTINUE
59119 WRITE(MSTU(11),5500) IPOT+IR-4, OUT
59120 180 CONTINUE
59121
59122C...Print sign and value of lower bin edge.
59123 IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+
59124 & 10.0001D0)-10
59125 OUT=' '
59126 DO 190 IX=1,NX
59127 IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3))
59128 & OUT(IX:IX)=CHA(11)
59129 IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4)))
59130 190 CONTINUE
59131 WRITE(MSTU(11),5600) OUT
59132 DO 210 IR=3,1,-1
59133 DO 200 IX=1,NX
59134 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
59135 200 CONTINUE
59136 WRITE(MSTU(11),5500) IPOT+IR-3, OUT
59137 210 CONTINUE
59138 ENDIF
59139
59140C...Calculate and print statistics.
59141 CSUM=0D0
59142 CXSUM=0D0
59143 CXXSUM=0D0
59144 DO 220 IX=1,NX
59145 CTA=ABS(BIN(IS+8+IX))
59146 X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4)
59147 CSUM=CSUM+CTA
59148 CXSUM=CXSUM+CTA*X
59149 CXXSUM=CXXSUM+CTA*X**2
59150 220 CONTINUE
59151 XMEAN=CXSUM/MAX(CSUM,1D-20)
59152 XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2))
59153 WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6),
59154 &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3)
59155
59156C...Formats for output.
59157 5000 FORMAT(/5X,'Histogram no',I5,' : no entries')
59158 5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X,
59159 &I2,':',I2/)
59160 5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/)
59161 5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100)
59162 5400 FORMAT(/8X,'Contents',3X,A100)
59163 5500 FORMAT(9X,'*10**',I2,3X,A100)
59164 5600 FORMAT(/8X,'Low edge',3X,A100)
59165 5700 FORMAT(/5X,'Entries =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow ='
59166 &,D12.4,6X,'Low edge =',D12.4/5X,'All chan =',D12.4,6X,
59167 &'Rms =',D12.4,6X,'Overflow =',D12.4,6X,'High edge =',D12.4)
59168
59169 RETURN
59170 END
59171
59172C*********************************************************************
59173
59174C...PYNULL
59175C...Resets bin contents of a histogram.
59176
59177 SUBROUTINE PYNULL(ID)
59178
59179C...Double precision declaration.
59180 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59181 IMPLICIT INTEGER(I-N)
59182C...Commonblock.
59183 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
59184 SAVE /PYBINS/
59185
59186 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
59187 IS=INDX(ID)
59188 IF(IS.EQ.0) RETURN
59189 DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1))
59190 BIN(IX)=0D0
59191 100 CONTINUE
59192
59193 RETURN
59194 END
59195
59196C*********************************************************************
59197
59198C...PYDUMP
59199C...Dumps histogram contents on file for reading by other program.
59200C...Can also read back own dump.
59201
59202 SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI)
59203
59204C...Double precision declaration.
59205 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59206 IMPLICIT INTEGER(I-N)
59207C...Commonblock.
59208 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
59209 SAVE /PYBINS/
59210C...Local arrays and character variables.
59211 DIMENSION IHI(*),ISS(100),VAL(5)
59212 CHARACTER TITLE*60,FORMAT*13
59213
59214C...Dump all histograms that have been booked,
59215C...including titles and ranges, one after the other.
59216 IF(MDUMP.EQ.1) THEN
59217
59218C...Loop over histograms and find which are wanted and booked.
59219 IF(NHI.LE.0) THEN
59220 NW=IHIST(1)
59221 ELSE
59222 NW=NHI
59223 ENDIF
59224 DO 130 IW=1,NW
59225 IF(NHI.EQ.0) THEN
59226 ID=IW
59227 ELSE
59228 ID=IHI(IW)
59229 ENDIF
59230 IS=INDX(ID)
59231 IF(IS.NE.0) THEN
59232
59233C...Write title, histogram size, filling statistics.
59234 NX=NINT(BIN(IS+1))
59235 DO 100 IT=1,20
59236 IEQ=NINT(BIN(IS+8+NX+IT))
59237 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//
59238 & CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256))
59239 100 CONTINUE
59240 WRITE(LFN,5100) ID,TITLE
59241 WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3)
59242 WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7),
59243 & BIN(IS+8)
59244
59245
59246C...Write histogram contents, in groups of five.
59247 DO 120 IXG=1,(NX+4)/5
59248 DO 110 IXV=1,5
59249 IX=5*IXG+IXV-5
59250 IF(IX.LE.NX) THEN
59251 VAL(IXV)=BIN(IS+8+IX)
59252 ELSE
59253 VAL(IXV)=0D0
59254 ENDIF
59255 110 CONTINUE
59256 WRITE(LFN,5400) (VAL(IXV),IXV=1,5)
59257 120 CONTINUE
59258
59259C...Go to next histogram; finish.
59260 ELSEIF(NHI.GT.0) THEN
59261 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
59262 ENDIF
59263 130 CONTINUE
59264
59265C...Read back in histograms dumped MDUMP=1.
59266 ELSEIF(MDUMP.EQ.2) THEN
59267
59268C...Read histogram number, title and range, and book.
59269 140 READ(LFN,5100,END=170) ID,TITLE
59270 READ(LFN,5200) NX,XL,XU
59271 CALL PYBOOK(ID,TITLE,NX,XL,XU)
59272 IS=INDX(ID)
59273
59274C...Read filling statistics.
59275 READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8)
59276 BIN(IS+5)=DBLE(NENTRY)
59277
59278C...Read histogram contents, in groups of five.
59279 DO 160 IXG=1,(NX+4)/5
59280 READ(LFN,5400) (VAL(IXV),IXV=1,5)
59281 DO 150 IXV=1,5
59282 IX=5*IXG+IXV-5
59283 IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV)
59284 150 CONTINUE
59285 160 CONTINUE
59286
59287C...Go to next histogram; finish.
59288 GOTO 140
59289 170 CONTINUE
59290
59291C...Write histogram contents in column format,
59292C...convenient e.g. for GNUPLOT input.
59293 ELSEIF(MDUMP.EQ.3) THEN
59294
59295C...Find addresses to wanted histograms.
59296 NSS=0
59297 IF(NHI.LE.0) THEN
59298 NW=IHIST(1)
59299 ELSE
59300 NW=NHI
59301 ENDIF
59302 DO 180 IW=1,NW
59303 IF(NHI.EQ.0) THEN
59304 ID=IW
59305 ELSE
59306 ID=IHI(IW)
59307 ENDIF
59308 IS=INDX(ID)
59309 IF(IS.NE.0.AND.NSS.LT.100) THEN
59310 NSS=NSS+1
59311 ISS(NSS)=IS
59312 ELSEIF(NSS.GE.100) THEN
59313 CALL PYERRM(8,'(PYDUMP:) too many histograms requested')
59314 ELSEIF(NHI.GT.0) THEN
59315 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
59316 ENDIF
59317 180 CONTINUE
59318
59319C...Check that they have common number of x bins. Fix format.
59320 NX=NINT(BIN(ISS(1)+1))
59321 DO 190 IW=2,NSS
59322 IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN
59323 CALL PYERRM(8,'(PYDUMP:) different number of bins')
59324 RETURN
59325 ENDIF
59326 190 CONTINUE
59327 FORMAT='(1P,000E12.4)'
59328 WRITE(FORMAT(5:7),'(I3)') NSS+1
59329
59330C...Write histogram contents; first column x values.
59331 DO 200 IX=1,NX
59332 X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4)
59333 WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS)
59334 200 CONTINUE
59335
59336 ENDIF
59337
59338C...Formats for output.
59339 5100 FORMAT(I5,5X,A60)
59340 5200 FORMAT(I5,1P,2D12.4)
59341 5300 FORMAT(I12,1P,3D12.4)
59342 5400 FORMAT(1P,5D12.4)
59343
59344 RETURN
59345 END
59346
59347C*********************************************************************
59348
59349C...PYKCUT
59350C...Dummy routine, which the user can replace in order to make cuts on
59351C...the kinematics on the parton level before the matrix elements are
59352C...evaluated and the event is generated. The cross-section estimates
59353C...will automatically take these cuts into account, so the given
59354C...values are for the allowed phase space region only. MCUT=0 means
59355C...that the event has passed the cuts, MCUT=1 that it has failed.
59356
59357 SUBROUTINE PYKCUT(MCUT)
59358
59359C...Double precision and integer declarations.
59360 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59361 IMPLICIT INTEGER(I-N)
59362 INTEGER PYK,PYCHGE,PYCOMP
59363C...Commonblocks.
59364 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59365 COMMON/PYINT1/MINT(400),VINT(400)
59366 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
59367 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
59368
59369C...Set default value (accepting event) for MCUT.
59370 MCUT=0
59371
59372C...Read out subprocess number.
59373 ISUB=MINT(1)
59374 ISTSB=ISET(ISUB)
59375
59376C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
59377 TAU=VINT(21)
59378 YST=VINT(22)
59379 CTH=0D0
59380 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
59381 TAUP=0D0
59382 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
59383
59384C...Calculate x_1, x_2, x_F.
59385 IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN
59386 X1=SQRT(TAU)*EXP(YST)
59387 X2=SQRT(TAU)*EXP(-YST)
59388 ELSE
59389 X1=SQRT(TAUP)*EXP(YST)
59390 X2=SQRT(TAUP)*EXP(-YST)
59391 ENDIF
59392 XF=X1-X2
59393
59394C...Calculate shat, that, uhat, p_T^2.
59395 SHAT=TAU*VINT(2)
59396 SQM3=VINT(63)
59397 SQM4=VINT(64)
59398 RM3=SQM3/SHAT
59399 RM4=SQM4/SHAT
59400 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
59401 RPTS=4D0*VINT(71)**2/SHAT
59402 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
59403 RM34=2D0*RM3*RM4
59404 RSQM=1D0+RM34
59405 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
59406 THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
59407 UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
59408 PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2))
59409
59410C...Decisions by user to be put here.
59411
59412C...Stop program if this routine is ever called.
59413C...You should not copy these lines to your own routine.
59414 WRITE(MSTU(11),5000)
59415 IF(PYR(0).LT.10D0) STOP
59416
59417C...Format for error printout.
59418 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ',
59419 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
59420 &1X,'Execution stopped!')
59421
59422 RETURN
59423 END
59424
59425C*********************************************************************
59426
59427C...PYEVWT
59428C...Dummy routine, which the user can replace in order to multiply the
59429C...standard PYTHIA differential cross-section by a process- and
59430C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
59431C...to generation of weighted events, with weight 1/WTXS, while for
59432C...MSTP(142)=2 it corresponds to a modification of the underlying
59433C...physics.
59434
59435 SUBROUTINE PYEVWT(WTXS)
59436
59437C...Double precision and integer declarations.
59438 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59439 IMPLICIT INTEGER(I-N)
59440 INTEGER PYK,PYCHGE,PYCOMP
59441C...Commonblocks.
59442 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59443 COMMON/PYINT1/MINT(400),VINT(400)
59444 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
59445 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
59446
59447C...Set default weight for WTXS.
59448 WTXS=1D0
59449
59450C...Read out subprocess number.
59451 ISUB=MINT(1)
59452 ISTSB=ISET(ISUB)
59453
59454C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
59455 TAU=VINT(21)
59456 YST=VINT(22)
59457 CTH=0D0
59458 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
59459 TAUP=0D0
59460 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
59461
59462C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
59463 X1=VINT(41)
59464 X2=VINT(42)
59465 XF=X1-X2
59466 SHAT=VINT(44)
59467 THAT=VINT(45)
59468 UHAT=VINT(46)
59469 PT2=VINT(48)
59470
59471C...Modifications by user to be put here.
59472
59473C...Stop program if this routine is ever called.
59474C...You should not copy these lines to your own routine.
59475 WRITE(MSTU(11),5000)
59476 IF(PYR(0).LT.10D0) STOP
59477
59478C...Format for error printout.
59479 5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ',
59480 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
59481 &1X,'Execution stopped!')
59482
59483 RETURN
59484 END
59485
59486C*********************************************************************
59487
59488C...UPINIT
59489C...Dummy routine, to be replaced by a user implementing external
59490C...processes. Is supposed to fill the HEPRUP commonblock with info
59491C...on incoming beams and allowed processes.
59492
59493 SUBROUTINE UPINIT
59494
59495C...Double precision and integer declarations.
59496 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59497 IMPLICIT INTEGER(I-N)
59498
59499C...User process initialization commonblock.
59500 INTEGER MAXPUP
59501 PARAMETER (MAXPUP=100)
59502 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
59503 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
59504 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
59505 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
59506 &LPRUP(MAXPUP)
59507 SAVE /HEPRUP/
59508
59509 RETURN
59510 END
59511
59512C*********************************************************************
59513
59514C...UPEVNT
59515C...Dummy routine, to be replaced by a user implementing external
59516C...processes. Depending on cross section model chosen, it either has
59517C...to generate a process of the type IDPRUP requested, or pick a type
59518C...itself and generate this event. The event is to be stored in the
59519C...HEPEUP commonblock, including (often) an event weight.
59520
59521 SUBROUTINE UPEVNT
59522
59523C...Double precision and integer declarations.
59524 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59525 IMPLICIT INTEGER(I-N)
59526
59527C...User process event common block.
59528 INTEGER MAXNUP
59529 PARAMETER (MAXNUP=500)
59530 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
59531 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
59532 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
59533 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
59534 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
59535 SAVE /HEPEUP/
59536
59537 RETURN
59538 END
59539
59540C*********************************************************************
59541C...SUGRA
59542C...Dummy routine, to be removed when ISAJET (ISASUSY) is to be linked.
59543
59544 SUBROUTINE SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODL)
59545 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59546 IMPLICIT INTEGER(I-N)
59547 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
59548 INTEGER IMODL
59549C...Commonblocks.
59550 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59551 SAVE /PYDAT1/
59552
59553C...Stop program if this routine is ever called.
59554 WRITE(MSTU(11),5000)
59555 IF(PYR(0).LT.10D0) STOP
59556
59557C...Format for error printout.
59558 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
59559 &1X,'Dummy routine SUGRA in PYTHIA file called instead.'/
59560 &1X,'Execution stopped!')
59561
59562 RETURN
59563 END
59564
59565C*********************************************************************
59566
59567C...VISAJE
59568C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
59569
59570 FUNCTION VISAJE()
59571 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59572 IMPLICIT INTEGER(I-N)
59573 CHARACTER*40 VISAJE
59574
59575C...Commonblocks.
59576 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59577 SAVE /PYDAT1/
59578
59579C...Assign default value.
59580 VISAJE='Undefined'
59581
59582C...Stop program if this routine is ever called.
59583 WRITE(MSTU(11),5000)
59584 IF(PYR(0).LT.10D0) STOP
59585
59586C...Format for error printout.
59587 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
59588 &1X,'Dummy function VISAJE in PYTHIA file called instead.'/
59589 &1X,'Execution stopped!')
59590
59591 RETURN
59592 END
59593
59594C*********************************************************************
59595
59596C...PYTAUD
59597C...Dummy routine, to be replaced by user, to handle the decay of a
59598C...polarized tau lepton.
59599C...Input:
59600C...ITAU is the position where the decaying tau is stored in /PYJETS/.
59601C...IORIG is the position where the mother of the tau is stored;
59602C... is 0 when the mother is not stored.
59603C...KFORIG is the flavour of the mother of the tau;
59604C... is 0 when the mother is not known.
59605C...Note that IORIG=0 does not necessarily imply KFORIG=0;
59606C... e.g. in B hadron semileptonic decays the W propagator
59607C... is not explicitly stored but the W code is still unambiguous.
59608C...Output:
59609C...NDECAY is the number of decay products in the current tau decay.
59610C...These decay products should be added to the /PYJETS/ common block,
59611C...in positions N+1 through N+NDECAY. For each product I you must
59612C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
59613C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
59614
59615 SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
59616
59617C...Double precision and integer declarations.
59618 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59619 IMPLICIT INTEGER(I-N)
59620 INTEGER PYK,PYCHGE,PYCOMP
59621C...Commonblocks.
59622 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59623 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59624 SAVE /PYJETS/,/PYDAT1/
59625
59626C...Stop program if this routine is ever called.
59627C...You should not copy these lines to your own routine.
59628 NDECAY=ITAU+IORIG+KFORIG
59629 WRITE(MSTU(11),5000)
59630 IF(PYR(0).LT.10D0) STOP
59631
59632C...Format for error printout.
59633 5000 FORMAT(1X,'Error: you did not link your PYTAUD routine ',
59634 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
59635 &1X,'Execution stopped!')
59636
59637 RETURN
59638 END
59639
59640C*********************************************************************
59641
59642C...PYTIME
59643C...Finds current date and time.
59644C...Since this task is not standardized in Fortran 77, the routine
59645C...is dummy, to be replaced by the user. Examples are given for
59646C...the Fortran 90 routine and DEC Fortran 77, and what to do if
59647C...you do not have access to suitable routines.
59648
59649 SUBROUTINE PYTIME(IDATI)
59650
59651C...Double precision and integer declarations.
59652 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59653 IMPLICIT INTEGER(I-N)
59654 INTEGER PYK,PYCHGE,PYCOMP
59655 CHARACTER*8 ATIME
59656C...Local array.
59657 INTEGER IDATI(6),IDTEMP(3)
59658
59659C...Example 0: if you do not have suitable routines.
59660 DO 100 J=1,6
59661 IDATI(J)=0
59662 100 CONTINUE
59663
59664C...Example 1: Fortran 90 routine.
59665C INTEGER IVAL(8)
59666C CALL DATE_AND_TIME(VALUES=IVAL)
59667C IDATI(1)=IVAL(1)
59668C IDATI(2)=IVAL(2)
59669C IDATI(3)=IVAL(3)
59670C IDATI(4)=IVAL(5)
59671C IDATI(5)=IVAL(6)
59672C IDATI(6)=IVAL(7)
59673
59674C...Example 2: DEC Fortran 77. AIX.
59675C CALL IDATE(IMON,IDAY,IYEAR)
59676C IDATI(1)=IYEAR
59677C IDATI(2)=IMON
59678C IDATI(3)=IDAY
59679C CALL ITIME(IHOUR,IMIN,ISEC)
59680C IDATI(4)=IHOUR
59681C IDATI(5)=IMIN
59682C IDATI(6)=ISEC
59683
59684C...Example 3: DEC Fortran, IRIX, IRIX64.
59685C CALL IDATE(IMON,IDAY,IYEAR)
59686C IDATI(1)=IYEAR
59687C IDATI(2)=IMON
59688C IDATI(3)=IDAY
59689C CALL TIME(ATIME)
59690C IHOUR=0
59691C IMIN=0
59692C ISEC=0
59693C READ(ATIME(1:2),'(I2)') IHOUR
59694C READ(ATIME(4:5),'(I2)') IMIN
59695C READ(ATIME(7:8),'(I2)') ISEC
59696C IDATI(4)=IHOUR
59697C IDATI(5)=IMIN
59698C IDATI(6)=ISEC
59699
59700C...Example 4: GNU LINUX libU77, SunOS.
286fd514 59701c CALL IDATE(IDTEMP)
59702c IDATI(1)=IDTEMP(3)
59703c IDATI(2)=IDTEMP(2)
59704c IDATI(3)=IDTEMP(1)
59705c CALL ITIME(IDTEMP)
59706c IDATI(4)=IDTEMP(1)
59707c IDATI(5)=IDTEMP(2)
59708c IDATI(6)=IDTEMP(3)
2dfa57d1 59709
59710C...Common code to ensure right century.
59711 IDATI(1)=2000+MOD(IDATI(1),100)
59712
59713 RETURN
59714 END