]> 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
Be sure to load mapping when needed
[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
bf6cd108 2859
2dfa57d1 2860C...Initial values for some counters.
2861 N=0
2862 MINT(5)=MINT(5)+1
2863 MINT(7)=0
2864 MINT(8)=0
2865 MINT(83)=0
2866 MINT(84)=MSTP(126)
2867 MSTU(24)=0
2868 MSTU70=0
2869 MSTJ14=MSTJ(14)
2870
2871C...If variable energies: redo incoming kinematics and cross-section.
2872 MSTI(61)=0
2873 IF(MSTP(171).EQ.1) THEN
2874 CALL PYINKI(1)
2875 IF(MSTI(61).EQ.1) THEN
2876 MINT(5)=MINT(5)-1
2877 RETURN
2878 ENDIF
2879 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
2880 CALL PYXTOT
2881 ENDIF
2882
2883C...Loop over number of pileup events; check space left.
2884 IF(MSTP(131).LE.0) THEN
2885 NPILE=1
2886 ELSE
2887 CALL PYPILE(2)
2888 NPILE=MINT(81)
2889 ENDIF
2890 DO 250 IPILE=1,NPILE
2891 IF(MINT(84)+100.GE.MSTU(4)) THEN
2892 CALL PYERRM(11,
2893 & '(PYEVNT:) no more space in PYJETS for pileup events')
2894 IF(MSTU(21).GE.1) GOTO 260
2895 ENDIF
2896 MINT(82)=IPILE
2897
2898C...Generate variables of hard scattering.
2899 MINT(51)=0
2900 MSTI(52)=0
2901 100 CONTINUE
2902 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
2903 MINT(31)=0
2904 MINT(51)=0
2905 MINT(57)=0
2906 CALL PYRAND
2907 IF(MSTI(61).EQ.1) THEN
2908 MINT(5)=MINT(5)-1
2909 RETURN
2910 ENDIF
2911 IF(MINT(51).EQ.2) RETURN
2912 ISUB=MINT(1)
2913 IF(MSTP(111).EQ.-1) GOTO 240
2914
2915 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
2916C...Hard scattering (including low-pT):
2917C...reconstruct kinematics and colour flow of hard scattering.
2918 MINT31=MINT(31)
2919 110 MINT(31)=MINT31
2920 MINT(51)=0
2921 CALL PYSCAT
2922 IF(MINT(51).EQ.1) GOTO 100
2923 IPU1=MINT(84)+1
2924 IPU2=MINT(84)+2
2925 IF(ISUB.EQ.95) GOTO 120
2926
2927C...Showering of initial state partons (optional).
2928 NFIN=N
2929 ALAMSV=PARJ(81)
2930 PARJ(81)=PARP(72)
2931 IF(MSTP(61).GE.1.AND.MINT(47).GE.2) CALL PYSSPA(IPU1,IPU2)
2932 PARJ(81)=ALAMSV
2933 IF(MINT(51).EQ.1) GOTO 100
2934
2935C...Showering of final state partons (optional).
2936 ALAMSV=PARJ(81)
2937 PARJ(81)=PARP(72)
2938 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.2.AND.ISET(ISUB).LE.10)
2939 & THEN
2940 IPU3=MINT(84)+3
2941 IPU4=MINT(84)+4
2942 IF(ISET(ISUB).EQ.5) IPU4=-3
2943 QMAX=VINT(55)
2944 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
2945 CALL PYSHOW(IPU3,IPU4,QMAX)
2946 ELSEIF(ISET(ISUB).EQ.11) THEN
2947 CALL PYADSH(NFIN)
2948 ENDIF
2949 PARJ(81)=ALAMSV
2950
2951C...Decay of final state resonances.
2952 MINT(32)=0
2953 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) CALL PYRESD(0)
2954 IF(MINT(51).EQ.1) GOTO 100
2955 MINT(52)=N
2956
2957C...Multiple interactions.
2958 IF(MSTP(81).GE.1.AND.MINT(50).EQ.1) CALL PYMULT(6)
2959 MINT(53)=N
2960
2961C...Hadron remnants and primordial kT.
2962 120 CALL PYREMN(IPU1,IPU2)
2963 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO 110
2964 IF(MINT(51).EQ.1) GOTO 100
2965
2966 ELSEIF(ISUB.NE.99) THEN
2967C...Diffractive and elastic scattering.
2968 CALL PYDIFF
2969
2970 ELSE
2971C...DIS scattering (photon flux external).
2972 CALL PYDISG
2973 IF(MINT(51).EQ.1) GOTO 100
2974 ENDIF
2975
2976C...Check that no odd resonance left undecayed.
2977 IF(MSTP(111).GE.1) THEN
2978 NFIX=N
2979 DO 130 I=MINT(84)+1,NFIX
2980 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
2981 & K(I,2).NE.22) THEN
2982 KCA=PYCOMP(K(I,2))
2983 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
2984 CALL PYRESD(I)
2985 IF(MINT(51).EQ.1) GOTO 100
2986 ENDIF
2987 ENDIF
2988 130 CONTINUE
2989 ENDIF
2990
2991C...Boost hadronic subsystem to overall rest frame.
2992C..(Only relevant when photon inside lepton beam.)
2993 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
2994
2995C...Recalculate energies from momenta and masses (if desired).
2996 IF(MSTP(113).GE.1) THEN
2997 DO 140 I=MINT(83)+1,N
2998 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
2999 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3000 140 CONTINUE
3001 NRECAL=N
3002 ENDIF
3003
3004C...Rearrange partons along strings, check invariant mass cuts.
3005 MSTU(28)=0
3006 IF(MSTP(111).LE.0) MSTJ(14)=-1
3007 CALL PYPREP(MINT(84)+1)
3008 MSTJ(14)=MSTJ14
3009 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
3010 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
3011 DO 170 I=MINT(84)+1,N
3012 IF(K(I,2).EQ.94) THEN
3013 DO 160 I1=I+1,MIN(N,I+10)
3014 IF(K(I1,3).EQ.I) THEN
3015 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
3016 IF(K(I1,3).EQ.0) THEN
3017 DO 150 II=MINT(84)+1,I-1
3018 IF(K(II,2).EQ.K(I1,2)) THEN
3019 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
3020 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
3021 ENDIF
3022 150 CONTINUE
3023 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
3024 ENDIF
3025 ENDIF
3026 160 CONTINUE
3027 ENDIF
3028 170 CONTINUE
3029 CALL PYEDIT(12)
3030 CALL PYEDIT(14)
3031 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
3032 IF(MSTP(125).EQ.0) MINT(4)=0
3033 DO 190 I=MINT(83)+1,N
3034 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
3035 DO 180 I1=I+1,N
3036 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
3037 IF(K(I1,3).EQ.I) K(I,5)=I1
3038 180 CONTINUE
3039 ENDIF
3040 190 CONTINUE
3041 ENDIF
3042
3043C...Introduce separators between sections in PYLIST event listing.
3044 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
3045 MSTU70=1
3046 MSTU(71)=N
3047 ELSEIF(IPILE.EQ.1) THEN
3048 MSTU70=3
3049 MSTU(71)=2
3050 MSTU(72)=MINT(4)
3051 MSTU(73)=N
3052 ENDIF
3053
3054C...Go back to lab frame (needed for vertices, also in fragmentation).
3055 CALL PYFRAM(1)
3056
3057C...Set nonvanishing production vertex (optional).
3058 IF(MSTP(151).EQ.1) THEN
3059 DO 200 J=1,4
3060 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
3061 & SIN(PARU(2)*PYR(0))
3062 200 CONTINUE
3063 DO 220 I=MINT(83)+1,N
3064 DO 210 J=1,4
3065 V(I,J)=V(I,J)+VTX(J)
3066 210 CONTINUE
3067 220 CONTINUE
3068 ENDIF
3069
3070C...Perform hadronization (if desired).
3071 IF(MSTP(111).GE.1) THEN
3072 CALL PYEXEC
3073 IF(MSTU(24).NE.0) GOTO 100
3074 ENDIF
3075 IF(MSTP(113).GE.1) THEN
3076 DO 230 I=NRECAL,N
3077 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3078 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3079 230 CONTINUE
3080 ENDIF
3081 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3082
3083C...Store event information and calculate Monte Carlo estimates of
3084C...subprocess cross-sections.
3085 240 IF(IPILE.EQ.1) CALL PYDOCU
3086
3087C...Set counters for current pileup event and loop to next one.
3088 MSTI(41)=IPILE
3089 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3090 IF(MSTU70.LT.10) THEN
3091 MSTU70=MSTU70+1
3092 MSTU(70+MSTU70)=N
3093 ENDIF
3094 MINT(83)=N
3095 MINT(84)=N+MSTP(126)
3096 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
3097 250 CONTINUE
3098
3099C...Generic information on pileup events. Reconstruct missing history.
3100 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
3101 PARI(91)=VINT(132)
3102 PARI(92)=VINT(133)
3103 PARI(93)=VINT(134)
3104 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
3105 ENDIF
3106 CALL PYEDIT(16)
3107
3108C...Transform to the desired coordinate frame.
3109 260 CALL PYFRAM(MSTP(124))
3110 MSTU(70)=MSTU70
3111 PARU(21)=VINT(1)
3112
3113C...Error messages
3114 5100 FORMAT(1X,'Error: no subprocess switched on.'/
3115 &1X,'Execution stopped.')
3116
3117 RETURN
3118 END
3119
3120C***********************************************************************
3121
3122C...PYSTAT
3123C...Prints out information about cross-sections, decay widths, branching
3124C...ratios, kinematical limits, status codes and parameter values.
3125
3126 SUBROUTINE PYSTAT(MSTAT)
3127
3128C...Double precision and integer declarations.
3129 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3130 IMPLICIT INTEGER(I-N)
3131 INTEGER PYK,PYCHGE,PYCOMP
3132C...Parameter statement to help give large particle numbers.
3133 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
3134 &KEXCIT=4000000,KDIMEN=5000000)
3135 PARAMETER (EPS=1D-3)
3136C...Commonblocks.
3137 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3138 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3139 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3140 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3141 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3142 COMMON/PYINT1/MINT(400),VINT(400)
3143 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3144 COMMON/PYINT4/MWID(500),WIDS(500,5)
3145 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3146 COMMON/PYINT6/PROC(0:500)
3147 CHARACTER PROC*28, CHTMP*16
3148 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
3149 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
3150 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
3151 &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/,/PYMSRV/
3152C...Local arrays, character variables and data.
3153 DIMENSION WDTP(0:400),WDTE(0:400,0:5),NMODES(0:20),PBRAT(10)
3154 CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16,
3155 &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28,
3156 &PROGG9(13)*28,PROGG4(4)*28,PROGG2(2)*28,PROGP4(4)*28
3157 CHARACTER*24 CHD0, CHDC(10)
3158 CHARACTER*6 DNAME(3)
3159 DATA PROGA/
3160 &'VMD/hadron * VMD ','VMD/hadron * direct ',
3161 &'VMD/hadron * anomalous ','direct * direct ',
3162 &'direct * anomalous ','anomalous * anomalous '/
3163 DATA DISGA/'e * VMD','e * anomalous'/
3164 DATA PROGG9/
3165 &'direct * direct ','direct * VMD ',
3166 &'direct * anomalous ','VMD * direct ',
3167 &'VMD * VMD ','VMD * anomalous ',
3168 &'anomalous * direct ','anomalous * VMD ',
3169 &'anomalous * anomalous ','DIS * VMD ',
3170 &'DIS * anomalous ','VMD * DIS ',
3171 &'anomalous * DIS '/
3172 DATA PROGG4/
3173 &'direct * direct ','direct * resolved ',
3174 &'resolved * direct ','resolved * resolved '/
3175 DATA PROGG2/
3176 &'direct * hadron ','resolved * hadron '/
3177 DATA PROGP4/
3178 &'VMD * hadron ','direct * hadron ',
3179 &'anomalous * hadron ','DIS * hadron '/
3180 DATA STATE/'----','off ','on ','on/+','on/-','on/1','on/2'/,
3181 &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
3182 &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ',
3183 &' y*_small ',' eta*_large ',' eta*_small ',
3184 &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ',
3185 &' x_2 ',' x_F ',' cos(theta_hard) ',
3186 &'m''_hard (GeV/c^2) ',' tau ',' y* ',
3187 &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ',
3188 &' tau'' '/
3189 DATA DNAME /'q ','lepton','nu '/
3190
3191C...Cross-sections.
3192 IF(MSTAT.LE.1) THEN
3193 IF(MINT(121).GT.1) CALL PYSAVE(5,0)
3194 WRITE(MSTU(11),5000)
3195 WRITE(MSTU(11),5100)
3196 WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)
3197 DO 100 I=1,500
3198 IF(MSUB(I).NE.1) GOTO 100
3199 WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)
3200 100 CONTINUE
3201 IF(MINT(121).GT.1) THEN
3202 WRITE(MSTU(11),5300)
3203 DO 110 IGA=1,MINT(121)
3204 CALL PYSAVE(3,IGA)
3205 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
3206 WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1),
3207 & XSEC(0,3)
3208 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
3209 WRITE(MSTU(11),5200) IGA,PROGG9(IGA),NGEN(0,3),NGEN(0,1),
3210 & XSEC(0,3)
3211 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.30) THEN
3212 WRITE(MSTU(11),5200) IGA,PROGP4(IGA),NGEN(0,3),NGEN(0,1),
3213 & XSEC(0,3)
3214 ELSEIF(MINT(121).EQ.4) THEN
3215 WRITE(MSTU(11),5200) IGA,PROGG4(IGA),NGEN(0,3),NGEN(0,1),
3216 & XSEC(0,3)
3217 ELSEIF(MINT(121).EQ.2) THEN
3218 WRITE(MSTU(11),5200) IGA,PROGG2(IGA),NGEN(0,3),NGEN(0,1),
3219 & XSEC(0,3)
3220 ELSE
3221 WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1),
3222 & XSEC(0,3)
3223 ENDIF
3224 110 CONTINUE
3225 CALL PYSAVE(5,0)
3226 ENDIF
3227 WRITE(MSTU(11),5400) 1D0-DBLE(NGEN(0,3))/
3228 & MAX(1D0,DBLE(NGEN(0,2)))
3229
3230C...Decay widths and branching ratios.
3231 ELSEIF(MSTAT.EQ.2) THEN
3232 WRITE(MSTU(11),5500)
3233 WRITE(MSTU(11),5600)
3234 DO 140 KC=1,500
3235 KF=KCHG(KC,4)
3236 CALL PYNAME(KF,CHKF)
3237 IOFF=0
3238 IF(KC.LE.22) THEN
3239 IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140
3240 IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140
3241 IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1
3242 IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1
3243 IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1
3244 ELSE
3245 IF(MWID(KC).LE.0) GOTO 140
3246 IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR.
3247 & KF/KSUSY1.EQ.2)) GOTO 140
3248 ENDIF
3249C...Off-shell branchings.
3250 IF(IOFF.EQ.1) THEN
3251 NGP=0
3252 IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2
3253 IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10),
3254 & PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0
3255 DO 120 J=1,MDCY(KC,3)
3256 IDC=J+MDCY(KC,2)-1
3257 NGP1=0
3258 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
3259 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
3260 NGP2=0
3261 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
3262 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
3263 CALL PYNAME(KFDP(IDC,1),CHD1)
3264 CALL PYNAME(KFDP(IDC,2),CHD2)
3265 IF(KFDP(IDC,3).EQ.0) THEN
3266 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
3267 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10),
3268 & CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
3269 ELSE
3270 CALL PYNAME(KFDP(IDC,3),CHD3)
3271 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
3272 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10),
3273 & CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
3274 ENDIF
3275 120 CONTINUE
3276C...On-shell decays.
3277 ELSE
3278 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
3279 BRFIN=1D0
3280 IF(WDTE(0,0).LE.0D0) BRFIN=0D0
3281 WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0,
3282 & STATE(MDCY(KC,1)),BRFIN
3283 DO 130 J=1,MDCY(KC,3)
3284 IDC=J+MDCY(KC,2)-1
3285 NGP1=0
3286 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
3287 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
3288 NGP2=0
3289 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
3290 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
3291 BRFIN=0D0
3292 IF(WDTE(0,0).GT.0D0) BRFIN=WDTE(J,0)/WDTE(0,0)
3293 CALL PYNAME(KFDP(IDC,1),CHD1)
3294 CALL PYNAME(KFDP(IDC,2),CHD2)
3295 IF(KFDP(IDC,3).EQ.0) THEN
3296 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
3297 & WRITE(MSTU(11),5800) IDC,CHD1(1:10),
3298 & CHD2(1:10),WDTP(J),WDTP(J)/WDTP(0),
3299 & STATE(MDME(IDC,1)),BRFIN
3300 ELSE
3301 CALL PYNAME(KFDP(IDC,3),CHD3)
3302 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
3303 & WRITE(MSTU(11),5900) IDC,CHD1(1:10),
3304 & CHD2(1:10),CHD3(1:10),WDTP(J),WDTP(J)/WDTP(0),
3305 & STATE(MDME(IDC,1)),BRFIN
3306 ENDIF
3307 130 CONTINUE
3308 ENDIF
3309 140 CONTINUE
3310 WRITE(MSTU(11),6000)
3311
3312C...Allowed incoming partons/particles at hard interaction.
3313 ELSEIF(MSTAT.EQ.3) THEN
3314 WRITE(MSTU(11),6100)
3315 CALL PYNAME(MINT(11),CHAU)
3316 CHIN(1)=CHAU(1:12)
3317 CALL PYNAME(MINT(12),CHAU)
3318 CHIN(2)=CHAU(1:12)
3319 WRITE(MSTU(11),6200) CHIN(1),CHIN(2)
3320 DO 150 I=-20,22
3321 IF(I.EQ.0) GOTO 150
3322 IA=IABS(I)
3323 IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150
3324 IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150
3325 CALL PYNAME(I,CHAU)
3326 WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU,
3327 & STATE(KFIN(2,I))
3328 150 CONTINUE
3329 WRITE(MSTU(11),6400)
3330
3331C...User-defined limits on kinematical variables.
3332 ELSEIF(MSTAT.EQ.4) THEN
3333 WRITE(MSTU(11),6500)
3334 WRITE(MSTU(11),6600)
3335 SHRMAX=CKIN(2)
3336 IF(SHRMAX.LT.0D0) SHRMAX=VINT(1)
3337 WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX
3338 PTHMIN=MAX(CKIN(3),CKIN(5))
3339 PTHMAX=CKIN(4)
3340 IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX
3341 WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX
3342 WRITE(MSTU(11),6900) CHKIN(3),CKIN(6)
3343 DO 160 I=4,14
3344 WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I)
3345 160 CONTINUE
3346 SPRMAX=CKIN(32)
3347 IF(SPRMAX.LT.0D0) SPRMAX=VINT(1)
3348 WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX
3349 WRITE(MSTU(11),7000)
3350
3351C...Status codes and parameter values.
3352 ELSEIF(MSTAT.EQ.5) THEN
3353 WRITE(MSTU(11),7100)
3354 WRITE(MSTU(11),7200)
3355 DO 170 I=1,100
3356 WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
3357 & PARP(100+I)
3358 170 CONTINUE
3359
3360C...List of all processes implemented in the program.
3361 ELSEIF(MSTAT.EQ.6) THEN
3362 WRITE(MSTU(11),7400)
3363 WRITE(MSTU(11),7500)
3364 DO 180 I=1,500
3365 IF(ISET(I).LT.0) GOTO 180
3366 WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2)
3367 180 CONTINUE
3368 WRITE(MSTU(11),7700)
3369
3370 ELSEIF(MSTAT.EQ.7) THEN
3371 WRITE (MSTU(11),8000)
3372 NMODES(0)=0
3373 NMODES(10)=0
3374 NMODES(9)=0
3375 DO 290 ILR=1,2
3376 DO 280 KFSM=1,16
3377 KFSUSY=ILR*KSUSY1+KFSM
3378 NRVDC=0
3379C...SDOWN DECAYS
3380 IF (KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5) THEN
3381 NRVDC=3
3382 DO 190 I=1,NRVDC
3383 PBRAT(I)=0D0
3384 NMODES(I)=0
3385 190 CONTINUE
3386 CALL PYNAME(KFSUSY,CHTMP)
3387 CHD0=CHTMP//' '
3388 CHDC(1)=DNAME(3) // ' + ' // DNAME(1)
3389 CHDC(2)=DNAME(2) // ' + ' // DNAME(1)
3390 CHDC(3)=DNAME(1) // ' + ' // DNAME(1)
3391 KC=PYCOMP(KFSUSY)
3392 DO 200 J=1,MDCY(KC,3)
3393 IDC=J+MDCY(KC,2)-1
3394 ID1=IABS(KFDP(IDC,1))
3395 ID2=IABS(KFDP(IDC,2))
3396 IF (KFDP(IDC,3).EQ.0) THEN
3397 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
3398 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
3399 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3400 NMODES(1)=NMODES(1)+1
3401 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3402 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3403 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3404 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6)) THEN
3405 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3406 NMODES(2)=NMODES(2)+1
3407 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3408 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3409 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
3410 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
3411 PBRAT(3)=PBRAT(3)+BRAT(IDC)
3412 NMODES(3)=NMODES(3)+1
3413 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3414 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3415 ENDIF
3416 ENDIF
3417 200 CONTINUE
3418 ENDIF
3419C...SUP DECAYS
3420 IF (KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6) THEN
3421 NRVDC=2
3422 DO 210 I=1,NRVDC
3423 NMODES(I)=0
3424 PBRAT(I)=0D0
3425 210 CONTINUE
3426 CALL PYNAME(KFSUSY,CHTMP)
3427 CHD0=CHTMP//' '
3428 CHDC(1)=DNAME(2) // ' + ' // DNAME(1)
3429 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
3430 KC=PYCOMP(KFSUSY)
3431 DO 220 J=1,MDCY(KC,3)
3432 IDC=J+MDCY(KC,2)-1
3433 ID1=IABS(KFDP(IDC,1))
3434 ID2=IABS(KFDP(IDC,2))
3435 IF (KFDP(IDC,3).EQ.0) THEN
3436 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
3437 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
3438 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3439 NMODES(1)=NMODES(1)+1
3440 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3441 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3442 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
3443 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
3444 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3445 NMODES(2)=NMODES(2)+1
3446 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3447 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3448 ENDIF
3449 ENDIF
3450 220 CONTINUE
3451 ENDIF
3452C...SLEPTON DECAYS
3453 IF (KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15) THEN
3454 NRVDC=2
3455 DO 230 I=1,NRVDC
3456 PBRAT(I)=0D0
3457 NMODES(I)=0
3458 230 CONTINUE
3459 CALL PYNAME(KFSUSY,CHTMP)
3460 CHD0=CHTMP//' '
3461 CHDC(1)=DNAME(3) // ' + ' // DNAME(2)
3462 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
3463 KC=PYCOMP(KFSUSY)
3464 DO 240 J=1,MDCY(KC,3)
3465 IDC=J+MDCY(KC,2)-1
3466 ID1=IABS(KFDP(IDC,1))
3467 ID2=IABS(KFDP(IDC,2))
3468 IF (KFDP(IDC,3).EQ.0) THEN
3469 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
3470 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
3471 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3472 NMODES(1)=NMODES(1)+1
3473 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3474 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3475 ENDIF
3476 IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND.(ID2
3477 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
3478 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3479 NMODES(2)=NMODES(2)+1
3480 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3481 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3482 ENDIF
3483 ENDIF
3484 240 CONTINUE
3485 ENDIF
3486C...SNEUTRINO DECAYS
3487 IF ((KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16).AND.ILR.EQ.1)
3488 & THEN
3489 NRVDC=2
3490 DO 250 I=1,NRVDC
3491 PBRAT(I)=0D0
3492 NMODES(I)=0
3493 250 CONTINUE
3494 CALL PYNAME(KFSUSY,CHTMP)
3495 CHD0=CHTMP//' '
3496 CHDC(1)=DNAME(2) // ' + ' // DNAME(2)
3497 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
3498 KC=PYCOMP(KFSUSY)
3499 DO 260 J=1,MDCY(KC,3)
3500 IDC=J+MDCY(KC,2)-1
3501 ID1=IABS(KFDP(IDC,1))
3502 ID2=IABS(KFDP(IDC,2))
3503 IF (KFDP(IDC,3).EQ.0) THEN
3504 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
3505 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
3506 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3507 NMODES(1)=NMODES(1)+1
3508 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3509 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3510 ENDIF
3511 IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
3512 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
3513 NMODES(2)=NMODES(2)+1
3514 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3515 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3516 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3517 ENDIF
3518 ENDIF
3519 260 CONTINUE
3520 ENDIF
3521 IF (NRVDC.NE.0) THEN
3522 DO 270 I=1,NRVDC
3523 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
3524 NMODES(0)=NMODES(0)+NMODES(I)
3525 270 CONTINUE
3526 ENDIF
3527 280 CONTINUE
3528 290 CONTINUE
3529 DO 370 KFSM=21,37
3530 KFSUSY=KSUSY1+KFSM
3531 NRVDC=0
3532C...NEUTRALINO DECAYS
3533 IF (KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
3534 NRVDC=4
3535 DO 300 I=1,NRVDC
3536 PBRAT(I)=0D0
3537 NMODES(I)=0
3538 300 CONTINUE
3539 CALL PYNAME(KFSUSY,CHTMP)
3540 CHD0=CHTMP//' '
3541 CHDC(1)=DNAME(3) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
3542 CHDC(2)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3543 CHDC(3)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3544 CHDC(4)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3545 KC=PYCOMP(KFSUSY)
3546 DO 310 J=1,MDCY(KC,3)
3547 IDC=J+MDCY(KC,2)-1
3548 ID1=IABS(KFDP(IDC,1))
3549 ID2=IABS(KFDP(IDC,2))
3550 ID3=IABS(KFDP(IDC,3))
3551 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
3552 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.11.OR
3553 & .ID3.EQ.13.OR.ID3.EQ.15)) THEN
3554 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3555 NMODES(1)=NMODES(1)+1
3556 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3557 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3558 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
3559 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
3560 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3561 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3562 NMODES(2)=NMODES(2)+1
3563 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3564 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3565 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3566 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
3567 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3568 PBRAT(3)=PBRAT(3)+BRAT(IDC)
3569 NMODES(3)=NMODES(3)+1
3570 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3571 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3572 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
3573 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
3574 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3575 PBRAT(4)=PBRAT(4)+BRAT(IDC)
3576 NMODES(4)=NMODES(4)+1
3577 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3578 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3579 ENDIF
3580 310 CONTINUE
3581 ENDIF
3582C...CHARGINO DECAYS
3583 IF (KFSM.EQ.24.OR.KFSM.EQ.37) THEN
3584 NRVDC=5
3585 DO 320 I=1,NRVDC
3586 PBRAT(I)=0D0
3587 NMODES(I)=0
3588 320 CONTINUE
3589 CALL PYNAME(KFSUSY,CHTMP)
3590 CHD0=CHTMP//' '
3591 CHDC(1)=DNAME(3) // ' + ' // DNAME(3) // ' + ' // DNAME(2)
3592 CHDC(2)=DNAME(2) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
3593 CHDC(3)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3594 CHDC(4)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3595 CHDC(5)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3596 KC=PYCOMP(KFSUSY)
3597 DO 330 J=1,MDCY(KC,3)
3598 IDC=J+MDCY(KC,2)-1
3599 ID1=IABS(KFDP(IDC,1))
3600 ID2=IABS(KFDP(IDC,2))
3601 ID3=IABS(KFDP(IDC,3))
3602 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
3603 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.12.OR
3604 & .ID3.EQ.14.OR.ID3.EQ.16)) THEN
3605 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3606 NMODES(1)=NMODES(1)+1
3607 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3608 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3609 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
3610 & .(ID2.EQ.12.OR.ID2.EQ.14.OR.ID2.EQ.16).AND.(ID3.EQ
3611 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
3612 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3613 NMODES(1)=NMODES(1)+1
3614 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3615 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3616 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3617 & .(ID2.EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ
3618 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
3619 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3620 NMODES(2)=NMODES(2)+1
3621 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3622 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3623 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
3624 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
3625 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
3626 PBRAT(3)=PBRAT(3)+BRAT(IDC)
3627 NMODES(3)=NMODES(3)+1
3628 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3629 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3630 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
3631 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
3632 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3633 PBRAT(3)=PBRAT(3)+BRAT(IDC)
3634 NMODES(3)=NMODES(3)+1
3635 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3636 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3637 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3638 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
3639 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
3640 PBRAT(4)=PBRAT(4)+BRAT(IDC)
3641 NMODES(4)=NMODES(4)+1
3642 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3643 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3644 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3645 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
3646 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3647 PBRAT(4)=PBRAT(4)+BRAT(IDC)
3648 NMODES(4)=NMODES(4)+1
3649 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3650 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3651 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
3652 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
3653 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3654 PBRAT(5)=PBRAT(5)+BRAT(IDC)
3655 NMODES(5)=NMODES(5)+1
3656 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3657 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3658 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND
3659 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
3660 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3661 PBRAT(5)=PBRAT(5)+BRAT(IDC)
3662 NMODES(5)=NMODES(5)+1
3663 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3664 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3665 ENDIF
3666 330 CONTINUE
3667 ENDIF
3668C...GLUINO DECAYS
3669 IF (KFSM.EQ.21) THEN
3670 NRVDC=3
3671 DO 340 I=1,NRVDC
3672 PBRAT(I)=0D0
3673 NMODES(I)=0
3674 340 CONTINUE
3675 CALL PYNAME(KFSUSY,CHTMP)
3676 CHD0=CHTMP//' '
3677 CHDC(1)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3678 CHDC(2)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3679 CHDC(3)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3680 KC=PYCOMP(KFSUSY)
3681 DO 350 J=1,MDCY(KC,3)
3682 IDC=J+MDCY(KC,2)-1
3683 ID1=IABS(KFDP(IDC,1))
3684 ID2=IABS(KFDP(IDC,2))
3685 ID3=IABS(KFDP(IDC,3))
3686 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
3687 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1.OR
3688 & .ID3.EQ.3.OR.ID3.EQ.5)) THEN
3689 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3690 NMODES(1)=NMODES(1)+1
3691 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3692 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3693 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3694 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
3695 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3696 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3697 NMODES(2)=NMODES(2)+1
3698 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3699 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3700 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
3701 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
3702 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3703 PBRAT(3)=PBRAT(3)+BRAT(IDC)
3704 NMODES(3)=NMODES(3)+1
3705 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3706 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3707 ENDIF
3708 350 CONTINUE
3709 ENDIF
3710
3711 IF (NRVDC.NE.0) THEN
3712 DO 360 I=1,NRVDC
3713 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
3714 NMODES(0)=NMODES(0)+NMODES(I)
3715 360 CONTINUE
3716 ENDIF
3717 370 CONTINUE
3718 WRITE (MSTU(11),8100) NMODES(0), NMODES(10), NMODES(9)
3719
3720 IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
3721 WRITE (MSTU(11),8500)
3722 DO 400 IRV=1,3
3723 DO 390 JRV=1,3
3724 DO 380 KRV=1,3
3725 WRITE (MSTU(11),8700) IRV,JRV,KRV,RVLAM(IRV,JRV,KRV)
3726 & ,RVLAMP(IRV,JRV,KRV),RVLAMB(IRV,JRV,KRV)
3727 380 CONTINUE
3728 390 CONTINUE
3729 400 CONTINUE
3730 WRITE (MSTU(11),8600)
3731 ENDIF
3732 ENDIF
3733
3734C...Formats for printouts.
3735 5000 FORMAT('1',9('*'),1X,'PYSTAT: Statistics on Number of ',
3736 &'Events and Cross-sections',1X,9('*'))
3737 5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
3738 &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
3739 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
3740 &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
3741 &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
3742 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
3743 &'I',12X,'I')
3744 5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
3745 &D10.3,1X,'I')
3746 5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/
3747 &1X,'I',34X,'I',28X,'I',12X,'I')
3748 5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
3749 &1X,'********* Fraction of events that fail fragmentation ',
3750 &'cuts =',1X,F8.5,' *********'/)
3751 5500 FORMAT('1',27('*'),1X,'PYSTAT: Decay Widths and Branching ',
3752 &'Ratios',1X,27('*'))
3753 5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
3754 &1X,'I',5X,'Mother --> Branching/Decay Channel',8X,'I',1X,
3755 &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,
3756 &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
3757 &1X,98('='))
3758 5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
3759 &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X,
3760 &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I')
3761 5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X,
3762 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
3763 &1P,D10.3,0P,1X,'I')
3764 5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X,
3765 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
3766 &1P,D10.3,0P,1X,'I')
3767 6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('='))
3768 6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
3769 &'Particles at Hard Interaction',1X,7('*'))
3770 6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
3771 &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X,
3772 &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X,
3773 &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X,
3774 &78('=')/1X,'I',38X,'I',37X,'I')
3775 6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I')
3776 6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
3777 6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
3778 &'Kinematical Variables',1X,12('*'))
3779 6600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
3780 6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P,
3781 &16X,'I')
3782 6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A,
3783 &1X,'<',1X,1P,D10.3,0P,16X,'I')
3784 6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I')
3785 7000 FORMAT(1X,'I',76X,'I'/1X,78('='))
3786 7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
3787 &'Parameter Values',1X,12('*'))
3788 7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
3789 &'PARP(I)'/)
3790 7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3)
3791 7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes',
3792 &1X,13('*'))
3793 7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X,
3794 &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X,
3795 &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I')
3796 7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I')
3797 7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('='))
3798 8000 FORMAT(1X/ 1X/
3799 & 17X,'Sums over R-Violating branching ratios',1X/ 1X
3800 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I'/1X,'I',4X
3801 & ,'Mother --> Sum over final state flavours',4X,'I',2X
3802 & ,'BR(sum)',2X,'I',2X,'N',2X,'I'/1X,'I',50X,'I',11X,'I',5X,'I'
3803 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I')
3804 8100 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I'/1X,70('=')/1X,'I',1X
3805 & ,'Total number of R-Violating modes :',3X,I5,24X,'I'/
3806 & 1X,'I',1X,'Total number with non-vanishing BR :',2X,I5,24X
3807 & ,'I'/1X,'I',1X,'Total number with BR > 0.001 :',8X,I5,24X,'I'
3808 & /1X,70('='))
3809 8200 FORMAT(1X,'I',1X,A9,1X,'-->',1X,A24,11X,
3810 & 'I',2X,1P,D8.2,0P,1X,'I',2X,I2,1X,'I')
3811 8300 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I')
3812 8500 FORMAT(1X/ 1X/
3813 & 1X,'R-Violating couplings',1X/ 1X /
3814 & 1X,55('=')/
3815 & 1X,'I',1X,'IJK',1X,'I',2X,'LAMBDA(IJK)',2X,'I',2X
3816 & ,'LAMBDA''(IJK)',1X,'I',1X,"LAMBDA''(IJK)",1X,'I'/1X,'I',5X
3817 & ,'I',15X,'I',15X,'I',15X,'I')
3818 8600 FORMAT(1X,55('='))
3819 8700 FORMAT(1X,'I',1X,I1,I1,I1,1X,'I',1X,1P,D13.3,0P,1X,'I',1X,1P
3820 & ,D13.3,0P,1X,'I',1X,1P,D13.3,0P,1X,'I')
3821
3822 RETURN
3823 END
3824
3825C*********************************************************************
3826
3827C...PYINRE
3828C...Calculates full and effective widths of gauge bosons, stores
3829C...masses and widths, rescales coefficients to be used for
3830C...resonance production generation.
3831
3832 SUBROUTINE PYINRE
3833
3834C...Double precision and integer declarations.
3835 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3836 IMPLICIT INTEGER(I-N)
3837 INTEGER PYK,PYCHGE,PYCOMP
3838C...Parameter statement to help give large particle numbers.
3839 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
3840 &KEXCIT=4000000,KDIMEN=5000000)
3841C...Commonblocks.
3842 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3843 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3844 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3845 COMMON/PYDAT4/CHAF(500,2)
3846 CHARACTER CHAF*16
3847 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3848 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3849 COMMON/PYINT1/MINT(400),VINT(400)
3850 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3851 COMMON/PYINT4/MWID(500),WIDS(500,5)
3852 COMMON/PYINT6/PROC(0:500)
3853 CHARACTER PROC*28
3854 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
3855 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
3856 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/
3857C...Local arrays and data.
3858 DIMENSION WDTP(0:400),WDTE(0:400,0:5),WDTPM(0:400),
3859 &WDTEM(0:400,0:5),KCORD(500),PMORD(500)
3860
3861C...Born level couplings in MSSM Higgs doublet sector.
3862 XW=PARU(102)
3863 XWV=XW
3864 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
3865 XW1=1D0-XW
3866 IF(MSTP(4).EQ.2) THEN
3867 TANBE=PARU(141)
3868 RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2
3869 SQMZ=PMAS(23,1)**2
3870 SQMW=PMAS(24,1)**2
3871 SQMH=PMAS(25,1)**2
3872 SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH)
3873 SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE))
3874 SQMHC=SQMA+SQMW
3875 IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN
3876 WRITE(MSTU(11),5000)
3877 STOP
3878 ENDIF
3879 PMAS(35,1)=SQRT(SQMHP)
3880 PMAS(36,1)=SQRT(SQMA)
3881 PMAS(37,1)=SQRT(SQMHC)
3882 ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)*
3883 & (SQMA-SQMZ)))
3884 BESU=ATAN(TANBE)
3885 PARU(142)=1D0
3886 PARU(143)=1D0
3887 PARU(161)=-SIN(ALSU)/COS(BESU)
3888 PARU(162)=COS(ALSU)/SIN(BESU)
3889 PARU(163)=PARU(161)
3890 PARU(164)=SIN(BESU-ALSU)
3891 PARU(165)=PARU(164)
3892 PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW
3893 PARU(171)=COS(ALSU)/COS(BESU)
3894 PARU(172)=SIN(ALSU)/SIN(BESU)
3895 PARU(173)=PARU(171)
3896 PARU(174)=COS(BESU-ALSU)
3897 PARU(175)=PARU(174)
3898 PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)*
3899 & SIN(BESU+ALSU)
3900 PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU)
3901 PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW
3902 PARU(181)=TANBE
3903 PARU(182)=1D0/TANBE
3904 PARU(183)=PARU(181)
3905 PARU(184)=0D0
3906 PARU(185)=PARU(184)
3907 PARU(186)=COS(BESU-ALSU)
3908 PARU(187)=SIN(BESU-ALSU)
3909 PARU(188)=PARU(186)
3910 PARU(189)=PARU(187)
3911 PARU(190)=0D0
3912 PARU(195)=COS(BESU-ALSU)
3913 ENDIF
3914
3915C...Reset effective widths of gauge bosons.
3916 DO 110 I=1,500
3917 DO 100 J=1,5
3918 WIDS(I,J)=1D0
3919 100 CONTINUE
3920 110 CONTINUE
3921
3922C...Order resonances by increasing mass (except Z0 and W+/-).
3923 NRES=0
3924 DO 140 KC=1,500
3925 KF=KCHG(KC,4)
3926 IF(KF.EQ.0) GOTO 140
3927 IF(MWID(KC).EQ.0) GOTO 140
3928 IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN
3929 IF(MSTP(1).LE.3) GOTO 140
3930 ENDIF
3931 IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN
3932 IF(IMSS(1).LE.0) GOTO 140
3933 ENDIF
3934 NRES=NRES+1
3935 PMRES=PMAS(KC,1)
3936 IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0
3937 DO 120 I1=NRES-1,1,-1
3938 IF(PMRES.GE.PMORD(I1)) GOTO 130
3939 KCORD(I1+1)=KCORD(I1)
3940 PMORD(I1+1)=PMORD(I1)
3941 120 CONTINUE
3942 130 KCORD(I1+1)=KC
3943 PMORD(I1+1)=PMRES
3944 140 CONTINUE
3945
3946C...Loop over possible resonances.
3947 DO 180 I=1,NRES
3948 KC=KCORD(I)
3949 KF=KCHG(KC,4)
3950
3951C...Check that no fourth generation channels on by mistake.
3952 IF(MSTP(1).LE.3) THEN
3953 DO 150 J=1,MDCY(KC,3)
3954 IDC=J+MDCY(KC,2)-1
3955 KFA1=IABS(KFDP(IDC,1))
3956 KFA2=IABS(KFDP(IDC,2))
3957 IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR.
3958 & KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18)
3959 & MDME(IDC,1)=-1
3960 150 CONTINUE
3961 ENDIF
3962
3963C...Check that no supersymmetric channels on by mistake.
3964 IF(IMSS(1).LE.0) THEN
3965 DO 160 J=1,MDCY(KC,3)
3966 IDC=J+MDCY(KC,2)-1
3967 KFA1S=IABS(KFDP(IDC,1))/KSUSY1
3968 KFA2S=IABS(KFDP(IDC,2))/KSUSY1
3969 IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2)
3970 & MDME(IDC,1)=-1
3971 160 CONTINUE
3972 ENDIF
3973
3974C...Find mass and evaluate width.
3975 PMR=PMAS(KC,1)
3976 IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1
3977 IF(MWID(KC).EQ.3) MINT(63)=1
3978 CALL PYWIDT(KF,PMR**2,WDTP,WDTE)
3979 MINT(51)=0
3980
3981C...Evaluate suppression factors due to non-simulated channels.
ced15360 3982C...AM
3983C...Protection against division by 0 since rho_21_tc is causing problem here
3984 IF (WDTP(0) .GT. 0.) THEN
3985
3986 IF(KCHG(KC,3).EQ.0) THEN
3987 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+
3988 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
3989 & 2D0*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
3990 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
3991 WIDS(KC,3)=0D0
3992 WIDS(KC,4)=0D0
3993 WIDS(KC,5)=0D0
3994 ELSE
3995 IF(MWID(KC).EQ.3) MINT(63)=1
3996 CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM)
3997 MINT(51)=0
3998 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+
3999 & (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+
4000 & (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+
4001 & WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))/WDTP(0)**2
4002 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
4003 WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))/WDTP(0)
4004 WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+
4005 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
4006 & 2D0*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
4007 WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+
4008 & 2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+
4009 & 2D0*WDTEM(0,4)*WDTEM(0,5))/WDTP(0)**2
4010 ENDIF
4011
2dfa57d1 4012 ENDIF
2dfa57d1 4013C...Set resonance widths and branching ratios;
4014C...also on/off switch for decays.
4015 IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN
4016 PMAS(KC,2)=WDTP(0)
4017 PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2))
4018 IF(MSTP(41).EQ.0.OR.MSTP(41).EQ.1) MDCY(KC,1)=MSTP(41)
4019 DO 170 J=1,MDCY(KC,3)
4020 IDC=J+MDCY(KC,2)-1
4021 BRAT(IDC)=0D0
4022 IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0)
4023 170 CONTINUE
4024 ENDIF
4025 180 CONTINUE
4026
4027C...Flavours of leptoquark: redefine charge and name.
4028 KFLQQ=KFDP(MDCY(42,2),1)
4029 KFLQL=KFDP(MDCY(42,2),2)
4030 KCHG(42,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+
4031 &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL)
4032 LL=1
4033 IF(IABS(KFLQL).EQ.13) LL=2
4034 IF(IABS(KFLQL).EQ.15) LL=3
4035 CHAF(42,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)//
4036 &CHAF(IABS(KFLQL),1)(1:LL)//' '
4037 CHAF(42,2)=CHAF(42,2)(1:4+LL)//'bar '
4038
4039C...Special cases in treatment of gamma*/Z0: redefine process name.
4040 IF(MSTP(43).EQ.1) THEN
4041 PROC(1)='f + fbar -> gamma*'
4042 PROC(15)='f + fbar -> g + gamma*'
4043 PROC(19)='f + fbar -> gamma + gamma*'
4044 PROC(30)='f + g -> f + gamma*'
4045 PROC(35)='f + gamma -> f + gamma*'
4046 ELSEIF(MSTP(43).EQ.2) THEN
4047 PROC(1)='f + fbar -> Z0'
4048 PROC(15)='f + fbar -> g + Z0'
4049 PROC(19)='f + fbar -> gamma + Z0'
4050 PROC(30)='f + g -> f + Z0'
4051 PROC(35)='f + gamma -> f + Z0'
4052 ELSEIF(MSTP(43).EQ.3) THEN
4053 PROC(1)='f + fbar -> gamma*/Z0'
4054 PROC(15)='f + fbar -> g + gamma*/Z0'
4055 PROC(19)='f + fbar -> gamma + gamma*/Z0'
4056 PROC(30)='f + g -> f + gamma*/Z0'
4057 PROC(35)='f + gamma -> f + gamma*/Z0'
4058 ENDIF
4059
4060C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
4061 IF(MSTP(44).EQ.1) THEN
4062 PROC(141)='f + fbar -> gamma*'
4063 ELSEIF(MSTP(44).EQ.2) THEN
4064 PROC(141)='f + fbar -> Z0'
4065 ELSEIF(MSTP(44).EQ.3) THEN
4066 PROC(141)='f + fbar -> Z''0'
4067 ELSEIF(MSTP(44).EQ.4) THEN
4068 PROC(141)='f + fbar -> gamma*/Z0'
4069 ELSEIF(MSTP(44).EQ.5) THEN
4070 PROC(141)='f + fbar -> gamma*/Z''0'
4071 ELSEIF(MSTP(44).EQ.6) THEN
4072 PROC(141)='f + fbar -> Z0/Z''0'
4073 ELSEIF(MSTP(44).EQ.7) THEN
4074 PROC(141)='f + fbar -> gamma*/Z0/Z''0'
4075 ENDIF
4076
4077C...Special cases in treatment of WW -> WW: redefine process name.
4078 IF(MSTP(45).EQ.1) THEN
4079 PROC(77)='W+ + W+ -> W+ + W+'
4080 ELSEIF(MSTP(45).EQ.2) THEN
4081 PROC(77)='W+ + W- -> W+ + W-'
4082 ELSEIF(MSTP(45).EQ.3) THEN
4083 PROC(77)='W+/- + W+/- -> W+/- + W+/-'
4084 ENDIF
4085
4086C...Format for error information.
4087 5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ',
4088 &'combination'/1X,'Execution stopped!')
4089
4090 RETURN
4091 END
4092
4093C*********************************************************************
4094
4095C...PYINBM
4096C...Identifies the two incoming particles and the choice of frame.
4097
4098 SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
4099
4100C...Double precision and integer declarations.
4101 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4102 IMPLICIT INTEGER(I-N)
4103 INTEGER PYK,PYCHGE,PYCOMP
4104
4105C...User process initialization commonblock.
4106 INTEGER MAXPUP
4107 PARAMETER (MAXPUP=100)
4108 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
4109 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
4110 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
4111 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
4112 &LPRUP(MAXPUP)
4113 SAVE /HEPRUP/
4114
4115C...Commonblocks.
4116 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
4117 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4118 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4119 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4120 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4121 COMMON/PYINT1/MINT(400),VINT(400)
4122 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
4123
4124C...Local arrays, character variables and data.
4125 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26,
4126 &CHIDNT(3)*12,CHTEMP*12,CHCDE(39)*12,CHINIT*76,CHNAME*16
4127 DIMENSION LEN(3),KCDE(39),PM(2)
4128 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
4129 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
4130 DATA CHCDE/ 'e- ','e+ ','nu_e ',
4131 &'nu_ebar ','mu- ','mu+ ','nu_mu ',
4132 &'nu_mubar ','tau- ','tau+ ','nu_tau ',
4133 &'nu_taubar ','pi+ ','pi- ','n0 ',
4134 &'nbar0 ','p+ ','pbar- ','gamma ',
4135 &'lambda0 ','sigma- ','sigma0 ','sigma+ ',
4136 &'xi- ','xi0 ','omega- ','pi0 ',
4137 &'reggeon ','pomeron ','gamma/e- ','gamma/e+ ',
4138 &'gamma/mu- ','gamma/mu+ ','gamma/tau- ','gamma/tau+ ',
4139 &'k+ ','k- ','ks0 ','kl0 '/
4140 DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
4141 &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
4142 &3312,3322,3334,111,110,990,6*22,321,-321,310,130/
4143
4144C...Store initial energy. Default frame.
4145 VINT(290)=WIN
4146 MINT(111)=0
4147
4148C...Special user process initialization; convert to normal input.
4149 IF(CHFRAM(1:1).EQ.'u'.OR.CHFRAM(1:1).EQ.'U') THEN
4150 MINT(111)=11
4151 CALL PYNAME(IDBMUP(1),CHNAME)
4152 CHBEAM=CHNAME(1:12)
4153 CALL PYNAME(IDBMUP(2),CHNAME)
4154 CHTARG=CHNAME(1:12)
4155 ENDIF
4156
4157C...Convert character variables to lowercase and find their length.
4158 CHCOM(1)=CHFRAM
4159 CHCOM(2)=CHBEAM
4160 CHCOM(3)=CHTARG
4161 DO 130 I=1,3
4162 LEN(I)=12
4163 DO 110 LL=12,1,-1
4164 IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
4165 DO 100 LA=1,26
4166 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
4167 & CHALP(1)(LA:LA)
4168 100 CONTINUE
4169 110 CONTINUE
4170 CHIDNT(I)=CHCOM(I)
4171
4172C...Fix up bar, underscore and charge in particle name (if needed).
4173 DO 120 LL=1,10
4174 IF(CHIDNT(I)(LL:LL).EQ.'~') THEN
4175 CHTEMP=CHIDNT(I)
4176 CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:10)//' '
4177 ENDIF
4178 120 CONTINUE
4179 IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN
4180 CHTEMP=CHIDNT(I)
4181 CHIDNT(I)='nu_'//CHTEMP(3:7)
4182 ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN
4183 CHIDNT(I)(1:3)='n0 '
4184 ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN
4185 CHIDNT(I)(1:5)='nbar0'
4186 ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN
4187 CHIDNT(I)(1:3)='p+ '
4188 ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR.
4189 & CHIDNT(I)(1:2).EQ.'p-') THEN
4190 CHIDNT(I)(1:5)='pbar-'
4191 ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN
4192 CHIDNT(I)(7:7)='0'
4193 ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN
4194 CHIDNT(I)(1:7)='reggeon'
4195 ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN
4196 CHIDNT(I)(1:7)='pomeron'
4197 ENDIF
4198 130 CONTINUE
4199
4200C...Identify free initialization.
4201 IF(CHCOM(1)(1:2).EQ.'no') THEN
4202 MINT(65)=1
4203 RETURN
4204 ENDIF
4205
4206C...Identify incoming beam and target particles.
4207 DO 160 I=1,2
4208 DO 140 J=1,39
4209 IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J)
4210 140 CONTINUE
4211 PM(I)=PYMASS(MINT(10+I))
4212 VINT(2+I)=PM(I)
4213 MINT(140+I)=0
4214 IF(MINT(10+I).EQ.22.AND.CHIDNT(I+1)(6:6).EQ.'/') THEN
4215 CHTEMP=CHIDNT(I+1)(7:12)//' '
4216 DO 150 J=1,12
4217 IF(CHTEMP.EQ.CHCDE(J)) MINT(140+I)=KCDE(J)
4218 150 CONTINUE
4219 PM(I)=PYMASS(MINT(140+I))
4220 VINT(302+I)=PM(I)
4221 ENDIF
4222 160 CONTINUE
4223 IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2))
4224 IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3))
4225 IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) STOP
4226
4227C...Identify choice of frame and input energies.
4228 CHINIT=' '
4229
4230C...Events defined in the CM frame.
4231 IF(CHCOM(1)(1:2).EQ.'cm') THEN
4232 MINT(111)=1
4233 S=WIN**2
4234 IF(MSTP(122).GE.1) THEN
4235 IF(CHCOM(2)(1:1).NE.'e') THEN
4236 LOFFS=(31-(LEN(2)+LEN(3)))/2
4237 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
4238 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4239 & ' collider'//' '
4240 ELSE
4241 LOFFS=(30-(LEN(2)+LEN(3)))/2
4242 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
4243 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4244 & ' collider'//' '
4245 ENDIF
4246 WRITE(MSTU(11),5200) CHINIT
4247 WRITE(MSTU(11),5300) WIN
4248 ENDIF
4249
4250C...Events defined in fixed target frame.
4251 ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
4252 MINT(111)=2
4253 S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2)
4254 IF(MSTP(122).GE.1) THEN
4255 LOFFS=(29-(LEN(2)+LEN(3)))/2
4256 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4257 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4258 & ' fixed target'//' '
4259 WRITE(MSTU(11),5200) CHINIT
4260 WRITE(MSTU(11),5400) WIN
4261 WRITE(MSTU(11),5500) SQRT(S)
4262 ENDIF
4263
4264C...Frame defined by user three-vectors.
4265 ELSEIF(CHCOM(1)(1:1).EQ.'3') THEN
4266 MINT(111)=3
4267 P(1,5)=PM(1)
4268 P(2,5)=PM(2)
4269 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
4270 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
4271 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
4272 & (P(1,3)+P(2,3))**2
4273 IF(MSTP(122).GE.1) THEN
4274 LOFFS=(22-(LEN(2)+LEN(3)))/2
4275 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4276 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4277 & ' user configuration'//' '
4278 WRITE(MSTU(11),5200) CHINIT
4279 WRITE(MSTU(11),5600)
4280 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
4281 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
4282 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
4283 ENDIF
4284
4285C...Frame defined by user four-vectors.
4286 ELSEIF(CHCOM(1)(1:1).EQ.'4') THEN
4287 MINT(111)=4
4288 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
4289 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
4290 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
4291 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
4292 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
4293 & (P(1,3)+P(2,3))**2
4294 IF(MSTP(122).GE.1) THEN
4295 LOFFS=(22-(LEN(2)+LEN(3)))/2
4296 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4297 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4298 & ' user configuration'//' '
4299 WRITE(MSTU(11),5200) CHINIT
4300 WRITE(MSTU(11),5600)
4301 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
4302 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
4303 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
4304 ENDIF
4305
4306C...Frame defined by user five-vectors.
4307 ELSEIF(CHCOM(1)(1:1).EQ.'5') THEN
4308 MINT(111)=5
4309 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
4310 & (P(1,3)+P(2,3))**2
4311 IF(MSTP(122).GE.1) THEN
4312 LOFFS=(22-(LEN(2)+LEN(3)))/2
4313 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4314 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4315 & ' user configuration'//' '
4316 WRITE(MSTU(11),5200) CHINIT
4317 WRITE(MSTU(11),5600)
4318 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
4319 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
4320 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
4321 ENDIF
4322
4323C...Frame defined by HEPRUP common block.
4324 ELSEIF(MINT(111).EQ.11) THEN
4325 S=(EBMUP(1)+EBMUP(2))**2-(SQRT(MAX(0D0,EBMUP(1)**2-PM(1)**2))-
4326 & SQRT(MAX(0D0,EBMUP(2)**2-PM(2)**2)))**2
4327 IF(MSTP(122).GE.1) THEN
4328 LOFFS=(22-(LEN(2)+LEN(3)))/2
4329 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4330 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4331 & ' user configuration'//' '
4332 WRITE(MSTU(11),5200) CHINIT
4333 WRITE(MSTU(11),6000) EBMUP(1),EBMUP(2)
4334 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
4335 ENDIF
4336
4337C...Unknown frame. Error for too low CM energy.
4338 ELSE
4339 WRITE(MSTU(11),5800) CHFRAM(1:LEN(1))
4340 STOP
4341 ENDIF
4342 IF(S.LT.PARP(2)**2) THEN
4343 WRITE(MSTU(11),5900) SQRT(S)
4344 STOP
4345 ENDIF
4346
4347C...Formats for initialization and error information.
4348 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/
4349 &1X,'Execution stopped!')
4350 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/
4351 &1X,'Execution stopped!')
4352 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
4353 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
4354 &19X,'I'/1X,'I',76X,'I'/1X,78('='))
4355 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
4356 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
4357 &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
4358 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X,
4359 &'pz (GeV/c)',6X,'E (GeV)',9X,'I')
4360 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I')
4361 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/
4362 &1X,'Execution stopped!')
4363 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
4364 &'generation.'/1X,'Execution stopped!')
4365 6000 FORMAT(1X,'I',12X,'with',1X,F10.3,1X,'GeV on',1X,F10.3,1X,
4366 &'GeV beam energies',13X,'I')
4367
4368 RETURN
4369 END
4370
4371C*********************************************************************
4372
4373C...PYINKI
4374C...Sets up kinematics, including rotations and boosts to/from CM frame.
4375
4376 SUBROUTINE PYINKI(MODKI)
4377
4378C...Double precision and integer declarations.
4379 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4380 IMPLICIT INTEGER(I-N)
4381 INTEGER PYK,PYCHGE,PYCOMP
4382
4383C...User process initialization commonblock.
4384 INTEGER MAXPUP
4385 PARAMETER (MAXPUP=100)
4386 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
4387 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
4388 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
4389 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
4390 &LPRUP(MAXPUP)
4391 SAVE /HEPRUP/
4392
4393C...Commonblocks.
4394 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
4395 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4396 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4397 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4398 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4399 COMMON/PYINT1/MINT(400),VINT(400)
4400 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
4401
4402C...Set initial flavour state.
4403 N=2
4404 DO 100 I=1,2
4405 K(I,1)=1
4406 K(I,2)=MINT(10+I)
4407 IF(MINT(140+I).NE.0) K(I,2)=MINT(140+I)
4408 100 CONTINUE
4409
4410C...Reset boost. Do kinematics for various cases.
4411 DO 110 J=6,10
4412 VINT(J)=0D0
4413 110 CONTINUE
4414
4415C...Set up kinematics for events defined in CM frame.
4416 IF(MINT(111).EQ.1) THEN
4417 WIN=VINT(290)
4418 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
4419 S=WIN**2
4420 P(1,5)=VINT(3)
4421 P(2,5)=VINT(4)
4422 IF(MINT(141).NE.0) P(1,5)=VINT(303)
4423 IF(MINT(142).NE.0) P(2,5)=VINT(304)
4424 P(1,1)=0D0
4425 P(1,2)=0D0
4426 P(2,1)=0D0
4427 P(2,2)=0D0
4428 P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/
4429 & (4D0*S))
4430 P(2,3)=-P(1,3)
4431 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
4432 P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
4433
4434C...Set up kinematics for fixed target events.
4435 ELSEIF(MINT(111).EQ.2) THEN
4436 WIN=VINT(290)
4437 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
4438 P(1,5)=VINT(3)
4439 P(2,5)=VINT(4)
4440 IF(MINT(141).NE.0) P(1,5)=VINT(303)
4441 IF(MINT(142).NE.0) P(2,5)=VINT(304)
4442 P(1,1)=0D0
4443 P(1,2)=0D0
4444 P(2,1)=0D0
4445 P(2,2)=0D0
4446 P(1,3)=WIN
4447 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
4448 P(2,3)=0D0
4449 P(2,4)=P(2,5)
4450 S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4)
4451 VINT(10)=P(1,3)/(P(1,4)+P(2,4))
4452 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
4453
4454C...Set up kinematics for events in user-defined frame.
4455 ELSEIF(MINT(111).EQ.3) THEN
4456 P(1,5)=VINT(3)
4457 P(2,5)=VINT(4)
4458 IF(MINT(141).NE.0) P(1,5)=VINT(303)
4459 IF(MINT(142).NE.0) P(2,5)=VINT(304)
4460 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
4461 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
4462 DO 120 J=1,3
4463 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
4464 120 CONTINUE
4465 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
4466 VINT(7)=PYANGL(P(1,1),P(1,2))
4467 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
4468 VINT(6)=PYANGL(P(1,3),P(1,1))
4469 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
4470 S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
4471
4472C...Set up kinematics for events with user-defined four-vectors.
4473 ELSEIF(MINT(111).EQ.4) THEN
4474 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
4475 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
4476 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
4477 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
4478 DO 130 J=1,3
4479 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
4480 130 CONTINUE
4481 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
4482 VINT(7)=PYANGL(P(1,1),P(1,2))
4483 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
4484 VINT(6)=PYANGL(P(1,3),P(1,1))
4485 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
4486 S=(P(1,4)+P(2,4))**2
4487
4488C...Set up kinematics for events with user-defined five-vectors.
4489 ELSEIF(MINT(111).EQ.5) THEN
4490 DO 140 J=1,3
4491 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
4492 140 CONTINUE
4493 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
4494 VINT(7)=PYANGL(P(1,1),P(1,2))
4495 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
4496 VINT(6)=PYANGL(P(1,3),P(1,1))
4497 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
4498 S=(P(1,4)+P(2,4))**2
4499
4500C...Set up kinematics for events with external user processes.
4501 ELSEIF(MINT(111).EQ.11) THEN
4502 P(1,5)=VINT(3)
4503 P(2,5)=VINT(4)
4504 IF(MINT(141).NE.0) P(1,5)=VINT(303)
4505 IF(MINT(142).NE.0) P(2,5)=VINT(304)
4506 P(1,1)=0D0
4507 P(1,2)=0D0
4508 P(2,1)=0D0
4509 P(2,2)=0D0
4510 P(1,3)=SQRT(MAX(0D0,EBMUP(1)**2-P(1,5)**2))
4511 P(2,3)=-SQRT(MAX(0D0,EBMUP(2)**2-P(2,5)**2))
4512 P(1,4)=EBMUP(1)
4513 P(2,4)=EBMUP(2)
4514 VINT(10)=(P(1,3)+P(2,3))/(P(1,4)+P(2,4))
4515 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
4516 S=(P(1,4)+P(2,4))**2
4517 ENDIF
4518
4519C...Return or error for too low CM energy.
4520 IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN
4521 IF(MSTP(172).LE.1) THEN
4522 CALL PYERRM(23,
4523 & '(PYINKI:) too low invariant mass in this event')
4524 ELSE
4525 MSTI(61)=1
4526 RETURN
4527 ENDIF
4528 ENDIF
4529
4530C...Save information on incoming particles.
4531 VINT(1)=SQRT(S)
4532 VINT(2)=S
4533 IF(MINT(111).GE.4) THEN
4534 IF(MINT(141).EQ.0) THEN
4535 VINT(3)=P(1,5)
4536 IF(MINT(11).EQ.22.AND.P(1,5).LT.0) VINT(307)=P(1,5)**2
4537 ELSE
4538 VINT(303)=P(1,5)
4539 ENDIF
4540 IF(MINT(142).EQ.0) THEN
4541 VINT(4)=P(2,5)
4542 IF(MINT(12).EQ.22.AND.P(2,5).LT.0) VINT(308)=P(2,5)**2
4543 ELSE
4544 VINT(304)=P(2,5)
4545 ENDIF
4546 ENDIF
4547 VINT(5)=P(1,3)
4548 IF(MODKI.EQ.0) VINT(289)=S
4549 DO 150 J=1,5
4550 V(1,J)=0D0
4551 V(2,J)=0D0
4552 VINT(290+J)=P(1,J)
4553 VINT(295+J)=P(2,J)
4554 150 CONTINUE
4555
4556C...Store pT cut-off and related constants to be used in generation.
4557 IF(MODKI.EQ.0) VINT(285)=CKIN(3)
4558 IF(MSTP(82).LE.1) THEN
4559 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
4560 ELSE
4561 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
4562 ENDIF
4563 VINT(149)=4D0*PTMN**2/S
4564 VINT(154)=PTMN
4565
4566 RETURN
4567 END
4568
4569C*********************************************************************
4570
4571C...PYINPR
4572C...Selects partonic subprocesses to be included in the simulation.
4573
4574 SUBROUTINE PYINPR
4575
4576C...Double precision and integer declarations.
4577 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4578 IMPLICIT INTEGER(I-N)
4579 INTEGER PYK,PYCHGE,PYCOMP
4580
4581C...User process initialization commonblock.
4582 INTEGER MAXPUP
4583 PARAMETER (MAXPUP=100)
4584 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
4585 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
4586 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
4587 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
4588 &LPRUP(MAXPUP)
4589 SAVE /HEPRUP/
4590
4591C...Commonblocks and character variables.
4592 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4593 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
4594 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4595 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4596 COMMON/PYINT1/MINT(400),VINT(400)
4597 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4598 COMMON/PYINT6/PROC(0:500)
4599 CHARACTER PROC*28
4600 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
4601 &/PYINT6/
4602 CHARACTER CHIPR*10
4603
4604C...Reset processes to be included.
4605 IF(MSEL.NE.0) THEN
4606 DO 100 I=1,500
4607 MSUB(I)=0
4608 100 CONTINUE
4609 ENDIF
4610
4611C...Set running pTmin scale.
4612 IF(MSTP(82).LE.1) THEN
4613 PTMRUN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
4614 ELSE
4615 PTMRUN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
4616 ENDIF
4617
4618C...Begin by assuming incoming photon to enter subprocess.
4619 IF(MINT(11).EQ.22) MINT(15)=22
4620 IF(MINT(12).EQ.22) MINT(16)=22
4621
4622C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous.
4623 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
4624 MSUB(10)=1
4625 MINT(123)=MINT(122)+1
4626
4627C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30
4628C...allow mixture.
4629C...Here also set a few parameters otherwise normally not touched.
4630 ELSEIF(MINT(121).GT.1) THEN
4631
4632C...Parton distributions dampened at small Q2; go to low energies,
4633C...alpha_s <1; no minimum pT cut-off a priori.
4634 IF(MSTP(18).EQ.2) THEN
4635 MSTP(57)=3
4636 PARP(2)=2D0
4637 PARU(115)=1D0
4638 CKIN(5)=0.2D0
4639 CKIN(6)=0.2D0
4640 ENDIF
4641
4642C...Define pT cut-off parameters and whether run involves low-pT.
4643 PTMVMD=PTMRUN
4644 VINT(154)=PTMVMD
4645 PTMDIR=PTMVMD
4646 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
4647 PTMANO=PTMVMD
4648 IF(MSTP(15).EQ.5) PTMANO=0.60D0+
4649 & 0.125D0*LOG(1D0+0.10D0*VINT(1))**2
4650 IPTL=1
4651 IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0
4652 IF(MSEL.EQ.2) IPTL=1
4653
4654C...Set up for p/gamma * gamma; real or virtual photons.
4655 IF(MINT(121).EQ.3.OR.MINT(121).EQ.6.OR.(MINT(121).EQ.4.AND.
4656 & MSTP(14).EQ.30)) THEN
4657
4658C...Set up for p/VMD * VMD.
4659 IF(MINT(122).EQ.1) THEN
4660 MINT(123)=2
4661 MSUB(11)=1
4662 MSUB(12)=1
4663 MSUB(13)=1
4664 MSUB(28)=1
4665 MSUB(53)=1
4666 MSUB(68)=1
4667 IF(IPTL.EQ.1) MSUB(95)=1
4668 IF(MSEL.EQ.2) THEN
4669 MSUB(91)=1
4670 MSUB(92)=1
4671 MSUB(93)=1
4672 MSUB(94)=1
4673 ENDIF
4674 IF(IPTL.EQ.1) CKIN(3)=0D0
4675
4676C...Set up for p/VMD * direct gamma.
4677 ELSEIF(MINT(122).EQ.2) THEN
4678 MINT(123)=0
4679 IF(MINT(121).EQ.6) MINT(123)=5
4680 MSUB(131)=1
4681 MSUB(132)=1
4682 MSUB(135)=1
4683 MSUB(136)=1
4684 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4685
4686C...Set up for p/VMD * anomalous gamma.
4687 ELSEIF(MINT(122).EQ.3) THEN
4688 MINT(123)=3
4689 IF(MINT(121).EQ.6) MINT(123)=7
4690 MSUB(11)=1
4691 MSUB(12)=1
4692 MSUB(13)=1
4693 MSUB(28)=1
4694 MSUB(53)=1
4695 MSUB(68)=1
4696 IF(IPTL.EQ.1) MSUB(95)=1
4697 IF(MSEL.EQ.2) THEN
4698 MSUB(91)=1
4699 MSUB(92)=1
4700 MSUB(93)=1
4701 MSUB(94)=1
4702 ENDIF
4703 IF(IPTL.EQ.1) CKIN(3)=0D0
4704
4705C...Set up for DIS * p.
4706 ELSEIF(MINT(122).EQ.4.AND.(IABS(MINT(11)).GT.100.OR.
4707 & IABS(MINT(12)).GT.100)) THEN
4708 MINT(123)=8
4709 IF(IPTL.EQ.1) MSUB(99)=1
4710
4711C...Set up for direct * direct gamma (switch off leptons).
4712 ELSEIF(MINT(122).EQ.4) THEN
4713 MINT(123)=0
4714 MSUB(137)=1
4715 MSUB(138)=1
4716 MSUB(139)=1
4717 MSUB(140)=1
4718 DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
4719 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
4720 110 CONTINUE
4721 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4722
4723C...Set up for direct * anomalous gamma.
4724 ELSEIF(MINT(122).EQ.5) THEN
4725 MINT(123)=6
4726 MSUB(131)=1
4727 MSUB(132)=1
4728 MSUB(135)=1
4729 MSUB(136)=1
4730 IF(IPTL.EQ.1) CKIN(3)=PTMANO
4731
4732C...Set up for anomalous * anomalous gamma.
4733 ELSEIF(MINT(122).EQ.6) THEN
4734 MINT(123)=3
4735 MSUB(11)=1
4736 MSUB(12)=1
4737 MSUB(13)=1
4738 MSUB(28)=1
4739 MSUB(53)=1
4740 MSUB(68)=1
4741 IF(IPTL.EQ.1) MSUB(95)=1
4742 IF(MSEL.EQ.2) THEN
4743 MSUB(91)=1
4744 MSUB(92)=1
4745 MSUB(93)=1
4746 MSUB(94)=1
4747 ENDIF
4748 IF(IPTL.EQ.1) CKIN(3)=0D0
4749 ENDIF
4750
4751C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom.
4752 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
4753
4754C...Set up for direct * direct gamma (switch off leptons).
4755 IF(MINT(122).EQ.1) THEN
4756 MINT(123)=0
4757 MSUB(137)=1
4758 MSUB(138)=1
4759 MSUB(139)=1
4760 MSUB(140)=1
4761 DO 120 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
4762 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
4763 120 CONTINUE
4764 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4765
4766C...Set up for direct * VMD and VMD * direct gamma.
4767 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.4) THEN
4768 MINT(123)=5
4769 MSUB(131)=1
4770 MSUB(132)=1
4771 MSUB(135)=1
4772 MSUB(136)=1
4773 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4774
4775C...Set up for direct * anomalous and anomalous * direct gamma.
4776 ELSEIF(MINT(122).EQ.3.OR.MINT(122).EQ.7) THEN
4777 MINT(123)=6
4778 MSUB(131)=1
4779 MSUB(132)=1
4780 MSUB(135)=1
4781 MSUB(136)=1
4782 IF(IPTL.EQ.1) CKIN(3)=PTMANO
4783
4784C...Set up for VMD*VMD.
4785 ELSEIF(MINT(122).EQ.5) THEN
4786 MINT(123)=2
4787 MSUB(11)=1
4788 MSUB(12)=1
4789 MSUB(13)=1
4790 MSUB(28)=1
4791 MSUB(53)=1
4792 MSUB(68)=1
4793 IF(IPTL.EQ.1) MSUB(95)=1
4794 IF(MSEL.EQ.2) THEN
4795 MSUB(91)=1
4796 MSUB(92)=1
4797 MSUB(93)=1
4798 MSUB(94)=1
4799 ENDIF
4800 IF(IPTL.EQ.1) CKIN(3)=0D0
4801
4802C...Set up for VMD * anomalous and anomalous * VMD gamma.
4803 ELSEIF(MINT(122).EQ.6.OR.MINT(122).EQ.8) THEN
4804 MINT(123)=7
4805 MSUB(11)=1
4806 MSUB(12)=1
4807 MSUB(13)=1
4808 MSUB(28)=1
4809 MSUB(53)=1
4810 MSUB(68)=1
4811 IF(IPTL.EQ.1) MSUB(95)=1
4812 IF(MSEL.EQ.2) THEN
4813 MSUB(91)=1
4814 MSUB(92)=1
4815 MSUB(93)=1
4816 MSUB(94)=1
4817 ENDIF
4818 IF(IPTL.EQ.1) CKIN(3)=0D0
4819
4820C...Set up for anomalous * anomalous gamma.
4821 ELSEIF(MINT(122).EQ.9) THEN
4822 MINT(123)=3
4823 MSUB(11)=1
4824 MSUB(12)=1
4825 MSUB(13)=1
4826 MSUB(28)=1
4827 MSUB(53)=1
4828 MSUB(68)=1
4829 IF(IPTL.EQ.1) MSUB(95)=1
4830 IF(MSEL.EQ.2) THEN
4831 MSUB(91)=1
4832 MSUB(92)=1
4833 MSUB(93)=1
4834 MSUB(94)=1
4835 ENDIF
4836 IF(IPTL.EQ.1) CKIN(3)=0D0
4837
4838C...Set up for DIS * VMD and VMD * DIS gamma.
4839 ELSEIF(MINT(122).EQ.10.OR.MINT(122).EQ.12) THEN
4840 MINT(123)=8
4841 IF(IPTL.EQ.1) MSUB(99)=1
4842
4843C...Set up for DIS * anomalous and anomalous * DIS gamma.
4844 ELSEIF(MINT(122).EQ.11.OR.MINT(122).EQ.13) THEN
4845 MINT(123)=9
4846 IF(IPTL.EQ.1) MSUB(99)=1
4847 ENDIF
4848
4849C...Set up for gamma* * p; virtual photons = dir, res.
4850 ELSEIF(MINT(121).EQ.2) THEN
4851
4852C...Set up for direct * p.
4853 IF(MINT(122).EQ.1) THEN
4854 MINT(123)=0
4855 MSUB(131)=1
4856 MSUB(132)=1
4857 MSUB(135)=1
4858 MSUB(136)=1
4859 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4860
4861C...Set up for resolved * p.
4862 ELSEIF(MINT(122).EQ.2) THEN
4863 MINT(123)=1
4864 MSUB(11)=1
4865 MSUB(12)=1
4866 MSUB(13)=1
4867 MSUB(28)=1
4868 MSUB(53)=1
4869 MSUB(68)=1
4870 IF(IPTL.EQ.1) MSUB(95)=1
4871 IF(MSEL.EQ.2) THEN
4872 MSUB(91)=1
4873 MSUB(92)=1
4874 MSUB(93)=1
4875 MSUB(94)=1
4876 ENDIF
4877 IF(IPTL.EQ.1) CKIN(3)=0D0
4878 ENDIF
4879
4880C...Set up for gamma* * gamma*; virtual photons = dir, res.
4881 ELSEIF(MINT(121).EQ.4) THEN
4882
4883C...Set up for direct * direct gamma (switch off leptons).
4884 IF(MINT(122).EQ.1) THEN
4885 MINT(123)=0
4886 MSUB(137)=1
4887 MSUB(138)=1
4888 MSUB(139)=1
4889 MSUB(140)=1
4890 DO 130 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
4891 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
4892 130 CONTINUE
4893 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4894
4895C...Set up for direct * resolved and resolved * direct gamma.
4896 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.3) THEN
4897 MINT(123)=5
4898 MSUB(131)=1
4899 MSUB(132)=1
4900 MSUB(135)=1
4901 MSUB(136)=1
4902 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4903
4904C...Set up for resolved * resolved gamma.
4905 ELSEIF(MINT(122).EQ.4) THEN
4906 MINT(123)=2
4907 MSUB(11)=1
4908 MSUB(12)=1
4909 MSUB(13)=1
4910 MSUB(28)=1
4911 MSUB(53)=1
4912 MSUB(68)=1
4913 IF(IPTL.EQ.1) MSUB(95)=1
4914 IF(MSEL.EQ.2) THEN
4915 MSUB(91)=1
4916 MSUB(92)=1
4917 MSUB(93)=1
4918 MSUB(94)=1
4919 ENDIF
4920 IF(IPTL.EQ.1) CKIN(3)=0D0
4921 ENDIF
4922
4923C...End of special set up for gamma-p and gamma-gamma.
4924 ENDIF
4925 CKIN(1)=2D0*CKIN(3)
4926 ENDIF
4927
4928C...Flavour information for individual beams.
4929 DO 140 I=1,2
4930 MINT(40+I)=1
4931 IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2
4932 IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2
4933 MINT(44+I)=MINT(40+I)
4934 IF(MSTP(11).GE.1.AND.(IABS(MINT(10+I)).EQ.11.OR.
4935 & IABS(MINT(10+I)).EQ.13.OR.IABS(MINT(10+I)).EQ.15)) MINT(44+I)=3
4936 140 CONTINUE
4937
4938C...If two real gammas, whereof one direct, pick the first.
4939C...For two virtual photons, keep requested order.
4940 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
4941 IF(MSTP(14).LE.10.AND.MINT(123).GE.4.AND.MINT(123).LE.6) THEN
4942 MINT(41)=1
4943 MINT(45)=1
4944 ELSEIF(MSTP(14).EQ.12.OR.MSTP(14).EQ.13.OR.MSTP(14).EQ.22.OR.
4945 & MSTP(14).EQ.26.OR.MSTP(14).EQ.27) THEN
4946 MINT(41)=1
4947 MINT(45)=1
4948 ELSEIF(MSTP(14).EQ.14.OR.MSTP(14).EQ.17.OR.MSTP(14).EQ.23.OR.
4949 & MSTP(14).EQ.28.OR.MSTP(14).EQ.29) THEN
4950 MINT(42)=1
4951 MINT(46)=1
4952 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.2
4953 & .OR.MINT(122).EQ.3.OR.MINT(122).EQ.10.OR.MINT(122).EQ.11)) THEN
4954 MINT(41)=1
4955 MINT(45)=1
4956 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.4
4957 & .OR.MINT(122).EQ.7.OR.MINT(122).EQ.12.OR.MINT(122).EQ.13)) THEN
4958 MINT(42)=1
4959 MINT(46)=1
4960 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.2) THEN
4961 MINT(41)=1
4962 MINT(45)=1
4963 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.3) THEN
4964 MINT(42)=1
4965 MINT(46)=1
4966 ENDIF
4967 ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN
4968 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28.OR.MINT(122).EQ.4) THEN
4969 IF(MINT(11).EQ.22) THEN
4970 MINT(41)=1
4971 MINT(45)=1
4972 ELSE
4973 MINT(42)=1
4974 MINT(46)=1
4975 ENDIF
4976 ENDIF
4977 IF(MINT(123).GE.4.AND.MINT(123).LE.7) CALL PYERRM(26,
4978 & '(PYINPR:) unallowed MSTP(14) code for single photon')
4979 ENDIF
4980
4981C...Flavour information on combination of incoming particles.
4982 MINT(43)=2*MINT(41)+MINT(42)-2
4983 MINT(44)=MINT(43)
4984 IF(MINT(123).LE.0) THEN
4985 IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2
4986 IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1
4987 ELSEIF(MINT(123).LE.3) THEN
4988 IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2
4989 IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1
4990 ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
4991 MINT(43)=4
4992 MINT(44)=1
4993 ENDIF
4994 MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2
4995 IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5
4996 IF(MINT(45).EQ.1.AND.MINT(46).EQ.3) MINT(47)=6
4997 IF(MINT(45).EQ.3.AND.MINT(46).EQ.1) MINT(47)=7
4998 MINT(50)=0
4999 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) MINT(50)=1
5000 MINT(107)=0
5001 MINT(108)=0
5002 IF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
5003 IF((MINT(122).GE.4.AND.MINT(122).LE.6).OR.MINT(122).EQ.12)
5004 & MINT(107)=2
5005 IF((MINT(122).GE.7.AND.MINT(122).LE.9).OR.MINT(122).EQ.13)
5006 & MINT(107)=3
5007 IF(MINT(122).EQ.10.OR.MINT(122).EQ.11) MINT(107)=4
5008 IF(MINT(122).EQ.2.OR.MINT(122).EQ.5.OR.MINT(122).EQ.8.OR.
5009 & MINT(122).EQ.10) MINT(108)=2
5010 IF(MINT(122).EQ.3.OR.MINT(122).EQ.6.OR.MINT(122).EQ.9.OR.
5011 & MINT(122).EQ.11) MINT(108)=3
5012 IF(MINT(122).EQ.12.OR.MINT(122).EQ.13) MINT(108)=4
5013 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.25) THEN
5014 IF(MINT(122).GE.3) MINT(107)=1
5015 IF(MINT(122).EQ.2.OR.MINT(122).EQ.4) MINT(108)=1
5016 ELSEIF(MINT(121).EQ.2) THEN
5017 IF(MINT(122).EQ.2.AND.MINT(11).EQ.22) MINT(107)=1
5018 IF(MINT(122).EQ.2.AND.MINT(12).EQ.22) MINT(108)=1
5019 ELSE
5020 IF(MINT(11).EQ.22) THEN
5021 MINT(107)=MINT(123)
5022 IF(MINT(123).GE.4) MINT(107)=0
5023 IF(MINT(123).EQ.7) MINT(107)=2
5024 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.27) MINT(107)=4
5025 IF(MSTP(14).EQ.28) MINT(107)=2
5026 IF(MSTP(14).EQ.29) MINT(107)=3
5027 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
5028 & MINT(107)=4
5029 ENDIF
5030 IF(MINT(12).EQ.22) THEN
5031 MINT(108)=MINT(123)
5032 IF(MINT(123).GE.4) MINT(108)=MINT(123)-3
5033 IF(MINT(123).EQ.7) MINT(108)=3
5034 IF(MSTP(14).EQ.26) MINT(108)=2
5035 IF(MSTP(14).EQ.27) MINT(108)=3
5036 IF(MSTP(14).EQ.28.OR.MSTP(14).EQ.29) MINT(108)=4
5037 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
5038 & MINT(108)=4
5039 ENDIF
5040 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.(MSTP(14).EQ.14.OR.
5041 & MSTP(14).EQ.17.OR.MSTP(14).EQ.18.OR.MSTP(14).EQ.23)) THEN
5042 MINTTP=MINT(107)
5043 MINT(107)=MINT(108)
5044 MINT(108)=MINTTP
5045 ENDIF
5046 ENDIF
5047 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
5048 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
5049
5050C...Select default processes according to incoming beams
5051C...(already done for gamma-p and gamma-gamma with
5052C...MSTP(14) = 10, 20, 25 or 30).
5053 IF(MINT(121).GT.1) THEN
5054 ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN
5055
5056 IF(MINT(43).EQ.1) THEN
5057C...Lepton + lepton -> gamma/Z0 or W.
5058 IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
5059 IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
5060
5061 ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND.
5062 & (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN
5063C...Unresolved photon + lepton: Compton scattering.
5064 MSUB(133)=1
5065 MSUB(134)=1
5066
5067 ELSEIF((MINT(123).EQ.8.OR.MINT(123).EQ.9).AND.(MINT(11).EQ.22
5068 & .OR.MINT(12).EQ.22)) THEN
5069C...DIS as pure gamma* + f -> f process.
5070 MSUB(99)=1
5071
5072 ELSEIF(MINT(43).LE.3) THEN
5073C...Lepton + hadron: deep inelastic scattering.
5074 MSUB(10)=1
5075
5076 ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND.
5077 & MINT(12).EQ.22) THEN
5078C...Two unresolved photons: fermion pair production,
5079C...exclude lepton pairs.
5080 DO 150 ISUB=137,140
5081 MSUB(ISUB)=1
5082 150 CONTINUE
5083 DO 160 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
5084 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
5085 160 CONTINUE
5086 PTMDIR=PTMRUN
5087 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
5088 IF(CKIN(3).LT.PTMRUN.OR.MSEL.EQ.2) CKIN(3)=PTMDIR
5089 CKIN(1)=MAX(CKIN(1),2D0*CKIN(3))
5090
5091 ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22))
5092 & .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND.
5093 & MINT(12).EQ.22)) THEN
5094C...Unresolved photon + hadron: photon-parton scattering.
5095 DO 170 ISUB=131,136
5096 MSUB(ISUB)=1
5097 170 CONTINUE
5098
5099 ELSEIF(MSEL.EQ.1) THEN
5100C...High-pT QCD processes:
5101 MSUB(11)=1
5102 MSUB(12)=1
5103 MSUB(13)=1
5104 MSUB(28)=1
5105 MSUB(53)=1
5106 MSUB(68)=1
5107 PTMN=PTMRUN
5108 VINT(154)=PTMN
5109 IF(CKIN(3).LT.PTMN) MSUB(95)=1
5110 IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0
5111
5112 ELSE
5113C...All QCD processes:
5114 MSUB(11)=1
5115 MSUB(12)=1
5116 MSUB(13)=1
5117 MSUB(28)=1
5118 MSUB(53)=1
5119 MSUB(68)=1
5120 MSUB(91)=1
5121 MSUB(92)=1
5122 MSUB(93)=1
5123 MSUB(94)=1
5124 MSUB(95)=1
5125 ENDIF
5126
5127 ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
5128C...Heavy quark production.
5129 MSUB(81)=1
5130 MSUB(82)=1
5131 MSUB(84)=1
5132 DO 180 J=1,MIN(8,MDCY(21,3))
5133 MDME(MDCY(21,2)+J-1,1)=0
5134 180 CONTINUE
5135 MDME(MDCY(21,2)+MSEL-1,1)=1
5136 MSUB(85)=1
5137 DO 190 J=1,MIN(12,MDCY(22,3))
5138 MDME(MDCY(22,2)+J-1,1)=0
5139 190 CONTINUE
5140 MDME(MDCY(22,2)+MSEL-1,1)=1
5141
5142 ELSEIF(MSEL.EQ.10) THEN
5143C...Prompt photon production:
5144 MSUB(14)=1
5145 MSUB(18)=1
5146 MSUB(29)=1
5147
5148 ELSEIF(MSEL.EQ.11) THEN
5149C...Z0/gamma* production:
5150 MSUB(1)=1
5151
5152 ELSEIF(MSEL.EQ.12) THEN
5153C...W+/- production:
5154 MSUB(2)=1
5155
5156 ELSEIF(MSEL.EQ.13) THEN
5157C...Z0 + jet:
5158 MSUB(15)=1
5159 MSUB(30)=1
5160
5161 ELSEIF(MSEL.EQ.14) THEN
5162C...W+/- + jet:
5163 MSUB(16)=1
5164 MSUB(31)=1
5165
5166 ELSEIF(MSEL.EQ.15) THEN
5167C...Z0 & W+/- pair production:
5168 MSUB(19)=1
5169 MSUB(20)=1
5170 MSUB(22)=1
5171 MSUB(23)=1
5172 MSUB(25)=1
5173
5174 ELSEIF(MSEL.EQ.16) THEN
5175C...h0 production:
5176 MSUB(3)=1
5177 MSUB(102)=1
5178 MSUB(103)=1
5179 MSUB(123)=1
5180 MSUB(124)=1
5181
5182 ELSEIF(MSEL.EQ.17) THEN
5183C...h0 & Z0 or W+/- pair production:
5184 MSUB(24)=1
5185 MSUB(26)=1
5186
5187 ELSEIF(MSEL.EQ.18) THEN
5188C...h0 production; interesting processes in e+e-.
5189 MSUB(24)=1
5190 MSUB(103)=1
5191 MSUB(123)=1
5192 MSUB(124)=1
5193
5194 ELSEIF(MSEL.EQ.19) THEN
5195C...h0, H0 and A0 production; interesting processes in e+e-.
5196 MSUB(24)=1
5197 MSUB(103)=1
5198 MSUB(123)=1
5199 MSUB(124)=1
5200 MSUB(153)=1
5201 MSUB(171)=1
5202 MSUB(173)=1
5203 MSUB(174)=1
5204 MSUB(158)=1
5205 MSUB(176)=1
5206 MSUB(178)=1
5207 MSUB(179)=1
5208
5209 ELSEIF(MSEL.EQ.21) THEN
5210C...Z'0 production:
5211 MSUB(141)=1
5212
5213 ELSEIF(MSEL.EQ.22) THEN
5214C...W'+/- production:
5215 MSUB(142)=1
5216
5217 ELSEIF(MSEL.EQ.23) THEN
5218C...H+/- production:
5219 MSUB(143)=1
5220
5221 ELSEIF(MSEL.EQ.24) THEN
5222C...R production:
5223 MSUB(144)=1
5224
5225 ELSEIF(MSEL.EQ.25) THEN
5226C...LQ (leptoquark) production.
5227 MSUB(145)=1
5228 MSUB(162)=1
5229 MSUB(163)=1
5230 MSUB(164)=1
5231
5232 ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN
5233C...Production of one heavy quark (W exchange):
5234 MSUB(83)=1
5235 DO 200 J=1,MIN(8,MDCY(21,3))
5236 MDME(MDCY(21,2)+J-1,1)=0
5237 200 CONTINUE
5238 MDME(MDCY(21,2)+MSEL-31,1)=1
5239
5240CMRENNA++Define SUSY alternatives.
5241 ELSEIF(MSEL.EQ.39) THEN
5242C...Turn on all SUSY processes.
5243 IF(MINT(43).EQ.4) THEN
5244C...Hadron-hadron processes.
5245 DO 210 I=201,301
5246 IF(ISET(I).GE.0) MSUB(I)=1
5247 210 CONTINUE
5248 ELSEIF(MINT(43).EQ.1) THEN
5249C...Lepton-lepton processes: QED production of squarks.
5250 DO 220 I=201,214
5251 MSUB(I)=1
5252 220 CONTINUE
5253 MSUB(210)=0
5254 MSUB(211)=0
5255 MSUB(212)=0
5256 DO 230 I=216,228
5257 MSUB(I)=1
5258 230 CONTINUE
5259 DO 240 I=261,263
5260 MSUB(I)=1
5261 240 CONTINUE
5262 MSUB(277)=1
5263 MSUB(278)=1
5264 ENDIF
5265
5266 ELSEIF(MSEL.EQ.40) THEN
5267C...Gluinos and squarks.
5268 IF(MINT(43).EQ.4) THEN
5269 MSUB(243)=1
5270 MSUB(244)=1
5271 MSUB(258)=1
5272 MSUB(259)=1
5273 MSUB(261)=1
5274 MSUB(262)=1
5275 MSUB(264)=1
5276 MSUB(265)=1
5277 DO 250 I=271,296
5278 MSUB(I)=1
5279 250 CONTINUE
5280 ELSEIF(MINT(43).EQ.1) THEN
5281 MSUB(277)=1
5282 MSUB(278)=1
5283 ENDIF
5284
5285 ELSEIF(MSEL.EQ.41) THEN
5286C...Stop production.
5287 MSUB(261)=1
5288 MSUB(262)=1
5289 MSUB(263)=1
5290 IF(MINT(43).EQ.4) THEN
5291 MSUB(264)=1
5292 MSUB(265)=1
5293 ENDIF
5294
5295 ELSEIF(MSEL.EQ.42) THEN
5296C...Slepton production.
5297 DO 260 I=201,214
5298 MSUB(I)=1
5299 260 CONTINUE
5300 IF(MINT(43).NE.4) THEN
5301 MSUB(210)=0
5302 MSUB(211)=0
5303 MSUB(212)=0
5304 ENDIF
5305
5306 ELSEIF(MSEL.EQ.43) THEN
5307C...Neutralino/Chargino + Gluino/Squark.
5308 IF(MINT(43).EQ.4) THEN
5309 DO 270 I=237,242
5310 MSUB(I)=1
5311 270 CONTINUE
5312 DO 280 I=246,257
5313 MSUB(I)=1
5314 280 CONTINUE
5315 ENDIF
5316
5317 ELSEIF(MSEL.EQ.44) THEN
5318C...Neutralino/Chargino pair production.
5319 IF(MINT(43).EQ.4) THEN
5320 DO 290 I=216,236
5321 MSUB(I)=1
5322 290 CONTINUE
5323 ELSEIF(MINT(43).EQ.1) THEN
5324 DO 300 I=216,228
5325 MSUB(I)=1
5326 300 CONTINUE
5327 ENDIF
5328
5329 ELSEIF(MSEL.EQ.45) THEN
5330C...Sbottom production.
5331 MSUB(287)=1
5332 MSUB(288)=1
5333 IF(MINT(43).EQ.4) THEN
5334 DO 310 I=281,296
5335 MSUB(I)=1
5336 310 CONTINUE
5337 ENDIF
5338
5339 ELSEIF(MSEL.EQ.50) THEN
5340C...Pair production of technipions and gauge bosons.
5341 DO 320 I=361,368
5342 MSUB(I)=1
5343 320 CONTINUE
5344 IF(MINT(43).EQ.4) THEN
5345 DO 330 I=370,377
5346 MSUB(I)=1
5347 330 CONTINUE
5348 ENDIF
5349
5350 ELSEIF(MSEL.EQ.51) THEN
5351C...QCD 2 -> 2 processes with compositeness/technicolor modifications.
5352 DO 340 I=381,386
5353 MSUB(I)=1
5354 340 CONTINUE
5355 ENDIF
5356
5357C...Find heaviest new quark flavour allowed in processes 81-84.
5358 KFLQM=1
5359 DO 350 I=1,MIN(8,MDCY(21,3))
5360 IDC=I+MDCY(21,2)-1
5361 IF(MDME(IDC,1).LE.0) GOTO 350
5362 KFLQM=I
5363 350 CONTINUE
5364 IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9))
5365 &KFLQM=MSTP(7)
5366 MINT(55)=KFLQM
5367 KFPR(81,1)=KFLQM
5368 KFPR(81,2)=KFLQM
5369 KFPR(82,1)=KFLQM
5370 KFPR(82,2)=KFLQM
5371 KFPR(83,1)=KFLQM
5372 KFPR(84,1)=KFLQM
5373 KFPR(84,2)=KFLQM
5374
5375C...Find heaviest new fermion flavour allowed in process 85.
5376 KFLFM=1
5377 DO 360 I=1,MIN(12,MDCY(22,3))
5378 IDC=I+MDCY(22,2)-1
5379 IF(MDME(IDC,1).LE.0) GOTO 360
5380 KFLFM=KFDP(IDC,1)
5381 360 CONTINUE
5382 IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND.
5383 &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7)
5384 MINT(56)=KFLFM
5385 KFPR(85,1)=KFLFM
5386 KFPR(85,2)=KFLFM
5387
5388C...Import relevant information on external user processes.
5389 IF(MINT(111).EQ.11) THEN
5390 IPYPR=0
5391 DO 390 IUP=1,NPRUP
5392C...Find next empty PYTHIA process number slot and enable it.
5393 370 IPYPR=IPYPR+1
5394 IF(IPYPR.GT.500) CALL PYERRM(26,
5395 & '(PYINPR.) no more empty slots for user processes')
5396 IF(ISET(IPYPR).GE.0.AND.ISET(IPYPR).LE.9) GOTO 370
5397 IF(IPYPR.GE.91.AND.IPYPR.LE.100) GOTO 370
5398 ISET(IPYPR)=11
5399C...Overwrite KFPR with references back to process number and ID.
5400 KFPR(IPYPR,1)=IUP
5401 KFPR(IPYPR,2)=LPRUP(IUP)
5402C...Process title.
5403 WRITE(CHIPR,'(I10)') LPRUP(IUP)
5404 ICHIN=1
5405 DO 380 ICH=1,9
5406 IF(CHIPR(ICH:ICH).EQ.' ') ICHIN=ICH+1
5407 380 CONTINUE
5408 PROC(IPYPR)='User process '//CHIPR(ICHIN:10)//' '
5409C...Switch on process.
5410 MSUB(IPYPR)=1
5411 390 CONTINUE
5412 ENDIF
5413
5414 RETURN
5415 END
5416
5417C*********************************************************************
5418
5419C...PYXTOT
5420C...Parametrizes total, elastic and diffractive cross-sections
5421C...for different energies and beams. Donnachie-Landshoff for
5422C...total and Schuler-Sjostrand for elastic and diffractive.
5423C...Process code IPROC:
5424C...= 1 : p + p;
5425C...= 2 : pbar + p;
5426C...= 3 : pi+ + p;
5427C...= 4 : pi- + p;
5428C...= 5 : pi0 + p;
5429C...= 6 : phi + p;
5430C...= 7 : J/psi + p;
5431C...= 11 : rho + rho;
5432C...= 12 : rho + phi;
5433C...= 13 : rho + J/psi;
5434C...= 14 : phi + phi;
5435C...= 15 : phi + J/psi;
5436C...= 16 : J/psi + J/psi;
5437C...= 21 : gamma + p (DL);
5438C...= 22 : gamma + p (VDM).
5439C...= 23 : gamma + pi (DL);
5440C...= 24 : gamma + pi (VDM);
5441C...= 25 : gamma + gamma (DL);
5442C...= 26 : gamma + gamma (VDM).
5443
5444 SUBROUTINE PYXTOT
5445
5446C...Double precision and integer declarations.
5447 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5448 IMPLICIT INTEGER(I-N)
5449 INTEGER PYK,PYCHGE,PYCOMP
5450C...Commonblocks.
5451 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5452 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5453 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5454 COMMON/PYINT1/MINT(400),VINT(400)
5455 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5456 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
5457 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/
5458C...Local arrays.
5459 DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20),
5460 &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8),
5461 &CEFFD(10,9),SIGTMP(6,0:5)
5462
5463C...Common constants.
5464 DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/,
5465 &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/,
5466 &FACDD/0.0084D0/
5467
5468C...Number of multiple processes to be evaluated (= 0 : undefined).
5469 DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
5470C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
5471 DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0,
5472 &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0,
5473 &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/
5474 DATA YPAR/
5475 &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0,
5476 &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0,
5477 &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/
5478
5479C...Beam and target hadron class:
5480C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
5481 DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
5482 DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/
5483C...Characteristic class masses, slope parameters, beta = sqrt(X).
5484 DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/
5485 DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
5486 DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/
5487
5488C...Fitting constants used in parametrizations of diffractive results.
5489 DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
5490 DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
5491 DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/
5492 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0,
5493 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0,
5494 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0,
5495 &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0,
5496 &0.267D0, 0.0D0, -0.46D0, 75D0, 0.267D0, 0.0D0, -0.46D0, 75D0,
5497 &0.232D0, 0.0D0, -0.46D0, 85D0, 0.267D0, 0.0D0, -0.48D0, 100D0,
5498 &0.115D0, 0.0D0, -0.50D0, 90D0, 0.267D0, 6.0D0, -0.56D0, 420D0,
5499 &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0,
5500 &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0,
5501 &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/
5502 DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/
5503 &3.11D0, -7.34D0, 9.71D0, 0.068D0, -0.42D0, 1.31D0,
5504 &-1.37D0, 35.0D0, 118D0, 3.11D0, -7.10D0, 10.6D0,
5505 &0.073D0, -0.41D0, 1.17D0, -1.41D0, 31.6D0, 95D0,
5506 &3.12D0, -7.43D0, 9.21D0, 0.067D0, -0.44D0, 1.41D0,
5507 &-1.35D0, 36.5D0, 132D0, 3.13D0, -8.18D0, -4.20D0,
5508 &0.056D0, -0.71D0, 3.12D0, -1.12D0, 55.2D0, 1298D0,
5509 &3.11D0, -6.90D0, 11.4D0, 0.078D0, -0.40D0, 1.05D0,
5510 &-1.40D0, 28.4D0, 78D0, 3.11D0, -7.13D0, 10.0D0,
5511 &0.071D0, -0.41D0, 1.23D0, -1.34D0, 33.1D0, 105D0,
5512 &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0, 2.72D0,
5513 &-1.13D0, 53.1D0, 995D0, 3.11D0, -7.39D0, 8.22D0,
5514 &0.065D0, -0.44D0, 1.45D0, -1.36D0, 38.1D0, 148D0,
5515 &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0, 3.32D0,
5516 &-1.12D0, 55.6D0, 1472D0, 4.18D0, -29.2D0, 56.2D0,
5517 &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/
5518
5519C...Parameters. Combinations of the energy.
5520 AEM=PARU(101)
5521 PMTH=PARP(102)
5522 S=VINT(2)
5523 SRT=VINT(1)
5524 SEPS=S**EPS
5525 SETA=S**ETA
5526 SLOG=LOG(S)
5527
5528C...Ratio of gamma/pi (for rescaling in parton distributions).
5529 VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/
5530 &(XPAR(5)*SEPS+YPAR(5)*SETA)
5531 VINT(317)=1D0
5532 IF(MINT(50).NE.1) RETURN
5533
5534C...Order flavours of incoming particles: KF1 < KF2.
5535 IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN
5536 KF1=IABS(MINT(11))
5537 KF2=IABS(MINT(12))
5538 IORD=1
5539 ELSE
5540 KF1=IABS(MINT(12))
5541 KF2=IABS(MINT(11))
5542 IORD=2
5543 ENDIF
5544 ISGN12=ISIGN(1,MINT(11)*MINT(12))
5545
5546C...Find process number (for lookup tables).
5547 IF(KF1.GT.1000) THEN
5548 IPROC=1
5549 IF(ISGN12.LT.0) IPROC=2
5550 ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN
5551 IPROC=3
5552 IF(ISGN12.LT.0) IPROC=4
5553 IF(KF1.EQ.111) IPROC=5
5554 ELSEIF(KF1.GT.100) THEN
5555 IPROC=11
5556 ELSEIF(KF2.GT.1000) THEN
5557 IPROC=21
5558 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=22
5559 ELSEIF(KF2.GT.100) THEN
5560 IPROC=23
5561 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=24
5562 ELSE
5563 IPROC=25
5564 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7) IPROC=26
5565 ENDIF
5566
5567C... Number of multiple processes to be stored; beam/target side.
5568 NPR=NPROC(IPROC)
5569 MINT(101)=1
5570 MINT(102)=1
5571 IF(NPR.EQ.3) THEN
5572 MINT(100+IORD)=4
5573 ELSEIF(NPR.EQ.6) THEN
5574 MINT(101)=4
5575 MINT(102)=4
5576 ENDIF
5577 N1=0
5578 IF(MINT(101).EQ.4) N1=4
5579 N2=0
5580 IF(MINT(102).EQ.4) N2=4
5581
5582C...Do not do any more for user-set or undefined cross-sections.
5583 IF(MSTP(31).LE.0) RETURN
5584 IF(NPR.EQ.0) CALL PYERRM(26,
5585 &'(PYXTOT:) cross section for this process not yet implemented')
5586
5587C...Parameters. Combinations of the energy.
5588 AEM=PARU(101)
5589 PMTH=PARP(102)
5590 S=VINT(2)
5591 SRT=VINT(1)
5592 SEPS=S**EPS
5593 SETA=S**ETA
5594 SLOG=LOG(S)
5595
5596C...Loop over multiple processes (for VDM).
5597 DO 110 I=1,NPR
5598 IF(NPR.EQ.1) THEN
5599 IPR=IPROC
5600 ELSEIF(NPR.EQ.3) THEN
5601 IPR=I+4
5602 IF(KF2.LT.1000) IPR=I+10
5603 ELSEIF(NPR.EQ.6) THEN
5604 IPR=I+10
5605 ENDIF
5606
5607C...Evaluate hadron species, mass, slope contribution and fit number.
5608 IHA=IHADA(IPR)
5609 IHB=IHADB(IPR)
5610 PMA=PMHAD(IHA)
5611 PMB=PMHAD(IHB)
5612 BHA=BHAD(IHA)
5613 BHB=BHAD(IHB)
5614 ISD=IFITSD(IPR)
5615 IDD=IFITDD(IPR)
5616
5617C...Skip if energy too low relative to masses.
5618 DO 100 J=0,5
5619 SIGTMP(I,J)=0D0
5620 100 CONTINUE
5621 IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110
5622
5623C...Total cross-section. Elastic slope parameter and cross-section.
5624 SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA
5625 BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0
5626 SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL
5627
5628C...Diffractive scattering A + B -> X + B.
5629 BSD=2D0*BHB
5630 SQML=(PMA+PMTH)**2
5631 SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2)
5632 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
5633 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
5634 BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
5635 SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/
5636 & (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
5637 SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2)
5638
5639C...Diffractive scattering A + B -> A + X.
5640 BSD=2D0*BHA
5641 SQML=(PMB+PMTH)**2
5642 SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6)
5643 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
5644 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
5645 BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
5646 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/
5647 & (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
5648 SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2)
5649
5650C...Order single diffractive correctly.
5651 IF(IORD.EQ.2) THEN
5652 SIGSAV=SIGTMP(I,2)
5653 SIGTMP(I,2)=SIGTMP(I,3)
5654 SIGTMP(I,3)=SIGSAV
5655 ENDIF
5656
5657C...Double diffractive scattering A + B -> X1 + X2.
5658 YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2)
5659 DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2
5660 SUM1=DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0)/(2D0*ALP)
5661 IF(YEFF.LE.0) SUM1=0D0
5662 SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2)
5663 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC))))
5664 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC))))
5665 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/
5666 & (2D0*ALP)
5667 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC))))
5668 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC))))
5669 SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/
5670 & (2D0*ALP)
5671 BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S
5672 SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB*PMRC)))
5673 SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*
5674 & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX)
5675 SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4)
5676
5677C...Non-diffractive by unitarity.
5678 SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)-
5679 & SIGTMP(I,4)
5680 110 CONTINUE
5681
5682C...Put temporary results in output array: only one process.
5683 IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN
5684 DO 120 J=0,5
5685 SIGT(0,0,J)=SIGTMP(1,J)
5686 120 CONTINUE
5687
5688C...Beam multiple processes.
5689 ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN
5690 IF(MINT(107).EQ.2) THEN
5691 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
5692 ELSE
5693 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
5694 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
5695 ENDIF
5696 IF(MSTP(20).GT.0) THEN
5697 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)))**MSTP(20)
5698 ENDIF
5699 DO 140 I=1,4
5700 IF(MINT(107).EQ.2) THEN
5701 CONV=(AEM/PARP(160+I))*VINT(317)
5702 ELSEIF(VINT(154).GT.PARP(15)) THEN
5703 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
5704 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
5705 ELSE
5706 CONV=0D0
5707 ENDIF
5708 I1=MAX(1,I-1)
5709 DO 130 J=0,5
5710 SIGT(I,0,J)=CONV*SIGTMP(I1,J)
5711 130 CONTINUE
5712 140 CONTINUE
5713 DO 150 J=0,5
5714 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
5715 150 CONTINUE
5716
5717C...Target multiple processes.
5718 ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN
5719 IF(MINT(108).EQ.2) THEN
5720 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
5721 ELSE
5722 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
5723 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
5724 ENDIF
5725 IF(MSTP(20).GT.0) THEN
5726 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(308)))**MSTP(20)
5727 ENDIF
5728 DO 170 I=1,4
5729 IF(MINT(108).EQ.2) THEN
5730 CONV=(AEM/PARP(160+I))*VINT(317)
5731 ELSEIF(VINT(154).GT.PARP(15)) THEN
5732 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
5733 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
5734 ELSE
5735 CONV=0D0
5736 ENDIF
5737 IV=MAX(1,I-1)
5738 DO 160 J=0,5
5739 SIGT(0,I,J)=CONV*SIGTMP(IV,J)
5740 160 CONTINUE
5741 170 CONTINUE
5742 DO 180 J=0,5
5743 SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J)
5744 180 CONTINUE
5745
5746C...Both beam and target multiple processes.
5747 ELSE
5748 IF(MINT(107).EQ.2) THEN
5749 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
5750 ELSE
5751 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
5752 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
5753 ENDIF
5754 IF(MINT(108).EQ.2) THEN
5755 VINT(317)=VINT(317)*(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
5756 ELSE
5757 VINT(317)=VINT(317)*16D0*PARP(15)**2*VINT(154)**2/
5758 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
5759 ENDIF
5760 IF(MSTP(20).GT.0) THEN
5761 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)+
5762 & VINT(308)))**MSTP(20)
5763 ENDIF
5764 DO 210 I1=1,4
5765 DO 200 I2=1,4
5766 IF(MINT(107).EQ.2) THEN
5767 CONV=(AEM/PARP(160+I1))*VINT(317)
5768 ELSEIF(VINT(154).GT.PARP(15)) THEN
5769 CONV=(AEM/PARU(1))*(KCHG(I1,1)/3D0)**2*PARP(18)**2*
5770 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
5771 ELSE
5772 CONV=0D0
5773 ENDIF
5774 IF(MINT(108).EQ.2) THEN
5775 CONV=CONV*(AEM/PARP(160+I2))
5776 ELSEIF(VINT(154).GT.PARP(15)) THEN
5777 CONV=CONV*(AEM/PARU(1))*(KCHG(I2,1)/3D0)**2*PARP(18)**2*
5778 & (1D0/PARP(15)**2-1D0/VINT(154)**2)
5779 ELSE
5780 CONV=0D0
5781 ENDIF
5782 IF(I1.LE.2) THEN
5783 IV=MAX(1,I2-1)
5784 ELSEIF(I2.LE.2) THEN
5785 IV=MAX(1,I1-1)
5786 ELSEIF(I1.EQ.I2) THEN
5787 IV=2*I1-2
5788 ELSE
5789 IV=5
5790 ENDIF
5791 DO 190 J=0,5
5792 JV=J
5793 IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J
5794 SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV)
5795 190 CONTINUE
5796 200 CONTINUE
5797 210 CONTINUE
5798 DO 230 J=0,5
5799 DO 220 I=1,4
5800 SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J)
5801 SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J)
5802 220 CONTINUE
5803 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
5804 230 CONTINUE
5805 ENDIF
5806
5807C...Scale up uniformly for Donnachie-Landshoff parametrization.
5808 IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN
5809 RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0)
5810 DO 260 I1=0,N1
5811 DO 250 I2=0,N2
5812 DO 240 J=0,5
5813 SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J)
5814 240 CONTINUE
5815 250 CONTINUE
5816 260 CONTINUE
5817 ENDIF
5818
5819 RETURN
5820 END
5821
5822C*********************************************************************
5823
5824C...PYMAXI
5825C...Finds optimal set of coefficients for kinematical variable selection
5826C...and the maximum of the part of the differential cross-section used
5827C...in the event weighting.
5828
5829 SUBROUTINE PYMAXI
5830
5831C...Double precision and integer declarations.
5832 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5833 IMPLICIT INTEGER(I-N)
5834 INTEGER PYK,PYCHGE,PYCOMP
5835C...Parameter statement to help give large particle numbers.
5836 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
5837 &KEXCIT=4000000,KDIMEN=5000000)
5838
5839C...User process initialization commonblock.
5840 INTEGER MAXPUP
5841 PARAMETER (MAXPUP=100)
5842 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5843 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5844 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5845 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5846 &LPRUP(MAXPUP)
5847 SAVE /HEPRUP/
5848
5849C...Commonblocks.
5850 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5851 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5852 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
5853 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5854 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5855 COMMON/PYINT1/MINT(400),VINT(400)
5856 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5857 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
5858 COMMON/PYINT4/MWID(500),WIDS(500,5)
5859 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5860 COMMON/PYINT6/PROC(0:500)
5861 CHARACTER PROC*28
5862 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
5863 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
5864 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/
5865C...Local arrays, character variables and data.
5866 CHARACTER CVAR(4)*4
5867 DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500),
5868 &NAREL(7),WTREL(7),WTMAT(7,7),WTRELN(7),COEFU(7),COEFO(7),
5869 &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2)
5870 DATA CVAR/'tau ','tau''','y* ','cth '/
5871 DATA SIGSSM/3*0D0/
5872
5873C...Initial values and loop over subprocesses.
5874 NPOSI=0
5875 VINT(143)=1D0
5876 VINT(144)=1D0
5877 XSEC(0,1)=0D0
5878 DO 460 ISUB=1,500
5879 MINT(1)=ISUB
5880 MINT(51)=0
5881
5882C...Find maximum weight factors for photon flux.
5883 IF(MSUB(ISUB).EQ.1.OR.(ISUB.GE.91.AND.ISUB.LE.100)) THEN
5884 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(2,WTGAGA)
5885 ENDIF
5886
5887C...Select subprocess to study: skip cases not applicable.
5888 IF(ISET(ISUB).EQ.11) THEN
5889 IF(MSUB(ISUB).NE.1) GOTO 460
5890C...User process intialization: cross section model dependent.
5891 IF(IABS(IDWTUP).EQ.1) THEN
5892 IF(IDWTUP.GT.0.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
5893 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
5894 XSEC(ISUB,1)=1.00000001D-9*ABS(XMAXUP(KFPR(ISUB,1)))
5895 ELSE
5896 IF((IDWTUP.EQ.2.OR.IDWTUP.EQ.3).AND.
5897 & XSECUP(KFPR(ISUB,1)).LT.0D0) CALL
5898 & PYERRM(26,'(PYMAXI:) Negative XSECUP for user process')
5899 IF(IDWTUP.EQ.2.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
5900 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
5901 XSEC(ISUB,1)=1.00000001D-9*ABS(XSECUP(KFPR(ISUB,1)))
5902 ENDIF
5903 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
5904 & WTGAGA*XSEC(ISUB,1)
5905 NPOSI=NPOSI+1
5906 GOTO 450
5907 ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN
5908 CALL PYSIGH(NCHN,SIGS)
5909 XSEC(ISUB,1)=SIGS
5910 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
5911 & WTGAGA*XSEC(ISUB,1)
5912 IF(MSUB(ISUB).NE.1) GOTO 460
5913 NPOSI=NPOSI+1
5914 GOTO 450
5915 ELSEIF(ISUB.EQ.99.AND.MSUB(ISUB).EQ.1) THEN
5916 CALL PYSIGH(NCHN,SIGS)
5917 XSEC(ISUB,1)=SIGS
5918 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
5919 & WTGAGA*XSEC(ISUB,1)
5920 IF(XSEC(ISUB,1).EQ.0D0) THEN
5921 MSUB(ISUB)=0
5922 ELSE
5923 NPOSI=NPOSI+1
5924 ENDIF
5925 GOTO 450
5926 ELSEIF(ISUB.EQ.96) THEN
5927 IF(MINT(50).EQ.0) GOTO 460
5928 IF(MSUB(95).NE.1.AND.MSTP(81).LE.0.AND.MSTP(131).LE.0)
5929 & GOTO 460
5930 IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460
5931 ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
5932 & ISUB.EQ.53.OR.ISUB.EQ.68) THEN
5933 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
5934 ELSEIF(ISUB.GE.381.AND.ISUB.LE.386) THEN
5935 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
5936 ELSE
5937 IF(MSUB(ISUB).NE.1) GOTO 460
5938 ENDIF
5939 ISTSB=ISET(ISUB)
5940 IF(ISUB.EQ.96) ISTSB=2
5941 IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB
5942 MWTXS=0
5943 IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+
5944 & MSUB(94)+MSUB(95).EQ.0) MWTXS=1
5945
5946C...Find resonances (explicit or implicit in cross-section).
5947 MINT(72)=0
5948 KFR1=0
5949 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
5950 KFR1=KFPR(ISUB,1)
5951 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165
5952 & .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
5953 KFR1=23
5954 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172
5955 & .OR.ISUB.EQ.177) THEN
5956 KFR1=24
5957 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
5958 KFR1=25
5959 IF(MSTP(46).EQ.5) THEN
5960 KFR1=89
5961 PMAS(89,1)=PARP(45)
5962 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
5963 ENDIF
5964 ELSEIF(ISUB.EQ.194) THEN
5965 KFR1=KTECHN+113
5966 ELSEIF(ISUB.EQ.195) THEN
5967 KFR1=KTECHN+213
5968 ELSEIF(ISUB.GE.361.AND.ISUB.LE.368) THEN
5969 KFR1=KTECHN+113
5970 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
5971 KFR1=KTECHN+213
5972 ENDIF
5973 CKMX=CKIN(2)
5974 IF(CKMX.LE.0D0) CKMX=VINT(1)
5975 KCR1=PYCOMP(KFR1)
5976 IF(KFR1.NE.0) THEN
5977 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
5978 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
5979 ENDIF
5980 IF(KFR1.NE.0) THEN
5981 TAUR1=PMAS(KCR1,1)**2/VINT(2)
5982 IF(KFR1.EQ.KTECHN+113) THEN
5983 CALL PYTECM(S1,S2)
5984 TAUR1=S1/VINT(2)
5985 ENDIF
5986 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
5987 MINT(72)=1
5988 MINT(73)=KFR1
5989 VINT(73)=TAUR1
5990 VINT(74)=GAMR1
5991 ENDIF
5992 KFR2=0
5993 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.(ISUB.GE.364.AND.ISUB.LE.368))
5994 $ THEN
5995 KFR2=23
5996 IF(ISUB.EQ.194) THEN
5997 KFR2=KTECHN+223
5998 ELSEIF(ISUB.GE.364.AND.ISUB.LE.368) THEN
5999 KFR2=KTECHN+223
6000 ENDIF
6001 KCR2=PYCOMP(KFR2)
6002 TAUR2=PMAS(KCR2,1)**2/VINT(2)
6003 IF(KFR2.EQ.KTECHN+223) THEN
6004 CALL PYTECM(S1,S2)
6005 TAUR2=S2/VINT(2)
6006 ENDIF
6007 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
6008 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
6009 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
6010 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
6011 MINT(72)=2
6012 MINT(74)=KFR2
6013 VINT(75)=TAUR2
6014 VINT(76)=GAMR2
6015 ELSEIF(KFR2.NE.0) THEN
6016 KFR1=KFR2
6017 TAUR1=TAUR2
6018 GAMR1=GAMR2
6019 MINT(72)=1
6020 MINT(73)=KFR1
6021 VINT(73)=TAUR1
6022 VINT(74)=GAMR1
6023 KFR2=0
6024 ENDIF
6025 ENDIF
6026
6027C...Find product masses and minimum pT of process.
6028 SQM3=0D0
6029 SQM4=0D0
6030 MINT(71)=0
6031 VINT(71)=CKIN(3)
6032 VINT(80)=1D0
6033 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
6034 NBW=0
6035 DO 110 I=1,2
6036 PMMN(I)=0D0
6037 IF(KFPR(ISUB,I).EQ.0) THEN
6038 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
6039 & PARP(41)) THEN
6040 IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
6041 IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
6042 ELSE
6043 NBW=NBW+1
6044C...This prevents SUSY/t particles from becoming too light.
6045 KFLW=KFPR(ISUB,I)
6046 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
6047 KCW=PYCOMP(KFLW)
6048 PMMN(I)=PMAS(KCW,1)
6049 DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
6050 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
6051 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
6052 & PMAS(PYCOMP(KFDP(IDC,2)),1)
6053 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
6054 & PMAS(PYCOMP(KFDP(IDC,3)),1)
6055 PMMN(I)=MIN(PMMN(I),PMSUM)
6056 ENDIF
6057 100 CONTINUE
6058 ELSEIF(KFLW.EQ.6) THEN
6059 PMMN(I)=PMAS(24,1)+PMAS(5,1)
6060 ENDIF
6061 ENDIF
6062 110 CONTINUE
6063 IF(NBW.GE.1) THEN
6064 CKIN41=CKIN(41)
6065 CKIN43=CKIN(43)
6066 CKIN(41)=MAX(PMMN(1),CKIN(41))
6067 CKIN(43)=MAX(PMMN(2),CKIN(43))
6068 CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
6069 CKIN(41)=CKIN41
6070 CKIN(43)=CKIN43
6071 IF(MINT(51).EQ.1) THEN
6072 WRITE(MSTU(11),5100) ISUB
6073 MSUB(ISUB)=0
6074 GOTO 460
6075 ENDIF
6076 SQM3=PQM3**2
6077 SQM4=PQM4**2
6078 ENDIF
6079 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
6080 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
6081 IF(ISUB.EQ.96.AND.MSTP(82).LE.1) THEN
6082 VINT(71)=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
6083 ELSEIF(ISUB.EQ.96) THEN
6084 VINT(71)=0.08D0*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
6085 ENDIF
6086 ENDIF
6087 VINT(63)=SQM3
6088 VINT(64)=SQM4
6089
6090C...Prepare for additional variable choices in 2 -> 3.
6091 IF(ISTSB.EQ.5) THEN
6092 VINT(201)=0D0
6093 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
6094 VINT(206)=VINT(201)
6095 VINT(204)=PMAS(23,1)
6096 IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
6097 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
6098 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182
6099 & .OR.ISUB.EQ.186.OR.ISUB.EQ.187) VINT(204)=VINT(201)
6100 VINT(209)=VINT(204)
6101 ENDIF
6102
6103C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
6104 NPTS(1)=2+2*MINT(72)
6105 IF(MINT(47).EQ.1) THEN
6106 IF(ISTSB.EQ.1.OR.ISTSB.EQ.2) NPTS(1)=1
6107 ELSEIF(MINT(47).GE.5) THEN
6108 IF(ISTSB.LE.2.OR.ISTSB.GT.5) NPTS(1)=NPTS(1)+1
6109 ENDIF
6110 NPTS(2)=1
6111 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
6112 IF(MINT(47).GE.2) NPTS(2)=2
6113 IF(MINT(47).GE.5) NPTS(2)=3
6114 ENDIF
6115 NPTS(3)=1
6116 IF(MINT(47).EQ.4.OR.MINT(47).EQ.5) THEN
6117 NPTS(3)=3
6118 IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1
6119 IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1
6120 ENDIF
6121 NPTS(4)=1
6122 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
6123 NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
6124
6125C...Reset coefficients of cross-section weighting.
6126 DO 120 J=1,20
6127 COEF(ISUB,J)=0D0
6128 120 CONTINUE
6129 COEF(ISUB,1)=1D0
6130 COEF(ISUB,8)=0.5D0
6131 COEF(ISUB,9)=0.5D0
6132 COEF(ISUB,13)=1D0
6133 COEF(ISUB,18)=1D0
6134 MCTH=0
6135 MTAUP=0
6136 METAUP=0
6137 VINT(23)=0D0
6138 VINT(26)=0D0
6139 SIGSAM=0D0
6140
6141C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
6142C...in grid of phase space points.
6143 CALL PYKLIM(1)
6144 METAU=MINT(51)
6145 NACC=0
6146 DO 150 ITRY=1,NTRY
6147 MINT(51)=0
6148 IF(METAU.EQ.1) GOTO 150
6149 IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
6150 MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
6151 IF(MTAU.GT.2+2*MINT(72)) MTAU=7
6152 RTAU=0.5D0
6153C...Special case when both resonances have same mass,
6154C...as is often the case in process 194.
6155 IF(MINT(72).EQ.2) THEN
6156 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
6157 & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
6158 IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
6159 RTAU=0.4D0
6160 ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
6161 RTAU=0.6D0
6162 ENDIF
6163 ENDIF
6164 ENDIF
6165 CALL PYKMAP(1,MTAU,RTAU)
6166 IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4)
6167 METAUP=MINT(51)
6168 ENDIF
6169 IF(METAUP.EQ.1) GOTO 150
6170 IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4))
6171 & .EQ.0) THEN
6172 MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
6173 CALL PYKMAP(4,MTAUP,0.5D0)
6174 ENDIF
6175 IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN
6176 CALL PYKLIM(2)
6177 MEYST=MINT(51)
6178 ENDIF
6179 IF(MEYST.EQ.1) GOTO 150
6180 IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
6181 MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
6182 IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5
6183 CALL PYKMAP(2,MYST,0.5D0)
6184 CALL PYKLIM(3)
6185 MECTH=MINT(51)
6186 ENDIF
6187 IF(MECTH.EQ.1) GOTO 150
6188 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
6189 MCTH=1+MOD(ITRY-1,NPTS(4))
6190 CALL PYKMAP(3,MCTH,0.5D0)
6191 ENDIF
6192 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2)
6193
6194C...Store position and limits.
6195 MINT(51)=0
6196 CALL PYKLIM(0)
6197 IF(MINT(51).EQ.1) GOTO 150
6198 NACC=NACC+1
6199 MVARPT(NACC,1)=MTAU
6200 MVARPT(NACC,2)=MTAUP
6201 MVARPT(NACC,3)=MYST
6202 MVARPT(NACC,4)=MCTH
6203 DO 130 J=1,30
6204 VINTPT(NACC,J)=VINT(10+J)
6205 130 CONTINUE
6206
6207C...Normal case: calculate cross-section.
6208 IF(ISTSB.NE.5) THEN
6209 CALL PYSIGH(NCHN,SIGS)
6210 IF(MWTXS.EQ.1) THEN
6211 CALL PYEVWT(WTXS)
6212 SIGS=WTXS*SIGS
6213 ENDIF
6214
6215C..2 -> 3: find highest value out of a number of tries.
6216 ELSE
6217 SIGS=0D0
6218 DO 140 IKIN3=1,MSTP(129)
6219 CALL PYKMAP(5,0,0D0)
6220 IF(MINT(51).EQ.1) GOTO 140
6221 CALL PYSIGH(NCHN,SIGTMP)
6222 IF(MWTXS.EQ.1) THEN
6223 CALL PYEVWT(WTXS)
6224 SIGTMP=WTXS*SIGTMP
6225 ENDIF
6226 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
6227 140 CONTINUE
6228 ENDIF
6229
6230C...Store cross-section.
6231 SIGSPT(NACC)=SIGS
6232 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
6233 IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP,
6234 & VINT(21),VINT(22),VINT(23),VINT(26),SIGS
6235 150 CONTINUE
6236 IF(NACC.EQ.0) THEN
6237 WRITE(MSTU(11),5100) ISUB
6238 MSUB(ISUB)=0
6239 GOTO 460
6240 ELSEIF(SIGSAM.EQ.0D0) THEN
6241 WRITE(MSTU(11),5300) ISUB
6242 MSUB(ISUB)=0
6243 GOTO 460
6244 ENDIF
6245 IF(ISUB.NE.96) NPOSI=NPOSI+1
6246
6247C...Calculate integrals in tau over maximal phase space limits.
6248 TAUMIN=VINT(11)
6249 TAUMAX=VINT(31)
6250 ATAU1=LOG(TAUMAX/TAUMIN)
6251 IF(NPTS(1).GE.2) THEN
6252 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
6253 ENDIF
6254 IF(NPTS(1).GE.4) THEN
6255 ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
6256 ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
6257 & GAMR1
6258 ENDIF
6259 IF(NPTS(1).GE.6) THEN
6260 ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
6261 ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
6262 & GAMR2
6263 ENDIF
6264 IF(NPTS(1).GT.2+2*MINT(72)) THEN
6265 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
6266 ENDIF
6267
6268C...Reset. Sum up cross-sections in points calculated.
6269 DO 320 IVAR=1,4
6270 IF(NPTS(IVAR).EQ.1) GOTO 320
6271 IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320
6272 NBIN=NPTS(IVAR)
6273 DO 170 J1=1,NBIN
6274 NAREL(J1)=0
6275 WTREL(J1)=0D0
6276 COEFU(J1)=0D0
6277 DO 160 J2=1,NBIN
6278 WTMAT(J1,J2)=0D0
6279 160 CONTINUE
6280 170 CONTINUE
6281 DO 180 IACC=1,NACC
6282 IBIN=MVARPT(IACC,IVAR)
6283 IF(IVAR.EQ.1.AND.IBIN.EQ.7) IBIN=3+2*MINT(72)
6284 IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4
6285 NAREL(IBIN)=NAREL(IBIN)+1
6286 WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
6287
6288C...Sum up tau cross-section pieces in points used.
6289 IF(IVAR.EQ.1) THEN
6290 TAU=VINTPT(IACC,11)
6291 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
6292 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
6293 IF(NBIN.GE.4) THEN
6294 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
6295 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
6296 & ((TAU-TAUR1)**2+GAMR1**2)
6297 ENDIF
6298 IF(NBIN.GE.6) THEN
6299 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
6300 WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
6301 & ((TAU-TAUR2)**2+GAMR2**2)
6302 ENDIF
6303 IF(NBIN.GT.2+2*MINT(72)) THEN
6304 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(ATAU1/ATAU7)*
6305 & TAU/MAX(2D-10,1D0-TAU)
6306 ENDIF
6307
6308C...Sum up tau' cross-section pieces in points used.
6309 ELSEIF(IVAR.EQ.2) THEN
6310 TAU=VINTPT(IACC,11)
6311 TAUP=VINTPT(IACC,16)
6312 TAUPMN=VINTPT(IACC,6)
6313 TAUPMX=VINTPT(IACC,26)
6314 ATAUP1=LOG(TAUPMX/TAUPMN)
6315 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
6316 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
6317 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*
6318 & (1D0-TAU/TAUP)**3/TAUP
6319 IF(NBIN.GE.3) THEN
6320 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
6321 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)*
6322 & TAUP/MAX(2D-10,1D0-TAUP)
6323 ENDIF
6324
6325C...Sum up y* cross-section pieces in points used.
6326 ELSEIF(IVAR.EQ.3) THEN
6327 YST=VINTPT(IACC,12)
6328 YSTMIN=VINTPT(IACC,2)
6329 YSTMAX=VINTPT(IACC,22)
6330 AYST0=YSTMAX-YSTMIN
6331 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
6332 AYST2=AYST1
6333 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
6334 WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
6335 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST)
6336 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
6337 IF(MINT(45).EQ.3) THEN
6338 TAUE=VINTPT(IACC,11)
6339 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
6340 YST0=-0.5D0*LOG(TAUE)
6341 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
6342 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
6343 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/
6344 & MAX(1D-10,1D0-EXP(YST-YST0))
6345 ENDIF
6346 IF(MINT(46).EQ.3) THEN
6347 TAUE=VINTPT(IACC,11)
6348 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
6349 YST0=-0.5D0*LOG(TAUE)
6350 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
6351 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
6352 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/
6353 & MAX(1D-10,1D0-EXP(-YST-YST0))
6354 ENDIF
6355
6356C...Sum up cos(theta-hat) cross-section pieces in points used.
6357 ELSE
6358 RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2)
6359 RSQM=1D0+RM34
6360 CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2)))
6361 CTHMIN=-CTHMAX
6362 IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/
6363 & (TAUMAX*VINT(2)))
6364 ACTH1=CTHMAX-CTHMIN
6365 ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
6366 ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
6367 ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
6368 ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
6369 CTH=VINTPT(IACC,13)
6370 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
6371 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
6372 & MAX(RM34,RSQM-CTH)
6373 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
6374 & MAX(RM34,RSQM+CTH)
6375 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
6376 & MAX(RM34,RSQM-CTH)**2
6377 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
6378 & MAX(RM34,RSQM+CTH)**2
6379 ENDIF
6380 180 CONTINUE
6381
6382C...Check that equation system solvable.
6383 IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
6384 MSOLV=1
6385 WTRELS=0D0
6386 DO 190 IBIN=1,NBIN
6387 IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
6388 & IRED=1,NBIN),WTREL(IBIN)
6389 IF(NAREL(IBIN).EQ.0) MSOLV=0
6390 WTRELS=WTRELS+WTREL(IBIN)
6391 190 CONTINUE
6392 IF(ABS(WTRELS).LT.1D-20) MSOLV=0
6393
6394C...Solve to find relative importance of cross-section pieces.
6395 IF(MSOLV.EQ.1) THEN
6396 DO 200 IBIN=1,NBIN
6397 WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
6398 200 CONTINUE
6399 DO 230 IRED=1,NBIN-1
6400 DO 220 IBIN=IRED+1,NBIN
6401 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
6402 MSOLV=0
6403 GOTO 260
6404 ENDIF
6405 RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
6406 WTREL(IBIN)=WTREL(IBIN)-RQT*WTREL(IRED)
6407 DO 210 ICOE=IRED,NBIN
6408 WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-RQT*WTMAT(IRED,ICOE)
6409 210 CONTINUE
6410 220 CONTINUE
6411 230 CONTINUE
6412 DO 250 IRED=NBIN,1,-1
6413 DO 240 ICOE=IRED+1,NBIN
6414 WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
6415 240 CONTINUE
6416 COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
6417 250 CONTINUE
6418 ENDIF
6419
6420C...Share evenly if failure.
6421 260 IF(MSOLV.EQ.0) THEN
6422 DO 270 IBIN=1,NBIN
6423 COEFU(IBIN)=1D0
6424 WTRELN(IBIN)=0.1D0
6425 IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0,
6426 & WTREL(IBIN)/WTRELS)
6427 270 CONTINUE
6428 ENDIF
6429
6430C...Normalize coefficients, with piece shared democratically.
6431 COEFSU=0D0
6432 WTRELS=0D0
6433 DO 280 IBIN=1,NBIN
6434 COEFU(IBIN)=MAX(0D0,COEFU(IBIN))
6435 COEFSU=COEFSU+COEFU(IBIN)
6436 WTRELS=WTRELS+WTRELN(IBIN)
6437 280 CONTINUE
6438 IF(COEFSU.GT.0D0) THEN
6439 DO 290 IBIN=1,NBIN
6440 COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0*
6441 & (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS)
6442 290 CONTINUE
6443 ELSE
6444 DO 300 IBIN=1,NBIN
6445 COEFO(IBIN)=1D0/NBIN
6446 300 CONTINUE
6447 ENDIF
6448 IF(IVAR.EQ.1) IOFF=0
6449 IF(IVAR.EQ.2) IOFF=17
6450 IF(IVAR.EQ.3) IOFF=7
6451 IF(IVAR.EQ.4) IOFF=12
6452 DO 310 IBIN=1,NBIN
6453 ICOF=IOFF+IBIN
6454 IF(IVAR.EQ.1.AND.IBIN.GT.2+2*MINT(72)) ICOF=7
6455 IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
6456 COEF(ISUB,ICOF)=COEFO(IBIN)
6457 310 CONTINUE
6458 IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR),
6459 & (COEFO(IBIN),IBIN=1,NBIN)
6460 320 CONTINUE
6461
6462C...Find two most promising maxima among points previously determined.
6463 DO 330 J=1,4
6464 IACCMX(J)=0
6465 SIGSMX(J)=0D0
6466 330 CONTINUE
6467 NMAX=0
6468 DO 390 IACC=1,NACC
6469 DO 340 J=1,30
6470 VINT(10+J)=VINTPT(IACC,J)
6471 340 CONTINUE
6472 IF(ISTSB.NE.5) THEN
6473 CALL PYSIGH(NCHN,SIGS)
6474 IF(MWTXS.EQ.1) THEN
6475 CALL PYEVWT(WTXS)
6476 SIGS=WTXS*SIGS
6477 ENDIF
6478 ELSE
6479 SIGS=0D0
6480 DO 350 IKIN3=1,MSTP(129)
6481 CALL PYKMAP(5,0,0D0)
6482 IF(MINT(51).EQ.1) GOTO 350
6483 CALL PYSIGH(NCHN,SIGTMP)
6484 IF(MWTXS.EQ.1) THEN
6485 CALL PYEVWT(WTXS)
6486 SIGTMP=WTXS*SIGTMP
6487 ENDIF
6488 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
6489 350 CONTINUE
6490 ENDIF
6491 IEQ=0
6492 DO 360 IMV=1,NMAX
6493 IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
6494 360 CONTINUE
6495 IF(IEQ.EQ.0) THEN
6496 DO 370 IMV=NMAX,1,-1
6497 IIN=IMV+1
6498 IF(SIGS.LE.SIGSMX(IMV)) GOTO 380
6499 IACCMX(IMV+1)=IACCMX(IMV)
6500 SIGSMX(IMV+1)=SIGSMX(IMV)
6501 370 CONTINUE
6502 IIN=1
6503 380 IACCMX(IIN)=IACC
6504 SIGSMX(IIN)=SIGS
6505 IF(NMAX.LE.1) NMAX=NMAX+1
6506 ENDIF
6507 390 CONTINUE
6508
6509C...Read out starting position for search.
6510 IF(MSTP(122).GE.2) WRITE(MSTU(11),5700)
6511 SIGSAM=SIGSMX(1)
6512 DO 440 IMAX=1,NMAX
6513 IACC=IACCMX(IMAX)
6514 MTAU=MVARPT(IACC,1)
6515 MTAUP=MVARPT(IACC,2)
6516 MYST=MVARPT(IACC,3)
6517 MCTH=MVARPT(IACC,4)
6518 VTAU=0.5D0
6519 VYST=0.5D0
6520 VCTH=0.5D0
6521 VTAUP=0.5D0
6522
6523C...Starting point and step size in parameter space.
6524 DO 430 IRPT=1,2
6525 DO 420 IVAR=1,4
6526 IF(NPTS(IVAR).EQ.1) GOTO 420
6527 IF(IVAR.EQ.1) VVAR=VTAU
6528 IF(IVAR.EQ.2) VVAR=VTAUP
6529 IF(IVAR.EQ.3) VVAR=VYST
6530 IF(IVAR.EQ.4) VVAR=VCTH
6531 IF(IVAR.EQ.1) MVAR=MTAU
6532 IF(IVAR.EQ.2) MVAR=MTAUP
6533 IF(IVAR.EQ.3) MVAR=MYST
6534 IF(IVAR.EQ.4) MVAR=MCTH
6535 IF(IRPT.EQ.1) VDEL=0.1D0
6536 IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0,
6537 & 0.98D0-VVAR))
6538 IF(IRPT.EQ.1) VMAR=0.02D0
6539 IF(IRPT.EQ.2) VMAR=0.002D0
6540 IMOV0=1
6541 IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
6542 DO 410 IMOV=IMOV0,8
6543
6544C...Define new point in parameter space.
6545 IF(IMOV.EQ.0) THEN
6546 INEW=2
6547 VNEW=VVAR
6548 ELSEIF(IMOV.EQ.1) THEN
6549 INEW=3
6550 VNEW=VVAR+VDEL
6551 ELSEIF(IMOV.EQ.2) THEN
6552 INEW=1
6553 VNEW=VVAR-VDEL
6554 ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
6555 & VVAR+2D0*VDEL.LT.1D0-VMAR) THEN
6556 VVAR=VVAR+VDEL
6557 SIGSSM(1)=SIGSSM(2)
6558 SIGSSM(2)=SIGSSM(3)
6559 INEW=3
6560 VNEW=VVAR+VDEL
6561 ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
6562 & VVAR-2D0*VDEL.GT.VMAR) THEN
6563 VVAR=VVAR-VDEL
6564 SIGSSM(3)=SIGSSM(2)
6565 SIGSSM(2)=SIGSSM(1)
6566 INEW=1
6567 VNEW=VVAR-VDEL
6568 ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
6569 VDEL=0.5D0*VDEL
6570 VVAR=VVAR+VDEL
6571 SIGSSM(1)=SIGSSM(2)
6572 INEW=2
6573 VNEW=VVAR
6574 ELSE
6575 VDEL=0.5D0*VDEL
6576 VVAR=VVAR-VDEL
6577 SIGSSM(3)=SIGSSM(2)
6578 INEW=2
6579 VNEW=VVAR
6580 ENDIF
6581
6582C...Convert to relevant variables and find derived new limits.
6583 ILERR=0
6584 IF(IVAR.EQ.1) THEN
6585 VTAU=VNEW
6586 CALL PYKMAP(1,MTAU,VTAU)
6587 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
6588 CALL PYKLIM(4)
6589 IF(MINT(51).EQ.1) ILERR=1
6590 ENDIF
6591 ENDIF
6592 IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
6593 & ILERR.EQ.0) THEN
6594 IF(IVAR.EQ.2) VTAUP=VNEW
6595 CALL PYKMAP(4,MTAUP,VTAUP)
6596 ENDIF
6597 IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
6598 CALL PYKLIM(2)
6599 IF(MINT(51).EQ.1) ILERR=1
6600 ENDIF
6601 IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
6602 IF(IVAR.EQ.3) VYST=VNEW
6603 CALL PYKMAP(2,MYST,VYST)
6604 CALL PYKLIM(3)
6605 IF(MINT(51).EQ.1) ILERR=1
6606 ENDIF
6607 IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
6608 & ILERR.EQ.0) THEN
6609 IF(IVAR.EQ.4) VCTH=VNEW
6610 CALL PYKMAP(3,MCTH,VCTH)
6611 ENDIF
6612 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
6613
6614C...Evaluate cross-section. Save new maximum. Final maximum.
6615 IF(ILERR.NE.0) THEN
6616 SIGS=0.
6617 ELSEIF(ISTSB.NE.5) THEN
6618 CALL PYSIGH(NCHN,SIGS)
6619 IF(MWTXS.EQ.1) THEN
6620 CALL PYEVWT(WTXS)
6621 SIGS=WTXS*SIGS
6622 ENDIF
6623 ELSE
6624 SIGS=0D0
6625 DO 400 IKIN3=1,MSTP(129)
6626 CALL PYKMAP(5,0,0D0)
6627 IF(MINT(51).EQ.1) GOTO 400
6628 CALL PYSIGH(NCHN,SIGTMP)
6629 IF(MWTXS.EQ.1) THEN
6630 CALL PYEVWT(WTXS)
6631 SIGTMP=WTXS*SIGTMP
6632 ENDIF
6633 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
6634 400 CONTINUE
6635 ENDIF
6636 SIGSSM(INEW)=SIGS
6637 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
6638 IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
6639 & IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
6640 410 CONTINUE
6641 420 CONTINUE
6642 430 CONTINUE
6643 440 CONTINUE
6644 IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
6645 XSEC(ISUB,1)=1.05D0*SIGSAM
6646 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
6647 & WTGAGA*XSEC(ISUB,1)
6648 450 CONTINUE
6649 IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
6650 & PARP(174)*XSEC(ISUB,1)
6651 IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
6652 460 CONTINUE
6653 MINT(51)=0
6654
6655C...Print summary table.
6656 IF(MINT(121).EQ.1.AND.NPOSI.EQ.0) THEN
6657 IF(MSTP(127).NE.1) THEN
6658 WRITE(MSTU(11),5900)
6659 STOP
6660 ELSE
6661 WRITE(MSTU(11),6400)
6662 MSTI(53)=1
6663 ENDIF
6664 ENDIF
6665 IF(MSTP(122).GE.1) THEN
6666 WRITE(MSTU(11),6000)
6667 WRITE(MSTU(11),6100)
6668 DO 470 ISUB=1,500
6669 IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470
6670 IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470
6671 IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MSTP(81).LE.0) GOTO 470
6672 IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470
6673 IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13
6674 & .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470
6675 IF(MSUB(95).EQ.1.AND.ISUB.GE.381.AND.ISUB.LE.386) GOTO 470
6676 WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1)
6677 470 CONTINUE
6678 WRITE(MSTU(11),6300)
6679 ENDIF
6680
6681C...Format statements for maximization results.
6682 5000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
6683 &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X,
6684 &'cth',9X,'tau''',7X,'sigma')
6685 5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ',
6686 &'phase space.'/1X,'Process switched off!')
6687 5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4)
6688 5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ',
6689 &'cross-section.'/1X,'Process switched off!')
6690 5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
6691 5500 FORMAT(1X,1P,8D11.3)
6692 5600 FORMAT(1X,'Result for ',A4,':',7F9.4)
6693 5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
6694 &'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
6695 5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4)
6696 5900 FORMAT(1X,'Error: no requested process has non-vanishing ',
6697 &'cross-section.'/1X,'Execution stopped!')
6698 6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
6699 &'cross-section maximum search',1X,8('*'))
6700 6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ',
6701 &'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I',
6702 &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
6703 6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I')
6704 6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
6705 6400 FORMAT(1X,'Error: no requested process has non-vanishing ',
6706 &'cross-section.'/
6707 &1X,'Execution will stop if you try to generate events.')
6708
6709 RETURN
6710 END
6711
6712C*********************************************************************
6713
6714C...PYPILE
6715C...Initializes multiplicity distribution and selects mutliplicity
6716C...of pileup events, i.e. several events occuring at the same
6717C...beam crossing.
6718
6719 SUBROUTINE PYPILE(MPILE)
6720
6721C...Double precision and integer declarations.
6722 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6723 IMPLICIT INTEGER(I-N)
6724 INTEGER PYK,PYCHGE,PYCOMP
6725C...Commonblocks.
6726 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6727 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6728 COMMON/PYINT1/MINT(400),VINT(400)
6729 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
6730 SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
6731C...Local arrays and saved variables.
6732 DIMENSION WTI(0:200)
6733 SAVE IMIN,IMAX,WTI,WTS
6734
6735C...Sum of allowed cross-sections for pileup events.
6736 IF(MPILE.EQ.1) THEN
6737 VINT(131)=SIGT(0,0,5)
6738 IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
6739 IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
6740 IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
6741 IF(MSTP(133).LE.0) RETURN
6742
6743C...Initialize multiplicity distribution at maximum.
6744 XNAVE=VINT(131)*PARP(131)
6745 IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
6746 INAVE=MAX(1,MIN(200,NINT(XNAVE)))
6747 WTI(INAVE)=1D0
6748 WTS=WTI(INAVE)
6749 WTN=WTI(INAVE)*INAVE
6750
6751C...Find shape of multiplicity distribution below maximum.
6752 IMIN=INAVE
6753 DO 100 I=INAVE-1,1,-1
6754 IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
6755 IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
6756 IF(WTI(I).LT.1D-6) GOTO 110
6757 WTS=WTS+WTI(I)
6758 WTN=WTN+WTI(I)*I
6759 IMIN=I
6760 100 CONTINUE
6761
6762C...Find shape of multiplicity distribution above maximum.
6763 110 IMAX=INAVE
6764 DO 120 I=INAVE+1,200
6765 IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
6766 IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
6767 IF(WTI(I).LT.1D-6) GOTO 130
6768 WTS=WTS+WTI(I)
6769 WTN=WTN+WTI(I)*I
6770 IMAX=I
6771 120 CONTINUE
6772 130 VINT(132)=XNAVE
6773 VINT(133)=WTN/WTS
6774 IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
6775 & WTS/(WTS+WTI(1)/XNAVE)
6776 IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
6777 IF(MSTP(133).GE.2) VINT(134)=XNAVE
6778
6779C...Pick multiplicity of pileup events.
6780 ELSE
6781 IF(MSTP(133).LE.0) THEN
6782 MINT(81)=MAX(1,MSTP(134))
6783 ELSE
6784 WTR=WTS*PYR(0)
6785 DO 140 I=IMIN,IMAX
6786 MINT(81)=I
6787 WTR=WTR-WTI(I)
6788 IF(WTR.LE.0D0) GOTO 150
6789 140 CONTINUE
6790 150 CONTINUE
6791 ENDIF
6792 ENDIF
6793
6794C...Format statement for error message.
6795 5000 FORMAT(1X,'Warning: requested average number of events per bunch',
6796 &'crossing too large, ',1P,D12.4)
6797
6798 RETURN
6799 END
6800
6801C*********************************************************************
6802
6803C...PYSAVE
6804C...Saves and restores parameter and cross section values for the
6805C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alternatives.
6806C...Also makes random choice between alternatives.
6807
6808 SUBROUTINE PYSAVE(ISAVE,IGA)
6809
6810C...Double precision and integer declarations.
6811 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6812 IMPLICIT INTEGER(I-N)
6813 INTEGER PYK,PYCHGE,PYCOMP
6814C...Commonblocks.
6815 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
6816 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6817 COMMON/PYINT1/MINT(400),VINT(400)
6818 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
6819 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6820 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
6821 SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/,/PYINT7/
6822C...Local arrays and saved variables.
6823 DIMENSION NCP(15),NSUBCP(15,20),MSUBCP(15,20),COEFCP(15,20,20),
6824 &NGENCP(15,0:20,3),XSECCP(15,0:20,3),SIGTCP(15,0:6,0:6,0:5),
6825 &INTCP(15,20),RECP(15,20)
6826 SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,SIGTCP,INTCP,RECP
6827
6828C...Save list of subprocesses and cross-section information.
6829 IF(ISAVE.EQ.1) THEN
6830 ICP=0
6831 DO 120 I=1,500
6832 IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
6833 ICP=ICP+1
6834 NSUBCP(IGA,ICP)=I
6835 MSUBCP(IGA,ICP)=MSUB(I)
6836 DO 100 J=1,20
6837 COEFCP(IGA,ICP,J)=COEF(I,J)
6838 100 CONTINUE
6839 DO 110 J=1,3
6840 NGENCP(IGA,ICP,J)=NGEN(I,J)
6841 XSECCP(IGA,ICP,J)=XSEC(I,J)
6842 110 CONTINUE
6843 120 CONTINUE
6844 NCP(IGA)=ICP
6845 DO 130 J=1,3
6846 NGENCP(IGA,0,J)=NGEN(0,J)
6847 XSECCP(IGA,0,J)=XSEC(0,J)
6848 130 CONTINUE
6849 DO 160 I1=0,6
6850 DO 150 I2=0,6
6851 DO 140 J=0,5
6852 SIGTCP(IGA,I1,I2,J)=SIGT(I1,I2,J)
6853 140 CONTINUE
6854 150 CONTINUE
6855 160 CONTINUE
6856
6857C...Save various common process variables.
6858 DO 170 J=1,10
6859 INTCP(IGA,J)=MINT(40+J)
6860 170 CONTINUE
6861 INTCP(IGA,11)=MINT(101)
6862 INTCP(IGA,12)=MINT(102)
6863 INTCP(IGA,13)=MINT(107)
6864 INTCP(IGA,14)=MINT(108)
6865 INTCP(IGA,15)=MINT(123)
6866 RECP(IGA,1)=CKIN(3)
6867 RECP(IGA,2)=VINT(318)
6868
6869C...Save cross-section information only.
6870 ELSEIF(ISAVE.EQ.2) THEN
6871 DO 190 ICP=1,NCP(IGA)
6872 I=NSUBCP(IGA,ICP)
6873 DO 180 J=1,3
6874 NGENCP(IGA,ICP,J)=NGEN(I,J)
6875 XSECCP(IGA,ICP,J)=XSEC(I,J)
6876 180 CONTINUE
6877 190 CONTINUE
6878 DO 200 J=1,3
6879 NGENCP(IGA,0,J)=NGEN(0,J)
6880 XSECCP(IGA,0,J)=XSEC(0,J)
6881 200 CONTINUE
6882
6883C...Choose between allowed alternatives.
6884 ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
6885 IF(ISAVE.EQ.4) THEN
6886 XSUMCP=0D0
6887 DO 210 IG=1,MINT(121)
6888 XSUMCP=XSUMCP+XSECCP(IG,0,1)
6889 210 CONTINUE
6890 XSUMCP=XSUMCP*PYR(0)
6891 DO 220 IG=1,MINT(121)
6892 IGA=IG
6893 XSUMCP=XSUMCP-XSECCP(IG,0,1)
6894 IF(XSUMCP.LE.0D0) GOTO 230
6895 220 CONTINUE
6896 230 CONTINUE
6897 ENDIF
6898
6899C...Restore cross-section information.
6900 DO 240 I=1,500
6901 MSUB(I)=0
6902 240 CONTINUE
6903 DO 270 ICP=1,NCP(IGA)
6904 I=NSUBCP(IGA,ICP)
6905 MSUB(I)=MSUBCP(IGA,ICP)
6906 DO 250 J=1,20
6907 COEF(I,J)=COEFCP(IGA,ICP,J)
6908 250 CONTINUE
6909 DO 260 J=1,3
6910 NGEN(I,J)=NGENCP(IGA,ICP,J)
6911 XSEC(I,J)=XSECCP(IGA,ICP,J)
6912 260 CONTINUE
6913 270 CONTINUE
6914 DO 280 J=1,3
6915 NGEN(0,J)=NGENCP(IGA,0,J)
6916 XSEC(0,J)=XSECCP(IGA,0,J)
6917 280 CONTINUE
6918 DO 310 I1=0,6
6919 DO 300 I2=0,6
6920 DO 290 J=0,5
6921 SIGT(I1,I2,J)=SIGTCP(IGA,I1,I2,J)
6922 290 CONTINUE
6923 300 CONTINUE
6924 310 CONTINUE
6925
6926C...Restore various common process variables.
6927 DO 320 J=1,10
6928 MINT(40+J)=INTCP(IGA,J)
6929 320 CONTINUE
6930 MINT(101)=INTCP(IGA,11)
6931 MINT(102)=INTCP(IGA,12)
6932 MINT(107)=INTCP(IGA,13)
6933 MINT(108)=INTCP(IGA,14)
6934 MINT(123)=INTCP(IGA,15)
6935 CKIN(3)=RECP(IGA,1)
6936 CKIN(1)=2D0*CKIN(3)
6937 VINT(318)=RECP(IGA,2)
6938
6939C...Sum up cross-section info (for PYSTAT).
6940 ELSEIF(ISAVE.EQ.5) THEN
6941 DO 330 I=1,500
6942 MSUB(I)=0
6943 NGEN(I,1)=0
6944 NGEN(I,3)=0
6945 XSEC(I,3)=0D0
6946 330 CONTINUE
6947 NGEN(0,1)=0
6948 NGEN(0,2)=0
6949 NGEN(0,3)=0
6950 XSEC(0,3)=0
6951 DO 350 IG=1,MINT(121)
6952 DO 340 ICP=1,NCP(IG)
6953 I=NSUBCP(IG,ICP)
6954 IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1
6955 NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1)
6956 NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3)
6957 XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3)
6958 340 CONTINUE
6959 NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1)
6960 NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2)
6961 NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3)
6962 XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3)
6963 350 CONTINUE
6964 ENDIF
6965
6966 RETURN
6967 END
6968
6969C*********************************************************************
6970
6971C...PYGAGA
6972C...For lepton beams it gives photon-hadron or photon-photon systems
6973C...to be treated with the ordinary machinery and combines this with a
6974C...description of the lepton -> lepton + photon branching.
6975
6976 SUBROUTINE PYGAGA(IGAGA,WTGAGA)
6977
6978C...Double precision and integer declarations.
6979 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6980 IMPLICIT INTEGER(I-N)
6981 INTEGER PYK,PYCHGE,PYCOMP
6982C...Commonblocks.
6983 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
6984 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6985 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6986 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
6987 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6988 COMMON/PYINT1/MINT(400),VINT(400)
6989 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6990 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
6991 &/PYINT5/
6992C...Local variables and data statement.
6993 DIMENSION PMS(2),XMIN(2),XMAX(2),Q2MIN(2),Q2MAX(2),PMC(3),
6994 &X(2),Q2(2),Y(2),THETA(2),PHI(2),PT(2),BETA(3)
6995 SAVE PMS,XMIN,XMAX,Q2MIN,Q2MAX,PMC,X,Q2,THETA,PHI,PT,W2MIN
6996 DATA EPS/1D-4/
6997
6998C...Initialize generation of photons inside leptons.
6999 IF(IGAGA.EQ.1) THEN
7000
7001C...Save quantities on incoming lepton system.
7002 VINT(301)=VINT(1)
7003 VINT(302)=VINT(2)
7004 PMS(1)=VINT(303)**2
7005 IF(MINT(141).EQ.0) PMS(1)=SIGN(VINT(3)**2,VINT(3))
7006 PMS(2)=VINT(304)**2
7007 IF(MINT(142).EQ.0) PMS(2)=SIGN(VINT(4)**2,VINT(4))
7008 PMC(3)=VINT(302)-PMS(1)-PMS(2)
7009 W2MIN=MAX(CKIN(77),2D0*CKIN(3),2D0*CKIN(5))**2
7010
7011C...Calculate range of x and Q2 values allowed in generation.
7012 DO 100 I=1,2
7013 PMC(I)=VINT(302)+PMS(I)-PMS(3-I)
7014 IF(MINT(140+I).NE.0) THEN
7015 XMIN(I)=MAX(CKIN(59+2*I),EPS)
7016 XMAX(I)=MIN(CKIN(60+2*I),1D0-2D0*VINT(301)*SQRT(PMS(I))/
7017 & PMC(I),1D0-EPS)
7018 YMIN=MAX(CKIN(71+2*I),EPS)
7019 YMAX=MIN(CKIN(72+2*I),1D0-EPS)
7020 IF(CKIN(64+2*I).GT.0D0) XMIN(I)=MAX(XMIN(I),
7021 & (YMIN*PMC(3)-CKIN(64+2*I))/PMC(I))
7022 XMAX(I)=MIN(XMAX(I),(YMAX*PMC(3)-CKIN(63+2*I))/PMC(I))
7023 THEMIN=MAX(CKIN(67+2*I),0D0)
7024 THEMAX=MIN(CKIN(68+2*I),PARU(1))
7025 IF(CKIN(68+2*I).LT.0D0) THEMAX=PARU(1)
7026 Q2MIN(I)=MAX(CKIN(63+2*I),XMIN(I)**2*PMS(I)/(1D0-XMIN(I))+
7027 & ((1D0-XMAX(I))*(VINT(302)-2D0*PMS(3-I))-
7028 & 2D0*PMS(I)/(1D0-XMAX(I)))*SIN(THEMIN/2D0)**2,0D0)
7029 Q2MAX(I)=XMAX(I)**2*PMS(I)/(1D0-XMAX(I))+
7030 & ((1D0-XMIN(I))*(VINT(302)-2D0*PMS(3-I))-
7031 & 2D0*PMS(I)/(1D0-XMIN(I)))*SIN(THEMAX/2D0)**2
7032 IF(CKIN(64+2*I).GT.0D0) Q2MAX(I)=MIN(CKIN(64+2*I),Q2MAX(I))
7033C...W limits when lepton on one side only.
7034 IF(MINT(143-I).EQ.0) THEN
7035 XMIN(I)=MAX(XMIN(I),(W2MIN-PMS(3-I))/PMC(I))
7036 IF(CKIN(78).GT.0D0) XMAX(I)=MIN(XMAX(I),
7037 & (CKIN(78)**2-PMS(3-I))/PMC(I))
7038 ENDIF
7039 ENDIF
7040 100 CONTINUE
7041
7042C...W limits when lepton on both sides.
7043 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
7044 IF(CKIN(78).GT.0D0) XMAX(1)=MIN(XMAX(1),
7045 & (CKIN(78)**2+PMC(3)-PMC(2)*XMIN(2))/PMC(1))
7046 IF(CKIN(78).GT.0D0) XMAX(2)=MIN(XMAX(2),
7047 & (CKIN(78)**2+PMC(3)-PMC(1)*XMIN(1))/PMC(2))
7048 IF(IABS(MINT(141)).NE.IABS(MINT(142))) THEN
7049 XMIN(1)=MAX(XMIN(1),(PMS(1)-PMS(2)+VINT(302)*(W2MIN-
7050 & PMS(1)-PMS(2))/(PMC(2)*XMAX(2)+PMS(1)-PMS(2)))/PMC(1))
7051 XMIN(2)=MAX(XMIN(2),(PMS(2)-PMS(1)+VINT(302)*(W2MIN-
7052 & PMS(1)-PMS(2))/(PMC(1)*XMAX(1)+PMS(2)-PMS(1)))/PMC(2))
7053 ELSE
7054 XMIN(1)=MAX(XMIN(1),W2MIN/(VINT(302)*XMAX(2)))
7055 XMIN(2)=MAX(XMIN(2),W2MIN/(VINT(302)*XMAX(1)))
7056 ENDIF
7057 ENDIF
7058
7059C...Q2 and W values and photon flux weight factors for initialization.
7060 ELSEIF(IGAGA.EQ.2) THEN
7061 ISUB=MINT(1)
7062 MINT(15)=0
7063 MINT(16)=0
7064
7065C...W value for photon on one or both sides, and for processes
7066C...with gamma-gamma cross section peaked at small shat.
7067 IF(MINT(141).NE.0.AND.MINT(142).EQ.0) THEN
7068 VINT(2)=VINT(302)+PMS(1)-PMC(1)*(1D0-XMAX(1))
7069 ELSEIF(MINT(141).EQ.0.AND.MINT(142).NE.0) THEN
7070 VINT(2)=VINT(302)+PMS(2)-PMC(2)*(1D0-XMAX(2))
7071 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
7072 VINT(2)=MAX(CKIN(77)**2,12D0*MAX(CKIN(3),CKIN(5))**2)
7073 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
7074 ELSE
7075 VINT(2)=XMAX(1)*XMAX(2)*VINT(302)
7076 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
7077 ENDIF
7078 VINT(1)=SQRT(MAX(0D0,VINT(2)))
7079
7080C...Upper estimate of photon flux weight factor.
7081C...Initialization Q2 scale. Flag incoming unresolved photon.
7082 WTGAGA=1D0
7083 DO 110 I=1,2
7084 IF(MINT(140+I).NE.0) THEN
7085 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
7086 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
7087 IF(ISUB.EQ.99.AND.MINT(106+I).EQ.4.AND.MINT(109-I).EQ.3)
7088 & THEN
7089 Q2INIT=5D0+Q2MIN(3-I)
7090 ELSEIF(ISUB.EQ.99.AND.MINT(106+I).EQ.4) THEN
7091 Q2INIT=PMAS(PYCOMP(113),1)**2+Q2MIN(3-I)
7092 ELSEIF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
7093 Q2INIT=MAX(CKIN(1),2D0*CKIN(3),2D0*CKIN(5))**2/3D0
7094 ELSEIF((ISUB.EQ.138.AND.I.EQ.2).OR.
7095 & (ISUB.EQ.139.AND.I.EQ.1)) THEN
7096 Q2INIT=VINT(2)/3D0
7097 ELSEIF(ISUB.EQ.140) THEN
7098 Q2INIT=VINT(2)/2D0
7099 ELSE
7100 Q2INIT=Q2MIN(I)
7101 ENDIF
7102 VINT(2+I)=-SQRT(MAX(Q2MIN(I),MIN(Q2MAX(I),Q2INIT)))
7103 IF(MSTP(14).EQ.0.OR.(ISUB.GE.131.AND.ISUB.LE.140))
7104 & MINT(14+I)=22
7105 VINT(306+I)=VINT(2+I)**2
7106 ENDIF
7107 110 CONTINUE
7108 VINT(320)=WTGAGA
7109
7110C...Update pTmin and cross section information.
7111 IF(MSTP(82).LE.1) THEN
7112 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
7113 ELSE
7114 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
7115 ENDIF
7116 VINT(149)=4D0*PTMN**2/VINT(2)
7117 VINT(154)=PTMN
7118 CALL PYXTOT
7119 VINT(318)=VINT(317)
7120
7121C...Generate photons inside leptons and
7122C...calculate photon flux weight factors.
7123 ELSEIF(IGAGA.EQ.3) THEN
7124 ISUB=MINT(1)
7125 MINT(15)=0
7126 MINT(16)=0
7127
7128C...Generate phase space point and check against cuts.
7129 LOOP=0
7130 120 LOOP=LOOP+1
7131 DO 130 I=1,2
7132 IF(MINT(140+I).NE.0) THEN
7133C...Pick x and Q2
7134 X(I)=XMIN(I)*(XMAX(I)/XMIN(I))**PYR(0)
7135 Q2(I)=Q2MIN(I)*(Q2MAX(I)/Q2MIN(I))**PYR(0)
7136C...Cuts on internal consistency in x and Q2.
7137 IF(Q2(I).LT.X(I)**2*PMS(I)/(1D0-X(I))) GOTO 120
7138 IF(Q2(I).GT.(1D0-X(I))*(VINT(302)-2D0*PMS(3-I))-
7139 & (2D0-X(I)**2)*PMS(I)/(1D0-X(I))) GOTO 120
7140C...Cuts on y and theta.
7141 Y(I)=(PMC(I)*X(I)+Q2(I))/PMC(3)
7142 IF(Y(I).LT.CKIN(71+2*I).OR.Y(I).GT.CKIN(72+2*I)) GOTO 120
7143 RAT=((1D0-X(I))*Q2(I)-X(I)**2*PMS(I))/
7144 & ((1D0-X(I))**2*(VINT(302)-2D0*PMS(3-I)-2D0*PMS(I)))
7145 THETA(I)=2D0*ASIN(SQRT(MAX(0D0,MIN(1D0,RAT))))
7146 IF(THETA(I).LT.CKIN(67+2*I)) GOTO 120
7147 IF(CKIN(68+2*I).GT.0D0.AND.THETA(I).GT.CKIN(68+2*I))
7148 & GOTO 120
7149
7150C...Phi angle isotropic. Reconstruct pT.
7151 PHI(I)=PARU(2)*PYR(0)
7152 PT(I)=SQRT(((1D0-X(I))*PMC(I))**2/(4D0*VINT(302))-
7153 & PMS(I))*SIN(THETA(I))
7154
7155C...Store info on variables selected, for documentation purposes.
7156 VINT(2+I)=-SQRT(Q2(I))
7157 VINT(304+I)=X(I)
7158 VINT(306+I)=Q2(I)
7159 VINT(308+I)=Y(I)
7160 VINT(310+I)=THETA(I)
7161 VINT(312+I)=PHI(I)
7162 ELSE
7163 VINT(304+I)=1D0
7164 VINT(306+I)=0D0
7165 VINT(308+I)=1D0
7166 VINT(310+I)=0D0
7167 VINT(312+I)=0D0
7168 ENDIF
7169 130 CONTINUE
7170
7171C...Cut on W combines info from two sides.
7172 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
7173 W2=-Q2(1)-Q2(2)+0.5D0*X(1)*PMC(1)*X(2)*PMC(2)/VINT(302)-
7174 & 2D0*PT(1)*PT(2)*COS(PHI(1)-PHI(2))+2D0*
7175 & SQRT((0.5D0*X(1)*PMC(1)/VINT(301))**2+Q2(1)-PT(1)**2)*
7176 & SQRT((0.5D0*X(2)*PMC(2)/VINT(301))**2+Q2(2)-PT(2)**2)
7177 IF(W2.LT.W2MIN) GOTO 120
7178 IF(CKIN(78).GT.0D0.AND.W2.GT.CKIN(78)**2) GOTO 120
7179 PMS1=-Q2(1)
7180 PMS2=-Q2(2)
7181 ELSEIF(MINT(141).NE.0) THEN
7182 W2=(VINT(302)+PMS(1))*X(1)+PMS(2)*(1D0-X(1))
7183 PMS1=-Q2(1)
7184 PMS2=PMS(2)
7185 ELSEIF(MINT(142).NE.0) THEN
7186 W2=(VINT(302)+PMS(2))*X(2)+PMS(1)*(1D0-X(2))
7187 PMS1=PMS(1)
7188 PMS2=-Q2(2)
7189 ENDIF
7190
7191C...Store kinematics info for photon(s) in subsystem cm frame.
7192 VINT(2)=W2
7193 VINT(1)=SQRT(W2)
7194 VINT(291)=0D0
7195 VINT(292)=0D0
7196 VINT(293)=0.5D0*SQRT((W2-PMS1-PMS2)**2-4D0*PMS1*PMS2)/VINT(1)
7197 VINT(294)=0.5D0*(W2+PMS1-PMS2)/VINT(1)
7198 VINT(295)=SIGN(SQRT(ABS(PMS1)),PMS1)
7199 VINT(296)=0D0
7200 VINT(297)=0D0
7201 VINT(298)=-VINT(293)
7202 VINT(299)=0.5D0*(W2+PMS2-PMS1)/VINT(1)
7203 VINT(300)=SIGN(SQRT(ABS(PMS2)),PMS2)
7204
7205C...Assign weight for photon flux; different for transverse and
7206C...longitudinal photons. Flag incoming unresolved photon.
7207 WTGAGA=1D0
7208 DO 140 I=1,2
7209 IF(MINT(140+I).NE.0) THEN
7210 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
7211 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
7212 IF(MSTP(16).EQ.0) THEN
7213 XY=X(I)
7214 ELSE
7215 WTGAGA=WTGAGA*X(I)/Y(I)
7216 XY=Y(I)
7217 ENDIF
7218 IF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
7219 WTGAGA=WTGAGA*(1D0-XY)
7220 ELSEIF(I.EQ.1.AND.(ISUB.EQ.139.OR.ISUB.EQ.140)) THEN
7221 WTGAGA=WTGAGA*(1D0-XY)
7222 ELSEIF(I.EQ.2.AND.(ISUB.EQ.138.OR.ISUB.EQ.140)) THEN
7223 WTGAGA=WTGAGA*(1D0-XY)
7224 ELSE
7225 WTGAGA=WTGAGA*(0.5D0*(1D0+(1D0-XY)**2)-
7226 & PMS(I)*XY**2/Q2(I))
7227 ENDIF
7228 IF(MINT(106+I).EQ.0) MINT(14+I)=22
7229 ENDIF
7230 140 CONTINUE
7231 VINT(319)=WTGAGA
7232 MINT(143)=LOOP
7233
7234C...Update pTmin and cross section information.
7235 IF(MSTP(82).LE.1) THEN
7236 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
7237 ELSE
7238 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
7239 ENDIF
7240 VINT(149)=4D0*PTMN**2/VINT(2)
7241 VINT(154)=PTMN
7242 CALL PYXTOT
7243
7244C...Reconstruct kinematics of photons inside leptons.
7245 ELSEIF(IGAGA.EQ.4) THEN
7246
7247C...Make place for incoming particles and scattered leptons.
7248 MOVE=3
7249 IF(MINT(141).NE.0.AND.MINT(142).NE.0) MOVE=4
7250 MINT(4)=MINT(4)+MOVE
7251 DO 160 I=MINT(84)-MOVE,MINT(83)+1,-1
7252 IF(K(I,1).EQ.21) THEN
7253 DO 150 J=1,5
7254 K(I+MOVE,J)=K(I,J)
7255 P(I+MOVE,J)=P(I,J)
7256 V(I+MOVE,J)=V(I,J)
7257 150 CONTINUE
7258 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
7259 & K(I+MOVE,3)=K(I,3)+MOVE
7260 IF(K(I,4).GT.MINT(83).AND.K(I,4).LE.MINT(84))
7261 & K(I+MOVE,4)=K(I,4)+MOVE
7262 IF(K(I,5).GT.MINT(83).AND.K(I,5).LE.MINT(84))
7263 & K(I+MOVE,5)=K(I,5)+MOVE
7264 ENDIF
7265 160 CONTINUE
7266 DO 170 I=MINT(84)+1,N
7267 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
7268 & K(I,3)=K(I,3)+MOVE
7269 170 CONTINUE
7270
7271C...Fill in incoming particles.
7272 DO 190 I=MINT(83)+1,MINT(83)+MOVE
7273 DO 180 J=1,5
7274 K(I,J)=0
7275 P(I,J)=0D0
7276 V(I,J)=0D0
7277 180 CONTINUE
7278 190 CONTINUE
7279 DO 200 I=1,2
7280 K(MINT(83)+I,1)=21
7281 IF(MINT(140+I).NE.0) THEN
7282 K(MINT(83)+I,2)=MINT(140+I)
7283 P(MINT(83)+I,5)=VINT(302+I)
7284 ELSE
7285 K(MINT(83)+I,2)=MINT(10+I)
7286 P(MINT(83)+I,5)=VINT(2+I)
7287 ENDIF
7288 P(MINT(83)+I,3)=0.5D0*SQRT((PMC(3)**2-4D0*PMS(1)*PMS(2))/
7289 & VINT(302))*(-1D0)**(I+1)
7290 P(MINT(83)+I,4)=0.5D0*PMC(I)/VINT(301)
7291 200 CONTINUE
7292
7293C...New mother-daughter relations in documentation section.
7294 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
7295 K(MINT(83)+1,4)=MINT(83)+3
7296 K(MINT(83)+1,5)=MINT(83)+5
7297 K(MINT(83)+2,4)=MINT(83)+4
7298 K(MINT(83)+2,5)=MINT(83)+6
7299 K(MINT(83)+3,3)=MINT(83)+1
7300 K(MINT(83)+5,3)=MINT(83)+1
7301 K(MINT(83)+4,3)=MINT(83)+2
7302 K(MINT(83)+6,3)=MINT(83)+2
7303 ELSEIF(MINT(141).NE.0) THEN
7304 K(MINT(83)+1,4)=MINT(83)+3
7305 K(MINT(83)+1,5)=MINT(83)+4
7306 K(MINT(83)+2,4)=MINT(83)+5
7307 K(MINT(83)+3,3)=MINT(83)+1
7308 K(MINT(83)+4,3)=MINT(83)+1
7309 K(MINT(83)+5,3)=MINT(83)+2
7310 ELSEIF(MINT(142).NE.0) THEN
7311 K(MINT(83)+1,4)=MINT(83)+4
7312 K(MINT(83)+2,4)=MINT(83)+3
7313 K(MINT(83)+2,5)=MINT(83)+5
7314 K(MINT(83)+3,3)=MINT(83)+2
7315 K(MINT(83)+4,3)=MINT(83)+1
7316 K(MINT(83)+5,3)=MINT(83)+2
7317 ENDIF
7318
7319C...Fill scattered lepton(s).
7320 DO 210 I=1,2
7321 IF(MINT(140+I).NE.0) THEN
7322 LSC=MINT(83)+MIN(I+2,MOVE)
7323 K(LSC,1)=21
7324 K(LSC,2)=MINT(140+I)
7325 P(LSC,1)=PT(I)*COS(PHI(I))
7326 P(LSC,2)=PT(I)*SIN(PHI(I))
7327 P(LSC,4)=(1D0-X(I))*P(MINT(83)+I,4)
7328 P(LSC,3)=SQRT(P(LSC,4)**2-PMS(I))*COS(THETA(I))*
7329 & (-1D0)**(I-1)
7330 P(LSC,5)=VINT(302+I)
7331 ENDIF
7332 210 CONTINUE
7333
7334C...Find incoming four-vectors to subprocess.
7335 K(N+1,1)=21
7336 IF(MINT(141).NE.0) THEN
7337 DO 220 J=1,4
7338 P(N+1,J)=P(MINT(83)+1,J)-P(MINT(83)+3,J)
7339 220 CONTINUE
7340 ELSE
7341 DO 230 J=1,4
7342 P(N+1,J)=P(MINT(83)+1,J)
7343 230 CONTINUE
7344 ENDIF
7345 K(N+2,1)=21
7346 IF(MINT(142).NE.0) THEN
7347 DO 240 J=1,4
7348 P(N+2,J)=P(MINT(83)+2,J)-P(MINT(83)+MOVE,J)
7349 240 CONTINUE
7350 ELSE
7351 DO 250 J=1,4
7352 P(N+2,J)=P(MINT(83)+2,J)
7353 250 CONTINUE
7354 ENDIF
7355
7356C...Define boost and rotation between hadronic subsystem and
7357C...collision rest frame; boost hadronic subsystem to this frame.
7358 DO 260 J=1,3
7359 BETA(J)=(P(N+1,J)+P(N+2,J))/(P(N+1,4)+P(N+2,4))
7360 260 CONTINUE
7361 CALL PYROBO(N+1,N+2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
7362 BPHI=PYANGL(P(N+1,1),P(N+1,2))
7363 CALL PYROBO(N+1,N+2,0D0,-BPHI,0D0,0D0,0D0)
7364 BTHETA=PYANGL(P(N+1,3),P(N+1,1))
7365 CALL PYROBO(MINT(83)+MOVE+1,N,BTHETA,BPHI,BETA(1),BETA(2),
7366 & BETA(3))
7367
7368C...Add on scattered leptons to final state.
7369 DO 280 I=1,2
7370 IF(MINT(140+I).NE.0) THEN
7371 LSC=MINT(83)+MIN(I+2,MOVE)
7372 N=N+1
7373 DO 270 J=1,5
7374 K(N,J)=K(LSC,J)
7375 P(N,J)=P(LSC,J)
7376 V(N,J)=V(LSC,J)
7377 270 CONTINUE
7378 K(N,1)=1
7379 K(N,3)=LSC
7380 ENDIF
7381 280 CONTINUE
7382 ENDIF
7383
7384 RETURN
7385 END
7386
7387C*********************************************************************
7388
7389C...PYRAND
7390C...Generates quantities characterizing the high-pT scattering at the
7391C...parton level according to the matrix elements. Chooses incoming,
7392C...reacting partons, their momentum fractions and one of the possible
7393C...subprocesses.
7394
7395 SUBROUTINE PYRAND
7396
7397C...Double precision and integer declarations.
7398 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
7399 IMPLICIT INTEGER(I-N)
7400 INTEGER PYK,PYCHGE,PYCOMP
7401C...Parameter statement to help give large particle numbers.
7402 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
7403 &KEXCIT=4000000,KDIMEN=5000000)
7404
7405C...User process initialization and event commonblocks.
7406 INTEGER MAXPUP
7407 PARAMETER (MAXPUP=100)
7408 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
7409 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
7410 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
7411 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
7412 &LPRUP(MAXPUP)
7413 INTEGER MAXNUP
7414 PARAMETER (MAXNUP=500)
7415 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
7416 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
7417 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
7418 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
7419 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
7420 SAVE /HEPRUP/,/HEPEUP/
7421
7422C...Commonblocks.
7423 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7424 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
7425 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
7426 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
7427 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
7428 COMMON/PYINT1/MINT(400),VINT(400)
7429 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
7430 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
7431 COMMON/PYINT4/MWID(500),WIDS(500,5)
7432 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
7433 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
7434 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
7435 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
7436 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYMSSM/
7437C...Local arrays.
7438 DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2)
7439
7440C...Parameters and data used in elastic/diffractive treatment.
7441 DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/,
7442 &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
7443
7444C...Initial values, specifically for (first) semihard interaction.
7445 MINT(10)=0
7446 MINT(17)=0
7447 MINT(18)=0
7448 VINT(97)=1D0
7449 VINT(143)=1D0
7450 VINT(144)=1D0
7451 VINT(157)=0D0
7452 VINT(158)=0D0
7453 MFAIL=0
7454 IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1
7455 ISUB=0
7456 ISTSB=0
7457 LOOP=0
7458 100 LOOP=LOOP+1
7459 MINT(51)=0
7460 MINT(143)=1
7461
7462C...Start by assuming incoming photon is entering subprocess.
7463 IF(MINT(11).EQ.22) THEN
7464 MINT(15)=22
7465 VINT(307)=VINT(3)**2
7466 ENDIF
7467 IF(MINT(12).EQ.22) THEN
7468 MINT(16)=22
7469 VINT(308)=VINT(4)**2
7470 ENDIF
7471 MINT(103)=MINT(11)
7472 MINT(104)=MINT(12)
7473
7474C...Choice of process type - first event of pileup.
7475 INMULT=0
7476 IF(MINT(82).EQ.1.AND.ISUB.GE.91.AND.ISUB.LE.96) THEN
7477 ELSEIF(MINT(82).EQ.1) THEN
7478
7479C...For gamma-p or gamma-gamma first pick between alternatives.
7480 IGA=0
7481 IF(MINT(121).GT.1) CALL PYSAVE(4,IGA)
7482 MINT(122)=IGA
7483
7484C...For real gamma + gamma with different nature, flip at random.
7485 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
7486 & MSTP(14).LE.10.AND.PYR(0).GT.0.5D0) THEN
7487 MINTSV=MINT(41)
7488 MINT(41)=MINT(42)
7489 MINT(42)=MINTSV
7490 MINTSV=MINT(45)
7491 MINT(45)=MINT(46)
7492 MINT(46)=MINTSV
7493 MINTSV=MINT(107)
7494 MINT(107)=MINT(108)
7495 MINT(108)=MINTSV
7496 IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47)
7497 ENDIF
7498
7499C...Pick process type, possibly by user process machinery.
7500C...(If the latter, also event will be picked here.)
7501 IF(MINT(111).EQ.11.AND.IABS(IDWTUP).EQ.2.AND.LOOP.GE.2) THEN
7502 CALL UPEVNT
7503 ELSEIF(MINT(111).EQ.11.AND.IABS(IDWTUP).GE.3) THEN
7504 CALL UPEVNT
7505 ISUB=0
7506 110 ISUB=ISUB+1
7507 IF((ISET(ISUB).NE.11.OR.KFPR(ISUB,2).NE.IDPRUP).AND.
7508 & ISUB.LT.500) GOTO 110
7509 ELSE
7510 RSUB=XSEC(0,1)*PYR(0)
7511 DO 120 I=1,500
7512 IF(MSUB(I).NE.1) GOTO 120
7513 ISUB=I
7514 RSUB=RSUB-XSEC(I,1)
7515 IF(RSUB.LE.0D0) GOTO 130
7516 120 CONTINUE
7517 130 IF(ISUB.EQ.95) ISUB=96
7518 IF(ISUB.EQ.96) INMULT=1
7519 IF(ISET(ISUB).EQ.11) THEN
7520 IDPRUP=KFPR(ISUB,2)
7521 CALL UPEVNT
7522 ENDIF
7523 ENDIF
7524
7525C...Choice of inclusive process type - pileup events.
7526 ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
7527 RSUB=VINT(131)*PYR(0)
7528 ISUB=96
7529 IF(RSUB.GT.SIGT(0,0,5)) ISUB=94
7530 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93
7531 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92
7532 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2))
7533 & ISUB=91
7534 IF(ISUB.EQ.96) INMULT=1
7535 ENDIF
7536
7537C...Choice of photon energy and flux factor inside lepton.
7538 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
7539 CALL PYGAGA(3,WTGAGA)
7540 IF(ISUB.GE.131.AND.ISUB.LE.140) THEN
7541 CKIN(3)=MAX(VINT(285),VINT(154))
7542 CKIN(1)=2D0*CKIN(3)
7543 ENDIF
7544C...When necessary set direct/resolved photon by hand.
7545 ELSEIF(MINT(15).EQ.22.OR.MINT(16).EQ.22) THEN
7546 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
7547 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
7548 ENDIF
7549
7550C...Restrict direct*resolved processes to pTmin >= Q,
7551C...to avoid doublecounting with DIS.
7552 IF(MSTP(18).EQ.3.AND.ISUB.GE.131.AND.ISUB.LE.136) THEN
7553 IF(MINT(15).EQ.22) THEN
7554 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(3)))
7555 ELSE
7556 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(4)))
7557 ENDIF
7558 CKIN(1)=2D0*CKIN(3)
7559 ENDIF
7560
7561C...Set up for multiple interactions.
7562 IF(INMULT.EQ.1) CALL PYMULT(2)
7563
7564C...Loopback point for minimum bias in photon physics.
7565 LOOP2=0
7566 140 LOOP2=LOOP2+1
7567 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+MINT(143)
7568 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+MINT(143)
7569 IF(ISUB.EQ.96.AND.LOOP2.EQ.1.AND.MINT(82).EQ.1)
7570 &NGEN(97,1)=NGEN(97,1)+MINT(143)
7571 MINT(1)=ISUB
7572 ISTSB=ISET(ISUB)
7573
7574C...Random choice of flavour for some SUSY processes.
7575 IF(ISUB.GE.201.AND.ISUB.LE.301) THEN
7576C...~e_L ~nu_e or ~mu_L ~nu_mu.
7577 IF(ISUB.EQ.210) THEN
7578 KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0))
7579 KFPR(ISUB,2)=KFPR(ISUB,1)+1
7580C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
7581 ELSEIF(ISUB.EQ.213) THEN
7582 KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0))
7583 KFPR(ISUB,2)=KFPR(ISUB,1)
7584C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
7585 ELSEIF(ISUB.GE.246.AND.ISUB.LE.259) THEN
7586 IF(ISUB.GE.258) THEN
7587 RKF=4D0
7588 ELSE
7589 RKF=5D0
7590 ENDIF
7591 IF(MOD(ISUB,2).EQ.0) THEN
7592 KFPR(ISUB,1)=KSUSY1+1+INT(RKF*PYR(0))
7593 ELSE
7594 KFPR(ISUB,1)=KSUSY2+1+INT(RKF*PYR(0))
7595 ENDIF
7596C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
7597 ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN
7598 IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN
7599 KSU1=KSUSY1
7600 KSU2=KSUSY1
7601 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN
7602 KSU1=KSUSY2
7603 KSU2=KSUSY2
7604 ELSEIF(PYR(0).LT.0.5D0) THEN
7605 KSU1=KSUSY1
7606 KSU2=KSUSY2
7607 ELSE
7608 KSU1=KSUSY2
7609 KSU2=KSUSY1
7610 ENDIF
7611 KFPR(ISUB,1)=KSU1+1+INT(4D0*PYR(0))
7612 KFPR(ISUB,2)=KSU2+1+INT(4D0*PYR(0))
7613C...~q ~q(bar); ~q = ~d, ~u, ~s, or ~c.
7614 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN
7615 KFPR(ISUB,1)=KSUSY1+1+INT(4D0*PYR(0))
7616 KFPR(ISUB,2)=KFPR(ISUB,1)
7617 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN
7618 KFPR(ISUB,1)=KSUSY2+1+INT(4D0*PYR(0))
7619 KFPR(ISUB,2)=KFPR(ISUB,1)
7620C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
7621 ELSEIF(ISUB.GE.281.AND.ISUB.LE.286) THEN
7622 IF(ISUB.EQ.281.OR.ISUB.EQ.284) THEN
7623 KSU1=KSUSY1
7624 KSU2=KSUSY1
7625 ELSEIF(ISUB.EQ.282.OR.ISUB.EQ.285) THEN
7626 KSU1=KSUSY2
7627 KSU2=KSUSY2
7628 ELSEIF(PYR(0).LT.0.5D0) THEN
7629 KSU1=KSUSY1
7630 KSU2=KSUSY2
7631 ELSE
7632 KSU1=KSUSY2
7633 KSU2=KSUSY1
7634 ENDIF
7635 IF(ISUB.EQ.281.OR.ISUB.LE.283) THEN
7636 RKF=5D0
7637 ELSE
7638 RKF=4D0
7639 ENDIF
7640 KFPR(ISUB,2)=KSU2+1+INT(RKF*PYR(0))
7641 ENDIF
7642 ENDIF
7643
7644C...Find resonances (explicit or implicit in cross-section).
7645 MINT(72)=0
7646 KFR1=0
7647 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
7648 KFR1=KFPR(ISUB,1)
7649 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR.
7650 & ISUB.EQ.171.OR.ISUB.EQ.176) THEN
7651 KFR1=23
7652 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR.
7653 & ISUB.EQ.177) THEN
7654 KFR1=24
7655 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
7656 KFR1=25
7657 IF(MSTP(46).EQ.5) THEN
7658 KFR1=89
7659 PMAS(89,1)=PARP(45)
7660 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
7661 ENDIF
7662 ELSEIF(ISUB.EQ.194) THEN
7663 KFR1=KTECHN+113
7664 ELSEIF(ISUB.EQ.195) THEN
7665 KFR1=KTECHN+213
7666 ELSEIF(ISUB.GE.361.AND.ISUB.LE.368) THEN
7667 KFR1=KTECHN+113
7668 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
7669 KFR1=KTECHN+213
7670 ENDIF
7671 CKMX=CKIN(2)
7672 IF(CKMX.LE.0D0) CKMX=VINT(1)
7673 KCR1=PYCOMP(KFR1)
7674 IF(KFR1.NE.0) THEN
7675 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
7676 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
7677 ENDIF
7678 IF(KFR1.NE.0) THEN
7679 TAUR1=PMAS(KCR1,1)**2/VINT(2)
7680 IF(KFR1.EQ.KTECHN+113) THEN
7681 CALL PYTECM(S1,S2)
7682 TAUR1=S1/VINT(2)
7683 ENDIF
7684 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
7685 MINT(72)=1
7686 MINT(73)=KFR1
7687 VINT(73)=TAUR1
7688 VINT(74)=GAMR1
7689 ENDIF
7690 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.(ISUB.GE.364.AND.ISUB.LE.368))
7691 $THEN
7692 KFR2=23
7693 IF(ISUB.EQ.194) THEN
7694 KFR2=KTECHN+223
7695 ELSEIF(ISUB.GE.364.AND.ISUB.LE.368) THEN
7696 KFR2=KTECHN+223
7697 ENDIF
7698 KCR2=PYCOMP(KFR2)
7699 TAUR2=PMAS(KCR2,1)**2/VINT(2)
7700 IF(KFR2.EQ.KTECHN+223) THEN
7701 CALL PYTECM(S1,S2)
7702 TAUR2=S2/VINT(2)
7703 ENDIF
7704 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
7705 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
7706 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
7707 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
7708 MINT(72)=2
7709 MINT(74)=KFR2
7710 VINT(75)=TAUR2
7711 VINT(76)=GAMR2
7712 ELSEIF(KFR2.NE.0) THEN
7713 KFR1=KFR2
7714 TAUR1=TAUR2
7715 GAMR1=GAMR2
7716 MINT(72)=1
7717 MINT(73)=KFR1
7718 VINT(73)=TAUR1
7719 VINT(74)=GAMR1
7720 ENDIF
7721 ENDIF
7722
7723C...Find product masses and minimum pT of process,
7724C...optionally with broadening according to a truncated Breit-Wigner.
7725 VINT(63)=0D0
7726 VINT(64)=0D0
7727 MINT(71)=0
7728 VINT(71)=CKIN(3)
7729 IF(MINT(82).GE.2) VINT(71)=0D0
7730 VINT(80)=1D0
7731 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7732 NBW=0
7733 DO 160 I=1,2
7734 PMMN(I)=0D0
7735 IF(KFPR(ISUB,I).EQ.0) THEN
7736 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
7737 & PARP(41)) THEN
7738 VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7739 ELSE
7740 NBW=NBW+1
7741C...This prevents SUSY/t particles from becoming too light.
7742 KFLW=KFPR(ISUB,I)
7743 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
7744 KCW=PYCOMP(KFLW)
7745 PMMN(I)=PMAS(KCW,1)
7746 DO 150 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
7747 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
7748 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
7749 & PMAS(PYCOMP(KFDP(IDC,2)),1)
7750 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
7751 & PMAS(PYCOMP(KFDP(IDC,3)),1)
7752 PMMN(I)=MIN(PMMN(I),PMSUM)
7753 ENDIF
7754 150 CONTINUE
7755 ELSEIF(KFLW.EQ.6) THEN
7756 PMMN(I)=PMAS(24,1)+PMAS(5,1)
7757 ENDIF
7758 ENDIF
7759 160 CONTINUE
7760 IF(NBW.GE.1) THEN
7761 CKIN41=CKIN(41)
7762 CKIN43=CKIN(43)
7763 CKIN(41)=MAX(PMMN(1),CKIN(41))
7764 CKIN(43)=MAX(PMMN(2),CKIN(43))
7765 CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
7766 CKIN(41)=CKIN41
7767 CKIN(43)=CKIN43
7768 IF(MINT(51).EQ.1) THEN
7769 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7770 IF(MFAIL.EQ.1) THEN
7771 MSTI(61)=1
7772 RETURN
7773 ENDIF
7774 GOTO 100
7775 ENDIF
7776 VINT(63)=PQM3**2
7777 VINT(64)=PQM4**2
7778 ENDIF
7779 IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
7780 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
7781 ENDIF
7782
7783C...Prepare for additional variable choices in 2 -> 3.
7784 IF(ISTSB.EQ.5) THEN
7785 VINT(201)=0D0
7786 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
7787 VINT(206)=VINT(201)
7788 VINT(204)=PMAS(23,1)
7789 IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
7790 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
7791 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
7792 & ISUB.EQ.186.OR.ISUB.EQ.187) VINT(204)=VINT(201)
7793 VINT(209)=VINT(204)
7794 ENDIF
7795
7796C...Select incoming VDM particle (rho/omega/phi/J/psi).
7797 IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND.
7798 &(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7)) THEN
7799 VRN=PYR(0)*SIGT(0,0,5)
7800 IF(MINT(101).LE.1) THEN
7801 I1MN=0
7802 I1MX=0
7803 ELSE
7804 I1MN=1
7805 I1MX=MINT(101)
7806 ENDIF
7807 IF(MINT(102).LE.1) THEN
7808 I2MN=0
7809 I2MX=0
7810 ELSE
7811 I2MN=1
7812 I2MX=MINT(102)
7813 ENDIF
7814 DO 180 I1=I1MN,I1MX
7815 KFV1=110*I1+3
7816 DO 170 I2=I2MN,I2MX
7817 KFV2=110*I2+3
7818 VRN=VRN-SIGT(I1,I2,5)
7819 IF(VRN.LE.0D0) GOTO 190
7820 170 CONTINUE
7821 180 CONTINUE
7822 190 IF(MINT(101).GE.2) MINT(103)=KFV1
7823 IF(MINT(102).GE.2) MINT(104)=KFV2
7824 ENDIF
7825
7826 IF(ISTSB.EQ.0) THEN
7827C...Elastic scattering or single or double diffractive scattering.
7828
7829C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
7830 MINT(103)=MINT(11)
7831 MINT(104)=MINT(12)
7832 PMM(1)=VINT(3)
7833 PMM(2)=VINT(4)
7834 IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN
7835 JJ=ISUB-90
7836 VRN=PYR(0)*SIGT(0,0,JJ)
7837 IF(MINT(101).LE.1) THEN
7838 I1MN=0
7839 I1MX=0
7840 ELSE
7841 I1MN=1
7842 I1MX=MINT(101)
7843 ENDIF
7844 IF(MINT(102).LE.1) THEN
7845 I2MN=0
7846 I2MX=0
7847 ELSE
7848 I2MN=1
7849 I2MX=MINT(102)
7850 ENDIF
7851 DO 210 I1=I1MN,I1MX
7852 KFV1=110*I1+3
7853 DO 200 I2=I2MN,I2MX
7854 KFV2=110*I2+3
7855 VRN=VRN-SIGT(I1,I2,JJ)
7856 IF(VRN.LE.0D0) GOTO 220
7857 200 CONTINUE
7858 210 CONTINUE
7859 220 IF(MINT(101).GE.2) THEN
7860 MINT(103)=KFV1
7861 PMM(1)=PYMASS(KFV1)
7862 ENDIF
7863 IF(MINT(102).GE.2) THEN
7864 MINT(104)=KFV2
7865 PMM(2)=PYMASS(KFV2)
7866 ENDIF
7867 ENDIF
7868 VINT(67)=PMM(1)
7869 VINT(68)=PMM(2)
7870
7871C...Select mass for GVMD states (rejecting previous assignment).
7872 Q0S=4D0*PARP(15)**2
7873 Q1S=4D0*VINT(154)**2
7874 LOOP3=0
7875 230 LOOP3=LOOP3+1
7876 DO 240 JT=1,2
7877 IF(MINT(106+JT).EQ.3) THEN
7878 PS=VINT(2+JT)**2
7879 PMM(JT)=(Q0S+PS)*(Q1S+PS)/
7880 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
7881 IF(MINT(102+JT).GE.333) PMM(JT)=PMM(JT)-
7882 & PMAS(PYCOMP(113),1)+PMAS(PYCOMP(MINT(102+JT)),1)
7883 ENDIF
7884 240 CONTINUE
7885 IF(PMM(1)+PMM(2)+PARP(104).GE.VINT(1)) THEN
7886 IF(LOOP3.LT.100.AND.(MINT(107).EQ.3.OR.MINT(108).EQ.3))
7887 & GOTO 230
7888 GOTO 100
7889 ENDIF
7890
7891C...Side/sides of diffractive system.
7892 MINT(17)=0
7893 MINT(18)=0
7894 IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1
7895 IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1
7896
7897C...Find masses of particles and minimal masses of diffractive states.
7898 DO 250 JT=1,2
7899 PDIF(JT)=PMM(JT)
7900 VINT(68+JT)=PDIF(JT)
7901 IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102)
7902 250 CONTINUE
7903 SH=VINT(2)
7904 SQM1=PMM(1)**2
7905 SQM2=PMM(2)**2
7906 SQM3=PDIF(1)**2
7907 SQM4=PDIF(2)**2
7908 SMRES1=(PMM(1)+PMRC)**2
7909 SMRES2=(PMM(2)+PMRC)**2
7910
7911C...Find elastic slope and lower limit diffractive slope.
7912 IHA=MAX(2,IABS(MINT(103))/110)
7913 IF(IHA.GE.5) IHA=1
7914 IHB=MAX(2,IABS(MINT(104))/110)
7915 IF(IHB.GE.5) IHB=1
7916 IF(ISUB.EQ.91) THEN
7917 BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0
7918 ELSEIF(ISUB.EQ.92) THEN
7919 BMN=MAX(2D0,2D0*BHAD(IHB))
7920 ELSEIF(ISUB.EQ.93) THEN
7921 BMN=MAX(2D0,2D0*BHAD(IHA))
7922 ELSEIF(ISUB.EQ.94) THEN
7923 BMN=2D0*ALP*4D0
7924 ENDIF
7925
7926C...Determine maximum possible t range and coefficient of generation.
7927 SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2
7928 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
7929 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
7930 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
7931 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
7932 & (SQM1*SQM4-SQM2*SQM3)/SH
7933 THL=-0.5D0*(THA+THB)
7934 THU=THC/THL
7935 THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0
7936
7937C...Select diffractive mass/masses according to dm^2/m^2.
7938 LOOP3=0
7939 260 LOOP3=LOOP3+1
7940 DO 270 JT=1,2
7941 IF(MINT(16+JT).EQ.0) THEN
7942 PDIF(2+JT)=PDIF(JT)
7943 ELSE
7944 PMMIN=PDIF(JT)
7945 PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT))
7946 PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0)
7947 ENDIF
7948 270 CONTINUE
7949 SQM3=PDIF(3)**2
7950 SQM4=PDIF(4)**2
7951
7952C..Additional mass factors, including resonance enhancement.
7953 IF(PDIF(3)+PDIF(4).GE.VINT(1)) THEN
7954 IF(LOOP3.LT.100) GOTO 260
7955 GOTO 100
7956 ENDIF
7957 IF(ISUB.EQ.92) THEN
7958 FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3))
7959 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
7960 ELSEIF(ISUB.EQ.93) THEN
7961 FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4))
7962 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
7963 ELSEIF(ISUB.EQ.94) THEN
7964 FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/
7965 & (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))*
7966 & (1D0+CRES*SMRES2/(SMRES2+SQM4))
7967 IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 260
7968 ENDIF
7969
7970C...Select t according to exp(Bmn*t) and correct to right slope.
7971 TH=THU+LOG(1D0+THRND*PYR(0))/BMN
7972 IF(ISUB.GE.92) THEN
7973 IF(ISUB.EQ.92) THEN
7974 BADD=2D0*ALP*LOG(SH/SQM3)
7975 IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
7976 ELSEIF(ISUB.EQ.93) THEN
7977 BADD=2D0*ALP*LOG(SH/SQM4)
7978 IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
7979 ELSEIF(ISUB.EQ.94) THEN
7980 BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0)
7981 ENDIF
7982 IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 260
7983 ENDIF
7984
7985C...Check whether m^2 and t choices are consistent.
7986 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
7987 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
7988 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
7989 IF(THB.LE.1D-8) GOTO 260
7990 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
7991 & (SQM1*SQM4-SQM2*SQM3)/SH
7992 THLM=-0.5D0*(THA+THB)
7993 THUM=THC/THLM
7994 IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 260
7995
7996C...Information to output.
7997 VINT(21)=1D0
7998 VINT(22)=0D0
7999 VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB))
8000 VINT(45)=TH
8001 VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB
8002 VINT(63)=PDIF(3)**2
8003 VINT(64)=PDIF(4)**2
8004 VINT(283)=PMM(1)**2/4D0
8005 VINT(284)=PMM(2)**2/4D0
8006
8007C...Note: in the following, by In is meant the integral over the
8008C...quantity multiplying coefficient cn.
8009C...Choose tau according to h1(tau)/tau, where
8010C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
8011C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
8012C...I1/I5*c5*1/(tau+tau_R') +
8013C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
8014C...I1/I7*c7*tau/(1.-tau), and
8015C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
8016 ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN
8017 CALL PYKLIM(1)
8018 IF(MINT(51).NE.0) THEN
8019 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8020 IF(MFAIL.EQ.1) THEN
8021 MSTI(61)=1
8022 RETURN
8023 ENDIF
8024 GOTO 100
8025 ENDIF
8026 RTAU=PYR(0)
8027 MTAU=1
8028 IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
8029 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
8030 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
8031 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
8032 & MTAU=5
8033 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
8034 & COEF(ISUB,5)) MTAU=6
8035 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
8036 & COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7
8037 CALL PYKMAP(1,MTAU,PYR(0))
8038
8039C...2 -> 3, 4 processes:
8040C...Choose tau' according to h4(tau,tau')/tau', where
8041C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
8042C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
8043 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
8044 CALL PYKLIM(4)
8045 IF(MINT(51).NE.0) THEN
8046 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8047 IF(MFAIL.EQ.1) THEN
8048 MSTI(61)=1
8049 RETURN
8050 ENDIF
8051 GOTO 100
8052 ENDIF
8053 RTAUP=PYR(0)
8054 MTAUP=1
8055 IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2
8056 IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3
8057 CALL PYKMAP(4,MTAUP,PYR(0))
8058 ENDIF
8059
8060C...Choose y* according to h2(y*), where
8061C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
8062C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
8063C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
8064C...and c1 + c2 + c3 + c4 + c5 = 1.
8065 CALL PYKLIM(2)
8066 IF(MINT(51).NE.0) THEN
8067 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8068 IF(MFAIL.EQ.1) THEN
8069 MSTI(61)=1
8070 RETURN
8071 ENDIF
8072 GOTO 100
8073 ENDIF
8074 RYST=PYR(0)
8075 MYST=1
8076 IF(RYST.GT.COEF(ISUB,8)) MYST=2
8077 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
8078 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4
8079 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+
8080 & COEF(ISUB,11)) MYST=5
8081 CALL PYKMAP(2,MYST,PYR(0))
8082
8083C...2 -> 2 processes:
8084C...Choose cos(theta-hat) (cth) according to h3(cth), where
8085C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
8086C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
8087C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
8088C...and c0 + c1 + c2 + c3 + c4 = 1.
8089 CALL PYKLIM(3)
8090 IF(MINT(51).NE.0) THEN
8091 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8092 IF(MFAIL.EQ.1) THEN
8093 MSTI(61)=1
8094 RETURN
8095 ENDIF
8096 GOTO 100
8097 ENDIF
8098 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
8099 RCTH=PYR(0)
8100 MCTH=1
8101 IF(RCTH.GT.COEF(ISUB,13)) MCTH=2
8102 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3
8103 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4
8104 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+
8105 & COEF(ISUB,16)) MCTH=5
8106 CALL PYKMAP(3,MCTH,PYR(0))
8107 ENDIF
8108
8109C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
8110 IF(ISTSB.EQ.5) THEN
8111 CALL PYKMAP(5,0,0D0)
8112 IF(MINT(51).NE.0) THEN
8113 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8114 IF(MFAIL.EQ.1) THEN
8115 MSTI(61)=1
8116 RETURN
8117 ENDIF
8118 GOTO 100
8119 ENDIF
8120 ENDIF
8121
8122C...DIS as f + gamma* -> f process: set dummy values.
8123 ELSEIF(ISTSB.EQ.8) THEN
8124 VINT(21)=0.9D0
8125 VINT(22)=0D0
8126 VINT(23)=0D0
8127 VINT(47)=0D0
8128 VINT(48)=0D0
8129
8130C...Low-pT or multiple interactions (first semihard interaction).
8131 ELSEIF(ISTSB.EQ.9) THEN
8132 CALL PYMULT(3)
8133 ISUB=MINT(1)
8134
8135C...Study user-defined process: kinematics plus weight.
8136 ELSEIF(ISTSB.EQ.11) THEN
8137 IF(IDWTUP.GT.0.AND.XWGTUP.LT.0D0) CALL
8138 & PYERRM(26,'(PYRAND:) Negative XWGTUP for user process')
8139 MSTI(51)=0
8140 IF(NUP.LE.0) THEN
8141 MINT(51)=2
8142 MSTI(51)=1
8143 IF(MINT(82).EQ.1) THEN
8144 NGEN(0,1)=NGEN(0,1)-1
8145 NGEN(ISUB,1)=NGEN(ISUB,1)-1
8146 ENDIF
8147 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8148 RETURN
8149 ENDIF
8150
8151C...Extract cross section event weight.
8152 IF(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.4) THEN
8153 SIGS=1D-9*XWGTUP
8154 ELSE
8155 SIGS=1D-9*XSECUP(KFPR(ISUB,1))
8156 ENDIF
8157 IF(IABS(IDWTUP).GE.1.AND.IABS(IDWTUP).LE.3) THEN
8158 VINT(97)=SIGN(1D0,XWGTUP)
8159 ELSE
8160 VINT(97)=1D-9*XWGTUP
8161 ENDIF
8162
8163C...Construct 'trivial' kinematical variables needed.
8164 KFL1=IDUP(1)
8165 KFL2=IDUP(2)
8166 VINT(41)=PUP(4,1)/EBMUP(1)
8167 VINT(42)=PUP(4,2)/EBMUP(2)
8168 VINT(21)=VINT(41)*VINT(42)
8169 VINT(22)=0.5D0*LOG(VINT(41)/VINT(42))
8170 VINT(44)=VINT(21)*VINT(2)
8171 VINT(43)=SQRT(MAX(0D0,VINT(44)))
8172 VINT(55)=SCALUP
8173 IF(SCALUP.LE.0D0) VINT(55)=VINT(43)
8174 VINT(56)=VINT(55)**2
8175 VINT(57)=AQEDUP
8176 VINT(58)=AQCDUP
8177
8178C...Construct other kinematical variables needed (approximately).
8179 VINT(23)=0D0
8180 VINT(26)=VINT(21)
8181 VINT(45)=-0.5D0*VINT(44)
8182 VINT(46)=-0.5D0*VINT(44)
8183 VINT(49)=VINT(43)
8184 VINT(50)=VINT(44)
8185 VINT(51)=VINT(55)
8186 VINT(52)=VINT(56)
8187 VINT(53)=VINT(55)
8188 VINT(54)=VINT(56)
8189 VINT(25)=0D0
8190 VINT(48)=0D0
8191 IF(ISTUP(1).NE.-1.OR.ISTUP(2).NE.-1) CALL PYERRM(26,
8192 & '(PYRAND:) unacceptable ISTUP code for incoming particles')
8193 DO 280 IUP=3,NUP
8194 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) CALL PYERRM(26,
8195 & '(PYRAND:) unacceptable ISTUP code for particles')
8196 IF(ISTUP(IUP).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(5,IUP)**2+
8197 & PUP(1,IUP)**2+PUP(2,IUP)**2)/VINT(2)
8198 IF(ISTUP(IUP).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(1,IUP)**2+
8199 & PUP(2,IUP)**2)
8200 280 CONTINUE
8201 VINT(47)=SQRT(VINT(48))
8202 ENDIF
8203
8204C...Choose azimuthal angle.
8205 VINT(24)=0D0
8206 IF(ISTSB.NE.11) VINT(24)=PARU(2)*PYR(0)
8207
8208C...Check against user cuts on kinematics at parton level.
8209 MINT(51)=0
8210 IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0)
8211 IF(MINT(51).NE.0) THEN
8212 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8213 IF(MFAIL.EQ.1) THEN
8214 MSTI(61)=1
8215 RETURN
8216 ENDIF
8217 GOTO 100
8218 ENDIF
8219 IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN
8220 MCUT=0
8221 IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
8222 & CALL PYKCUT(MCUT)
8223 IF(MCUT.NE.0) THEN
8224 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8225 IF(MFAIL.EQ.1) THEN
8226 MSTI(61)=1
8227 RETURN
8228 ENDIF
8229 GOTO 100
8230 ENDIF
8231 ENDIF
8232
8233C...Calculate differential cross-section for different subprocesses.
8234 IF(ISTSB.LE.10) CALL PYSIGH(NCHN,SIGS)
8235 SIGSOR=SIGS
8236 SIGLPT=SIGT(0,0,5)*VINT(315)*VINT(316)
8237
8238C...Multiply cross section by lepton -> photon flux factor.
8239 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
8240 SIGS=WTGAGA*SIGS
8241 DO 290 ICHN=1,NCHN
8242 SIGH(ICHN)=WTGAGA*SIGH(ICHN)
8243 290 CONTINUE
8244 SIGLPT=WTGAGA*SIGLPT
8245 ENDIF
8246
8247C...Multiply cross-section by user-defined weights.
8248 IF(MSTP(173).EQ.1) THEN
8249 SIGS=PARP(173)*SIGS
8250 DO 300 ICHN=1,NCHN
8251 SIGH(ICHN)=PARP(173)*SIGH(ICHN)
8252 300 CONTINUE
8253 SIGLPT=PARP(173)*SIGLPT
8254 ENDIF
8255 WTXS=1D0
8256 SIGSWT=SIGS
8257 VINT(99)=1D0
8258 VINT(100)=1D0
8259 IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN
8260 IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+
8261 & MSUB(95).EQ.0) CALL PYEVWT(WTXS)
8262 SIGSWT=WTXS*SIGS
8263 VINT(99)=WTXS
8264 IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS
8265 ENDIF
8266
8267C...Calculations for Monte Carlo estimate of all cross-sections.
8268 IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
8269 IF(MSTP(142).LE.1) THEN
8270 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
8271 ELSE
8272 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT
8273 ENDIF
8274 ELSEIF(MINT(82).EQ.1) THEN
8275 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
8276 ENDIF
8277 IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP2.EQ.1.AND.
8278 &MINT(82).EQ.1) XSEC(97,2)=XSEC(97,2)+SIGLPT
8279
8280C...Multiple interactions: store results of cross-section calculation.
8281 IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN
8282 VINT(153)=SIGSOR
8283 CALL PYMULT(4)
8284 ENDIF
8285
8286C...Ratio of actual to maximum cross section.
8287 IF(ISTSB.NE.11) THEN
8288 VIOL=SIGSWT/XSEC(ISUB,1)
8289 IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174)
8290 ELSEIF(IDWTUP.EQ.1.OR.IDWTUP.EQ.2) THEN
8291 VIOL=XWGTUP/XMAXUP(KFPR(ISUB,1))
8292 ELSEIF(IDWTUP.EQ.-1.OR.IDWTUP.EQ.-2) THEN
8293 VIOL=ABS(XWGTUP)/ABS(XMAXUP(KFPR(ISUB,1)))
8294 ELSE
8295 VIOL=1D0
8296 ENDIF
8297
8298C...Check that weight not negative.
8299 IF(MSTP(123).LE.0) THEN
8300 IF(VIOL.LT.-1D-3) THEN
8301 WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1
8302 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
8303 & VINT(22),VINT(23),VINT(26)
8304 STOP
8305 ENDIF
8306 ELSE
8307 IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN
8308 VINT(109)=VIOL
8309 WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1
8310 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
8311 & VINT(22),VINT(23),VINT(26)
8312 ENDIF
8313 ENDIF
8314
8315C...Weighting using estimate of maximum of differential cross-section.
8316 IF(MFAIL.EQ.0.AND.ISUB.NE.95.AND.ISUB.NE.96) THEN
8317 IF(VIOL.LT.PYR(0)) THEN
8318 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8319 IF(ISUB.GE.91.AND.ISUB.LE.94) ISUB=0
8320 GOTO 100
8321 ENDIF
8322 ELSEIF(MFAIL.EQ.0) THEN
8323 RATND=SIGLPT/XSEC(95,1)
8324 VIOL=VIOL/RATND
8325 IF(LOOP2.EQ.1.AND.RATND.LT.PYR(0)) THEN
8326 IF(VIOL.GT.PYR(0).AND.MINT(82).EQ.1.AND.MSUB(95).EQ.1.AND.
8327 & (ISUB.LE.90.OR.ISUB.GE.95)) NGEN(95,1)=NGEN(95,1)+MINT(143)
8328 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8329 ISUB=0
8330 GOTO 100
8331 ENDIF
8332 IF(VIOL.LT.PYR(0)) THEN
8333 GOTO 140
8334 ENDIF
8335 ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN
8336 IF(VIOL.LT.PYR(0)) THEN
8337 MSTI(61)=1
8338 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8339 RETURN
8340 ENDIF
8341 ELSE
8342 RATND=SIGLPT/XSEC(95,1)
8343 IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN
8344 MSTI(61)=1
8345 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8346 RETURN
8347 ENDIF
8348 VIOL=VIOL/RATND
8349 IF(VIOL.LT.PYR(0)) THEN
8350 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8351 GOTO 100
8352 ENDIF
8353 ENDIF
8354
8355C...Check for possible violation of estimated maximum of differential
8356C...cross-section used in weighting.
8357 IF(MSTP(123).LE.0) THEN
8358 IF(VIOL.GT.1D0) THEN
8359 WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1
8360 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
8361 & VINT(22),VINT(23),VINT(26)
8362 STOP
8363 ENDIF
8364 ELSEIF(MSTP(123).EQ.1) THEN
8365 IF(VIOL.GT.VINT(108)) THEN
8366 VINT(108)=VIOL
8367 IF(VIOL.GT.1.0001D0) THEN
8368 MINT(10)=1
8369 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
8370 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
8371 & VINT(22),VINT(23),VINT(26)
8372 ENDIF
8373 ENDIF
8374 ELSEIF(VIOL.GT.VINT(108)) THEN
8375 VINT(108)=VIOL
8376 IF(VIOL.GT.1D0) THEN
8377 MINT(10)=1
8378 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
8379 IF(ISTSB.EQ.11.AND.(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.2))
8380 & THEN
8381 XMAXUP(KFPR(ISUB,1))=VIOL*XMAXUP(KFPR(ISUB,1))
8382 IF(KFPR(ISUB,1).LE.9) THEN
8383 WRITE(MSTU(11),5800) KFPR(ISUB,1),XMAXUP(KFPR(ISUB,1))
8384 ELSEIF(KFPR(ISUB,1).LE.99) THEN
8385 WRITE(MSTU(11),5900) KFPR(ISUB,1),XMAXUP(KFPR(ISUB,1))
8386 ELSE
8387 WRITE(MSTU(11),6000) KFPR(ISUB,1),XMAXUP(KFPR(ISUB,1))
8388 ENDIF
8389 ENDIF
8390 IF(ISTSB.NE.11.OR.IABS(IDWTUP).EQ.1) THEN
8391 XDIF=XSEC(ISUB,1)*(VIOL-1D0)
8392 XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
8393 IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
8394 & XSEC(0,1)=XSEC(0,1)+XDIF
8395 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
8396 & VINT(22),VINT(23),VINT(26)
8397 IF(ISUB.LE.9) THEN
8398 WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1)
8399 ELSEIF(ISUB.LE.99) THEN
8400 WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1)
8401 ELSE
8402 WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1)
8403 ENDIF
8404 ENDIF
8405 VINT(108)=1D0
8406 ENDIF
8407 ENDIF
8408
8409C...Multiple interactions: choose impact parameter.
8410 VINT(148)=1D0
8411 IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.
8412 &MSTP(82).GE.3) THEN
8413 CALL PYMULT(5)
8414 IF(VINT(150).LT.PYR(0)) THEN
8415 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8416 IF(MFAIL.EQ.1) THEN
8417 MSTI(61)=1
8418 RETURN
8419 ENDIF
8420 GOTO 100
8421 ENDIF
8422 ENDIF
8423 IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1
8424 IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
8425 IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+MINT(143)
8426 IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
8427 ENDIF
8428 IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
8429
8430C...Choose flavour of reacting partons (and subprocess).
8431 IF(ISTSB.GE.11) GOTO 320
8432 RSIGS=SIGS*PYR(0)
8433 QT2=VINT(48)
8434 RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82)*
8435 &(VINT(1)/PARP(89))**PARP(90))**2))**2)
8436 IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
8437 &PYR(0).GT.RQQBAR)) THEN
8438 DO 310 ICHN=1,NCHN
8439 KFL1=ISIG(ICHN,1)
8440 KFL2=ISIG(ICHN,2)
8441 MINT(2)=ISIG(ICHN,3)
8442 RSIGS=RSIGS-SIGH(ICHN)
8443 IF(RSIGS.LE.0D0) GOTO 320
8444 310 CONTINUE
8445
8446C...Multiple interactions: choose qqbar preferentially at small pT.
8447 ELSEIF(ISUB.EQ.96) THEN
8448 MINT(105)=MINT(103)
8449 MINT(109)=MINT(107)
8450 CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
8451 MINT(105)=MINT(104)
8452 MINT(109)=MINT(108)
8453 CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
8454 MINT(1)=11
8455 MINT(2)=1
8456 IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2
8457
8458C...Low-pT: choose string drawing configuration.
8459 ELSE
8460 KFL1=21
8461 KFL2=21
8462 RSIGS=6D0*PYR(0)
8463 MINT(2)=1
8464 IF(RSIGS.GT.1D0) MINT(2)=2
8465 IF(RSIGS.GT.2D0) MINT(2)=3
8466 ENDIF
8467
8468C...Reassign QCD process. Partons before initial state radiation.
8469 320 IF(MINT(2).GT.10) THEN
8470 MINT(1)=MINT(2)/10
8471 MINT(2)=MOD(MINT(2),10)
8472 ENDIF
8473 IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)=
8474 &NGEN(MINT(1),2)+1
8475 MINT(15)=KFL1
8476 MINT(16)=KFL2
8477 MINT(13)=MINT(15)
8478 MINT(14)=MINT(16)
8479 VINT(141)=VINT(41)
8480 VINT(142)=VINT(42)
8481 VINT(151)=0D0
8482 VINT(152)=0D0
8483
8484C...Calculate x value of photon for parton inside photon inside e.
8485 DO 350 JT=1,2
8486 MINT(18+JT)=0
8487 VINT(154+JT)=0D0
8488 MSPLI=0
8489 IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1
8490 IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1
8491 IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1
8492 IF(MSPLI.EQ.2) THEN
8493 KFLH=MINT(14+JT)
8494 XHRD=VINT(140+JT)
8495 Q2HRD=VINT(54)
8496 MINT(105)=MINT(102+JT)
8497 MINT(109)=MINT(106+JT)
8498 VINT(120)=VINT(2+JT)
8499 IF(MSTP(57).LE.1) THEN
8500 CALL PYPDFU(22,XHRD,Q2HRD,XPQ)
8501 ELSE
8502 CALL PYPDFL(22,XHRD,Q2HRD,XPQ)
8503 ENDIF
8504 WTMX=4D0*XPQ(KFLH)
8505 IF(MSTP(13).EQ.2) THEN
8506 Q2PMS=Q2HRD/PMAS(11,1)**2
8507 WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2))
8508 ENDIF
8509 330 XE=XHRD**PYR(0)
8510 XG=MIN(1D0-1D-10,XHRD/XE)
8511 IF(MSTP(57).LE.1) THEN
8512 CALL PYPDFU(22,XG,Q2HRD,XPQ)
8513 ELSE
8514 CALL PYPDFL(22,XG,Q2HRD,XPQ)
8515 ENDIF
8516 WT=(1D0+(1D0-XE)**2)*XPQ(KFLH)
8517 IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2))
8518 IF(WT.LT.PYR(0)*WTMX) GOTO 330
8519 MINT(18+JT)=1
8520 VINT(154+JT)=XE
8521 DO 340 KFLS=-25,25
8522 XSFX(JT,KFLS)=XPQ(KFLS)
8523 340 CONTINUE
8524 ENDIF
8525 350 CONTINUE
8526
8527C...Pick scale where photon is resolved.
8528 Q0S=PARP(15)**2
8529 Q1S=VINT(154)**2
8530 VINT(283)=0D0
8531 IF(MINT(107).EQ.3) THEN
8532 IF(MSTP(66).EQ.1) THEN
8533 VINT(283)=Q0S*(VINT(54)/Q0S)**PYR(0)
8534 ELSEIF(MSTP(66).EQ.2) THEN
8535 PS=VINT(3)**2
8536 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
8537 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
8538 Q2INT=SQRT(Q0S*Q2EFF)
8539 VINT(283)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
8540 ELSEIF(MSTP(66).EQ.3) THEN
8541 VINT(283)=Q0S*(Q1S/Q0S)**PYR(0)
8542 ELSEIF(MSTP(66).GE.4) THEN
8543 PS=0.25D0*VINT(3)**2
8544 VINT(283)=(Q0S+PS)*(Q1S+PS)/
8545 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
8546 ENDIF
8547 ENDIF
8548 VINT(284)=0D0
8549 IF(MINT(108).EQ.3) THEN
8550 IF(MSTP(66).EQ.1) THEN
8551 VINT(284)=Q0S*(VINT(54)/Q0S)**PYR(0)
8552 ELSEIF(MSTP(66).EQ.2) THEN
8553 PS=VINT(4)**2
8554 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
8555 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
8556 Q2INT=SQRT(Q0S*Q2EFF)
8557 VINT(284)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
8558 ELSEIF(MSTP(66).EQ.3) THEN
8559 VINT(284)=Q0S*(Q1S/Q0S)**PYR(0)
8560 ELSEIF(MSTP(66).GE.4) THEN
8561 PS=0.25D0*VINT(4)**2
8562 VINT(284)=(Q0S+PS)*(Q1S+PS)/
8563 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
8564 ENDIF
8565 ENDIF
8566 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8567
8568C...Format statements for differential cross-section maximum violations.
8569 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
8570 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
8571 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
8572 &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
8573 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
8574 &'in event',1X,I7)
8575 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
8576 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
8577 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
8578 &'in event',1X,I7)
8579 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
8580 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
8581 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
8582 5800 FORMAT(1X,'XMAXUP(',I1,') increased to',1P,D11.3)
8583 5900 FORMAT(1X,'XMAXUP(',I2,') increased to',1P,D11.3)
8584 6000 FORMAT(1X,'XMAXUP(',I3,') increased to',1P,D11.3)
8585
8586 RETURN
8587 END
8588
8589C*********************************************************************
8590
8591C...PYSCAT
8592C...Finds outgoing flavours and event type; sets up the kinematics
8593C...and colour flow of the hard scattering
8594
8595 SUBROUTINE PYSCAT
8596
8597C...Double precision and integer declarations
8598 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8599 IMPLICIT INTEGER(I-N)
8600 INTEGER PYK,PYCHGE,PYCOMP
8601C...Parameter statement to help give large particle numbers.
8602 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
8603 &KEXCIT=4000000,KDIMEN=5000000)
8604
8605C...User process event common block.
8606 INTEGER MAXNUP
8607 PARAMETER (MAXNUP=500)
8608 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
8609 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
8610 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
8611 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
8612 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
8613 SAVE /HEPEUP/
8614
8615C...Commonblocks
8616 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
8617 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8618 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
8619 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
8620 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8621 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8622 COMMON/PYINT1/MINT(400),VINT(400)
8623 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
8624 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
8625 COMMON/PYINT4/MWID(500),WIDS(500,5)
8626 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8627 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
8628 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
8629 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
8630 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
8631 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYSSMT/,/PYTCSM/
8632C...Local arrays and saved variables
8633 DIMENSION WDTP(0:400),WDTE(0:400,0:5),PMQ(2),Z(2),CTHE(2),
8634 &PHI(2),KUPPO(100),VINTSV(41:66),ILAB(100)
8635 SAVE VINTSV
8636
8637C...Read out process
8638 ISUB=MINT(1)
8639 ISUBSV=ISUB
8640
8641C...Restore information for low-pT processes
8642 IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN
8643 DO 100 J=41,66
8644 100 VINT(J)=VINTSV(J)
8645 ENDIF
8646
8647C...Convert H' or A process into equivalent H one
8648 IHIGG=1
8649 KFHIGG=25
8650 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
8651 &ISUB.LE.190)) THEN
8652 IHIGG=2
8653 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
8654 KFHIGG=33+IHIGG
8655 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
8656 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
8657 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
8658 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
8659 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
8660 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
8661 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
8662 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
8663 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
8664 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
8665 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
8666 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
8667 ENDIF
8668
8669C...Choice of subprocess, number of documentation lines
8670 IDOC=6+ISET(ISUB)
8671 IF(ISUB.EQ.95) IDOC=8
8672 IF(ISET(ISUB).EQ.5) IDOC=9
8673 IF(ISET(ISUB).EQ.11) IDOC=4+NUP
8674 MINT(3)=IDOC-6
8675 IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2
8676 MINT(4)=IDOC
8677 IPU1=MINT(84)+1
8678 IPU2=MINT(84)+2
8679 IPU3=MINT(84)+3
8680 IPU4=MINT(84)+4
8681 IPU5=MINT(84)+5
8682 IPU6=MINT(84)+6
8683
8684C...Reset K, P and V vectors. Store incoming particles
8685 DO 120 JT=1,MSTP(126)+100
8686 I=MINT(83)+JT
8687 IF(I.GT.MSTU(4)) GOTO 120
8688 DO 110 J=1,5
8689 K(I,J)=0
8690 P(I,J)=0D0
8691 V(I,J)=0D0
8692 110 CONTINUE
8693 120 CONTINUE
8694 DO 140 JT=1,2
8695 I=MINT(83)+JT
8696 K(I,1)=21
8697 K(I,2)=MINT(10+JT)
8698 DO 130 J=1,5
8699 P(I,J)=VINT(285+5*JT+J)
8700 130 CONTINUE
8701 140 CONTINUE
8702 MINT(6)=2
8703 KFRES=0
8704
8705C...Store incoming partons in their CM-frame
8706 SH=VINT(44)
8707 SHR=SQRT(SH)
8708 SHP=VINT(26)*VINT(2)
8709 SHPR=SQRT(SHP)
8710 SHUSER=SHR
8711 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR
8712 DO 150 JT=1,2
8713 I=MINT(84)+JT
8714 K(I,1)=14
8715 K(I,2)=MINT(14+JT)
8716 K(I,3)=MINT(83)+2+JT
8717 P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1)
8718 P(I,4)=0.5D0*SHUSER
8719 150 CONTINUE
8720
8721C...Copy incoming partons to documentation lines
8722 DO 170 JT=1,2
8723 I1=MINT(83)+4+JT
8724 I2=MINT(84)+JT
8725 K(I1,1)=21
8726 K(I1,2)=K(I2,2)
8727 K(I1,3)=I1-2
8728 DO 160 J=1,5
8729 P(I1,J)=P(I2,J)
8730 160 CONTINUE
8731 170 CONTINUE
8732
8733C...Choose new quark/lepton flavour for relevant annihilation graphs
8734 IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58.OR.
8735 &(ISUB.GE.135.AND.ISUB.LE.140).OR.ISUB.EQ.382.OR.ISUB.EQ.385) THEN
8736 IGLGA=21
8737 IF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) IGLGA=22
8738 CALL PYWIDT(IGLGA,SH,WDTP,WDTE)
8739 180 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
8740 DO 190 I=1,MDCY(IGLGA,3)
8741 KFLF=KFDP(I+MDCY(IGLGA,2)-1,1)
8742 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
8743 IF(RKFL.LE.0D0) GOTO 200
8744 190 CONTINUE
8745 200 CONTINUE
8746 IF((ISUB.EQ.53.OR.ISUB.EQ.385).AND.MINT(2).LE.2) THEN
8747 IF(KFLF.GE.4) GOTO 180
8748 ELSEIF((ISUB.EQ.53.OR.ISUB.EQ.385).AND.MINT(2).LE.4) THEN
8749 KFLF=4
8750 MINT(2)=MINT(2)-2
8751 ELSEIF(ISUB.EQ.53.OR.ISUB.EQ.385) THEN
8752 KFLF=5
8753 MINT(2)=MINT(2)-4
8754 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.1.AND.IABS(MINT(15)).LE.2
8755 & .AND.IABS(KFLF).GE.3) THEN
8756 FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/
8757 & VINT(44)**2
8758 FACCIB=VINT(46)**2/RTCM(41)**4
8759 IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180
8760 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.2) THEN
8761 KFLF=5
8762 MINT(2)=1
8763 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.1) THEN
8764 IF(KFLF.EQ.5) GOTO 180
8765 ELSEIF(ISUB.EQ.54.OR.ISUB.EQ.135.OR.ISUB.EQ.136) THEN
8766 IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180
8767 ELSEIF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) THEN
8768 IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180
8769 ENDIF
8770 ENDIF
8771
8772C...Final state flavours and colour flow: default values
8773 JS=1
8774 MINT(21)=MINT(15)
8775 MINT(22)=MINT(16)
8776 MINT(23)=0
8777 MINT(24)=0
8778 KCC=20
8779 KCS=ISIGN(1,MINT(15))
8780
8781 IF(ISET(ISUB).EQ.11) THEN
8782C...User-defined processes: find products
8783 MINT(3)=0
8784 DO 210 IUP=3,NUP
8785 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) THEN
8786 ELSEIF(NUP.EQ.5.AND.IUP.GE.4.AND.MOTHUP(1,4).EQ.3) THEN
8787 MINT(21+IUP)=IDUP(IUP)
8788 ELSEIF(ISTUP(IUP).EQ.1.AND.(ISTUP(MOTHUP(1,IUP)).EQ.2.OR.
8789 & ISTUP(MOTHUP(1,IUP)).EQ.3).AND.IDUP(MOTHUP(1,IUP)).NE.0) THEN
8790 ELSEIF(IDUP(IUP).EQ.0) THEN
8791 ELSE
8792 MINT(3)=MINT(3)+1
8793 IF(MINT(3).LE.6) MINT(20+MINT(3))=IDUP(IUP)
8794 ENDIF
8795 210 CONTINUE
8796
8797 ELSEIF(ISUB.LE.10) THEN
8798 IF(ISUB.EQ.1) THEN
8799C...f + fbar -> gamma*/Z0
8800 KFRES=23
8801
8802 ELSEIF(ISUB.EQ.2) THEN
8803C...f + fbar' -> W+/-
8804 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8805 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8806 KFRES=ISIGN(24,KCH1+KCH2)
8807
8808 ELSEIF(ISUB.EQ.3) THEN
8809C...f + fbar -> h0 (or H0, or A0)
8810 KFRES=KFHIGG
8811
8812 ELSEIF(ISUB.EQ.4) THEN
8813C...gamma + W+/- -> W+/-
8814
8815 ELSEIF(ISUB.EQ.5) THEN
8816C...Z0 + Z0 -> h0
8817 XH=SH/SHP
8818 MINT(21)=MINT(15)
8819 MINT(22)=MINT(16)
8820 PMQ(1)=PYMASS(MINT(21))
8821 PMQ(2)=PYMASS(MINT(22))
8822 220 JT=INT(1.5D0+PYR(0))
8823 ZMIN=2D0*PMQ(JT)/SHPR
8824 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
8825 & (SHPR*(SHPR-PMQ(3-JT)))
8826 ZMAX=MIN(1D0-XH,ZMAX)
8827 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
8828 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
8829 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220
8830 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
8831 IF(SQC1.LT.1D-8) GOTO 220
8832 C1=SQRT(SQC1)
8833 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
8834 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8835 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
8836 Z(3-JT)=1D0-XH/(1D0-Z(JT))
8837 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
8838 IF(SQC1.LT.1D-8) GOTO 220
8839 C1=SQRT(SQC1)
8840 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
8841 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8842 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
8843 PHIR=PARU(2)*PYR(0)
8844 CPHI=COS(PHIR)
8845 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
8846 & SQRT(1D0-CTHE(2)**2)*CPHI
8847 Z1=2D0-Z(JT)
8848 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
8849 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
8850 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
8851 & PMQ(3-JT)**2/SHP))
8852 ZMIN=2D0*PMQ(3-JT)/SHPR
8853 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
8854 ZMAX=MIN(1D0-XH,ZMAX)
8855 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220
8856 KCC=22
8857 KFRES=25
8858
8859 ELSEIF(ISUB.EQ.6) THEN
8860C...Z0 + W+/- -> W+/-
8861
8862 ELSEIF(ISUB.EQ.7) THEN
8863C...W+ + W- -> Z0
8864
8865 ELSEIF(ISUB.EQ.8) THEN
8866C...W+ + W- -> h0
8867 XH=SH/SHP
8868 230 DO 260 JT=1,2
8869 I=MINT(14+JT)
8870 IA=IABS(I)
8871 IF(IA.LE.10) THEN
8872 RVCKM=VINT(180+I)*PYR(0)
8873 DO 240 J=1,MSTP(1)
8874 IB=2*J-1+MOD(IA,2)
8875 IPM=(5-ISIGN(1,I))/2
8876 IDC=J+MDCY(IA,2)+2
8877 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240
8878 MINT(20+JT)=ISIGN(IB,I)
8879 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8880 IF(RVCKM.LE.0D0) GOTO 250
8881 240 CONTINUE
8882 ELSE
8883 IB=2*((IA+1)/2)-1+MOD(IA,2)
8884 MINT(20+JT)=ISIGN(IB,I)
8885 ENDIF
8886 250 PMQ(JT)=PYMASS(MINT(20+JT))
8887 260 CONTINUE
8888 JT=INT(1.5D0+PYR(0))
8889 ZMIN=2D0*PMQ(JT)/SHPR
8890 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
8891 & (SHPR*(SHPR-PMQ(3-JT)))
8892 ZMAX=MIN(1D0-XH,ZMAX)
8893 IF(ZMIN.GE.ZMAX) GOTO 230
8894 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
8895 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
8896 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230
8897 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
8898 IF(SQC1.LT.1D-8) GOTO 230
8899 C1=SQRT(SQC1)
8900 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
8901 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8902 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
8903 Z(3-JT)=1D0-XH/(1D0-Z(JT))
8904 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
8905 IF(SQC1.LT.1D-8) GOTO 230
8906 C1=SQRT(SQC1)
8907 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
8908 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8909 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
8910 PHIR=PARU(2)*PYR(0)
8911 CPHI=COS(PHIR)
8912 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
8913 & SQRT(1D0-CTHE(2)**2)*CPHI
8914 Z1=2D0-Z(JT)
8915 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
8916 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
8917 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
8918 & PMQ(3-JT)**2/SHP))
8919 ZMIN=2D0*PMQ(3-JT)/SHPR
8920 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
8921 ZMAX=MIN(1D0-XH,ZMAX)
8922 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230
8923 KCC=22
8924 KFRES=25
8925
8926 ELSEIF(ISUB.EQ.10) THEN
8927C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
8928 IF(MINT(2).EQ.1) THEN
8929 KCC=22
8930 ELSE
8931C...W exchange: need to mix flavours according to CKM matrix
8932 DO 280 JT=1,2
8933 I=MINT(14+JT)
8934 IA=IABS(I)
8935 IF(IA.LE.10) THEN
8936 RVCKM=VINT(180+I)*PYR(0)
8937 DO 270 J=1,MSTP(1)
8938 IB=2*J-1+MOD(IA,2)
8939 IPM=(5-ISIGN(1,I))/2
8940 IDC=J+MDCY(IA,2)+2
8941 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
8942 MINT(20+JT)=ISIGN(IB,I)
8943 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8944 IF(RVCKM.LE.0D0) GOTO 280
8945 270 CONTINUE
8946 ELSE
8947 IB=2*((IA+1)/2)-1+MOD(IA,2)
8948 MINT(20+JT)=ISIGN(IB,I)
8949 ENDIF
8950 280 CONTINUE
8951 KCC=22
8952 ENDIF
8953 ENDIF
8954
8955 ELSEIF(ISUB.LE.20) THEN
8956 IF(ISUB.EQ.11) THEN
8957C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
8958 KCC=MINT(2)
8959 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8960
8961 ELSEIF(ISUB.EQ.12) THEN
8962C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
8963 MINT(21)=ISIGN(KFLF,MINT(15))
8964 MINT(22)=-MINT(21)
8965 KCC=4
8966
8967 ELSEIF(ISUB.EQ.13) THEN
8968C...f + fbar -> g + g; th arbitrary
8969 MINT(21)=21
8970 MINT(22)=21
8971 KCC=MINT(2)+4
8972
8973 ELSEIF(ISUB.EQ.14) THEN
8974C...f + fbar -> g + gamma; th arbitrary
8975 IF(PYR(0).GT.0.5D0) JS=2
8976 MINT(20+JS)=21
8977 MINT(23-JS)=22
8978 KCC=17+JS
8979
8980 ELSEIF(ISUB.EQ.15) THEN
8981C...f + fbar -> g + Z0; th arbitrary
8982 IF(PYR(0).GT.0.5D0) JS=2
8983 MINT(20+JS)=21
8984 MINT(23-JS)=23
8985 KCC=17+JS
8986
8987 ELSEIF(ISUB.EQ.16) THEN
8988C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
8989 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8990 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8991 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
8992 MINT(20+JS)=21
8993 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
8994 KCC=17+JS
8995
8996 ELSEIF(ISUB.EQ.17) THEN
8997C...f + fbar -> g + h0; th arbitrary
8998 IF(PYR(0).GT.0.5D0) JS=2
8999 MINT(20+JS)=21
9000 MINT(23-JS)=25
9001 KCC=17+JS
9002
9003 ELSEIF(ISUB.EQ.18) THEN
9004C...f + fbar -> gamma + gamma; th arbitrary
9005 MINT(21)=22
9006 MINT(22)=22
9007
9008 ELSEIF(ISUB.EQ.19) THEN
9009C...f + fbar -> gamma + Z0; th arbitrary
9010 IF(PYR(0).GT.0.5D0) JS=2
9011 MINT(20+JS)=22
9012 MINT(23-JS)=23
9013
9014 ELSEIF(ISUB.EQ.20) THEN
9015C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
9016C...(p(fbar')-p(W+))**2
9017 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9018 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9019 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
9020 MINT(20+JS)=22
9021 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
9022 ENDIF
9023
9024 ELSEIF(ISUB.LE.30) THEN
9025 IF(ISUB.EQ.21) THEN
9026C...f + fbar -> gamma + h0; th arbitrary
9027 IF(PYR(0).GT.0.5D0) JS=2
9028 MINT(20+JS)=22
9029 MINT(23-JS)=25
9030
9031 ELSEIF(ISUB.EQ.22) THEN
9032C...f + fbar -> Z0 + Z0; th arbitrary
9033 MINT(21)=23
9034 MINT(22)=23
9035
9036 ELSEIF(ISUB.EQ.23) THEN
9037C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
9038 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9039 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9040 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
9041 MINT(20+JS)=23
9042 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
9043
9044 ELSEIF(ISUB.EQ.24) THEN
9045C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
9046 IF(PYR(0).GT.0.5D0) JS=2
9047 MINT(20+JS)=23
9048 MINT(23-JS)=KFHIGG
9049
9050 ELSEIF(ISUB.EQ.25) THEN
9051C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
9052 MINT(21)=-ISIGN(24,MINT(15))
9053 MINT(22)=-MINT(21)
9054
9055 ELSEIF(ISUB.EQ.26) THEN
9056C...f + fbar' -> W+/- + h0 (or H0, or A0);
9057C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
9058 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9059 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9060 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
9061 MINT(20+JS)=ISIGN(24,KCH1+KCH2)
9062 MINT(23-JS)=KFHIGG
9063
9064 ELSEIF(ISUB.EQ.27) THEN
9065C...f + fbar -> h0 + h0
9066
9067 ELSEIF(ISUB.EQ.28) THEN
9068C...f + g -> f + g; th = (p(f)-p(f))**2
9069 IF(MINT(15).EQ.21) JS=2
9070 KCC=MINT(2)+6
9071 IF(MINT(15).EQ.21) KCC=KCC+2
9072 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
9073 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
9074
9075 ELSEIF(ISUB.EQ.29) THEN
9076C...f + g -> f + gamma; th = (p(f)-p(f))**2
9077 IF(MINT(15).EQ.21) JS=2
9078 MINT(23-JS)=22
9079 KCC=15+JS
9080 KCS=ISIGN(1,MINT(14+JS))
9081
9082 ELSEIF(ISUB.EQ.30) THEN
9083C...f + g -> f + Z0; th = (p(f)-p(f))**2
9084 IF(MINT(15).EQ.21) JS=2
9085 MINT(23-JS)=23
9086 KCC=15+JS
9087 KCS=ISIGN(1,MINT(14+JS))
9088 ENDIF
9089
9090 ELSEIF(ISUB.LE.40) THEN
9091 IF(ISUB.EQ.31) THEN
9092C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
9093 IF(MINT(15).EQ.21) JS=2
9094 I=MINT(14+JS)
9095 IA=IABS(I)
9096 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
9097 RVCKM=VINT(180+I)*PYR(0)
9098 DO 290 J=1,MSTP(1)
9099 IB=2*J-1+MOD(IA,2)
9100 IPM=(5-ISIGN(1,I))/2
9101 IDC=J+MDCY(IA,2)+2
9102 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290
9103 MINT(20+JS)=ISIGN(IB,I)
9104 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
9105 IF(RVCKM.LE.0D0) GOTO 300
9106 290 CONTINUE
9107 300 KCC=15+JS
9108 KCS=ISIGN(1,MINT(14+JS))
9109
9110 ELSEIF(ISUB.EQ.32) THEN
9111C...f + g -> f + h0; th = (p(f)-p(f))**2
9112 IF(MINT(15).EQ.21) JS=2
9113 MINT(23-JS)=25
9114 KCC=15+JS
9115 KCS=ISIGN(1,MINT(14+JS))
9116
9117 ELSEIF(ISUB.EQ.33) THEN
9118C...f + gamma -> f + g; th=(p(f)-p(f))**2
9119 IF(MINT(15).EQ.22) JS=2
9120 MINT(23-JS)=21
9121 KCC=24+JS
9122 KCS=ISIGN(1,MINT(14+JS))
9123
9124 ELSEIF(ISUB.EQ.34) THEN
9125C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
9126 IF(MINT(15).EQ.22) JS=2
9127 KCC=22
9128 KCS=ISIGN(1,MINT(14+JS))
9129
9130 ELSEIF(ISUB.EQ.35) THEN
9131C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
9132 IF(MINT(15).EQ.22) JS=2
9133 MINT(23-JS)=23
9134 KCC=22
9135
9136 ELSEIF(ISUB.EQ.36) THEN
9137C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
9138 IF(MINT(15).EQ.22) JS=2
9139 I=MINT(14+JS)
9140 IA=IABS(I)
9141 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
9142 IF(IA.LE.10) THEN
9143 RVCKM=VINT(180+I)*PYR(0)
9144 DO 310 J=1,MSTP(1)
9145 IB=2*J-1+MOD(IA,2)
9146 IPM=(5-ISIGN(1,I))/2
9147 IDC=J+MDCY(IA,2)+2
9148 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310
9149 MINT(20+JS)=ISIGN(IB,I)
9150 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
9151 IF(RVCKM.LE.0D0) GOTO 320
9152 310 CONTINUE
9153 ELSE
9154 IB=2*((IA+1)/2)-1+MOD(IA,2)
9155 MINT(20+JS)=ISIGN(IB,I)
9156 ENDIF
9157 320 KCC=22
9158
9159 ELSEIF(ISUB.EQ.37) THEN
9160C...f + gamma -> f + h0
9161
9162 ELSEIF(ISUB.EQ.38) THEN
9163C...f + Z0 -> f + g
9164
9165 ELSEIF(ISUB.EQ.39) THEN
9166C...f + Z0 -> f + gamma
9167
9168 ELSEIF(ISUB.EQ.40) THEN
9169C...f + Z0 -> f + Z0
9170 ENDIF
9171
9172 ELSEIF(ISUB.LE.50) THEN
9173 IF(ISUB.EQ.41) THEN
9174C...f + Z0 -> f' + W+/-
9175
9176 ELSEIF(ISUB.EQ.42) THEN
9177C...f + Z0 -> f + h0
9178
9179 ELSEIF(ISUB.EQ.43) THEN
9180C...f + W+/- -> f' + g
9181
9182 ELSEIF(ISUB.EQ.44) THEN
9183C...f + W+/- -> f' + gamma
9184
9185 ELSEIF(ISUB.EQ.45) THEN
9186C...f + W+/- -> f' + Z0
9187
9188 ELSEIF(ISUB.EQ.46) THEN
9189C...f + W+/- -> f' + W+/-
9190
9191 ELSEIF(ISUB.EQ.47) THEN
9192C...f + W+/- -> f' + h0
9193
9194 ELSEIF(ISUB.EQ.48) THEN
9195C...f + h0 -> f + g
9196
9197 ELSEIF(ISUB.EQ.49) THEN
9198C...f + h0 -> f + gamma
9199
9200 ELSEIF(ISUB.EQ.50) THEN
9201C...f + h0 -> f + Z0
9202 ENDIF
9203
9204 ELSEIF(ISUB.LE.60) THEN
9205 IF(ISUB.EQ.51) THEN
9206C...f + h0 -> f' + W+/-
9207
9208 ELSEIF(ISUB.EQ.52) THEN
9209C...f + h0 -> f + h0
9210
9211 ELSEIF(ISUB.EQ.53) THEN
9212C...g + g -> f + fbar; th arbitrary
9213 KCS=(-1)**INT(1.5D0+PYR(0))
9214 MINT(21)=ISIGN(KFLF,KCS)
9215 MINT(22)=-MINT(21)
9216 KCC=MINT(2)+10
9217
9218 ELSEIF(ISUB.EQ.54) THEN
9219C...g + gamma -> f + fbar; th arbitrary
9220 KCS=(-1)**INT(1.5D0+PYR(0))
9221 MINT(21)=ISIGN(KFLF,KCS)
9222 MINT(22)=-MINT(21)
9223 KCC=27
9224 IF(MINT(16).EQ.21) KCC=28
9225
9226 ELSEIF(ISUB.EQ.55) THEN
9227C...g + Z0 -> f + fbar
9228
9229 ELSEIF(ISUB.EQ.56) THEN
9230C...g + W+/- -> f + fbar'
9231
9232 ELSEIF(ISUB.EQ.57) THEN
9233C...g + h0 -> f + fbar
9234
9235 ELSEIF(ISUB.EQ.58) THEN
9236C...gamma + gamma -> f + fbar; th arbitrary
9237 KCS=(-1)**INT(1.5D0+PYR(0))
9238 MINT(21)=ISIGN(KFLF,KCS)
9239 MINT(22)=-MINT(21)
9240 KCC=21
9241
9242 ELSEIF(ISUB.EQ.59) THEN
9243C...gamma + Z0 -> f + fbar
9244
9245 ELSEIF(ISUB.EQ.60) THEN
9246C...gamma + W+/- -> f + fbar'
9247 ENDIF
9248
9249 ELSEIF(ISUB.LE.70) THEN
9250 IF(ISUB.EQ.61) THEN
9251C...gamma + h0 -> f + fbar
9252
9253 ELSEIF(ISUB.EQ.62) THEN
9254C...Z0 + Z0 -> f + fbar
9255
9256 ELSEIF(ISUB.EQ.63) THEN
9257C...Z0 + W+/- -> f + fbar'
9258
9259 ELSEIF(ISUB.EQ.64) THEN
9260C...Z0 + h0 -> f + fbar
9261
9262 ELSEIF(ISUB.EQ.65) THEN
9263C...W+ + W- -> f + fbar
9264
9265 ELSEIF(ISUB.EQ.66) THEN
9266C...W+/- + h0 -> f + fbar'
9267
9268 ELSEIF(ISUB.EQ.67) THEN
9269C...h0 + h0 -> f + fbar
9270
9271 ELSEIF(ISUB.EQ.68) THEN
9272C...g + g -> g + g; th arbitrary
9273 KCC=MINT(2)+12
9274 KCS=(-1)**INT(1.5D0+PYR(0))
9275
9276 ELSEIF(ISUB.EQ.69) THEN
9277C...gamma + gamma -> W+ + W-; th arbitrary
9278 MINT(21)=24
9279 MINT(22)=-24
9280 KCC=21
9281
9282 ELSEIF(ISUB.EQ.70) THEN
9283C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
9284 IF(MINT(15).EQ.22) MINT(21)=23
9285 IF(MINT(16).EQ.22) MINT(22)=23
9286 KCC=21
9287 ENDIF
9288
9289 ELSEIF(ISUB.LE.80) THEN
9290 IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
9291C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
9292 XH=SH/SHP
9293 MINT(21)=MINT(15)
9294 MINT(22)=MINT(16)
9295 PMQ(1)=PYMASS(MINT(21))
9296 PMQ(2)=PYMASS(MINT(22))
9297 330 JT=INT(1.5D0+PYR(0))
9298 ZMIN=2D0*PMQ(JT)/SHPR
9299 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
9300 & (SHPR*(SHPR-PMQ(3-JT)))
9301 ZMAX=MIN(1D0-XH,ZMAX)
9302 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
9303 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
9304 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330
9305 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
9306 IF(SQC1.LT.1D-8) GOTO 330
9307 C1=SQRT(SQC1)
9308 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
9309 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9310 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
9311 Z(3-JT)=1D0-XH/(1D0-Z(JT))
9312 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
9313 IF(SQC1.LT.1D-8) GOTO 330
9314 C1=SQRT(SQC1)
9315 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
9316 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9317 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
9318 PHIR=PARU(2)*PYR(0)
9319 CPHI=COS(PHIR)
9320 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
9321 & SQRT(1D0-CTHE(2)**2)*CPHI
9322 Z1=2D0-Z(JT)
9323 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
9324 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
9325 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
9326 & PMQ(3-JT)**2/SHP))
9327 ZMIN=2D0*PMQ(3-JT)/SHPR
9328 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
9329 ZMAX=MIN(1D0-XH,ZMAX)
9330 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330
9331 KCC=22
9332
9333 ELSEIF(ISUB.EQ.73) THEN
9334C...Z0 + W+/- -> Z0 + W+/-
9335 JS=MINT(2)
9336 XH=SH/SHP
9337 340 JT=3-MINT(2)
9338 I=MINT(14+JT)
9339 IA=IABS(I)
9340 IF(IA.LE.10) THEN
9341 RVCKM=VINT(180+I)*PYR(0)
9342 DO 350 J=1,MSTP(1)
9343 IB=2*J-1+MOD(IA,2)
9344 IPM=(5-ISIGN(1,I))/2
9345 IDC=J+MDCY(IA,2)+2
9346 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350
9347 MINT(20+JT)=ISIGN(IB,I)
9348 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
9349 IF(RVCKM.LE.0D0) GOTO 360
9350 350 CONTINUE
9351 ELSE
9352 IB=2*((IA+1)/2)-1+MOD(IA,2)
9353 MINT(20+JT)=ISIGN(IB,I)
9354 ENDIF
9355 360 PMQ(JT)=PYMASS(MINT(20+JT))
9356 MINT(23-JT)=MINT(17-JT)
9357 PMQ(3-JT)=PYMASS(MINT(23-JT))
9358 JT=INT(1.5D0+PYR(0))
9359 ZMIN=2D0*PMQ(JT)/SHPR
9360 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
9361 & (SHPR*(SHPR-PMQ(3-JT)))
9362 ZMAX=MIN(1D0-XH,ZMAX)
9363 IF(ZMIN.GE.ZMAX) GOTO 340
9364 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
9365 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
9366 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340
9367 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
9368 IF(SQC1.LT.1D-8) GOTO 340
9369 C1=SQRT(SQC1)
9370 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
9371 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9372 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
9373 Z(3-JT)=1D0-XH/(1D0-Z(JT))
9374 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
9375 IF(SQC1.LT.1D-8) GOTO 340
9376 C1=SQRT(SQC1)
9377 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
9378 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9379 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
9380 PHIR=PARU(2)*PYR(0)
9381 CPHI=COS(PHIR)
9382 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
9383 & SQRT(1D0-CTHE(2)**2)*CPHI
9384 Z1=2D0-Z(JT)
9385 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
9386 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
9387 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
9388 & PMQ(3-JT)**2/SHP))
9389 ZMIN=2D0*PMQ(3-JT)/SHPR
9390 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
9391 ZMAX=MIN(1D0-XH,ZMAX)
9392 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
9393 KCC=22
9394
9395 ELSEIF(ISUB.EQ.74) THEN
9396C...Z0 + h0 -> Z0 + h0
9397
9398 ELSEIF(ISUB.EQ.75) THEN
9399C...W+ + W- -> gamma + gamma
9400
9401 ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
9402C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
9403 XH=SH/SHP
9404 370 DO 400 JT=1,2
9405 I=MINT(14+JT)
9406 IA=IABS(I)
9407 IF(IA.LE.10) THEN
9408 RVCKM=VINT(180+I)*PYR(0)
9409 DO 380 J=1,MSTP(1)
9410 IB=2*J-1+MOD(IA,2)
9411 IPM=(5-ISIGN(1,I))/2
9412 IDC=J+MDCY(IA,2)+2
9413 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380
9414 MINT(20+JT)=ISIGN(IB,I)
9415 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
9416 IF(RVCKM.LE.0D0) GOTO 390
9417 380 CONTINUE
9418 ELSE
9419 IB=2*((IA+1)/2)-1+MOD(IA,2)
9420 MINT(20+JT)=ISIGN(IB,I)
9421 ENDIF
9422 390 PMQ(JT)=PYMASS(MINT(20+JT))
9423 400 CONTINUE
9424 JT=INT(1.5D0+PYR(0))
9425 ZMIN=2D0*PMQ(JT)/SHPR
9426 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
9427 & (SHPR*(SHPR-PMQ(3-JT)))
9428 ZMAX=MIN(1D0-XH,ZMAX)
9429 IF(ZMIN.GE.ZMAX) GOTO 370
9430 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
9431 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
9432 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370
9433 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
9434 IF(SQC1.LT.1D-8) GOTO 370
9435 C1=SQRT(SQC1)
9436 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
9437 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9438 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
9439 Z(3-JT)=1D0-XH/(1D0-Z(JT))
9440 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
9441 IF(SQC1.LT.1D-8) GOTO 370
9442 C1=SQRT(SQC1)
9443 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
9444 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9445 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
9446 PHIR=PARU(2)*PYR(0)
9447 CPHI=COS(PHIR)
9448 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
9449 & SQRT(1D0-CTHE(2)**2)*CPHI
9450 Z1=2D0-Z(JT)
9451 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
9452 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
9453 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
9454 & PMQ(3-JT)**2/SHP))
9455 ZMIN=2D0*PMQ(3-JT)/SHPR
9456 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
9457 ZMAX=MIN(1D0-XH,ZMAX)
9458 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370
9459 KCC=22
9460
9461 ELSEIF(ISUB.EQ.78) THEN
9462C...W+/- + h0 -> W+/- + h0
9463
9464 ELSEIF(ISUB.EQ.79) THEN
9465C...h0 + h0 -> h0 + h0
9466
9467 ELSEIF(ISUB.EQ.80) THEN
9468C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
9469 IF(MINT(15).EQ.22) JS=2
9470 I=MINT(14+JS)
9471 IA=IABS(I)
9472 MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I)
9473 IB=3-IA
9474 MINT(20+JS)=ISIGN(IB,I)
9475 KCC=22
9476 ENDIF
9477
9478 ELSEIF(ISUB.LE.90) THEN
9479 IF(ISUB.EQ.81) THEN
9480C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
9481 MINT(21)=ISIGN(MINT(55),MINT(15))
9482 MINT(22)=-MINT(21)
9483 KCC=4
9484
9485 ELSEIF(ISUB.EQ.82) THEN
9486C...g + g -> Q + Qbar; th arbitrary
9487 KCS=(-1)**INT(1.5D0+PYR(0))
9488 MINT(21)=ISIGN(MINT(55),KCS)
9489 MINT(22)=-MINT(21)
9490 KCC=MINT(2)+10
9491
9492 ELSEIF(ISUB.EQ.83) THEN
9493C...f + q -> f' + Q; th = (p(f) - p(f'))**2
9494 KFOLD=MINT(16)
9495 IF(MINT(2).EQ.2) KFOLD=MINT(15)
9496 KFAOLD=IABS(KFOLD)
9497 IF(KFAOLD.GT.10) THEN
9498 KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1
9499 ELSE
9500 RCKM=VINT(180+KFOLD)*PYR(0)
9501 IPM=(5-ISIGN(1,KFOLD))/2
9502 KFANEW=-MOD(KFAOLD+1,2)
9503 410 KFANEW=KFANEW+2
9504 IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2
9505 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN
9506 IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM-
9507 & VCKM(KFAOLD/2,(KFANEW+1)/2)
9508 IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM-
9509 & VCKM(KFANEW/2,(KFAOLD+1)/2)
9510 ENDIF
9511 IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410
9512 ENDIF
9513 IF(MINT(2).EQ.1) THEN
9514 MINT(21)=ISIGN(MINT(55),MINT(15))
9515 MINT(22)=ISIGN(KFANEW,MINT(16))
9516 ELSE
9517 MINT(21)=ISIGN(KFANEW,MINT(15))
9518 MINT(22)=ISIGN(MINT(55),MINT(16))
9519 JS=2
9520 ENDIF
9521 KCC=22
9522
9523 ELSEIF(ISUB.EQ.84) THEN
9524C...g + gamma -> Q + Qbar; th arbitary
9525 KCS=(-1)**INT(1.5D0+PYR(0))
9526 MINT(21)=ISIGN(MINT(55),KCS)
9527 MINT(22)=-MINT(21)
9528 KCC=27
9529 IF(MINT(16).EQ.21) KCC=28
9530
9531 ELSEIF(ISUB.EQ.85) THEN
9532C...gamma + gamma -> F + Fbar; th arbitary
9533 KCS=(-1)**INT(1.5D0+PYR(0))
9534 MINT(21)=ISIGN(MINT(56),KCS)
9535 MINT(22)=-MINT(21)
9536 KCC=21
9537
9538 ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN
9539C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
9540 MINT(21)=KFPR(ISUB,1)
9541 MINT(22)=KFPR(ISUB,2)
9542 KCC=24
9543 KCS=(-1)**INT(1.5D0+PYR(0))
9544 ENDIF
9545
9546 ELSEIF(ISUB.LE.100) THEN
9547 IF(ISUB.EQ.95) THEN
9548C...Low-pT ( = energyless g + g -> g + g)
9549 KCC=MINT(2)+12
9550 KCS=(-1)**INT(1.5D0+PYR(0))
9551
9552 ELSEIF(ISUB.EQ.96) THEN
9553C...Multiple interactions (should be reassigned to QCD process)
9554 ENDIF
9555
9556 ELSEIF(ISUB.LE.110) THEN
9557 IF(ISUB.EQ.101) THEN
9558C...g + g -> gamma*/Z0
9559 KCC=21
9560 KFRES=22
9561
9562 ELSEIF(ISUB.EQ.102) THEN
9563C...g + g -> h0 (or H0, or A0)
9564 KCC=21
9565 KFRES=KFHIGG
9566
9567 ELSEIF(ISUB.EQ.103) THEN
9568C...gamma + gamma -> h0 (or H0, or A0)
9569 KCC=21
9570 KFRES=KFHIGG
9571
9572 ELSEIF(ISUB.EQ.104.OR.ISUB.EQ.105) THEN
9573C...g + g -> chi_0c or chi_2c.
9574 KCC=21
9575 KFRES=KFPR(ISUB,1)
9576
9577 ELSEIF(ISUB.EQ.106) THEN
9578C...g + g -> J/Psi + gamma
9579 MINT(21)=KFPR(ISUB,1)
9580 MINT(22)=KFPR(ISUB,2)
9581 KCC=21
9582
9583 ELSEIF(ISUB.EQ.107) THEN
9584C...g + gamma -> J/Psi + g
9585 MINT(21)=KFPR(ISUB,1)
9586 MINT(22)=KFPR(ISUB,2)
9587 KCC=22
9588 IF(MINT(16).EQ.22) KCC=33
9589
9590 ELSEIF(ISUB.EQ.108) THEN
9591C...gamma + gamma -> J/Psi + gamma
9592 MINT(21)=KFPR(ISUB,1)
9593 MINT(22)=KFPR(ISUB,2)
9594
9595 ELSEIF(ISUB.EQ.110) THEN
9596C...f + fbar -> gamma + h0; th arbitrary
9597 IF(PYR(0).GT.0.5D0) JS=2
9598 MINT(20+JS)=22
9599 MINT(23-JS)=KFHIGG
9600 ENDIF
9601
9602 ELSEIF(ISUB.LE.120) THEN
9603 IF(ISUB.EQ.111) THEN
9604C...f + fbar -> g + h0; th arbitrary
9605 IF(PYR(0).GT.0.5D0) JS=2
9606 MINT(20+JS)=21
9607 MINT(23-JS)=KFHIGG
9608 KCC=17+JS
9609
9610 ELSEIF(ISUB.EQ.112) THEN
9611C...f + g -> f + h0; th = (p(f) - p(f))**2
9612 IF(MINT(15).EQ.21) JS=2
9613 MINT(23-JS)=KFHIGG
9614 KCC=15+JS
9615 KCS=ISIGN(1,MINT(14+JS))
9616
9617 ELSEIF(ISUB.EQ.113) THEN
9618C...g + g -> g + h0; th arbitrary
9619 IF(PYR(0).GT.0.5D0) JS=2
9620 MINT(23-JS)=KFHIGG
9621 KCC=22+JS
9622 KCS=(-1)**INT(1.5D0+PYR(0))
9623
9624 ELSEIF(ISUB.EQ.114) THEN
9625C...g + g -> gamma + gamma; th arbitrary
9626 IF(PYR(0).GT.0.5D0) JS=2
9627 MINT(21)=22
9628 MINT(22)=22
9629 KCC=21
9630
9631 ELSEIF(ISUB.EQ.115) THEN
9632C...g + g -> g + gamma; th arbitrary
9633 IF(PYR(0).GT.0.5D0) JS=2
9634 MINT(23-JS)=22
9635 KCC=22+JS
9636 KCS=(-1)**INT(1.5D0+PYR(0))
9637
9638 ELSEIF(ISUB.EQ.116) THEN
9639C...g + g -> gamma + Z0
9640
9641 ELSEIF(ISUB.EQ.117) THEN
9642C...g + g -> Z0 + Z0
9643
9644 ELSEIF(ISUB.EQ.118) THEN
9645C...g + g -> W+ + W-
9646 ENDIF
9647
9648 ELSEIF(ISUB.LE.140) THEN
9649 IF(ISUB.EQ.121) THEN
9650C...g + g -> Q + Qbar + h0
9651 KCS=(-1)**INT(1.5D0+PYR(0))
9652 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
9653 MINT(22)=-MINT(21)
9654 KCC=11+INT(0.5D0+PYR(0))
9655 KFRES=KFHIGG
9656
9657 ELSEIF(ISUB.EQ.122) THEN
9658C...q + qbar -> Q + Qbar + h0
9659 MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15))
9660 MINT(22)=-MINT(21)
9661 KCC=4
9662 KFRES=KFHIGG
9663
9664 ELSEIF(ISUB.EQ.123) THEN
9665C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
9666C...inner process)
9667 KCC=22
9668 KFRES=KFHIGG
9669
9670 ELSEIF(ISUB.EQ.124) THEN
9671C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
9672C...inner process)
9673 DO 430 JT=1,2
9674 I=MINT(14+JT)
9675 IA=IABS(I)
9676 IF(IA.LE.10) THEN
9677 RVCKM=VINT(180+I)*PYR(0)
9678 DO 420 J=1,MSTP(1)
9679 IB=2*J-1+MOD(IA,2)
9680 IPM=(5-ISIGN(1,I))/2
9681 IDC=J+MDCY(IA,2)+2
9682 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420
9683 MINT(20+JT)=ISIGN(IB,I)
9684 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
9685 IF(RVCKM.LE.0D0) GOTO 430
9686 420 CONTINUE
9687 ELSE
9688 IB=2*((IA+1)/2)-1+MOD(IA,2)
9689 MINT(20+JT)=ISIGN(IB,I)
9690 ENDIF
9691 430 CONTINUE
9692 KCC=22
9693 KFRES=KFHIGG
9694
9695 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
9696C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2
9697 IF(MINT(15).EQ.22) JS=2
9698 MINT(23-JS)=21
9699 KCC=24+JS
9700 KCS=ISIGN(1,MINT(14+JS))
9701
9702 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
9703C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2
9704 IF(MINT(15).EQ.22) JS=2
9705 KCC=22
9706 KCS=ISIGN(1,MINT(14+JS))
9707
9708 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
9709C...g + gamma*_(T,L) -> f + fbar; th arbitrary
9710 KCS=(-1)**INT(1.5D0+PYR(0))
9711 MINT(21)=ISIGN(KFLF,KCS)
9712 MINT(22)=-MINT(21)
9713 KCC=27
9714 IF(MINT(16).EQ.21) KCC=28
9715
9716 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
9717C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary
9718 KCS=(-1)**INT(1.5D0+PYR(0))
9719 MINT(21)=ISIGN(KFLF,KCS)
9720 MINT(22)=-MINT(21)
9721 KCC=21
9722
9723 ENDIF
9724
9725 ELSEIF(ISUB.LE.160) THEN
9726 IF(ISUB.EQ.141) THEN
9727C...f + fbar -> gamma*/Z0/Z'0
9728 KFRES=32
9729
9730 ELSEIF(ISUB.EQ.142) THEN
9731C...f + fbar' -> W'+/-
9732 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9733 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9734 KFRES=ISIGN(34,KCH1+KCH2)
9735
9736 ELSEIF(ISUB.EQ.143) THEN
9737C...f + fbar' -> H+/-
9738 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9739 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9740 KFRES=ISIGN(37,KCH1+KCH2)
9741
9742 ELSEIF(ISUB.EQ.144) THEN
9743C...f + fbar' -> R
9744 KFRES=ISIGN(41,MINT(15)+MINT(16))
9745
9746 ELSEIF(ISUB.EQ.145) THEN
9747C...q + l -> LQ (leptoquark)
9748 IF(IABS(MINT(16)).LE.8) JS=2
9749 KFRES=ISIGN(42,MINT(14+JS))
9750 KCC=28+JS
9751 KCS=ISIGN(1,MINT(14+JS))
9752
9753 ELSEIF(ISUB.EQ.146) THEN
9754C...e + gamma -> e* (excited lepton)
9755 IF(MINT(15).EQ.22) JS=2
9756 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
9757 KCC=22
9758
9759 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
9760C...q + g -> q* (excited quark)
9761 IF(MINT(15).EQ.21) JS=2
9762 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
9763 KCC=30+JS
9764 KCS=ISIGN(1,MINT(14+JS))
9765
9766 ELSEIF(ISUB.EQ.149) THEN
9767C...g + g -> eta_tc
9768 KFRES=KTECHN+331
9769 KCC=23
9770 KCS=(-1)**INT(1.5D0+PYR(0))
9771 ENDIF
9772
9773 ELSEIF(ISUB.LE.200) THEN
9774 IF(ISUB.EQ.161) THEN
9775C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
9776 IF(MINT(15).EQ.21) JS=2
9777 I=MINT(14+JS)
9778 IA=IABS(I)
9779 MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I)
9780 IB=IA+MOD(IA,2)-MOD(IA+1,2)
9781 MINT(20+JS)=ISIGN(IB,I)
9782 KCC=15+JS
9783 KCS=ISIGN(1,MINT(14+JS))
9784
9785 ELSEIF(ISUB.EQ.162) THEN
9786C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
9787 IF(MINT(15).EQ.21) JS=2
9788 MINT(20+JS)=ISIGN(42,MINT(14+JS))
9789 KFLQL=KFDP(MDCY(42,2),2)
9790 MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS))
9791 KCC=15+JS
9792 KCS=ISIGN(1,MINT(14+JS))
9793
9794 ELSEIF(ISUB.EQ.163) THEN
9795C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
9796 KCS=(-1)**INT(1.5D0+PYR(0))
9797 MINT(21)=ISIGN(42,KCS)
9798 MINT(22)=-MINT(21)
9799 KCC=MINT(2)+10
9800
9801 ELSEIF(ISUB.EQ.164) THEN
9802C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
9803 MINT(21)=ISIGN(42,MINT(15))
9804 MINT(22)=-MINT(21)
9805 KCC=4
9806
9807 ELSEIF(ISUB.EQ.165) THEN
9808C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
9809 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9810 MINT(22)=-MINT(21)
9811
9812 ELSEIF(ISUB.EQ.166) THEN
9813C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
9814 IF(MOD(MINT(15),2).EQ.0) THEN
9815 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
9816 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
9817 ELSE
9818 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9819 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
9820 ENDIF
9821
9822 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
9823C...q + q' -> q" + q* (excited quark)
9824 KFQSTR=KFPR(ISUB,2)
9825 KFQEXC=MOD(KFQSTR,KEXCIT)
9826 JS=MINT(2)
9827 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
9828 IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC)
9829 & MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
9830 KCC=22
9831 JS=3-JS
9832
9833 ELSEIF(ISUB.EQ.169) THEN
9834C...q + qbar -> e + e* (excited lepton)
9835 KFQSTR=KFPR(ISUB,2)
9836 KFQEXC=MOD(KFQSTR,KEXCIT)
9837 JS=MINT(2)
9838 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
9839 MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
9840 JS=3-JS
9841
9842 ELSEIF(ISUB.EQ.191) THEN
9843C...f + fbar -> rho_tc0.
9844 KFRES=KTECHN+113
9845
9846 ELSEIF(ISUB.EQ.192) THEN
9847C...f + fbar' -> rho_tc+/-
9848 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9849 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9850 KFRES=ISIGN(KTECHN+213,KCH1+KCH2)
9851
9852 ELSEIF(ISUB.EQ.193) THEN
9853C...f + fbar -> omega_tc0.
9854 KFRES=KTECHN+223
9855
9856 ELSEIF(ISUB.EQ.194) THEN
9857C...f + fbar -> f' + fbar' via mixture of s-channel
9858C...rho_tc and omega_tc; th=(p(f)-p(f'))**2
9859 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9860 MINT(22)=-MINT(21)
9861
9862 ELSEIF(ISUB.EQ.195) THEN
9863C...f + fbar' -> f'' + fbar''' via s-channel
9864C...rho_tc+ th=(p(f)-p(f'))**2
9865C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
9866 IF(MOD(MINT(15),2).EQ.0) THEN
9867 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
9868 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
9869 ELSE
9870 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9871 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
9872 ENDIF
9873 ENDIF
9874
9875CMRENNA++
9876 ELSEIF(ISUB.LE.215) THEN
9877 IF(ISUB.EQ.201) THEN
9878C...f + fbar -> ~e_L + ~e_Lbar
9879 MINT(21)=ISIGN(KSUSY1+11,KCS)
9880 MINT(22)=-MINT(21)
9881
9882 ELSEIF(ISUB.EQ.202) THEN
9883C...f + fbar -> ~e_R + ~e_Rbar
9884 MINT(21)=ISIGN(KSUSY2+11,KCS)
9885 MINT(22)=-MINT(21)
9886
9887 ELSEIF(ISUB.EQ.203) THEN
9888C...f + fbar -> ~e_L + ~e_Rbar
9889 IF(MINT(15).LT.0) JS=2
9890 IF(MINT(2).EQ.1) THEN
9891 MINT(20+JS)=KFPR(ISUB,1)
9892 MINT(23-JS)=-KFPR(ISUB,2)
9893 ELSE
9894 MINT(20+JS)=-KFPR(ISUB,1)
9895 MINT(23-JS)=KFPR(ISUB,2)
9896 ENDIF
9897
9898 ELSEIF(ISUB.EQ.204) THEN
9899C...f + fbar -> ~mu_L + ~mu_Lbar
9900 MINT(21)=ISIGN(KSUSY1+13,KCS)
9901 MINT(22)=-MINT(21)
9902
9903 ELSEIF(ISUB.EQ.205) THEN
9904C...f + fbar -> ~mu_R + ~mu_Rbar
9905 MINT(21)=ISIGN(KSUSY2+13,KCS)
9906 MINT(22)=-MINT(21)
9907
9908 ELSEIF(ISUB.EQ.206) THEN
9909C...f + fbar -> ~mu_L + ~mu_Rbar
9910 IF(MINT(15).LT.0) JS=2
9911 IF(MINT(2).EQ.1) THEN
9912 MINT(20+JS)=KFPR(ISUB,1)
9913 MINT(23-JS)=-KFPR(ISUB,2)
9914 ELSE
9915 MINT(20+JS)=-KFPR(ISUB,1)
9916 MINT(23-JS)=KFPR(ISUB,2)
9917 ENDIF
9918
9919 ELSEIF(ISUB.EQ.207) THEN
9920C...f + fbar -> ~tau_1 + ~tau_1bar
9921 MINT(21)=ISIGN(KSUSY1+15,KCS)
9922 MINT(22)=-MINT(21)
9923
9924 ELSEIF(ISUB.EQ.208) THEN
9925C...f + fbar -> ~tau_2 + ~tau_2bar
9926 MINT(21)=ISIGN(KSUSY2+15,KCS)
9927 MINT(22)=-MINT(21)
9928
9929 ELSEIF(ISUB.EQ.209) THEN
9930C...f + fbar -> ~tau_1 + ~tau_2bar
9931 IF(MINT(15).LT.0) JS=2
9932 IF(MINT(2).EQ.1) THEN
9933 MINT(20+JS)=KFPR(ISUB,1)
9934 MINT(23-JS)=-KFPR(ISUB,2)
9935 ELSE
9936 MINT(20+JS)=-KFPR(ISUB,1)
9937 MINT(23-JS)=KFPR(ISUB,2)
9938 ENDIF
9939
9940 ELSEIF(ISUB.EQ.210) THEN
9941C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
9942 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9943 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9944 MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2)
9945 MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2)
9946
9947 ELSEIF(ISUB.EQ.211) THEN
9948C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
9949 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9950 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9951 MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2)
9952 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
9953
9954 ELSEIF(ISUB.EQ.212) THEN
9955C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
9956 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9957 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9958 MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2)
9959 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
9960
9961 ELSEIF(ISUB.EQ.213) THEN
9962C...f + fbar -> ~nul + ~nulbar
9963 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
9964 MINT(22)=-MINT(21)
9965
9966 ELSEIF(ISUB.EQ.214) THEN
9967C...f + fbar -> ~nutau + ~nutaubar
9968 MINT(21)=ISIGN(KSUSY1+16,KCS)
9969 MINT(22)=-MINT(21)
9970 ENDIF
9971
9972 ELSEIF(ISUB.LE.225) THEN
9973 IF(ISUB.EQ.216) THEN
9974C...f + fbar -> ~chi01 + ~chi01
9975 MINT(21)=KSUSY1+22
9976 MINT(22)=KSUSY1+22
9977
9978 ELSEIF(ISUB.EQ.217) THEN
9979C...f + fbar -> ~chi02 + ~chi02
9980 MINT(21)=KSUSY1+23
9981 MINT(22)=KSUSY1+23
9982
9983 ELSEIF(ISUB.EQ.218 ) THEN
9984C...f + fbar -> ~chi03 + ~chi03
9985 MINT(21)=KSUSY1+25
9986 MINT(22)=KSUSY1+25
9987
9988 ELSEIF(ISUB.EQ.219 ) THEN
9989C...f + fbar -> ~chi04 + ~chi04
9990 MINT(21)=KSUSY1+35
9991 MINT(22)=KSUSY1+35
9992
9993 ELSEIF(ISUB.EQ.220 ) THEN
9994C...f + fbar -> ~chi01 + ~chi02
9995 IF(MINT(15).LT.0) JS=2
9996C IF(PYR(0).GT.0.5D0) JS=2
9997 MINT(20+JS)=KSUSY1+22
9998 MINT(23-JS)=KSUSY1+23
9999
10000 ELSEIF(ISUB.EQ.221 ) THEN
10001C...f + fbar -> ~chi01 + ~chi03
10002 IF(MINT(15).LT.0) JS=2
10003C IF(PYR(0).GT.0.5D0) JS=2
10004 MINT(20+JS)=KSUSY1+22
10005 MINT(23-JS)=KSUSY1+25
10006
10007 ELSEIF(ISUB.EQ.222) THEN
10008C...f + fbar -> ~chi01 + ~chi04
10009 IF(MINT(15).LT.0) JS=2
10010C IF(PYR(0).GT.0.5D0) JS=2
10011 MINT(20+JS)=KSUSY1+22
10012 MINT(23-JS)=KSUSY1+35
10013
10014 ELSEIF(ISUB.EQ.223) THEN
10015C...f + fbar -> ~chi02 + ~chi03
10016 IF(MINT(15).LT.0) JS=2
10017C IF(PYR(0).GT.0.5D0) JS=2
10018 MINT(20+JS)=KSUSY1+23
10019 MINT(23-JS)=KSUSY1+25
10020
10021 ELSEIF(ISUB.EQ.224) THEN
10022C...f + fbar -> ~chi02 + ~chi04
10023 IF(MINT(15).LT.0) JS=2
10024C IF(PYR(0).GT.0.5D0) JS=2
10025 MINT(20+JS)=KSUSY1+23
10026 MINT(23-JS)=KSUSY1+35
10027
10028 ELSEIF(ISUB.EQ.225) THEN
10029C...f + fbar -> ~chi03 + ~chi04
10030 IF(MINT(15).LT.0) JS=2
10031C IF(PYR(0).GT.0.5D0) JS=2
10032 MINT(20+JS)=KSUSY1+25
10033 MINT(23-JS)=KSUSY1+35
10034 ENDIF
10035
10036 ELSEIF(ISUB.LE.236) THEN
10037 IF(ISUB.EQ.226) THEN
10038C...f + fbar -> ~chi+-1 + ~chi-+1
10039C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
10040 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10041 MINT(21)=ISIGN(KSUSY1+24,KCH1)
10042 MINT(22)=-MINT(21)
10043
10044 ELSEIF(ISUB.EQ.227) THEN
10045C...f + fbar -> ~chi+-2 + ~chi-+2
10046 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10047 MINT(21)=ISIGN(KSUSY1+37,KCH1)
10048 MINT(22)=-MINT(21)
10049
10050 ELSEIF(ISUB.EQ.228) THEN
10051C...f + fbar -> ~chi+-1 + ~chi-+2
10052C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
10053C...js=1 if pyr<.5, js=2 if pyr>.5
10054C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
10055C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
10056C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
10057C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
10058 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10059 KCH2=INT(1-KCH1)/2
10060 IF(MINT(2).EQ.1) THEN
10061 MINT(21)= ISIGN(KSUSY1+24,KCH1)
10062 MINT(22)= -ISIGN(KSUSY1+37,KCH1)
10063c IF(KCH2.EQ.0) JS=2
10064 ELSE
10065 MINT(21)= ISIGN(KSUSY1+37,KCH1)
10066 MINT(22)= -ISIGN(KSUSY1+24,KCH1)
10067 JS=2
10068c IF(KCH2.EQ.1) JS=2
10069 ENDIF
10070
10071 ELSEIF(ISUB.EQ.229) THEN
10072C...q + qbar' -> ~chi01 + ~chi+-1
10073C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
10074 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10075 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10076C...CHECK THIS
10077 IF(MOD(MINT(15),2).EQ.0) JS=2
10078 MINT(20+JS)=KSUSY1+22
10079 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
10080
10081 ELSEIF(ISUB.EQ.230) THEN
10082C...q + qbar' -> ~chi02 + ~chi+-1
10083 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10084 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10085 IF(MOD(MINT(15),2).EQ.0) JS=2
10086 MINT(20+JS)=KSUSY1+23
10087 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
10088
10089 ELSEIF(ISUB.EQ.231) THEN
10090C...q + qbar' -> ~chi03 + ~chi+-1
10091 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10092 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10093 IF(MOD(MINT(15),2).EQ.0) JS=2
10094 MINT(20+JS)=KSUSY1+25
10095 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
10096
10097 ELSEIF(ISUB.EQ.232) THEN
10098C...q + qbar' -> ~chi04 + ~chi+-1
10099 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10100 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10101 IF(MOD(MINT(15),2).EQ.0) JS=2
10102 MINT(20+JS)=KSUSY1+35
10103 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
10104
10105 ELSEIF(ISUB.EQ.233) THEN
10106C...q + qbar' -> ~chi01 + ~chi+-2
10107 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10108 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10109 IF(MOD(MINT(15),2).EQ.0) JS=2
10110 MINT(20+JS)=KSUSY1+22
10111 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
10112
10113 ELSEIF(ISUB.EQ.234) THEN
10114C...q + qbar' -> ~chi02 + ~chi+-2
10115 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10116 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10117 IF(MOD(MINT(15),2).EQ.0) JS=2
10118 MINT(20+JS)=KSUSY1+23
10119 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
10120
10121 ELSEIF(ISUB.EQ.235) THEN
10122C...q + qbar' -> ~chi03 + ~chi+-2
10123 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10124 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10125 IF(MOD(MINT(15),2).EQ.0) JS=2
10126 MINT(20+JS)=KSUSY1+25
10127 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
10128
10129 ELSEIF(ISUB.EQ.236) THEN
10130C...q + qbar' -> ~chi04 + ~chi+-2
10131 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10132 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10133 IF(MOD(MINT(15),2).EQ.0) JS=2
10134 MINT(20+JS)=KSUSY1+35
10135 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
10136 ENDIF
10137
10138 ELSEIF(ISUB.LE.245) THEN
10139 IF(ISUB.EQ.237) THEN
10140C...q + qbar -> ~chi01 + ~g
10141C...th arbitrary
10142 IF(PYR(0).GT.0.5D0) JS=2
10143 MINT(20+JS)=KSUSY1+21
10144 MINT(23-JS)=KSUSY1+22
10145 KCC=17+JS
10146
10147 ELSEIF(ISUB.EQ.238) THEN
10148C...q + qbar -> ~chi02 + ~g
10149C...th arbitrary
10150 IF(PYR(0).GT.0.5D0) JS=2
10151 MINT(20+JS)=KSUSY1+21
10152 MINT(23-JS)=KSUSY1+23
10153 KCC=17+JS
10154
10155 ELSEIF(ISUB.EQ.239) THEN
10156C...q + qbar -> ~chi03 + ~g
10157C...th arbitrary
10158 IF(PYR(0).GT.0.5D0) JS=2
10159 MINT(20+JS)=KSUSY1+21
10160 MINT(23-JS)=KSUSY1+25
10161 KCC=17+JS
10162
10163 ELSEIF(ISUB.EQ.240) THEN
10164C...q + qbar -> ~chi04 + ~g
10165C...th arbitrary
10166 IF(PYR(0).GT.0.5D0) JS=2
10167 MINT(20+JS)=KSUSY1+21
10168 MINT(23-JS)=KSUSY1+35
10169 KCC=17+JS
10170
10171 ELSEIF(ISUB.EQ.241) THEN
10172C...q + qbar' -> ~chi+-1 + ~g
10173C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
10174C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
10175C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
10176C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
10177C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
10178 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10179 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10180 JS=1
10181 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10182 MINT(20+JS)=KSUSY1+21
10183 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
10184 KCC=17+JS
10185
10186 ELSEIF(ISUB.EQ.242) THEN
10187C...q + qbar' -> ~chi+-2 + ~g
10188C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
10189C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
10190C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
10191C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
10192C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
10193 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10194 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10195 JS=1
10196 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10197 MINT(20+JS)=KSUSY1+21
10198 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
10199 KCC=17+JS
10200
10201 ELSEIF(ISUB.EQ.243) THEN
10202C...q + qbar -> ~g + ~g ; th arbitrary
10203 MINT(21)=KSUSY1+21
10204 MINT(22)=KSUSY1+21
10205 KCC=MINT(2)+4
10206
10207 ELSEIF(ISUB.EQ.244) THEN
10208C...g + g -> ~g + ~g ; th arbitrary
10209 KCC=MINT(2)+12
10210 KCS=(-1)**INT(1.5D0+PYR(0))
10211 MINT(21)=KSUSY1+21
10212 MINT(22)=KSUSY1+21
10213 ENDIF
10214
10215 ELSEIF(ISUB.LE.260) THEN
10216 IF(ISUB.EQ.246) THEN
10217C...qj + g -> ~qj_L + ~chi01
10218 IF(MINT(15).EQ.21) JS=2
10219 I=MINT(14+JS)
10220 IA=IABS(I)
10221 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10222 MINT(23-JS)=KSUSY1+22
10223 KCC=15+JS
10224 KCS=ISIGN(1,MINT(14+JS))
10225
10226 ELSEIF(ISUB.EQ.247) THEN
10227C...qj + g -> ~qj_R + ~chi01
10228 IF(MINT(15).EQ.21) JS=2
10229 I=MINT(14+JS)
10230 IA=IABS(I)
10231 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10232 MINT(23-JS)=KSUSY1+22
10233 KCC=15+JS
10234 KCS=ISIGN(1,MINT(14+JS))
10235
10236 ELSEIF(ISUB.EQ.248) THEN
10237C...qj + g -> ~qj_L + ~chi02
10238 IF(MINT(15).EQ.21) JS=2
10239 I=MINT(14+JS)
10240 IA=IABS(I)
10241 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10242 MINT(23-JS)=KSUSY1+23
10243 KCC=15+JS
10244 KCS=ISIGN(1,MINT(14+JS))
10245
10246 ELSEIF(ISUB.EQ.249) THEN
10247C...qj + g -> ~qj_R + ~chi02
10248 IF(MINT(15).EQ.21) JS=2
10249 I=MINT(14+JS)
10250 IA=IABS(I)
10251 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10252 MINT(23-JS)=KSUSY1+23
10253 KCC=15+JS
10254 KCS=ISIGN(1,MINT(14+JS))
10255
10256 ELSEIF(ISUB.EQ.250) THEN
10257C...qj + g -> ~qj_L + ~chi03
10258 IF(MINT(15).EQ.21) JS=2
10259 I=MINT(14+JS)
10260 IA=IABS(I)
10261 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10262 MINT(23-JS)=KSUSY1+25
10263 KCC=15+JS
10264 KCS=ISIGN(1,MINT(14+JS))
10265
10266 ELSEIF(ISUB.EQ.251) THEN
10267C...qj + g -> ~qj_R + ~chi03
10268 IF(MINT(15).EQ.21) JS=2
10269 I=MINT(14+JS)
10270 IA=IABS(I)
10271 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10272 MINT(23-JS)=KSUSY1+25
10273 KCC=15+JS
10274 KCS=ISIGN(1,MINT(14+JS))
10275
10276 ELSEIF(ISUB.EQ.252) THEN
10277C...qj + g -> ~qj_L + ~chi04
10278 IF(MINT(15).EQ.21) JS=2
10279 I=MINT(14+JS)
10280 IA=IABS(I)
10281 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10282 MINT(23-JS)=KSUSY1+35
10283 KCC=15+JS
10284 KCS=ISIGN(1,MINT(14+JS))
10285
10286 ELSEIF(ISUB.EQ.253) THEN
10287C...qj + g -> ~qj_R + ~chi04
10288 IF(MINT(15).EQ.21) JS=2
10289 I=MINT(14+JS)
10290 IA=IABS(I)
10291 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10292 MINT(23-JS)=KSUSY1+35
10293 KCC=15+JS
10294 KCS=ISIGN(1,MINT(14+JS))
10295
10296 ELSEIF(ISUB.EQ.254) THEN
10297C...qj + g -> ~qk_L + ~chi+-1
10298 IF(MINT(15).EQ.21) JS=2
10299 I=MINT(14+JS)
10300 IA=IABS(I)
10301 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
10302 IB=-IA+INT((IA+1)/2)*4-1
10303 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
10304 KCC=15+JS
10305 KCS=ISIGN(1,MINT(14+JS))
10306
10307 ELSEIF(ISUB.EQ.255) THEN
10308C...qj + g -> ~qk_L + ~chi+-1
10309 IF(MINT(15).EQ.21) JS=2
10310 I=MINT(14+JS)
10311 IA=IABS(I)
10312 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
10313 IB=-IA+INT((IA+1)/2)*4-1
10314 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
10315 KCC=15+JS
10316 KCS=ISIGN(1,MINT(14+JS))
10317
10318 ELSEIF(ISUB.EQ.256) THEN
10319C...qj + g -> ~qk_L + ~chi+-2
10320 IF(MINT(15).EQ.21) JS=2
10321 I=MINT(14+JS)
10322 IA=IABS(I)
10323 IB=-IA+INT((IA+1)/2)*4-1
10324 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
10325 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
10326 KCC=15+JS
10327 KCS=ISIGN(1,MINT(14+JS))
10328
10329 ELSEIF(ISUB.EQ.257) THEN
10330C...qj + g -> ~qk_R + ~chi+-2
10331 IF(MINT(15).EQ.21) JS=2
10332 I=MINT(14+JS)
10333 IA=IABS(I)
10334 IB=-IA+INT((IA+1)/2)*4-1
10335 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
10336 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
10337 KCC=15+JS
10338 KCS=ISIGN(1,MINT(14+JS))
10339
10340 ELSEIF(ISUB.EQ.258) THEN
10341C...qj + g -> ~qj_L + ~g
10342 IF(MINT(15).EQ.21) JS=2
10343 I=MINT(14+JS)
10344 IA=IABS(I)
10345 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10346 MINT(23-JS)=KSUSY1+21
10347 KCC=MINT(2)+6
10348 IF(JS.EQ.2) KCC=KCC+2
10349 KCS=ISIGN(1,I)
10350
10351 ELSEIF(ISUB.EQ.259) THEN
10352C...qj + g -> ~qj_R + ~g
10353 IF(MINT(15).EQ.21) JS=2
10354 I=MINT(14+JS)
10355 IA=IABS(I)
10356 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10357 MINT(23-JS)=KSUSY1+21
10358 KCC=MINT(2)+6
10359 IF(JS.EQ.2) KCC=KCC+2
10360 KCS=ISIGN(1,I)
10361 ENDIF
10362
10363 ELSEIF(ISUB.LE.270) THEN
10364 IF(ISUB.EQ.261) THEN
10365C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
10366 ISGN=1
10367 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
10368 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
10369 MINT(22)=-MINT(21)
10370C...Correct color combination
10371 IF(MINT(43).EQ.4) KCC=4
10372
10373 ELSEIF(ISUB.EQ.262) THEN
10374C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
10375 ISGN=1
10376 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
10377 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
10378 MINT(22)=-MINT(21)
10379C...Correct color combination
10380 IF(MINT(43).EQ.4) KCC=4
10381
10382 ELSEIF(ISUB.EQ.263) THEN
10383C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
10384 IF((KCS.GT.0.AND.MINT(2).EQ.1).OR.
10385 & (KCS.LT.0.AND.MINT(2).EQ.2)) THEN
10386 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10387 MINT(22)=-ISIGN(KFPR(ISUB,2),KCS)
10388 ELSE
10389 JS=2
10390 MINT(21)=ISIGN(KFPR(ISUB,2),KCS)
10391 MINT(22)=-ISIGN(KFPR(ISUB,1),KCS)
10392 ENDIF
10393C...Correct color combination
10394 IF(MINT(43).EQ.4) KCC=4
10395
10396 ELSEIF(ISUB.EQ.264) THEN
10397C...g + g -> ~t_1 + ~t_1bar; th arbitrary
10398 KCS=(-1)**INT(1.5D0+PYR(0))
10399 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10400 MINT(22)=-MINT(21)
10401 KCC=MINT(2)+10
10402
10403 ELSEIF(ISUB.EQ.265) THEN
10404C...g + g -> ~t_2 + ~t_2bar; th arbitrary
10405 KCS=(-1)**INT(1.5D0+PYR(0))
10406 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10407 MINT(22)=-MINT(21)
10408 KCC=MINT(2)+10
10409 ENDIF
10410
10411 ELSEIF(ISUB.LE.296) THEN
10412 IF(ISUB.EQ.271.OR.ISUB.EQ.281.OR.ISUB.EQ.291) THEN
10413C...qi + qj -> ~qi_L + ~qj_L
10414 KCC=MINT(2)
10415 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10416 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
10417 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
10418
10419 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.282.OR.ISUB.EQ.292) THEN
10420C...qi + qj -> ~qi_R + ~qj_R
10421 KCC=MINT(2)
10422 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10423 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
10424 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
10425
10426 ELSEIF(ISUB.EQ.273.OR.ISUB.EQ.283.OR.ISUB.EQ.293) THEN
10427C...qi + qj -> ~qi_L + ~qj_R
10428 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
10429 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
10430 KCC=MINT(2)
10431 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10432
10433 ELSEIF(ISUB.EQ.274.OR.ISUB.EQ.284) THEN
10434C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
10435 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
10436 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
10437 KCC=MINT(2)
10438 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10439
10440 ELSEIF(ISUB.EQ.275.OR.ISUB.EQ.285) THEN
10441C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
10442 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
10443 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
10444 KCC=MINT(2)
10445 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10446
10447 ELSEIF(ISUB.EQ.276.OR.ISUB.EQ.286.OR.ISUB.EQ.296) THEN
10448C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
10449 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
10450 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
10451 KCC=MINT(2)
10452 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10453
10454 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.287) THEN
10455C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
10456 ISGN=1
10457 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
10458 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
10459 MINT(22)=-MINT(21)
10460 IF(MINT(43).EQ.4) KCC=4
10461
10462 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.288) THEN
10463C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
10464 ISGN=1
10465 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
10466 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
10467 MINT(22)=-MINT(21)
10468 IF(MINT(43).EQ.4) KCC=4
10469
10470 ELSEIF(ISUB.EQ.279.OR.ISUB.EQ.289) THEN
10471C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
10472C...pure LL + RR
10473 KCS=(-1)**INT(1.5D0+PYR(0))
10474 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10475 MINT(22)=-MINT(21)
10476 KCC=MINT(2)+10
10477
10478 ELSEIF(ISUB.EQ.280.OR.ISUB.EQ.290) THEN
10479C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
10480 KCS=(-1)**INT(1.5D0+PYR(0))
10481 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10482 MINT(22)=-MINT(21)
10483 KCC=MINT(2)+10
10484
10485 ELSEIF(ISUB.EQ.294) THEN
10486C...qj + g -> ~qj_L + ~g
10487 IF(MINT(15).EQ.21) JS=2
10488 I=MINT(14+JS)
10489 IA=IABS(I)
10490 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10491 MINT(23-JS)=KSUSY1+21
10492 KCC=MINT(2)+6
10493 IF(JS.EQ.2) KCC=KCC+2
10494 KCS=ISIGN(1,I)
10495
10496 ELSEIF(ISUB.EQ.295) THEN
10497C...qj + g -> ~qj_R + ~g
10498 IF(MINT(15).EQ.21) JS=2
10499 I=MINT(14+JS)
10500 IA=IABS(I)
10501 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10502 MINT(23-JS)=KSUSY1+21
10503 KCC=MINT(2)+6
10504 IF(JS.EQ.2) KCC=KCC+2
10505 KCS=ISIGN(1,I)
10506 ENDIF
10507
10508 ELSEIF(ISUB.LE.340) THEN
10509
10510 IF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
10511C...q + qbar' -> H+ + H0
10512 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10513 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10514 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10515 MINT(20+JS)=ISIGN(37,KCH1+KCH2)
10516 MINT(23-JS)=KFPR(ISUB,2)
10517 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
10518C...f + fbar -> A0 + H0; th arbitrary
10519 IF(PYR(0).GT.0.5D0) JS=2
10520 MINT(20+JS)=KFPR(ISUB,1)
10521 MINT(23-JS)=KFPR(ISUB,2)
10522 ELSEIF(ISUB.EQ.301) THEN
10523C...f + fbar -> H+ H-
10524 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10525 MINT(22)=-MINT(21)
10526 ENDIF
10527CMRENNA--
10528
10529 ELSEIF(ISUB.LE.360) THEN
10530
10531 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
10532C...l + l -> H_L++/--, H_R++/--
10533 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10534 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10535 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
10536
10537 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
10538C...l + gamma -> l' + H++/--; th=(p(l)-p(H))**2
10539 IF(MINT(15).EQ.22) JS=2
10540 MINT(20+JS)=ISIGN(KFPR(ISUB,1),-MINT(14+JS))
10541 MINT(23-JS)=ISIGN(KFPR(ISUB,2),-MINT(14+JS))
10542 KCC=22
10543
10544 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
10545C...f + fbar -> H++ + H--; th = (p(f)-p(H--))**2
10546 MINT(21)=-ISIGN(KFPR(ISUB,1),MINT(15))
10547 MINT(22)=-MINT(21)
10548
10549 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
10550C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/--
10551C...as inner process).
10552 DO 450 JT=1,2
10553 I=MINT(14+JT)
10554 IA=IABS(I)
10555 IF(IA.LE.10) THEN
10556 RVCKM=VINT(180+I)*PYR(0)
10557 DO 440 J=1,MSTP(1)
10558 IB=2*J-1+MOD(IA,2)
10559 IPM=(5-ISIGN(1,I))/2
10560 IDC=J+MDCY(IA,2)+2
10561 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 440
10562 MINT(20+JT)=ISIGN(IB,I)
10563 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10564 IF(RVCKM.LE.0D0) GOTO 450
10565 440 CONTINUE
10566 ELSE
10567 IB=2*((IA+1)/2)-1+MOD(IA,2)
10568 MINT(20+JT)=ISIGN(IB,I)
10569 ENDIF
10570 450 CONTINUE
10571 KCC=22
10572 KFRES=ISIGN(KFPR(ISUB,1),MINT(15))
10573 IF(MOD(MINT(15),2).EQ.1) KFRES=-KFRES
10574
10575 ELSEIF(ISUB.EQ.353) THEN
10576C...f + fbar -> Z_R0
10577 KFRES=KFPR(ISUB,1)
10578
10579 ELSEIF(ISUB.EQ.354) THEN
10580C...f + fbar' -> W+/-
10581 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10582 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10583 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
10584
10585 ENDIF
10586
10587 ELSEIF(ISUB.LE.380) THEN
10588
10589 IF(ISUB.LE.363.OR.ISUB.EQ.368) THEN
10590C...f + fbar -> charged+ charged- technicolor
10591 KSW=(-1)**INT(1.5D0+PYR(0))
10592 MINT(21)=ISIGN(KFPR(ISUB,1),KSW)
10593 MINT(22)=-ISIGN(KFPR(ISUB,2),KSW)
10594
10595 ELSEIF(ISUB.LE.367) THEN
10596C...f + fbar -> neutral neutral technicolor
10597 MINT(21)=KFPR(ISUB,1)
10598 MINT(22)=KFPR(ISUB,2)
10599
10600 ELSEIF(ISUB.EQ.374.OR.ISUB.EQ.375) THEN
10601C...f + fbar' -> neutral charged technicolor
10602 IN=1
10603 IC=2
10604 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10605 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10606 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10607 MINT(23-JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
10608 MINT(20+JS)=KFPR(ISUB,IN)
10609
10610 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
10611C...f + fbar' -> charged neutral technicolor
10612 IN=2
10613 IC=1
10614 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10615 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10616 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10617 MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
10618 MINT(23-JS)=KFPR(ISUB,IN)
10619 ENDIF
10620
10621 ELSEIF(ISUB.LE.400) THEN
10622 IF(ISUB.EQ.381) THEN
10623C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2, TC extensions
10624 KCC=MINT(2)
10625 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10626
10627 ELSEIF(ISUB.EQ.382) THEN
10628C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2, TC extensions
10629 MINT(21)=ISIGN(KFLF,MINT(15))
10630 MINT(22)=-MINT(21)
10631 KCC=4
10632
10633 ELSEIF(ISUB.EQ.383) THEN
10634C...f + fbar -> g + g; th arbitrary, TC extensions
10635 MINT(21)=21
10636 MINT(22)=21
10637 KCC=MINT(2)+4
10638
10639 ELSEIF(ISUB.EQ.384) THEN
10640C...f + g -> f + g; th = (p(f)-p(f))**2, TC extensions
10641 IF(MINT(15).EQ.21) JS=2
10642 KCC=MINT(2)+6
10643 IF(MINT(15).EQ.21) KCC=KCC+2
10644 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
10645 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
10646
10647 ELSEIF(ISUB.EQ.385) THEN
10648C...g + g -> f + fbar; th arbitrary, TC extensions
10649 KCS=(-1)**INT(1.5D0+PYR(0))
10650 MINT(21)=ISIGN(KFLF,KCS)
10651 MINT(22)=-MINT(21)
10652 KCC=MINT(2)+10
10653
10654 ELSEIF(ISUB.EQ.386) THEN
10655C...g + g -> g + g; th arbitrary, TC extensions
10656 KCC=MINT(2)+12
10657 KCS=(-1)**INT(1.5D0+PYR(0))
10658
10659 ELSEIF(ISUB.EQ.387) THEN
10660C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2, TC extensions
10661 MINT(21)=ISIGN(MINT(55),MINT(15))
10662 MINT(22)=-MINT(21)
10663 KCC=4
10664
10665 ELSEIF(ISUB.EQ.388) THEN
10666C...g + g -> Q + Qbar; th arbitrary, TC extensions
10667 KCS=(-1)**INT(1.5D0+PYR(0))
10668 MINT(21)=ISIGN(MINT(55),KCS)
10669 MINT(22)=-MINT(21)
10670 KCC=MINT(2)+10
10671
10672 ELSEIF(ISUB.EQ.391) THEN
10673C...f + fbar -> G*.
10674 KFRES=KFPR(ISUB,1)
10675
10676 ELSEIF(ISUB.EQ.392) THEN
10677C...g + g -> G*.
10678 KCC=21
10679 KFRES=KFPR(ISUB,1)
10680
10681 ELSEIF(ISUB.EQ.393) THEN
10682C...q + qbar -> g + G*; th arbitrary.
10683 IF(PYR(0).GT.0.5D0) JS=2
10684 MINT(20+JS)=KFPR(ISUB,1)
10685 MINT(23-JS)=KFPR(ISUB,2)
10686 KCC=17+JS
10687
10688 ELSEIF(ISUB.EQ.394) THEN
10689C...q + g -> q + G*; th = (p(f) - p(f))**2
10690 IF(MINT(15).EQ.21) JS=2
10691 MINT(23-JS)=KFPR(ISUB,2)
10692 KCC=15+JS
10693 KCS=ISIGN(1,MINT(14+JS))
10694
10695 ELSEIF(ISUB.EQ.395) THEN
10696C...g + g -> G* + g; th arbitrary.
10697 IF(PYR(0).GT.0.5D0) JS=2
10698 MINT(23-JS)=KFPR(ISUB,2)
10699 KCC=22+JS
10700 ENDIF
10701 ENDIF
10702
10703 IF(ISET(ISUB).EQ.11) THEN
10704C...Store documentation for user-defined processes
10705 BEZUP=(PUP(3,1)+PUP(3,2))/(PUP(4,1)+PUP(4,2))
10706 KUPPO(1)=MINT(83)+5
10707 KUPPO(2)=MINT(83)+6
10708 I=MINT(83)+6
10709 DO 470 IUP=3,NUP
10710 KUPPO(IUP)=0
10711 IF(MSTP(128).GE.2.AND.MOTHUP(1,IUP).GE.3) THEN
10712 IDOC=IDOC-1
10713 MINT(4)=MINT(4)-1
10714 GOTO 470
10715 ENDIF
10716 I=I+1
10717 KUPPO(IUP)=I
10718 K(I,1)=21
10719 K(I,2)=IDUP(IUP)
10720 IF(IDUP(IUP).EQ.0) K(I,2)=90
10721 K(I,3)=0
10722 IF(MOTHUP(1,IUP).GE.3) K(I,3)=KUPPO(MOTHUP(1,IUP))
10723 K(I,4)=0
10724 K(I,5)=0
10725 DO 460 J=1,5
10726 P(I,J)=PUP(J,IUP)
10727 460 CONTINUE
10728 V(I,5)=VTIMUP(IUP)
10729 470 CONTINUE
10730 CALL PYROBO(MINT(83)+7,MINT(83)+4+NUP,0D0,VINT(24),0D0,0D0,
10731 & -BEZUP)
10732
10733C...Store final state partons for user-defined processes
10734 N=IPU2
10735 DO 490 IUP=3,NUP
10736 N=N+1
10737 K(N,1)=1
10738 IF(ISTUP(IUP).EQ.2.OR.ISTUP(IUP).EQ.3) K(N,1)=11
10739 K(N,2)=IDUP(IUP)
10740 IF(IDUP(IUP).EQ.0) K(N,2)=90
10741 IF(MSTP(128).LE.0.OR.MOTHUP(1,IUP).EQ.0) THEN
10742 K(N,3)=KUPPO(IUP)
10743 ELSE
10744 K(N,3)=MINT(84)+MOTHUP(1,IUP)
10745 ENDIF
10746 K(N,4)=0
10747 K(N,5)=0
10748 DO 480 J=1,5
10749 P(N,J)=PUP(J,IUP)
10750 480 CONTINUE
10751 V(N,5)=VTIMUP(IUP)
10752 490 CONTINUE
10753 CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP)
10754
10755C...Arrange colour flow for user-defined processes
10756 NLBL=0
10757 DO 540 IUP1=1,NUP
10758 I1=MINT(84)+IUP1
10759 IF(KCHG(PYCOMP(K(I1,2)),2).EQ.0) GOTO 540
10760 IF(K(I1,1).EQ.1) K(I1,1)=3
10761 IF(K(I1,1).EQ.11) K(I1,1)=14
10762C...Find a not yet considered colour/anticolour line.
10763 DO 530 ISDE1=1,2
10764 IF(ICOLUP(ISDE1,IUP1).EQ.0) GOTO 530
10765 NMAT=0
10766 DO 500 ILBL=1,NLBL
10767 IF(ICOLUP(ISDE1,IUP1).EQ.ILAB(ILBL)) NMAT=1
10768 500 CONTINUE
10769 IF(NMAT.EQ.0) THEN
10770 NLBL=NLBL+1
10771 ILAB(NLBL)=ICOLUP(ISDE1,IUP1)
10772C...Find all others belonging to same line.
10773 I3=I1
10774 I4=0
10775 DO 520 IUP2=IUP1+1,NUP
10776 I2=MINT(84)+IUP2
10777 DO 510 ISDE2=1,2
10778 IF(ICOLUP(ISDE2,IUP2).EQ.ICOLUP(ISDE1,IUP1)) THEN
10779 IF(ISDE2.EQ.ISDE1) THEN
10780 K(I3,3+ISDE2)=K(I3,3+ISDE2)+I2
10781 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I3
10782 I3=I2
10783 ELSEIF(I4.NE.0) THEN
10784 K(I4,3+ISDE2)=K(I4,3+ISDE2)+I2
10785 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I4
10786 I4=I2
10787 ELSEIF(IUP2.LE.2) THEN
10788 K(I1,3+ISDE1)=K(I1,3+ISDE1)+I2
10789 K(I2,3+ISDE2)=K(I2,3+ISDE2)+I1
10790 I4=I2
10791 ELSE
10792 K(I1,3+ISDE1)=K(I1,3+ISDE1)+MSTU(5)*I2
10793 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I1
10794 I4=I2
10795 ENDIF
10796 ENDIF
10797 510 CONTINUE
10798 520 CONTINUE
10799 ENDIF
10800 530 CONTINUE
10801 540 CONTINUE
10802
10803 ELSEIF(IDOC.EQ.7) THEN
10804C...Resonance not decaying; store kinematics
10805 I=MINT(83)+7
10806 K(IPU3,1)=1
10807 K(IPU3,2)=KFRES
10808 K(IPU3,3)=I
10809 P(IPU3,4)=SHUSER
10810 P(IPU3,5)=SHUSER
10811 K(I,1)=21
10812 K(I,2)=KFRES
10813 P(I,4)=SHUSER
10814 P(I,5)=SHUSER
10815 N=IPU3
10816 MINT(21)=KFRES
10817 MINT(22)=0
10818
10819C...Special cases: colour flow in coloured resonances
10820 KCRES=PYCOMP(KFRES)
10821 IF(KCHG(KCRES,2).NE.0) THEN
10822 K(IPU3,1)=3
10823 DO 550 J=1,2
10824 JC=J
10825 IF(KCS.EQ.-1) JC=3-J
10826 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
10827 & MINT(84)+ICOL(KCC,1,JC)
10828 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
10829 & MINT(84)+ICOL(KCC,2,JC)
10830 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
10831 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
10832 550 CONTINUE
10833 ELSE
10834 K(IPU1,4)=IPU2
10835 K(IPU1,5)=IPU2
10836 K(IPU2,4)=IPU1
10837 K(IPU2,5)=IPU1
10838 ENDIF
10839
10840 ELSEIF(IDOC.EQ.8) THEN
10841C...2 -> 2 processes: store outgoing partons in their CM-frame
10842 DO 560 JT=1,2
10843 I=MINT(84)+2+JT
10844 KCA=PYCOMP(MINT(20+JT))
10845 K(I,1)=1
10846 IF(KCHG(KCA,2).NE.0) K(I,1)=3
10847 K(I,2)=MINT(20+JT)
10848 K(I,3)=MINT(83)+IDOC+JT-2
10849 KFAA=IABS(K(I,2))
10850 IF(KFPR(ISUBSV,1+MOD(JS+JT,2)).NE.0) THEN
10851 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
10852 ELSE
10853 P(I,5)=PYMASS(K(I,2))
10854 ENDIF
10855 IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND.
10856 & P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2))
10857 560 CONTINUE
10858 IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
10859 KFA1=IABS(MINT(21))
10860 KFA2=IABS(MINT(22))
10861 IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
10862 & THEN
10863 MINT(51)=1
10864 RETURN
10865 ENDIF
10866 P(IPU3,5)=0D0
10867 P(IPU4,5)=0D0
10868 ENDIF
10869 P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
10870 P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2))
10871 P(IPU4,4)=SHR-P(IPU3,4)
10872 P(IPU4,3)=-P(IPU3,3)
10873 N=IPU4
10874 MINT(7)=MINT(83)+7
10875 MINT(8)=MINT(83)+8
10876
10877C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
10878 CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
10879
10880 ELSEIF(IDOC.EQ.9) THEN
10881C...2 -> 3 processes: store outgoing partons in their CM frame
10882 DO 570 JT=1,2
10883 I=MINT(84)+2+JT
10884 KCA=PYCOMP(MINT(20+JT))
10885 K(I,1)=1
10886 IF(KCHG(KCA,2).NE.0) K(I,1)=3
10887 K(I,2)=MINT(20+JT)
10888 K(I,3)=MINT(83)+IDOC+JT-3
10889 IF(IABS(K(I,2)).LE.22) THEN
10890 P(I,5)=PYMASS(K(I,2))
10891 ELSE
10892 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
10893 ENDIF
10894 PT=SQRT(MAX(0D0,VINT(197+5*JT)-P(I,5)**2+VINT(196+5*JT)**2))
10895 P(I,1)=PT*COS(VINT(198+5*JT))
10896 P(I,2)=PT*SIN(VINT(198+5*JT))
10897 570 CONTINUE
10898 K(IPU5,1)=1
10899 K(IPU5,2)=KFRES
10900 K(IPU5,3)=MINT(83)+IDOC
10901 P(IPU5,5)=SHR
10902 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
10903 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
10904 PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
10905 PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2
10906 PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2
10907 PMT3=SQRT(PMS3)
10908 P(IPU5,3)=PMT3*SINH(VINT(211))
10909 P(IPU5,4)=PMT3*COSH(VINT(211))
10910 PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2
10911 SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2
10912 IF(SQL12.LE.0D0) THEN
10913 MINT(51)=1
10914 RETURN
10915 ENDIF
10916 P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+
10917 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
10918 P(IPU4,3)=-P(IPU3,3)-P(IPU5,3)
10919 P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2)
10920 P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2)
10921 MINT(23)=KFRES
10922 N=IPU5
10923 MINT(7)=MINT(83)+7
10924 MINT(8)=MINT(83)+8
10925
10926 ELSEIF(IDOC.EQ.11) THEN
10927C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
10928 PHI(1)=PARU(2)*PYR(0)
10929 PHI(2)=PHI(1)-PHIR
10930 DO 580 JT=1,2
10931 I=MINT(84)+2+JT
10932 K(I,1)=1
10933 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
10934 K(I,2)=MINT(20+JT)
10935 K(I,3)=MINT(83)+IDOC+JT-2
10936 P(I,5)=PYMASS(K(I,2))
10937 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN
10938 MINT(51)=1
10939 RETURN
10940 ENDIF
10941 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
10942 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
10943 P(I,1)=PTABS*COS(PHI(JT))
10944 P(I,2)=PTABS*SIN(PHI(JT))
10945 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
10946 P(I,4)=0.5D0*SHPR*Z(JT)
10947 IZW=MINT(83)+6+JT
10948 K(IZW,1)=21
10949 K(IZW,2)=23
10950 IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT)))
10951 K(IZW,3)=IZW-2
10952 P(IZW,1)=-P(I,1)
10953 P(IZW,2)=-P(I,2)
10954 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
10955 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
10956 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
10957 580 CONTINUE
10958 I=MINT(83)+9
10959 K(IPU5,1)=1
10960 K(IPU5,2)=KFRES
10961 K(IPU5,3)=I
10962 P(IPU5,5)=SHR
10963 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
10964 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
10965 P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
10966 P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
10967 K(I,1)=21
10968 K(I,2)=KFRES
10969 DO 590 J=1,5
10970 P(I,J)=P(IPU5,J)
10971 590 CONTINUE
10972 N=IPU5
10973 MINT(23)=KFRES
10974
10975 ELSEIF(IDOC.EQ.12) THEN
10976C...Z0 and W+/- scattering: store bosons and outgoing partons
10977 PHI(1)=PARU(2)*PYR(0)
10978 PHI(2)=PHI(1)-PHIR
10979 JTRAN=INT(1.5D0+PYR(0))
10980 DO 600 JT=1,2
10981 I=MINT(84)+2+JT
10982 K(I,1)=1
10983 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
10984 K(I,2)=MINT(20+JT)
10985 K(I,3)=MINT(83)+IDOC+JT-2
10986 P(I,5)=PYMASS(K(I,2))
10987 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0
10988 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
10989 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
10990 P(I,1)=PTABS*COS(PHI(JT))
10991 P(I,2)=PTABS*SIN(PHI(JT))
10992 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
10993 P(I,4)=0.5D0*SHPR*Z(JT)
10994 IZW=MINT(83)+6+JT
10995 K(IZW,1)=21
10996 IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
10997 K(IZW,2)=23
10998 ELSE
10999 K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT)))
11000 ENDIF
11001 K(IZW,3)=IZW-2
11002 P(IZW,1)=-P(I,1)
11003 P(IZW,2)=-P(I,2)
11004 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
11005 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
11006 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
11007 IPU=MINT(84)+4+JT
11008 K(IPU,1)=3
11009 K(IPU,2)=KFPR(ISUB,JT)
11010 IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2)
11011 IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2)
11012 K(IPU,3)=MINT(83)+8+JT
11013 IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
11014 P(IPU,5)=PYMASS(K(IPU,2))
11015 ELSE
11016 P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
11017 ENDIF
11018 MINT(22+JT)=K(IPU,2)
11019 600 CONTINUE
11020C...Find rotation and boost for hard scattering subsystem
11021 I1=MINT(83)+7
11022 I2=MINT(83)+8
11023 BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
11024 BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
11025 BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
11026 GAMCM=(P(I1,4)+P(I2,4))/SHR
11027 BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
11028 PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM
11029 PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM
11030 PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM
11031 THECM=PYANGL(PZ,SQRT(PX**2+PY**2))
11032 PHICM=PYANGL(PX,PY)
11033C...Store hard scattering subsystem. Rotate and boost it
11034 SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2*
11035 & P(IPU6,5)**2
11036 PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH)))
11037 CTHWZ=VINT(23)
11038 STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2))
11039 PHIWZ=VINT(24)-PHICM
11040 P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
11041 P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
11042 P(IPU5,3)=PABS*CTHWZ
11043 P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
11044 P(IPU6,1)=-P(IPU5,1)
11045 P(IPU6,2)=-P(IPU5,2)
11046 P(IPU6,3)=-P(IPU5,3)
11047 P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
11048 CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM)
11049 DO 620 JT=1,2
11050 I1=MINT(83)+8+JT
11051 I2=MINT(84)+4+JT
11052 K(I1,1)=21
11053 K(I1,2)=K(I2,2)
11054 DO 610 J=1,5
11055 P(I1,J)=P(I2,J)
11056 610 CONTINUE
11057 620 CONTINUE
11058 N=IPU6
11059 MINT(7)=MINT(83)+9
11060 MINT(8)=MINT(83)+10
11061 ENDIF
11062
11063 IF(ISET(ISUB).EQ.11) THEN
11064 ELSEIF(IDOC.GE.8) THEN
11065C...Store colour connection indices
11066 DO 630 J=1,2
11067 JC=J
11068 IF(KCS.EQ.-1) JC=3-J
11069 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
11070 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
11071 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
11072 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
11073 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
11074 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
11075 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
11076 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
11077 630 CONTINUE
11078
11079C...Copy outgoing partons to documentation lines
11080 IMAX=2
11081 IF(IDOC.EQ.9) IMAX=3
11082 DO 650 I=1,IMAX
11083 I1=MINT(83)+IDOC-IMAX+I
11084 I2=MINT(84)+2+I
11085 K(I1,1)=21
11086 K(I1,2)=K(I2,2)
11087 IF(IDOC.LE.9) K(I1,3)=0
11088 IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
11089 DO 640 J=1,5
11090 P(I1,J)=P(I2,J)
11091 640 CONTINUE
11092 650 CONTINUE
11093
11094 ELSEIF(IDOC.EQ.9) THEN
11095C...Store colour connection indices
11096 DO 660 J=1,2
11097 JC=J
11098 IF(KCS.EQ.-1) JC=3-J
11099 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
11100 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+
11101 & MAX(0,MIN(1,ICOL(KCC,1,JC)-2))
11102 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
11103 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+
11104 & MAX(0,MIN(1,ICOL(KCC,2,JC)-2))
11105 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
11106 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
11107 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)=
11108 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
11109 660 CONTINUE
11110
11111C...Copy outgoing partons to documentation lines
11112 DO 680 I=1,3
11113 I1=MINT(83)+IDOC-3+I
11114 I2=MINT(84)+2+I
11115 K(I1,1)=21
11116 K(I1,2)=K(I2,2)
11117 K(I1,3)=0
11118 DO 670 J=1,5
11119 P(I1,J)=P(I2,J)
11120 670 CONTINUE
11121 680 CONTINUE
11122 ENDIF
11123
11124C...Low-pT events: remove gluons used for string drawing purposes
11125 IF(ISUB.EQ.95) THEN
11126 K(IPU3,1)=K(IPU3,1)+10
11127 K(IPU4,1)=K(IPU4,1)+10
11128 DO 690 J=41,66
11129 VINTSV(J)=VINT(J)
11130 VINT(J)=0D0
11131 690 CONTINUE
11132 DO 710 I=MINT(83)+5,MINT(83)+8
11133 DO 700 J=1,5
11134 P(I,J)=0D0
11135 700 CONTINUE
11136 710 CONTINUE
11137 ENDIF
11138
11139 RETURN
11140 END
11141
11142C*********************************************************************
11143
11144C...PYSSPA
11145C...Generates spacelike parton showers.
11146
11147 SUBROUTINE PYSSPA(IPU1,IPU2)
11148
11149C...Double precision and integer declarations.
11150 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
11151 IMPLICIT INTEGER(I-N)
11152 INTEGER PYK,PYCHGE,PYCOMP
11153C...Commonblocks.
11154 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
11155 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11156 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
11157 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
11158 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
11159 COMMON/PYINT1/MINT(400),VINT(400)
11160 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
11161 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
11162 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
11163 &/PYINT2/,/PYINT3/
11164C...Local arrays and data.
11165 DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2),
11166 &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25),
11167 &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),
11168 &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2),
11169 &THEFIS(2,2),ISFI(2),DPHI(2),MCESV(2)
11170 DATA IS/2*0/
11171
11172C...Read out basic information; set global Q^2 scale.
11173 IPUS1=IPU1
11174 IPUS2=IPU2
11175 ISUB=MINT(1)
11176 Q2MX=VINT(56)
11177 IF(ISET(ISUB).EQ.2) Q2MX=MIN(VINT(2),PARP(67)*VINT(56))
11178 FCQ2MX=1D0
11179
11180C...Define which processes ME corrections have been implemented for.
11181 MECOR=0
11182 IF(MSTP(68).EQ.1) THEN
11183 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ.142.OR.
11184 & ISUB.EQ.144) MECOR=1
11185 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
11186 ENDIF
11187
11188C...Initialize QCD evolution and check phase space.
11189 Q2MNC=PARP(62)**2
11190 Q2MNCS(1)=Q2MNC
11191 Q2MNCS(2)=Q2MNC
11192 IF(MINT(107).EQ.2.AND.MSTP(66).EQ.2) THEN
11193 Q0S=PARP(15)**2
11194 PS=VINT(3)**2
11195 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
11196 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
11197 Q2INT=SQRT(Q0S*Q2EFF)
11198 Q2MNCS(1)=MAX(Q2MNC,Q2INT)
11199 ELSEIF(MINT(107).EQ.3.AND.MSTP(66).GE.1) THEN
11200 Q2MNCS(1)=MAX(Q2MNC,VINT(283))
11201 ENDIF
11202 IF(MINT(108).EQ.2.AND.MSTP(66).EQ.2) THEN
11203 Q0S=PARP(15)**2
11204 PS=VINT(4)**2
11205 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
11206 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
11207 Q2INT=SQRT(Q0S*Q2EFF)
11208 Q2MNCS(2)=MAX(Q2MNC,Q2INT)
11209 ELSEIF(MINT(108).EQ.3.AND.MSTP(66).GE.1) THEN
11210 Q2MNCS(2)=MAX(Q2MNC,VINT(284))
11211 ENDIF
11212 MCEV=0
11213 ALAMS=PARU(112)
11214 PARU(112)=PARP(61)
11215 FQ2C=1D0
11216 TCMX=0D0
11217 IF(MINT(47).GE.2.AND.(MINT(47).LT.5.OR.MSTP(12).GE.1)) THEN
11218 MCEV=1
11219 IF(MSTP(64).EQ.1) FQ2C=PARP(63)
11220 IF(MSTP(64).EQ.2) FQ2C=PARP(64)
11221 TCMX=LOG(FQ2C*Q2MX/PARP(61)**2)
11222 IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0)
11223 & MCEV=0
11224 ENDIF
11225
11226C...Initialize QED evolution and check phase space.
11227 MEEV=0
11228 XEE=1D-10
11229 SPME=PMAS(11,1)**2
11230 IF(IABS(MINT(11)).EQ.13.OR.IABS(MINT(12)).EQ.13)
11231 &SPME=PMAS(13,1)**2
11232 IF(IABS(MINT(11)).EQ.15.OR.IABS(MINT(12)).EQ.15)
11233 &SPME=PMAS(15,1)**2
11234 Q2MNE=MAX(PARP(68)**2,2D0*SPME)
11235 TEMX=0D0
11236 FWTE=10D0
11237 IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN
11238 MEEV=1
11239 TEMX=LOG(Q2MX/SPME)
11240 IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0
11241 ENDIF
11242 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0) THEN
11243 MEEV=2
11244 TEMX=TCMX
11245 FWTE=1D0
11246 ENDIF
11247 IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN
11248
11249C...Loopback point in case of failure to reconstruct kinematics.
11250 NS=N
11251 LOOP=0
11252 100 LOOP=LOOP+1
11253 IF(LOOP.GT.100) THEN
11254 MINT(51)=1
11255 RETURN
11256 ENDIF
11257 N=NS
11258
11259C...Initial values: flavours, momenta, virtualities.
11260 DO 120 JT=1,2
11261 MORE(JT)=1
11262 KFBEAM(JT)=MINT(10+JT)
11263 IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22
11264 KFLS(JT)=MINT(14+JT)
11265 KFLS(JT+2)=KFLS(JT)
11266 XS(JT)=VINT(40+JT)
11267 IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT)
11268 ZS(JT)=1D0
11269 Q2S(JT)=FCQ2MX*Q2MX
11270 DQ2(JT)=0D0
11271 TEVCSV(JT)=TCMX
11272 ALAM(JT)=PARP(61)
11273 THE2(JT)=1D0
11274 TEVESV(JT)=TEMX
11275 MCESV(JT)=0
11276C...Calculate initial parton distribution weights.
11277 MINT(105)=MINT(102+JT)
11278 MINT(109)=MINT(106+JT)
11279 VINT(120)=VINT(2+JT)
11280C.... ALICE
11281C.... Store side in MINT(124)
11282 MINT(124) = JT
11283C....
11284 IF(XS(JT).LT.1D0-XEE) THEN
11285 IF(MSTP(57).LE.1) THEN
11286 CALL PYPDFU(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
11287 ELSE
11288 CALL PYPDFL(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
11289 ENDIF
11290 ENDIF
11291 DO 110 KFL=-25,25
11292 XFS(JT,KFL)=XFB(KFL)
11293 110 CONTINUE
11294C...Special kinematics check for c/b quarks (that g -> c cbar or
11295C...b bbar kinematically possible).
11296 KFLCB=IABS(KFLS(JT))
11297 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
11298 IF(XS(JT).GT.0.9D0*Q2S(JT)/(PMAS(KFLCB,1)**2+Q2S(JT))) THEN
11299 MINT(51)=1
11300 RETURN
11301 ENDIF
11302 ENDIF
11303 120 CONTINUE
11304 DSH=VINT(44)
11305 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2)
11306
11307C...Find if interference with final state partons.
11308 MFIS=0
11309 IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67)
11310 IF(MFIS.NE.0) THEN
11311 DO 140 I=1,2
11312 KCFI(I)=0
11313 KCA=PYCOMP(IABS(KFLS(I)))
11314 IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I))
11315 NFIS(I)=0
11316 IF(KCFI(I).NE.0) THEN
11317 IF(I.EQ.1) IPFS=IPUS1
11318 IF(I.EQ.2) IPFS=IPUS2
11319 DO 130 J=1,2
11320 ICSI=MOD(K(IPFS,3+J),MSTU(5))
11321 IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND.
11322 & (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN
11323 NFIS(I)=NFIS(I)+1
11324 THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+
11325 & P(ICSI,2)**2))
11326 IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I))
11327 ENDIF
11328 130 CONTINUE
11329 ENDIF
11330 140 CONTINUE
11331 IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0
11332 ENDIF
11333
11334C...Pick up leg with highest virtuality.
11335 JTOLD=1
11336 150 N=N+1
11337 JT=1
11338 IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
11339 IF(N.EQ.NS+2.AND.JT.EQ.JTOLD) JT=3-JT
11340 IF(MORE(JT).EQ.0) JT=3-JT
11341 JTOLD=JT
11342 KFLB=KFLS(JT)
11343 XB=XS(JT)
11344 DO 160 KFL=-25,25
11345 XFB(KFL)=XFS(JT,KFL)
11346 160 CONTINUE
11347 DSHR=2D0*SQRT(DSH)
11348 DSHZ=DSH/ZS(JT)
11349
11350C...Check if allowed to branch.
11351 MCEV=0
11352 IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN
11353 MCEV=1
11354 XEC=MAX(PARP(65)*DSHR/VINT(2),XB*(1D0/(1D0-PARP(66))-1D0))
11355 IF(XB.GE.1D0-2D0*XEC) MCEV=0
11356 ENDIF
11357 MEEV=0
11358 IF(MINT(44+JT).EQ.3) THEN
11359 MEEV=1
11360 IF(XB.GE.1D0-2D0*XEE) MEEV=0
11361 IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC)
11362 & MEEV=0
11363C***Currently kill QED shower for resolved photoproduction.
11364 IF(MINT(18+JT).EQ.1) MEEV=0
11365C***Currently kill shower for W inside electron.
11366 IF(IABS(KFLB).EQ.24) THEN
11367 MCEV=0
11368 MEEV=0
11369 ENDIF
11370 ENDIF
11371 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0.AND.IABS(KFLB).LE.10)
11372 &MEEV=2
11373 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
11374 Q2B=0D0
11375 GOTO 260
11376 ENDIF
11377
11378C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
11379 Q2B=Q2S(JT)
11380 TEVCB=TEVCSV(JT)
11381 TEVEB=TEVESV(JT)
11382 IF(MSTP(62).LE.1) THEN
11383 IF(ZS(JT).GT.0.99999D0) THEN
11384 Q2B=Q2S(JT)
11385 ELSE
11386 Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)*
11387 & (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+
11388 & 8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT))))
11389 ENDIF
11390 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
11391 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
11392 ENDIF
11393 IF(MCEV.EQ.1) THEN
11394 ALSDUM=PYALPS(FQ2C*Q2B)
11395 TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117))
11396 ALAM(JT)=PARU(117)
11397 B0=(33D0-2D0*MSTU(118))/6D0
11398 ENDIF
11399 IF(MEEV.EQ.2) TEVEB=TEVCB
11400 TEVCBS=TEVCB
11401 TEVEBS=TEVEB
11402
11403C...Select side for interference with final state partons.
11404 IF(MFIS.GE.1.AND.N.LE.NS+2) THEN
11405 IFI=N-NS
11406 ISFI(IFI)=0
11407 IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN
11408 ISFI(IFI)=1
11409 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN
11410 IF(PYR(0).GT.0.5D0) ISFI(IFI)=1
11411 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN
11412 ISFI(IFI)=1
11413 IF(PYR(0).GT.0.5D0) ISFI(IFI)=2
11414 ENDIF
11415 ENDIF
11416
11417C...Calculate preweighting factor for ME-corrected processes.
11418 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
11419
11420C...Calculate Altarelli-Parisi weights.
11421 DO 170 KFL=-25,25
11422 WTAPC(KFL)=0D0
11423 WTAPE(KFL)=0D0
11424 WTSF(KFL)=0D0
11425 170 CONTINUE
11426C...q -> q (g or gamma emission), g -> q.
11427 IF(IABS(KFLB).LE.10) THEN
11428 WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC)))
11429 WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC))
11430 EQ2=1D0/9D0
11431 IF(MOD(IABS(KFLB),2).EQ.0) EQ2=4D0*EQ2
11432 IF(MEEV.EQ.2) WTAPE(KFLB)=2.*EQ2*LOG((1D0-XEC-XB)*(XB+XEC)/
11433 & (XEC*(1D0-XEC)))
11434 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11435 WTAPC(KFLB)=WTFF*WTAPC(KFLB)
11436 WTAPC(21)=WTGF*WTAPC(21)
11437 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
11438 ENDIF
11439C...f -> f, gamma -> f.
11440 ELSEIF(IABS(KFLB).LE.20) THEN
11441 WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE)))
11442 WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))
11443 WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2)
11444 IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE)
11445 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11446 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
11447 WTAPE(22)=WTGF*WTAPE(22)
11448 ENDIF
11449C...f -> g, g -> g.
11450 ELSEIF(KFLB.EQ.21) THEN
11451 WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB))
11452 DO 180 KFL=1,MSTP(58)
11453 WTAPC(KFL)=WTAPQ
11454 WTAPC(-KFL)=WTAPQ
11455 180 CONTINUE
11456 WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC)
11457 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11458 DO 190 KFL=1,MSTP(58)
11459 WTAPC(KFL)=WTFG*WTAPC(KFL)
11460 WTAPC(-KFL)=WTFG*WTAPC(-KFL)
11461 190 CONTINUE
11462 WTAPC(21)=WTGG*WTAPC(21)
11463 ENDIF
11464C...f -> gamma, W+, W-.
11465 ELSEIF(KFLB.EQ.22) THEN
11466 WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB
11467 WTAPE(11)=WTAPF
11468 WTAPE(-11)=WTAPF
11469 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11470 WTAPE(11)=WTFG*WTAPE(11)
11471 WTAPE(-11)=WTFG*WTAPE(-11)
11472 ENDIF
11473 ELSEIF(KFLB.EQ.24) THEN
11474 WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
11475 & (XEE*(XB+XEE)))/XB
11476 ELSEIF(KFLB.EQ.-24) THEN
11477 WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
11478 & (XEE*(XB+XEE)))/XB
11479 ENDIF
11480
11481C...Calculate parton distribution weights and sum.
11482 NTRY=0
11483 200 NTRY=NTRY+1
11484 IF(NTRY.GT.500) THEN
11485 MINT(51)=1
11486 RETURN
11487 ENDIF
11488 WTSUMC=0D0
11489 WTSUME=0D0
11490 XFBO=MAX(1D-10,XFB(KFLB))
11491 DO 210 KFL=-25,25
11492 WTSF(KFL)=XFB(KFL)/XFBO
11493 WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL)
11494 WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL)
11495 210 CONTINUE
11496 WTSUMC=MAX(0.0001D0,WTSUMC)
11497 WTSUME=MAX(0.0001D0/FWTE,WTSUME)
11498
11499C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
11500 NTRY2=0
11501 220 NTRY2=NTRY2+1
11502 IF(NTRY2.GT.500) THEN
11503 MINT(51)=1
11504 RETURN
11505 ENDIF
11506 IF(MCEV.EQ.1) THEN
11507 IF(MSTP(64).LE.0) THEN
11508 TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC)
11509 ELSEIF(MSTP(64).EQ.1) THEN
11510 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC))
11511 ELSE
11512 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC)))
11513 ENDIF
11514 ENDIF
11515 IF(MEEV.EQ.1) THEN
11516 TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
11517 & (PARU(101)*FWTE*WTSUME*TEMX)))
11518 ELSEIF(MEEV.EQ.2) THEN
11519 TEVEB=TEVEB+LOG(PYR(0))*PARU(2)/(PARU(101)*WTSUME)
11520 ENDIF
11521
11522C...Translate t into Q2 scale; choose between QCD and QED evolution.
11523 230 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C
11524 IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
11525 IF(MEEV.EQ.2) Q2EB=ALAM(JT)**2*EXP(MAX(-50D0,TEVEB))/FQ2C
11526C...Ensure that Q2 is above threshold for charm/bottom.
11527 KFLCB=IABS(KFLB)
11528 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
11529 &MCEV.EQ.1) THEN
11530 IF(Q2CB.LT.PMAS(KFLCB,1)**2) THEN
11531 Q2CB=1.1D0*PMAS(KFLCB,1)**2
11532 TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
11533 FCQ2MX=MIN(2D0,1.05D0*FCQ2MX)
11534 ENDIF
11535 ENDIF
11536 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
11537 &MEEV.EQ.2) THEN
11538 IF(Q2EB.LT.PMAS(KFLCB,1)**2) MEEV=0
11539 ENDIF
11540 MCE=0
11541 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
11542 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN
11543 IF(Q2CB.GT.Q2MNCS(JT)) MCE=1
11544 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN
11545 IF(Q2EB.GT.Q2MNE) MCE=2
11546 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.2) THEN
11547 IF(Q2EB.GT.Q2MNCS(JT)) MCE=2
11548 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.2) THEN
11549 IF(Q2CB.GT.Q2EB.AND.Q2CB.GT.Q2MNCS(JT)) MCE=1
11550 IF(Q2EB.GT.Q2CB.AND.Q2EB.GT.Q2MNCS(JT)) MCE=2
11551 ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN
11552 MCE=1
11553 IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2
11554 IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0
11555 ELSE
11556 MCE=2
11557 IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1
11558 IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0
11559 ENDIF
11560
11561C...Evolution possibly ended. Update t values.
11562 IF(MCE.EQ.0) THEN
11563 Q2B=0D0
11564 GOTO 260
11565 ELSEIF(MCE.EQ.1) THEN
11566 Q2B=Q2CB
11567 Q2REF=FQ2C*Q2B
11568 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
11569 IF(MEEV.EQ.2) TEVEB=LOG(FQ2C*Q2B/ALAM(JT)**2)
11570 ELSE
11571 Q2B=Q2EB
11572 Q2REF=Q2B
11573 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
11574 ENDIF
11575
11576C...Select flavour for branching parton.
11577 IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC
11578 IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME
11579 KFLA=-25
11580 240 KFLA=KFLA+1
11581 IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA)
11582 IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA)
11583 IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 240
11584 IF(KFLA.EQ.25) THEN
11585 Q2B=0D0
11586 GOTO 260
11587 ENDIF
11588
11589C...Choose z value and corrective weight.
11590 WTZ=0D0
11591C...q -> q + g or q -> q + gamma.
11592 IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN
11593 Z=1D0-((1D0-XB-XEC)/(1D0-XEC))*
11594 & (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0)
11595 WTZ=0.5D0*(1D0+Z**2)
11596C...q -> g + q.
11597 ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN
11598 Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2
11599 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
11600C...f -> f + gamma.
11601 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
11602 IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN
11603 Z=1D0-((1D0-XB-XEE)/(1D0-XEE))*
11604 & (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0)
11605 ELSE
11606 Z=XB+XB*(XEE/(1D0-XEE))*
11607 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
11608 ENDIF
11609 WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB)
11610C...f -> gamma + f.
11611 ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) THEN
11612 Z=XB+XB*(XEE/(1D0-XEE))*
11613 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
11614 WTZ=0.5D0*(1D0+(1D0-Z)**2)*XB*(Z-XB)/Z
11615C...f -> W+- + f.
11616 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) THEN
11617 Z=XB+XB*(XEE/(1D0-XEE))*
11618 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
11619 WTZ=0.5D0*(1D0+(1D0-Z)**2)*(XB*(Z-XB)/Z)*
11620 & (Q2B/(Q2B+PMAS(24,1)**2))
11621C...g -> q + qbar.
11622 ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN
11623 Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC))
11624 WTZ=1D0-2D0*Z*(1D0-Z)
11625C...g -> g + g.
11626 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
11627 Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0))
11628 WTZ=(1D0-Z*(1D0-Z))**2
11629C...gamma -> f + fbar.
11630 ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN
11631 Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE))
11632 WTZ=1D0-2D0*Z*(1D0-Z)
11633 ENDIF
11634 IF(MCE.EQ.2.AND.MEEV.EQ.1) WTZ=(WTZ/FWTE)*(TEVEB/TEMX)
11635
11636C...Option with resummation of soft gluon emission as effective z shift.
11637 IF(MCE.EQ.1) THEN
11638 IF(MSTP(65).GE.1) THEN
11639 RSOFT=6D0
11640 IF(KFLB.NE.21) RSOFT=8D0/3D0
11641 Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0))
11642 IF(Z.LE.XB) GOTO 220
11643 ENDIF
11644
11645C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
11646 IF(MSTP(64).GE.2) THEN
11647 IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 220
11648 ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z))
11649 IF(ALPRAT.LT.5D0*PYR(0)) GOTO 220
11650 IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0
11651 ENDIF
11652 ENDIF
11653
11654C...Remove kinematically impossible branchings.
11655 UHAT=Q2B-DSH*(1D0-Z)/Z
11656 IF(MSTP(68).GE.0.AND.UHAT.GT.0D0) GOTO 220
11657
11658C...Select phi angle of branching at random.
11659 PHIBR=PARU(2)*PYR(0)
11660
11661C...Matrix-element corrections for some processes.
11662 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11663 IF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
11664 CALL PYMEWT(MECOR,1,Q2B,Z,PHIBR,WTME)
11665 WTZ=WTZ*WTME/WTFF
11666 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.IABS(KFLB).LE.20) THEN
11667 CALL PYMEWT(MECOR,2,Q2B,Z,PHIBR,WTME)
11668 WTZ=WTZ*WTME/WTGF
11669 ELSEIF(IABS(KFLA).LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
11670 CALL PYMEWT(MECOR,3,Q2B,Z,PHIBR,WTME)
11671 WTZ=WTZ*WTME/WTFG
11672 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
11673 CALL PYMEWT(MECOR,4,Q2B,Z,PHIBR,WTME)
11674 WTZ=WTZ*WTME/WTGG
11675 ENDIF
11676 ENDIF
11677
11678C...Impose angular constraint in first branching from interference
11679C...with final state partons.
11680 IF(MCE.EQ.1) THEN
11681 IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN
11682 THE2D=(4D0*Q2B)/(DSH*(1D0-Z))
11683 IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN
11684 IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 220
11685 ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN
11686 IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 220
11687 ENDIF
11688 ENDIF
11689
11690C...Option with angular ordering requirement.
11691 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN
11692 THE2T=(4D0*Z**2*Q2B)/(4D0*Z**2*Q2B+(1D0-Z)*XB**2*VINT(2))
11693 IF(THE2T.GT.THE2(JT)) GOTO 220
11694 ENDIF
11695 ENDIF
11696
11697C...Weighting with new parton distributions.
11698 MINT(105)=MINT(102+JT)
11699 MINT(109)=MINT(106+JT)
11700 VINT(120)=VINT(2+JT)
11701C.... ALICE
11702C.... Store side in MINT(124)
11703 MINT(124)=JT
11704C....
11705 IF(MSTP(57).LE.1) THEN
11706 CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN)
11707 ELSE
11708 CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN)
11709 ENDIF
11710 XFBN=XFN(KFLB)
11711 IF(XFBN.LT.1D-20) THEN
11712 IF(KFLA.EQ.KFLB) THEN
11713 TEVCB=TEVCBS
11714 TEVEB=TEVEBS
11715 WTAPC(KFLB)=0D0
11716 WTAPE(KFLB)=0D0
11717 GOTO 200
11718 ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN
11719 TEVCB=0.5D0*(TEVCBS+TEVCB)
11720 GOTO 230
11721 ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN
11722 TEVEB=0.5D0*(TEVEBS+TEVEB)
11723 GOTO 230
11724 ELSE
11725 XFBN=1D-10
11726 XFN(KFLB)=XFBN
11727 ENDIF
11728 ENDIF
11729 DO 250 KFL=-25,25
11730 XFB(KFL)=XFN(KFL)
11731 250 CONTINUE
11732 XA=XB/Z
11733C.... ALICE
11734C.... Store side in MINT(124)
11735 MINT(124) = JT
11736C....
11737 IF(MSTP(57).LE.1) THEN
11738 CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA)
11739 ELSE
11740 CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA)
11741 ENDIF
11742 XFAN=XFA(KFLA)
11743 IF(XFAN.LT.1D-20) GOTO 200
11744 WTSFA=WTSF(KFLA)
11745 IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 200
11746
11747C...Define two hard scatterers in their CM-frame.
11748 260 IF(N.EQ.NS+2) THEN
11749 DQ2(JT)=Q2B
11750 DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
11751 DO 280 JR=1,2
11752 I=NS+JR
11753 IF(JR.EQ.1) IPO=IPUS1
11754 IF(JR.EQ.2) IPO=IPUS2
11755 DO 270 J=1,5
11756 K(I,J)=0
11757 P(I,J)=0D0
11758 V(I,J)=0D0
11759 270 CONTINUE
11760 K(I,1)=14
11761 K(I,2)=KFLS(JR+2)
11762 K(I,4)=IPO
11763 K(I,5)=IPO
11764 P(I,3)=DPLCM*(-1)**(JR+1)
11765 P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
11766 P(I,5)=-SQRT(DQ2(JR))
11767 K(IPO,1)=14
11768 K(IPO,3)=I
11769 K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
11770 K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
11771 280 CONTINUE
11772
11773C...Find maximum allowed mass of timelike parton.
11774 ELSEIF(N.GT.NS+2) THEN
11775 JR=3-JT
11776 DQ2(3)=Q2B
11777 DPC(1)=P(IS(1),4)
11778 DPC(2)=P(IS(2),4)
11779 DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
11780 DPD(1)=DSH+DQ2(JR)+DQ2(JT)
11781 DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
11782 DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
11783 DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
11784 IKIN=0
11785 IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE.
11786 & 1D-10*DPD(1)) IKIN=1
11787 IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))*
11788 & (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
11789 IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/
11790 & (2D0*DQ2(JR))-DQ2(JT)-DQ2(3)
11791
11792C...Generate timelike parton shower (if required).
11793 IT=N
11794 DO 290 J=1,5
11795 K(IT,J)=0
11796 P(IT,J)=0D0
11797 V(IT,J)=0D0
11798 290 CONTINUE
11799C...f -> f + g (gamma).
11800 IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN
11801 K(IT,2)=21
11802 IF(MCESV(JT).EQ.2.OR.IABS(KFLB).GE.11) K(IT,2)=22
11803C...f -> g (gamma, W+-) + f.
11804 ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN
11805 K(IT,2)=KFLB
11806 IF(KFLS(JT+2).EQ.24) THEN
11807 K(IT,2)=-12
11808 ELSEIF(KFLS(JT+2).EQ.-24) THEN
11809 K(IT,2)=12
11810 ENDIF
11811C...g (gamma) -> f + fbar, g + g.
11812 ELSE
11813 K(IT,2)=-KFLS(JT+2)
11814 IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2)
11815 ENDIF
11816 K(IT,1)=3
11817 IF((IABS(K(IT,2)).GE.11.AND.IABS(K(IT,2)).LE.18).OR.
11818 & IABS(K(IT,2)).EQ.22) K(IT,1)=1
11819 P(IT,5)=PYMASS(K(IT,2))
11820 IF(DMSMA.LE.P(IT,5)**2) GOTO 100
11821 IF(MSTP(63).GE.1.AND.MCESV(JT).EQ.1) THEN
11822 MSTJ48=MSTJ(48)
11823 PARJ85=PARJ(85)
11824 P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
11825 P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
11826 IF(MSTP(63).EQ.1) THEN
11827 Q2TIM=DMSMA
11828 ELSEIF(MSTP(63).EQ.2) THEN
11829 Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT))
11830 ELSE
11831 Q2TIM=DMSMA
11832 MSTJ(48)=1
11833 IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
11834 IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)*
11835 & DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2)
11836 PARJ(85)=SQRT(MAX(0D0,DPT2))*
11837 & (1D0/P(IT,4)+1D0/P(IS(JT),4))
11838 ENDIF
11839 CALL PYSHOW(IT,0,SQRT(Q2TIM))
11840 MSTJ(48)=MSTJ48
11841 PARJ(85)=PARJ85
11842 IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
11843 ENDIF
11844
11845C...Reconstruct kinematics of branching: timelike parton shower.
11846 DMS=P(IT,5)**2
11847 IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
11848 IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+
11849 & 0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/
11850 & (4D0*DSH*DPC(3)**2)
11851 IF(DPT2.LT.0D0) GOTO 100
11852 DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
11853 & DSHR)/DPC(3)-DPC(3)
11854 P(IT,1)=SQRT(DPT2)
11855 P(IT,3)=DPB(1)*(-1)**(JT+1)
11856 P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS)
11857 IF(N.GE.IT+1) THEN
11858 DPB(1)=SQRT(DPB(1)**2+DPT2)
11859 DPB(2)=SQRT(DPB(1)**2+DMS)
11860 DPB(3)=P(IT+1,3)
11861 DPB(4)=SQRT(DPB(3)**2+DMS)
11862 DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
11863 & DPB(1))
11864 CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ)
11865 THE=PYANGL(P(IT,3),P(IT,1))
11866 CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0)
11867 ENDIF
11868
11869C...Reconstruct kinematics of branching: spacelike parton.
11870 DO 300 J=1,5
11871 K(N+1,J)=0
11872 P(N+1,J)=0D0
11873 V(N+1,J)=0D0
11874 300 CONTINUE
11875 K(N+1,1)=14
11876 K(N+1,2)=KFLB
11877 P(N+1,1)=P(IT,1)
11878 P(N+1,3)=P(IT,3)+P(IS(JT),3)
11879 P(N+1,4)=P(IT,4)+P(IS(JT),4)
11880 P(N+1,5)=-SQRT(DQ2(3))
11881
11882C...Define colour flow of branching.
11883 K(IS(JT),3)=N+1
11884 K(IT,3)=N+1
11885 IM1=N+1
11886 IM2=N+1
11887C...f -> f + gamma (Z, W).
11888 IF(IABS(K(IT,2)).GE.22) THEN
11889 K(IT,1)=1
11890 ID1=IS(JT)
11891 ID2=IS(JT)
11892C...f -> gamma (Z, W) + f.
11893 ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN
11894 ID1=IT
11895 ID2=IT
11896C...gamma -> q + qbar, g + g.
11897 ELSEIF(K(N+1,2).EQ.22) THEN
11898 ID1=IS(JT)
11899 ID2=IT
11900 IM1=ID2
11901 IM2=ID1
11902C...q -> q + g.
11903 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN
11904 ID1=IT
11905 ID2=IS(JT)
11906C...q -> g + q.
11907 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN
11908 ID1=IS(JT)
11909 ID2=IT
11910C...qbar -> qbar + g.
11911 ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN
11912 ID1=IS(JT)
11913 ID2=IT
11914C...qbar -> g + qbar.
11915 ELSEIF(K(N+1,2).LT.0) THEN
11916 ID1=IT
11917 ID2=IS(JT)
11918C...g -> g + g; g -> q + qbar.
11919 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
11920 ID1=IS(JT)
11921 ID2=IT
11922 ELSE
11923 ID1=IT
11924 ID2=IS(JT)
11925 ENDIF
11926 IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1
11927 IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2
11928 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
11929 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
11930 IF(ID1.NE.ID2) THEN
11931 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
11932 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
11933 ENDIF
11934 N=N+1
11935 IF(K(IT,1).EQ.1) THEN
11936 K(IT,4)=0
11937 K(IT,5)=0
11938 ENDIF
11939
11940C...Boost to new CM-frame.
11941 DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4))
11942 DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4))
11943 IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100
11944 CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ)
11945 IR=N+(JT-1)*(IS(1)-N)
11946 CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),DPHI(JT),
11947 & 0D0,0D0,0D0)
11948 ENDIF
11949
11950C...Update kinematics variables.
11951 IS(JT)=N
11952 DQ2(JT)=Q2B
11953 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THE2(JT)=THE2T
11954 DSH=DSHZ
11955
11956C...Save quantities; loop back.
11957 Q2S(JT)=Q2B
11958 DPHI(JT)=PHIBR
11959 MCESV(JT)=MCE
11960 IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR.
11961 &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN
11962 KFLS(JT+2)=KFLS(JT)
11963 KFLS(JT)=KFLA
11964 XS(JT)=XA
11965 ZS(JT)=Z
11966 DO 310 KFL=-25,25
11967 XFS(JT,KFL)=XFA(KFL)
11968 310 CONTINUE
11969 TEVCSV(JT)=TEVCB
11970 TEVESV(JT)=TEVEB
11971 ELSE
11972 MORE(JT)=0
11973 IF(JT.EQ.1) IPU1=N
11974 IF(JT.EQ.2) IPU2=N
11975 ENDIF
11976 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
11977 CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS')
11978 IF(MSTU(21).GE.1) N=NS
11979 IF(MSTU(21).GE.1) RETURN
11980 ENDIF
11981 IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150
11982
11983C...Boost hard scattering partons to frame of shower initiators.
11984 DO 320 J=1,3
11985 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
11986 320 CONTINUE
11987 K(N+2,1)=1
11988 DO 330 J=1,5
11989 P(N+2,J)=P(NS+1,J)
11990 330 CONTINUE
11991 CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5))
11992 ROBO(2)=PYANGL(P(N+2,1),P(N+2,2))
11993 ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
11994 CALL PYROBO(MINT(83)+5,NS,0D0,-ROBO(2),0D0,0D0,0D0)
11995 CALL PYROBO(MINT(83)+5,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),
11996 &ROBO(5))
11997
11998C...Store user information. Reset Lambda value.
11999 K(IPU1,3)=MINT(83)+3
12000 K(IPU2,3)=MINT(83)+4
12001 DO 340 JT=1,2
12002 MINT(12+JT)=KFLS(JT)
12003 VINT(140+JT)=XS(JT)
12004 IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT)
12005 340 CONTINUE
12006 PARU(112)=ALAMS
12007
12008 RETURN
12009 END
12010
12011C*********************************************************************
12012
12013C...PYMEMX
12014C...Generates maximum ME weight in some initial-state showers.
12015C...Inparameter MECOR: kind of hard scattering process
12016C...Outparameter WTFF: maximum weight for fermion -> fermion
12017C... WTGF: maximum weight for gluon/photon -> fermion
12018C... WTFG: maximum weight for fermion -> gluon/photon
12019C... WTGG: maximum weight for gluon -> gluon
12020
12021 SUBROUTINE PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
12022
12023C...Double precision and integer declarations.
12024 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12025 IMPLICIT INTEGER(I-N)
12026 INTEGER PYK,PYCHGE,PYCOMP
12027C...Commonblocks.
12028 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12029 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12030 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12031 COMMON/PYINT1/MINT(400),VINT(400)
12032 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
12033 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
12034
12035C...Default maximum weight.
12036 WTFF=1D0
12037 WTGF=1D0
12038 WTFG=1D0
12039 WTGG=1D0
12040
12041C...Select maximum weight by process.
12042 IF(MECOR.EQ.1) THEN
12043 WTFF=1D0
12044 WTGF=3D0
12045 ELSEIF(MECOR.EQ.2) THEN
12046 WTFG=1D0
12047 WTGG=1D0
12048 ENDIF
12049
12050 RETURN
12051 END
12052
12053C*********************************************************************
12054
12055C...PYMEWT
12056C...Calculates actual ME weight in some initial-state showers.
12057C...Inparameter MECOR: kind of hard scattering process
12058C... IFLCB: flavour combination of branching,
12059C... 1 for fermion -> fermion,
12060C... 2 for gluon/photon -> fermion
12061C... 3 for fermion -> gluon/photon,
12062C... 4 for gluon -> gluon
12063C... Q2: Q2 value of shower branching
12064C... Z: Z value of branching
12065C...In+outparameter PHIBR: azimuthal angle of branching
12066C...Outparameter WTME: actual ME weight
12067
12068 SUBROUTINE PYMEWT(MECOR,IFLCB,Q2,Z,PHIBR,WTME)
12069
12070C...Double precision and integer declarations.
12071 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12072 IMPLICIT INTEGER(I-N)
12073 INTEGER PYK,PYCHGE,PYCOMP
12074C...Commonblocks.
12075 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12076 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12077 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12078 COMMON/PYINT1/MINT(400),VINT(400)
12079 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
12080 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
12081
12082C...Default output.
12083 WTME=1D0
12084
12085C...Define kinematics of shower branching in Mandelstam variables.
12086 SQM=VINT(44)
12087 SH=SQM/Z
12088 TH=-Q2
12089 UH=Q2-SQM*(1D0-Z)/Z
12090
12091C...Matrix-element corrections for f + fbar -> s-channel vector boson.
12092 IF(MECOR.EQ.1) THEN
12093 IF(IFLCB.EQ.1) THEN
12094 WTME=(TH**2+UH**2+2D0*SQM*SH)/(SH**2+SQM**2)
12095 ELSEIF(IFLCB.EQ.2) THEN
12096 WTME=(SH**2+UH**2+2D0*SQM*TH)/((SH-SQM)**2+SQM**2)
12097 ENDIF
12098
12099C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0).
12100 ELSEIF(MECOR.EQ.2) THEN
12101 IF(IFLCB.EQ.3) THEN
12102 WTME=(SH**2+UH**2)/(SH**2+(SH-SQM)**2)
12103 ELSEIF(IFLCB.EQ.4) THEN
12104 WTME=0.5D0*(SH**4+UH**4+TH**4+SQM**4)/(SH**2-SQM*(SH-SQM))**2
12105 ENDIF
12106 ENDIF
12107
12108 RETURN
12109 END
12110
12111C*********************************************************************
12112
12113C...PYADSH
12114C...Administers the generation of successive final-state showers
12115C...in external processes.
12116
12117 SUBROUTINE PYADSH(NFIN)
12118
12119C...Double precision and integer declarations.
12120 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12121 IMPLICIT INTEGER(I-N)
12122 INTEGER PYK,PYCHGE,PYCOMP
12123C...Commonblocks.
12124 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12125 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12126 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12127 COMMON/PYINT1/MINT(400),VINT(400)
12128 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
12129C...Local array.
12130 DIMENSION IBEG(100),KSAV(10,5),IORD(10),PSUM(4),BETA(3)
12131
12132C...Set primary vertex.
12133 DO 100 J=1,5
12134 V(MINT(83)+5,J)=0D0
12135 V(MINT(83)+6,J)=0D0
12136 V(MINT(84)+1,J)=0D0
12137 V(MINT(84)+2,J)=0D0
12138 100 CONTINUE
12139
12140C...Isolate systems of particles with the same mother.
12141 NSYS=0
12142 IMS=-1
12143 DO 140 I=MINT(84)+3,NFIN
12144 IM=K(I,3)
12145 IF(IM.GT.0.AND.IM.LE.MINT(84)) IM=K(IM,3)
12146 IF(IM.NE.IMS) THEN
12147 NSYS=NSYS+1
12148 IBEG(NSYS)=I
12149 IMS=IM
12150 ENDIF
12151
12152C...Set production vertices.
12153 IF(IM.LE.MINT(83)+6.OR.(IM.GT.MINT(84).AND.IM.LE.MINT(84)+2))
12154 & THEN
12155 DO 110 J=1,4
12156 V(I,J)=0D0
12157 110 CONTINUE
12158 ELSE
12159 DO 120 J=1,4
12160 V(I,J)=V(IM,J)+V(IM,5)*P(IM,J)/P(IM,5)
12161 120 CONTINUE
12162 ENDIF
12163 IF(MSTP(125).GE.1) THEN
12164 IDOC=I-MSTP(126)+4
12165 DO 130 J=1,5
12166 V(IDOC,J)=V(I,J)
12167 130 CONTINUE
12168 ENDIF
12169 140 CONTINUE
12170
12171C...End loop over systems. Return if no showers to be performed.
12172 IBEG(NSYS+1)=NFIN+1
12173 IF(MSTP(71).LE.0) RETURN
12174
12175C...Loop through systems of particles; check that sensible size.
12176 DO 260 ISYS=1,NSYS
12177 NSIZ=IBEG(ISYS+1)-IBEG(ISYS)
12178 IF(NSIZ.EQ.1.AND.ISYS.EQ.1) THEN
12179 ELSEIF(NSIZ.LE.1) THEN
12180 CALL PYERRM(2,'(PYADSH:) only one particle in system')
12181 ELSEIF(NSIZ.GT.7) THEN
12182 CALL PYERRM(2,'(PYADSH:) more than seven particles in system')
12183 ELSE
12184
12185C...Save status codes and daughters of showering pair; reset them.
12186 DO 150 J=1,4
12187 PSUM(J)=0D0
12188 150 CONTINUE
12189 DO 170 II=1,NSIZ
12190 I=IBEG(ISYS)-1+II
12191 KSAV(II,1)=K(I,1)
12192 IF(K(I,1).GT.10) THEN
12193 K(I,1)=1
12194 IF(KSAV(II,1).EQ.14) K(I,1)=3
12195 ENDIF
12196 IF(KSAV(II,1).LE.10) THEN
12197 ELSEIF(K(I,1).EQ.1) THEN
12198 KSAV(II,4)=K(I,4)
12199 KSAV(II,5)=K(I,5)
12200 K(I,4)=0
12201 K(I,5)=0
12202 ELSE
12203 KSAV(II,4)=MOD(K(I,4),MSTU(5))
12204 KSAV(II,5)=MOD(K(I,5),MSTU(5))
12205 K(I,4)=K(I,4)-KSAV(II,4)
12206 K(I,5)=K(I,5)-KSAV(II,5)
12207 ENDIF
12208 DO 160 J=1,4
12209 PSUM(J)=PSUM(J)+P(I,J)
12210 160 CONTINUE
12211 170 CONTINUE
12212
12213C...Perform shower.
12214 QMAX=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
12215 & PSUM(3)**2))
12216 IF(ISYS.EQ.1) QMAX=MIN(QMAX,SQRT(PARP(71))*VINT(55))
12217 NSAV=N
12218 IF(NSIZ.EQ.2) THEN
12219 CALL PYSHOW(IBEG(ISYS),IBEG(ISYS)+1,QMAX)
12220 ELSE
12221 CALL PYSHOW(IBEG(ISYS),-NSIZ,QMAX)
12222 ENDIF
12223
12224C...Look up showered copies of original showering particles.
12225 DO 250 II=1,NSIZ
12226 I=IBEG(ISYS)-1+II
12227 IMV=I
12228 IF(N.EQ.NSAV.OR.K(I,1).LE.10) THEN
12229 ELSEIF(K(I,1).EQ.11) THEN
12230 180 IMV=MOD(K(IMV,4),MSTU(5))
12231 IF(K(IMV,1).EQ.11) GOTO 180
12232 ELSE
12233 KDA1=MOD(K(I,4),MSTU(5))
12234 KDA2=MOD(K(I,5),MSTU(5))
12235 DO 190 I3=I+1,N
12236 IF(K(I3,2).EQ.K(I,2).AND.(I3.EQ.KDA1.OR.I3.EQ.KDA2))
12237 & THEN
12238 IMV=I3
12239 KDA1=MOD(K(I3,4),MSTU(5))
12240 KDA2=MOD(K(I3,5),MSTU(5))
12241 ENDIF
12242 190 CONTINUE
12243 ENDIF
12244
12245C...Restore daughter info of original partons to showered copies.
12246 IF(KSAV(II,1).GT.10) K(IMV,1)=KSAV(II,1)
12247 IF(KSAV(II,1).LE.10) THEN
12248 ELSEIF(K(I,1).EQ.1) THEN
12249 K(IMV,4)=KSAV(II,4)
12250 K(IMV,5)=KSAV(II,5)
12251 ELSE
12252 K(IMV,4)=K(IMV,4)+KSAV(II,4)
12253 K(IMV,5)=K(IMV,5)+KSAV(II,5)
12254 ENDIF
12255
12256C...Reset mother info of existing daughters to showered copies.
12257 DO 200 I3=IBEG(ISYS+1),NFIN
12258 IF(K(I3,3).EQ.I) K(I3,3)=IMV
12259 IF(K(I3,1).EQ.3.OR.K(I3,1).EQ.14) THEN
12260 IF(K(I3,4)/MSTU(5).EQ.I) K(I3,4)=K(I3,4)+MSTU(5)*(IMV-I)
12261 IF(K(I3,5)/MSTU(5).EQ.I) K(I3,5)=K(I3,5)+MSTU(5)*(IMV-I)
12262 ENDIF
12263 200 CONTINUE
12264
12265C...Boost all original daughters to new frame of showered copy.
12266 IF(IMV.NE.I) THEN
12267 DO 210 J=1,3
12268 BETA(J)=(P(IMV,J)-P(I,J))/(P(IMV,4)+P(I,4))
12269 210 CONTINUE
12270 FAC=2D0/(1D0+BETA(1)**2+BETA(2)**2+BETA(3)**2)
12271 DO 220 J=1,3
12272 BETA(J)=FAC*BETA(J)
12273 220 CONTINUE
12274 DO 240 I3=IBEG(ISYS+1),NFIN
12275 IMO=I3
12276 230 IMO=K(IMO,3)
12277 IF(MSTP(128).LE.0) THEN
12278 IF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) GOTO 230
12279 IF(IMO.EQ.I.OR.(K(I,3).LE.MINT(84).AND.IMO.EQ.K(I,3)))
12280 & CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
12281 ELSE
12282 IF(IMO.EQ.IMV) THEN
12283 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
12284 ELSEIF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) THEN
12285 GOTO 230
12286 ENDIF
12287 ENDIF
12288 240 CONTINUE
12289 ENDIF
12290 250 CONTINUE
12291
12292C...End of loop over showering systems
12293 ENDIF
12294 260 CONTINUE
12295
12296 RETURN
12297 END
12298
12299C*********************************************************************
12300
12301C...PYRESD
12302C...Allows resonances to decay (including parton showers for hadronic
12303C...channels).
12304
12305 SUBROUTINE PYRESD(IRES)
12306
12307C...Double precision and integer declarations.
12308 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12309 IMPLICIT INTEGER(I-N)
12310 INTEGER PYK,PYCHGE,PYCOMP
12311C...Parameter statement to help give large particle numbers.
12312 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
12313 &KEXCIT=4000000,KDIMEN=5000000)
12314C...Commonblocks.
12315 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12316 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12317 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
12318 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
12319 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
12320 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12321 COMMON/PYINT1/MINT(400),VINT(400)
12322 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
12323 COMMON/PYINT4/MWID(500),WIDS(500,5)
12324 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
12325 &/PYINT1/,/PYINT2/,/PYINT4/
12326C...Local arrays and complex and character variables.
12327 DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
12328 &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(3),ILIN(6),
12329 &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3),
12330 &PHI(3),WDTP(0:400),WDTE(0:400,0:5),DPMO(5),XM(5),VDCY(4),
12331 &ITJUNC(3),CTM2(3)
12332 COMPLEX FGK,HA(6,6),HC(6,6)
12333 REAL TIR,UIR
12334 CHARACTER CODE*9,MASS*9
12335
12336C...The F, Xi and Xj functions of Gunion and Kunszt
12337C...(Phys. Rev. D33, 665, plus errata from the authors).
12338 FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
12339 &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
12340 DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/
12341 &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34))
12342 DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU-
12343 &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+
12344 &2D0*(D34/D56+D56/D34))
12345
12346C...Some general constants.
12347 XW=PARU(102)
12348 XWV=XW
12349 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
12350 XW1=1D0-XW
12351 SQMZ=PMAS(23,1)**2
12352
12353 GMMZ=PMAS(23,1)*PMAS(23,2)
12354 SQMW=PMAS(24,1)**2
12355 GMMW=PMAS(24,1)*PMAS(24,2)
12356 SH=VINT(44)
12357
12358C...Boost and rotate to rest frame of incoming partons,
12359C...to get proper amount of smearing of decay angles.
12360 IBST=0
12361 IF(IRES.EQ.0) THEN
12362 IBST=1
12363 ETOTIN=P(MINT(84)+1,4)+P(MINT(84)+2,4)
12364 BEXIN=(P(MINT(84)+1,1)+P(MINT(84)+2,1))/ETOTIN
12365 BEYIN=(P(MINT(84)+1,2)+P(MINT(84)+2,2))/ETOTIN
12366 BEZIN=(P(MINT(84)+1,3)+P(MINT(84)+2,3))/ETOTIN
12367 CALL PYROBO(MINT(83)+7,N,0D0,0D0,-BEXIN,-BEYIN,-BEZIN)
12368 PHIIN=PYANGL(P(MINT(84)+1,1),P(MINT(84)+1,2))
12369 CALL PYROBO(MINT(83)+7,N,0D0,-PHIIN,0D0,0D0,0D0)
12370 THEIN=PYANGL(P(MINT(84)+1,3),P(MINT(84)+1,1))
12371 CALL PYROBO(MINT(83)+7,N,-THEIN,0D0,0D0,0D0,0D0)
12372 ENDIF
12373
12374C...Reset original resonance configuration.
12375 DO 100 JT=1,8
12376 IREF(1,JT)=0
12377 100 CONTINUE
12378
12379C...Define initial one, two or three objects for subprocess.
12380 IHDEC=0
12381 IF(IRES.EQ.0) THEN
12382 ISUB=MINT(1)
12383 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
12384 IREF(1,1)=MINT(84)+2+ISET(ISUB)
12385 IREF(1,4)=MINT(83)+6+ISET(ISUB)
12386 JTMAX=1
12387 ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
12388 IREF(1,1)=MINT(84)+1+ISET(ISUB)
12389 IREF(1,2)=MINT(84)+2+ISET(ISUB)
12390 IREF(1,4)=MINT(83)+5+ISET(ISUB)
12391 IREF(1,5)=MINT(83)+6+ISET(ISUB)
12392 JTMAX=2
12393 ELSEIF(ISET(ISUB).EQ.5) THEN
12394 IREF(1,1)=MINT(84)+3
12395 IREF(1,2)=MINT(84)+4
12396 IREF(1,3)=MINT(84)+5
12397 IREF(1,4)=MINT(83)+7
12398 IREF(1,5)=MINT(83)+8
12399 IREF(1,6)=MINT(83)+9
12400 JTMAX=3
12401 ENDIF
12402
12403C...Define original resonance for odd cases.
12404 ELSE
12405 ISUB=0
12406 IF(K(IRES,2).EQ.25.OR.K(IRES,2).EQ.35.OR.K(IRES,2).EQ.36)
12407 & IHDEC=1
12408 IF(IHDEC.EQ.1) ISUB=3
12409 IREF(1,1)=IRES
12410 IREF(1,4)=K(IRES,3)
12411 JTMAX=1
12412 ENDIF
12413
12414C...Check if initial resonance has been moved (in resonance + jet).
12415 DO 120 JT=1,3
12416 IF(IREF(1,JT).GT.0) THEN
12417 IF(K(IREF(1,JT),1).GT.10) THEN
12418 KFA=IABS(K(IREF(1,JT),2))
12419 IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN
12420 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
12421 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
12422 DO 110 I=IREF(1,JT)+1,N
12423 IF(K(I,2).EQ.K(IREF(1,JT),2).AND.(I.EQ.KDA1.OR.
12424 & I.EQ.KDA2)) THEN
12425 IREF(1,JT)=I
12426 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
12427 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
12428 ENDIF
12429 110 CONTINUE
12430 ELSE
12431 KDA=MOD(K(IREF(1,JT),4),MSTU(5))
12432 IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA
12433 ENDIF
12434 ENDIF
12435 ENDIF
12436 120 CONTINUE
12437
12438C.....Set decay vertex for initial resonances
12439 DO 140 JT=1,JTMAX
12440 DO 130 I=1,4
12441 V(IREF(1,JT),I)=0D0
12442 130 CONTINUE
12443 140 CONTINUE
12444
12445C...Loop over decay history.
12446 NP=1
12447 IP=0
12448 150 IP=IP+1
12449 NINH=0
12450 JTMAX=2
12451 IF(IREF(IP,2).EQ.0) JTMAX=1
12452 IF(IREF(IP,3).NE.0) JTMAX=3
12453 IT4=0
12454 NSAV=N
12455
12456C...Check for Higgs which appears as decay product of user-process.
12457 IF(ISUB.EQ.0) THEN
12458 IHDEC=0
12459 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
12460 & .EQ.36) IHDEC=1
12461 IF(IHDEC.EQ.1) ISUB=3
12462 ENDIF
12463
12464C...Start treatment of one, two or three resonances in parallel.
12465 160 N=NSAV
12466 DO 320 JT=1,JTMAX
12467 ID=IREF(IP,JT)
12468 KDCY(JT)=0
12469 KFL1(JT)=0
12470 KFL2(JT)=0
12471 KFL3(JT)=0
12472 KEQL(JT)=0
12473 NSD(JT)=ID
12474 ITJUNC(JT)=0
12475
12476C...Check whether particle can/is allowed to decay.
12477 IF(ID.EQ.0) GOTO 310
12478 KFA=IABS(K(ID,2))
12479 KCA=PYCOMP(KFA)
12480 IF(MWID(KCA).EQ.0) GOTO 310
12481 IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 310
12482 IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR.
12483 & KFA.EQ.18) IT4=IT4+1
12484 K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5))
12485 K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5))
12486
12487C...Choose lifetime and determine decay vertex.
12488 IF(K(ID,1).EQ.5) THEN
12489 V(ID,5)=0D0
12490 ELSEIF(K(ID,1).NE.4) THEN
12491 V(ID,5)=-PMAS(KCA,4)*LOG(PYR(0))
12492 ENDIF
12493 DO 170 J=1,4
12494 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
12495 170 CONTINUE
12496
12497C...Determine whether decay allowed or not.
12498 MOUT=0
12499 IF(MSTJ(22).EQ.2) THEN
12500 IF(PMAS(KCA,4).GT.PARJ(71)) MOUT=1
12501 ELSEIF(MSTJ(22).EQ.3) THEN
12502 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
12503 ELSEIF(MSTJ(22).EQ.4) THEN
12504 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
12505 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
12506 ENDIF
12507 IF(MOUT.EQ.1.AND.K(ID,1).NE.5) THEN
12508 K(ID,1)=4
12509 GOTO 310
12510 ENDIF
12511
12512C...Info for selection of decay channel: sign, pairings.
12513 IF(KCHG(KCA,3).EQ.0) THEN
12514 IPM=2
12515 ELSE
12516 IPM=(5-ISIGN(1,K(ID,2)))/2
12517 ENDIF
12518 KFB=0
12519 IF(JTMAX.EQ.2) THEN
12520 KFB=IABS(K(IREF(IP,3-JT),2))
12521 ELSEIF(JTMAX.EQ.3) THEN
12522 JT2=JT+1-3*(JT/3)
12523 KFB=IABS(K(IREF(IP,JT2),2))
12524 IF(KFB.NE.KFA) THEN
12525 JT2=JT+2-3*((JT+1)/3)
12526 KFB=IABS(K(IREF(IP,JT2),2))
12527 ENDIF
12528 ENDIF
12529
12530C...Select decay channel.
12531 IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.
12532 & ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1
12533 CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE)
12534 WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4)
12535 IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5)
12536 IF(WDTE0S.LE.0D0) GOTO 310
12537 RKFL=WDTE0S*PYR(0)
12538 IDL=0
12539 180 IDL=IDL+1
12540 IDC=IDL+MDCY(KCA,2)-1
12541 RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4))
12542 IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5)
12543 IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 180
12544
12545C...Read out flavours and colour charges of decay channel chosen.
12546 KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2))
12547 IF(KCQM(JT).EQ.-2) KCQM(JT)=2
12548 KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
12549 KFC1A=PYCOMP(IABS(KFL1(JT)))
12550 IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT))
12551 KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT))
12552 IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2
12553 KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
12554 KFC2A=PYCOMP(IABS(KFL2(JT)))
12555 IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT))
12556 KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT))
12557 IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2
12558 KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2))
12559 KCQ3(JT)=0
12560 IF(KFL3(JT).NE.0) THEN
12561 KFC3A=PYCOMP(IABS(KFL3(JT)))
12562 IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT))
12563 KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT))
12564 IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2
12565 ENDIF
12566
12567C...Set/save further info on channel.
12568 KDCY(JT)=1
12569 IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1)
12570 NSD(JT)=N
12571 HGZ(JT,1)=VINT(111)
12572 HGZ(JT,2)=VINT(112)
12573 HGZ(JT,3)=VINT(114)
12574 JTZ=JT
12575
12576C...Select masses; to begin with assume resonances narrow.
12577 DO 200 I=1,3
12578 P(N+I,5)=0D0
12579 PMMN(I)=0D0
12580 IF(I.EQ.1) THEN
12581 KFLW=IABS(KFL1(JT))
12582 KCW=KFC1A
12583 ELSEIF(I.EQ.2) THEN
12584 KFLW=IABS(KFL2(JT))
12585 KCW=KFC2A
12586 ELSEIF(I.EQ.3) THEN
12587 IF(KFL3(JT).EQ.0) GOTO 200
12588 KFLW=IABS(KFL3(JT))
12589 KCW=KFC3A
12590 ENDIF
12591 P(N+I,5)=PMAS(KCW,1)
12592CMRENNA++
12593C...This prevents SUSY/t particles from becoming too light.
12594 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
12595 PMMN(I)=PMAS(KCW,1)
12596 DO 190 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
12597 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
12598 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
12599 & PMAS(PYCOMP(KFDP(IDC,2)),1)
12600 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
12601 & PMAS(PYCOMP(KFDP(IDC,3)),1)
12602 PMMN(I)=MIN(PMMN(I),PMSUM)
12603 ENDIF
12604 190 CONTINUE
12605CMRENNA--
12606 ELSEIF(KFLW.EQ.6) THEN
12607 PMMN(I)=PMAS(24,1)+PMAS(5,1)
12608 ENDIF
12609 200 CONTINUE
12610
12611C...Check which two out of three are widest.
12612 IWID1=1
12613 IWID2=2
12614 PWID1=PMAS(KFC1A,2)
12615 PWID2=PMAS(KFC2A,2)
12616 KFLW1=IABS(KFL1(JT))
12617 KFLW2=IABS(KFL2(JT))
12618 IF(KFL3(JT).NE.0) THEN
12619 PWID3=PMAS(KFC3A,2)
12620 IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN
12621 IWID1=3
12622 PWID1=PWID3
12623 KFLW1=IABS(KFL3(JT))
12624 ELSEIF(PWID3.GT.PWID2) THEN
12625 IWID2=3
12626 PWID2=PWID3
12627 KFLW2=IABS(KFL3(JT))
12628 ENDIF
12629 ENDIF
12630
12631C...If all narrow then only check that masses consistent.
12632 IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND.
12633 & PWID2.LT.PARP(41))) THEN
12634CMRENNA++
12635C....Handle near degeneracy cases.
12636 IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN
12637 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
12638 P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0
12639 IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0
12640 ENDIF
12641 ENDIF
12642CMRENNA--
12643 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
12644 CALL PYERRM(13,'(PYRESD:) daughter masses too large')
12645 MINT(51)=1
12646 GOTO 700
12647 ELSEIF(P(N+1,5)+P(N+2,5)+P(N+3,5)+PARJ(64).GT.P(ID,5)) THEN
12648 CALL PYERRM(3,'(PYRESD:) daughter masses too large')
12649 MINT(51)=1
12650 GOTO 700
12651 ENDIF
12652
12653C...For three wide resonances select narrower of three
12654C...according to BW decoupled from rest.
12655 ELSE
12656 PMTOT=P(ID,5)
12657 IF(KFL3(JT).NE.0) THEN
12658 IWID3=6-IWID1-IWID2
12659 KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))-
12660 & KFLW1-KFLW2
12661 LOOP=0
12662 210 LOOP=LOOP+1
12663 P(N+IWID3,5)=PYMASS(KFLW3)
12664 IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 210
12665 PMTOT=PMTOT-P(N+IWID3,5)
12666 ENDIF
12667C...Select other two correlated within remaining phase space.
12668 IF(IP.EQ.1) THEN
12669 CKIN45=CKIN(45)
12670 CKIN47=CKIN(47)
12671 CKIN(45)=MAX(PMMN(IWID1),CKIN(45))
12672 CKIN(47)=MAX(PMMN(IWID2),CKIN(47))
12673 CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
12674 & P(N+IWID2,5))
12675 CKIN(45)=CKIN45
12676 CKIN(47)=CKIN47
12677 ELSE
12678 CKIN(49)=PMMN(IWID1)
12679 CKIN(50)=PMMN(IWID2)
12680 CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
12681 & P(N+IWID2,5))
12682 CKIN(49)=0D0
12683 CKIN(50)=0D0
12684 ENDIF
12685 IF(MINT(51).EQ.1) GOTO 700
12686 ENDIF
12687
12688C...Begin fill decay products, with colour flow for coloured objects.
12689 MSTU10=MSTU(10)
12690 MSTU(10)=1
12691 MSTU(19)=1
12692
12693CMRENNA++
12694C...1) Three-body decays of SUSY particles (plus special case top).
12695 IF(KFL3(JT).NE.0) THEN
12696 DO 230 I=N+1,N+3
12697 DO 220 J=1,5
12698 K(I,J)=0
12699 V(I,J)=0D0
12700 220 CONTINUE
12701 230 CONTINUE
12702 K(N+1,1)=1
12703 K(N+1,2)=KFL1(JT)
12704 K(N+2,1)=1
12705 K(N+2,2)=KFL2(JT)
12706 K(N+3,1)=1
12707 K(N+3,2)=KFL3(JT)
12708 IDIN=ID
12709 CALL PYTBDY(IDIN)
12710
12711C...Set colour flow for t -> W + b + Z.
12712 IF(KFA.EQ.6) THEN
12713 K(N+2,1)=3
12714 ISID=4
12715 IF(KCQM(JT).EQ.-1) ISID=5
12716 IDAU=N+2
12717 K(ID,ISID)=K(ID,ISID)+IDAU
12718 K(IDAU,ISID)=MSTU(5)*ID
12719
12720C...Set colour flow in three-body decays - programmed as special cases.
12721 ELSEIF(KFC2A.LE.6) THEN
12722 K(N+2,1)=3
12723 K(N+3,1)=3
12724 ISID=4
12725 IF(KFL2(JT).LT.0) ISID=5
12726 K(N+2,ISID)=MSTU(5)*(N+3)
12727 K(N+3,9-ISID)=MSTU(5)*(N+2)
12728 ENDIF
12729 IF(KFL1(JT).EQ.KSUSY1+21) THEN
12730 K(N+1,1)=3
12731 K(N+2,1)=3
12732 K(N+3,1)=3
12733 ISID=4
12734 IF(KFL2(JT).LT.0) ISID=5
12735 K(N+1,ISID)=MSTU(5)*(N+2)
12736 K(N+1,9-ISID)=MSTU(5)*(N+3)
12737 K(N+2,ISID)=MSTU(5)*(N+1)
12738 K(N+3,9-ISID)=MSTU(5)*(N+1)
12739 ENDIF
12740 IF(KFA.EQ.KSUSY1+21) THEN
12741 K(N+2,1)=3
12742 K(N+3,1)=3
12743 ISID=4
12744 IF(KFL2(JT).LT.0) ISID=5
12745 K(ID,ISID)=K(ID,ISID)+(N+2)
12746 K(ID,9-ISID)=K(ID,9-ISID)+(N+3)
12747 K(N+2,ISID)=MSTU(5)*ID
12748 K(N+3,9-ISID)=MSTU(5)*ID
12749 ENDIF
12750CMRENNA--
12751
12752 IF(KFA.GE.KSUSY1+22.AND.KFA.LE.KSUSY1+37.AND.
12753 & IABS(KCQ2(JT)).EQ.1) THEN
12754 K(N+2,1)=3
12755 K(N+3,1)=3
12756 ISID=4
12757 IF(KFL2(JT).LT.0) ISID=5
12758 K(N+2,ISID)=MSTU(5)*(N+3)
12759 K(N+3,9-ISID)=MSTU(5)*(N+2)
12760 ENDIF
12761
12762C...Set colour flow in three-body decays with baryon number violation.
12763C...Neutralino and chargino decays first.
12764 KCQSUM=KCQ1(JT)+KCQ2(JT)+KCQ3(JT)
12765 IF(KCQM(JT).EQ.0.AND.IABS(KCQSUM).EQ.3) THEN
12766 ITJUNC(JT)=(1+(1-KCQ1(JT))/2)
12767 K(N+4,4)=ITJUNC(JT)*MSTU(5)
12768C...Insert junction to keep track of colours.
12769 IF(KCQ1(JT).NE.0) K(N+1,1)=3
12770 IF(KCQ2(JT).NE.0) K(N+2,1)=3
12771 IF(KCQ3(JT).NE.0) K(N+3,1)=3
12772C...Set special junction codes:
12773 K(N+4,1)=42
12774 K(N+4,2)=88
12775
12776C...Order decay products by invariant mass. (will be used in PYSTRF).
12777 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)-
12778 & P(N+1,3)*P(N+2,3)
12779 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)-
12780 & P(N+1,3)*P(N+3,3)
12781 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)-
12782 & P(N+2,3)*P(N+3,3)
12783 IF(PM12.LT.PM13.AND.PM12.LT.PM23) THEN
12784 K(N+4,4)=N+3+K(N+4,4)
12785 K(N+4,5)=N+1+MSTU(5)*(N+2)
12786 ELSEIF(PM13.LT.PM23) THEN
12787 K(N+4,4)=N+2+K(N+4,4)
12788 K(N+4,5)=N+1+MSTU(5)*(N+3)
12789 ELSE
12790 K(N+4,4)=N+1+K(N+4,4)
12791 K(N+4,5)=N+2+MSTU(5)*(N+3)
12792 ENDIF
12793 DO 240 J=1,5
12794 P(N+4,J)=0D0
12795 V(N+4,J)=0D0
12796 240 CONTINUE
12797C...Connect daughters to junction.
12798 DO 250 II=N+1,N+3
12799 K(II,4)=0
12800 K(II,5)=0
12801 K(II,ITJUNC(JT)+3)=MSTU(5)*(N+4)
12802 250 CONTINUE
12803C...Particle counter should be stepped up one extra for junction.
12804 N=N+1
12805
12806C...Gluino decays.
12807 ELSEIF (KCQM(JT).EQ.2.AND.IABS(KCQSUM).EQ.3) THEN
12808 ITJUNC(JT)=(5+(1-KCQ1(JT))/2)
12809 K(N+4,4)=ITJUNC(JT)*MSTU(5)
12810C...Insert junction to keep track of colours.
12811 IF(KCQ1(JT).NE.0) K(N+1,1)=3
12812 IF(KCQ2(JT).NE.0) K(N+2,1)=3
12813 IF(KCQ3(JT).NE.0) K(N+3,1)=3
12814 K(N+4,1)=42
12815 K(N+4,2)=88
12816 DO 260 J=1,5
12817 P(N+4,J)=0D0
12818 V(N+4,J)=0D0
12819 260 CONTINUE
12820 CTMSUM=0D0
12821 DO 270 II=N+1,N+3
12822 K(II,4)=0
12823 K(II,5)=0
12824C...Start by connecting all daughters to junction.
12825 K(II,ITJUNC(JT)-1)=MSTU(5)*(N+4)
12826C...Only consider colour topologies with off shell resonances.
12827 RMQ1=PMAS(PYCOMP(K(II,2)),1)
12828 RMRES=PMAS(PYCOMP(KSUSY1+IABS(K(II,2))),1)
12829 RMGLU=PMAS(PYCOMP(KSUSY1+21),1)
12830 IF (RMGLU-RMQ1.LT.RMRES) THEN
12831C...Calculate propagators for each colour topology.
12832 RM2Q23=RMGLU**2+RMQ1**2-2D0*(P(II,4)*P(ID,4)+P(II,1)
12833 & *P(ID,1)+P(II,2)*P(ID,2)+P(II,3)*P(ID,3))
12834 CTM2(II-N)=1D0/(RM2Q23-RMRES**2)**2
12835 ELSE
12836 CTM2(II-N)=0D0
12837 ENDIF
12838 CTMSUM=CTMSUM+CTM2(II-N)
12839 270 CONTINUE
12840 CTMSUM=PYR(0)*CTMSUM
12841C...Select colour topology J, with most off shell least likely.
12842 J=0
12843 280 J=J+1
12844 CTMSUM=CTMSUM-CTM2(J)
12845 IF (CTMSUM.GT.0D0) GOTO 280
12846C...The lucky winner gets its colour (anti-colour) directly from gluino.
12847 K(N+J,ITJUNC(JT)-1)=MSTU(5)*ID
12848 K(ID,ITJUNC(JT)-1)=N+J+(K(ID,ITJUNC(JT)-1)/MSTU(5))*MSTU(5)
12849C...The other gluino colour is connected to junction
12850 K(ID,10-ITJUNC(JT))=N+4+(K(ID,10-ITJUNC(JT))/MSTU(5))*
12851 & MSTU(5)
12852 K(N+4,4)=K(N+4,4)+ID
12853C...Lastly, connect junction to remaining daughters.
12854 K(N+4,5)=N+1+MOD(J,3)+MSTU(5)*(N+1+MOD(J+1,3))
12855C...Particle counter should be stepped up one extra for junction.
12856 N=N+1
12857 ENDIF
12858
12859C...Update particle counter.
12860 N=N+3
12861
12862C...2) Everything else two-body decay.
12863 ELSE
12864 CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
12865C...First set colour flow as if mother colour singlet.
12866 IF(KCQ1(JT).NE.0) THEN
12867 K(N-1,1)=3
12868 IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N
12869 IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N
12870 ENDIF
12871 IF(KCQ2(JT).NE.0) THEN
12872 K(N,1)=3
12873 IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1)
12874 IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1)
12875 ENDIF
12876C...Then redirect colour flow if mother (anti)triplet.
12877 IF(KCQM(JT).EQ.0) THEN
12878 ELSEIF(KCQM(JT).NE.2) THEN
12879 ISID=4
12880 IF(KCQM(JT).EQ.-1) ISID=5
12881 IDAU=N-1
12882 IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N
12883 K(ID,ISID)=K(ID,ISID)+IDAU
12884 K(IDAU,ISID)=MSTU(5)*ID
12885C...Then redirect colour flow if mother octet.
12886 ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN
12887 IDAU=N-1
12888 IF(KCQ1(JT).EQ.0) IDAU=N
12889 K(ID,4)=K(ID,4)+IDAU
12890 K(ID,5)=K(ID,5)+IDAU
12891 K(IDAU,4)=MSTU(5)*ID
12892 K(IDAU,5)=MSTU(5)*ID
12893 ELSE
12894 ISID=4
12895 IF(KCQ1(JT).EQ.-1) ISID=5
12896 IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0))
12897 K(ID,ISID)=K(ID,ISID)+(N-1)
12898 K(ID,9-ISID)=K(ID,9-ISID)+N
12899 K(N-1,ISID)=MSTU(5)*ID
12900 K(N,9-ISID)=MSTU(5)*ID
12901 ENDIF
12902
12903C...Insert junction
12904 IF(IABS(KCQ1(JT)+KCQ2(JT)-KCQM(JT)).EQ.3) THEN
12905 N=N+1
12906C...~q* mother: type 3 junction. ~q mother: type 4.
12907 ITJUNC(JT)=(7+KCQM(JT))/2
12908C...Specify junction KF and set colour flow from junction
12909 K(N,1)=42
12910 K(N,2)=88
12911 K(N,3)=ID
12912C...Junction type encoded together with mother:
12913 K(N,4)=ID+ITJUNC(JT)*MSTU(5)
12914 K(N,5)=N-1+MSTU(5)*(N-2)
12915C...Zero P and V for junction (V filled later)
12916 DO 290 J=1,5
12917 P(N,J)=0D0
12918 V(N,J)=0D0
12919 290 CONTINUE
12920C...Set colour flow from mother to junction
12921 K(ID,8-ITJUNC(JT))= N + MSTU(5)*(K(ID,8-ITJUNC(JT))/MSTU(5))
12922C...Set colour flow from daughters to junction
12923 DO 300 II=N-2,N-1
12924 K(II,4) = 0
12925 K(II,5) = 0
12926C...(Anti-)colour mother is junction.
12927 K(II,1+ITJUNC(JT)) = MSTU(5)*(N)
12928 300 CONTINUE
12929 ENDIF
12930 ENDIF
12931
12932C...End loop over resonances for daughter flavour and mass selection.
12933 MSTU(10)=MSTU10
12934 310 IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0))
12935 & NINH=NINH+1
12936 IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.MDCY(KCA,1).NE.0.AND.
12937 & KFL1(JT).EQ.0) THEN
12938 WRITE(CODE,'(I9)') K(ID,2)
12939 WRITE(MASS,'(F9.3)') P(ID,5)
12940 CALL PYERRM(3,'(PYRESD:) Failed to decay particle'//
12941 & CODE//' with mass'//MASS)
12942 MINT(51)=1
12943 GOTO 700
12944 ENDIF
12945 320 CONTINUE
12946
12947C...Check for allowed combinations. Skip if no decays.
12948 IF(JTMAX.EQ.1) THEN
12949 IF(KDCY(1).EQ.0) GOTO 690
12950 ELSEIF(JTMAX.EQ.2) THEN
12951 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 690
12952 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 160
12953 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 160
12954 ELSEIF(JTMAX.EQ.3) THEN
12955 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 690
12956 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 160
12957 IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 160
12958 IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 160
12959 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 160
12960 IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 160
12961 IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 160
12962 ENDIF
12963
12964C...Special case: matrix element option for Z0 decay to quarks.
12965 IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND.
12966 &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN
12967
12968C...Check consistency of MSTJ options set.
12969 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
12970 CALL PYERRM(6,
12971 & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
12972 MSTJ(110)=1
12973 ENDIF
12974 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
12975 CALL PYERRM(6,
12976 & '(PYRESD:) MSTJ(109) value requires MSTJ(111) = 0')
12977
12978 MSTJ(111)=0
12979 ENDIF
12980
12981C...Select alpha_strong behaviour.
12982 MST111=MSTU(111)
12983 PAR112=PARU(112)
12984 MSTU(111)=MSTJ(108)
12985 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
12986 & MSTU(111)=1
12987 PARU(112)=PARJ(121)
12988 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
12989
12990C...Find axial fraction in total cross section for scalar gluon model.
12991 PARJ(171)=0D0
12992 IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR.
12993 & (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN
12994 POLL=1D0-PARJ(131)*PARJ(132)
12995 SFF=1D0/(16D0*XW*XW1)
12996 SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+
12997 & (PARJ(123)*PARJ(124))**2)
12998 SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2)
12999 VE=4D0*XW-1D0
13000 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
13001 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*
13002 & (PARJ(132)-PARJ(131)))
13003 KFLC=IABS(KFL1(1))
13004 PMQ=PYMASS(KFLC)
13005 QF=KCHG(KFLC,1)/3D0
13006 VQ=1D0
13007 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,
13008 & 1D0-(2D0*PMQ/P(ID,5))**2))
13009 VF=SIGN(1D0,QF)-4D0*QF*XW
13010 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+
13011 & VF**2*HF1W)+VQ**3*HF1W
13012 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
13013 ENDIF
13014
13015C...Choice of jet configuration.
13016 CALL PYXJET(P(ID,5),NJET,CUT)
13017 KFLC=IABS(KFL1(1))
13018 KFLN=21
13019
13020 IF(NJET.EQ.4) THEN
13021 CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14)
13022 ELSEIF(NJET.EQ.3) THEN
13023 CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3)
13024 ELSE
13025 MSTJ(120)=1
13026 ENDIF
13027
13028C...Fill jet configuration; return if incorrect kinematics.
13029 NC=N-2
13030 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN
13031 CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5))
13032 ELSEIF(NJET.EQ.2) THEN
13033 CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5))
13034 ELSEIF(NJET.EQ.3) THEN
13035 CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3)
13036 ELSEIF(KFLN.EQ.21) THEN
13037 CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
13038 & X12,X14)
13039 ELSE
13040 CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
13041 & X12,X14)
13042 ENDIF
13043 IF(MSTU(24).NE.0) THEN
13044 MINT(51)=1
13045 MSTU(111)=MST111
13046 PARU(112)=PAR112
13047 GOTO 700
13048 ENDIF
13049
13050C...Angular orientation according to matrix element.
13051 IF(MSTJ(106).EQ.1) THEN
13052 CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHIZ,THEZ,PHIZ)
13053 IF(MINT(11).LT.0) THEZ=PARU(1)-THEZ
13054 CTHE(1)=COS(THEZ)
13055 CALL PYROBO(NC+1,N,0D0,CHIZ,0D0,0D0,0D0)
13056 CALL PYROBO(NC+1,N,THEZ,PHIZ,0D0,0D0,0D0)
13057 ENDIF
13058
13059C...Boost partons to Z0 rest frame.
13060 CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4),
13061 & P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
13062
13063C...Mark decayed resonance and add documentation lines,
13064 K(ID,1)=K(ID,1)+10
13065 IDOC=MINT(83)+MINT(4)
13066 DO 340 I=NC+1,N
13067 I1=MINT(83)+MINT(4)+1
13068 K(I,3)=I1
13069 IF(MSTP(128).GE.1) K(I,3)=ID
13070 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
13071 MINT(4)=MINT(4)+1
13072 K(I1,1)=21
13073 K(I1,2)=K(I,2)
13074 K(I1,3)=IREF(IP,4)
13075 DO 330 J=1,5
13076 P(I1,J)=P(I,J)
13077 330 CONTINUE
13078 ENDIF
13079 340 CONTINUE
13080
13081C...Generate parton shower.
13082 IF(MSTJ(101).EQ.5) CALL PYSHOW(N-1,N,P(ID,5))
13083
13084C... End special case for Z0: skip ahead.
13085 MSTU(111)=MST111
13086 PARU(112)=PAR112
13087 GOTO 680
13088 ENDIF
13089
13090C...Order incoming partons and outgoing resonances.
13091 IF(JTMAX.EQ.2.AND.ISUB.NE.0.AND.MSTP(47).GE.1.AND.
13092 &NINH.EQ.0) THEN
13093 ILIN(1)=MINT(84)+1
13094 IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
13095 IF(K(ILIN(1),2).EQ.21.OR.K(ILIN(1),2).EQ.22)
13096 & ILIN(1)=2*MINT(84)+3-ILIN(1)
13097 ILIN(2)=2*MINT(84)+3-ILIN(1)
13098 IMIN=1
13099 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
13100 & .EQ.36) IMIN=3
13101 IMAX=2
13102 IORD=1
13103 IF(K(IREF(IP,1),2).EQ.23) IORD=2
13104 IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
13105 IAKIPD=IABS(K(IREF(IP,IORD),2))
13106 IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD
13107 IF(KDCY(IORD).EQ.0) IORD=3-IORD
13108
13109C...Order decay products of resonances.
13110 DO 350 JT=IORD,3-IORD,3-2*IORD
13111 IF(KDCY(JT).EQ.0) THEN
13112 ILIN(IMAX+1)=NSD(JT)
13113 IMAX=IMAX+1
13114 ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
13115 ILIN(IMAX+1)=N+2*JT-1
13116 ILIN(IMAX+2)=N+2*JT
13117 IMAX=IMAX+2
13118 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
13119 K(N+2*JT,2)=K(NSD(JT)+2,2)
13120 ELSE
13121 ILIN(IMAX+1)=N+2*JT
13122
13123 ILIN(IMAX+2)=N+2*JT-1
13124 IMAX=IMAX+2
13125 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
13126 K(N+2*JT,2)=K(NSD(JT)+2,2)
13127 ENDIF
13128 350 CONTINUE
13129
13130C...Find charge, isospin, left- and righthanded couplings.
13131 DO 370 I=IMIN,IMAX
13132 DO 360 J=1,4
13133 COUP(I,J)=0D0
13134 360 CONTINUE
13135 KFA=IABS(K(ILIN(I),2))
13136 IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 370
13137 COUP(I,1)=KCHG(KFA,1)/3D0
13138 COUP(I,2)=(-1)**MOD(KFA,2)
13139 COUP(I,4)=-2D0*COUP(I,1)*XWV
13140 COUP(I,3)=COUP(I,2)+COUP(I,4)
13141 370 CONTINUE
13142
13143C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
13144 IF(ISUB.EQ.22) THEN
13145 DO 400 I=3,5,2
13146 I1=IORD
13147 IF(I.EQ.5) I1=3-IORD
13148 DO 390 J1=1,2
13149 DO 380 J2=1,2
13150 CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/
13151 & 16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)*
13152 & COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)*
13153 & COUP(I,J2+2)**2
13154 380 CONTINUE
13155 390 CONTINUE
13156 400 CONTINUE
13157 COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
13158 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2))
13159 COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))*
13160 & (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2))
13161
13162 IF(COWT12.LT.PYR(0)*COMX12) GOTO 160
13163 ENDIF
13164 ENDIF
13165
13166C...Select angular orientation type - Z'/W' only.
13167 MZPWP=0
13168 IF(ISUB.EQ.141) THEN
13169 IF(PYR(0).LT.PARU(130)) MZPWP=1
13170 IF(IP.EQ.2) THEN
13171 IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2
13172 IAKIR=IABS(K(IREF(2,2),2))
13173 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
13174 IF(IAKIR.LE.20) MZPWP=2
13175 ENDIF
13176 IF(IP.GE.3) MZPWP=2
13177 ELSEIF(ISUB.EQ.142) THEN
13178 IF(PYR(0).LT.PARU(136)) MZPWP=1
13179 IF(IP.EQ.2) THEN
13180 IAKIR=IABS(K(IREF(2,2),2))
13181 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
13182 IF(IAKIR.LE.20) MZPWP=2
13183 ENDIF
13184 IF(IP.GE.3) MZPWP=2
13185 ENDIF
13186
13187C...Select random angles (begin of weighting procedure).
13188 410 DO 420 JT=1,JTMAX
13189 IF(KDCY(JT).EQ.0) GOTO 420
13190 IF(JTMAX.EQ.1.AND.ISUB.NE.0.AND.IHDEC.EQ.0) THEN
13191 CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0)
13192 IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
13193 PHI(JT)=VINT(24)
13194 ELSE
13195 CTHE(JT)=2D0*PYR(0)-1D0
13196 PHI(JT)=PARU(2)*PYR(0)
13197 ENDIF
13198 420 CONTINUE
13199
13200 IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
13201C...Construct massless four-vectors.
13202 DO 440 I=N+1,N+4
13203 K(I,1)=1
13204 DO 430 J=1,5
13205 P(I,J)=0D0
13206 V(I,J)=0D0
13207 430 CONTINUE
13208 440 CONTINUE
13209 DO 450 JT=1,JTMAX
13210 IF(KDCY(JT).EQ.0) GOTO 450
13211 ID=IREF(IP,JT)
13212 P(N+2*JT-1,3)=0.5D0*P(ID,5)
13213 P(N+2*JT-1,4)=0.5D0*P(ID,5)
13214 P(N+2*JT,3)=-0.5D0*P(ID,5)
13215 P(N+2*JT,4)=0.5D0*P(ID,5)
13216 CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
13217 & P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
13218 450 CONTINUE
13219
13220C...Store incoming and outgoing momenta, with random rotation to
13221C...avoid accidental zeroes in HA expressions.
13222 IF(ISUB.NE.0) THEN
13223 DO 470 I=IMIN,IMAX
13224 K(N+4+I,1)=1
13225 P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+
13226 & P(ILIN(I),3)**2+P(ILIN(I),5)**2)
13227 P(N+4+I,5)=P(ILIN(I),5)
13228 DO 460 J=1,3
13229 P(N+4+I,J)=P(ILIN(I),J)
13230 460 CONTINUE
13231 470 CONTINUE
13232 480 THERR=ACOS(2D0*PYR(0)-1D0)
13233 PHIRR=PARU(2)*PYR(0)
13234 CALL PYROBO(N+4+IMIN,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
13235 DO 500 I=IMIN,IMAX
13236 IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*P(N+4+I,4)**2)
13237 & GOTO 480
13238 DO 490 J=1,4
13239 PK(I,J)=P(N+4+I,J)
13240 490 CONTINUE
13241 500 CONTINUE
13242 ENDIF
13243
13244C...Calculate internal products.
13245 IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR.
13246 & ISUB.EQ.142) THEN
13247 DO 520 I1=IMIN,IMAX-1
13248 DO 510 I2=I1+1,IMAX
13249 HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+
13250 & PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))*
13251 & CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))-
13252 & SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
13253 & (1D-20+PK(I2,1)**2+PK(I2,2)**2)))*
13254 & CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2)))
13255 HC(I1,I2)=CONJG(HA(I1,I2))
13256 IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
13257 IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
13258 HA(I2,I1)=-HA(I1,I2)
13259 HC(I2,I1)=-HC(I1,I2)
13260 510 CONTINUE
13261 520 CONTINUE
13262 ENDIF
13263
13264C...Calculate four-products.
13265 IF(ISUB.NE.0) THEN
13266 DO 540 I=1,2
13267 DO 530 J=1,4
13268 PK(I,J)=-PK(I,J)
13269 530 CONTINUE
13270 540 CONTINUE
13271 DO 560 I1=IMIN,IMAX-1
13272 DO 550 I2=I1+1,IMAX
13273 PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
13274 & PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
13275 PKK(I2,I1)=PKK(I1,I2)
13276 550 CONTINUE
13277 560 CONTINUE
13278 ENDIF
13279 ENDIF
13280
13281 KFAGM=IABS(IREF(IP,7))
13282 IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN
13283C...Isotropic decay selected by user.
13284 WT=1D0
13285 WTMAX=1D0
13286
13287 ELSEIF(JTMAX.EQ.3) THEN
13288C...Isotropic decay when three mother particles.
13289 WT=1D0
13290 WTMAX=1D0
13291
13292 ELSEIF(IT4.GE.1) THEN
13293C... Isotropic decay t -> b + W etc for 4th generation q and l.
13294 WT=1D0
13295 WTMAX=1D0
13296
13297 ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.
13298 & IREF(IP,7).EQ.36) THEN
13299C...Angular weight for h0/A0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
13300C...CP-odd case added by Kari Ertresvag Myklevoll.
13301 IF(IP.EQ.1) WTMAX=SH**2
13302 IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4
13303 KFA=IABS(K(IREF(IP,1),2))
13304 IF(KFA.EQ.23) THEN
13305 KFLF1A=IABS(KFL1(1))
13306 EF1=KCHG(KFLF1A,1)/3D0
13307 AF1=SIGN(1D0,EF1+0.1D0)
13308 VF1=AF1-4D0*EF1*XWV
13309 KFLF2A=IABS(KFL1(2))
13310 EF2=KCHG(KFLF2A,1)/3D0
13311 AF2=SIGN(1D0,EF2+0.1D0)
13312 VF2=AF2-4D0*EF2*XWV
13313 VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)
13314 & *(VF2**2+AF2**2))
13315 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
13316 & THEN
13317C...CP-even decay
13318 WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+
13319 & 8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5)
13320 ELSE
13321C...CP-odd decay
13322 WT=((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
13323 & -2*PKK(3,4)*PKK(5,6)
13324 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
13325 & (PKK(3,4)*PKK(5,6))
13326 & +VA12AS*(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
13327 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))/(1+VA12AS)
13328 ENDIF
13329 ELSEIF(KFA.EQ.24) THEN
13330 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
13331 & THEN
13332C...CP-even decay
13333 WT=16D0*PKK(3,5)*PKK(4,6)
13334 ELSE
13335C...CP-odd decay
13336 WT=0.5D0*((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
13337 & -2*PKK(3,4)*PKK(5,6)
13338 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
13339 & (PKK(3,4)*PKK(5,6))
13340 & +(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
13341 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))
13342 ENDIF
13343 ELSE
13344 WT=WTMAX
13345 ENDIF
13346
13347 ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR.
13348 & KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24)
13349 & THEN
13350C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
13351 I1=IREF(IP,8)
13352 IF(MOD(KFAGM,2).EQ.0) THEN
13353 I2=N+1
13354 I3=N+2
13355 ELSE
13356 I2=N+2
13357 I3=N+1
13358 ENDIF
13359 I4=IREF(IP,2)
13360 WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
13361 & P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)-
13362 & P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3))
13363 WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0
13364
13365 ELSEIF(ISUB.EQ.1) THEN
13366C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
13367 EI=KCHG(IABS(MINT(15)),1)/3D0
13368 AI=SIGN(1D0,EI+0.1D0)
13369 VI=AI-4D0*EI*XWV
13370 EF=KCHG(IABS(KFL1(1)),1)/3D0
13371 AF=SIGN(1D0,EF+0.1D0)
13372
13373 VF=AF-4D0*EF*XWV
13374 RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH)
13375 WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
13376 & (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2)
13377 WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
13378 & (VI**2+AI**2)*VINT(114)*VF**2)
13379 WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+
13380 & 4D0*VI*AI*VINT(114)*VF*AF)
13381 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
13382 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
13383 WTMAX=2D0*(WT1+ABS(WT3))
13384
13385 ELSEIF(ISUB.EQ.2) THEN
13386C...Angular weight for W+/- -> 2 quarks/leptons.
13387 RM3=PMAS(IABS(KFL1(1)),1)**2/SH
13388 RM4=PMAS(IABS(KFL2(1)),1)**2/SH
13389 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
13390 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
13391 WTMAX=4D0
13392
13393 ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
13394C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
13395C...-> gluon/gamma + 2 quarks/leptons.
13396 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13397 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
13398 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
13399 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13400 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
13401 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
13402 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13403 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
13404 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
13405 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13406 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
13407 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
13408 WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+
13409 & (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2)
13410 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
13411 & ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
13412
13413 ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
13414C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
13415C...-> gluon/gamma + 2 quarks/leptons.
13416 WT=PKK(1,3)**2+PKK(2,4)**2
13417 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
13418
13419 ELSEIF(ISUB.EQ.22) THEN
13420C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
13421 S34=P(IREF(IP,IORD),5)**2
13422 S56=P(IREF(IP,3-IORD),5)**2
13423 TI=PKK(1,3)+PKK(1,4)+S34
13424 UI=PKK(1,5)+PKK(1,6)+S56
13425 TIR=REAL(TI)
13426 UIR=REAL(UI)
13427 FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2
13428 FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2
13429 FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2
13430 FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2
13431 FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2
13432 FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2
13433 FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2
13434 FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2
13435
13436 WT=
13437 & CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+
13438 & CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+
13439 & CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+
13440 & CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264
13441 WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
13442 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56*
13443 & ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+
13444 & 1D0/UI**2))
13445
13446 ELSEIF(ISUB.EQ.23) THEN
13447C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
13448 D34=P(IREF(IP,IORD),5)**2
13449 D56=P(IREF(IP,3-IORD),5)**2
13450 DT=PKK(1,3)+PKK(1,4)+D34
13451 DU=PKK(1,5)+PKK(1,6)+D56
13452 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
13453 CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
13454 CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
13455 FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+
13456
13457 & REAL(CBWZ)*FGK(1,2,5,6,3,4))
13458 FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+
13459 & REAL(CBWZ)*FGK(1,2,6,5,3,4))
13460 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
13461 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
13462 & DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
13463
13464 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
13465C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
13466C...(or H0, or A0).
13467 WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
13468 & PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
13469 & COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
13470 WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
13471 & (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
13472
13473 ELSEIF(ISUB.EQ.25) THEN
13474C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
13475 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
13476 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
13477 D34=P(IREF(IP,IORD),5)**2
13478 D56=P(IREF(IP,3-IORD),5)**2
13479 DT=PKK(1,3)+PKK(1,4)+D34
13480 DU=PKK(1,5)+PKK(1,6)+D56
13481 FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2)
13482 CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH
13483 CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT
13484 CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU
13485 CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH
13486 FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)-
13487 & REAL(CBWW)*FGK(1,2,5,6,3,4))
13488 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
13489 IF(MSTP(50).LE.0) THEN
13490 WT=FGK135**2+(CCWW*FGK253)**2
13491 WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-
13492 & CAWW*CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-
13493 & DJGK(DT,DU)))
13494 ELSE
13495 WT=POLL*FGK135**2+POLR*(CCWW*FGK253)**2
13496 WTMAX=4D0*D34*D56*(POLL*(CAWW**2*DIGK(DT,DU)+
13497 & CBWW**2*DIGK(DU,DT)-CAWW*CBWW*DJGK(DT,DU))+
13498 & POLR*CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
13499 ENDIF
13500
13501 ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN
13502C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
13503C...(or H0, or A0).
13504 WT=PKK(1,3)*PKK(2,4)
13505 WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
13506
13507 ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN
13508C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
13509C...-> f + 2 quarks/leptons.
13510 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13511 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
13512 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
13513 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13514 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
13515 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
13516 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13517 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
13518 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
13519 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13520 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
13521 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
13522 IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+
13523 & PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2)
13524 IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+
13525 & PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2)
13526 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
13527 & ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
13528
13529 ELSEIF(ISUB.EQ.31.OR.ISUB.EQ.36) THEN
13530C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions.
13531 IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
13532 IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
13533 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
13534
13535 ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.
13536 & ISUB.EQ.77) THEN
13537C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
13538 WT=16D0*PKK(3,5)*PKK(4,6)
13539 WTMAX=SH**2
13540
13541 ELSEIF(ISUB.EQ.110) THEN
13542C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
13543 WT=1D0
13544 WTMAX=1D0
13545
13546 ELSEIF(ISUB.EQ.141) THEN
13547 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
13548C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
13549C...Couplings of incoming flavour.
13550 KFAI=IABS(MINT(15))
13551 EI=KCHG(KFAI,1)/3D0
13552 AI=SIGN(1D0,EI+0.1D0)
13553 VI=AI-4D0*EI*XWV
13554 KFAIC=1
13555 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
13556 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
13557 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
13558 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
13559 VPI=PARU(119+2*KFAIC)
13560 API=PARU(120+2*KFAIC)
13561 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
13562 VPI=PARJ(178+2*KFAIC)
13563 API=PARJ(179+2*KFAIC)
13564 ELSE
13565 VPI=PARJ(186+2*KFAIC)
13566 API=PARJ(187+2*KFAIC)
13567 ENDIF
13568C...Couplings of final flavour.
13569 KFAF=IABS(KFL1(1))
13570 EF=KCHG(KFAF,1)/3D0
13571 AF=SIGN(1D0,EF+0.1D0)
13572 VF=AF-4D0*EF*XWV
13573 KFAFC=1
13574 IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2
13575 IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3
13576 IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4
13577 IF(KFAF.LE.2.OR.KFAF.EQ.11.OR.KFAF.EQ.12) THEN
13578 VPF=PARU(119+2*KFAFC)
13579 APF=PARU(120+2*KFAFC)
13580 ELSEIF(KFAF.LE.4.OR.KFAF.EQ.13.OR.KFAF.EQ.14) THEN
13581 VPF=PARJ(178+2*KFAFC)
13582 APF=PARJ(179+2*KFAFC)
13583 ELSE
13584 VPF=PARJ(186+2*KFAFC)
13585 APF=PARJ(187+2*KFAFC)
13586 ENDIF
13587C...Asymmetry and weight.
13588 ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+
13589 & 4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)*
13590 & (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/
13591 & (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
13592 & EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
13593 & (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+
13594 & (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2))
13595 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
13596 WTMAX=2D0+ABS(ASYM)
13597 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN
13598C...Angular weight for f + fbar -> Z' -> W+ + W-.
13599 RM1=P(NSD(1)+1,5)**2/SH
13600 RM2=P(NSD(1)+2,5)**2/SH
13601 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
13602 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
13603 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
13604 & (RM2-RM1)**2)
13605 WT=CFLAT+CCOS2*CTHE(1)**2
13606 WTMAX=CFLAT+MAX(0D0,CCOS2)
13607 ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR.
13608 & IABS(KFL1(1)).EQ.37)) THEN
13609C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
13610 WT=1D0-CTHE(1)**2
13611 WTMAX=1D0
13612 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
13613C...Angular weight for f + fbar -> Z' -> Z0 + h0.
13614 RM1=P(NSD(1)+1,5)**2/SH
13615 RM2=P(NSD(1)+2,5)**2/SH
13616 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
13617 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
13618 WTMAX=1D0+FLAM2/(8D0*RM1)
13619 ELSEIF(MZPWP.EQ.0) THEN
13620C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
13621C...(W:s like if intermediate Z).
13622 D34=P(IREF(IP,IORD),5)**2
13623 D56=P(IREF(IP,3-IORD),5)**2
13624 DT=PKK(1,3)+PKK(1,4)+D34
13625 DU=PKK(1,5)+PKK(1,6)+D56
13626 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
13627 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
13628 WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2
13629 WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)*
13630 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
13631 ELSEIF(MZPWP.EQ.1) THEN
13632C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
13633C...(W:s approximately longitudinal, like if intermediate H).
13634 WT=16D0*PKK(3,5)*PKK(4,6)
13635 WTMAX=SH**2
13636 ELSE
13637C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
13638C...H0 + A0 -> 4 quarks/leptons, t + tbar -> b + W+ + bbar + W- .
13639 WT=1D0
13640 WTMAX=1D0
13641 ENDIF
13642
13643 ELSEIF(ISUB.EQ.142) THEN
13644 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
13645C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
13646 KFAI=IABS(MINT(15))
13647 KFAIC=1
13648 IF(KFAI.GT.10) KFAIC=2
13649 VI=PARU(129+2*KFAIC)
13650 AI=PARU(130+2*KFAIC)
13651 KFAF=IABS(KFL1(1))
13652 KFAFC=1
13653 IF(KFAF.GT.10) KFAFC=2
13654 VF=PARU(129+2*KFAFC)
13655 AF=PARU(130+2*KFAFC)
13656 ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2))
13657 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
13658 WTMAX=2D0+ABS(ASYM)
13659 ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN
13660C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
13661 RM1=P(NSD(1)+1,5)**2/SH
13662 RM2=P(NSD(1)+2,5)**2/SH
13663 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
13664 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
13665 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
13666 & (RM2-RM1)**2)
13667 WT=CFLAT+CCOS2*CTHE(1)**2
13668 WTMAX=CFLAT+MAX(0D0,CCOS2)
13669 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
13670C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
13671 RM1=P(NSD(1)+1,5)**2/SH
13672 RM2=P(NSD(1)+2,5)**2/SH
13673 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
13674 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
13675 WTMAX=1D0+FLAM2/(8D0*RM1)
13676 ELSEIF(MZPWP.EQ.0) THEN
13677C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
13678C...(W/Z like if intermediate W).
13679 D34=P(IREF(IP,IORD),5)**2
13680 D56=P(IREF(IP,3-IORD),5)**2
13681 DT=PKK(1,3)+PKK(1,4)+D34
13682 DU=PKK(1,5)+PKK(1,6)+D56
13683 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
13684 FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4))
13685 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
13686 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*
13687 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
13688 ELSEIF(MZPWP.EQ.1) THEN
13689C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
13690C...(W/Z approximately longitudinal, like if intermediate H).
13691 WT=16D0*PKK(3,5)*PKK(4,6)
13692 WTMAX=SH**2
13693 ELSE
13694C...Angular weight for f + fbar -> W' -> W + h0 -> whatever,
13695C...t + bbar -> t + W + bbar.
13696 WT=1D0
13697 WTMAX=1D0
13698 ENDIF
13699
13700 ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164)
13701 & THEN
13702C...Isotropic decay of leptoquarks (assumed spin 0).
13703 WT=1D0
13704 WTMAX=1D0
13705
13706 ELSEIF(ISUB.GE.146.AND.ISUB.LE.148) THEN
13707C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-).
13708 SIDE=1D0
13709 IF(MINT(16).EQ.21.OR.MINT(16).EQ.22) SIDE=-1D0
13710 IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN
13711 WT=1D0+SIDE*CTHE(1)
13712 WTMAX=2D0
13713 ELSEIF(IP.EQ.1) THEN
13714
13715 RM1=P(NSD(1)+1,5)**2/SH
13716 WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
13717 WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
13718 ELSE
13719C...W/Z decay assumed isotropic, since not known.
13720 WT=1D0
13721 WTMAX=1D0
13722 ENDIF
13723
13724 ELSEIF(ISUB.EQ.149) THEN
13725C...Isotropic decay of techni-eta.
13726 WT=1D0
13727 WTMAX=1D0
13728
13729 ELSEIF(ISUB.EQ.191) THEN
13730 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
13731C...Angular weight for f + fbar -> rho_tc0 -> W+ W-,
13732C...W+ pi_tc-, pi_tc+ W- or pi_tc+ pi_tc-.
13733 WT=1D0-CTHE(1)**2
13734 WTMAX=1D0
13735 ELSEIF(IP.EQ.1) THEN
13736C...Angular weight for f + fbar -> rho_tc0 -> f fbar.
13737 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
13738 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
13739 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
13740 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
13741 KFAI=IABS(MINT(15))
13742 EI=KCHG(KFAI,1)/3D0
13743 AI=SIGN(1D0,EI+0.1D0)
13744 VI=AI-4D0*EI*XWV
13745 VALI=0.5D0*(VI+AI)
13746 VARI=0.5D0*(VI-AI)
13747 ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2
13748 ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2
13749 KFAF=IABS(KFL1(1))
13750 EF=KCHG(KFAF,1)/3D0
13751 AF=SIGN(1D0,EF+0.1D0)
13752 VF=AF-4D0*EF*XWV
13753 VALF=0.5D0*(VF+AF)
13754 VARF=0.5D0*(VF-AF)
13755 ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2
13756 ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2
13757 ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF
13758 AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF
13759 WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2
13760 WTMAX=4D0*MAX(ASAME,AFLIP)
13761 ELSE
13762C...Isotropic decay of W/pi_tc produced in rho_tc decay.
13763 WT=1D0
13764 WTMAX=1D0
13765 ENDIF
13766
13767 ELSEIF(ISUB.EQ.192) THEN
13768 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
13769C...Angular weight for f + fbar' -> rho_tc+ -> W+ Z0,
13770C...W+ pi_tc0, pi_tc+ Z0 or pi_tc+ pi_tc0.
13771 WT=1D0-CTHE(1)**2
13772 WTMAX=1D0
13773 ELSEIF(IP.EQ.1) THEN
13774C...Angular weight for f + fbar' -> rho_tc+ -> f fbar'.
13775 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
13776 WT=(1D0+CTHESG)**2
13777 WTMAX=4D0
13778 ELSE
13779C...Isotropic decay of W/Z/pi_tc produced in rho_tc+ decay.
13780 WT=1D0
13781 WTMAX=1D0
13782 ENDIF
13783
13784 ELSEIF(ISUB.EQ.193) THEN
13785 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
13786C...Angular weight for f + fbar -> omega_tc0 ->
13787C...gamma pi_tc0 or Z0 pi_tc0.
13788 WT=1D0+CTHE(1)**2
13789 WTMAX=2D0
13790 ELSEIF(IP.EQ.1) THEN
13791C...Angular weight for f + fbar -> omega_tc0 -> f fbar.
13792 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
13793 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
13794 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
13795 KFAI=IABS(MINT(15))
13796 EI=KCHG(KFAI,1)/3D0
13797 AI=SIGN(1D0,EI+0.1D0)
13798 VI=AI-4D0*EI*XWV
13799 VALI=0.5D0*(VI+AI)
13800 VARI=0.5D0*(VI-AI)
13801 BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2
13802 BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2
13803 KFAF=IABS(KFL1(1))
13804 EF=KCHG(KFAF,1)/3D0
13805 AF=SIGN(1D0,EF+0.1D0)
13806 VF=AF-4D0*EF*XWV
13807 VALF=0.5D0*(VF+AF)
13808 VARF=0.5D0*(VF-AF)
13809 BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2
13810 BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2
13811 BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF
13812 BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF
13813 WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2
13814 WTMAX=4D0*MAX(BSAME,BFLIP)
13815 ELSE
13816C...Isotropic decay of Z/pi_tc produced in omega_tc decay.
13817 WT=1D0
13818 WTMAX=1D0
13819 ENDIF
13820
13821 ELSEIF(ISUB.EQ.353) THEN
13822C...Angular weight for Z_R0 -> 2 quarks/leptons.
13823 EI=KCHG(IABS(MINT(15)),1)/3D0
13824 AI=SIGN(1D0,EI+0.1D0)
13825 VI=AI-4D0*EI*XWV
13826 EF=KCHG(PYCOMP(KFL1(1)),1)/3D0
13827 AF=SIGN(1D0,EF+0.1D0)
13828 VF=AF-4D0*EF*XWV
13829 RMF=MIN(1D0,4D0*PMAS(PYCOMP(KFL1(1)),1)**2/SH)
13830 WT1=(VI**2+AI**2)*(VF**2+(1D0-RMF)*AF**2)
13831 WT2=RMF*(VI**2+AI**2)*VF**2
13832 WT3=SQRT(1D0-RMF)*4D0*VI*AI*VF*AF
13833 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
13834 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
13835 WTMAX=2D0*(WT1+ABS(WT3))
13836
13837 ELSEIF(ISUB.EQ.354) THEN
13838C...Angular weight for W_R+/- -> 2 quarks/leptons.
13839 RM3=PMAS(PYCOMP(KFL1(1)),1)**2/SH
13840 RM4=PMAS(PYCOMP(KFL2(1)),1)**2/SH
13841 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
13842 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
13843 WTMAX=4D0
13844
13845 ELSEIF(ISUB.EQ.391) THEN
13846C...Angular weight for f + fbar -> G* -> f + fbar
13847 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
13848 WT=1D0-3D0*CTHE(1)**2+4D0*CTHE(1)**4
13849 WTMAX=2D0
13850C...Other G* decays not yet implemented angular distributions.
13851 ELSE
13852 WT=1D0
13853 WTMAX=1D0
13854 ENDIF
13855
13856 ELSEIF(ISUB.EQ.392) THEN
13857C...Angular weight for g + g -> G* -> f + fbar
13858 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
13859 WT=1D0-CTHE(1)**4
13860 WTMAX=1D0
13861C...Other G* decays not yet implemented angular distributions.
13862 ELSE
13863 WT=1D0
13864 WTMAX=1D0
13865 ENDIF
13866
13867C...Obtain correct angular distribution by rejection techniques.
13868 ELSE
13869 WT=1D0
13870 WTMAX=1D0
13871 ENDIF
13872 IF(WT.LT.PYR(0)*WTMAX) GOTO 410
13873
13874C...Construct massive four-vectors using angles chosen.
13875 570 DO 670 JT=1,JTMAX
13876 IF(KDCY(JT).EQ.0) GOTO 670
13877 ID=IREF(IP,JT)
13878 DO 580 J=1,5
13879 DPMO(J)=P(ID,J)
13880 580 CONTINUE
13881 DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2)
13882CMRENNA++
13883 IF(KFL3(JT).EQ.0) THEN
13884 CALL PYROBO(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT),
13885 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
13886 N0=NSD(JT)+2
13887 ELSE
13888 CALL PYROBO(NSD(JT)+1,NSD(JT)+3,ACOS(CTHE(JT)),PHI(JT),
13889 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
13890 N0=NSD(JT)+3
13891 ENDIF
13892
13893 DO 590 J=1,4
13894 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
13895 590 CONTINUE
13896C...Fill in position of decay vertex.
13897 DO 610 I=NSD(JT)+1,N0
13898 DO 600 J=1,4
13899 V(I,J)=VDCY(J)
13900 600 CONTINUE
13901 V(I,5)=0D0
13902
13903 610 CONTINUE
13904CMRENNA--
13905
13906C...Mark decayed resonances; trace history.
13907 K(ID,1)=K(ID,1)+10
13908 KFA=IABS(K(ID,2))
13909 KCA=PYCOMP(KFA)
13910 IF(KCQM(JT).NE.0) THEN
13911C...Do not kill colour flow through coloured resonance!
13912 ELSE
13913 K(ID,4)=NSD(JT)+1
13914 K(ID,5)=NSD(JT)+2
13915C...If 3-body or 2-body with junction:
13916 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).NE.0) K(ID,5)=NSD(JT)+3
13917C...If 3-body with junction:
13918 IF(ITJUNC(JT).NE.0.AND.KFL3(JT).NE.0) K(ID,5)=NSD(JT)+4
13919 ENDIF
13920
13921C...Add documentation lines.
13922 ISUBRG=MAX(1,MIN(500,MINT(1)))
13923 IF(IRES.EQ.0.OR.ISET(ISUBRG).EQ.11) THEN
13924 IDOC=MINT(83)+MINT(4)
13925CMRENNA+++
13926 IHI=NSD(JT)+2
13927 IF(KFL3(JT).NE.0) IHI=IHI+1
13928 DO 630 I=NSD(JT)+1,IHI
13929CMRENNA---
13930 I1=MINT(83)+MINT(4)+1
13931 K(I,3)=I1
13932 IF(MSTP(128).GE.1) K(I,3)=ID
13933 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
13934 MINT(4)=MINT(4)+1
13935 K(I1,1)=21
13936 K(I1,2)=K(I,2)
13937 K(I1,3)=IREF(IP,JT+3)
13938 DO 620 J=1,5
13939 P(I1,J)=P(I,J)
13940 620 CONTINUE
13941 ENDIF
13942 630 CONTINUE
13943 ELSE
13944 K(NSD(JT)+1,3)=ID
13945 K(NSD(JT)+2,3)=ID
13946C...If 3-body or 2-body with junction:
13947 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).GT.0) K(NSD(JT)+3,3)=ID
13948C...If 3-body with junction:
13949 IF(KFL3(JT).NE.0.AND.ITJUNC(JT).GT.0) K(NSD(JT)+4,3)=ID
13950 ENDIF
13951
13952C...Do showering of two or three objects.
13953 NSHBEF=N
13954 IF(MSTP(71).GE.1) THEN
13955 IF(KFL3(JT).EQ.0) THEN
13956 CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
13957 ELSE
13958 CALL PYSHOW(NSD(JT)+1,-3,P(ID,5))
13959 ENDIF
13960 ENDIF
13961 NSHAFT=N
13962 IF(JT.EQ.1) NAFT1=N
13963
13964C...Check if decay products moved by shower.
13965 NSD1=NSD(JT)+1
13966 NSD2=NSD(JT)+2
13967 NSD3=NSD(JT)+3
13968 IF(NSHAFT.GT.NSHBEF) THEN
13969 IF(K(NSD1,1).GT.10) THEN
13970 DO 640 I=NSHBEF+1,NSHAFT
13971 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
13972 640 CONTINUE
13973 ENDIF
13974 IF(K(NSD2,1).GT.10) THEN
13975 DO 650 I=NSHBEF+1,NSHAFT
13976 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
13977 & I.NE.NSD1) NSD2=I
13978 650 CONTINUE
13979 ENDIF
13980 IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
13981 DO 660 I=NSHBEF+1,NSHAFT
13982 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND.
13983 & I.NE.NSD1.AND.I.NE.NSD2) NSD3=I
13984 660 CONTINUE
13985 ENDIF
13986 ENDIF
13987
13988C...Store decay products for further treatment.
13989 NP=NP+1
13990 IREF(NP,1)=NSD1
13991 IREF(NP,2)=NSD2
13992 IREF(NP,3)=0
13993 IF(KFL3(JT).NE.0) IREF(NP,3)=NSD3
13994 IREF(NP,4)=IDOC+1
13995 IREF(NP,5)=IDOC+2
13996 IREF(NP,6)=0
13997 IF(KFL3(JT).NE.0) IREF(NP,6)=IDOC+3
13998 IREF(NP,7)=K(IREF(IP,JT),2)
13999 IREF(NP,8)=IREF(IP,JT)
14000 670 CONTINUE
14001
14002C...Fill information for 2 -> 1 -> 2.
14003 680 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN
14004 MINT(7)=MINT(83)+6+2*ISET(ISUB)
14005 MINT(8)=MINT(83)+7+2*ISET(ISUB)
14006 MINT(25)=KFL1(1)
14007 MINT(26)=KFL2(1)
14008 VINT(23)=CTHE(1)
14009 RM3=P(N-1,5)**2/SH
14010 RM4=P(N,5)**2/SH
14011 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
14012 VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1))
14013 VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1))
14014 VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2)
14015 VINT(47)=SQRT(VINT(48))
14016 ENDIF
14017
14018C...Possibility of colour rearrangement in W+W- events.
14019 IF((ISUB.EQ.25.OR.ISUB.EQ.22).AND.MSTP(115).GE.1) THEN
14020 IAKF1=IABS(KFL1(1))
14021 IAKF2=IABS(KFL1(2))
14022 IAKF3=IABS(KFL2(1))
14023 IAKF4=IABS(KFL2(2))
14024 IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
14025 & MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
14026 & PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
14027 ENDIF
14028
14029C...Loop back if needed.
14030 690 IF(IP.LT.NP) GOTO 150
14031
14032C...Boost back to standard frame.
14033 700 IF(IBST.EQ.1) CALL PYROBO(MINT(83)+7,N,THEIN,PHIIN,BEXIN,BEYIN,
14034 &BEZIN)
14035
14036 RETURN
14037 END
14038
14039C*********************************************************************
14040
14041C...PYMULT
14042C...Initializes treatment of multiple interactions, selects kinematics
14043C...of hardest interaction if low-pT physics included in run, and
14044C...generates all non-hardest interactions.
14045
14046 SUBROUTINE PYMULT(MMUL)
14047
14048C...Double precision and integer declarations.
14049 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14050 IMPLICIT INTEGER(I-N)
14051 INTEGER PYK,PYCHGE,PYCOMP
14052C...Commonblocks.
14053 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14054 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14055 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14056 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
14057 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14058 COMMON/PYINT1/MINT(400),VINT(400)
14059 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
14060 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
14061 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
14062 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
14063 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
14064 &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
14065C...Local arrays and saved variables.
14066 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
14067 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM
14068
14069C...Initialization of multiple interaction treatment.
14070 IF(MMUL.EQ.1) THEN
14071 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
14072 ISUB=96
14073 MINT(1)=96
14074 VINT(63)=0D0
14075 VINT(64)=0D0
14076 VINT(143)=1D0
14077 VINT(144)=1D0
14078
14079C...Loop over phase space points: xT2 choice in 20 bins.
14080 100 SIGSUM=0D0
14081 DO 120 IXT2=1,20
14082 NMUL(IXT2)=MSTP(83)
14083 SIGM(IXT2)=0D0
14084 DO 110 ITRY=1,MSTP(83)
14085 RSCA=0.05D0*((21-IXT2)-PYR(0))
14086 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
14087 XT2=MAX(0.01D0*VINT(149),XT2)
14088 VINT(25)=XT2
14089
14090C...Choose tau and y*. Calculate cos(theta-hat).
14091 IF(PYR(0).LE.COEF(ISUB,1)) THEN
14092 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
14093 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
14094 ELSE
14095 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
14096 ENDIF
14097 VINT(21)=TAU
14098 CALL PYKLIM(2)
14099 RYST=PYR(0)
14100 MYST=1
14101 IF(RYST.GT.COEF(ISUB,8)) MYST=2
14102 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
14103 CALL PYKMAP(2,MYST,PYR(0))
14104 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
14105
14106C...Calculate differential cross-section.
14107 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
14108 CALL PYSIGH(NCHN,SIGS)
14109 SIGM(IXT2)=SIGM(IXT2)+SIGS
14110 110 CONTINUE
14111 SIGSUM=SIGSUM+SIGM(IXT2)
14112 120 CONTINUE
14113 SIGSUM=SIGSUM/(20D0*MSTP(83))
14114
14115C...Reject result if sigma(parton-parton) is smaller than hadronic one.
14116 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
14117 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
14118 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
14119 PARP(82)=0.9D0*PARP(82)
14120 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
14121 & VINT(2)
14122 GOTO 100
14123 ENDIF
14124 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
14125 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
14126
14127C...Start iteration to find k factor.
14128 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
14129 SO=0.5D0
14130 XI=0D0
14131 YI=0D0
14132 XF=0D0
14133 YF=0D0
14134 XK=0.5D0
14135 IIT=0
14136 130 IF(IIT.EQ.0) THEN
14137 XK=2D0*XK
14138 ELSEIF(IIT.EQ.1) THEN
14139 XK=0.5D0*XK
14140 ELSE
14141 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
14142 ENDIF
14143
14144C...Evaluate overlap integrals.
14145 IF(MSTP(82).EQ.2) THEN
14146 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
14147 SOP=SP/PARU(1)
14148 ELSE
14149 IF(MSTP(82).EQ.3) DELTAB=0.02D0
14150 IF(MSTP(82).EQ.4) DELTAB=MIN(0.01D0,0.05D0*PARP(84))
14151 SP=0D0
14152 SOP=0D0
14153 B=-0.5D0*DELTAB
14154 140 B=B+DELTAB
14155 IF(MSTP(82).EQ.3) THEN
14156 OV=EXP(-B**2)/PARU(2)
14157 ELSE
14158 CQ2=PARP(84)**2
14159 OV=((1D0-PARP(83))**2*EXP(-MIN(50D0,B**2))+
14160 & 2D0*PARP(83)*(1D0-PARP(83))*2D0/(1D0+CQ2)*
14161 & EXP(-MIN(50D0,B**2*2D0/(1D0+CQ2)))+
14162 & PARP(83)**2/CQ2*EXP(-MIN(50D0,B**2/CQ2)))/PARU(2)
14163 ENDIF
14164 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
14165 SP=SP+PARU(2)*B*DELTAB*PACC
14166 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
14167 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
14168 ENDIF
14169 YK=PARU(1)*XK*SO/SP
14170
14171C...Continue iteration until convergence.
14172 IF(YK.LT.YKE) THEN
14173 XI=XK
14174 YI=YK
14175 IF(IIT.EQ.1) IIT=2
14176 ELSE
14177 XF=XK
14178 YF=YK
14179 IF(IIT.EQ.0) IIT=1
14180 ENDIF
14181 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
14182
14183C...Store some results for subsequent use.
14184 VINT(145)=SIGSUM
14185 VINT(146)=SOP/SO
14186 VINT(147)=SOP/SP
14187
14188C...Initialize iteration in xT2 for hardest interaction.
14189 ELSEIF(MMUL.EQ.2) THEN
14190 IF(MSTP(82).LE.0) THEN
14191 ELSEIF(MSTP(82).EQ.1) THEN
14192 XT2=1D0
14193 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
14194 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
14195 & VINT(317)/(VINT(318)*VINT(320))
14196 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
14197 ELSEIF(MSTP(82).EQ.2) THEN
14198 XT2=1D0
14199 XT2FAC=VINT(146)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
14200 & VINT(149)*(1D0+VINT(149))
14201 ELSE
14202 XC2=4D0*CKIN(3)**2/VINT(2)
14203 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
14204 ENDIF
14205
14206 ELSEIF(MMUL.EQ.3) THEN
14207C...Low-pT or multiple interactions (first semihard interaction):
14208C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
14209C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
14210 ISUB=MINT(1)
14211 IF(MSTP(82).LE.0) THEN
14212 XT2=0D0
14213 ELSEIF(MSTP(82).EQ.1) THEN
14214 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
14215 ELSEIF(MSTP(82).EQ.2) THEN
14216 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
14217 & VINT(149)))).GT.PYR(0)) XT2=1D0
14218 IF(XT2.GE.1D0) THEN
14219 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
14220 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
14221 & VINT(149)
14222 ELSE
14223 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
14224 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
14225 & VINT(149)
14226 ENDIF
14227 XT2=MAX(0.01D0*VINT(149),XT2)
14228 ELSE
14229 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
14230 & PYR(0)*(1D0-XC2))-VINT(149)
14231 XT2=MAX(0.01D0*VINT(149),XT2)
14232 ENDIF
14233 VINT(25)=XT2
14234
14235C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
14236 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
14237 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
14238 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
14239 ISUB=95
14240 MINT(1)=ISUB
14241 VINT(21)=0.01D0*VINT(149)
14242 VINT(22)=0D0
14243 VINT(23)=0D0
14244 VINT(25)=0.01D0*VINT(149)
14245
14246 ELSE
14247C...Multiple interactions (first semihard interaction).
14248C...Choose tau and y*. Calculate cos(theta-hat).
14249 IF(PYR(0).LE.COEF(ISUB,1)) THEN
14250 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
14251 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
14252 ELSE
14253 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
14254 ENDIF
14255 VINT(21)=TAU
14256 CALL PYKLIM(2)
14257 RYST=PYR(0)
14258 MYST=1
14259 IF(RYST.GT.COEF(ISUB,8)) MYST=2
14260 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
14261 CALL PYKMAP(2,MYST,PYR(0))
14262 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
14263 ENDIF
14264 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
14265
14266C...Store results of cross-section calculation.
14267 ELSEIF(MMUL.EQ.4) THEN
14268 ISUB=MINT(1)
14269 XTS=VINT(25)
14270 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
14271 IF(ISET(ISUB).EQ.2)
14272 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
14273 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
14274 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
14275 & (XTS+VINT(149))))
14276 IRBIN=INT(1D0+20D0*RBIN)
14277 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
14278 NMUL(IRBIN)=NMUL(IRBIN)+1
14279 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
14280 ENDIF
14281
14282C...Choose impact parameter.
14283 ELSEIF(MMUL.EQ.5) THEN
14284 ISUB=MINT(1)
14285 150 IF(MSTP(82).EQ.3) THEN
14286 VINT(148)=PYR(0)/(PARU(2)*VINT(147))
14287 ELSE
14288 RTYPE=PYR(0)
14289 CQ2=PARP(84)**2
14290 IF(RTYPE.LT.(1D0-PARP(83))**2) THEN
14291 B2=-LOG(PYR(0))
14292 ELSEIF(RTYPE.LT.1D0-PARP(83)**2) THEN
14293 B2=-0.5D0*(1D0+CQ2)*LOG(PYR(0))
14294 ELSE
14295 B2=-CQ2*LOG(PYR(0))
14296 ENDIF
14297 VINT(148)=((1D0-PARP(83))**2*EXP(-MIN(50D0,B2))+2D0*PARP(83)*
14298 & (1D0-PARP(83))*2D0/(1D0+CQ2)*EXP(-MIN(50D0,B2*2D0/(1D0+CQ2)))+
14299 & PARP(83)**2/CQ2*EXP(-MIN(50D0,B2/CQ2)))/(PARU(2)*VINT(147))
14300 ENDIF
14301
14302C...Multiple interactions (variable impact parameter) : reject with
14303C...probability exp(-overlap*cross-section above pT/normalization).
14304 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
14305 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
14306 DO 160 IBIN=IRBIN+1,20
14307 RNCOR=RNCOR+NMUL(IBIN)
14308 SIGCOR=SIGCOR+SIGM(IBIN)
14309 160 CONTINUE
14310 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
14311 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
14312 VINT(150)=EXP(-MIN(50D0,VINT(146)*VINT(148)*
14313 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
14314 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
14315 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
14316 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
14317 IF(VINT(150).LT.PYR(0)) GOTO 150
14318 VINT(150)=1D0
14319 ENDIF
14320
14321C...Generate additional multiple semihard interactions.
14322 ELSEIF(MMUL.EQ.6) THEN
14323 ISUBSV=MINT(1)
14324 DO 170 J=11,80
14325 VINTSV(J)=VINT(J)
14326 170 CONTINUE
14327 ISUB=96
14328 MINT(1)=96
14329 VINT(151)=0D0
14330 VINT(152)=0D0
14331
14332C...Reconstruct strings in hard scattering.
14333 NMAX=MINT(84)+4
14334 IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2
14335 IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3)
14336 NSTR=0
14337 DO 190 I=MINT(84)+1,NMAX
14338 KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
14339 IF(KCS.EQ.0) GOTO 190
14340 DO 180 J=1,4
14341 IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 180
14342 IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 180
14343 IF(J.LE.2) THEN
14344 IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
14345 ELSE
14346 IST=MOD(K(I,J+1),MSTU(5))
14347 ENDIF
14348 IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 180
14349 IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 180
14350 NSTR=NSTR+1
14351 IF(J.EQ.1.OR.J.EQ.4) THEN
14352 KSTR(NSTR,1)=I
14353 KSTR(NSTR,2)=IST
14354 ELSE
14355 KSTR(NSTR,1)=IST
14356 KSTR(NSTR,2)=I
14357 ENDIF
14358 180 CONTINUE
14359 190 CONTINUE
14360
14361C...Set up starting values for iteration in xT2.
14362 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
14363 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
14364 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
14365 & ISUBSV.NE.96)) THEN
14366 XT2=(1D0-VINT(141))*(1D0-VINT(142))
14367 ELSE
14368 XT2=VINT(25)
14369 IF(ISET(ISUBSV).EQ.1) XT2=VINT(21)
14370 IF(ISET(ISUBSV).EQ.2)
14371 & XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
14372 IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26)
14373 ENDIF
14374 IF(MSTP(82).LE.1) THEN
14375 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
14376 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
14377 & VINT(317)/(VINT(318)*VINT(320))
14378 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
14379 ELSE
14380 XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/
14381 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
14382 ENDIF
14383 VINT(63)=0D0
14384 VINT(64)=0D0
14385 VINT(143)=1D0-VINT(141)
14386 VINT(144)=1D0-VINT(142)
14387
14388C...Iterate downwards in xT2.
14389 200 IF(MSTP(82).LE.1) THEN
14390 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
14391 IF(XT2.LT.VINT(149)) GOTO 250
14392 ELSE
14393 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 250
14394 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
14395 & LOG(PYR(0)))-VINT(149)
14396 IF(XT2.LE.0D0) GOTO 250
14397 XT2=MAX(0.01D0*VINT(149),XT2)
14398 ENDIF
14399 VINT(25)=XT2
14400
14401C...Choose tau and y*. Calculate cos(theta-hat).
14402 IF(PYR(0).LE.COEF(ISUB,1)) THEN
14403 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
14404 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
14405 ELSE
14406 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
14407 ENDIF
14408 VINT(21)=TAU
14409 CALL PYKLIM(2)
14410 RYST=PYR(0)
14411 MYST=1
14412 IF(RYST.GT.COEF(ISUB,8)) MYST=2
14413 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
14414 CALL PYKMAP(2,MYST,PYR(0))
14415 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
14416
14417C...Check that x not used up. Accept or reject kinematical variables.
14418 X1M=SQRT(TAU)*EXP(VINT(22))
14419 X2M=SQRT(TAU)*EXP(-VINT(22))
14420 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 200
14421 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
14422 CALL PYSIGH(NCHN,SIGS)
14423 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
14424 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 200
14425
14426C...Reset K, P and V vectors. Select some variables.
14427 DO 220 I=N+1,N+2
14428 DO 210 J=1,5
14429 K(I,J)=0
14430 P(I,J)=0D0
14431 V(I,J)=0D0
14432 210 CONTINUE
14433 220 CONTINUE
14434 RFLAV=PYR(0)
14435 PT=0.5D0*VINT(1)*SQRT(XT2)
14436 PHI=PARU(2)*PYR(0)
14437 CTH=VINT(23)
14438
14439C...Add first parton to event record.
14440 K(N+1,1)=3
14441 K(N+1,2)=21
14442 IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
14443 & 1+INT((2D0+PARJ(2))*PYR(0))
14444 P(N+1,1)=PT*COS(PHI)
14445 P(N+1,2)=PT*SIN(PHI)
14446 P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH))
14447 P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH))
14448 P(N+1,5)=0D0
14449
14450C...Add second parton to event record.
14451 K(N+2,1)=3
14452 K(N+2,2)=21
14453 IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
14454 P(N+2,1)=-P(N+1,1)
14455 P(N+2,2)=-P(N+1,2)
14456 P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH))
14457 P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH))
14458 P(N+2,5)=0D0
14459
14460 IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
14461C....Choose relevant string pieces to place gluons on.
14462 DO 240 I=N+1,N+2
14463 DMIN=1D8
14464 DO 230 ISTR=1,NSTR
14465 I1=KSTR(ISTR,1)
14466 I2=KSTR(ISTR,2)
14467 DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
14468 & P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
14469 & P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
14470 & P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
14471 IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
14472 DMIN=DIST
14473 IST1=I1
14474 IST2=I2
14475 ISTM=ISTR
14476 ENDIF
14477 230 CONTINUE
14478
14479C....Colour flow adjustments, new string pieces.
14480 IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
14481 & MOD(K(IST1,4),MSTU(5))
14482 IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
14483 & MSTU(5)*(K(IST1,5)/MSTU(5))+I
14484 K(I,5)=MSTU(5)*IST1
14485 K(I,4)=MSTU(5)*IST2
14486 IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
14487 & MOD(K(IST2,5),MSTU(5))
14488 IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
14489 & MSTU(5)*(K(IST2,4)/MSTU(5))+I
14490 KSTR(ISTM,2)=I
14491 KSTR(NSTR+1,1)=I
14492 KSTR(NSTR+1,2)=IST2
14493 NSTR=NSTR+1
14494 240 CONTINUE
14495
14496C...String drawing and colour flow for gluon loop.
14497 ELSEIF(K(N+1,2).EQ.21) THEN
14498 K(N+1,4)=MSTU(5)*(N+2)
14499 K(N+1,5)=MSTU(5)*(N+2)
14500 K(N+2,4)=MSTU(5)*(N+1)
14501 K(N+2,5)=MSTU(5)*(N+1)
14502 KSTR(NSTR+1,1)=N+1
14503 KSTR(NSTR+1,2)=N+2
14504 KSTR(NSTR+2,1)=N+2
14505 KSTR(NSTR+2,2)=N+1
14506 NSTR=NSTR+2
14507
14508C...String drawing and colour flow for qqbar pair.
14509 ELSE
14510 K(N+1,4)=MSTU(5)*(N+2)
14511 K(N+2,5)=MSTU(5)*(N+1)
14512 KSTR(NSTR+1,1)=N+1
14513 KSTR(NSTR+1,2)=N+2
14514 NSTR=NSTR+1
14515 ENDIF
14516
14517C...Update remaining energy; iterate.
14518 N=N+2
14519 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
14520 CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
14521 IF(MSTU(21).GE.1) RETURN
14522 ENDIF
14523 MINT(31)=MINT(31)+1
14524 VINT(151)=VINT(151)+VINT(41)
14525 VINT(152)=VINT(152)+VINT(42)
14526 VINT(143)=VINT(143)-VINT(41)
14527 VINT(144)=VINT(144)-VINT(42)
14528 IF(MINT(31).LT.240) GOTO 200
14529 250 CONTINUE
14530 MINT(1)=ISUBSV
14531 DO 260 J=11,80
14532 VINT(J)=VINTSV(J)
14533 260 CONTINUE
14534 ENDIF
14535
14536C...Format statements for printout.
14537 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
14538 &'actions for MSTP(82) =',I2,' ******')
14539 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
14540 &D9.2,' mb: rejected')
14541 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
14542 &D9.2,' mb: accepted')
14543
14544 RETURN
14545 END
14546
14547C*********************************************************************
14548
14549C...PYREMN
14550C...Adds on target remnants (one or two from each side) and
14551C...includes primordial kT for hadron beams.
14552
14553 SUBROUTINE PYREMN(IPU1,IPU2)
14554
14555C...Double precision and integer declarations.
14556 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14557 IMPLICIT INTEGER(I-N)
14558 INTEGER PYK,PYCHGE,PYCOMP
14559C...Commonblocks.
14560 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14561 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14562 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14563 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14564 COMMON/PYINT1/MINT(400),VINT(400)
14565 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
14566C...Local arrays.
14567 DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
14568 &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
14569
14570C...Find event type and remaining energy.
14571 ISUB=MINT(1)
14572 NS=N
14573 IF(MINT(50).EQ.0.OR.MSTP(81).LE.0) THEN
14574 VINT(143)=1D0-VINT(141)
14575 VINT(144)=1D0-VINT(142)
14576 ENDIF
14577
14578C...Define initial partons.
14579 NTRY=0
14580 100 NTRY=NTRY+1
14581 DO 130 JT=1,2
14582 I=MINT(83)+JT+2
14583 IF(JT.EQ.1) IPU=IPU1
14584 IF(JT.EQ.2) IPU=IPU2
14585 K(I,1)=21
14586 K(I,2)=K(IPU,2)
14587 K(I,3)=I-2
14588 PMS(JT)=0D0
14589 VINT(156+JT)=0D0
14590 VINT(158+JT)=0D0
14591 IF(MINT(47).EQ.1) THEN
14592 DO 110 J=1,5
14593 P(I,J)=P(I-2,J)
14594 110 CONTINUE
14595 ELSEIF(ISUB.EQ.95) THEN
14596 K(I,2)=21
14597 ELSE
14598 P(I,5)=P(IPU,5)
14599
14600C...No primordial kT, or chosen according to truncated Gaussian or
14601C...exponential, or (for photon) predetermined or power law.
14602 120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
14603 IF(MSTP(91).LE.0) THEN
14604 PT=0D0
14605 ELSEIF(MSTP(91).EQ.1) THEN
14606 PT=PARP(91)*SQRT(-LOG(PYR(0)))
14607 ELSE
14608 RPT1=PYR(0)
14609 RPT2=PYR(0)
14610 PT=-PARP(92)*LOG(RPT1*RPT2)
14611 ENDIF
14612 IF(PT.GT.PARP(93)) GOTO 120
14613 ELSEIF(MINT(106+JT).EQ.3) THEN
14614 PTA=SQRT(VINT(282+JT))
14615 PTB=0D0
14616 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
14617 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
14618 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
14619 RPT1=PYR(0)
14620 RPT2=PYR(0)
14621 PTB=-PARP(99)*LOG(RPT1*RPT2)
14622 ENDIF
14623 IF(PTB.GT.PARP(100)) GOTO 120
14624 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
14625 PT=PT*0.8D0**MINT(57)
14626 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
14627 ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN
14628 IF(MSTP(93).LE.0) THEN
14629 PT=0D0
14630 ELSEIF(MSTP(93).EQ.1) THEN
14631 PT=PARP(99)*SQRT(-LOG(PYR(0)))
14632 ELSEIF(MSTP(93).EQ.2) THEN
14633 RPT1=PYR(0)
14634 RPT2=PYR(0)
14635 PT=-PARP(99)*LOG(RPT1*RPT2)
14636 ELSEIF(MSTP(93).EQ.3) THEN
14637 HA=PARP(99)**2
14638 HB=PARP(100)**2
14639 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
14640 ELSE
14641 HA=PARP(99)**2
14642 HB=PARP(100)**2
14643 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
14644 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
14645 ENDIF
14646 IF(PT.GT.PARP(100)) GOTO 120
14647 ELSE
14648 PT=0D0
14649 ENDIF
14650 VINT(156+JT)=PT
14651 PHI=PARU(2)*PYR(0)
14652 P(I,1)=PT*COS(PHI)
14653 P(I,2)=PT*SIN(PHI)
14654 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
14655 ENDIF
14656 130 CONTINUE
14657 IF(MINT(47).EQ.1) RETURN
14658
14659C...Kinematics construction for initial partons.
14660 I1=MINT(83)+3
14661 I2=MINT(83)+4
14662 IF(ISUB.EQ.95) THEN
14663 SHS=0D0
14664 SHR=0D0
14665 ELSE
14666 SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+
14667 & (P(I1,2)+P(I2,2))**2
14668 SHR=SQRT(MAX(0D0,SHS))
14669 IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100
14670 P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR)
14671 P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1)))
14672 P(I2,4)=SHR-P(I1,4)
14673 P(I2,3)=-P(I1,3)
14674
14675C...Transform partons to overall CM-frame.
14676 ROBO(3)=(P(I1,1)+P(I2,1))/SHR
14677 ROBO(4)=(P(I1,2)+P(I2,2))/SHR
14678 CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0)
14679 ROBO(2)=PYANGL(P(I1,1),P(I1,2))
14680 CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0)
14681 ROBO(1)=PYANGL(P(I1,3),P(I1,1))
14682 CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0)
14683 CALL PYROBO(I2+1,MINT(52),0D0,-ROBO(2),0D0,0D0,0D0)
14684 CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0)
14685 ROBO(5)=(VINT(141)-VINT(142))/(VINT(141)+VINT(142))
14686 CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5))
14687 ENDIF
14688
14689C...Optionally fix up x and Q2 definitions for leptoproduction.
14690 IDISXQ=0
14691 IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND.
14692 &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1
14693 IF(IDISXQ.EQ.1) THEN
14694
14695C...Find where incoming and outgoing leptons/partons are sitting.
14696 LESD=1
14697 IF(MINT(42).EQ.1) LESD=2
14698 LPIN=MINT(83)+3-LESD
14699 LEIN=MINT(84)+LESD
14700 LQIN=MINT(84)+3-LESD
14701 LEOUT=MINT(84)+2+LESD
14702 LQOUT=MINT(84)+5-LESD
14703 IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3)
14704 IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3)
14705 LSCMS=0
14706 DO 140 I=MINT(84)+5,N
14707 IF(K(I,2).EQ.94) THEN
14708 LSCMS=I
14709 LEOUT=I+LESD
14710 LQOUT=I+3-LESD
14711 ENDIF
14712 140 CONTINUE
14713 LQBG=IPU1
14714 IF(LESD.EQ.1) LQBG=IPU2
14715
14716C...Calculate actual and wanted momentum transfer.
14717 XNOM=VINT(43-LESD)
14718 Q2NOM=-VINT(45)
14719 HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)-
14720 & P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))*
14721 & (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4))
14722 HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK)))
14723 FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2))
14724 P(N+1,1)=FAC*P(LEOUT,1)
14725 P(N+1,2)=FAC*P(LEOUT,2)
14726 P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)-
14727 & Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1)
14728 P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+
14729 & P(N+1,3)**2)
14730 DO 150 J=1,4
14731 QOLD(J)=P(LEIN,J)-P(LEOUT,J)
14732 QNEW(J)=P(LEIN,J)-P(N+1,J)
14733 150 CONTINUE
14734
14735C...Boost outgoing electron and daughters.
14736 IF(LSCMS.EQ.0) THEN
14737 DO 160 J=1,4
14738 P(LEOUT,J)=P(N+1,J)
14739 160 CONTINUE
14740 ELSE
14741 DO 170 J=1,3
14742 P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4))
14743 170 CONTINUE
14744 PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2)
14745 DO 180 J=1,3
14746 DBE(J)=PINV*P(N+2,J)
14747 180 CONTINUE
14748 DO 200 I=LSCMS+1,N
14749 IORIG=I
14750 190 IORIG=K(IORIG,3)
14751 IF(IORIG.GT.LEOUT) GOTO 190
14752 IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT)
14753 & CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3))
14754 200 CONTINUE
14755 ENDIF
14756
14757C...Copy shower initiator and all outgoing partons.
14758 NCOP=N+1
14759 K(NCOP,3)=LQBG
14760 DO 210 J=1,5
14761 P(NCOP,J)=P(LQBG,J)
14762 210 CONTINUE
14763 DO 240 I=MINT(84)+1,N
14764 ICOP=0
14765 IF(K(I,1).GT.10) GOTO 240
14766 IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN
14767 ICOP=I
14768 ELSE
14769 IORIG=I
14770 220 IORIG=K(IORIG,3)
14771 IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN
14772 ICOP=IORIG
14773 ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN
14774 GOTO 220
14775 ENDIF
14776 ENDIF
14777 IF(ICOP.NE.0) THEN
14778 NCOP=NCOP+1
14779 K(NCOP,3)=I
14780 DO 230 J=1,5
14781 P(NCOP,J)=P(I,J)
14782 230 CONTINUE
14783 ENDIF
14784 240 CONTINUE
14785
14786C...Calculate relative rescaling factors.
14787 SLC=3-2*LESD
14788 PLCSUM=0D0
14789 DO 250 I=N+2,NCOP
14790 PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3))
14791 250 CONTINUE
14792 DO 260 I=N+2,NCOP
14793 V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM
14794 260 CONTINUE
14795
14796C...Transfer extra three-momentum of current.
14797 DO 280 I=N+2,NCOP
14798 DO 270 J=1,3
14799 P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J))
14800 270 CONTINUE
14801 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
14802 280 CONTINUE
14803
14804C...Iterate change of initiator momentum to get energy right.
14805 ITER=0
14806 290 ITER=ITER+1
14807 PEEX=-P(N+1,4)-QNEW(4)
14808 PEMV=-P(N+1,3)/P(N+1,4)
14809 DO 300 I=N+2,NCOP
14810 PEEX=PEEX+P(I,4)
14811 PEMV=PEMV+V(I,1)*P(I,3)/P(I,4)
14812 300 CONTINUE
14813 IF(ABS(PEMV).LT.1D-10) THEN
14814 MINT(51)=1
14815 MINT(57)=MINT(57)+1
14816 RETURN
14817 ENDIF
14818 PZCH=-PEEX/PEMV
14819 P(N+1,3)=P(N+1,3)+PZCH
14820 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)
14821 DO 310 I=N+2,NCOP
14822 P(I,3)=P(I,3)+V(I,1)*PZCH
14823 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
14824 310 CONTINUE
14825 IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290
14826
14827C...Modify momenta in event record.
14828 HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/
14829 & ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2)
14830 IF(ABS(HBE).GE.1D0) THEN
14831 MINT(51)=1
14832 MINT(57)=MINT(57)+1
14833 RETURN
14834 ENDIF
14835 I=MINT(83)+5-LESD
14836 CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE)
14837 DO 330 I=N+1,NCOP
14838 ICOP=K(I,3)
14839 DO 320 J=1,4
14840 P(ICOP,J)=P(I,J)
14841 320 CONTINUE
14842 330 CONTINUE
14843 ENDIF
14844
14845C...Check minimum invariant mass of remnant system(s).
14846 PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152))
14847 PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152))
14848 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
14849 PMIN(0)=SQRT(PMS(0))
14850 DO 340 JT=1,2
14851 PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT)
14852 PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1)
14853 PMIN(JT)=0D0
14854 IF(MINT(44+JT).EQ.1) GOTO 340
14855 MINT(105)=MINT(102+JT)
14856 MINT(109)=MINT(106+JT)
14857 CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
14858 IF(MINT(51).NE.0) THEN
14859 MINT(57)=MINT(57)+1
14860 RETURN
14861 ENDIF
14862 IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT))
14863 IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT))
14864 IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111)
14865 PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+
14866 & P(MINT(83)+JT+2,2)**2)
14867 340 CONTINUE
14868 IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND.
14869 &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT.
14870 &PSYS(2,4))) THEN
14871 MINT(51)=1
14872 MINT(57)=MINT(57)+1
14873 RETURN
14874 ENDIF
14875
14876C...Loop over two remnants; skip if none there.
14877 I=NS
14878 DO 410 JT=1,2
14879 ISN(JT)=0
14880 IF(MINT(44+JT).EQ.1) GOTO 410
14881 IF(JT.EQ.1) IPU=IPU1
14882 IF(JT.EQ.2) IPU=IPU2
14883
14884C...Store first remnant parton.
14885 I=I+1
14886 IS(JT)=I
14887 ISN(JT)=1
14888 DO 350 J=1,5
14889 K(I,J)=0
14890 P(I,J)=0D0
14891 V(I,J)=0D0
14892 350 CONTINUE
14893 K(I,1)=1
14894 K(I,2)=KFLSP(JT)
14895 K(I,3)=MINT(83)+JT
14896 P(I,5)=PYMASS(K(I,2))
14897
14898C...First parton colour connections and kinematics.
14899 KCOL=KCHG(PYCOMP(KFLSP(JT)),2)
14900 IF(KCOL.EQ.2) THEN
14901 K(I,1)=3
14902 K(I,4)=MSTU(5)*IPU+IPU
14903 K(I,5)=MSTU(5)*IPU+IPU
14904 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
14905 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
14906 ELSEIF(KCOL.NE.0) THEN
14907 K(I,1)=3
14908 KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2
14909 K(I,KFLS+3)=IPU
14910 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
14911 ENDIF
14912 IF(KFLCH(JT).EQ.0) THEN
14913 P(I,1)=-P(MINT(83)+JT+2,1)
14914 P(I,2)=-P(MINT(83)+JT+2,2)
14915 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
14916 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
14917 P(I,3)=PSYS(JT,3)
14918 P(I,4)=PSYS(JT,4)
14919
14920C...When extra remnant parton or hadron: store extra remnant.
14921 ELSE
14922 I=I+1
14923 ISN(JT)=2
14924 DO 360 J=1,5
14925 K(I,J)=0
14926 P(I,J)=0D0
14927 V(I,J)=0D0
14928 360 CONTINUE
14929 K(I,1)=1
14930 K(I,2)=KFLCH(JT)
14931 K(I,3)=MINT(83)+JT
14932 P(I,5)=PYMASS(K(I,2))
14933
14934C...Find parton colour connections of extra remnant.
14935 KCOL=KCHG(PYCOMP(KFLCH(JT)),2)
14936 IF(KCOL.EQ.2) THEN
14937 K(I,1)=3
14938 K(I,4)=MSTU(5)*IPU+IPU
14939 K(I,5)=MSTU(5)*IPU+IPU
14940 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
14941 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
14942 ELSEIF(KCOL.NE.0) THEN
14943 K(I,1)=3
14944 KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2
14945 K(I,KFLS+3)=IPU
14946 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
14947 ENDIF
14948
14949C...Relative transverse momentum when two remnants.
14950 LOOP=0
14951 370 LOOP=LOOP+1
14952 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
14953 IF(IABS(MINT(10+JT)).LT.20) THEN
14954 P(I-1,1)=0D0
14955 P(I-1,2)=0D0
14956 ELSE
14957 P(I-1,1)=P(I-1,1)-0.5D0*P(MINT(83)+JT+2,1)
14958 P(I-1,2)=P(I-1,2)-0.5D0*P(MINT(83)+JT+2,2)
14959 ENDIF
14960 PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
14961 P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
14962 P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
14963 PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
14964
14965C...Meson or baryon; photon as meson. For splitup below.
14966 IMB=1
14967 IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
14968
14969C***Relative distribution for electron into two electrons. Temporary!
14970 IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT))
14971 & THEN
14972 CHI(JT)=PYR(0)
14973
14974C...Relative distribution of electron energy into electron plus parton.
14975 ELSEIF(IABS(MINT(10+JT)).LT.20) THEN
14976 XHRD=VINT(140+JT)
14977 XE=VINT(154+JT)
14978 CHI(JT)=(XE-XHRD)/(1D0-XHRD)
14979
14980C...Relative distribution of energy for particle into two jets.
14981 ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
14982 CHIK=PARP(92+2*IMB)
14983 IF(MSTP(92).LE.1) THEN
14984 IF(IMB.EQ.1) CHI(JT)=PYR(0)
14985 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
14986 ELSEIF(MSTP(92).EQ.2) THEN
14987 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK))
14988 ELSEIF(MSTP(92).EQ.3) THEN
14989 CUT=2D0*0.3D0/VINT(1)
14990 380 CHI(JT)=PYR(0)**2
14991 IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0*
14992 & (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380
14993 ELSEIF(MSTP(92).EQ.4) THEN
14994 CUT=2D0*0.3D0/VINT(1)
14995 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
14996 390 CHIR=CUT*CUTR**PYR(0)
14997 CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR)
14998 IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390
14999 ELSE
15000 CUT=2D0*0.3D0/VINT(1)
15001 CUTA=CUT**(1D0-PARP(98))
15002 CUTB=(1D0+CUT)**(1D0-PARP(98))
15003 400 CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
15004 IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))**
15005 & (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400
15006 ENDIF
15007
15008C...Relative distribution of energy for particle into jet plus particle.
15009 ELSE
15010 IF(MSTP(94).LE.1) THEN
15011 IF(IMB.EQ.1) CHI(JT)=PYR(0)
15012 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
15013 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
15014 ELSEIF(MSTP(94).EQ.2) THEN
15015 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
15016 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
15017 ELSEIF(MSTP(94).EQ.3) THEN
15018 CALL PYZDIS(1,0,PMS(JT+4),ZZ)
15019 CHI(JT)=ZZ
15020 ELSE
15021 CALL PYZDIS(1000,0,PMS(JT+4),ZZ)
15022 CHI(JT)=ZZ
15023 ENDIF
15024 ENDIF
15025
15026C...Construct total transverse mass; reject if too large.
15027 CHI(JT)=MAX(1D-8,MIN(1D0-1D-8,CHI(JT)))
15028 PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT))
15029 IF(PMS(JT).GT.PSYS(JT,4)**2) THEN
15030 IF(LOOP.LT.100) THEN
15031 GOTO 370
15032 ELSE
15033 MINT(51)=1
15034 MINT(57)=MINT(57)+1
15035 RETURN
15036 ENDIF
15037 ENDIF
15038 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
15039 VINT(158+JT)=CHI(JT)
15040
15041C...Subdivide longitudinal momentum according to value selected above.
15042 PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3)))
15043 P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1)
15044 P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
15045 P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4)
15046 P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3)
15047 ENDIF
15048 410 CONTINUE
15049 N=I
15050
15051C...Check if longitudinal boosts needed - if so pick two systems.
15052 PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+
15053 &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3))
15054 IF(PDEV.LE.1D-6*VINT(1)) RETURN
15055 IF(ISN(1).EQ.0) THEN
15056 IR=0
15057 IL=2
15058 ELSEIF(ISN(2).EQ.0) THEN
15059 IR=1
15060 IL=0
15061 ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN
15062 IR=1
15063 IL=2
15064 ELSEIF(VINT(143).GT.0.2D0) THEN
15065 IR=1
15066 IL=0
15067 ELSEIF(VINT(144).GT.0.2D0) THEN
15068 IR=0
15069 IL=2
15070 ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN
15071 IR=1
15072 IL=0
15073 ELSE
15074 IR=0
15075 IL=2
15076 ENDIF
15077 IG=3-IR-IL
15078
15079C...E+-pL wanted for system to be modified.
15080 IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN
15081 PPB=VINT(1)
15082 PNB=VINT(1)
15083 ELSE
15084 PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3))
15085 PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3))
15086 ENDIF
15087
15088C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
15089 IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN
15090 PPB=PPB-(PSYS(0,4)+PSYS(0,3))
15091 PNB=PNB-(PSYS(0,4)-PSYS(0,3))
15092 DO 420 J=1,4
15093 PSYS(0,J)=0D0
15094 420 CONTINUE
15095 DO 450 I=MINT(84)+1,NS
15096 IF(K(I,1).GT.10) GOTO 450
15097 INCL=0
15098 IORIG=I
15099 430 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
15100 IORIG=K(IORIG,3)
15101 IF(IORIG.GT.LPIN) GOTO 430
15102 IF(INCL.EQ.0) GOTO 450
15103 DO 440 J=1,4
15104 PSYS(0,J)=PSYS(0,J)+P(I,J)
15105 440 CONTINUE
15106 450 CONTINUE
15107 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
15108 PPB=PPB+(PSYS(0,4)+PSYS(0,3))
15109 PNB=PNB+(PSYS(0,4)-PSYS(0,3))
15110 ENDIF
15111
15112C...Construct longitudinal boosts.
15113 DPMTB=PPB*PNB
15114 DPMTR=PMS(IR)
15115 DPMTL=PMS(IL)
15116 DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL))
15117 IF(DSQLAM.LE.1D-6*DPMTB) THEN
15118 MINT(51)=1
15119 MINT(57)=MINT(57)+1
15120 RETURN
15121 ENDIF
15122 DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
15123 DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/
15124 &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB)
15125 DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/
15126 &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB)
15127 DBER=(DRKR**2-1D0)/(DRKR**2+1D0)
15128 DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0)
15129
15130C...Perform longitudinal boosts.
15131 IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN
15132 P(IS(1),3)=0D0
15133 P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2)
15134 ELSEIF(IR.EQ.1) THEN
15135 CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER)
15136 ELSEIF(IDISXQ.EQ.1) THEN
15137 DO 470 I=I1,NS
15138 INCL=0
15139 IORIG=I
15140 460 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
15141 IORIG=K(IORIG,3)
15142 IF(IORIG.GT.LPIN) GOTO 460
15143 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER)
15144 470 CONTINUE
15145 ELSE
15146 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER)
15147 ENDIF
15148 IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN
15149 P(IS(2),3)=0D0
15150 P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2)
15151 ELSEIF(IL.EQ.2) THEN
15152 CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL)
15153 ELSEIF(IDISXQ.EQ.1) THEN
15154 DO 490 I=I1,NS
15155 INCL=0
15156 IORIG=I
15157 480 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
15158 IORIG=K(IORIG,3)
15159 IF(IORIG.GT.LPIN) GOTO 480
15160 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL)
15161 490 CONTINUE
15162 ELSE
15163 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL)
15164 ENDIF
15165
15166C...Final check that energy-momentum conservation worked.
15167 PESUM=0D0
15168 PZSUM=0D0
15169 DO 500 I=MINT(84)+1,N
15170 IF(K(I,1).GT.10) GOTO 500
15171 PESUM=PESUM+P(I,4)
15172 PZSUM=PZSUM+P(I,3)
15173 500 CONTINUE
15174 PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM)
15175 IF(PDEV.GT.1D-4*VINT(1)) THEN
15176 MINT(51)=1
15177 MINT(57)=MINT(57)+1
15178 RETURN
15179 ENDIF
15180
15181C...Calculate rotation and boost from overall CM frame to
15182C...hadronic CM frame in leptoproduction.
15183 MINT(91)=0
15184 IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
15185 MINT(91)=1
15186 LESD=1
15187 IF(MINT(42).EQ.1) LESD=2
15188 LPIN=MINT(83)+3-LESD
15189
15190C...Sum upp momenta of everything not lepton or photon to define boost.
15191 DO 510 J=1,4
15192 PSUM(J)=0D0
15193 510 CONTINUE
15194 DO 530 I=1,N
15195 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
15196 IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
15197 IF(K(I,2).EQ.22) GOTO 530
15198 DO 520 J=1,4
15199 PSUM(J)=PSUM(J)+P(I,J)
15200 520 CONTINUE
15201 530 CONTINUE
15202 VINT(223)=-PSUM(1)/PSUM(4)
15203 VINT(224)=-PSUM(2)/PSUM(4)
15204 VINT(225)=-PSUM(3)/PSUM(4)
15205
15206C...Boost incoming hadron to hadronic CM frame to determine rotations.
15207 K(N+1,1)=1
15208 DO 540 J=1,5
15209 P(N+1,J)=P(LPIN,J)
15210 V(N+1,J)=V(LPIN,J)
15211 540 CONTINUE
15212 CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
15213 VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
15214 CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
15215 IF(LESD.EQ.2) THEN
15216 VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
15217 ELSE
15218 VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
15219 ENDIF
15220 ENDIF
15221
15222 RETURN
15223 END
15224
15225C*********************************************************************
15226
15227C...PYDIFF
15228C...Handles diffractive and elastic scattering.
15229
15230 SUBROUTINE PYDIFF
15231
15232C...Double precision and integer declarations.
15233 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15234 IMPLICIT INTEGER(I-N)
15235 INTEGER PYK,PYCHGE,PYCOMP
15236C...Commonblocks.
15237 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15238 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15239 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15240 COMMON/PYINT1/MINT(400),VINT(400)
15241 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
15242
15243C...Reset K, P and V vectors. Store incoming particles.
15244 DO 110 JT=1,MSTP(126)+10
15245 I=MINT(83)+JT
15246 DO 100 J=1,5
15247 K(I,J)=0
15248 P(I,J)=0D0
15249 V(I,J)=0D0
15250 100 CONTINUE
15251 110 CONTINUE
15252 N=MINT(84)
15253 MINT(3)=0
15254 MINT(21)=0
15255 MINT(22)=0
15256 MINT(23)=0
15257 MINT(24)=0
15258 MINT(4)=4
15259 DO 130 JT=1,2
15260 I=MINT(83)+JT
15261 K(I,1)=21
15262 K(I,2)=MINT(10+JT)
15263 DO 120 J=1,5
15264 P(I,J)=VINT(285+5*JT+J)
15265 120 CONTINUE
15266 130 CONTINUE
15267 MINT(6)=2
15268
15269C...Subprocess; kinematics.
15270 SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64)
15271 PZ=SQRT(SQLAM)/(2D0*VINT(1))
15272 DO 200 JT=1,2
15273 I=MINT(83)+JT
15274 PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1))
15275 KFH=MINT(102+JT)
15276
15277C...Elastically scattered particle. (Except elastic GVMD states.)
15278 IF(MINT(16+JT).LE.0.AND.(MINT(10+JT).NE.22.OR.
15279 & MINT(106+JT).NE.3)) THEN
15280 N=N+1
15281 K(N,1)=1
15282 K(N,2)=KFH
15283 K(N,3)=I+2
15284 P(N,3)=PZ*(-1)**(JT+1)
15285 P(N,4)=PE
15286 P(N,5)=SQRT(VINT(62+JT))
15287
15288C...Decay rho from elastic scattering of gamma with sin**2(theta)
15289C...distribution of decay products (in rho rest frame).
15290 IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN
15291 NSAV=N
15292 DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2)
15293 P(N,3)=0D0
15294 P(N,4)=P(N,5)
15295 CALL PYDECY(NSAV)
15296 IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN
15297 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
15298 CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0)
15299 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
15300 CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0)
15301 140 CTHE=2D0*PYR(0)-1D0
15302 IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140
15303 CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0)
15304 ENDIF
15305 CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ)
15306 ENDIF
15307
15308C...Diffracted particle: low-mass system to two particles.
15309 ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN
15310 N=N+2
15311 K(N-1,1)=1
15312 K(N,1)=1
15313 K(N-1,3)=I+2
15314 K(N,3)=I+2
15315 PMMAS=SQRT(VINT(62+JT))
15316 NTRY=0
15317 150 NTRY=NTRY+1
15318 IF(NTRY.LT.20) THEN
15319 MINT(105)=MINT(102+JT)
15320 MINT(109)=MINT(106+JT)
15321 CALL PYSPLI(KFH,21,KFL1,KFL2)
15322 CALL PYKFDI(KFL1,0,KFL3,KF1)
15323 IF(KF1.EQ.0) GOTO 150
15324 CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2)
15325 IF(KF2.EQ.0) GOTO 150
15326 ELSE
15327 KF1=KFH
15328 KF2=111
15329 ENDIF
15330 PM1=PYMASS(KF1)
15331 PM2=PYMASS(KF2)
15332 IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150
15333 K(N-1,2)=KF1
15334 K(N,2)=KF2
15335 P(N-1,5)=PM1
15336 P(N,5)=PM2
15337 PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2-
15338 & 4D0*PM1**2*PM2**2))/(2D0*PMMAS)
15339 P(N-1,3)=PZP
15340 P(N,3)=-PZP
15341 P(N-1,4)=SQRT(PM1**2+PZP**2)
15342 P(N,4)=SQRT(PM2**2+PZP**2)
15343 CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0),
15344 & 0D0,0D0,0D0)
15345 DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2)
15346 CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ)
15347
15348C...Diffracted particle: valence quark kicked out.
15349 ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT.
15350 & PARP(101))) THEN
15351 N=N+2
15352 K(N-1,1)=2
15353 K(N,1)=1
15354 K(N-1,3)=I+2
15355 K(N,3)=I+2
15356 MINT(105)=MINT(102+JT)
15357 MINT(109)=MINT(106+JT)
15358 CALL PYSPLI(KFH,21,K(N,2),K(N-1,2))
15359 P(N-1,5)=PYMASS(K(N-1,2))
15360 P(N,5)=PYMASS(K(N,2))
15361 SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
15362 & 4D0*P(N-1,5)**2*P(N,5)**2
15363 P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
15364 & P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1)
15365 P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
15366 P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
15367 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
15368
15369C...Diffracted particle: gluon kicked out.
15370 ELSE
15371 N=N+3
15372 K(N-2,1)=2
15373 K(N-1,1)=2
15374 K(N,1)=1
15375 K(N-2,3)=I+2
15376 K(N-1,3)=I+2
15377 K(N,3)=I+2
15378 MINT(105)=MINT(102+JT)
15379 MINT(109)=MINT(106+JT)
15380 CALL PYSPLI(KFH,21,K(N,2),K(N-2,2))
15381 K(N-1,2)=21
15382 P(N-2,5)=PYMASS(K(N-2,2))
15383 P(N-1,5)=0D0
15384 P(N,5)=PYMASS(K(N,2))
15385C...Energy distribution for particle into two jets.
15386 160 IMB=1
15387 IF(MOD(KFH/1000,10).NE.0) IMB=2
15388 CHIK=PARP(92+2*IMB)
15389 IF(MSTP(92).LE.1) THEN
15390 IF(IMB.EQ.1) CHI=PYR(0)
15391 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
15392 ELSEIF(MSTP(92).EQ.2) THEN
15393 CHI=1D0-PYR(0)**(1D0/(1D0+CHIK))
15394 ELSEIF(MSTP(92).EQ.3) THEN
15395 CUT=2D0*0.3D0/VINT(1)
15396 170 CHI=PYR(0)**2
15397 IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT.
15398 & PYR(0)) GOTO 170
15399 ELSEIF(MSTP(92).EQ.4) THEN
15400 CUT=2D0*0.3D0/VINT(1)
15401 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
15402 180 CHIR=CUT*CUTR**PYR(0)
15403 CHI=(CHIR**2-CUT**2)/(2D0*CHIR)
15404 IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180
15405 ELSE
15406 CUT=2D0*0.3D0/VINT(1)
15407 CUTA=CUT**(1D0-PARP(98))
15408 CUTB=(1D0+CUT)**(1D0-PARP(98))
15409 190 CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
15410 IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))**
15411 & (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
15412 ENDIF
15413 IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/
15414 & VINT(62+JT)) GOTO 160
15415 SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI
15416 PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
15417 & (2D0*VINT(62+JT))
15418 PEI=SQRT(PZI**2+SQM)
15419 PQQP=(1D0-CHI)*(PEI+PZI)
15420 P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
15421 P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
15422 P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
15423 P(N-1,3)=P(N-1,4)*(-1)**JT
15424 P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
15425 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
15426 ENDIF
15427
15428C...Documentation lines.
15429 K(I+2,1)=21
15430 IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
15431 IF(MINT(16+JT).NE.0.OR.(MINT(10+JT).EQ.22.AND.
15432 & MINT(106+JT).EQ.3)) K(I+2,2)=ISIGN(9900000,KFH)+10*(KFH/10)
15433 K(I+2,3)=I
15434 P(I+2,3)=PZ*(-1)**(JT+1)
15435 P(I+2,4)=PE
15436 P(I+2,5)=SQRT(VINT(62+JT))
15437 200 CONTINUE
15438
15439C...Rotate outgoing partons/particles using cos(theta).
15440 IF(VINT(23).LT.0.9D0) THEN
15441 CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
15442 ELSE
15443 CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
15444 ENDIF
15445
15446 RETURN
15447 END
15448
15449C*********************************************************************
15450
15451C...PYDISG
15452C...Set up a DIS process as gamma* + f -> f, with beam remnant
15453C...and showering added consecutively. Photon flux by the PYGAGA
15454C...routine (if at all).
15455
15456 SUBROUTINE PYDISG
15457
15458C...Double precision and integer declarations.
15459 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15460 IMPLICIT INTEGER(I-N)
15461 INTEGER PYK,PYCHGE,PYCOMP
15462C...Parameter statement to help give large particle numbers.
15463 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
15464 &KEXCIT=4000000,KDIMEN=5000000)
15465C...Commonblocks.
15466 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15467 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15468 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15469 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
15470 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15471 COMMON/PYINT1/MINT(400),VINT(400)
15472 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
15473C...Local arrays.
15474 DIMENSION PMS(4)
15475
15476C...Choice of subprocess, number of documentation lines
15477 IDOC=7
15478 MINT(3)=IDOC-6
15479 MINT(4)=IDOC
15480 IPU1=MINT(84)+1
15481 IPU2=MINT(84)+2
15482 IPU3=MINT(84)+3
15483 ISIDE=1
15484 IF(MINT(107).EQ.4) ISIDE=2
15485
15486C...Reset K, P and V vectors. Store incoming particles
15487 DO 110 JT=1,MSTP(126)+20
15488 I=MINT(83)+JT
15489 DO 100 J=1,5
15490 K(I,J)=0
15491 P(I,J)=0D0
15492 V(I,J)=0D0
15493 100 CONTINUE
15494 110 CONTINUE
15495 DO 130 JT=1,2
15496 I=MINT(83)+JT
15497 K(I,1)=21
15498 K(I,2)=MINT(10+JT)
15499 DO 120 J=1,5
15500 P(I,J)=VINT(285+5*JT+J)
15501 120 CONTINUE
15502 130 CONTINUE
15503 MINT(6)=2
15504
15505C...Store incoming partons in hadronic CM-frame
15506 DO 140 JT=1,2
15507 I=MINT(84)+JT
15508 K(I,1)=14
15509 K(I,2)=MINT(14+JT)
15510 K(I,3)=MINT(83)+2+JT
15511 140 CONTINUE
15512 IF(MINT(15).EQ.22) THEN
15513 P(MINT(84)+1,3)=0.5D0*(VINT(1)+VINT(307)/VINT(1))
15514 P(MINT(84)+1,4)=0.5D0*(VINT(1)-VINT(307)/VINT(1))
15515 P(MINT(84)+1,5)=-SQRT(VINT(307))
15516 P(MINT(84)+2,3)=-0.5D0*VINT(307)/VINT(1)
15517 P(MINT(84)+2,4)=0.5D0*VINT(307)/VINT(1)
15518 KFRES=MINT(16)
15519 ISIDE=2
15520 ELSE
15521 P(MINT(84)+1,3)=0.5D0*VINT(308)/VINT(1)
15522 P(MINT(84)+1,4)=0.5D0*VINT(308)/VINT(1)
15523 P(MINT(84)+2,3)=-0.5D0*(VINT(1)+VINT(308)/VINT(1))
15524 P(MINT(84)+2,4)=0.5D0*(VINT(1)-VINT(308)/VINT(1))
15525 P(MINT(84)+1,5)=-SQRT(VINT(308))
15526 KFRES=MINT(15)
15527 ISIDE=1
15528 ENDIF
15529 SIDESG=(-1D0)**(ISIDE-1)
15530
15531C...Copy incoming partons to documentation lines.
15532 DO 170 JT=1,2
15533 I1=MINT(83)+4+JT
15534 I2=MINT(84)+JT
15535 K(I1,1)=21
15536 K(I1,2)=K(I2,2)
15537 K(I1,3)=I1-2
15538 DO 150 J=1,5
15539 P(I1,J)=P(I2,J)
15540 150 CONTINUE
15541
15542C...Second copy for partons before ISR shower, since no such.
15543 I1=MINT(83)+2+JT
15544 K(I1,1)=21
15545 K(I1,2)=K(I2,2)
15546 K(I1,3)=I1-2
15547 DO 160 J=1,5
15548 P(I1,J)=P(I2,J)
15549 160 CONTINUE
15550 170 CONTINUE
15551
15552C...Define initial partons.
15553 NTRY=0
15554 180 NTRY=NTRY+1
15555 IF(NTRY.GT.100) THEN
15556 MINT(51)=1
15557 RETURN
15558 ENDIF
15559
15560C...Scattered quark in hadronic CM frame.
15561 I=MINT(83)+7
15562 K(IPU3,1)=3
15563 K(IPU3,2)=KFRES
15564 K(IPU3,3)=I
15565 P(IPU3,5)=PYMASS(KFRES)
15566 P(IPU3,3)=P(IPU1,3)+P(IPU2,3)
15567 P(IPU3,4)=P(IPU1,4)+P(IPU2,4)
15568 P(IPU3,5)=0D0
15569 K(I,1)=21
15570 K(I,2)=KFRES
15571 K(I,3)=MINT(83)+4+ISIDE
15572 P(I,3)=P(IPU3,3)
15573 P(I,4)=P(IPU3,4)
15574 P(I,5)=P(IPU3,5)
15575 N=IPU3
15576 MINT(21)=KFRES
15577 MINT(22)=0
15578
15579C...No primordial kT, or chosen according to truncated Gaussian or
15580C...exponential, or (for photon) predetermined or power law.
15581 190 IF(MINT(40+ISIDE).EQ.2.AND.MINT(10+ISIDE).NE.22) THEN
15582 IF(MSTP(91).LE.0) THEN
15583 PT=0D0
15584 ELSEIF(MSTP(91).EQ.1) THEN
15585 PT=PARP(91)*SQRT(-LOG(PYR(0)))
15586 ELSE
15587 RPT1=PYR(0)
15588 RPT2=PYR(0)
15589 PT=-PARP(92)*LOG(RPT1*RPT2)
15590 ENDIF
15591 IF(PT.GT.PARP(93)) GOTO 190
15592 ELSEIF(MINT(106+ISIDE).EQ.3) THEN
15593 PTA=SQRT(VINT(282+ISIDE))
15594 PTB=0D0
15595 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
15596 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
15597 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
15598 RPT1=PYR(0)
15599 RPT2=PYR(0)
15600 PTB=-PARP(99)*LOG(RPT1*RPT2)
15601 ENDIF
15602 IF(PTB.GT.PARP(100)) GOTO 190
15603 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
15604 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
15605 ELSEIF(IABS(MINT(14+ISIDE)).LE.8.OR.MINT(14+ISIDE).EQ.21) THEN
15606 IF(MSTP(93).LE.0) THEN
15607 PT=0D0
15608 ELSEIF(MSTP(93).EQ.1) THEN
15609 PT=PARP(99)*SQRT(-LOG(PYR(0)))
15610 ELSEIF(MSTP(93).EQ.2) THEN
15611 RPT1=PYR(0)
15612 RPT2=PYR(0)
15613 PT=-PARP(99)*LOG(RPT1*RPT2)
15614 ELSEIF(MSTP(93).EQ.3) THEN
15615 HA=PARP(99)**2
15616 HB=PARP(100)**2
15617 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
15618 ELSE
15619 HA=PARP(99)**2
15620 HB=PARP(100)**2
15621 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
15622 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
15623 ENDIF
15624 IF(PT.GT.PARP(100)) GOTO 190
15625 ELSE
15626 PT=0D0
15627 ENDIF
15628 VINT(156+ISIDE)=PT
15629 PHI=PARU(2)*PYR(0)
15630 P(IPU3,1)=PT*COS(PHI)
15631 P(IPU3,2)=PT*SIN(PHI)
15632 P(IPU3,4)=SQRT(P(IPU3,5)**2+PT**2+P(IPU3,3)**2)
15633 PMS(3-ISIDE)=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
15634 PCP=P(IPU3,4)+ABS(P(IPU3,3))
15635
15636C...Find one or two beam remnants.
15637 MINT(105)=MINT(102+ISIDE)
15638 MINT(109)=MINT(106+ISIDE)
15639 CALL PYSPLI(MINT(10+ISIDE),MINT(12+ISIDE),KFLCH,KFLSP)
15640 IF(MINT(51).NE.0) THEN
15641 MINT(51)=0
15642 GOTO 180
15643 ENDIF
15644
15645C...Store first remnant parton, with colour info and kinematics.
15646 I=N+1
15647 K(I,1)=1
15648 K(I,2)=KFLSP
15649 K(I,3)=MINT(83)+ISIDE
15650 P(I,5)=PYMASS(K(I,2))
15651 KCOL=KCHG(PYCOMP(KFLSP),2)
15652 IF(KCOL.NE.0) THEN
15653 K(I,1)=3
15654 KFLS=(3-KCOL*ISIGN(1,KFLSP))/2
15655 K(I,KFLS+3)=MSTU(5)*IPU3
15656 K(IPU3,6-KFLS)=MSTU(5)*I
15657 ICOLR=I
15658 ENDIF
15659 IF(KFLCH.EQ.0) THEN
15660 P(I,1)=-P(IPU3,1)
15661 P(I,2)=-P(IPU3,2)
15662 PMS(ISIDE)=P(I,5)**2+P(I,1)**2+P(I,2)**2
15663 P(I,3)=-P(IPU3,3)
15664 P(I,4)=SQRT(PMS(ISIDE)+P(I,3)**2)
15665 PRP=P(I,4)+ABS(P(I,3))
15666
15667C...When extra remnant parton or hadron: store extra remnant.
15668 ELSE
15669 I=I+1
15670 K(I,1)=1
15671 K(I,2)=KFLCH
15672 K(I,3)=MINT(83)+ISIDE
15673 P(I,5)=PYMASS(K(I,2))
15674 KCOL=KCHG(PYCOMP(KFLCH),2)
15675 IF(KCOL.NE.0) THEN
15676 K(I,1)=3
15677 KFLS=(3-KCOL*ISIGN(1,KFLCH))/2
15678 K(I,KFLS+3)=MSTU(5)*IPU3
15679 K(IPU3,6-KFLS)=MSTU(5)*I
15680 ICOLR=I
15681 ENDIF
15682
15683C...Relative transverse momentum when two remnants.
15684 LOOP=0
15685 200 LOOP=LOOP+1
15686 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
15687 P(I-1,1)=P(I-1,1)-0.5D0*P(IPU3,1)
15688 P(I-1,2)=P(I-1,2)-0.5D0*P(IPU3,2)
15689 PMS(3)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
15690 P(I,1)=-P(IPU3,1)-P(I-1,1)
15691 P(I,2)=-P(IPU3,2)-P(I-1,2)
15692 PMS(4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
15693
15694C...Relative distribution of energy for particle into jet plus particle.
15695 IMB=1
15696 IF(MOD(MINT(10+ISIDE)/1000,10).NE.0) IMB=2
15697 IF(MSTP(94).LE.1) THEN
15698 IF(IMB.EQ.1) CHI=PYR(0)
15699 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
15700 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
15701 ELSEIF(MSTP(94).EQ.2) THEN
15702 CHI=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
15703 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
15704 ELSEIF(MSTP(94).EQ.3) THEN
15705 CALL PYZDIS(1,0,PMS(4),ZZ)
15706 CHI=ZZ
15707 ELSE
15708 CALL PYZDIS(1000,0,PMS(4),ZZ)
15709 CHI=ZZ
15710 ENDIF
15711
15712C...Construct total transverse mass; reject if too large.
15713 CHI=MAX(1D-8,MIN(1D0-1D-8,CHI))
15714 PMS(ISIDE)=PMS(4)/CHI+PMS(3)/(1D0-CHI)
15715 IF(PMS(ISIDE).GT.P(IPU3,4)**2) THEN
15716 IF(LOOP.LT.10) GOTO 200
15717 GOTO 180
15718 ENDIF
15719 VINT(158+ISIDE)=CHI
15720
15721C...Subdivide longitudinal momentum according to value selected above.
15722 PRP=SQRT(PMS(ISIDE)+P(IPU3,3)**2)+ABS(P(IPU3,3))
15723 PW1=(1D0-CHI)*PRP
15724 P(I-1,4)=0.5D0*(PW1+PMS(3)/PW1)
15725 P(I-1,3)=0.5D0*(PW1-PMS(3)/PW1)*SIDESG
15726 PW2=CHI*PRP
15727 P(I,4)=0.5D0*(PW2+PMS(4)/PW2)
15728 P(I,3)=0.5D0*(PW2-PMS(4)/PW2)*SIDESG
15729 ENDIF
15730 N=I
15731
15732C...Boost current and remnant systems to correct frame.
15733 IF(SQRT(PMS(1))+SQRT(PMS(2)).GT.0.99D0*VINT(1)) GOTO 180
15734 DSQLAM=SQRT(MAX(0D0,(VINT(2)-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2)))
15735 DRKC=(VINT(2)+PMS(3-ISIDE)-PMS(ISIDE)+DSQLAM)/
15736 &(2D0*VINT(1)*PCP)
15737 DRKR=(VINT(2)+PMS(ISIDE)-PMS(3-ISIDE)+DSQLAM)/
15738 &(2D0*VINT(1)*PRP)
15739 DBEC=-SIDESG*(DRKC**2-1D0)/(DRKC**2+1D0)
15740 DBER=SIDESG*(DRKR**2-1D0)/(DRKR**2+1D0)
15741 CALL PYROBO(IPU3,IPU3,0D0,0D0,0D0,0D0,DBEC)
15742 CALL PYROBO(IPU3+1,N,0D0,0D0,0D0,0D0,DBER)
15743
15744C...Let current quark shower; recoil but no showering by colour partner.
15745 QMAX=2D0*SQRT(VINT(309-ISIDE))
15746 MSTJ48=MSTJ(48)
15747 MSTJ(48)=1
15748 PARJ86=PARJ(86)
15749 PARJ(86)=0D0
15750 IF(MSTP(71).EQ.1) CALL PYSHOW(IPU3,ICOLR,QMAX)
15751 MSTJ(48)=MSTJ48
15752 PARJ(86)=PARJ86
15753
15754 RETURN
15755 END
15756
15757C*********************************************************************
15758
15759C...PYDOCU
15760C...Handles the documentation of the process in MSTI and PARI,
15761C...and also computes cross-sections based on accumulated statistics.
15762
15763 SUBROUTINE PYDOCU
15764
15765C...Double precision and integer declarations.
15766 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15767 IMPLICIT INTEGER(I-N)
15768 INTEGER PYK,PYCHGE,PYCOMP
15769C...Commonblocks.
15770 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15771 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15772 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15773 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
15774 COMMON/PYINT1/MINT(400),VINT(400)
15775 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15776 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
15777 SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
15778 &/PYINT5/
15779
15780C...Calculate Monte Carlo estimates of cross-sections.
15781 ISUB=MINT(1)
15782 IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
15783 NGEN(0,3)=NGEN(0,3)+1
15784 XSEC(0,3)=0D0
15785 DO 100 I=1,500
15786 IF(I.EQ.96.OR.I.EQ.97) THEN
15787 XSEC(I,3)=0D0
15788 ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
15789 & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
15790 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
15791 & DBLE(NGEN(96,2)))
15792 ELSEIF(MSUB(95).EQ.1.AND.I.GE.381.AND.I.LE.386) THEN
15793 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
15794 & DBLE(NGEN(96,2)))
15795 ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
15796 XSEC(I,3)=0D0
15797 ELSEIF(NGEN(I,2).EQ.0) THEN
15798 XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))*
15799 & DBLE(NGEN(0,2)))
15800 ELSE
15801 XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))*
15802 & DBLE(NGEN(I,2)))
15803 ENDIF
15804 XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
15805 100 CONTINUE
15806
15807C...Rescale to known low-pT cross-section for standard QCD processes.
15808 IF(MSUB(95).EQ.1) THEN
15809 XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
15810 & XSEC(68,3)+XSEC(95,3)
15811 XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
15812 IF(XSECH.GT.1D-20.AND.XSECW.GT.1D-20) THEN
15813 FAC=XSECW/XSECH
15814 XSEC(11,3)=FAC*XSEC(11,3)
15815 XSEC(12,3)=FAC*XSEC(12,3)
15816 XSEC(13,3)=FAC*XSEC(13,3)
15817 XSEC(28,3)=FAC*XSEC(28,3)
15818 XSEC(53,3)=FAC*XSEC(53,3)
15819 XSEC(68,3)=FAC*XSEC(68,3)
15820 XSEC(95,3)=FAC*XSEC(95,3)
15821 XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
15822 ENDIF
15823 ENDIF
15824
15825C...Save information for gamma-p and gamma-gamma.
15826 IF(MINT(121).GT.1) THEN
15827 IGA=MINT(122)
15828 CALL PYSAVE(2,IGA)
15829 CALL PYSAVE(5,0)
15830 ENDIF
15831
15832C...Reset information on hard interaction.
15833 DO 110 J=1,200
15834 MSTI(J)=0
15835 PARI(J)=0D0
15836 110 CONTINUE
15837
15838C...Copy integer valued information from MINT into MSTI.
15839 DO 120 J=1,32
15840 MSTI(J)=MINT(J)
15841 120 CONTINUE
15842 IF(MINT(121).GT.1) MSTI(9)=MINT(122)
15843
15844C...Store cross-section variables in PARI.
15845 PARI(1)=XSEC(0,3)
15846 PARI(2)=XSEC(0,3)/MINT(5)
15847 PARI(7)=VINT(97)
15848 PARI(9)=VINT(99)
15849 PARI(10)=VINT(100)
15850 VINT(98)=VINT(98)+VINT(100)
15851 IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
15852
15853C...Store kinematics variables in PARI.
15854 PARI(11)=VINT(1)
15855 PARI(12)=VINT(2)
15856 IF(ISUB.NE.95) THEN
15857 DO 130 J=13,26
15858 PARI(J)=VINT(30+J)
15859 130 CONTINUE
15860 PARI(31)=VINT(141)
15861 PARI(32)=VINT(142)
15862 PARI(33)=VINT(41)
15863 PARI(34)=VINT(42)
15864 PARI(35)=PARI(33)-PARI(34)
15865 PARI(36)=VINT(21)
15866 PARI(37)=VINT(22)
15867 PARI(38)=VINT(26)
15868 PARI(39)=VINT(157)
15869 PARI(40)=VINT(158)
15870 PARI(41)=VINT(23)
15871 PARI(42)=2D0*VINT(47)/VINT(1)
15872 ENDIF
15873
15874C...Store information on scattered partons in PARI.
15875 IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
15876 DO 140 IS=7,8
15877 I=MINT(IS)
15878 PARI(36+IS)=P(I,3)/VINT(1)
15879 PARI(38+IS)=P(I,4)/VINT(1)
15880 PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
15881 PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
15882 & SQRT(PR),1D20)),P(I,3))
15883 PR=MAX(1D-20,P(I,1)**2+P(I,2)**2)
15884 PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
15885 & SQRT(PR),1D20)),P(I,3))
15886 PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2)
15887 PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
15888 PARI(48+IS)=PYANGL(P(I,1),P(I,2))
15889 140 CONTINUE
15890 ENDIF
15891
15892C...Store sum up transverse and longitudinal momenta.
15893 PARI(65)=2D0*PARI(17)
15894 IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
15895 DO 150 I=MSTP(126)+1,N
15896 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
15897 PT=SQRT(P(I,1)**2+P(I,2)**2)
15898 PARI(69)=PARI(69)+PT
15899 IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
15900 IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
15901 150 CONTINUE
15902 PARI(67)=PARI(68)
15903 PARI(71)=VINT(151)
15904 PARI(72)=VINT(152)
15905 PARI(73)=VINT(151)
15906 PARI(74)=VINT(152)
15907 ELSE
15908 PARI(66)=PARI(65)
15909 PARI(69)=PARI(65)
15910 ENDIF
15911
15912C...Store various other pieces of information into PARI.
15913 PARI(61)=VINT(148)
15914 PARI(75)=VINT(155)
15915 PARI(76)=VINT(156)
15916 PARI(77)=VINT(159)
15917 PARI(78)=VINT(160)
15918 PARI(81)=VINT(138)
15919
15920C...Store information on lepton -> lepton + gamma in PYGAGA.
15921 MSTI(71)=MINT(141)
15922 MSTI(72)=MINT(142)
15923 PARI(101)=VINT(301)
15924 PARI(102)=VINT(302)
15925 DO 160 I=103,114
15926 PARI(I)=VINT(I+202)
15927 160 CONTINUE
15928
15929C...Set information for PYTABU.
15930 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
15931 MSTU(161)=MINT(21)
15932 MSTU(162)=0
15933 ELSEIF(ISET(ISUB).EQ.5) THEN
15934 MSTU(161)=MINT(23)
15935 MSTU(162)=0
15936 ELSE
15937 MSTU(161)=MINT(21)
15938 MSTU(162)=MINT(22)
15939 ENDIF
15940
15941 RETURN
15942 END
15943
15944C*********************************************************************
15945
15946C...PYFRAM
15947C...Performs transformations between different coordinate frames.
15948
15949 SUBROUTINE PYFRAM(IFRAME)
15950
15951C...Double precision and integer declarations.
15952 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15953 IMPLICIT INTEGER(I-N)
15954 INTEGER PYK,PYCHGE,PYCOMP
15955C...Commonblocks.
15956 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15957 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15958 COMMON/PYINT1/MINT(400),VINT(400)
15959 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
15960
15961C...Check that transformation can and should be done.
15962 IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
15963 &MINT(91).EQ.1)) THEN
15964 IF(IFRAME.EQ.MINT(6)) RETURN
15965 ELSE
15966 WRITE(MSTU(11),5000) IFRAME,MINT(6)
15967 RETURN
15968 ENDIF
15969
15970 IF(MINT(6).EQ.1) THEN
15971C...Transform from fixed target or user specified frame to
15972C...overall CM frame.
15973 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
15974 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
15975 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
15976 ELSEIF(MINT(6).EQ.3) THEN
15977C...Transform from hadronic CM frame in DIS to overall CM frame.
15978 CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
15979 & -VINT(225))
15980 ENDIF
15981
15982 IF(IFRAME.EQ.1) THEN
15983C...Transform from overall CM frame to fixed target or user specified
15984C...frame.
15985 CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
15986 ELSEIF(IFRAME.EQ.3) THEN
15987C...Transform from overall CM frame to hadronic CM frame in DIS.
15988 CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
15989 CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
15990 CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
15991 ENDIF
15992
15993C...Set information about new frame.
15994 MINT(6)=IFRAME
15995 MSTI(6)=IFRAME
15996
15997 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
15998 &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
15999 &1X,I5)
16000
16001 RETURN
16002 END
16003
16004C*********************************************************************
16005
16006C...PYWIDT
16007C...Calculates full and partial widths of resonances.
16008
16009 SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
16010
16011C...Double precision and integer declarations.
16012 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16013 IMPLICIT INTEGER(I-N)
16014 INTEGER PYK,PYCHGE,PYCOMP
16015C...Parameter statement to help give large particle numbers.
16016 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
16017 &KEXCIT=4000000,KDIMEN=5000000)
16018C...Commonblocks.
16019 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16020 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
16021 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
16022 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
16023 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16024 COMMON/PYINT1/MINT(400),VINT(400)
16025 COMMON/PYINT4/MWID(500),WIDS(500,5)
16026 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
16027 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
16028 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
16029 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
16030 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
16031 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYTCSM/
16032C...Local arrays and saved variables.
16033 COMPLEX*16 ZMIXC(4,4),AL,BL,AR,BR,FL,FR
16034 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
16035 &WID2SV(3,2),WDTPP(0:400),WDTEP(0:400,0:5)
16036 SAVE MOFSV,WIDWSV,WID2SV
16037 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
16038
16039C...Compressed code and sign; mass.
16040 KFLA=IABS(KFLR)
16041 KFLS=ISIGN(1,KFLR)
16042 KC=PYCOMP(KFLA)
16043 SHR=SQRT(SH)
16044 PMR=PMAS(KC,1)
16045
16046C...Reset width information.
16047 DO 110 I=0,MDCY(KC,3)
16048 WDTP(I)=0D0
16049 DO 100 J=0,5
16050 WDTE(I,J)=0D0
16051 100 CONTINUE
16052 110 CONTINUE
16053
16054C...Allow for fudge factor to rescale resonance width.
16055 FUDGE=1D0
16056 IF(MSTP(110).NE.0.AND.(MWID(KC).EQ.1.OR.MWID(KC).EQ.2.OR.
16057 &(MWID(KC).EQ.3.AND.MINT(63).EQ.1))) THEN
16058 IF(MSTP(110).EQ.KFLA) THEN
16059 FUDGE=PARP(110)
16060 ELSEIF(MSTP(110).EQ.-1) THEN
16061 IF(KFLA.NE.6.AND.KFLA.NE.23.AND.KFLA.NE.24) FUDGE=PARP(110)
16062 ELSEIF(MSTP(110).EQ.-2) THEN
16063 FUDGE=PARP(110)
16064 ENDIF
16065 ENDIF
16066
16067C...Not to be treated as a resonance: return.
16068 IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND.
16069 &KFLA.NE.22) THEN
16070 WDTP(0)=1D0
16071 WDTE(0,0)=1D0
16072 MINT(61)=0
16073 MINT(62)=0
16074 MINT(63)=0
16075 RETURN
16076
16077C...Treatment as a resonance based on tabulated branching ratios.
16078 ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN
16079C...Loop over possible decay channels; skip irrelevant ones.
16080 DO 120 I=1,MDCY(KC,3)
16081 IDC=I+MDCY(KC,2)-1
16082 IF(MDME(IDC,1).LT.0) GOTO 120
16083
16084C...Read out decay products and nominal masses.
16085 KFD1=KFDP(IDC,1)
16086 KFC1=PYCOMP(KFD1)
16087 IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1
16088 PM1=PMAS(KFC1,1)
16089 KFD2=KFDP(IDC,2)
16090 KFC2=PYCOMP(KFD2)
16091 IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2
16092 PM2=PMAS(KFC2,1)
16093 KFD3=KFDP(IDC,3)
16094 PM3=0D0
16095 IF(KFD3.NE.0) THEN
16096 KFC3=PYCOMP(KFD3)
16097 IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3
16098 PM3=PMAS(KFC3,1)
16099 ENDIF
16100
16101C...Naive partial width and alternative threshold factors.
16102 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)
16103 IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND.
16104 & PM1+PM2+PM3.GE.SHR) THEN
16105 WDTP(I)=0D0
16106 ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN
16107 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2-
16108 & 4D0*PM1**2*PM2**2))/SH
16109 ELSEIF(MDME(IDC,2).EQ.52) THEN
16110 PMA=MAX(PM1,PM2,PM3)
16111 PMC=MIN(PM1,PM2,PM3)
16112 PMB=PM1+PM2+PM3-PMA-PMC
16113 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC)
16114 PMAN=PMA**2/SH
16115 PMBN=PMB**2/SH
16116 PMCN=PMC**2/SH
16117 PMBCN=PMBC**2/SH
16118 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,
16119 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
16120 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
16121 & ((SHR-PMA)**2-(PMB+PMC)**2)*
16122 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
16123 & ((1D0-PMBCN)*PMBCN*SH)
16124 ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
16125 WDTP(I)=WDTP(I)*SQRT(
16126 & MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/
16127 & MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2))
16128 ELSEIF(MDME(IDC,2).EQ.53) THEN
16129 PMA=MAX(PM1,PM2,PM3)
16130 PMC=MIN(PM1,PM2,PM3)
16131 PMB=PM1+PM2+PM3-PMA-PMC
16132 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC)
16133 PMAN=PMA**2/SH
16134 PMBN=PMB**2/SH
16135 PMCN=PMC**2/SH
16136 PMBCN=PMBC**2/SH
16137 FACACT=SQRT(MAX(0D0,
16138 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
16139 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
16140 & ((SHR-PMA)**2-(PMB+PMC)**2)*
16141 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
16142 & ((1D0-PMBCN)*PMBCN*SH)
16143 PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
16144 PMAN=PMA**2/PMR**2
16145 PMBN=PMB**2/PMR**2
16146 PMCN=PMC**2/PMR**2
16147 PMBCN=PMBC**2/PMR**2
16148 FACNOM=SQRT(MAX(0D0,
16149 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
16150 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
16151 & ((PMR-PMA)**2-(PMB+PMC)**2)*
16152 & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
16153 & ((1D0-PMBCN)*PMBCN*PMR**2)
16154 WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM)
16155 ENDIF
16156 WDTP(I)=FUDGE*WDTP(I)
16157 WDTP(0)=WDTP(0)+WDTP(I)
16158
16159C...Calculate secondary width (at most two identical/opposite).
16160 WID2=1D0
16161 IF(MDME(IDC,1).GT.0) THEN
16162 IF(KFD2.EQ.KFD1) THEN
16163 IF(KCHG(KFC1,3).EQ.0) THEN
16164 WID2=WIDS(KFC1,1)
16165 ELSEIF(KFD1.GT.0) THEN
16166 WID2=WIDS(KFC1,4)
16167 ELSE
16168 WID2=WIDS(KFC1,5)
16169 ENDIF
16170 IF(KFD3.GT.0) THEN
16171 WID2=WID2*WIDS(KFC3,2)
16172 ELSEIF(KFD3.LT.0) THEN
16173 WID2=WID2*WIDS(KFC3,3)
16174 ENDIF
16175 ELSEIF(KFD2.EQ.-KFD1) THEN
16176 WID2=WIDS(KFC1,1)
16177 IF(KFD3.GT.0) THEN
16178 WID2=WID2*WIDS(KFC3,2)
16179 ELSEIF(KFD3.LT.0) THEN
16180 WID2=WID2*WIDS(KFC3,3)
16181 ENDIF
16182 ELSEIF(KFD3.EQ.KFD1) THEN
16183 IF(KCHG(KFC1,3).EQ.0) THEN
16184 WID2=WIDS(KFC1,1)
16185 ELSEIF(KFD1.GT.0) THEN
16186 WID2=WIDS(KFC1,4)
16187 ELSE
16188 WID2=WIDS(KFC1,5)
16189 ENDIF
16190 IF(KFD2.GT.0) THEN
16191 WID2=WID2*WIDS(KFC2,2)
16192 ELSEIF(KFD2.LT.0) THEN
16193 WID2=WID2*WIDS(KFC2,3)
16194 ENDIF
16195 ELSEIF(KFD3.EQ.-KFD1) THEN
16196 WID2=WIDS(KFC1,1)
16197 IF(KFD2.GT.0) THEN
16198 WID2=WID2*WIDS(KFC2,2)
16199 ELSEIF(KFD2.LT.0) THEN
16200 WID2=WID2*WIDS(KFC2,3)
16201 ENDIF
16202 ELSEIF(KFD3.EQ.KFD2) THEN
16203 IF(KCHG(KFC2,3).EQ.0) THEN
16204 WID2=WIDS(KFC2,1)
16205 ELSEIF(KFD2.GT.0) THEN
16206 WID2=WIDS(KFC2,4)
16207 ELSE
16208 WID2=WIDS(KFC2,5)
16209 ENDIF
16210 IF(KFD1.GT.0) THEN
16211 WID2=WID2*WIDS(KFC1,2)
16212 ELSEIF(KFD1.LT.0) THEN
16213 WID2=WID2*WIDS(KFC1,3)
16214 ENDIF
16215 ELSEIF(KFD3.EQ.-KFD2) THEN
16216 WID2=WIDS(KFC2,1)
16217 IF(KFD1.GT.0) THEN
16218 WID2=WID2*WIDS(KFC1,2)
16219 ELSEIF(KFD1.LT.0) THEN
16220 WID2=WID2*WIDS(KFC1,3)
16221 ENDIF
16222 ELSE
16223 IF(KFD1.GT.0) THEN
16224 WID2=WIDS(KFC1,2)
16225 ELSE
16226 WID2=WIDS(KFC1,3)
16227 ENDIF
16228 IF(KFD2.GT.0) THEN
16229 WID2=WID2*WIDS(KFC2,2)
16230 ELSE
16231 WID2=WID2*WIDS(KFC2,3)
16232 ENDIF
16233 IF(KFD3.GT.0) THEN
16234 WID2=WID2*WIDS(KFC3,2)
16235 ELSEIF(KFD3.LT.0) THEN
16236 WID2=WID2*WIDS(KFC3,3)
16237 ENDIF
16238 ENDIF
16239
16240C...Store effective widths according to case.
16241 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16242 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16243 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16244 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16245 ENDIF
16246 120 CONTINUE
16247C...Return.
16248 MINT(61)=0
16249 MINT(62)=0
16250 MINT(63)=0
16251 RETURN
16252 ENDIF
16253
16254C...Here begins detailed dynamical calculation of resonance widths.
16255C...Shared treatment of Higgs states.
16256 KFHIGG=25
16257 IHIGG=1
16258 IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN
16259 KFHIGG=KFLA
16260 IHIGG=KFLA-33
16261 ENDIF
16262
16263C...Common electroweak and strong constants.
16264 XW=PARU(102)
16265 XWV=XW
16266 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
16267 XW1=1D0-XW
16268 AEM=PYALEM(SH)
16269 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
16270 AS=PYALPS(SH)
16271 RADC=1D0+AS/PARU(1)
16272
16273 IF(KFLA.EQ.6) THEN
16274C...t quark.
16275 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
16276 RADCT=1D0-2.5D0*AS/PARU(1)
16277 DO 140 I=1,MDCY(KC,3)
16278 IDC=I+MDCY(KC,2)-1
16279 IF(MDME(IDC,1).LT.0) GOTO 140
16280 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16281 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16282 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
16283 WID2=1D0
16284 IF(I.GE.4.AND.I.LE.7) THEN
16285C...t -> W + q; including approximate QCD correction factor.
16286 WDTP(I)=FAC*VCKM(3,I-3)*RADCT*
16287 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16288 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
16289 IF(KFLR.GT.0) THEN
16290 WID2=WIDS(24,2)
16291 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
16292 ELSE
16293 WID2=WIDS(24,3)
16294 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
16295 ENDIF
16296 ELSEIF(I.EQ.9) THEN
16297C...t -> H + b.
16298 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16299 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
16300 WID2=WIDS(37,2)
16301 IF(KFLR.LT.0) WID2=WIDS(37,3)
16302CMRENNA++
16303 ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN
16304C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
16305 BETA=ATAN(RMSS(5))
16306 SINB=SIN(BETA)
16307 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
16308 ET=KCHG(6,1)/3D0
16309 T3L=SIGN(0.5D0,ET)
16310 KFC1=PYCOMP(KFDP(IDC,1))
16311 KFC2=PYCOMP(KFDP(IDC,2))
16312 PMNCHI=PMAS(KFC1,1)
16313 PMSTOP=PMAS(KFC2,1)
16314 IF(SHR.GT.PMNCHI+PMSTOP) THEN
16315 IZ=I-9
16316 DO 130 IK=1,4
16317 ZMIXC(IZ,IK)=DCMPLX(ZMIX(IZ,IK),ZMIXI(IZ,IK))
16318 130 CONTINUE
16319 AL=SHR*DCONJG(ZMIXC(IZ,4))/(2.0D0*PMAS(24,1)*SINB)
16320 AR=-ET*ZMIXC(IZ,1)*TANW
16321 BL=T3L*(ZMIXC(IZ,2)-ZMIXC(IZ,1)*TANW)-AR
16322 BR=AL
16323 FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR
16324 FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR
16325 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
16326 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
16327 WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM*
16328 & ((ABS(FL)**2+ABS(FR)**2)*(SH+PMNCHI**2-PMSTOP**2)+
16329 & SMZ(IZ)*4D0*SHR*DBLE(FL*DCONJG(FR)))/SH
16330 IF(KFLR.GT.0) THEN
16331 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
16332 ELSE
16333 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
16334 ENDIF
16335 ENDIF
16336 ELSEIF(I.EQ.14.AND.IMSS(1).NE.0) THEN
16337C...t -> ~g + ~t
16338 KFC1=PYCOMP(KFDP(IDC,1))
16339 KFC2=PYCOMP(KFDP(IDC,2))
16340 PMNCHI=PMAS(KFC1,1)
16341 PMSTOP=PMAS(KFC2,1)
16342 IF(SHR.GT.PMNCHI+PMSTOP) THEN
16343 RL=SFMIX(6,1)
16344 RR=-SFMIX(6,2)
16345 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
16346 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
16347 WDTP(I)=4D0/3D0*0.5D0*PYALPS(SH)*PCM*((RL**2+RR**2)*
16348 & (SH+PMNCHI**2-PMSTOP**2)+PMNCHI*4D0*SHR*RL*RR)/SH
16349 IF(KFLR.GT.0) THEN
16350 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
16351 ELSE
16352 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
16353 ENDIF
16354 ENDIF
16355 ELSEIF(I.EQ.15.AND.IMSS(1).NE.0) THEN
16356C...t -> ~gravitino + ~t
16357 XMP2=RMSS(29)**2
16358 KFC1=PYCOMP(KFDP(IDC,1))
16359 XMGR2=PMAS(KFC1,1)**2
16360 WDTP(I)=SH**2*SHR/(96D0*PARU(1)*XMP2*XMGR2)*(1D0-RM2)**4
16361 KFC2=PYCOMP(KFDP(IDC,2))
16362 WID2=WIDS(KFC2,2)
16363 IF(KFLR.LT.0) WID2=WIDS(KFC2,3)
16364CMRENNA--
16365 ENDIF
16366 WDTP(I)=FUDGE*WDTP(I)
16367 WDTP(0)=WDTP(0)+WDTP(I)
16368 IF(MDME(IDC,1).GT.0) THEN
16369 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16370 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16371 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16372 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16373 ENDIF
16374 140 CONTINUE
16375
16376 ELSEIF(KFLA.EQ.7) THEN
16377C...b' quark.
16378 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
16379 DO 150 I=1,MDCY(KC,3)
16380 IDC=I+MDCY(KC,2)-1
16381 IF(MDME(IDC,1).LT.0) GOTO 150
16382 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16383 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16384 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150
16385 WID2=1D0
16386 IF(I.GE.4.AND.I.LE.7) THEN
16387C...b' -> W + q.
16388 WDTP(I)=FAC*VCKM(I-3,4)*
16389 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16390 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
16391 IF(KFLR.GT.0) THEN
16392 WID2=WIDS(24,3)
16393 IF(I.EQ.6) WID2=WID2*WIDS(6,2)
16394 IF(I.EQ.7) WID2=WID2*WIDS(8,2)
16395 ELSE
16396 WID2=WIDS(24,2)
16397 IF(I.EQ.6) WID2=WID2*WIDS(6,3)
16398 IF(I.EQ.7) WID2=WID2*WIDS(8,3)
16399 ENDIF
16400 WID2=WIDS(24,3)
16401 IF(KFLR.LT.0) WID2=WIDS(24,2)
16402 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
16403C...b' -> H + q.
16404 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16405 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
16406 IF(KFLR.GT.0) THEN
16407 WID2=WIDS(37,3)
16408 IF(I.EQ.10) WID2=WID2*WIDS(6,2)
16409 ELSE
16410 WID2=WIDS(37,2)
16411 IF(I.EQ.10) WID2=WID2*WIDS(6,3)
16412 ENDIF
16413 ENDIF
16414 WDTP(I)=FUDGE*WDTP(I)
16415 WDTP(0)=WDTP(0)+WDTP(I)
16416 IF(MDME(IDC,1).GT.0) THEN
16417 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16418 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16419 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16420 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16421 ENDIF
16422 150 CONTINUE
16423
16424 ELSEIF(KFLA.EQ.8) THEN
16425C...t' quark.
16426 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
16427 DO 160 I=1,MDCY(KC,3)
16428 IDC=I+MDCY(KC,2)-1
16429 IF(MDME(IDC,1).LT.0) GOTO 160
16430 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16431 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16432 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160
16433 WID2=1D0
16434 IF(I.GE.4.AND.I.LE.7) THEN
16435C...t' -> W + q.
16436 WDTP(I)=FAC*VCKM(4,I-3)*
16437 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16438 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
16439 IF(KFLR.GT.0) THEN
16440 WID2=WIDS(24,2)
16441 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
16442 ELSE
16443 WID2=WIDS(24,3)
16444 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
16445 ENDIF
16446 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
16447C...t' -> H + q.
16448 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16449 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
16450 IF(KFLR.GT.0) THEN
16451 WID2=WIDS(37,2)
16452 IF(I.EQ.10) WID2=WID2*WIDS(7,2)
16453 ELSE
16454 WID2=WIDS(37,3)
16455 IF(I.EQ.10) WID2=WID2*WIDS(7,3)
16456 ENDIF
16457 ENDIF
16458 WDTP(I)=FUDGE*WDTP(I)
16459 WDTP(0)=WDTP(0)+WDTP(I)
16460 IF(MDME(IDC,1).GT.0) THEN
16461 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16462 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16463 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16464 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16465 ENDIF
16466 160 CONTINUE
16467
16468 ELSEIF(KFLA.EQ.17) THEN
16469C...tau' lepton.
16470 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
16471 DO 170 I=1,MDCY(KC,3)
16472 IDC=I+MDCY(KC,2)-1
16473 IF(MDME(IDC,1).LT.0) GOTO 170
16474 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16475 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16476 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170
16477 WID2=1D0
16478 IF(I.EQ.3) THEN
16479C...tau' -> W + nu'_tau.
16480 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16481 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
16482 IF(KFLR.GT.0) THEN
16483 WID2=WIDS(24,3)
16484 WID2=WID2*WIDS(18,2)
16485 ELSE
16486 WID2=WIDS(24,2)
16487 WID2=WID2*WIDS(18,3)
16488 ENDIF
16489 ELSEIF(I.EQ.5) THEN
16490C...tau' -> H + nu'_tau.
16491 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16492 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
16493 IF(KFLR.GT.0) THEN
16494 WID2=WIDS(37,3)
16495 WID2=WID2*WIDS(18,2)
16496 ELSE
16497 WID2=WIDS(37,2)
16498 WID2=WID2*WIDS(18,3)
16499 ENDIF
16500 ENDIF
16501 WDTP(I)=FUDGE*WDTP(I)
16502 WDTP(0)=WDTP(0)+WDTP(I)
16503 IF(MDME(IDC,1).GT.0) THEN
16504 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16505 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16506 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16507 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16508 ENDIF
16509 170 CONTINUE
16510
16511 ELSEIF(KFLA.EQ.18) THEN
16512C...nu'_tau neutrino.
16513 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
16514 DO 180 I=1,MDCY(KC,3)
16515 IDC=I+MDCY(KC,2)-1
16516 IF(MDME(IDC,1).LT.0) GOTO 180
16517 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16518 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16519 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180
16520 WID2=1D0
16521 IF(I.EQ.2) THEN
16522C...nu'_tau -> W + tau'.
16523 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16524 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
16525 IF(KFLR.GT.0) THEN
16526 WID2=WIDS(24,2)
16527 WID2=WID2*WIDS(17,2)
16528 ELSE
16529 WID2=WIDS(24,3)
16530 WID2=WID2*WIDS(17,3)
16531 ENDIF
16532 ELSEIF(I.EQ.3) THEN
16533C...nu'_tau -> H + tau'.
16534 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16535 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
16536 IF(KFLR.GT.0) THEN
16537 WID2=WIDS(37,2)
16538 WID2=WID2*WIDS(17,2)
16539 ELSE
16540 WID2=WIDS(37,3)
16541 WID2=WID2*WIDS(17,3)
16542 ENDIF
16543 ENDIF
16544 WDTP(I)=FUDGE*WDTP(I)
16545 WDTP(0)=WDTP(0)+WDTP(I)
16546 IF(MDME(IDC,1).GT.0) THEN
16547 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16548 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16549 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16550 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16551 ENDIF
16552 180 CONTINUE
16553
16554 ELSEIF(KFLA.EQ.21) THEN
16555C...QCD:
16556C***Note that widths are not given in dimensional quantities here.
16557 DO 190 I=1,MDCY(KC,3)
16558 IDC=I+MDCY(KC,2)-1
16559 IF(MDME(IDC,1).LT.0) GOTO 190
16560 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16561 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16562 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190
16563 WID2=1D0
16564 IF(I.LE.8) THEN
16565C...QCD -> q + qbar
16566 WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
16567 IF(I.EQ.6) WID2=WIDS(6,1)
16568 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
16569 ENDIF
16570 WDTP(I)=FUDGE*WDTP(I)
16571 WDTP(0)=WDTP(0)+WDTP(I)
16572 IF(MDME(IDC,1).GT.0) THEN
16573 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16574 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16575 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16576 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16577 ENDIF
16578 190 CONTINUE
16579
16580 ELSEIF(KFLA.EQ.22) THEN
16581C...QED photon.
16582C***Note that widths are not given in dimensional quantities here.
16583 DO 200 I=1,MDCY(KC,3)
16584 IDC=I+MDCY(KC,2)-1
16585 IF(MDME(IDC,1).LT.0) GOTO 200
16586 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16587 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16588 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 200
16589 WID2=1D0
16590 IF(I.LE.8) THEN
16591C...QED -> q + qbar.
16592 EF=KCHG(I,1)/3D0
16593 FCOF=3D0*RADC
16594 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
16595 WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
16596 IF(I.EQ.6) WID2=WIDS(6,1)
16597 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
16598 ELSEIF(I.LE.12) THEN
16599C...QED -> l+ + l-.
16600 EF=KCHG(9+2*(I-8),1)/3D0
16601 WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
16602 IF(I.EQ.12) WID2=WIDS(17,1)
16603 ENDIF
16604 WDTP(I)=FUDGE*WDTP(I)
16605 WDTP(0)=WDTP(0)+WDTP(I)
16606 IF(MDME(IDC,1).GT.0) THEN
16607 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16608 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16609 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16610 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16611 ENDIF
16612 200 CONTINUE
16613
16614 ELSEIF(KFLA.EQ.23) THEN
16615C...Z0:
16616 ICASE=1
16617 XWC=1D0/(16D0*XW*XW1)
16618 FAC=(AEM*XWC/3D0)*SHR
16619 210 CONTINUE
16620 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
16621 VINT(111)=0D0
16622 VINT(112)=0D0
16623 VINT(114)=0D0
16624 ENDIF
16625 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
16626 KFI=IABS(MINT(15))
16627 IF(KFI.GT.20) KFI=IABS(MINT(16))
16628 EI=KCHG(KFI,1)/3D0
16629 AI=SIGN(1D0,EI)
16630 VI=AI-4D0*EI*XWV
16631 SQMZ=PMAS(23,1)**2
16632 HZ=SHR*WDTP(0)
16633 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0
16634 IF(MSTP(43).EQ.3) VINT(112)=
16635 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
16636 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
16637 & XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
16638 ENDIF
16639 DO 220 I=1,MDCY(KC,3)
16640 IDC=I+MDCY(KC,2)-1
16641 IF(MDME(IDC,1).LT.0) GOTO 220
16642 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16643 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16644 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220
16645 WID2=1D0
16646 IF(I.LE.8) THEN
16647C...Z0 -> q + qbar
16648 EF=KCHG(I,1)/3D0
16649 AF=SIGN(1D0,EF+0.1D0)
16650 VF=AF-4D0*EF*XWV
16651 FCOF=3D0*RADC
16652 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
16653 IF(I.EQ.6) WID2=WIDS(6,1)
16654 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
16655 ELSEIF(I.LE.16) THEN
16656C...Z0 -> l+ + l-, nu + nubar
16657 EF=KCHG(I+2,1)/3D0
16658 AF=SIGN(1D0,EF+0.1D0)
16659 VF=AF-4D0*EF*XWV
16660 FCOF=1D0
16661 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
16662 ENDIF
16663 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
16664 IF(ICASE.EQ.1) THEN
16665 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
16666 & BE34
16667 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
16668 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
16669 & EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+
16670 & (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34
16671 ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
16672 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
16673 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
16674 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
16675 ENDIF
16676 IF(ICASE.EQ.1) WDTP(I)=FUDGE*WDTP(I)
16677 IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I)
16678 IF(MDME(IDC,1).GT.0) THEN
16679 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
16680 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
16681 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16682 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
16683 & WDTE(I,MDME(IDC,1))
16684 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16685 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16686 ENDIF
16687 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
16688 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=
16689 & VINT(111)+FGGF*WID2
16690 IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2
16691 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
16692 & VINT(114)+FZZF*WID2
16693 ENDIF
16694 ENDIF
16695 220 CONTINUE
16696 IF(MINT(61).GE.1) ICASE=3-ICASE
16697 IF(ICASE.EQ.2) GOTO 210
16698
16699 ELSEIF(KFLA.EQ.24) THEN
16700C...W+/-:
16701 FAC=(AEM/(24D0*XW))*SHR
16702 DO 230 I=1,MDCY(KC,3)
16703 IDC=I+MDCY(KC,2)-1
16704 IF(MDME(IDC,1).LT.0) GOTO 230
16705 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16706 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16707 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 230
16708 WID2=1D0
16709 IF(I.LE.16) THEN
16710C...W+/- -> q + qbar'
16711 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
16712 IF(KFLR.GT.0) THEN
16713 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
16714 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
16715 IF(I.GE.13) WID2=WID2*WIDS(7,3)
16716 ELSE
16717 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
16718 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
16719 IF(I.GE.13) WID2=WID2*WIDS(7,2)
16720 ENDIF
16721 ELSEIF(I.LE.20) THEN
16722C...W+/- -> l+/- + nu
16723 FCOF=1D0
16724 IF(KFLR.GT.0) THEN
16725 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
16726 ELSE
16727 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
16728 ENDIF
16729 ENDIF
16730 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
16731 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
16732 WDTP(I)=FUDGE*WDTP(I)
16733 WDTP(0)=WDTP(0)+WDTP(I)
16734 IF(MDME(IDC,1).GT.0) THEN
16735 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16736 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16737 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16738 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16739 ENDIF
16740 230 CONTINUE
16741
16742 ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN
16743C...h0 (or H0, or A0):
16744 SHFS=SH
16745 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
16746 DO 270 I=1,MDCY(KFHIGG,3)
16747 IDC=I+MDCY(KFHIGG,2)-1
16748 IF(MDME(IDC,1).LT.0) GOTO 270
16749 KFC1=PYCOMP(KFDP(IDC,1))
16750 KFC2=PYCOMP(KFDP(IDC,2))
16751 RM1=PMAS(KFC1,1)**2/SH
16752 RM2=PMAS(KFC2,1)**2/SH
16753 IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0)
16754 & GOTO 270
16755 WID2=1D0
16756
16757 IF(I.LE.8) THEN
16758C...h0 -> q + qbar
16759 WDTP(I)=FAC*3D0*(PYMRUN(KFDP(IDC,1),SH)**2/SHFS)*
16760 & SQRT(MAX(0D0,1D0-4D0*RM1))*RADC
16761C...A0 behaves like beta, ho and H0 like beta**3.
16762 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
16763 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
16764 IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2
16765 IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2
16766 IF(IMSS(1).NE.0.AND.KFC1.EQ.5) THEN
16767 WDTP(I)=WDTP(I)/(1D0+RMSS(41))**2
16768 IF(IHIGG.NE.3) THEN
16769 WDTP(I)=WDTP(I)*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
16770 & PARU(151+10*IHIGG))**2
16771 ENDIF
16772 ENDIF
16773 ENDIF
16774 IF(I.EQ.6) WID2=WIDS(6,1)
16775 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
16776 ELSEIF(I.LE.12) THEN
16777C...h0 -> l+ + l-
16778 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))*(SH/SHFS)
16779C...A0 behaves like beta, ho and H0 like beta**3.
16780 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
16781 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
16782 & PARU(153+10*IHIGG)**2
16783 IF(I.EQ.12) WID2=WIDS(17,1)
16784
16785 ELSEIF(I.EQ.13) THEN
16786C...h0 -> g + g; quark loop contribution only
16787 ETARE=0D0
16788 ETAIM=0D0
16789 DO 240 J=1,2*MSTP(1)
16790 EPS=(2D0*PMAS(J,1))**2/SH
16791C...Loop integral; function of eps=4m^2/shat; different for A0.
16792 IF(EPS.LE.1D0) THEN
16793 IF(EPS.GT.1D-4) THEN
16794 ROOT=SQRT(1D0-EPS)
16795 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
16796 ELSE
16797 RLN=LOG(4D0/EPS-2D0)
16798 ENDIF
16799 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
16800 PHIIM=0.5D0*PARU(1)*RLN
16801 ELSE
16802 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
16803 PHIIM=0D0
16804 ENDIF
16805 IF(IHIGG.LE.2) THEN
16806 ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
16807 ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM
16808 ELSE
16809 ETAREJ=-0.5D0*EPS*PHIRE
16810 ETAIMJ=-0.5D0*EPS*PHIIM
16811 ENDIF
16812C...Couplings (=1 for standard model Higgs).
16813 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
16814 IF(MOD(J,2).EQ.1) THEN
16815 ETAREJ=ETAREJ*PARU(151+10*IHIGG)
16816 ETAIMJ=ETAIMJ*PARU(151+10*IHIGG)
16817 ELSE
16818 ETAREJ=ETAREJ*PARU(152+10*IHIGG)
16819 ETAIMJ=ETAIMJ*PARU(152+10*IHIGG)
16820 ENDIF
16821 ENDIF
16822 ETARE=ETARE+ETAREJ
16823 ETAIM=ETAIM+ETAIMJ
16824 240 CONTINUE
16825 ETA2=ETARE**2+ETAIM**2
16826 WDTP(I)=FAC*(AS/PARU(1))**2*ETA2
16827
16828 ELSEIF(I.EQ.14) THEN
16829C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
16830 ETARE=0D0
16831 ETAIM=0D0
16832 JMAX=3*MSTP(1)+1
16833 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
16834 DO 250 J=1,JMAX
16835 IF(J.LE.2*MSTP(1)) THEN
16836 EJ=KCHG(J,1)/3D0
16837 EPS=(2D0*PMAS(J,1))**2/SH
16838 ELSEIF(J.LE.3*MSTP(1)) THEN
16839 JL=2*(J-2*MSTP(1))-1
16840 EJ=KCHG(10+JL,1)/3D0
16841 EPS=(2D0*PMAS(10+JL,1))**2/SH
16842 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
16843 EPS=(2D0*PMAS(24,1))**2/SH
16844 ELSE
16845 EPS=(2D0*PMAS(37,1))**2/SH
16846 ENDIF
16847C...Loop integral; function of eps=4m^2/shat.
16848 IF(EPS.LE.1D0) THEN
16849 IF(EPS.GT.1D-4) THEN
16850 ROOT=SQRT(1D0-EPS)
16851 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
16852 ELSE
16853 RLN=LOG(4D0/EPS-2D0)
16854 ENDIF
16855 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
16856 PHIIM=0.5D0*PARU(1)*RLN
16857 ELSE
16858 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
16859 PHIIM=0D0
16860 ENDIF
16861 IF(J.LE.3*MSTP(1)) THEN
16862C...Fermion loops: loop integral different for A0; charges.
16863 IF(IHIGG.LE.2) THEN
16864 PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
16865 PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM
16866 ELSE
16867 PHIPRE=-0.5D0*EPS*PHIRE
16868 PHIPIM=-0.5D0*EPS*PHIIM
16869 ENDIF
16870 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
16871 EJC=3D0*EJ**2
16872 EJH=PARU(151+10*IHIGG)
16873 ELSEIF(J.LE.2*MSTP(1)) THEN
16874 EJC=3D0*EJ**2
16875 EJH=PARU(152+10*IHIGG)
16876 ELSE
16877 EJC=EJ**2
16878 EJH=PARU(153+10*IHIGG)
16879 ENDIF
16880 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
16881 ETAREJ=EJC*EJH*PHIPRE
16882 ETAIMJ=EJC*EJH*PHIPIM
16883 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
16884C...W loops: loop integral and charges.
16885 ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE)
16886 ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM
16887 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
16888 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
16889 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
16890 ENDIF
16891 ELSE
16892C...Charged H loops: loop integral and charges.
16893 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*
16894 & PARU(158+10*IHIGG+2*(IHIGG/3))
16895 ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH
16896 ETAIMJ=-EPS**2*PHIIM*FACHHH
16897 ENDIF
16898 ETARE=ETARE+ETAREJ
16899 ETAIM=ETAIM+ETAIMJ
16900 250 CONTINUE
16901 ETA2=ETARE**2+ETAIM**2
16902 WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2
16903
16904 ELSEIF(I.EQ.15) THEN
16905C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
16906 ETARE=0D0
16907 ETAIM=0D0
16908 JMAX=3*MSTP(1)+1
16909 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
16910 DO 260 J=1,JMAX
16911 IF(J.LE.2*MSTP(1)) THEN
16912 EJ=KCHG(J,1)/3D0
16913 AJ=SIGN(1D0,EJ+0.1D0)
16914 VJ=AJ-4D0*EJ*XWV
16915 EPS=(2D0*PMAS(J,1))**2/SH
16916 EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2
16917 ELSEIF(J.LE.3*MSTP(1)) THEN
16918 JL=2*(J-2*MSTP(1))-1
16919 EJ=KCHG(10+JL,1)/3D0
16920 AJ=SIGN(1D0,EJ+0.1D0)
16921 VJ=AJ-4D0*EJ*XWV
16922 EPS=(2D0*PMAS(10+JL,1))**2/SH
16923 EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2
16924 ELSE
16925 EPS=(2D0*PMAS(24,1))**2/SH
16926 EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2
16927 ENDIF
16928C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
16929 IF(EPS.LE.1D0) THEN
16930 ROOT=SQRT(1D0-EPS)
16931 IF(EPS.GT.1D-4) THEN
16932 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
16933 ELSE
16934 RLN=LOG(4D0/EPS-2D0)
16935 ENDIF
16936 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
16937 PHIIM=0.5D0*PARU(1)*RLN
16938 PSIRE=0.5D0*ROOT*RLN
16939 PSIIM=-0.5D0*ROOT*PARU(1)
16940 ELSE
16941 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
16942 PHIIM=0D0
16943 PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS))
16944 PSIIM=0D0
16945 ENDIF
16946 IF(EPSP.LE.1D0) THEN
16947 ROOT=SQRT(1D0-EPSP)
16948 IF(EPSP.GT.1D-4) THEN
16949 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
16950 ELSE
16951 RLN=LOG(4D0/EPSP-2D0)
16952 ENDIF
16953 PHIREP=-0.25D0*(RLN**2-PARU(1)**2)
16954 PHIIMP=0.5D0*PARU(1)*RLN
16955 PSIREP=0.5D0*ROOT*RLN
16956 PSIIMP=-0.5D0*ROOT*PARU(1)
16957 ELSE
16958 PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
16959 PHIIMP=0D0
16960 PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
16961 PSIIMP=0D0
16962 ENDIF
16963 FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)*
16964 & (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
16965 FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)*
16966 & (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP))
16967 F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP)
16968 F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP)
16969 IF(J.LE.3*MSTP(1)) THEN
16970C...Fermion loops: loop integral different for A0; charges.
16971 IF(IHIGG.EQ.3) FXYRE=0D0
16972 IF(IHIGG.EQ.3) FXYIM=0D0
16973 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
16974 EJC=-3D0*EJ*VJ
16975 EJH=PARU(151+10*IHIGG)
16976 ELSEIF(J.LE.2*MSTP(1)) THEN
16977 EJC=-3D0*EJ*VJ
16978 EJH=PARU(152+10*IHIGG)
16979 ELSE
16980 EJC=-EJ*VJ
16981 EJH=PARU(153+10*IHIGG)
16982 ENDIF
16983 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
16984 ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE)
16985 ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM)
16986 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
16987C...W loops: loop integral and charges.
16988 HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS)
16989 ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE)
16990 ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM)
16991 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
16992 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
16993 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
16994 ENDIF
16995 ELSE
16996C...Charged H loops: loop integral and charges.
16997 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)*
16998 & PARU(158+10*IHIGG+2*(IHIGG/3))
16999 ETAREJ=FACHHH*FXYRE
17000 ETAIMJ=FACHHH*FXYIM
17001 ENDIF
17002 ETARE=ETARE+ETAREJ
17003 ETAIM=ETAIM+ETAIMJ
17004 260 CONTINUE
17005 ETA2=(ETARE**2+ETAIM**2)/(XW*XW1)
17006 WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2
17007 WID2=WIDS(23,2)
17008
17009 ELSEIF(I.LE.17) THEN
17010C...h0 -> Z0 + Z0, W+ + W-
17011 PM1=PMAS(IABS(KFDP(IDC,1)),1)
17012 PG1=PMAS(IABS(KFDP(IDC,1)),2)
17013 IF(MINT(62).GE.1) THEN
17014 IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND.
17015 & CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND.
17016 & MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN
17017 MOFSV(IHIGG,I-15)=0
17018 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
17019 & 1D0-4D0*RM1))
17020 WID2=1D0
17021 ELSE
17022 MOFSV(IHIGG,I-15)=1
17023 RMAS=SQRT(MAX(0D0,SH))
17024 CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW,
17025 & WID2)
17026 WIDWSV(IHIGG,I-15)=WIDW
17027 WID2SV(IHIGG,I-15)=WID2
17028 ENDIF
17029 ELSE
17030 IF(MOFSV(IHIGG,I-15).EQ.0) THEN
17031 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
17032 & 1D0-4D0*RM1))
17033 WID2=1D0
17034 ELSE
17035 WIDW=WIDWSV(IHIGG,I-15)
17036 WID2=WID2SV(IHIGG,I-15)
17037 ENDIF
17038 ENDIF
17039 WDTP(I)=FAC*WIDW/(2D0*(18-I))
17040 IF(MSTP(49).NE.0) WDTP(I)=WDTP(I)*PMAS(KFHIGG,1)**2/SHFS
17041 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
17042 & PARU(138+I+10*IHIGG)**2
17043 WID2=WID2*WIDS(7+I,1)
17044
17045 ELSEIF(I.EQ.18.AND.IHIGG.GE.2) THEN
17046C...H0 -> Z0 + h0, A0-> Z0 + h0
17047 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
17048 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17049 IF(IHIGG.EQ.2) THEN
17050 WDTP(I)=WDTP(I)*PARU(179)**2
17051 ELSEIF(IHIGG.EQ.3) THEN
17052 WDTP(I)=WDTP(I)*PARU(186)**2
17053 ENDIF
17054 WID2=WIDS(23,2)*WIDS(25,2)
17055
17056 ELSEIF(I.EQ.19.AND.IHIGG.GE.2) THEN
17057C...H0 -> h0 + h0, A0-> h0 + h0
17058 WDTP(I)=FAC*0.25D0*
17059 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
17060 IF(IHIGG.EQ.2) THEN
17061 WDTP(I)=WDTP(I)*PARU(176)**2
17062 ELSEIF(IHIGG.EQ.3) THEN
17063 WDTP(I)=WDTP(I)*PARU(169)**2
17064 ENDIF
17065 WID2=WIDS(25,1)
17066 ELSEIF((I.EQ.20.OR.I.EQ.21).AND.IHIGG.GE.2) THEN
17067C...H0 -> W+/- + H-/+, A0 -> W+/- + H-/+
17068 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
17069 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17070 & *PARU(195+IHIGG)**2
17071 IF(I.EQ.20) THEN
17072 WID2=WIDS(24,2)*WIDS(37,3)
17073 ELSEIF(I.EQ.21) THEN
17074 WID2=WIDS(24,3)*WIDS(37,2)
17075 ENDIF
17076
17077 ELSEIF(I.EQ.22.AND.IHIGG.EQ.2) THEN
17078C...H0 -> Z0 + A0.
17079 WDTP(I)=FAC*0.5D0*PARU(187)**2*SQRT(MAX(0D0,
17080 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*0.0D0
17081 WID2=WIDS(36,2)*WIDS(23,2)
17082
17083 ELSEIF(I.EQ.23.AND.IHIGG.EQ.2) THEN
17084C...H0 -> h0 + A0.
17085 WDTP(I)=FAC*0.5D0*PARU(180)**2*
17086 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
17087 WID2=WIDS(25,2)*WIDS(36,2)
17088
17089 ELSEIF(I.EQ.24.AND.IHIGG.EQ.2) THEN
17090C...H0 -> A0 + A0
17091 WDTP(I)=FAC*0.25D0*PARU(177)**2*
17092 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
17093 WID2=WIDS(36,1)
17094
17095CMRENNA++
17096 ELSE
17097C...Add in SUSY decays (two-body) by rescaling by phase space factor.
17098 RM10=RM1*SH/PMR**2
17099 RM20=RM2*SH/PMR**2
17100 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
17101 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
17102 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
17103 WFAC=0D0
17104 ELSE
17105 WFAC=WFAC/WFAC0
17106 ENDIF
17107 WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
17108CMRENNA--
17109 IF(KFC2.EQ.KFC1) THEN
17110 WID2=WIDS(KFC1,1)
17111 ELSE
17112 KSGN1=2
17113 IF(KFDP(IDC,1).LT.0) KSGN1=3
17114 KSGN2=2
17115 IF(KFDP(IDC,2).LT.0) KSGN2=3
17116 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
17117 ENDIF
17118 ENDIF
17119 WDTP(I)=FUDGE*WDTP(I)
17120 WDTP(0)=WDTP(0)+WDTP(I)
17121 IF(MDME(IDC,1).GT.0) THEN
17122 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17123 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17124 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17125 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17126 ENDIF
17127 270 CONTINUE
17128
17129 ELSEIF(KFLA.EQ.32) THEN
17130C...Z'0:
17131 ICASE=1
17132 XWC=1D0/(16D0*XW*XW1)
17133 FAC=(AEM*XWC/3D0)*SHR
17134 VINT(117)=0D0
17135 280 CONTINUE
17136 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
17137 VINT(111)=0D0
17138 VINT(112)=0D0
17139 VINT(113)=0D0
17140 VINT(114)=0D0
17141 VINT(115)=0D0
17142 VINT(116)=0D0
17143 ENDIF
17144 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
17145 KFAI=IABS(MINT(15))
17146 EI=KCHG(KFAI,1)/3D0
17147 AI=SIGN(1D0,EI+0.1D0)
17148 VI=AI-4D0*EI*XWV
17149 KFAIC=1
17150 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
17151 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
17152 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
17153 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
17154 VPI=PARU(119+2*KFAIC)
17155 API=PARU(120+2*KFAIC)
17156 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
17157 VPI=PARJ(178+2*KFAIC)
17158 API=PARJ(179+2*KFAIC)
17159 ELSE
17160 VPI=PARJ(186+2*KFAIC)
17161 API=PARJ(187+2*KFAIC)
17162 ENDIF
17163 SQMZ=PMAS(23,1)**2
17164 HZ=SHR*VINT(117)
17165 SQMZP=PMAS(32,1)**2
17166 HZP=SHR*WDTP(0)
17167 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
17168 & MSTP(44).EQ.7) VINT(111)=1D0
17169 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=
17170 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
17171 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
17172 & 2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2)
17173 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
17174 & MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
17175 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
17176 & 2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/
17177 & (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2))
17178 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
17179 & MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2)
17180 ENDIF
17181 DO 290 I=1,MDCY(KC,3)
17182 IDC=I+MDCY(KC,2)-1
17183 IF(MDME(IDC,1).LT.0) GOTO 290
17184 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17185 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17186 IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 290
17187 WID2=1D0
17188 IF(I.LE.16) THEN
17189 IF(I.LE.8) THEN
17190C...Z'0 -> q + qbar
17191 EF=KCHG(I,1)/3D0
17192 AF=SIGN(1D0,EF+0.1D0)
17193 VF=AF-4D0*EF*XWV
17194 IF(I.LE.2) THEN
17195 VPF=PARU(123-2*MOD(I,2))
17196 APF=PARU(124-2*MOD(I,2))
17197 ELSEIF(I.LE.4) THEN
17198 VPF=PARJ(182-2*MOD(I,2))
17199 APF=PARJ(183-2*MOD(I,2))
17200 ELSE
17201 VPF=PARJ(190-2*MOD(I,2))
17202 APF=PARJ(191-2*MOD(I,2))
17203 ENDIF
17204 FCOF=3D0*RADC
17205 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
17206 & PYHFTH(SH,SH*RM1,1D0)
17207 IF(I.EQ.6) WID2=WIDS(6,1)
17208 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
17209 ELSEIF(I.LE.16) THEN
17210C...Z'0 -> l+ + l-, nu + nubar
17211 EF=KCHG(I+2,1)/3D0
17212 AF=SIGN(1D0,EF+0.1D0)
17213 VF=AF-4D0*EF*XWV
17214 IF(I.LE.10) THEN
17215 VPF=PARU(127-2*MOD(I,2))
17216 APF=PARU(128-2*MOD(I,2))
17217 ELSEIF(I.LE.12) THEN
17218 VPF=PARJ(186-2*MOD(I,2))
17219 APF=PARJ(187-2*MOD(I,2))
17220 ELSE
17221 VPF=PARJ(194-2*MOD(I,2))
17222 APF=PARJ(195-2*MOD(I,2))
17223 ENDIF
17224 FCOF=1D0
17225 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
17226 ENDIF
17227 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
17228 IF(ICASE.EQ.1) THEN
17229 WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
17230 WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+
17231 & APF**2*(1D0-4D0*RM1))*BE34
17232 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
17233 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
17234 & EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
17235 & VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)*
17236 & VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)*
17237 & AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)*
17238 & VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34
17239 ELSEIF(MINT(61).EQ.2) THEN
17240 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
17241 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
17242 FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34
17243 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
17244 FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))*
17245 & BE34
17246 FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))*
17247 & BE34
17248 ENDIF
17249 ELSEIF(I.EQ.17) THEN
17250C...Z'0 -> W+ + W-
17251 WDTPZP=PARU(129)**2*XW1**2*
17252 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17253 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
17254 IF(ICASE.EQ.1) THEN
17255 WDTPZ=0D0
17256 WDTP(I)=FAC*WDTPZP
17257 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
17258 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
17259 ELSEIF(MINT(61).EQ.2) THEN
17260 FGGF=0D0
17261 FGZF=0D0
17262 FGZPF=0D0
17263 FZZF=0D0
17264 FZZPF=0D0
17265 FZPZPF=WDTPZP
17266 ENDIF
17267 WID2=WIDS(24,1)
17268 ELSEIF(I.EQ.18) THEN
17269C...Z'0 -> H+ + H-
17270 CZC=2D0*(1D0-2D0*XW)
17271 BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
17272 IF(ICASE.EQ.1) THEN
17273 WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C
17274 WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C
17275 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
17276 WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI*
17277 & VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2*
17278 & (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)*
17279 & (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2*
17280 & (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C
17281 ELSEIF(MINT(61).EQ.2) THEN
17282 FGGF=0.25D0*BE34C
17283 FGZF=0.25D0*PARU(142)*CZC*BE34C
17284 FGZPF=0.25D0*PARU(143)*CZC*BE34C
17285 FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C
17286 FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C
17287 FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C
17288 ENDIF
17289 WID2=WIDS(37,1)
17290 ELSEIF(I.EQ.19) THEN
17291C...Z'0 -> Z0 + gamma.
17292 ELSEIF(I.EQ.20) THEN
17293C...Z'0 -> Z0 + h0
17294 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17295 WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)*
17296 & (3D0*RM1+0.25D0*FLAM**2)*FLAM
17297 IF(ICASE.EQ.1) THEN
17298 WDTPZ=0D0
17299 WDTP(I)=FAC*WDTPZP
17300 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
17301 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
17302 ELSEIF(MINT(61).EQ.2) THEN
17303 FGGF=0D0
17304 FGZF=0D0
17305 FGZPF=0D0
17306 FZZF=0D0
17307 FZZPF=0D0
17308 FZPZPF=WDTPZP
17309 ENDIF
17310 WID2=WIDS(23,2)*WIDS(25,2)
17311 ELSEIF(I.EQ.21.OR.I.EQ.22) THEN
17312C...Z' -> h0 + A0 or H0 + A0.
17313 BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17314 IF(I.EQ.21) THEN
17315 CZAH=PARU(186)
17316 CZPAH=PARU(188)
17317 ELSE
17318 CZAH=PARU(187)
17319 CZPAH=PARU(189)
17320 ENDIF
17321 IF(ICASE.EQ.1) THEN
17322 WDTPZ=CZAH**2*BE34C
17323 WDTP(I)=FAC*CZPAH**2*BE34C
17324 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
17325 WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH*
17326 & (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)*
17327 & VINT(116))*BE34C
17328 ELSEIF(MINT(61).EQ.2) THEN
17329 FGGF=0D0
17330 FGZF=0D0
17331 FGZPF=0D0
17332 FZZF=CZAH**2*BE34C
17333 FZZPF=CZAH*CZPAH*BE34C
17334 FZPZPF=CZPAH**2*BE34C
17335 ENDIF
17336 IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2)
17337 IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2)
17338 ENDIF
17339 IF(ICASE.EQ.1) THEN
17340 VINT(117)=VINT(117)+FAC*WDTPZ
17341 WDTP(I)=FUDGE*WDTP(I)
17342 WDTP(0)=WDTP(0)+WDTP(I)
17343 ENDIF
17344 IF(MDME(IDC,1).GT.0) THEN
17345 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
17346 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
17347 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17348 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
17349 & WDTE(I,MDME(IDC,1))
17350 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17351 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17352 ENDIF
17353 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
17354 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
17355 & MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2
17356 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+
17357 & FGZF*WID2
17358 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+
17359 & FGZPF*WID2
17360 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
17361 & MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2
17362 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+
17363 & FZZPF*WID2
17364 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
17365 & MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2
17366 ENDIF
17367 ENDIF
17368 290 CONTINUE
17369 IF(MINT(61).GE.1) ICASE=3-ICASE
17370 IF(ICASE.EQ.2) GOTO 280
17371
17372 ELSEIF(KFLA.EQ.34) THEN
17373C...W'+/-:
17374 FAC=(AEM/(24D0*XW))*SHR
17375 DO 300 I=1,MDCY(KC,3)
17376 IDC=I+MDCY(KC,2)-1
17377 IF(MDME(IDC,1).LT.0) GOTO 300
17378 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17379 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17380 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300
17381 WID2=1D0
17382 IF(I.LE.20) THEN
17383 IF(I.LE.16) THEN
17384C...W'+/- -> q + qbar'
17385 FCOF=3D0*RADC*(PARU(131)**2+PARU(132)**2)*
17386 & VCKM((I-1)/4+1,MOD(I-1,4)+1)
17387 IF(KFLR.GT.0) THEN
17388 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
17389 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
17390 IF(I.GE.13) WID2=WID2*WIDS(7,3)
17391 ELSE
17392 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
17393 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
17394 IF(I.GE.13) WID2=WID2*WIDS(7,2)
17395 ENDIF
17396 ELSEIF(I.LE.20) THEN
17397C...W'+/- -> l+/- + nu
17398 FCOF=PARU(133)**2+PARU(134)**2
17399 IF(KFLR.GT.0) THEN
17400 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
17401 ELSE
17402 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
17403 ENDIF
17404 ENDIF
17405 WDTP(I)=FAC*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)*
17406 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17407 ELSEIF(I.EQ.21) THEN
17408C...W'+/- -> W+/- + Z0
17409 WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)*
17410 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17411 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
17412 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2)
17413 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2)
17414 ELSEIF(I.EQ.23) THEN
17415C...W'+/- -> W+/- + h0
17416 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17417 WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM
17418 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
17419 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
17420 ENDIF
17421 WDTP(I)=FUDGE*WDTP(I)
17422 WDTP(0)=WDTP(0)+WDTP(I)
17423 IF(MDME(IDC,1).GT.0) THEN
17424 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17425 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17426 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17427 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17428 ENDIF
17429 300 CONTINUE
17430
17431 ELSEIF(KFLA.EQ.37) THEN
17432C...H+/-:
17433C IF(MSTP(49).EQ.0) THEN
17434 SHFS=SH
17435C ELSE
17436C SHFS=PMAS(37,1)**2
17437C ENDIF
17438 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
17439 DO 310 I=1,MDCY(KC,3)
17440 IDC=I+MDCY(KC,2)-1
17441 IF(MDME(IDC,1).LT.0) GOTO 310
17442 KFC1=PYCOMP(KFDP(IDC,1))
17443 KFC2=PYCOMP(KFDP(IDC,2))
17444 RM1=PMAS(KFC1,1)**2/SH
17445 RM2=PMAS(KFC2,1)**2/SH
17446 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310
17447 WID2=1D0
17448 IF(I.LE.4) THEN
17449C...H+/- -> q + qbar'
17450 RM1R=PYMRUN(KFDP(IDC,1),SH)**2/SH
17451 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
17452 WDTP(I)=FAC*3D0*RADC*MAX(0D0,(RM1R*PARU(141)**2+
17453 & RM2R/PARU(141)**2)*(1D0-RM1R-RM2R)-4D0*RM1R*RM2R)*
17454 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
17455 IF(KFLR.GT.0) THEN
17456 IF(I.EQ.3) WID2=WIDS(6,2)
17457 IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2)
17458 ELSE
17459 IF(I.EQ.3) WID2=WIDS(6,3)
17460 IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3)
17461 ENDIF
17462 ELSEIF(I.LE.8) THEN
17463C...H+/- -> l+/- + nu
17464 WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)*
17465 & (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0,
17466 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
17467 IF(KFLR.GT.0) THEN
17468 IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2)
17469 ELSE
17470 IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3)
17471 ENDIF
17472 ELSEIF(I.EQ.9) THEN
17473C...H+/- -> W+/- + h0.
17474 WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0,
17475 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17476 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
17477 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
17478
17479CMRENNA++
17480 ELSE
17481C...Add in SUSY decays (two-body) by rescaling by phase space factor.
17482 RM10=RM1*SH/PMR**2
17483 RM20=RM2*SH/PMR**2
17484 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
17485 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
17486 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
17487 WFAC=0D0
17488 ELSE
17489 WFAC=WFAC/WFAC0
17490 ENDIF
17491 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
17492CMRENNA--
17493 KSGN1=2
17494 IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3
17495 KSGN2=2
17496 IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3
17497 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
17498 ENDIF
17499 WDTP(I)=FUDGE*WDTP(I)
17500 WDTP(0)=WDTP(0)+WDTP(I)
17501 IF(MDME(IDC,1).GT.0) THEN
17502 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17503 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17504 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17505 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17506 ENDIF
17507 310 CONTINUE
17508
17509 ELSEIF(KFLA.EQ.41) THEN
17510C...R:
17511 FAC=(AEM/(12D0*XW))*SHR
17512 DO 320 I=1,MDCY(KC,3)
17513 IDC=I+MDCY(KC,2)-1
17514 IF(MDME(IDC,1).LT.0) GOTO 320
17515 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17516 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17517 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320
17518 WID2=1D0
17519 IF(I.LE.6) THEN
17520C...R -> q + qbar'
17521 FCOF=3D0*RADC
17522 ELSEIF(I.LE.9) THEN
17523C...R -> l+ + l'-
17524 FCOF=1D0
17525 ENDIF
17526 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
17527 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17528 IF(KFLR.GT.0) THEN
17529 IF(I.EQ.4) WID2=WIDS(6,3)
17530 IF(I.EQ.5) WID2=WIDS(7,3)
17531 IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3)
17532 IF(I.EQ.9) WID2=WIDS(17,3)
17533 ELSE
17534 IF(I.EQ.4) WID2=WIDS(6,2)
17535 IF(I.EQ.5) WID2=WIDS(7,2)
17536 IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2)
17537 IF(I.EQ.9) WID2=WIDS(17,2)
17538 ENDIF
17539 WDTP(I)=FUDGE*WDTP(I)
17540 WDTP(0)=WDTP(0)+WDTP(I)
17541 IF(MDME(IDC,1).GT.0) THEN
17542 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17543 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17544 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17545 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17546 ENDIF
17547 320 CONTINUE
17548
17549 ELSEIF(KFLA.EQ.42) THEN
17550C...LQ (leptoquark).
17551 FAC=(AEM/4D0)*PARU(151)*SHR
17552 DO 330 I=1,MDCY(KC,3)
17553 IDC=I+MDCY(KC,2)-1
17554 IF(MDME(IDC,1).LT.0) GOTO 330
17555 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17556 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17557 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330
17558 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17559 WID2=1D0
17560 ILQQ=KFDP(IDC,1)*ISIGN(1,KFLR)
17561 IF(ILQQ.GE.6) WID2=WIDS(ILQQ,2)
17562 IF(ILQQ.LE.-6) WID2=WIDS(-ILQQ,3)
17563 ILQL=KFDP(IDC,2)*ISIGN(1,KFLR)
17564 IF(ILQL.GE.17) WID2=WID2*WIDS(ILQL,2)
17565 IF(ILQL.LE.-17) WID2=WID2*WIDS(-ILQL,3)
17566 WDTP(I)=FUDGE*WDTP(I)
17567 WDTP(0)=WDTP(0)+WDTP(I)
17568 IF(MDME(IDC,1).GT.0) THEN
17569 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17570 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17571 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17572 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17573 ENDIF
17574 330 CONTINUE
17575
17576 ELSEIF(KFLA.EQ.KTECHN+111.OR.KFLA.EQ.KTECHN+221) THEN
17577C...Techni-pi0 and techni-pi0':
17578 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
17579 DO 340 I=1,MDCY(KC,3)
17580 IDC=I+MDCY(KC,2)-1
17581 IF(MDME(IDC,1).LT.0) GOTO 340
17582 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
17583 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
17584 RM1=PM1**2/SH
17585 RM2=PM2**2/SH
17586 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340
17587 WID2=1D0
17588C...pi_tc -> g + g
17589 IF(I.EQ.8) THEN
17590 FACP=(AS/(4D0*PARU(1))*ITCM(1)/RTCM(1))**2
17591 & /(8D0*PARU(1))*SH*SHR
17592 IF(KFLA.EQ.KTECHN+111) THEN
17593 FACP=FACP*RTCM(9)
17594 ELSE
17595 FACP=FACP*RTCM(10)
17596 ENDIF
17597 WDTP(I)=FACP
17598 ELSE
17599C...pi_tc -> f + fbar.
17600 FCOF=1D0
17601 IKA=IABS(KFDP(IDC,1))
17602 IF(IKA.LT.10) FCOF=3D0*RADC
17603 HM1=PM1
17604 HM2=PM2
17605 IF(IKA.GE.4.AND.IKA.LE.6) THEN
17606 FCOF=FCOF*RTCM(1+IKA)**2
17607 HM1=PYMRUN(KFDP(IDC,1),SH)
17608 HM2=PYMRUN(KFDP(IDC,2),SH)
17609 ELSEIF(IKA.EQ.15) THEN
17610 FCOF=FCOF*RTCM(8)**2
17611 ENDIF
17612 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
17613 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17614 ENDIF
17615 WDTP(I)=FUDGE*WDTP(I)
17616 WDTP(0)=WDTP(0)+WDTP(I)
17617 IF(MDME(IDC,1).GT.0) THEN
17618 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17619 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17620 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17621 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17622 ENDIF
17623 340 CONTINUE
17624
17625 ELSEIF(KFLA.EQ.KTECHN+211) THEN
17626C...pi+_tc
17627 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
17628 DO 350 I=1,MDCY(KC,3)
17629 IDC=I+MDCY(KC,2)-1
17630 IF(MDME(IDC,1).LT.0) GOTO 350
17631 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
17632 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
17633 PM3=0D0
17634 IF(I.EQ.5) PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
17635 RM1=PM1**2/SH
17636 RM2=PM2**2/SH
17637 RM3=PM3**2/SH
17638 IF(SQRT(RM1)+SQRT(RM2)+SQRT(RM3).GT.1D0) GOTO 350
17639 WID2=1D0
17640C...pi_tc -> f + f'.
17641 FCOF=1D0
17642 IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
17643C...pi_tc+ -> W b b~
17644 IF(I.EQ.5.AND.SHR.LT.PMAS(6,1)+PMAS(5,1)) THEN
17645 FCOF=3D0*RADC
17646 XMT2=PMAS(6,1)**2/SH
17647 FACP=FAC/(4D0*PARU(1))*FCOF*XMT2*RTCM(7)**2
17648 KFC3=PYCOMP(KFDP(IDC,3))
17649 CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3)
17650 CHECK = SQRT(RM1)
17651 T0 = (1D0-CHECK**2)*
17652 & (XMT2*(6D0*XMT2**2+3D0*XMT2*RM1-4D0*RM1**2)-
17653 & (5D0*XMT2**2+2D0*XMT2*RM1-8D0*RM1**2))/(4D0*XMT2**2)
17654 T1 = (1D0-XMT2)*(RM1-XMT2)*((XMT2**2+XMT2*RM1+4D0*RM1**2)
17655 & -3D0*XMT2**2*(XMT2+RM1))/(2D0*XMT2**3)
17656 T3 = RM1**2/XMT2**3*(3D0*XMT2-4D0*RM1+4D0*XMT2*RM1)
17657 WDTP(I)=FACP*(T0 + T1*LOG((XMT2-CHECK**2)/(XMT2-1D0))
17658 & +T3*LOG(CHECK))
17659 IF(KFLR.GT.0) THEN
17660 WID2=WIDS(24,2)
17661 ELSE
17662 WID2=WIDS(24,3)
17663 ENDIF
17664 ELSE
17665 FCOF=1D0
17666 IKA=IABS(KFDP(IDC,1))
17667 IF(IKA.LT.10) FCOF=3D0*RADC
17668 HM1=PM1
17669 HM2=PM2
17670 IF(I.GE.1.AND.I.LE.5) THEN
17671 IF(I.LE.2) THEN
17672 FCOF=FCOF*RTCM(5)**2
17673 ELSEIF(I.LE.4) THEN
17674 FCOF=FCOF*RTCM(6)**2
17675 ELSEIF(I.EQ.5) THEN
17676 FCOF=FCOF*RTCM(7)**2
17677 ENDIF
17678 HM1=PYMRUN(KFDP(IDC,1),SH)
17679 HM2=PYMRUN(KFDP(IDC,2),SH)
17680 ELSEIF(I.EQ.8) THEN
17681 FCOF=FCOF*RTCM(8)**2
17682 ENDIF
17683 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
17684 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17685 ENDIF
17686 WDTP(I)=FUDGE*WDTP(I)
17687 WDTP(0)=WDTP(0)+WDTP(I)
17688 IF(MDME(IDC,1).GT.0) THEN
17689 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17690 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17691 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17692 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17693 ENDIF
17694 350 CONTINUE
17695
17696 ELSEIF(KFLA.EQ.KTECHN+331) THEN
17697C...Techni-eta.
17698 FAC=(SH/PARP(46)**2)*SHR
17699 DO 360 I=1,MDCY(KC,3)
17700 IDC=I+MDCY(KC,2)-1
17701 IF(MDME(IDC,1).LT.0) GOTO 360
17702 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17703 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17704 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360
17705 WID2=1D0
17706 IF(I.LE.2) THEN
17707 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1))
17708 IF(I.EQ.2) WID2=WIDS(6,1)
17709 ELSE
17710 WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3)
17711 ENDIF
17712 WDTP(I)=FUDGE*WDTP(I)
17713 WDTP(0)=WDTP(0)+WDTP(I)
17714 IF(MDME(IDC,1).GT.0) THEN
17715 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17716 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17717 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17718 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17719 ENDIF
17720 360 CONTINUE
17721
17722 ELSEIF(KFLA.EQ.KTECHN+113) THEN
17723C...Techni-rho0:
17724 ALPRHT=2.91D0*(3D0/ITCM(1))
17725 FAC=(ALPRHT/12D0)*SHR
17726 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
17727 SQMZ=PMAS(23,1)**2
17728 SQMW=PMAS(24,1)**2
17729 SHP=SH
17730 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
17731 GMMZ=SHR*WDTPP(0)
17732 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
17733 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
17734 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
17735 DO 370 I=1,MDCY(KC,3)
17736 IDC=I+MDCY(KC,2)-1
17737 IF(MDME(IDC,1).LT.0) GOTO 370
17738 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17739 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17740 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370
17741 WID2=1D0
17742 IF(I.EQ.1) THEN
17743C...rho_tc0 -> W+ + W-.
17744 WDTP(I)=FAC*RTCM(3)**4*
17745 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17746 WID2=WIDS(24,1)
17747 ELSEIF(I.EQ.2) THEN
17748C...rho_tc0 -> W+ + pi_tc-.
17749 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
17750 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
17751 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
17752 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
17753 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
17754 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
17755 ELSEIF(I.EQ.3) THEN
17756C...rho_tc0 -> pi_tc+ + W-.
17757 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
17758 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
17759 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
17760 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
17761 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
17762 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(24,3)
17763 ELSEIF(I.EQ.4) THEN
17764C...rho_tc0 -> pi_tc+ + pi_tc-.
17765 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
17766 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17767 WID2=WIDS(PYCOMP(KTECHN+211),1)
17768 ELSEIF(I.EQ.5) THEN
17769C...rho_tc0 -> gamma + pi_tc0
17770 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17771 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
17772 & SHR**3
17773 WID2=WIDS(PYCOMP(KTECHN+111),2)
17774 ELSEIF(I.EQ.6) THEN
17775C...rho_tc0 -> gamma + pi_tc0'
17776 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17777 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*SHR**3
17778 WID2=WIDS(PYCOMP(KTECHN+221),2)
17779 ELSEIF(I.EQ.7) THEN
17780C...rho_tc0 -> Z0 + pi_tc0
17781 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17782 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
17783 & XW/XW1*SHR**3
17784 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
17785 ELSEIF(I.EQ.8) THEN
17786C...rho_tc0 -> Z0 + pi_tc0'
17787 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17788 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
17789 & XW/XW1*SHR**3
17790 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
17791 ELSE
17792C...rho_tc0 -> f + fbar.
17793 WID2=1D0
17794 IF(I.LE.16) THEN
17795 IA=I-8
17796 FCOF=3D0*RADC
17797 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
17798 ELSE
17799 IA=I-6
17800 FCOF=1D0
17801 IF(IA.GE.17) WID2=WIDS(IA,1)
17802 ENDIF
17803 EI=KCHG(IA,1)/3D0
17804 AI=SIGN(1D0,EI+0.1D0)
17805 VI=AI-4D0*EI*XWV
17806 VALI=0.5D0*(VI+AI)
17807 VARI=0.5D0*(VI-AI)
17808 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
17809 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
17810 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
17811 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
17812 ENDIF
17813 WDTP(I)=FUDGE*WDTP(I)
17814 WDTP(0)=WDTP(0)+WDTP(I)
17815 IF(MDME(IDC,1).GT.0) THEN
17816 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17817 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17818 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17819 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17820 ENDIF
17821 370 CONTINUE
17822
17823 ELSEIF(KFLA.EQ.KTECHN+213) THEN
17824C...Techni-rho+/-:
17825 ALPRHT=2.91D0*(3D0/ITCM(1))
17826 FAC=(ALPRHT/12D0)*SHR
17827 SQMZ=PMAS(23,1)**2
17828 SQMW=PMAS(24,1)**2
17829 SHP=SH
17830 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
17831 GMMW=SHR*WDTPP(0)
17832 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
17833 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
17834 DO 380 I=1,MDCY(KC,3)
17835 IDC=I+MDCY(KC,2)-1
17836 IF(MDME(IDC,1).LT.0) GOTO 380
17837 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17838 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17839 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380
17840 WID2=1D0
17841 IF(I.EQ.1) THEN
17842C...rho_tc+ -> W+ + Z0.
17843 WDTP(I)=FAC*RTCM(3)**4*
17844 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17845 IF(KFLR.GT.0) THEN
17846 WID2=WIDS(24,2)*WIDS(23,2)
17847 ELSE
17848 WID2=WIDS(24,3)*WIDS(23,2)
17849 ENDIF
17850 ELSEIF(I.EQ.2) THEN
17851C...rho_tc+ -> W+ + pi_tc0.
17852 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
17853 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
17854 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
17855 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
17856 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
17857 IF(KFLR.GT.0) THEN
17858 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+111),2)
17859 ELSE
17860 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+111),2)
17861 ENDIF
17862 ELSEIF(I.EQ.3) THEN
17863C...rho_tc+ -> pi_tc+ + Z0.
17864 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
17865 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
17866 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
17867 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMZ/SH)*
17868 & (1D0-RTCM(3)**2)/4D0/XW/XW1/24D0/RTCM(13)**2*SHR**3+
17869 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17870 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
17871 & SHR**3*XW/XW1
17872 IF(KFLR.GT.0) THEN
17873 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(23,2)
17874 ELSE
17875 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(23,2)
17876 ENDIF
17877 ELSEIF(I.EQ.4) THEN
17878C...rho_tc+ -> pi_tc+ + pi_tc0.
17879 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
17880 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17881 IF(KFLR.GT.0) THEN
17882 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(PYCOMP(KTECHN+111),2)
17883 ELSE
17884 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(PYCOMP(KTECHN+111),2)
17885 ENDIF
17886 ELSEIF(I.EQ.5) THEN
17887C...rho_tc+ -> pi_tc+ + gamma
17888 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17889 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
17890 & SHR**3
17891 IF(KFLR.GT.0) THEN
17892 WID2=WIDS(PYCOMP(KTECHN+211),2)
17893 ELSE
17894 WID2=WIDS(PYCOMP(KTECHN+211),3)
17895 ENDIF
17896 ELSEIF(I.EQ.6) THEN
17897C...rho_tc+ -> W+ + pi_tc0'
17898 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17899 & (1D0-RTCM(4)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3
17900 IF(KFLR.GT.0) THEN
17901 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+221),2)
17902 ELSE
17903 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+221),2)
17904 ENDIF
17905 ELSE
17906C...rho_tc+ -> f + fbar'.
17907 IA=I-6
17908 WID2=1D0
17909 IF(IA.LE.16) THEN
17910 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
17911 IF(KFLR.GT.0) THEN
17912 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
17913 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
17914 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
17915 ELSE
17916 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
17917 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
17918 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
17919 ENDIF
17920 ELSE
17921 FCOF=1D0
17922 IF(KFLR.GT.0) THEN
17923 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
17924 ELSE
17925 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
17926 ENDIF
17927 ENDIF
17928 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
17929 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17930 ENDIF
17931 WDTP(I)=FUDGE*WDTP(I)
17932 WDTP(0)=WDTP(0)+WDTP(I)
17933 IF(MDME(IDC,1).GT.0) THEN
17934 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17935 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17936 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17937 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17938 ENDIF
17939 380 CONTINUE
17940
17941 ELSEIF(KFLA.EQ.KTECHN+223) THEN
17942C...Techni-omega:
17943 ALPRHT=2.91D0*(3D0/ITCM(1))
17944 FAC=(ALPRHT/12D0)*SHR
17945 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR*(2D0*RTCM(2)-1D0)**2
17946 SQMZ=PMAS(23,1)**2
17947 SHP=SH
17948 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
17949 GMMZ=SHR*WDTPP(0)
17950 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
17951 BWZI=-(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
17952 DO 390 I=1,MDCY(KC,3)
17953 IDC=I+MDCY(KC,2)-1
17954 IF(MDME(IDC,1).LT.0) GOTO 390
17955 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17956 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17957 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390
17958 WID2=1D0
17959 IF(I.EQ.1) THEN
17960C...omega_tc0 -> gamma + pi_tc0.
17961 WDTP(I)=AEM/24D0/RTCM(12)**2*(1D0-RTCM(3)**2)*
17962 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*SHR**3
17963 WID2=WIDS(PYCOMP(KTECHN+111),2)
17964 ELSEIF(I.EQ.2) THEN
17965C...omega_tc0 -> Z0 + pi_tc0
17966 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17967 & (1D0-RTCM(3)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
17968 & XW/XW1*SHR**3
17969 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
17970 ELSEIF(I.EQ.3) THEN
17971C...omega_tc0 -> gamma + pi_tc0'
17972 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17973 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
17974 & SHR**3
17975 WID2=WIDS(PYCOMP(KTECHN+221),2)
17976 ELSEIF(I.EQ.4) THEN
17977C...omega_tc0 -> Z0 + pi_tc0'
17978 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17979 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
17980 & XW/XW1*SHR**3
17981 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
17982 ELSEIF(I.EQ.5) THEN
17983C...omega_tc0 -> W+ + pi_tc-
17984 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17985 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
17986 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
17987 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17988 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
17989 ELSEIF(I.EQ.6) THEN
17990C...omega_tc0 -> pi_tc+ + W-
17991 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17992 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
17993 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
17994 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17995 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
17996 ELSEIF(I.EQ.7) THEN
17997C...omega_tc0 -> W+ + W-.
17998 WDTP(I)=FAC*RTCM(3)**4*RTCM(11)**2*
17999 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
18000 WID2=WIDS(24,1)
18001 ELSEIF(I.EQ.8) THEN
18002C...omega_tc0 -> pi_tc+ + pi_tc-.
18003 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*RTCM(11)**2*
18004 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
18005 WID2=WIDS(PYCOMP(KTECHN+211),1)
18006 ELSE
18007C...omega_tc0 -> f + fbar.
18008 WID2=1D0
18009 IF(I.LE.14) THEN
18010 IA=I-8
18011 FCOF=3D0*RADC
18012 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
18013 ELSE
18014 IA=I-6
18015 FCOF=1D0
18016 IF(IA.GE.17) WID2=WIDS(IA,1)
18017 ENDIF
18018 EI=KCHG(IA,1)/3D0
18019 AI=SIGN(1D0,EI+0.1D0)
18020 VI=AI-4D0*EI*XWV
18021 VALI=-0.5D0*(VI+AI)
18022 VARI=-0.5D0*(VI-AI)
18023 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
18024 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
18025 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
18026 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
18027 ENDIF
18028 WDTP(I)=FUDGE*WDTP(I)
18029 WDTP(0)=WDTP(0)+WDTP(I)
18030 IF(MDME(IDC,1).GT.0) THEN
18031 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18032 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18033 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18034 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18035 ENDIF
18036 390 CONTINUE
18037
18038C.....V8 -> quark anti-quark
18039 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
18040 FAC=AS/6D0*SHR
18041 TANT3=RTCM(21)
18042 IF(ITCM(2).EQ.0) THEN
18043 IMDL=1
18044 ELSEIF(ITCM(2).EQ.1) THEN
18045 IMDL=2
18046 ENDIF
18047 DO 400 I=1,MDCY(KC,3)
18048 IDC=I+MDCY(KC,2)-1
18049 IF(MDME(IDC,1).LT.0) GOTO 400
18050 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
18051 RM1=PM1**2/SH
18052 IF(RM1.GT.0.25D0) GOTO 400
18053 WID2=1D0
18054 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
18055 FMIX=1D0/TANT3**2
18056 ELSE
18057 FMIX=TANT3**2
18058 ENDIF
18059 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
18060 IF(I.EQ.6) WID2=WIDS(6,1)
18061 WDTP(I)=FUDGE*WDTP(I)
18062 WDTP(0)=WDTP(0)+WDTP(I)
18063 IF(MDME(IDC,1).GT.0) THEN
18064 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18065 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18066 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18067 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18068 ENDIF
18069 400 CONTINUE
18070
18071 ELSEIF(KFLA.EQ.KTECHN+100111.OR.KFLA.EQ.KTECHN+200111) THEN
18072 FAC=(1D0/(4D0*PARU(1)*RTCM(1)**2))*SHR
18073 CLEBF=0D0
18074 DO 410 I=1,MDCY(KC,3)
18075 IDC=I+MDCY(KC,2)-1
18076 IF(MDME(IDC,1).LT.0) GOTO 410
18077 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18078 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18079 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410
18080 WID2=1D0
18081C...pi_tc -> g + g
18082 IF(I.EQ.7) THEN
18083 IF(KFLA.EQ.KTECHN+100111) THEN
18084 CLEBG=4D0/3D0
18085 ELSE
18086 CLEBG=5D0/3D0
18087 ENDIF
18088 FACP=(AS/(8D0*PARU(1))*ITCM(1)/RTCM(1))**2
18089 & /(2D0*PARU(1))*SH*SHR*CLEBG
18090 WDTP(I)=FACP
18091 ELSE
18092C...pi_tc -> f + fbar.
18093 IF(I.EQ.6) WID2=WIDS(6,1)
18094 FCOF=1D0
18095 IKA=IABS(KFDP(IDC,1))
18096 IF(IKA.LT.10) FCOF=3D0*RADC
18097 HM1=PYMRUN(KFDP(IDC,1),SH)
18098 WDTP(I)=FAC*FCOF*HM1**2*CLEBF*
18099 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18100 ENDIF
18101 WDTP(I)=FUDGE*WDTP(I)
18102 WDTP(0)=WDTP(0)+WDTP(I)
18103 IF(MDME(IDC,1).GT.0) THEN
18104 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18105 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18106 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18107 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18108 ENDIF
18109 410 CONTINUE
18110
18111 ELSEIF(KFLA.GE.KTECHN+100113.AND.KFLA.LE.KTECHN+400113) THEN
18112 FAC=AS/6D0*SHR
18113 ALPRHT=2.91D0*(3D0/ITCM(1))
18114 TANT3=RTCM(21)
18115 SIN2T=2D0*TANT3/(TANT3**2+1D0)
18116 SINT3=TANT3/SQRT(TANT3**2+1D0)
18117 CSXPP=RTCM(22)
18118 RM82=RTCM(27)**2
18119 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
18120 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)
18121 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
18122 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)
18123 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
18124 & SINT3**2)*2D0
18125 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
18126 & SINT3**2)*2D0
18127 CALL PYWIDX(KTECHN+100021,SH,WDTPP,WDTEP)
18128
18129 IF(WDTPP(0).GT.RTCM(33)*SHR) WDTPP(0)=RTCM(33)*SHR
18130 GMV8=SHR*WDTPP(0)
18131 RMV8=PMAS(PYCOMP(KTECHN+100021),1)
18132 FV8RE=SH*(SH-RMV8**2)/((SH-RMV8**2)**2+GMV8**2)
18133 FV8IM=SH*GMV8/((SH-RMV8**2)**2+GMV8**2)
18134 IF(ITCM(2).EQ.0) THEN
18135 IMDL=1
18136 ELSE
18137 IMDL=2
18138 ENDIF
18139 DO 420 I=1,MDCY(KC,3)
18140 IF(I.EQ.7.AND.(KFLA.EQ.KTECHN+200113.OR.
18141 & KFLA.EQ.KTECHN+300113)) GOTO 420
18142 IDC=I+MDCY(KC,2)-1
18143 IF(MDME(IDC,1).LT.0) GOTO 420
18144 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18145 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18146 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 420
18147 WID2=1D0
18148 IF(I.LE.6) THEN
18149 IF(I.EQ.6) WID2=WIDS(6,1)
18150 XIG=1D0
18151 IF(KFLA.EQ.KTECHN+200113) THEN
18152 XIG=0D0
18153 XIJ=X12
18154 ELSEIF(KFLA.EQ.KTECHN+300113) THEN
18155 XIG=0D0
18156 XIJ=X21
18157 ELSEIF(KFLA.EQ.KTECHN+100113) THEN
18158 XIJ=X11
18159 ELSE
18160 XIJ=X22
18161 ENDIF
18162 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
18163 FMIX=1D0/TANT3/SIN2T
18164 ELSE
18165 FMIX=-TANT3/SIN2T
18166 ENDIF
18167 XFAC=(XIG+FMIX*XIJ*FV8RE)**2+(FMIX*XIJ*FV8IM)**2
18168 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*AS/ALPRHT*XFAC
18169 ELSEIF(I.EQ.7) THEN
18170 WDTP(I)=SHR*AS**2/(4D0*ALPRHT)
18171 ELSEIF(KFLA.EQ.KTECHN+400113.AND.I.LE.9) THEN
18172 PSH=SHR*(1D0-RM1)/2D0
18173 WDTP(I)=AS/9D0*PSH**3/RM82
18174 IF(I.EQ.8) THEN
18175 WDTP(I)=2D0*WDTP(I)*CSXPP**2
18176 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
18177 ELSE
18178 WDTP(I)=5D0*WDTP(I)
18179 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
18180 ENDIF
18181 ENDIF
18182 WDTP(I)=FUDGE*WDTP(I)
18183 WDTP(0)=WDTP(0)+WDTP(I)
18184 IF(MDME(IDC,1).GT.0) THEN
18185 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18186 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18187 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18188 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18189 ENDIF
18190 420 CONTINUE
18191
18192 ELSEIF(KFLA.EQ.KEXCIT+1) THEN
18193C...d* excited quark.
18194 FAC=(SH/RTCM(41)**2)*SHR
18195 DO 430 I=1,MDCY(KC,3)
18196 IDC=I+MDCY(KC,2)-1
18197 IF(MDME(IDC,1).LT.0) GOTO 430
18198 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18199 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18200 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 430
18201 WID2=1D0
18202 IF(I.EQ.1) THEN
18203C...d* -> g + d.
18204 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
18205 WID2=1D0
18206 ELSEIF(I.EQ.2) THEN
18207C...d* -> gamma + d.
18208 QF=-RTCM(43)/2D0+RTCM(44)/6D0
18209 WDTP(I)=FAC*AEM*QF**2/4D0
18210 WID2=1D0
18211 ELSEIF(I.EQ.3) THEN
18212C...d* -> Z0 + d.
18213 QF=-RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
18214 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
18215 & (1D0-RM1)**2*(2D0+RM1)
18216 WID2=WIDS(23,2)
18217 ELSEIF(I.EQ.4) THEN
18218C...d* -> W- + u.
18219 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
18220 & (1D0-RM1)**2*(2D0+RM1)
18221 IF(KFLR.GT.0) WID2=WIDS(24,3)
18222 IF(KFLR.LT.0) WID2=WIDS(24,2)
18223 ENDIF
18224 WDTP(I)=FUDGE*WDTP(I)
18225 WDTP(0)=WDTP(0)+WDTP(I)
18226 IF(MDME(IDC,1).GT.0) THEN
18227 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18228 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18229 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18230 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18231 ENDIF
18232 430 CONTINUE
18233
18234 ELSEIF(KFLA.EQ.KEXCIT+2) THEN
18235C...u* excited quark.
18236 FAC=(SH/RTCM(41)**2)*SHR
18237 DO 440 I=1,MDCY(KC,3)
18238 IDC=I+MDCY(KC,2)-1
18239 IF(MDME(IDC,1).LT.0) GOTO 440
18240 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18241 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18242 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 440
18243 WID2=1D0
18244 IF(I.EQ.1) THEN
18245C...u* -> g + u.
18246 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
18247 WID2=1D0
18248 ELSEIF(I.EQ.2) THEN
18249C...u* -> gamma + u.
18250 QF=RTCM(43)/2D0+RTCM(44)/6D0
18251 WDTP(I)=FAC*AEM*QF**2/4D0
18252 WID2=1D0
18253 ELSEIF(I.EQ.3) THEN
18254C...u* -> Z0 + u.
18255 QF=RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
18256 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
18257 & (1D0-RM1)**2*(2D0+RM1)
18258 WID2=WIDS(23,2)
18259 ELSEIF(I.EQ.4) THEN
18260C...u* -> W+ + d.
18261 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
18262 & (1D0-RM1)**2*(2D0+RM1)
18263 IF(KFLR.GT.0) WID2=WIDS(24,2)
18264 IF(KFLR.LT.0) WID2=WIDS(24,3)
18265 ENDIF
18266 WDTP(I)=FUDGE*WDTP(I)
18267 WDTP(0)=WDTP(0)+WDTP(I)
18268 IF(MDME(IDC,1).GT.0) THEN
18269 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18270 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18271 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18272 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18273 ENDIF
18274 440 CONTINUE
18275
18276 ELSEIF(KFLA.EQ.KEXCIT+11) THEN
18277C...e* excited lepton.
18278 FAC=(SH/RTCM(41)**2)*SHR
18279 DO 450 I=1,MDCY(KC,3)
18280 IDC=I+MDCY(KC,2)-1
18281 IF(MDME(IDC,1).LT.0) GOTO 450
18282 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18283 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18284 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 450
18285 WID2=1D0
18286 IF(I.EQ.1) THEN
18287C...e* -> gamma + e.
18288 QF=-RTCM(43)/2D0-RTCM(44)/2D0
18289 WDTP(I)=FAC*AEM*QF**2/4D0
18290 WID2=1D0
18291 ELSEIF(I.EQ.2) THEN
18292C...e* -> Z0 + e.
18293 QF=-RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
18294 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
18295 & (1D0-RM1)**2*(2D0+RM1)
18296 WID2=WIDS(23,2)
18297 ELSEIF(I.EQ.3) THEN
18298C...e* -> W- + nu.
18299 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
18300 & (1D0-RM1)**2*(2D0+RM1)
18301 IF(KFLR.GT.0) WID2=WIDS(24,3)
18302 IF(KFLR.LT.0) WID2=WIDS(24,2)
18303 ENDIF
18304 WDTP(I)=FUDGE*WDTP(I)
18305 WDTP(0)=WDTP(0)+WDTP(I)
18306 IF(MDME(IDC,1).GT.0) THEN
18307 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18308 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18309 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18310 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18311 ENDIF
18312 450 CONTINUE
18313
18314 ELSEIF(KFLA.EQ.KEXCIT+12) THEN
18315C...nu*_e excited neutrino.
18316 FAC=(SH/RTCM(41)**2)*SHR
18317 DO 460 I=1,MDCY(KC,3)
18318 IDC=I+MDCY(KC,2)-1
18319 IF(MDME(IDC,1).LT.0) GOTO 460
18320 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18321 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18322 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 460
18323 WID2=1D0
18324 IF(I.EQ.1) THEN
18325C...nu*_e -> Z0 + nu*_e.
18326 QF=RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
18327 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
18328 & (1D0-RM1)**2*(2D0+RM1)
18329 WID2=WIDS(23,2)
18330 ELSEIF(I.EQ.2) THEN
18331C...nu*_e -> W+ + e.
18332 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
18333 & (1D0-RM1)**2*(2D0+RM1)
18334 IF(KFLR.GT.0) WID2=WIDS(24,2)
18335 IF(KFLR.LT.0) WID2=WIDS(24,3)
18336 ENDIF
18337 WDTP(I)=FUDGE*WDTP(I)
18338 WDTP(0)=WDTP(0)+WDTP(I)
18339 IF(MDME(IDC,1).GT.0) THEN
18340 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18341 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18342 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18343 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18344 ENDIF
18345 460 CONTINUE
18346
18347 ELSEIF(KFLA.EQ.KDIMEN+39) THEN
18348C...G* (graviton resonance):
18349 FAC=(PARP(50)**2/PARU(1))*SHR
18350 DO 470 I=1,MDCY(KC,3)
18351 IDC=I+MDCY(KC,2)-1
18352 IF(MDME(IDC,1).LT.0) GOTO 470
18353 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18354 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18355 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 470
18356 WID2=1D0
18357 IF(I.LE.8) THEN
18358C...G* -> q + qbar
18359 FCOF=3D0*RADC
18360 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
18361 & PYHFTH(SH,SH*RM1,1D0)
18362 WDTP(I)=FAC*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
18363 & (1D0+8D0*RM1/3D0)/320D0
18364 IF(I.EQ.6) WID2=WIDS(6,1)
18365 IF(I.EQ.7.OR.I.EQ.8) WID2=WIDS(I,1)
18366 ELSEIF(I.LE.16) THEN
18367C...G* -> l+ + l-, nu + nubar
18368 FCOF=1D0
18369 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
18370 & (1D0+8D0*RM1/3D0)/320D0
18371 IF(I.EQ.15.OR.I.EQ.16) WID2=WIDS(2+I,1)
18372 ELSEIF(I.EQ.17) THEN
18373C...G* -> g + g.
18374 WDTP(I)=FAC/20D0
18375 ELSEIF(I.EQ.18) THEN
18376C...G* -> gamma + gamma.
18377 WDTP(I)=FAC/160D0
18378 ELSEIF(I.EQ.19) THEN
18379C...G* -> Z0 + Z0.
18380 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
18381 & 14D0*RM1/3D0+4D0*RM1**2)/160D0
18382 WID2=WIDS(23,1)
18383 ELSEIF(I.EQ.20) THEN
18384C...G* -> W+ + W-.
18385 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
18386 & 14D0*RM1/3D0+4D0*RM1**2)/80D0
18387 WID2=WIDS(24,1)
18388 ENDIF
18389 WDTP(I)=FUDGE*WDTP(I)
18390 WDTP(0)=WDTP(0)+WDTP(I)
18391 IF(MDME(IDC,1).GT.0) THEN
18392 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18393 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18394 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18395 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18396 ENDIF
18397 470 CONTINUE
18398
18399 ELSEIF(KFLA.EQ.9900012.OR.KFLA.EQ.9900014.OR.KFLA.EQ.9900016) THEN
18400C...nu_eR, nu_muR, nu_tauR: righthanded Majorana neutrinos.
18401 PMWR=MAX(1.001D0*SHR,PMAS(PYCOMP(9900024),1))
18402 FAC=(AEM**2/(768D0*PARU(1)*XW**2))*SHR**5/PMWR**4
18403 DO 480 I=1,MDCY(KC,3)
18404 IDC=I+MDCY(KC,2)-1
18405 IF(MDME(IDC,1).LT.0) GOTO 480
18406 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
18407 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
18408 PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
18409 IF(PM1+PM2+PM3.GE.SHR) GOTO 480
18410 WID2=1D0
18411 IF(I.LE.9) THEN
18412C...nu_lR -> l- qbar q'
18413 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
18414 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
18415 ELSEIF(I.LE.18) THEN
18416C...nu_lR -> l+ q qbar'
18417 FCOF=3D0*RADC*VCKM((I-10)/3+1,MOD(I-10,3)+1)
18418 IF(MOD(I-9,3).EQ.0) WID2=WIDS(6,3)
18419 ELSE
18420C...nu_lR -> l- l'+ nu_lR' + charge conjugate.
18421 FCOF=1D0
18422 WID2=WIDS(PYCOMP(KFDP(IDC,3)),2)
18423 ENDIF
18424 X=(PM1+PM2+PM3)/SHR
18425 FX=1D0-8D0*X**2+8D0*X**6-X**8-24D0*X**4*LOG(X)
18426 Y=(SHR/PMWR)**2
18427 FY=(12D0*(1D0-Y)*LOG(1D0-Y)+12D0*Y-6D0*Y**2-2D0*Y**3)/Y**4
18428 WDTP(I)=FAC*FCOF*FX*FY
18429 WDTP(I)=FUDGE*WDTP(I)
18430 WDTP(0)=WDTP(0)+WDTP(I)
18431 IF(MDME(IDC,1).GT.0) THEN
18432 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18433 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18434 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18435 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18436 ENDIF
18437 480 CONTINUE
18438
18439 ELSEIF(KFLA.EQ.9900023) THEN
18440C...Z_R0:
18441 FAC=(AEM/(48D0*XW*XW1*(1D0-2D0*XW)))*SHR
18442 DO 490 I=1,MDCY(KC,3)
18443 IDC=I+MDCY(KC,2)-1
18444 IF(MDME(IDC,1).LT.0) GOTO 490
18445 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18446 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18447 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 490
18448 WID2=1D0
18449 SYMMET=1D0
18450 IF(I.LE.6) THEN
18451C...Z_R0 -> q + qbar
18452 EF=KCHG(I,1)/3D0
18453 AF=SIGN(1D0,EF+0.1D0)*(1D0-2D0*XW)
18454 VF=SIGN(1D0,EF+0.1D0)-4D0*EF*XW
18455 FCOF=3D0*RADC
18456 IF(I.EQ.6) WID2=WIDS(6,1)
18457 ELSEIF(I.EQ.7.OR.I.EQ.10.OR.I.EQ.13) THEN
18458C...Z_R0 -> l+ + l-
18459 AF=-(1D0-2D0*XW)
18460 VF=-1D0+4D0*XW
18461 FCOF=1D0
18462 ELSEIF(I.EQ.8.OR.I.EQ.11.OR.I.EQ.14) THEN
18463C...Z0 -> nu_L + nu_Lbar, assumed Majorana.
18464 AF=-2D0*XW
18465 VF=0D0
18466 FCOF=1D0
18467 SYMMET=0.5D0
18468 ELSEIF(I.LE.15) THEN
18469C...Z0 -> nu_R + nu_R, assumed Majorana.
18470 AF=2D0*XW1
18471 VF=0D0
18472 FCOF=1D0
18473 WID2=WIDS(PYCOMP(KFDP(IDC,1)),1)
18474 SYMMET=0.5D0
18475 ENDIF
18476 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
18477 & SQRT(MAX(0D0,1D0-4D0*RM1))*SYMMET
18478 WDTP(I)=FUDGE*WDTP(I)
18479 WDTP(0)=WDTP(0)+WDTP(I)
18480 IF(MDME(IDC,1).GT.0) THEN
18481 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18482 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18483 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18484 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18485 ENDIF
18486 490 CONTINUE
18487
18488 ELSEIF(KFLA.EQ.9900024) THEN
18489C...W_R+/-:
18490 FAC=(AEM/(24D0*XW))*SHR
18491 DO 500 I=1,MDCY(KC,3)
18492 IDC=I+MDCY(KC,2)-1
18493 IF(MDME(IDC,1).LT.0) GOTO 500
18494 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18495 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18496 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 500
18497 WID2=1D0
18498 IF(I.LE.9) THEN
18499C...W_R+/- -> q + qbar'
18500 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
18501 IF(KFLR.GT.0) THEN
18502 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
18503 ELSE
18504 IF(MOD(I,3).EQ.0) WID2=WIDS(6,3)
18505 ENDIF
18506 ELSEIF(I.LE.12) THEN
18507C...W_R+/- -> l+/- + nu_R
18508 FCOF=1D0
18509 ENDIF
18510 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
18511 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18512 WDTP(I)=FUDGE*WDTP(I)
18513 WDTP(0)=WDTP(0)+WDTP(I)
18514 IF(MDME(IDC,1).GT.0) THEN
18515 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18516 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18517 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18518 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18519 ENDIF
18520 500 CONTINUE
18521
18522 ELSEIF(KFLA.EQ.9900041) THEN
18523C...H_L++/--:
18524 FAC=(1D0/(8D0*PARU(1)))*SHR
18525 DO 510 I=1,MDCY(KC,3)
18526 IDC=I+MDCY(KC,2)-1
18527 IF(MDME(IDC,1).LT.0) GOTO 510
18528 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18529 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18530 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 510
18531 WID2=1D0
18532 IF(I.LE.6) THEN
18533C...H_L++/-- -> l+/- + l'+/-
18534 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
18535 & (IABS(KFDP(IDC,2))-9)/2)**2
18536 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
18537 ELSEIF(I.EQ.7) THEN
18538C...H_L++/-- -> W_L+/- + W_L+/-
18539 FCOF=0.5D0*PARP(190)**4*PARP(192)**2/PMAS(24,1)**2*
18540 & (3D0*RM1+0.25D0/RM1-1D0)
18541 WID2=WIDS(24,4+(1-KFLS)/2)
18542 ENDIF
18543 WDTP(I)=FAC*FCOF*
18544 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18545 WDTP(I)=FUDGE*WDTP(I)
18546 WDTP(0)=WDTP(0)+WDTP(I)
18547 IF(MDME(IDC,1).GT.0) THEN
18548 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18549 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18550 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18551 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18552 ENDIF
18553 510 CONTINUE
18554
18555 ELSEIF(KFLA.EQ.9900042) THEN
18556C...H_R++/--:
18557 FAC=(1D0/(8D0*PARU(1)))*SHR
18558 DO 520 I=1,MDCY(KC,3)
18559 IDC=I+MDCY(KC,2)-1
18560 IF(MDME(IDC,1).LT.0) GOTO 520
18561 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18562 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18563 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 520
18564 WID2=1D0
18565 IF(I.LE.6) THEN
18566C...H_R++/-- -> l+/- + l'+/-
18567 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
18568 & (IABS(KFDP(IDC,2))-9)/2)**2
18569 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
18570 ELSEIF(I.EQ.7) THEN
18571C...H_R++/-- -> W_R+/- + W_R+/-
18572 FCOF=PARP(191)**2*(3D0*RM1+0.25D0/RM1-1D0)
18573 WID2=WIDS(PYCOMP(9900024),4+(1-KFLS)/2)
18574 ENDIF
18575 WDTP(I)=FAC*FCOF*
18576 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18577 WDTP(I)=FUDGE*WDTP(I)
18578 WDTP(0)=WDTP(0)+WDTP(I)
18579 IF(MDME(IDC,1).GT.0) THEN
18580 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18581 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18582 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18583 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18584 ENDIF
18585 520 CONTINUE
18586
18587 ENDIF
18588 MINT(61)=0
18589 MINT(62)=0
18590 MINT(63)=0
18591 RETURN
18592 END
18593
18594C***********************************************************************
18595
18596C...PYOFSH
18597C...Calculates partial width and differential cross-section maxima
18598C...of channels/processes not allowed on mass-shell, and selects
18599C...masses in such channels/processes.
18600
18601 SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
18602
18603C...Double precision and integer declarations.
18604 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
18605 IMPLICIT INTEGER(I-N)
18606 INTEGER PYK,PYCHGE,PYCOMP
18607C...Commonblocks.
18608 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
18609 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
18610 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
18611 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
18612 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
18613 COMMON/PYINT1/MINT(400),VINT(400)
18614 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
18615 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
18616 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
18617 &/PYINT2/,/PYINT5/
18618C...Local arrays.
18619 DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2),
18620 &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100),
18621 &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:400),
18622 &WDTE(0:400,0:5)
18623
18624C...Find if particles equal, maximum mass, matrix elements, etc.
18625 MINT(51)=0
18626 ISUB=MINT(1)
18627 KFD(1)=IABS(KFD1)
18628 KFD(2)=IABS(KFD2)
18629 MEQL=0
18630 IF(KFD(1).EQ.KFD(2)) MEQL=1
18631 MLM=0
18632 IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0))
18633 IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN
18634 NOFF=44
18635 PMMX=PMMO
18636 ELSE
18637 NOFF=40
18638 PMMX=VINT(1)
18639 IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1))
18640 ENDIF
18641 MMED=0
18642 IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
18643 &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
18644 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR.
18645 &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2
18646 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR.
18647 &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3
18648 LOOP=1
18649
18650C...Find where Breit-Wigners are required, else select discrete masses.
18651 100 DO 110 I=1,2
18652 KFCA=PYCOMP(KFD(I))
18653 IF(KFCA.GT.0) THEN
18654 PMD(I)=PMAS(KFCA,1)
18655 PGD(I)=PMAS(KFCA,2)
18656 ELSE
18657 PMD(I)=0D0
18658 PGD(I)=0D0
18659 ENDIF
18660 IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN
18661 MBW(I)=0
18662 PMG(I)=PMD(I)
18663 RMG(I)=(PMG(I)/PMMX)**2
18664 ELSE
18665 MBW(I)=1
18666 ENDIF
18667 110 CONTINUE
18668
18669C...Find allowed mass range and Breit-Wigner parameters.
18670 DO 120 I=1,2
18671 IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN
18672 PML(I)=PARP(42)
18673 PMU(I)=PMMX-PARP(42)
18674 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
18675 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
18676 ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN
18677 ILM=I
18678 IF(MLM.EQ.2) ILM=3-I
18679 PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42))
18680 IF(MBW(3-I).EQ.0) THEN
18681 PMU(I)=PMMX-PMD(3-I)
18682 ELSE
18683 PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42))
18684 ENDIF
18685 IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=
18686 & MIN(PMU(I),CKIN(NOFF+2*ILM))
18687 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
18688 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
18689 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
18690 IF(MBW(I).EQ.1) THEN
18691 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
18692 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
18693 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
18694 & PGD(I)))
18695 ENDIF
18696 ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN
18697 ILM=I
18698 IF(MLM.EQ.2) ILM=3-I
18699 PML(I)=MAX(CKIN(48+I),PARP(42))
18700 PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42))
18701 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
18702 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
18703 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
18704 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
18705 IF(MBW(I).EQ.1) THEN
18706 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
18707 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
18708 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
18709 & PGD(I)))
18710 ENDIF
18711 ENDIF
18712 120 CONTINUE
18713 IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0))
18714 &THEN
18715 CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses')
18716 MINT(51)=1
18717 RETURN
18718 ENDIF
18719
18720C...Calculation of partial width of resonance.
18721 IF(MOFSH.EQ.1) THEN
18722
18723C..If only one integration, pick that to be the inner.
18724 IF(MBW(1).EQ.0) THEN
18725 PM2=PMD(1)
18726 PMD(1)=PMD(2)
18727 PGD(1)=PGD(2)
18728 PML(1)=PML(2)
18729 PMU(1)=PMU(2)
18730 ELSEIF(MBW(2).EQ.0) THEN
18731 PM2=PMD(2)
18732 ENDIF
18733
18734C...Start outer loop of integration.
18735 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
18736 ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
18737 ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
18738 NPT2=1
18739 XPT2(1)=1D0
18740 INX2(1)=0
18741 FMAX2=0D0
18742 ENDIF
18743 130 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
18744 PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2))
18745 PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S))))
18746 ENDIF
18747 RM2=(PM2/PMMX)**2
18748
18749C...Start inner loop of integration.
18750 PML1=PML(1)
18751 PMU1=MIN(PMU(1),PMMX-PM2)
18752 IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2)
18753 ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
18754 ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
18755 IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN
18756 FUNC2=0D0
18757 GOTO 180
18758 ENDIF
18759 NPT1=1
18760 XPT1(1)=1D0
18761 INX1(1)=0
18762 FMAX1=0D0
18763 140 PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1))
18764 PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S))))
18765 RM1=(PM1/PMMX)**2
18766
18767C...Evaluate function value - inner loop.
18768 FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18769 IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2)
18770 IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+
18771 & RM2**2+10D0*RM1*RM2)
18772 IF(FUNC1.GT.FMAX1) FMAX1=FUNC1
18773 FPT1(NPT1)=FUNC1
18774
18775C...Go to next position in inner loop.
18776 IF(NPT1.EQ.1) THEN
18777 NPT1=NPT1+1
18778 XPT1(NPT1)=0D0
18779 INX1(NPT1)=1
18780 GOTO 140
18781 ELSEIF(NPT1.LE.8) THEN
18782 NPT1=NPT1+1
18783 IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1
18784 ISH1=ISH1+1
18785 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
18786 INX1(NPT1)=INX1(ISH1)
18787 INX1(ISH1)=NPT1
18788 GOTO 140
18789 ELSEIF(NPT1.LT.100) THEN
18790 ISN1=ISH1
18791 150 ISH1=ISH1+1
18792 IF(ISH1.GT.NPT1) ISH1=2
18793 IF(ISH1.EQ.ISN1) GOTO 160
18794 DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1)))
18795 IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150
18796 NPT1=NPT1+1
18797 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
18798 INX1(NPT1)=INX1(ISH1)
18799 INX1(ISH1)=NPT1
18800 GOTO 140
18801 ENDIF
18802
18803C...Calculate integral over inner loop.
18804 160 FSUM1=0D0
18805 DO 170 IPT1=2,NPT1
18806 FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))*
18807 & (XPT1(INX1(IPT1))-XPT1(IPT1))
18808 170 CONTINUE
18809 FUNC2=FSUM1*(ATU1-ATL1)/PARU(1)
18810 180 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
18811 IF(FUNC2.GT.FMAX2) FMAX2=FUNC2
18812 FPT2(NPT2)=FUNC2
18813
18814C...Go to next position in outer loop.
18815 IF(NPT2.EQ.1) THEN
18816 NPT2=NPT2+1
18817 XPT2(NPT2)=0D0
18818 INX2(NPT2)=1
18819 GOTO 130
18820 ELSEIF(NPT2.LE.8) THEN
18821 NPT2=NPT2+1
18822 IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1
18823 ISH2=ISH2+1
18824 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
18825 INX2(NPT2)=INX2(ISH2)
18826 INX2(ISH2)=NPT2
18827 GOTO 130
18828 ELSEIF(NPT2.LT.100) THEN
18829 ISN2=ISH2
18830 190 ISH2=ISH2+1
18831 IF(ISH2.GT.NPT2) ISH2=2
18832 IF(ISH2.EQ.ISN2) GOTO 200
18833 DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2)))
18834 IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190
18835 NPT2=NPT2+1
18836 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
18837 INX2(NPT2)=INX2(ISH2)
18838 INX2(ISH2)=NPT2
18839 GOTO 130
18840 ENDIF
18841
18842C...Calculate integral over outer loop.
18843 200 FSUM2=0D0
18844 DO 210 IPT2=2,NPT2
18845 FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))*
18846 & (XPT2(INX2(IPT2))-XPT2(IPT2))
18847 210 CONTINUE
18848 FSUM2=FSUM2*(ATU2-ATL2)/PARU(1)
18849 IF(MEQL.EQ.1) FSUM2=2D0*FSUM2
18850 ELSE
18851 FSUM2=FUNC2
18852 ENDIF
18853
18854C...Save result; second integration for user-selected mass range.
18855 IF(LOOP.EQ.1) WIDW=FSUM2
18856 WID2=FSUM2
18857 IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47)
18858 & .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN
18859 LOOP=2
18860 GOTO 100
18861 ENDIF
18862 RET1=WIDW
18863 RET2=WID2/WIDW
18864
18865C...Select two decay product masses of a resonance.
18866 ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN
18867 220 DO 230 I=1,2
18868 IF(MBW(I).EQ.0) GOTO 230
18869 PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*
18870 & (ATU(I)-ATL(I)))
18871 PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW))))
18872 RMG(I)=(PMG(I)/PMMX)**2
18873 230 CONTINUE
18874 IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
18875 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220
18876
18877C...Weight with matrix element (if none known, use beta factor).
18878 FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2)))
18879 IF(MMED.EQ.1) THEN
18880 WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2))
18881 ELSEIF(MMED.EQ.2) THEN
18882 WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+
18883 & RMG(2)**2+10D0*RMG(1)*RMG(2))
18884 ELSEIF(MMED.EQ.3) THEN
18885 WTBE=FLAM*(RMG(1)+FLAM**2/12D0)
18886 ELSE
18887 WTBE=FLAM
18888 ENDIF
18889 IF(WTBE.LT.PYR(0)) GOTO 220
18890 RET1=PMG(1)
18891 RET2=PMG(2)
18892
18893C...Find suitable set of masses for initialization of 2 -> 2 processes.
18894 ELSEIF(MOFSH.EQ.3) THEN
18895 IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN
18896 PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1)))
18897 PMG(2)=PMD(2)
18898 ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN
18899 PMG(1)=PMD(1)
18900 PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2)))
18901 ELSE
18902 IDIV=-1
18903 240 IDIV=IDIV+1
18904 PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1)))
18905 PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2)))
18906 IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240
18907 ENDIF
18908 RET1=PMG(1)
18909 RET2=PMG(2)
18910
18911C...Evaluate importance of excluded tails of Breit-Wigners.
18912 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
18913 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
18914 IF(MEQL.LE.1) THEN
18915 VINT(80)=1D0
18916 DO 250 I=1,2
18917 IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/
18918 & PARU(1)
18919 250 CONTINUE
18920 ELSE
18921 VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))*
18922 & (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2)))
18923 ENDIF
18924 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND.
18925 & MSTP(43).NE.2) VINT(80)=2D0*VINT(80)
18926 IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80)
18927 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
18928
18929C...Pick one particle to be the lighter (if improves efficiency).
18930 ELSEIF(MOFSH.EQ.4) THEN
18931 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
18932 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
18933 260 IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0))
18934
18935C...Select two masses according to Breit-Wigner + flat in s + 1/s.
18936 DO 270 I=1,2
18937 IF(MBW(I).EQ.0) GOTO 270
18938 PMV=PMU(I)
18939 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
18940 ATV=ATU(I)
18941 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
18942 RBR=PYR(0)
18943 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
18944 & ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR
18945 IF(RBR.LT.0.8D0) THEN
18946 PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I)))
18947 PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR))))
18948 ELSEIF(RBR.LT.0.9D0) THEN
18949 PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2)))
18950 ELSEIF(RBR.LT.1.5D0) THEN
18951 PMG(I)=PML(I)*(PMV/PML(I))**PYR(0)
18952 ELSE
18953 PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)*
18954 & (PMV**2-PML(I)**2))))
18955 ENDIF
18956 270 CONTINUE
18957 IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
18958 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN
18959 IF(MINT(48).EQ.1) THEN
18960 NGEN(0,1)=NGEN(0,1)+1
18961 NGEN(MINT(1),1)=NGEN(MINT(1),1)+1
18962 GOTO 260
18963 ELSE
18964 MINT(51)=1
18965 RETURN
18966 ENDIF
18967 ENDIF
18968 RET1=PMG(1)
18969 RET2=PMG(2)
18970
18971C...Give weight for selected mass distribution.
18972 VINT(80)=1D0
18973 DO 280 I=1,2
18974 IF(MBW(I).EQ.0) GOTO 280
18975 PMV=PMU(I)
18976 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
18977 ATV=ATU(I)
18978 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
18979 F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+
18980 & (PMD(I)*PGD(I))**2)/PARU(1)
18981 F1=1D0
18982 F2=1D0/PMG(I)**2
18983 F3=1D0/PMG(I)**4
18984 FI0=(ATV-ATL(I))/PARU(1)
18985 FI1=PMV**2-PML(I)**2
18986 FI2=2D0*LOG(PMV/PML(I))
18987 FI3=1D0/PML(I)**2-1D0/PMV**2
18988 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
18989 & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
18990 VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+
18991 & 5D0*F3/FI3))
18992 ELSE
18993 VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2))
18994 ENDIF
18995 VINT(80)=VINT(80)*FI0
18996 280 CONTINUE
18997 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
18998 ENDIF
18999
19000 RETURN
19001 END
19002
19003C***********************************************************************
19004
19005C...PYRECO
19006C...Handles the possibility of colour reconnection in W+W- events,
19007C...Based on the main scenarios of the Sjostrand and Khoze study:
19008C...I, II, II', intermediate and instantaneous; plus one model
19009C...along the lines of the Gustafson and Hakkinen: GH.
19010C...Note: also handles Z0 Z0 and W-W+ events, but notation below
19011C...is as if first resonance is W+ and second W-.
19012
19013 SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
19014
19015C...Double precision and integer declarations.
19016 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19017 IMPLICIT INTEGER(I-N)
19018 INTEGER PYK,PYCHGE,PYCOMP
19019C...Parameter value; number of points in MC integration.
19020 PARAMETER (NPT=100)
19021C...Commonblocks.
19022 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19023 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19024 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19025 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19026 COMMON/PYINT1/MINT(400),VINT(400)
19027 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
19028C...Local arrays.
19029 DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
19030 &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
19031 &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
19032 &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
19033 &TMC(20),IJOIN(100)
19034
19035C...Functions to give four-product and to do determinants.
19036 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)
19037 DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+
19038 &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+
19039 &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3)
19040
19041C...Only allow fraction of recoupling for GH, intermediate and
19042C...instantaneous.
19043 IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
19044 IF(PYR(0).GT.PARP(120)) RETURN
19045 ENDIF
19046 ISUB=MINT(1)
19047
19048C...Common part for scenarios I, II, II', and GH.
19049 IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
19050 &MSTP(115).EQ.5) THEN
19051
19052C...Read out frequently-used parameters.
19053 PI=PARU(1)
19054 HBAR=PARU(3)
19055 PMW=PMAS(24,1)
19056 IF(ISUB.EQ.22) PMW=PMAS(23,1)
19057 PGW=PMAS(24,2)
19058 IF(ISUB.EQ.22) PGW=PMAS(23,2)
19059 TFRAG=PARP(115)
19060 RHAD=PARP(116)
19061 FACT=PARP(117)
19062 BLOWR=PARP(118)
19063 BLOWT=PARP(119)
19064
19065C...Find range of decay products of the W's.
19066C...Background: the W's are stored in IW1 and IW2.
19067C...Their direct decay products in NSD1+1 through NSD1+4.
19068C...Products after shower (if any) in NSD1+5 through NAFT1
19069C...for first W and in NAFT1+1 through N for the second.
19070 IF(NAFT1.GT.NSD1+4) THEN
19071 NBEG(1)=NSD1+5
19072 NEND(1)=NAFT1
19073 ELSE
19074 NBEG(1)=NSD1+1
19075 NEND(1)=NSD1+2
19076 ENDIF
19077 IF(N.GT.NAFT1) THEN
19078 NBEG(2)=NAFT1+1
19079 NEND(2)=N
19080 ELSE
19081 NBEG(2)=NSD1+3
19082 NEND(2)=NSD1+4
19083 ENDIF
19084
19085C...Rearrange parton shower products along strings.
19086 NOLD=N
19087 CALL PYPREP(NSD1+1)
19088
19089C...Find partons pointing back to W+ and W-; store them with quark
19090C...end of string first.
19091 NNP=0
19092 NNM=0
19093 ISGP=0
19094 ISGM=0
19095 DO 120 I=NOLD+1,N
19096 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
19097 IF(IABS(K(I,2)).GE.22) GOTO 120
19098 IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
19099 IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
19100 NNP=NNP+1
19101 IF(ISGP.EQ.1) THEN
19102 INP(NNP)=I
19103 ELSE
19104 DO 100 I1=NNP,2,-1
19105 INP(I1)=INP(I1-1)
19106 100 CONTINUE
19107 INP(1)=I
19108 ENDIF
19109 IF(K(I,1).EQ.1) ISGP=0
19110 ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
19111 IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
19112 NNM=NNM+1
19113 IF(ISGM.EQ.1) THEN
19114 INM(NNM)=I
19115 ELSE
19116 DO 110 I1=NNM,2,-1
19117 INM(I1)=INM(I1-1)
19118 110 CONTINUE
19119 INM(1)=I
19120 ENDIF
19121 IF(K(I,1).EQ.1) ISGM=0
19122 ENDIF
19123 120 CONTINUE
19124
19125C...Boost to W+W- rest frame (not strictly needed).
19126 DO 130 J=1,3
19127 BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
19128 130 CONTINUE
19129 CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
19130 CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
19131 CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
19132
19133C...Select decay vertices of W+ and W-.
19134 TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/
19135 & SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2)
19136 TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/
19137 & SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2)
19138 GTMAX=MAX(TP,TM)
19139 DO 140 J=1,3
19140 XP(J)=TP*P(IW1,J)/P(IW1,4)
19141 XM(J)=TM*P(IW2,J)/P(IW2,4)
19142 140 CONTINUE
19143
19144C...Begin scenario I specifics.
19145 IF(MSTP(115).EQ.1) THEN
19146
19147C...Reconstruct velocity and direction of W+ string pieces.
19148 DO 170 IIP=1,NNP-1
19149 IF(K(INP(IIP),2).LT.0) GOTO 170
19150 I1=INP(IIP)
19151 I2=INP(IIP+1)
19152 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
19153 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
19154 DO 150 J=1,3
19155 V1(J)=P(I1,J)/P1A
19156 V2(J)=P(I2,J)/P2A
19157 BETP(IIP,J)=0.5D0*(V1(J)+V2(J))
19158 DIRP(IIP,J)=V1(J)-V2(J)
19159 150 CONTINUE
19160 BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2-
19161 & BETP(IIP,3)**2)
19162 DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2)
19163 DO 160 J=1,3
19164 DIRP(IIP,J)=DIRP(IIP,J)/DIRL
19165 160 CONTINUE
19166 170 CONTINUE
19167
19168C...Reconstruct velocity and direction of W- string pieces.
19169 DO 200 IIM=1,NNM-1
19170 IF(K(INM(IIM),2).LT.0) GOTO 200
19171 I1=INM(IIM)
19172 I2=INM(IIM+1)
19173 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
19174 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
19175 DO 180 J=1,3
19176 V1(J)=P(I1,J)/P1A
19177 V2(J)=P(I2,J)/P2A
19178 BETM(IIM,J)=0.5D0*(V1(J)+V2(J))
19179 DIRM(IIM,J)=V1(J)-V2(J)
19180 180 CONTINUE
19181 BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2-
19182 & BETM(IIM,3)**2)
19183 DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2)
19184 DO 190 J=1,3
19185 DIRM(IIM,J)=DIRM(IIM,J)/DIRL
19186 190 CONTINUE
19187 200 CONTINUE
19188
19189C...Loop over number of space-time points.
19190 NACC=0
19191 SUM=0D0
19192 DO 250 IPT=1,NPT
19193
19194C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
19195 R=SQRT(-LOG(PYR(0)))
19196 PHI=2D0*PI*PYR(0)
19197 X=BLOWR*RHAD*R*COS(PHI)
19198 Y=BLOWR*RHAD*R*SIN(PHI)
19199 R=SQRT(-LOG(PYR(0)))
19200 PHI=2D0*PI*PYR(0)
19201 Z=BLOWR*RHAD*R*COS(PHI)
19202 T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI))
19203
19204C...Reject impossible points. Weight for sample distribution.
19205 IF(T**2-X**2-Y**2-Z**2.LT.0D0) GOTO 250
19206 WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)*
19207 & EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2)
19208
19209C...Loop over W+ string pieces and find one with largest weight.
19210 IMAXP=0
19211 WTMAXP=1D-10
19212 XD(1)=X-XP(1)
19213 XD(2)=Y-XP(2)
19214 XD(3)=Z-XP(3)
19215 XD(4)=T-TP
19216 DO 220 IIP=1,NNP-1
19217 IF(K(INP(IIP),2).LT.0) GOTO 220
19218 BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3)
19219 BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4))
19220 DO 210 J=1,3
19221 XB(J)=XD(J)+BEDG*BETP(IIP,J)
19222 210 CONTINUE
19223 XB(4)=BETP(IIP,4)*(XD(4)-BED)
19224 SR2=XB(1)**2+XB(2)**2+XB(3)**2
19225 SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+
19226 & DIRP(IIP,3)*XB(3))**2
19227 WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
19228 & TFRAG**2)
19229 IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0
19230 IF(WTP.GT.WTMAXP) THEN
19231 IMAXP=IIP
19232 WTMAXP=WTP
19233 ENDIF
19234 220 CONTINUE
19235
19236C...Loop over W- string pieces and find one with largest weight.
19237 IMAXM=0
19238 WTMAXM=1D-10
19239 XD(1)=X-XM(1)
19240 XD(2)=Y-XM(2)
19241 XD(3)=Z-XM(3)
19242 XD(4)=T-TM
19243 DO 240 IIM=1,NNM-1
19244 IF(K(INM(IIM),2).LT.0) GOTO 240
19245 BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3)
19246 BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4))
19247 DO 230 J=1,3
19248 XB(J)=XD(J)+BEDG*BETM(IIM,J)
19249 230 CONTINUE
19250 XB(4)=BETM(IIM,4)*(XD(4)-BED)
19251 SR2=XB(1)**2+XB(2)**2+XB(3)**2
19252 SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+
19253 & DIRM(IIM,3)*XB(3))**2
19254 WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
19255 & TFRAG**2)
19256 IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0
19257 IF(WTM.GT.WTMAXM) THEN
19258 IMAXM=IIM
19259 WTMAXM=WTM
19260 ENDIF
19261 240 CONTINUE
19262
19263C...Result of integration.
19264 WT=0D0
19265 IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN
19266 WT=WTMAXP*WTMAXM/WTSMP
19267 SUM=SUM+WT
19268 NACC=NACC+1
19269 IAP(NACC)=IMAXP
19270 IAM(NACC)=IMAXM
19271 WTA(NACC)=WT
19272 ENDIF
19273 250 CONTINUE
19274 RES=BLOWR**3*BLOWT*SUM/NPT
19275
19276C...Decide whether to reconnect and, if so, where.
19277 IACC=0
19278 PREC=1D0-EXP(-FACT*RES)
19279 IF(PREC.GT.PYR(0)) THEN
19280 RSUM=PYR(0)*SUM
19281 DO 260 IA=1,NACC
19282 IACC=IA
19283 RSUM=RSUM-WTA(IA)
19284 IF(RSUM.LE.0D0) GOTO 270
19285 260 CONTINUE
19286 270 IIP=IAP(IACC)
19287 IIM=IAM(IACC)
19288 ENDIF
19289
19290C...Begin scenario II and II' specifics.
19291 ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN
19292
19293C...Loop through all string pieces, one from W+ and one from W-.
19294 NCROSS=0
19295 TC(0)=0D0
19296 DO 340 IIP=1,NNP-1
19297 IF(K(INP(IIP),2).LT.0) GOTO 340
19298 I1P=INP(IIP)
19299 I2P=INP(IIP+1)
19300 DO 330 IIM=1,NNM-1
19301 IF(K(INM(IIM),2).LT.0) GOTO 330
19302 I1M=INM(IIM)
19303 I2M=INM(IIM+1)
19304
19305C...Find endpoint velocity vectors.
19306 DO 280 J=1,3
19307 V1P(J)=P(I1P,J)/P(I1P,4)
19308 V2P(J)=P(I2P,J)/P(I2P,4)
19309 V1M(J)=P(I1M,J)/P(I1M,4)
19310 V2M(J)=P(I2M,J)/P(I2M,4)
19311 280 CONTINUE
19312
19313C...Define q matrix and find t.
19314 DO 290 J=1,3
19315 Q(1,J)=V2P(J)-V1P(J)
19316 Q(2,J)=-(V2M(J)-V1M(J))
19317 Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J)
19318 Q(4,J)=V1P(J)-V1M(J)
19319 290 CONTINUE
19320 T=-DETER(1,2,3)/DETER(1,2,4)
19321
19322C...Find alpha and beta; i.e. coordinates of crossing point.
19323 S11=Q(1,1)*(T-TP)
19324 S12=Q(2,1)*(T-TM)
19325 S13=Q(3,1)+Q(4,1)*T
19326 S21=Q(1,2)*(T-TP)
19327 S22=Q(2,2)*(T-TM)
19328 S23=Q(3,2)+Q(4,2)*T
19329 DEN=S11*S22-S12*S21
19330 ALP=(S12*S23-S22*S13)/DEN
19331 BET=(S21*S13-S11*S23)/DEN
19332
19333C...Check if solution acceptable.
19334 IANSW=1
19335 IF(T.LT.GTMAX) IANSW=0
19336 IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
19337 IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
19338
19339C...Find point of crossing and check that not inconsistent.
19340 DO 300 J=1,3
19341 XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP)
19342 XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM)
19343 300 CONTINUE
19344 D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+
19345 & (XPP(3)-XMM(3))**2
19346 D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2
19347 D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2
19348 IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
19349
19350C...Find string eigentimes at crossing.
19351 IF(IANSW.EQ.1) THEN
19352 TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2-
19353 & (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2))
19354 TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2-
19355 & (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2))
19356 ELSE
19357 TAUP=0D0
19358 TAUM=0D0
19359 ENDIF
19360
19361C...Order crossings by time. End loop over crossings.
19362 IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
19363 NCROSS=NCROSS+1
19364 DO 310 I1=NCROSS,1,-1
19365 IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
19366 IPC(I1)=IIP
19367 IMC(I1)=IIM
19368 TC(I1)=T
19369 TPC(I1)=TAUP
19370 TMC(I1)=TAUM
19371 GOTO 320
19372 ELSE
19373 IPC(I1)=IPC(I1-1)
19374 IMC(I1)=IMC(I1-1)
19375 TC(I1)=TC(I1-1)
19376 TPC(I1)=TPC(I1-1)
19377 TMC(I1)=TMC(I1-1)
19378 ENDIF
19379 310 CONTINUE
19380 320 CONTINUE
19381 ENDIF
19382 330 CONTINUE
19383 340 CONTINUE
19384
19385C...Loop over crossings; find first (if any) acceptable one.
19386 IACC=0
19387 IF(NCROSS.GE.1) THEN
19388 DO 350 IC=1,NCROSS
19389 PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2)
19390 IF(PNFRAG.GT.PYR(0)) THEN
19391C...Scenario II: only compare with fragmentation time.
19392 IF(MSTP(115).EQ.2) THEN
19393 IACC=IC
19394 IIP=IPC(IACC)
19395 IIM=IMC(IACC)
19396 GOTO 360
19397C...Scenario II': also require that string length decreases.
19398 ELSE
19399 IIP=IPC(IC)
19400 IIM=IMC(IC)
19401 I1P=INP(IIP)
19402 I2P=INP(IIP+1)
19403 I1M=INM(IIM)
19404 I2M=INM(IIM+1)
19405 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
19406 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
19407 IF(ELNEW.LT.ELOLD) THEN
19408 IACC=IC
19409 IIP=IPC(IACC)
19410 IIM=IMC(IACC)
19411 GOTO 360
19412 ENDIF
19413 ENDIF
19414 ENDIF
19415 350 CONTINUE
19416 360 CONTINUE
19417 ENDIF
19418
19419C...Begin scenario GH specifics.
19420 ELSEIF(MSTP(115).EQ.5) THEN
19421
19422C...Loop through all string pieces, one from W+ and one from W-.
19423 IACC=0
19424 ELMIN=1D0
19425 DO 380 IIP=1,NNP-1
19426 IF(K(INP(IIP),2).LT.0) GOTO 380
19427 I1P=INP(IIP)
19428 I2P=INP(IIP+1)
19429 DO 370 IIM=1,NNM-1
19430 IF(K(INM(IIM),2).LT.0) GOTO 370
19431 I1M=INM(IIM)
19432 I2M=INM(IIM+1)
19433
19434C...Look for largest decrease of (exponent of) Lambda measure.
19435 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
19436 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
19437 ELDIF=ELNEW/MAX(1D-10,ELOLD)
19438 IF(ELDIF.LT.ELMIN) THEN
19439 IACC=IIP+IIM
19440 ELMIN=ELDIF
19441 IPC(1)=IIP
19442 IMC(1)=IIM
19443 ENDIF
19444 370 CONTINUE
19445 380 CONTINUE
19446 IIP=IPC(1)
19447 IIM=IMC(1)
19448 ENDIF
19449
19450C...Common for scenarios I, II, II' and GH: reconnect strings.
19451 IF(IACC.NE.0) THEN
19452 MINT(32)=1
19453 NJOIN=0
19454 DO 390 IS=1,NNP+NNM
19455 NJOIN=NJOIN+1
19456 IF(IS.LE.IIP) THEN
19457 I=INP(IS)
19458 ELSEIF(IS.LE.IIP+NNM-IIM) THEN
19459 I=INM(IS-IIP+IIM)
19460 ELSEIF(IS.LE.IIP+NNM) THEN
19461 I=INM(IS-IIP-NNM+IIM)
19462 ELSE
19463 I=INP(IS-NNM)
19464 ENDIF
19465 IJOIN(NJOIN)=I
19466 IF(K(I,2).LT.0) THEN
19467 CALL PYJOIN(NJOIN,IJOIN)
19468 NJOIN=0
19469 ENDIF
19470 390 CONTINUE
19471
19472C...Restore original event record if no reconnection.
19473 ELSE
19474 DO 400 I=NSD1+1,NOLD
19475 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
19476 K(I,4)=MOD(K(I,4),MSTU(5)**2)
19477 K(I,5)=MOD(K(I,5),MSTU(5)**2)
19478 ENDIF
19479 400 CONTINUE
19480 DO 410 I=NOLD+1,N
19481 K(K(I,3),1)=3
19482 410 CONTINUE
19483 N=NOLD
19484 ENDIF
19485
19486C...Boost back system.
19487 CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
19488 CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
19489 IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
19490 & BEWW(1),BEWW(2),BEWW(3))
19491
19492C...Common part for intermediate and instantaneous scenarios.
19493 ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
19494 MINT(32)=1
19495
19496C...Remove old shower products and reset showering ones.
19497 N=NSD1+4
19498 DO 420 I=NSD1+1,NSD1+4
19499 K(I,1)=3
19500 K(I,4)=MOD(K(I,4),MSTU(5)**2)
19501 K(I,5)=MOD(K(I,5),MSTU(5)**2)
19502 420 CONTINUE
19503
19504C...Identify quark-antiquark pairs.
19505 IQ1=NSD1+1
19506 IQ2=NSD1+2
19507 IQ3=NSD1+3
19508 IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
19509 IQ4=2*NSD1+7-IQ3
19510
19511C...Reconnect strings.
19512 IJOIN(1)=IQ1
19513 IJOIN(2)=IQ4
19514 CALL PYJOIN(2,IJOIN)
19515 IJOIN(1)=IQ3
19516 IJOIN(2)=IQ2
19517 CALL PYJOIN(2,IJOIN)
19518
19519C...Do new parton showers in intermediate scenario.
19520 IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
19521 MSTJ50=MSTJ(50)
19522 MSTJ(50)=0
19523 CALL PYSHOW(IQ1,IQ2,P(IW1,5))
19524 CALL PYSHOW(IQ3,IQ4,P(IW2,5))
19525 MSTJ(50)=MSTJ50
19526
19527C...Do new parton showers in instantaneous scenario.
19528 ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
19529 PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2-
19530 & (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2
19531 PPM=SQRT(MAX(0D0,PPM2))
19532 CALL PYSHOW(IQ1,IQ4,PPM)
19533 PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2-
19534 & (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2
19535 PPM=SQRT(MAX(0D0,PPM2))
19536 CALL PYSHOW(IQ3,IQ2,PPM)
19537 ENDIF
19538 ENDIF
19539
19540 RETURN
19541 END
19542
19543C***********************************************************************
19544
19545C...PYKLIM
19546C...Checks generated variables against pre-set kinematical limits;
19547C...also calculates limits on variables used in generation.
19548
19549 SUBROUTINE PYKLIM(ILIM)
19550
19551C...Double precision and integer declarations.
19552 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19553 IMPLICIT INTEGER(I-N)
19554 INTEGER PYK,PYCHGE,PYCOMP
19555C...Commonblocks.
19556 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19557 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19558 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19559 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
19560 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
19561 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19562 COMMON/PYINT1/MINT(400),VINT(400)
19563 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
19564 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
19565 &/PYINT1/,/PYINT2/
19566
19567C...Common kinematical expressions.
19568 MINT(51)=0
19569 ISUB=MINT(1)
19570 ISTSB=ISET(ISUB)
19571 IF(ISUB.EQ.96) GOTO 100
19572 SQM3=VINT(63)
19573 SQM4=VINT(64)
19574 IF(ILIM.NE.0) THEN
19575 IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
19576 CKIN09=MAX(CKIN(9),CKIN(13))
19577 CKIN10=MIN(CKIN(10),CKIN(14))
19578 CKIN11=MAX(CKIN(11),CKIN(15))
19579 CKIN12=MIN(CKIN(12),CKIN(16))
19580 ELSE
19581 CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
19582 CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
19583 CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
19584 CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
19585 ENDIF
19586 ENDIF
19587 IF(ILIM.NE.1) THEN
19588 TAU=VINT(21)
19589 RM3=SQM3/(TAU*VINT(2))
19590 RM4=SQM4/(TAU*VINT(2))
19591 BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
19592 ENDIF
19593 PTHMIN=CKIN(3)
19594 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3)
19595 &PTHMIN=MAX(CKIN(3),CKIN(5))
19596
19597 IF(ILIM.EQ.0) THEN
19598C...Check generated values of tau, y*, cos(theta-hat), and tau' against
19599C...pre-set kinematical limits.
19600 YST=VINT(22)
19601 CTH=VINT(23)
19602 TAUP=VINT(26)
19603 TAUE=TAU
19604 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
19605 X1=SQRT(TAUE)*EXP(YST)
19606 X2=SQRT(TAUE)*EXP(-YST)
19607 XF=X1-X2
19608 IF(MINT(47).NE.1) THEN
19609 IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
19610 IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
19611 IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
19612 IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
19613 ENDIF
19614 IF(MINT(45).NE.1) THEN
19615 IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
19616 ENDIF
19617 IF(MINT(46).NE.1) THEN
19618 IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
19619 ENDIF
19620 IF(MINT(45).EQ.2) THEN
19621 IF(X1.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
19622 ENDIF
19623 IF(MINT(46).EQ.2) THEN
19624 IF(X2.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
19625 ENDIF
19626 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
19627 PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2))
19628 EXPY3=MAX(1D-20,(1D0+RM3-RM4+BE34*CTH)/
19629 & MAX(1D-20,(1D0+RM3-RM4-BE34*CTH)))
19630 EXPY4=MAX(1D-20,(1D0-RM3+RM4-BE34*CTH)/
19631 & MAX(1D-20,(1D0-RM3+RM4+BE34*CTH)))
19632 Y3=YST+0.5D0*LOG(EXPY3)
19633 Y4=YST+0.5D0*LOG(EXPY4)
19634 YLARGE=MAX(Y3,Y4)
19635 YSMALL=MIN(Y3,Y4)
19636 ETALAR=20D0
19637 ETASMA=-20D0
19638 STH=SQRT(MAX(0D0,1D0-CTH**2))
19639 EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*
19640 & CTH)**2-4D0*RM3))
19641 EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*
19642 & CTH)**2-4D0*RM4))
19643 IF(STH.GE.1D-10) THEN
19644 EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/
19645 & (BE34*STH)
19646 EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/
19647 & (BE34*STH)
19648 ETA3=LOG(MIN(1D10,MAX(1D-10,EXPET3)))
19649 ETA4=LOG(MIN(1D10,MAX(1D-10,EXPET4)))
19650 ETALAR=MAX(ETA3,ETA4)
19651 ETASMA=MIN(ETA3,ETA4)
19652 ENDIF
19653 CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3
19654 CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4
19655 CTSLAR=MIN(1D0,MAX(-1D0,CTS3,CTS4))
19656 CTSSMA=MAX(-1D0,MIN(1D0,CTS3,CTS4))
19657 SH=TAU*VINT(2)
19658 RPTS=4D0*VINT(71)**2/SH
19659 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
19660 RM34=MAX(1D-20,2D0*RM3*RM4)
19661 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
19662 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
19663 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
19664 THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
19665 UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
19666 IF(PTH.LT.PTHMIN) MINT(51)=1
19667 IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1
19668 IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
19669 IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
19670 IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
19671 IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
19672 IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
19673 IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
19674 IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
19675 IF(THA.LT.CKIN(35)) MINT(51)=1
19676 IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1
19677 IF(UHA.LT.CKIN(37)) MINT(51)=1
19678 IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1
19679 ENDIF
19680 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
19681 IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
19682 IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
19683 ENDIF
19684
19685C...Additional cuts on W2 (approximately) in DIS.
19686 IF(ISUB.EQ.10.AND.MINT(43).GE.2) THEN
19687 XBJ=X2
19688 IF(IABS(MINT(12)).LT.20) XBJ=X1
19689 Q2BJ=THA
19690 W2BJ=Q2BJ*(1D0-XBJ)/XBJ
19691 IF(W2BJ.LT.CKIN(39)) MINT(51)=1
19692 IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1
19693 ENDIF
19694
19695 ELSEIF(ILIM.EQ.1) THEN
19696C...Calculate limits on tau
19697C...0) due to definition
19698 TAUMN0=0D0
19699 TAUMX0=1D0
19700C...1) due to limits on subsystem mass
19701 TAUMN1=CKIN(1)**2/VINT(2)
19702 TAUMX1=1D0
19703 IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2)
19704C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
19705 TM3=SQRT(SQM3+PTHMIN**2)
19706 TM4=SQRT(SQM4+PTHMIN**2)
19707 YDCOSH=1D0
19708 IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12)
19709 TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
19710 TAUMX2=1D0
19711C...3) due to limits on pT-hat and cos(theta-hat)
19712 CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
19713 CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
19714 TAUMN3=0D0
19715 IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3=
19716 & (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+
19717 & SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2)
19718 TAUMX3=1D0
19719 IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3=
19720 & (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+
19721 & SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2)
19722C...4) due to limits on x1 and x2
19723 TAUMN4=CKIN(21)*CKIN(23)
19724 TAUMX4=CKIN(22)*CKIN(24)
19725C...5) due to limits on xF
19726 TAUMN5=0D0
19727 TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26))
19728C...6) due to limits on that and uhat
19729 TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2)
19730 TAUMX6=1D0
19731 IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6=
19732 & (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2)
19733
19734C...Net effect of all separate limits.
19735 VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6)
19736 VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6)
19737 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
19738 VINT(11)=1D0-1D-9
19739 VINT(31)=1D0+1D-9
19740 ELSEIF(MINT(47).EQ.5) THEN
19741 VINT(31)=MIN(VINT(31),1D0-2D-10)
19742 ELSEIF(MINT(47).GE.6) THEN
19743 VINT(31)=MIN(VINT(31),1D0-1D-10)
19744 ENDIF
19745 IF(VINT(31).LE.VINT(11)) MINT(51)=1
19746
19747 ELSEIF(ILIM.EQ.2) THEN
19748C...Calculate limits on y*
19749 TAUE=TAU
19750 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
19751 TAURT=SQRT(TAUE)
19752C...0) due to kinematics
19753 YSTMN0=LOG(TAURT)
19754 YSTMX0=-YSTMN0
19755C...1) due to explicit limits
19756 YSTMN1=CKIN(7)
19757 YSTMX1=CKIN(8)
19758C...2) due to limits on x1
19759 YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT)
19760 YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT)
19761C...3) due to limits on x2
19762 YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT)
19763 YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT)
19764C...4) due to limits on xF
19765 YEPMN4=0.5D0*ABS(CKIN(25))/TAURT
19766 YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25))
19767 YEPMX4=0.5D0*ABS(CKIN(26))/TAURT
19768 YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26))
19769C...5) due to simultaneous limits on y-large and y-small
19770 YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11)
19771 YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12)
19772 YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN)))
19773 YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX)))
19774 YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN)
19775 YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX)
19776C...6) due to simultaneous limits on cos(theta-hat) and y-large or
19777C... y-small
19778 CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2))))
19779 RZMN=BE34*MAX(CKIN(27),-CTHLIM)
19780 RZMX=BE34*MIN(CKIN(28),CTHLIM)
19781 YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX)
19782 YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN)
19783 YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN)
19784 YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX)
19785 YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX))
19786 YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN))
19787
19788C...Net effect of all separate limits.
19789 VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
19790 VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
19791 IF(MINT(47).EQ.1) THEN
19792 VINT(12)=-1D-9
19793 VINT(32)=1D-9
19794 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
19795 VINT(12)=(1D0-1D-9)*YSTMX0
19796 VINT(32)=(1D0+1D-9)*YSTMX0
19797 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
19798 VINT(12)=-(1D0+1D-9)*YSTMX0
19799 VINT(32)=-(1D0-1D-9)*YSTMX0
19800 ELSEIF(MINT(47).EQ.5) THEN
19801 YSTEE=LOG((1D0-1D-10)/TAURT)
19802 VINT(12)=MAX(VINT(12),-YSTEE)
19803 VINT(32)=MIN(VINT(32),YSTEE)
19804 ENDIF
19805 IF(VINT(32).LE.VINT(12)) MINT(51)=1
19806
19807 ELSEIF(ILIM.EQ.3) THEN
19808C...Calculate limits on cos(theta-hat)
19809 YST=VINT(22)
19810C...0) due to definition
19811 CTNMN0=-1D0
19812 CTNMX0=0D0
19813 CTPMN0=0D0
19814 CTPMX0=1D0
19815C...1) due to explicit limits
19816 CTNMN1=MIN(0D0,CKIN(27))
19817 CTNMX1=MIN(0D0,CKIN(28))
19818 CTPMN1=MAX(0D0,CKIN(27))
19819 CTPMX1=MAX(0D0,CKIN(28))
19820C...2) due to limits on pT-hat
19821 CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2))))
19822 CTPMX2=-CTNMN2
19823 CTNMX2=0D0
19824 CTPMN2=0D0
19825 IF(CKIN(4).GE.0D0) THEN
19826 CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/
19827 & (BE34**2*TAU*VINT(2))))
19828 CTPMN2=-CTNMX2
19829 ENDIF
19830C...3) due to limits on y-large and y-small
19831 CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST),
19832 & -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST)))
19833 CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST),
19834 & -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST))
19835 CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST),
19836 & -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST))
19837 CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST),
19838 & -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST)))
19839C...4) due to limits on that
19840 CTNMN4=-1D0
19841 CTNMX4=0D0
19842 CTPMN4=0D0
19843 CTPMX4=1D0
19844 SH=TAU*VINT(2)
19845 IF(CKIN(35).GT.0D0) THEN
19846 CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34
19847 IF(CTLIM.GT.0D0) THEN
19848 CTPMX4=CTLIM
19849 ELSE
19850 CTPMX4=0D0
19851 CTNMX4=CTLIM
19852 ENDIF
19853 ENDIF
19854 IF(CKIN(36).GT.0D0) THEN
19855 CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34
19856 IF(CTLIM.LT.0D0) THEN
19857 CTNMN4=CTLIM
19858 ELSE
19859 CTNMN4=0D0
19860 CTPMN4=CTLIM
19861 ENDIF
19862 ENDIF
19863C...5) due to limits on uhat
19864 CTNMN5=-1D0
19865 CTNMX5=0D0
19866 CTPMN5=0D0
19867 CTPMX5=1D0
19868 IF(CKIN(37).GT.0D0) THEN
19869 CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34
19870 IF(CTLIM.LT.0D0) THEN
19871 CTNMN5=CTLIM
19872 ELSE
19873 CTNMN5=0D0
19874 CTPMN5=CTLIM
19875 ENDIF
19876 ENDIF
19877 IF(CKIN(38).GT.0D0) THEN
19878 CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34
19879 IF(CTLIM.GT.0D0) THEN
19880 CTPMX5=CTLIM
19881 ELSE
19882 CTPMX5=0D0
19883 CTNMX5=CTLIM
19884 ENDIF
19885 ENDIF
19886
19887C...Net effect of all separate limits.
19888 VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5)
19889 VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5)
19890 VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5)
19891 VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5)
19892 IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
19893
19894 ELSEIF(ILIM.EQ.4) THEN
19895C...Calculate limits on tau'
19896C...0) due to kinematics
19897 TAPMN0=TAU
19898 IF(ISTSB.EQ.5.AND.KFPR(ISUB,2).GT.0) THEN
19899 PQRAT=2D0*PMAS(PYCOMP(KFPR(ISUB,2)),1)/VINT(1)
19900 TAPMN0=(SQRT(TAU)+PQRAT)**2
19901 ENDIF
19902 TAPMX0=1D0
19903C...1) due to explicit limits
19904 TAPMN1=CKIN(31)**2/VINT(2)
19905 TAPMX1=1D0
19906 IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2)
19907
19908C...Net effect of all separate limits.
19909 VINT(16)=MAX(TAPMN0,TAPMN1)
19910 VINT(36)=MIN(TAPMX0,TAPMX1)
19911 IF(MINT(47).EQ.1) THEN
19912 VINT(16)=1D0-1D-9
19913 VINT(36)=1D0+1D-9
19914 ELSEIF(MINT(47).EQ.5) THEN
19915 VINT(36)=MIN(VINT(36),1D0-2D-10)
19916 ELSEIF(MINT(47).EQ.6.OR.MINT(47).EQ.7) THEN
19917 VINT(36)=MIN(VINT(36),1D0-1D-10)
19918 ENDIF
19919 IF(VINT(36).LE.VINT(16)) MINT(51)=1
19920
19921 ENDIF
19922 RETURN
19923
19924C...Special case for low-pT and multiple interactions:
19925C...effective kinematical limits for tau, y*, cos(theta-hat).
19926 100 IF(ILIM.EQ.0) THEN
19927 ELSEIF(ILIM.EQ.1) THEN
19928 IF(MSTP(82).LE.1) THEN
19929 VINT(11)=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
19930 & VINT(2)
19931 ELSE
19932 VINT(11)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/VINT(2)
19933 ENDIF
19934 VINT(31)=1D0
19935 ELSEIF(ILIM.EQ.2) THEN
19936 VINT(12)=0.5D0*LOG(VINT(21))
19937 VINT(32)=-VINT(12)
19938 ELSEIF(ILIM.EQ.3) THEN
19939 IF(MSTP(82).LE.1) THEN
19940 ST2EFF=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
19941 & (VINT(21)*VINT(2))
19942 ELSE
19943 ST2EFF=0.01D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
19944 & (VINT(21)*VINT(2))
19945 ENDIF
19946 VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF))
19947 VINT(33)=0D0
19948 VINT(14)=0D0
19949 VINT(34)=-VINT(13)
19950 ENDIF
19951
19952 RETURN
19953 END
19954
19955C*********************************************************************
19956
19957C...PYKMAP
19958C...Maps a uniform distribution into a distribution of a kinematical
19959C...variable according to one of the possibilities allowed. It is
19960C...assumed that kinematical limits have been set by a PYKLIM call.
19961
19962 SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
19963
19964C...Double precision and integer declarations.
19965 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19966 IMPLICIT INTEGER(I-N)
19967 INTEGER PYK,PYCHGE,PYCOMP
19968C...Commonblocks.
19969 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19970 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19971 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
19972 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19973 COMMON/PYINT1/MINT(400),VINT(400)
19974 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
19975 SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
19976
19977C...Convert VVAR to tau variable.
19978 ISUB=MINT(1)
19979 ISTSB=ISET(ISUB)
19980 IF(IVAR.EQ.1) THEN
19981 TAUMIN=VINT(11)
19982 TAUMAX=VINT(31)
19983 IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
19984 TAURE=VINT(73)
19985 GAMRE=VINT(74)
19986 ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
19987 TAURE=VINT(75)
19988 GAMRE=VINT(76)
19989 ENDIF
19990 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
19991 TAU=1D0
19992 ELSEIF(MVAR.EQ.1) THEN
19993 TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
19994 ELSEIF(MVAR.EQ.2) THEN
19995 TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
19996 ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5) THEN
19997 RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
19998 TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
19999 ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6) THEN
20000 AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
20001 ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
20002 TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
20003 ELSEIF(MINT(47).EQ.5) THEN
20004 AUPP=LOG(MAX(2D-10,1D0-TAUMAX))
20005 ALOW=LOG(MAX(2D-10,1D0-TAUMIN))
20006 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
20007 ELSE
20008 AUPP=LOG(MAX(1D-10,1D0-TAUMAX))
20009 ALOW=LOG(MAX(1D-10,1D0-TAUMIN))
20010 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
20011 ENDIF
20012 VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
20013
20014C...Convert VVAR to y* variable.
20015 ELSEIF(IVAR.EQ.2) THEN
20016 YSTMIN=VINT(12)
20017 YSTMAX=VINT(32)
20018 TAUE=VINT(21)
20019 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
20020 IF(MINT(47).EQ.1) THEN
20021 YST=0D0
20022 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
20023 YST=-0.5D0*LOG(TAUE)
20024 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
20025 YST=0.5D0*LOG(TAUE)
20026 ELSEIF(MVAR.EQ.1) THEN
20027 YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
20028 ELSEIF(MVAR.EQ.2) THEN
20029 YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR)
20030 ELSEIF(MVAR.EQ.3) THEN
20031 AUPP=ATAN(EXP(YSTMAX))
20032 ALOW=ATAN(EXP(YSTMIN))
20033 YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
20034 ELSEIF(MVAR.EQ.4) THEN
20035 YST0=-0.5D0*LOG(TAUE)
20036 AUPP=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0))
20037 ALOW=LOG(MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
20038 YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW)))
20039 ELSE
20040 YST0=-0.5D0*LOG(TAUE)
20041 AUPP=LOG(MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
20042 ALOW=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0))
20043 YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0
20044 ENDIF
20045 VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
20046
20047C...Convert VVAR to cos(theta-hat) variable.
20048 ELSEIF(IVAR.EQ.3) THEN
20049 RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2)
20050 RSQM=1D0+RM34
20051 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
20052 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
20053 CTNMIN=VINT(13)
20054 CTNMAX=VINT(33)
20055 CTPMIN=VINT(14)
20056 CTPMAX=VINT(34)
20057 IF(MVAR.EQ.1) THEN
20058 ANEG=CTNMAX-CTNMIN
20059 APOS=CTPMAX-CTPMIN
20060 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
20061 VCTN=VVAR*(ANEG+APOS)/ANEG
20062 CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
20063 ELSE
20064 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
20065 CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
20066 ENDIF
20067 ELSEIF(MVAR.EQ.2) THEN
20068 RMNMIN=MAX(RM34,RSQM-CTNMIN)
20069 RMNMAX=MAX(RM34,RSQM-CTNMAX)
20070 RMPMIN=MAX(RM34,RSQM-CTPMIN)
20071 RMPMAX=MAX(RM34,RSQM-CTPMAX)
20072 ANEG=LOG(RMNMIN/RMNMAX)
20073 APOS=LOG(RMPMIN/RMPMAX)
20074 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
20075 VCTN=VVAR*(ANEG+APOS)/ANEG
20076 CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
20077 ELSE
20078 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
20079 CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
20080 ENDIF
20081 ELSEIF(MVAR.EQ.3) THEN
20082 RMNMIN=MAX(RM34,RSQM+CTNMIN)
20083 RMNMAX=MAX(RM34,RSQM+CTNMAX)
20084 RMPMIN=MAX(RM34,RSQM+CTPMIN)
20085 RMPMAX=MAX(RM34,RSQM+CTPMAX)
20086 ANEG=LOG(RMNMAX/RMNMIN)
20087 APOS=LOG(RMPMAX/RMPMIN)
20088 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
20089 VCTN=VVAR*(ANEG+APOS)/ANEG
20090 CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
20091 ELSE
20092 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
20093 CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
20094 ENDIF
20095 ELSEIF(MVAR.EQ.4) THEN
20096 RMNMIN=MAX(RM34,RSQM-CTNMIN)
20097 RMNMAX=MAX(RM34,RSQM-CTNMAX)
20098 RMPMIN=MAX(RM34,RSQM-CTPMIN)
20099 RMPMAX=MAX(RM34,RSQM-CTPMAX)
20100 ANEG=1D0/RMNMAX-1D0/RMNMIN
20101 APOS=1D0/RMPMAX-1D0/RMPMIN
20102 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
20103 VCTN=VVAR*(ANEG+APOS)/ANEG
20104 CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN)
20105 ELSE
20106 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
20107 CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP)
20108 ENDIF
20109 ELSEIF(MVAR.EQ.5) THEN
20110 RMNMIN=MAX(RM34,RSQM+CTNMIN)
20111 RMNMAX=MAX(RM34,RSQM+CTNMAX)
20112 RMPMIN=MAX(RM34,RSQM+CTPMIN)
20113 RMPMAX=MAX(RM34,RSQM+CTPMAX)
20114 ANEG=1D0/RMNMIN-1D0/RMNMAX
20115 APOS=1D0/RMPMIN-1D0/RMPMAX
20116 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
20117 VCTN=VVAR*(ANEG+APOS)/ANEG
20118 CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM
20119 ELSE
20120 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
20121 CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM
20122 ENDIF
20123 ENDIF
20124 IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
20125 IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
20126 VINT(23)=CTH
20127
20128C...Convert VVAR to tau' variable.
20129 ELSEIF(IVAR.EQ.4) THEN
20130 TAU=VINT(21)
20131 TAUPMN=VINT(16)
20132 TAUPMX=VINT(36)
20133 IF(MINT(47).EQ.1) THEN
20134 TAUP=1D0
20135 ELSEIF(MVAR.EQ.1) THEN
20136 TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
20137 ELSEIF(MVAR.EQ.2) THEN
20138 AUPP=(1D0-TAU/TAUPMX)**4
20139 ALOW=(1D0-TAU/TAUPMN)**4
20140 TAUP=TAU/MAX(1D-10,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0)
20141 ELSEIF(MINT(47).EQ.5) THEN
20142 AUPP=LOG(MAX(2D-10,1D0-TAUPMX))
20143 ALOW=LOG(MAX(2D-10,1D0-TAUPMN))
20144 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
20145 ELSE
20146 AUPP=LOG(MAX(1D-10,1D0-TAUPMX))
20147 ALOW=LOG(MAX(1D-10,1D0-TAUPMN))
20148 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
20149 ENDIF
20150 VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
20151
20152C...Selection of extra variables needed in 2 -> 3 process:
20153C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
20154C...Since no options are available, the functions of PYKLIM
20155C...and PYKMAP are joint for these choices.
20156 ELSEIF(IVAR.EQ.5) THEN
20157
20158C...Read out total energy and particle masses.
20159 MINT(51)=0
20160 MPTPK=1
20161 IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174
20162 & .OR.ISUB.EQ.178.OR.ISUB.EQ.179.OR.ISUB.EQ.351.OR.ISUB.EQ.352)
20163 & MPTPK=2
20164 SHP=VINT(26)*VINT(2)
20165 SHPR=SQRT(SHP)
20166 PM1=VINT(201)
20167 PM2=VINT(206)
20168 PM3=SQRT(VINT(21))*VINT(1)
20169 IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN
20170 MINT(51)=1
20171 RETURN
20172 ENDIF
20173 PMRS1=VINT(204)**2
20174 PMRS2=VINT(209)**2
20175
20176C...Specify coefficients of pT choice; upper and lower limits.
20177 IF(MPTPK.EQ.1) THEN
20178 HWT1=0.4D0
20179 HWT2=0.4D0
20180 ELSE
20181 HWT1=0.05D0
20182 HWT2=0.05D0
20183 ENDIF
20184 HWT3=1D0-HWT1-HWT2
20185 PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/
20186 & (4D0*SHP)
20187 IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
20188 PTSMN1=CKIN(51)**2
20189 PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/
20190 & (4D0*SHP)
20191 IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2)
20192 PTSMN2=CKIN(53)**2
20193
20194C...Select transverse momenta according to
20195C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
20196 HMX=PMRS1+PTSMX1
20197 HMN=PMRS1+PTSMN1
20198 IF(HMX.LT.1.0001D0*HMN) THEN
20199 MINT(51)=1
20200 RETURN
20201 ENDIF
20202 HDE=PTSMX1-PTSMN1
20203 RPT=PYR(0)
20204 IF(RPT.LT.HWT1) THEN
20205 PTS1=PTSMN1+PYR(0)*HDE
20206 ELSEIF(RPT.LT.HWT1+HWT2) THEN
20207 PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1)
20208 ELSE
20209 PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1)
20210 ENDIF
20211 WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+
20212 & HWT3*HMN*HMX/(PMRS1+PTS1)**2)
20213 HMX=PMRS2+PTSMX2
20214 HMN=PMRS2+PTSMN2
20215 IF(HMX.LT.1.0001D0*HMN) THEN
20216 MINT(51)=1
20217 RETURN
20218 ENDIF
20219 HDE=PTSMX2-PTSMN2
20220 RPT=PYR(0)
20221 IF(RPT.LT.HWT1) THEN
20222 PTS2=PTSMN2+PYR(0)*HDE
20223 ELSEIF(RPT.LT.HWT1+HWT2) THEN
20224 PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2)
20225 ELSE
20226 PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2)
20227 ENDIF
20228 WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+
20229 & HWT3*HMN*HMX/(PMRS2+PTS2)**2)
20230
20231C...Select azimuthal angles and check pT choice.
20232 PHI1=PARU(2)*PYR(0)
20233 PHI2=PARU(2)*PYR(0)
20234 PHIR=PHI2-PHI1
20235 PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR))
20236 IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT.
20237 & CKIN(56)**2)) THEN
20238 MINT(51)=1
20239 RETURN
20240 ENDIF
20241
20242C...Calculate transverse masses and check phase space not closed.
20243 PMS1=PM1**2+PTS1
20244 PMS2=PM2**2+PTS2
20245 PMS3=PM3**2+PTS3
20246 PMT1=SQRT(PMS1)
20247 PMT2=SQRT(PMS2)
20248 PMT3=SQRT(PMS3)
20249 PM12=(PMT1+PMT2)**2
20250 IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN
20251 MINT(51)=1
20252 RETURN
20253 ENDIF
20254
20255C...Select rapidity for particle 3 and check phase space not closed.
20256 Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2-
20257 & 4D0*PMS3*PM12)))/(2D0*SHPR*PMT3))
20258 IF(Y3MAX.LT.1D-6) THEN
20259 MINT(51)=1
20260 RETURN
20261 ENDIF
20262 Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX
20263 PZ3=PMT3*SINH(Y3)
20264 PE3=PMT3*COSH(Y3)
20265
20266C...Find momentum transfers in two mirror solutions (in 1-2 frame).
20267 PZ12=-PZ3
20268 PE12=SHPR-PE3
20269 PMS12=PE12**2-PZ12**2
20270 SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2))
20271 IF(SQL12.LT.1D-6*SHP) THEN
20272 MINT(51)=1
20273 RETURN
20274 ENDIF
20275 PMM1=PMS12+PMS1-PMS2
20276 PMM2=PMS12+PMS2-PMS1
20277 TFAC=-SHPR/(2D0*PMS12)
20278 T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12)
20279 T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12)
20280 T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12)
20281 T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12)
20282
20283C...Construct relative mirror weights and make choice.
20284 IF(MPTPK.EQ.1.OR.ISUB.EQ.351.OR.ISUB.EQ.352) THEN
20285 WTPU=1D0
20286 WTNU=1D0
20287 ELSE
20288 WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2
20289 WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2
20290 ENDIF
20291 WTP=WTPU/(WTPU+WTNU)
20292 WTN=WTNU/(WTPU+WTNU)
20293 EPS=1D0
20294 IF(WTN.GT.PYR(0)) EPS=-1D0
20295
20296C...Store result of variable choice and associated weights.
20297 VINT(202)=PTS1
20298 VINT(207)=PTS2
20299 VINT(203)=PHI1
20300 VINT(208)=PHI2
20301 VINT(205)=WTPTS1
20302 VINT(210)=WTPTS2
20303 VINT(211)=Y3
20304 VINT(212)=Y3MAX
20305 VINT(213)=EPS
20306 IF(EPS.GT.0D0) THEN
20307 VINT(214)=1D0/WTP
20308 VINT(215)=T1P
20309 VINT(216)=T2P
20310 ELSE
20311 VINT(214)=1D0/WTN
20312 VINT(215)=T1N
20313 VINT(216)=T2N
20314 ENDIF
20315 VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12)
20316 VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12)
20317 VINT(219)=0.5D0*(PMS12-PTS3)
20318 VINT(220)=SQL12
20319 ENDIF
20320
20321 RETURN
20322 END
20323
20324C***********************************************************************
20325
20326C...PYSIGH
20327C...Differential matrix elements for all included subprocesses
20328C...Note that what is coded is (disregarding the COMFAC factor)
20329C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
20330C...when d(sigma-hat) is given in the zero-width limit, the delta
20331C...function in tau is replaced by a (modified) Breit-Wigner:
20332C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
20333C...where H_res = s-hat/m_res*Gamma_res(s-hat);
20334C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
20335C...i.e., dimensionless quantities
20336C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
20337C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
20338C...(2pi)^4 delta^4(P - sum p_i)
20339C...COMFAC contains the factor pi/s (or equivalent) and
20340C...the conversion factor from GeV^-2 to mb
20341
20342 SUBROUTINE PYSIGH(NCHN,SIGS)
20343
20344C...Double precision and integer declarations
20345 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
20346 IMPLICIT INTEGER(I-N)
20347 INTEGER PYK,PYCHGE,PYCOMP
20348C...Parameter statement to help give large particle numbers.
20349 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
20350 &KEXCIT=4000000,KDIMEN=5000000)
20351C...Commonblocks
20352 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
20353 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
20354 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
20355 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
20356 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
20357 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
20358 COMMON/PYINT1/MINT(400),VINT(400)
20359 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
20360 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
20361 COMMON/PYINT4/MWID(500),WIDS(500,5)
20362 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
20363 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
20364 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
20365 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
20366 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
20367 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
20368 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
20369 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
20370 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
20371 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
20372 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
20373 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
20374 &/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYSGCM/
20375C...Local arrays and complex variables
20376 DIMENSION X(2),XPQ(-25:25)
20377
20378C...Map of processes onto which routine to call
20379C...in order to evaluate cross section:
20380C...0 = not implemented;
20381C...1 = standard QCD (including photons);
20382C...2 = heavy flavours;
20383C...3 = W/Z;
20384C...4 = Higgs (2 doublets; including longitudinal W/Z scattering);
20385C...5 = SUSY;
20386C...6 = Technicolor;
20387C...7 = exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
20388 DIMENSION MAPPR(500)
20389 DATA (MAPPR(I),I=1,180)/
20390 & 3, 3, 4, 0, 4, 0, 0, 4, 0, 1,
20391 1 1, 1, 1, 1, 3, 3, 0, 1, 3, 3,
20392 2 0, 3, 3, 4, 3, 4, 0, 1, 1, 3,
20393 3 3, 4, 1, 1, 3, 3, 0, 0, 0, 0,
20394 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
20395 5 0, 0, 1, 1, 0, 0, 0, 1, 0, 0,
20396 6 0, 0, 0, 0, 0, 0, 0, 1, 3, 3,
20397 7 4, 4, 4, 0, 0, 4, 4, 0, 0, 1,
20398 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
20399 9 1, 1, 1, 1, 1, 1, 0, 0, 1, 0,
20400 & 0, 4, 4, 2, 2, 2, 2, 2, 0, 4,
20401 1 4, 4, 4, 1, 1, 0, 0, 0, 0, 0,
20402 2 4, 4, 4, 4, 0, 0, 0, 0, 0, 0,
20403 3 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
20404 4 7, 7, 4, 7, 7, 7, 7, 7, 6, 0,
20405 5 4, 4, 4, 0, 0, 4, 4, 4, 0, 0,
20406 6 4, 7, 7, 7, 6, 6, 7, 7, 7, 0,
20407 7 4, 4, 4, 4, 0, 4, 4, 4, 4, 0/
20408 DATA (MAPPR(I),I=181,500)/
20409 8 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
20410 9 6, 6, 6, 6, 6, 0, 0, 0, 0, 0,
20411 & 100*5,
20412 & 5, 0, 0, 0, 0, 0, 0, 0, 0, 0,
20413 1 30*0,
20414 4 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
20415 5 7, 7, 7, 7, 0, 0, 0, 0, 0, 0,
20416 6 6, 6, 6, 6, 6, 6, 6, 6, 0, 6,
20417 7 6, 6, 6, 6, 6, 6, 6, 0, 0, 0,
20418 8 6, 6, 6, 6, 6, 6, 6, 6, 0, 0,
20419 9 7, 7, 7, 7, 7, 0, 0, 0, 0, 0,
20420 & 100*0/
20421
20422C...Reset number of channels and cross-section
20423 NCHN=0
20424 SIGS=0D0
20425
20426C...Read process to consider.
20427 ISUB=MINT(1)
20428 ISUBSV=ISUB
20429 MAP=MAPPR(ISUB)
20430
20431C...Read kinematical variables and limits
20432 ISTSB=ISET(ISUBSV)
20433 TAUMIN=VINT(11)
20434 YSTMIN=VINT(12)
20435 CTNMIN=VINT(13)
20436 CTPMIN=VINT(14)
20437 TAUPMN=VINT(16)
20438 TAU=VINT(21)
20439 YST=VINT(22)
20440 CTH=VINT(23)
20441 XT2=VINT(25)
20442 TAUP=VINT(26)
20443 TAUMAX=VINT(31)
20444 YSTMAX=VINT(32)
20445 CTNMAX=VINT(33)
20446 CTPMAX=VINT(34)
20447 TAUPMX=VINT(36)
20448
20449C...Derive kinematical quantities
20450 TAUE=TAU
20451 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
20452 X(1)=SQRT(TAUE)*EXP(YST)
20453 X(2)=SQRT(TAUE)*EXP(-YST)
20454 IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN
20455 IF(X(1).GT.1D0-1D-7) RETURN
20456 ELSEIF(MINT(45).EQ.3) THEN
20457 X(1)=MIN(1D0-1.1D-10,X(1))
20458 ENDIF
20459 IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
20460 IF(X(2).GT.1D0-1D-7) RETURN
20461 ELSEIF(MINT(46).EQ.3) THEN
20462 X(2)=MIN(1D0-1.1D-10,X(2))
20463 ENDIF
20464 SH=MAX(1D0,TAU*VINT(2))
20465 SQM3=VINT(63)
20466 SQM4=VINT(64)
20467 RM3=SQM3/SH
20468 RM4=SQM4/SH
20469 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
20470 RPTS=4D0*VINT(71)**2/SH
20471 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
20472 RM34=MAX(1D-20,2D0*RM3*RM4)
20473 RSQM=1D0+RM34
20474 IF(2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)).LT.0.0001D0)
20475 &RM34=MAX(RM34,2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)))
20476 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
20477 IF(ISTSB.EQ.0) THEN
20478 TH=VINT(45)
20479 UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
20480 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
20481 ELSE
20482C...Kinematics with incoming masses tricky: now depends on how
20483C...subprocess has been set up w.r.t. order of incoming partons.
20484 RM1=0D0
20485 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) RM1=-VINT(3)**2/SH
20486 RM2=0D0
20487 IF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) RM2=-VINT(4)**2/SH
20488 IF(ISUB.EQ.35) THEN
20489 RM2=MIN(RM1,RM2)
20490 RM1=0D0
20491 ENDIF
20492 BE12=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
20493 TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4)
20494 TH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM4-2D0*RM2*RM3-
20495 & BE12*BE34*CTH)
20496 UH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM3-2D0*RM2*RM4+
20497 & BE12*BE34*CTH)
20498 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
20499 ENDIF
20500 SHR=SQRT(SH)
20501 SH2=SH**2
20502 TH2=TH**2
20503 UH2=UH**2
20504
20505C...Choice of Q2 scale: hard, parton distributions, parton showers
20506 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
20507 Q2=SH
20508 ELSEIF(ISTSB.EQ.8) THEN
20509 IF(MINT(107).EQ.4) Q2=VINT(307)
20510 IF(MINT(108).EQ.4) Q2=VINT(308)
20511 ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
20512 Q2IN1=0D0
20513 IF(MINT(11).EQ.22.AND.VINT(3).LT.0D0) Q2IN1=VINT(3)**2
20514 Q2IN2=0D0
20515 IF(MINT(12).EQ.22.AND.VINT(4).LT.0D0) Q2IN2=VINT(4)**2
20516 IF(MSTP(32).EQ.1) THEN
20517 Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
20518 ELSEIF(MSTP(32).EQ.2) THEN
20519 Q2=SQPTH+0.5D0*(SQM3+SQM4)
20520 ELSEIF(MSTP(32).EQ.3) THEN
20521 Q2=MIN(-TH,-UH)
20522 ELSEIF(MSTP(32).EQ.4) THEN
20523 Q2=SH
20524 ELSEIF(MSTP(32).EQ.5) THEN
20525 Q2=-TH
20526 ELSEIF(MSTP(32).EQ.6) THEN
20527 XSF1=X(1)
20528 IF(ISTSB.EQ.9) XSF1=X(1)/VINT(143)
20529 XSF2=X(2)
20530 IF(ISTSB.EQ.9) XSF2=X(2)/VINT(144)
20531 Q2=(1D0+XSF1*Q2IN1/SH+XSF2*Q2IN2/SH)*
20532 & (SQPTH+0.5D0*(SQM3+SQM4))
20533 ELSEIF(MSTP(32).EQ.7) THEN
20534 Q2=(1D0+Q2IN1/SH+Q2IN2/SH)*(SQPTH+0.5D0*(SQM3+SQM4))
20535 ELSEIF(MSTP(32).EQ.8) THEN
20536 Q2=SQPTH+0.5D0*(Q2IN1+Q2IN2+SQM3+SQM4)
20537 ELSEIF(MSTP(32).EQ.9) THEN
20538 Q2=SQPTH+Q2IN1+Q2IN2+SQM3+SQM4
20539 ELSEIF(MSTP(32).EQ.10) THEN
20540 Q2=VINT(2)
20541 ENDIF
20542 IF(ISTSB.EQ.9) Q2=SQPTH
20543 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2=Q2+
20544 & (PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
20545 ENDIF
20546 Q2SF=Q2
20547 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
20548 Q2SF=PMAS(23,1)**2
20549 IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124.OR.
20550 & ISUB.EQ.351) Q2SF=PMAS(24,1)**2
20551 IF(ISUB.EQ.352) Q2SF=PMAS(PYCOMP(9900024),1)**2
20552 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
20553 & ISUB.EQ.186.OR.ISUB.EQ.187) THEN
20554 Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
20555 IF(MSTP(39).EQ.2) Q2SF=Q2SF+MAX(VINT(202),VINT(207))
20556 IF(MSTP(39).EQ.3) Q2SF=SH
20557 IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2)
20558 IF(MSTP(39).EQ.5) Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,1)),1)**2
20559 ENDIF
20560 ENDIF
20561 Q2PS=Q2SF
20562 Q2SF=Q2SF*PARP(34)
20563 IF(MSTP(69).GE.1.AND.MINT(47).EQ.5) Q2SF=VINT(2)
20564 IF(MSTP(69).GE.2) Q2SF=VINT(2)
20565 IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND.
20566 &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
20567 XBJ=X(2)
20568 IF(MINT(43).EQ.3) XBJ=X(1)
20569 IF(MSTP(22).EQ.1) THEN
20570 Q2PS=-TH
20571 ELSEIF(MSTP(22).EQ.2) THEN
20572 Q2PS=((1D0-XBJ)/XBJ)*(-TH)
20573 ELSEIF(MSTP(22).EQ.3) THEN
20574 Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH)
20575 ELSE
20576 Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH)
20577 ENDIF
20578 ENDIF
20579 IF(MSTP(68).EQ.1.AND.(ISUBSV.EQ.1.OR.ISUBSV.EQ.2.OR.
20580 &ISUBSV.EQ.102.OR.ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR.
20581 &ISUBSV.EQ.144.OR.ISUBSV.EQ.152.OR.ISUBSV.EQ.157)) THEN
20582 Q2PS=VINT(2)
20583 ELSEIF(MSTP(68).GE.2.AND.(ISUBSV.NE.11.AND.ISUBSV.NE.12.AND.
20584 &ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.ISUBSV.NE.53.AND.
20585 &ISUBSV.NE.68)) THEN
20586 Q2PS=VINT(2)
20587 ENDIF
20588
20589C...Store derived kinematical quantities
20590 VINT(41)=X(1)
20591 VINT(42)=X(2)
20592 VINT(44)=SH
20593 VINT(43)=SQRT(SH)
20594 VINT(45)=TH
20595 VINT(46)=UH
20596 IF(ISTSB.NE.8) VINT(48)=SQPTH
20597 IF(ISTSB.NE.8) VINT(47)=SQRT(SQPTH)
20598 VINT(50)=TAUP*VINT(2)
20599 VINT(49)=SQRT(MAX(0D0,VINT(50)))
20600 VINT(52)=Q2
20601 VINT(51)=SQRT(Q2)
20602 VINT(54)=Q2SF
20603 VINT(53)=SQRT(Q2SF)
20604 VINT(56)=Q2PS
20605 VINT(55)=SQRT(Q2PS)
20606
20607C...Calculate parton distributions
20608 IF(ISTSB.LE.0) GOTO 160
20609 IF(MINT(47).GE.2) THEN
20610 DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
20611 XSF=X(I)
20612 IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
20613 IF(ISUB.EQ.99) THEN
20614 IF(MINT(140+I).EQ.0) THEN
20615 XSF=VINT(309-I)/(VINT(2)+VINT(309-I)-VINT(I+2)**2)
20616 ELSE
20617 XSF=VINT(309-I)/(VINT(2)+VINT(307)+VINT(308))
20618 ENDIF
20619 VINT(40+I)=XSF
20620 Q2SF=VINT(309-I)
20621 ENDIF
20622 MINT(105)=MINT(102+I)
20623 MINT(109)=MINT(106+I)
20624 VINT(120)=VINT(2+I)
20625C.... ALICE
20626C.... Store side in MINT(124)
20627 MINT(124)=I
20628C....
20629 IF(MSTP(57).LE.1) THEN
20630 CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ)
20631 ELSE
20632 CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ)
20633 ENDIF
20634 DO 100 KFL=-25,25
20635 XSFX(I,KFL)=XPQ(KFL)
20636 100 CONTINUE
20637 110 CONTINUE
20638 ENDIF
20639
20640C...Calculate alpha_em, alpha_strong and K-factor
20641 XW=PARU(102)
20642 XWV=XW
20643 IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW=
20644 &1D0-(PMAS(24,1)/PMAS(23,1))**2
20645 XW1=1D0-XW
20646 XWC=1D0/(16D0*XW*XW1)
20647 AEM=PYALEM(Q2)
20648 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
20649 IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2)
20650 FACK=1D0
20651 FACA=1D0
20652 IF(MSTP(33).EQ.1) THEN
20653 FACK=PARP(31)
20654 ELSEIF(MSTP(33).EQ.2) THEN
20655 FACK=PARP(31)
20656 FACA=PARP(32)/PARP(31)
20657 ELSEIF(MSTP(33).EQ.3) THEN
20658 Q2AS=PARP(33)*Q2
20659 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+
20660 & PARU(112)*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
20661 AS=PYALPS(Q2AS)
20662 ENDIF
20663 VINT(138)=1D0
20664 VINT(57)=AEM
20665 VINT(58)=AS
20666
20667C...Set flags for allowed reacting partons/leptons
20668 DO 140 I=1,2
20669 DO 120 J=-25,25
20670 KFAC(I,J)=0
20671 120 CONTINUE
20672 IF(MINT(44+I).EQ.1) THEN
20673 KFAC(I,MINT(10+I))=1
20674 ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN
20675 KFAC(I,MINT(10+I))=1
20676 KFAC(I,22)=1
20677 KFAC(I,24)=1
20678 KFAC(I,-24)=1
20679 ELSE
20680 DO 130 J=-25,25
20681 KFAC(I,J)=KFIN(I,J)
20682 IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0
20683 IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0
20684 130 CONTINUE
20685 ENDIF
20686 140 CONTINUE
20687
20688C...Lower and upper limit for fermion flavour loops
20689 MMIN1=0
20690 MMAX1=0
20691 MMIN2=0
20692 MMAX2=0
20693 DO 150 J=-20,20
20694 IF(KFAC(1,-J).EQ.1) MMIN1=-J
20695 IF(KFAC(1,J).EQ.1) MMAX1=J
20696 IF(KFAC(2,-J).EQ.1) MMIN2=-J
20697 IF(KFAC(2,J).EQ.1) MMAX2=J
20698 150 CONTINUE
20699 MMINA=MIN(MMIN1,MMIN2)
20700 MMAXA=MAX(MMAX1,MMAX2)
20701
20702C...Common resonance mass and width combinations
20703 SQMZ=PMAS(23,1)**2
20704 SQMW=PMAS(24,1)**2
20705 GMMZ=PMAS(23,1)*PMAS(23,2)
20706 GMMW=PMAS(24,1)*PMAS(24,2)
20707
20708C...Polarization factors...implemented so far for W+W-(25)
20709 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
20710 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
20711 POLRR=(1D0+PARJ(132))*(1D0+PARJ(131))
20712 POLLL=(1D0-PARJ(132))*(1D0-PARJ(131))
20713
20714C...Phase space integral in tau
20715 COMFAC=PARU(1)*PARU(5)/VINT(2)
20716 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK
20717 IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND.
20718 &ISTSB.NE.8.AND.ISTSB.NE.9) THEN
20719 ATAU1=LOG(TAUMAX/TAUMIN)
20720 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
20721 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
20722 IF(MINT(72).GE.1) THEN
20723 TAUR1=VINT(73)
20724 GAMR1=VINT(74)
20725 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
20726 ATAU3=ATAUD/TAUR1
20727 IF(ATAUD.GT.1D-10) H1=H1+
20728 & (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
20729 ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
20730 ATAU4=ATAUD/GAMR1
20731 IF(ATAUD.GT.1D-10) H1=H1+
20732 & (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
20733 ENDIF
20734 IF(MINT(72).EQ.2) THEN
20735 TAUR2=VINT(75)
20736 GAMR2=VINT(76)
20737 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
20738 ATAU5=ATAUD/TAUR2
20739 IF(ATAUD.GT.1D-10) H1=H1+
20740 & (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
20741 ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
20742 ATAU6=ATAUD/GAMR2
20743 IF(ATAUD.GT.1D-10) H1=H1+
20744 & (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
20745 ENDIF
20746 IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
20747 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
20748 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
20749 & MAX(2D-10,1D0-TAU)
20750 ELSEIF(MINT(47).GE.6.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
20751 ATAU7=LOG(MAX(1D-10,1D0-TAUMIN)/MAX(1D-10,1D0-TAUMAX))
20752 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
20753 & MAX(1D-10,1D0-TAU)
20754 ENDIF
20755 COMFAC=COMFAC*ATAU1/(TAU*H1)
20756 ENDIF
20757
20758C...Phase space integral in y*
20759 IF((MINT(47).EQ.4.OR.MINT(47).EQ.5).AND.ISTSB.NE.8.AND.ISTSB.NE.9)
20760 &THEN
20761 AYST0=YSTMAX-YSTMIN
20762 IF(AYST0.LT.1D-10) THEN
20763 COMFAC=0D0
20764 ELSE
20765 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
20766 AYST2=AYST1
20767 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
20768 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
20769 & (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
20770 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
20771 IF(MINT(45).EQ.3) THEN
20772 YST0=-0.5D0*LOG(TAUE)
20773 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
20774 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
20775 IF(AYST4.GT.1D-10) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
20776 & MAX(1D-10,1D0-EXP(YST-YST0))
20777 ENDIF
20778 IF(MINT(46).EQ.3) THEN
20779 YST0=-0.5D0*LOG(TAUE)
20780 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
20781 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
20782 IF(AYST5.GT.1D-10) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
20783 & MAX(1D-10,1D0-EXP(-YST-YST0))
20784 ENDIF
20785 COMFAC=COMFAC*AYST0/H2
20786 ENDIF
20787 ENDIF
20788
20789C...2 -> 1 processes: reduction in angular part of phase space integral
20790C...for case of decaying resonance
20791 ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
20792 IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
20793 IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
20794 IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
20795 & KFPR(ISUB,1).EQ.39) THEN
20796 COMFAC=COMFAC*0.5D0*ACTH0
20797 ELSE
20798 COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
20799 & CTPMAX**3-CTPMIN**3)
20800 ENDIF
20801 ENDIF
20802
20803C...2 -> 2 processes: angular part of phase space integral
20804 ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
20805 ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
20806 & (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
20807 ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
20808 & (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
20809 ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
20810 & 1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
20811 ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
20812 & 1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
20813 H3=COEF(ISUBSV,13)+
20814 & (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
20815 & (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
20816 & (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
20817 & (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
20818 COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3
20819
20820C...2 -> 2 processes: take into account final state Breit-Wigners
20821 COMFAC=COMFAC*VINT(80)
20822 ENDIF
20823
20824C...2 -> 3, 4 processes: phace space integral in tau'
20825 IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
20826 ATAUP1=LOG(TAUPMX/TAUPMN)
20827 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
20828 H4=COEF(ISUBSV,18)+
20829 & (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
20830 IF(MINT(47).EQ.5) THEN
20831 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
20832 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-10,1D0-TAUP)
20833 ELSEIF(MINT(47).GE.6) THEN
20834 ATAUP3=LOG(MAX(1D-10,1D0-TAUPMN)/MAX(1D-10,1D0-TAUPMX))
20835 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(1D-10,1D0-TAUP)
20836 ENDIF
20837 COMFAC=COMFAC*ATAUP1/H4
20838 ENDIF
20839
20840C...2 -> 3, 4 processes: effective W/Z parton distributions
20841 IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
20842 IF(1D0-TAU/TAUP.GT.1D-4) THEN
20843 FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
20844 ELSE
20845 FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
20846 ENDIF
20847 COMFAC=COMFAC*FZW
20848 ENDIF
20849
20850C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
20851 IF(ISTSB.EQ.5) THEN
20852 COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
20853 & (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
20854 ENDIF
20855
20856C...Phase space integral for low-pT and multiple interactions
20857 IF(ISTSB.EQ.9) THEN
20858 COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
20859 ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
20860 ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
20861 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
20862 COMFAC=COMFAC*ATAU1/H1
20863 AYST0=YSTMAX-YSTMIN
20864 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
20865 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
20866 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
20867 & (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
20868 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
20869 COMFAC=COMFAC*AYST0/H2
20870 IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
20871C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
20872C...introduced to make cross-section finite for xT2 -> 0
20873 IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
20874 & (1D0+VINT(149)))
20875 ENDIF
20876
20877C...Real gamma + gamma: include factor 2 when different nature
20878 160 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
20879 &MSTP(14).LE.10) COMFAC=2D0*COMFAC
20880
20881C...Extra factors to include the effects of
20882C...longitudinal resolved photons (but not direct or DIS ones).
20883 DO 170 ISDE=1,2
20884 IF(MINT(10+ISDE).EQ.22.AND.MINT(106+ISDE).GE.1.AND.
20885 & MINT(106+ISDE).LE.3) THEN
20886 VINT(314+ISDE)=1D0
20887 XY=PARP(166+ISDE)
20888 IF(MSTP(16).EQ.0) THEN
20889 IF(VINT(304+ISDE).GT.0D0.AND.VINT(304+ISDE).LT.1D0)
20890 & XY=VINT(304+ISDE)
20891 ELSE
20892 IF(VINT(308+ISDE).GT.0D0.AND.VINT(308+ISDE).LT.1D0)
20893 & XY=VINT(308+ISDE)
20894 ENDIF
20895 Q2GA=VINT(306+ISDE)
20896 IF(MSTP(17).GT.0.AND.XY.GT.0D0.AND.XY.LT.1D0.AND.
20897 & Q2GA.GT.0D0) THEN
20898 REDUCE=0D0
20899 IF(MSTP(17).EQ.1) THEN
20900 REDUCE=4D0*Q2*Q2GA/(Q2+Q2GA)**2
20901 ELSEIF(MSTP(17).EQ.2) THEN
20902 REDUCE=4D0*Q2GA/(Q2+Q2GA)
20903 ELSEIF(MSTP(17).EQ.3) THEN
20904 PMVIRT=PMAS(PYCOMP(113),1)
20905 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
20906 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.1) THEN
20907 PMVIRT=PMAS(PYCOMP(113),1)
20908 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
20909 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.2) THEN
20910 PMVIRT=PMAS(PYCOMP(113),1)
20911 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
20912 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.3) THEN
20913 PMVSMN=4D0*PARP(15)**2
20914 PMVSMX=4D0*VINT(154)**2
20915 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
20916 REDLON=(3D0*PMVSMN+Q2GA)/(PMVSMN+Q2GA)**3-
20917 & (3D0*PMVSMX+Q2GA)/(PMVSMX+Q2GA)**3
20918 REDUCE=4D0*(Q2GA/6D0)*REDLON/REDTRA
20919 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.1) THEN
20920 PMVIRT=PMAS(PYCOMP(113),1)
20921 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
20922 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.2) THEN
20923 PMVIRT=PMAS(PYCOMP(113),1)
20924 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
20925 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.3) THEN
20926 PMVSMN=4D0*PARP(15)**2
20927 PMVSMX=4D0*VINT(154)**2
20928 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
20929 REDLON=1D0/(PMVSMN+Q2GA)**2-1D0/(PMVSMX+Q2GA)**2
20930 REDUCE=4D0*(Q2GA/2D0)*REDLON/REDTRA
20931 ENDIF
20932 BEAMAS=PYMASS(11)
20933 IF(VINT(302+ISDE).GT.0D0) BEAMAS=VINT(302+ISDE)
20934 FRACLT=1D0/(1D0+XY**2/2D0/(1D0-XY)*
20935 & (1D0-2D0*BEAMAS**2/Q2GA))
20936 VINT(314+ISDE)=1D0+PARP(165)*REDUCE*FRACLT
20937 ENDIF
20938 ELSE
20939 VINT(314+ISDE)=1D0
20940 ENDIF
20941 COMFAC=COMFAC*VINT(314+ISDE)
20942 170 CONTINUE
20943
20944C...Evaluate cross sections - done in separate routines by kind
20945C...of physics, to keep PYSIGH of sensible size.
20946 IF(MAP.EQ.1) THEN
20947C...Standard QCD (including photons).
20948 CALL PYSGQC(NCHN,SIGS)
20949 ELSEIF(MAP.EQ.2) THEN
20950C...Heavy flavours.
20951 CALL PYSGHF(NCHN,SIGS)
20952 ELSEIF(MAP.EQ.3) THEN
20953C...W/Z.
20954 CALL PYSGWZ(NCHN,SIGS)
20955 ELSEIF(MAP.EQ.4) THEN
20956C...Higgs (2 doublets; including longitudinal W/Z scattering).
20957 CALL PYSGHG(NCHN,SIGS)
20958 ELSEIF(MAP.EQ.5) THEN
20959C...SUSY.
20960 CALL PYSGSU(NCHN,SIGS)
20961 ELSEIF(MAP.EQ.6) THEN
20962C...Technicolor.
20963 CALL PYSGTC(NCHN,SIGS)
20964 ELSEIF(MAP.EQ.7) THEN
20965C...Exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
20966 CALL PYSGEX(NCHN,SIGS)
20967 ENDIF
20968
20969C...Multiply with parton distributions
20970 IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
20971 DO 180 ICHN=1,NCHN
20972 IF(MINT(45).GE.2) THEN
20973 KFL1=ISIG(ICHN,1)
20974 SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
20975 ENDIF
20976 IF(MINT(46).GE.2) THEN
20977 KFL2=ISIG(ICHN,2)
20978 SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
20979 ENDIF
20980 SIGS=SIGS+SIGH(ICHN)
20981 180 CONTINUE
20982 ENDIF
20983
20984 RETURN
20985 END
20986
20987C*********************************************************************
20988
20989C...PYSGQC
20990C...Subprocess cross sections for QCD processes,
20991C...including photons.
20992C...Auxiliary to PYSIGH.
20993
20994 SUBROUTINE PYSGQC(NCHN,SIGS)
20995
20996C...Double precision and integer declarations
20997 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
20998 IMPLICIT INTEGER(I-N)
20999 INTEGER PYK,PYCHGE,PYCOMP
21000C...Parameter statement to help give large particle numbers.
21001 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
21002 &KEXCIT=4000000,KDIMEN=5000000)
21003C...Commonblocks
21004 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21005 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21006 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
21007 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21008 COMMON/PYINT1/MINT(400),VINT(400)
21009 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
21010 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
21011 COMMON/PYINT4/MWID(500),WIDS(500,5)
21012 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
21013 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
21014 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
21015 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
21016 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
21017 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
21018 &/PYINT3/,/PYINT4/,/PYINT7/,/PYSGCM/
21019C...Local arrays
21020 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
21021
21022C...Differential cross section expressions.
21023
21024 IF(ISUB.LE.20) THEN
21025 IF(ISUB.EQ.10) THEN
21026C...f + f' -> f + f' (gamma/Z/W exchange)
21027 FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2
21028 FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ))
21029 FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2
21030 FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2
21031 DO 110 I=MMIN1,MMAX1
21032 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 110
21033 IA=IABS(I)
21034 DO 100 J=MMIN2,MMAX2
21035 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 100
21036 JA=IABS(J)
21037C...Electroweak couplings
21038 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
21039 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
21040 VI=AI-4D0*EI*XWV
21041 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
21042 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
21043 VJ=AJ-4D0*EJ*XWV
21044 EPSIJ=ISIGN(1,I*J)
21045C...gamma/Z exchange, only gamma exchange, or only Z exchange
21046 IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN
21047 IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN
21048 FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ*
21049 & (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+
21050 & FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+
21051 & 4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
21052 ELSEIF(MSTP(21).EQ.2) THEN
21053 FACNCF=FACGGF*EI**2*EJ**2
21054 ELSE
21055 FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*
21056 & (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
21057 ENDIF
21058C...Extrafactor 2 for only one incoming neutrino spin state.
21059 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACNCF=2D0*FACNCF
21060 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACNCF=2D0*FACNCF
21061 NCHN=NCHN+1
21062 ISIG(NCHN,1)=I
21063 ISIG(NCHN,2)=J
21064 ISIG(NCHN,3)=1
21065 SIGH(NCHN)=FACNCF
21066 ENDIF
21067C...W exchange
21068 IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN
21069 FACCCF=FACWWF*VINT(180+I)*VINT(180+J)
21070 IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2
21071 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF
21072 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF
21073 NCHN=NCHN+1
21074 ISIG(NCHN,1)=I
21075 ISIG(NCHN,2)=J
21076 ISIG(NCHN,3)=2
21077 SIGH(NCHN)=FACCCF
21078 ENDIF
21079 100 CONTINUE
21080 110 CONTINUE
21081
21082 ELSEIF(ISUB.EQ.11) THEN
21083C...f + f' -> f + f' (g exchange)
21084 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
21085 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
21086 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
21087 FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
21088 & MSTP(34)*2D0/3D0*SH2/(TH*UH))
21089 DO 130 I=MMIN1,MMAX1
21090 IA=IABS(I)
21091 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 130
21092 DO 120 J=MMIN2,MMAX2
21093 JA=IABS(J)
21094 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 120
21095 NCHN=NCHN+1
21096 ISIG(NCHN,1)=I
21097 ISIG(NCHN,2)=J
21098 ISIG(NCHN,3)=1
21099 SIGH(NCHN)=FACQQ1
21100 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
21101 IF(I.EQ.J) THEN
21102 SIGH(NCHN)=0.5D0*SIGH(NCHN)
21103 NCHN=NCHN+1
21104 ISIG(NCHN,1)=I
21105 ISIG(NCHN,2)=J
21106 ISIG(NCHN,3)=2
21107 SIGH(NCHN)=0.5D0*FACQQ2
21108 ENDIF
21109 120 CONTINUE
21110 130 CONTINUE
21111
21112 ELSEIF(ISUB.EQ.12) THEN
21113C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
21114 CALL PYWIDT(21,SH,WDTP,WDTE)
21115 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
21116 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
21117 DO 140 I=MMINA,MMAXA
21118 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
21119 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
21120 NCHN=NCHN+1
21121 ISIG(NCHN,1)=I
21122 ISIG(NCHN,2)=-I
21123 ISIG(NCHN,3)=1
21124 SIGH(NCHN)=FACQQB
21125 140 CONTINUE
21126
21127 ELSEIF(ISUB.EQ.13) THEN
21128C...f + fbar -> g + g (q + qbar -> g + g only)
21129 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
21130 & UH2/SH2)
21131 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
21132 & TH2/SH2)
21133 DO 150 I=MMINA,MMAXA
21134 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
21135 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
21136 NCHN=NCHN+1
21137 ISIG(NCHN,1)=I
21138 ISIG(NCHN,2)=-I
21139 ISIG(NCHN,3)=1
21140 SIGH(NCHN)=0.5D0*FACGG1
21141 NCHN=NCHN+1
21142 ISIG(NCHN,1)=I
21143 ISIG(NCHN,2)=-I
21144 ISIG(NCHN,3)=2
21145 SIGH(NCHN)=0.5D0*FACGG2
21146 150 CONTINUE
21147
21148 ELSEIF(ISUB.EQ.14) THEN
21149C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
21150 FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH)
21151 DO 160 I=MMINA,MMAXA
21152 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
21153 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
21154 EI=KCHG(IABS(I),1)/3D0
21155 NCHN=NCHN+1
21156 ISIG(NCHN,1)=I
21157 ISIG(NCHN,2)=-I
21158 ISIG(NCHN,3)=1
21159 SIGH(NCHN)=FACGG*EI**2
21160 160 CONTINUE
21161
21162 ELSEIF(ISUB.EQ.18) THEN
21163C...f + fbar -> gamma + gamma
21164 FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH)
21165 DO 170 I=MMINA,MMAXA
21166 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 170
21167 EI=KCHG(IABS(I),1)/3D0
21168 FCOI=1D0
21169 IF(IABS(I).LE.10) FCOI=FACA/3D0
21170 NCHN=NCHN+1
21171 ISIG(NCHN,1)=I
21172 ISIG(NCHN,2)=-I
21173 ISIG(NCHN,3)=1
21174 SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4
21175 170 CONTINUE
21176 ENDIF
21177
21178 ELSEIF(ISUB.LE.40) THEN
21179 IF(ISUB.EQ.28) THEN
21180C...f + g -> f + g (q + g -> q + g only)
21181 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
21182 & UH/SH)*FACA
21183 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
21184 & SH/UH)
21185 DO 190 I=MMINA,MMAXA
21186 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
21187 DO 180 ISDE=1,2
21188 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
21189 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
21190 NCHN=NCHN+1
21191 ISIG(NCHN,ISDE)=I
21192 ISIG(NCHN,3-ISDE)=21
21193 ISIG(NCHN,3)=1
21194 SIGH(NCHN)=FACQG1
21195 NCHN=NCHN+1
21196 ISIG(NCHN,ISDE)=I
21197 ISIG(NCHN,3-ISDE)=21
21198 ISIG(NCHN,3)=2
21199 SIGH(NCHN)=FACQG2
21200 180 CONTINUE
21201 190 CONTINUE
21202
21203 ELSEIF(ISUB.EQ.29) THEN
21204C...f + g -> f + gamma (q + g -> q + gamma only)
21205 FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH)
21206 DO 210 I=MMINA,MMAXA
21207 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 210
21208 EI=KCHG(IABS(I),1)/3D0
21209 FACGQ=FGQ*EI**2
21210 DO 200 ISDE=1,2
21211 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 200
21212 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 200
21213 NCHN=NCHN+1
21214 ISIG(NCHN,ISDE)=I
21215 ISIG(NCHN,3-ISDE)=21
21216 ISIG(NCHN,3)=1
21217 SIGH(NCHN)=FACGQ
21218 200 CONTINUE
21219 210 CONTINUE
21220
21221 ELSEIF(ISUB.EQ.33) THEN
21222C...f + gamma -> f + g (q + gamma -> q + g only)
21223 FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH)
21224 DO 230 I=MMINA,MMAXA
21225 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 230
21226 EI=KCHG(IABS(I),1)/3D0
21227 FACGQ=FGQ*EI**2
21228 DO 220 ISDE=1,2
21229 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 220
21230 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 220
21231 NCHN=NCHN+1
21232 ISIG(NCHN,ISDE)=I
21233 ISIG(NCHN,3-ISDE)=22
21234 ISIG(NCHN,3)=1
21235 SIGH(NCHN)=FACGQ
21236 220 CONTINUE
21237 230 CONTINUE
21238
21239 ELSEIF(ISUB.EQ.34) THEN
21240C...f + gamma -> f + gamma
21241 FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH)
21242 DO 250 I=MMINA,MMAXA
21243 IF(I.EQ.0) GOTO 250
21244 EI=KCHG(IABS(I),1)/3D0
21245 FACGQ=FGQ*EI**4
21246 DO 240 ISDE=1,2
21247 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 240
21248 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 240
21249 NCHN=NCHN+1
21250 ISIG(NCHN,ISDE)=I
21251 ISIG(NCHN,3-ISDE)=22
21252 ISIG(NCHN,3)=1
21253 SIGH(NCHN)=FACGQ
21254 240 CONTINUE
21255 250 CONTINUE
21256 ENDIF
21257
21258 ELSEIF(ISUB.LE.80) THEN
21259 IF(ISUB.EQ.53) THEN
21260C...g + g -> f + fbar (g + g -> q + qbar only)
21261 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 270
21262 IDC0=MDCY(21,2)-1
21263C...Begin by d, u, s flavours.
21264 FLAVWT=0D0
21265 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
21266 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
21267 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
21268 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
21269 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
21270 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
21271 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
21272 & UH2/SH2)*FLAVWT*FACA
21273 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
21274 & TH2/SH2)*FLAVWT*FACA
21275 NCHN=NCHN+1
21276 ISIG(NCHN,1)=21
21277 ISIG(NCHN,2)=21
21278 ISIG(NCHN,3)=1
21279 SIGH(NCHN)=FACQQ1
21280 NCHN=NCHN+1
21281 ISIG(NCHN,1)=21
21282 ISIG(NCHN,2)=21
21283 ISIG(NCHN,3)=2
21284 SIGH(NCHN)=FACQQ2
21285C...Next c and b flavours: modified that and uhat for fixed
21286C...cos(theta-hat).
21287 DO 260 IFL=4,5
21288 SQMAVG=PMAS(IFL,1)**2
21289 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
21290 BE34=SQRT(1D0-4D0*SQMAVG/SH)
21291 THQ=-0.5D0*SH*(1D0-BE34*CTH)
21292 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
21293 THUHQ=THQ*UHQ-SQMAVG*SH
21294 IF(MSTP(34).EQ.0) THEN
21295 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
21296 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
21297 ELSE
21298 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
21299 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
21300 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
21301 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
21302 ENDIF
21303 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
21304 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
21305 NCHN=NCHN+1
21306 ISIG(NCHN,1)=21
21307 ISIG(NCHN,2)=21
21308 ISIG(NCHN,3)=1+2*(IFL-3)
21309 SIGH(NCHN)=FACQQ1
21310 NCHN=NCHN+1
21311 ISIG(NCHN,1)=21
21312 ISIG(NCHN,2)=21
21313 ISIG(NCHN,3)=2+2*(IFL-3)
21314 SIGH(NCHN)=FACQQ2
21315 ENDIF
21316 260 CONTINUE
21317 270 CONTINUE
21318
21319 ELSEIF(ISUB.EQ.54) THEN
21320C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
21321 CALL PYWIDT(21,SH,WDTP,WDTE)
21322 WDTESU=0D0
21323 DO 280 I=1,MIN(8,MDCY(21,3))
21324 EF=KCHG(I,1)/3D0
21325 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
21326 & WDTE(I,4))
21327 280 CONTINUE
21328 FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH)
21329 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
21330 NCHN=NCHN+1
21331 ISIG(NCHN,1)=21
21332 ISIG(NCHN,2)=22
21333 ISIG(NCHN,3)=1
21334 SIGH(NCHN)=FACQQ
21335 ENDIF
21336 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
21337 NCHN=NCHN+1
21338 ISIG(NCHN,1)=22
21339 ISIG(NCHN,2)=21
21340 ISIG(NCHN,3)=1
21341 SIGH(NCHN)=FACQQ
21342 ENDIF
21343
21344 ELSEIF(ISUB.EQ.58) THEN
21345C...gamma + gamma -> f + fbar
21346 CALL PYWIDT(22,SH,WDTP,WDTE)
21347 WDTESU=0D0
21348 DO 290 I=1,MIN(12,MDCY(22,3))
21349 IF(I.LE.8) EF= KCHG(I,1)/3D0
21350 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
21351 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
21352 & WDTE(I,4))
21353 290 CONTINUE
21354 FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH)
21355 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
21356 NCHN=NCHN+1
21357 ISIG(NCHN,1)=22
21358 ISIG(NCHN,2)=22
21359 ISIG(NCHN,3)=1
21360 SIGH(NCHN)=FACFF
21361 ENDIF
21362
21363 ELSEIF(ISUB.EQ.68) THEN
21364C...g + g -> g + g
21365 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 300
21366 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+2D0*TH/SH+
21367 & TH2/SH2)*FACA
21368 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+2D0*SH/UH+
21369 & SH2/UH2)*FACA
21370 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+2D0*UH/TH+
21371 & UH2/TH2)
21372 NCHN=NCHN+1
21373 ISIG(NCHN,1)=21
21374 ISIG(NCHN,2)=21
21375 ISIG(NCHN,3)=1
21376 SIGH(NCHN)=0.5D0*FACGG1
21377 NCHN=NCHN+1
21378 ISIG(NCHN,1)=21
21379 ISIG(NCHN,2)=21
21380 ISIG(NCHN,3)=2
21381 SIGH(NCHN)=0.5D0*FACGG2
21382 NCHN=NCHN+1
21383 ISIG(NCHN,1)=21
21384 ISIG(NCHN,2)=21
21385 ISIG(NCHN,3)=3
21386 SIGH(NCHN)=0.5D0*FACGG3
21387 300 CONTINUE
21388
21389 ELSEIF(ISUB.EQ.80) THEN
21390C...q + gamma -> q' + pi+/-
21391 FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2)
21392 ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
21393 Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
21394 DELSH=UH*SQRT(ASSH*Q2FPSH)
21395 ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
21396 Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
21397 DELUH=SH*SQRT(ASUH*Q2FPUH)
21398 DO 320 I=MAX(-2,MMINA),MIN(2,MMAXA)
21399 IF(I.EQ.0) GOTO 320
21400 EI=KCHG(IABS(I),1)/3D0
21401 EJ=SIGN(1D0-ABS(EI),EI)
21402 DO 310 ISDE=1,2
21403 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 310
21404 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 310
21405 NCHN=NCHN+1
21406 ISIG(NCHN,ISDE)=I
21407 ISIG(NCHN,3-ISDE)=22
21408 ISIG(NCHN,3)=1
21409 SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2
21410 310 CONTINUE
21411 320 CONTINUE
21412 ENDIF
21413
21414 ELSEIF(ISUB.LE.100) THEN
21415 IF(ISUB.EQ.91) THEN
21416C...Elastic scattering
21417 SIGS=VINT(315)*VINT(316)*SIGT(0,0,1)
21418
21419 ELSEIF(ISUB.EQ.92) THEN
21420C...Single diffractive scattering (first side, i.e. XB)
21421 SIGS=VINT(315)*VINT(316)*SIGT(0,0,2)
21422
21423 ELSEIF(ISUB.EQ.93) THEN
21424C...Single diffractive scattering (second side, i.e. AX)
21425 SIGS=VINT(315)*VINT(316)*SIGT(0,0,3)
21426
21427 ELSEIF(ISUB.EQ.94) THEN
21428C...Double diffractive scattering
21429 SIGS=VINT(315)*VINT(316)*SIGT(0,0,4)
21430
21431 ELSEIF(ISUB.EQ.95) THEN
21432C...Low-pT scattering
21433 SIGS=VINT(315)*VINT(316)*SIGT(0,0,5)
21434
21435 ELSEIF(ISUB.EQ.96) THEN
21436C...Multiple interactions: sum of QCD processes
21437 CALL PYWIDT(21,SH,WDTP,WDTE)
21438
21439C...q + q' -> q + q'
21440 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
21441 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
21442 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
21443 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)/UH2
21444 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
21445 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
21446 DO 340 I=-5,5
21447 IF(I.EQ.0) GOTO 340
21448 DO 330 J=-5,5
21449 IF(J.EQ.0) GOTO 330
21450 NCHN=NCHN+1
21451 ISIG(NCHN,1)=I
21452 ISIG(NCHN,2)=J
21453 ISIG(NCHN,3)=111
21454 SIGH(NCHN)=FACQQ1
21455 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
21456 IF(I.EQ.J) THEN
21457 SIGH(NCHN)=0.5D0*FACQQ1*RATQQI
21458 NCHN=NCHN+1
21459 ISIG(NCHN,1)=I
21460 ISIG(NCHN,2)=J
21461 ISIG(NCHN,3)=112
21462 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
21463 ENDIF
21464 330 CONTINUE
21465 340 CONTINUE
21466
21467C...q + qbar -> q' + qbar' or g + g
21468 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
21469 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
21470 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
21471 & UH2/SH2)
21472 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
21473 & TH2/SH2)
21474 DO 350 I=-5,5
21475 IF(I.EQ.0) GOTO 350
21476 NCHN=NCHN+1
21477 ISIG(NCHN,1)=I
21478 ISIG(NCHN,2)=-I
21479 ISIG(NCHN,3)=121
21480 SIGH(NCHN)=FACQQB
21481 NCHN=NCHN+1
21482 ISIG(NCHN,1)=I
21483 ISIG(NCHN,2)=-I
21484 ISIG(NCHN,3)=131
21485 SIGH(NCHN)=0.5D0*FACGG1
21486 NCHN=NCHN+1
21487 ISIG(NCHN,1)=I
21488 ISIG(NCHN,2)=-I
21489 ISIG(NCHN,3)=132
21490 SIGH(NCHN)=0.5D0*FACGG2
21491 350 CONTINUE
21492
21493C...q + g -> q + g
21494 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
21495 & UH/SH)*FACA
21496 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
21497 & SH/UH)
21498 DO 370 I=-5,5
21499 IF(I.EQ.0) GOTO 370
21500 DO 360 ISDE=1,2
21501 NCHN=NCHN+1
21502 ISIG(NCHN,ISDE)=I
21503 ISIG(NCHN,3-ISDE)=21
21504 ISIG(NCHN,3)=281
21505 SIGH(NCHN)=FACQG1
21506 NCHN=NCHN+1
21507 ISIG(NCHN,ISDE)=I
21508 ISIG(NCHN,3-ISDE)=21
21509 ISIG(NCHN,3)=282
21510 SIGH(NCHN)=FACQG2
21511 360 CONTINUE
21512 370 CONTINUE
21513
21514C...g + g -> q + qbar (only d, u, s)
21515 IDC0=MDCY(21,2)-1
21516 FLAVWT=0D0
21517 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
21518 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
21519 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
21520 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
21521 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
21522 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
21523 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
21524 & UH2/SH2)*FLAVWT*FACA
21525 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
21526 & TH2/SH2)*FLAVWT*FACA
21527 NCHN=NCHN+1
21528 ISIG(NCHN,1)=21
21529 ISIG(NCHN,2)=21
21530 ISIG(NCHN,3)=531
21531 SIGH(NCHN)=FACQQ1
21532 NCHN=NCHN+1
21533 ISIG(NCHN,1)=21
21534 ISIG(NCHN,2)=21
21535 ISIG(NCHN,3)=532
21536 SIGH(NCHN)=FACQQ2
21537
21538C...g + g -> c + cbar, b + bbar: modified that/uhat for fixed
21539C...cos(theta-hat)
21540 DO 380 IFL=4,5
21541 SQMAVG=PMAS(IFL,1)**2
21542 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
21543 BE34=SQRT(1D0-4D0*SQMAVG/SH)
21544 THQ=-0.5D0*SH*(1D0-BE34*CTH)
21545 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
21546 THUHQ=THQ*UHQ-SQMAVG*SH
21547 IF(MSTP(34).EQ.0) THEN
21548 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
21549 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
21550 ELSE
21551 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
21552 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
21553 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
21554 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
21555 ENDIF
21556 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
21557 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
21558 NCHN=NCHN+1
21559 ISIG(NCHN,1)=21
21560 ISIG(NCHN,2)=21
21561 ISIG(NCHN,3)=531+2*(IFL-3)
21562 SIGH(NCHN)=FACQQ1
21563 NCHN=NCHN+1
21564 ISIG(NCHN,1)=21
21565 ISIG(NCHN,2)=21
21566 ISIG(NCHN,3)=532+2*(IFL-3)
21567 SIGH(NCHN)=FACQQ2
21568 ENDIF
21569 380 CONTINUE
21570
21571C...g + g -> g + g
21572 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
21573 & 2D0*TH/SH+TH2/SH2)*FACA
21574 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
21575 & 2D0*SH/UH+SH2/UH2)*FACA
21576 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+
21577 & 2D0*UH/TH+UH2/TH2)
21578 NCHN=NCHN+1
21579 ISIG(NCHN,1)=21
21580 ISIG(NCHN,2)=21
21581 ISIG(NCHN,3)=681
21582 SIGH(NCHN)=0.5D0*FACGG1
21583 NCHN=NCHN+1
21584 ISIG(NCHN,1)=21
21585 ISIG(NCHN,2)=21
21586 ISIG(NCHN,3)=682
21587 SIGH(NCHN)=0.5D0*FACGG2
21588 NCHN=NCHN+1
21589 ISIG(NCHN,1)=21
21590 ISIG(NCHN,2)=21
21591 ISIG(NCHN,3)=683
21592 SIGH(NCHN)=0.5D0*FACGG3
21593
21594 ELSEIF(ISUB.EQ.99) THEN
21595C...f + gamma* -> f.
21596 IF(MINT(107).EQ.4) THEN
21597 Q2GA=VINT(307)
21598 P2GA=VINT(308)
21599 ISDE=2
21600 ELSE
21601 Q2GA=VINT(308)
21602 P2GA=VINT(307)
21603 ISDE=1
21604 ENDIF
21605 COMFAC=PARU(5)*4D0*PARU(1)**2*PARU(101)*VINT(315)*VINT(316)
21606 PM2RHO=PMAS(PYCOMP(113),1)**2
21607 IF(MSTP(19).EQ.0) THEN
21608 COMFAC=COMFAC/Q2GA
21609 ELSEIF(MSTP(19).EQ.1) THEN
21610 COMFAC=COMFAC/(Q2GA+PM2RHO)
21611 ELSEIF(MSTP(19).EQ.2) THEN
21612 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
21613 ELSE
21614 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
21615 W2GA=VINT(2)
21616 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
21617 RDRDS=4.1D-3*W2GA**2.167D0/((Q2GA+0.15D0*W2GA)**2*
21618 & Q2GA**0.75D0)*(1D0+0.11D0*Q2GA*P2GA/(1D0+0.02D0*P2GA**2))
21619 XGA=Q2GA/(W2GA+VINT(307)+VINT(308))
21620 ELSE
21621 RDRDS=1.5D-4*W2GA**2.167D0/((Q2GA+0.041D0*W2GA)**2*
21622 & Q2GA**0.57D0)
21623 XGA=Q2GA/(W2GA+Q2GA-PMAS(PYCOMP(MINT(10+ISDE)),1)**2)
21624 ENDIF
21625 COMFAC=COMFAC*EXP(-MAX(1D-10,RDRDS))
21626 IF(MSTP(19).EQ.4) COMFAC=COMFAC/MAX(1D-2,1D0-XGA)
21627 ENDIF
21628 DO 390 I=MMINA,MMAXA
21629 IF(I.EQ.0.OR.KFAC(ISDE,I).EQ.0) GOTO 390
21630 IF(IABS(I).LT.10.AND.IABS(I).GT.MSTP(58)) GOTO 390
21631 EI=KCHG(IABS(I),1)/3D0
21632 NCHN=NCHN+1
21633 ISIG(NCHN,ISDE)=I
21634 ISIG(NCHN,3-ISDE)=22
21635 ISIG(NCHN,3)=1
21636 SIGH(NCHN)=COMFAC*EI**2
21637 390 CONTINUE
21638 ENDIF
21639
21640 ELSE
21641 IF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN
21642C...g + g -> gamma + gamma or g + g -> g + gamma
21643 A0STUR=0D0
21644 A0STUI=0D0
21645 A0TSUR=0D0
21646 A0TSUI=0D0
21647 A0UTSR=0D0
21648 A0UTSI=0D0
21649 A1STUR=0D0
21650 A1STUI=0D0
21651 A2STUR=0D0
21652 A2STUI=0D0
21653 ALST=LOG(-SH/TH)
21654 ALSU=LOG(-SH/UH)
21655 ALTU=LOG(TH/UH)
21656 IMAX=2*MSTP(1)
21657 IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38)
21658 DO 400 I=1,IMAX
21659 EI=KCHG(IABS(I),1)/3D0
21660 EIWT=EI**2
21661 IF(ISUB.EQ.115) EIWT=EI
21662 SQMQ=PMAS(I,1)**2
21663 EPSS=4D0*SQMQ/SH
21664 EPST=4D0*SQMQ/TH
21665 EPSU=4D0*SQMQ/UH
21666 IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1D-4) THEN
21667 B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+
21668 & PARU(1)**2)
21669 B0STUI=0D0
21670 B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2
21671 B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU)
21672 B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2
21673 B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST)
21674 B1STUR=-1D0
21675 B1STUI=0D0
21676 B2STUR=-1D0
21677 B2STUI=0D0
21678 ELSE
21679 CALL PYWAUX(1,EPSS,W1SR,W1SI)
21680 CALL PYWAUX(1,EPST,W1TR,W1TI)
21681 CALL PYWAUX(1,EPSU,W1UR,W1UI)
21682 CALL PYWAUX(2,EPSS,W2SR,W2SI)
21683 CALL PYWAUX(2,EPST,W2TR,W2TI)
21684 CALL PYWAUX(2,EPSU,W2UR,W2UI)
21685 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
21686 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
21687 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
21688 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
21689 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
21690 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
21691 B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+
21692 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)-
21693 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)-
21694 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+
21695 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
21696 & 0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
21697 B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+
21698 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)-
21699 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)-
21700 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+
21701 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
21702 & 0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
21703 B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+
21704 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)-
21705 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)-
21706 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+
21707 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
21708 & 0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)
21709 B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+
21710 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)-
21711 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)-
21712 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+
21713 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
21714 & 0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)
21715 B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+
21716 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)-
21717 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)-
21718 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+
21719 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
21720 & 0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR)
21721 B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+
21722 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)-
21723 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)-
21724 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+
21725 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
21726 & 0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI)
21727 B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+
21728 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+
21729 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+
21730 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
21731 B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+
21732 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+
21733 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+
21734 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
21735 B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+
21736 & 0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+
21737 & 0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR)
21738 B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+
21739 & 0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+
21740 & 0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI)
21741 ENDIF
21742 A0STUR=A0STUR+EIWT*B0STUR
21743 A0STUI=A0STUI+EIWT*B0STUI
21744 A0TSUR=A0TSUR+EIWT*B0TSUR
21745 A0TSUI=A0TSUI+EIWT*B0TSUI
21746 A0UTSR=A0UTSR+EIWT*B0UTSR
21747 A0UTSI=A0UTSI+EIWT*B0UTSI
21748 A1STUR=A1STUR+EIWT*B1STUR
21749 A1STUI=A1STUI+EIWT*B1STUI
21750 A2STUR=A2STUR+EIWT*B2STUR
21751 A2STUI=A2STUI+EIWT*B2STUI
21752 400 CONTINUE
21753 ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+
21754 & A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2
21755 FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM
21756 FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM
21757 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
21758 NCHN=NCHN+1
21759 ISIG(NCHN,1)=21
21760 ISIG(NCHN,2)=21
21761 ISIG(NCHN,3)=1
21762 IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG
21763 IF(ISUB.EQ.115) SIGH(NCHN)=FACGP
21764 410 CONTINUE
21765
21766 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
21767C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only)
21768 PH=0D0
21769 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
21770 & PH=VINT(3)**2
21771 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
21772 & PH=VINT(4)**2
21773 IF(ISUB.EQ.131) THEN
21774 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**2*
21775 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
21776 ELSE
21777 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
21778 ENDIF
21779 DO 430 I=MMINA,MMAXA
21780 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
21781 EI=KCHG(IABS(I),1)/3D0
21782 FACGQ=FGQ*EI**2
21783 DO 420 ISDE=1,2
21784 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 420
21785 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 420
21786 NCHN=NCHN+1
21787 ISIG(NCHN,ISDE)=I
21788 ISIG(NCHN,3-ISDE)=22
21789 ISIG(NCHN,3)=1
21790 SIGH(NCHN)=FACGQ
21791 420 CONTINUE
21792 430 CONTINUE
21793
21794 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
21795C...f + gamma*_(T,L) -> f + gamma
21796 PH=0D0
21797 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
21798 & PH=VINT(3)**2
21799 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
21800 & PH=VINT(4)**2
21801 IF(ISUB.EQ.133) THEN
21802 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**2*
21803 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
21804 ELSE
21805 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
21806 ENDIF
21807 DO 450 I=MMINA,MMAXA
21808 IF(I.EQ.0) GOTO 450
21809 EI=KCHG(IABS(I),1)/3D0
21810 FACGQ=FGQ*EI**4
21811 DO 440 ISDE=1,2
21812 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 440
21813 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 440
21814 NCHN=NCHN+1
21815 ISIG(NCHN,ISDE)=I
21816 ISIG(NCHN,3-ISDE)=22
21817 ISIG(NCHN,3)=1
21818 SIGH(NCHN)=FACGQ
21819 440 CONTINUE
21820 450 CONTINUE
21821
21822 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
21823C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only)
21824 PH=0D0
21825 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
21826 & PH=VINT(3)**2
21827 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
21828 & PH=VINT(4)**2
21829 CALL PYWIDT(21,SH,WDTP,WDTE)
21830 WDTESU=0D0
21831 DO 460 I=1,MIN(8,MDCY(21,3))
21832 EF=KCHG(I,1)/3D0
21833 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
21834 & WDTE(I,4))
21835 460 CONTINUE
21836 IF(ISUB.EQ.135) THEN
21837 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**2*
21838 & ((TH2+UH2-2D0*PH*SH)/(TH*UH)+4D0*PH*SH/(SH+PH)**2)
21839 ELSE
21840 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**4*8D0*PH*SH
21841 ENDIF
21842 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
21843 NCHN=NCHN+1
21844 ISIG(NCHN,1)=21
21845 ISIG(NCHN,2)=22
21846 ISIG(NCHN,3)=1
21847 SIGH(NCHN)=FACQQ
21848 ENDIF
21849 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
21850 NCHN=NCHN+1
21851 ISIG(NCHN,1)=22
21852 ISIG(NCHN,2)=21
21853 ISIG(NCHN,3)=1
21854 SIGH(NCHN)=FACQQ
21855 ENDIF
21856
21857 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
21858C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar
21859 PH1=0D0
21860 IF(VINT(3).LT.0D0) PH1=VINT(3)**2
21861 PH2=0D0
21862 IF(VINT(4).LT.0D0) PH2=VINT(4)**2
21863 CALL PYWIDT(22,SH,WDTP,WDTE)
21864 WDTESU=0D0
21865 DO 470 I=1,MIN(12,MDCY(22,3))
21866 IF(I.LE.8) EF= KCHG(I,1)/3D0
21867 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
21868 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
21869 & WDTE(I,4))
21870 470 CONTINUE
21871 DLAMB2=(TH+UH)**2-4D0*PH1*PH2
21872 IF(ISUB.EQ.137) THEN
21873 FPARAM=-SH*(TH+UH)/DLAMB2
21874 FACFF=COMFAC*AEM**2*WDTESU*2D0*SH2/(DLAMB2*TH2*UH2)*
21875 & (TH*UH-PH1*PH2)*((TH2+UH2)*(1D0-2D0*FPARAM*(1D0-FPARAM))-
21876 & 2D0*PH1*PH2*FPARAM**2)
21877 ELSEIF(ISUB.EQ.138) THEN
21878 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
21879 & PH2*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH1*SH*(TH-UH)**2/DLAMB2)+
21880 & 2D0*PH1**2*(TH-UH)**2)
21881 ELSEIF(ISUB.EQ.139) THEN
21882 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
21883 & PH1*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH2*SH*(TH-UH)**2/DLAMB2)+
21884 & 2D0*PH2**2*(TH-UH)**2)
21885 ELSE
21886 FACFF=COMFAC*AEM**2*WDTESU*32D0*SH2**2/(DLAMB2**3*TH2*UH2)*
21887 & PH1*PH2*(TH*UH-PH1*PH2)*(TH-UH)**2
21888 ENDIF
21889 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
21890 NCHN=NCHN+1
21891 ISIG(NCHN,1)=22
21892 ISIG(NCHN,2)=22
21893 ISIG(NCHN,3)=1
21894 SIGH(NCHN)=FACFF
21895 ENDIF
21896
21897 ENDIF
21898 ENDIF
21899
21900 RETURN
21901 END
21902
21903C*********************************************************************
21904
21905C...PYSGHF
21906C...Subprocess cross sections for heavy flavour production,
21907C...open and closed.
21908C...Auxiliary to PYSIGH.
21909
21910 SUBROUTINE PYSGHF(NCHN,SIGS)
21911
21912C...Double precision and integer declarations
21913 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21914 IMPLICIT INTEGER(I-N)
21915 INTEGER PYK,PYCHGE,PYCOMP
21916C...Parameter statement to help give large particle numbers.
21917 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
21918 &KEXCIT=4000000,KDIMEN=5000000)
21919C...Commonblocks
21920 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21921 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21922 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21923 COMMON/PYINT1/MINT(400),VINT(400)
21924 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
21925 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
21926 COMMON/PYINT4/MWID(500),WIDS(500,5)
21927 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
21928 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
21929 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
21930 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
21931 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
21932 &/PYINT4/,/PYSGCM/
21933C...Local arrays
21934 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
21935
21936C...Differential cross section expressions.
21937
21938 IF(ISUB.LE.100) THEN
21939 IF(ISUB.EQ.81) THEN
21940C...q + qbar -> Q + Qbar
21941 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
21942 THQ=-0.5D0*SH*(1D0-BE34*CTH)
21943 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
21944 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
21945 & 2D0*SQMAVG/SH)
21946 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
21947 WID2=1D0
21948 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
21949 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
21950 FACQQB=FACQQB*WID2
21951 DO 100 I=MMINA,MMAXA
21952 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
21953 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
21954 NCHN=NCHN+1
21955 ISIG(NCHN,1)=I
21956 ISIG(NCHN,2)=-I
21957 ISIG(NCHN,3)=1
21958 SIGH(NCHN)=FACQQB
21959 100 CONTINUE
21960
21961 ELSEIF(ISUB.EQ.82) THEN
21962C...g + g -> Q + Qbar
21963 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
21964 THQ=-0.5D0*SH*(1D0-BE34*CTH)
21965 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
21966 THUHQ=THQ*UHQ-SQMAVG*SH
21967 IF(MSTP(34).EQ.0) THEN
21968 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
21969 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
21970 ELSE
21971 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
21972 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
21973 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
21974 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
21975 ENDIF
21976 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
21977 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
21978 IF(MSTP(35).GE.1) THEN
21979 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
21980 FACQQ1=FACQQ1*FATRE
21981 FACQQ2=FACQQ2*FATRE
21982 ENDIF
21983 WID2=1D0
21984 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
21985 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
21986 FACQQ1=FACQQ1*WID2
21987 FACQQ2=FACQQ2*WID2
21988 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 110
21989 NCHN=NCHN+1
21990 ISIG(NCHN,1)=21
21991 ISIG(NCHN,2)=21
21992 ISIG(NCHN,3)=1
21993 SIGH(NCHN)=FACQQ1
21994 NCHN=NCHN+1
21995 ISIG(NCHN,1)=21
21996 ISIG(NCHN,2)=21
21997 ISIG(NCHN,3)=2
21998 SIGH(NCHN)=FACQQ2
21999 110 CONTINUE
22000
22001 ELSEIF(ISUB.EQ.83) THEN
22002C...f + q -> f' + Q
22003 FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2
22004 FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2
22005 DO 130 I=MMIN1,MMAX1
22006 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 130
22007 DO 120 J=MMIN2,MMAX2
22008 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 120
22009 IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 120
22010 IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 120
22011 IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1)
22012 & THEN
22013 NCHN=NCHN+1
22014 ISIG(NCHN,1)=I
22015 ISIG(NCHN,2)=J
22016 ISIG(NCHN,3)=1
22017 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
22018 & (IABS(I)+1)/2)*VINT(180+J)
22019 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2,
22020 & (MINT(55)+1)/2)*VINT(180+J)
22021 WID2=1D0
22022 IF(I.GT.0) THEN
22023 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
22024 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
22025 & WIDS(MINT(55),2)
22026 ELSE
22027 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
22028 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
22029 & WIDS(MINT(55),3)
22030 ENDIF
22031 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
22032 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
22033 ENDIF
22034 IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1)
22035 & THEN
22036 NCHN=NCHN+1
22037 ISIG(NCHN,1)=I
22038 ISIG(NCHN,2)=J
22039 ISIG(NCHN,3)=2
22040 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
22041 & (IABS(J)+1)/2)*VINT(180+I)
22042 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2,
22043 & (MINT(55)+1)/2)*VINT(180+I)
22044 IF(J.GT.0) THEN
22045 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
22046 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
22047 & WIDS(MINT(55),2)
22048 ELSE
22049 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
22050 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
22051 & WIDS(MINT(55),3)
22052 ENDIF
22053 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
22054 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
22055 ENDIF
22056 120 CONTINUE
22057 130 CONTINUE
22058
22059 ELSEIF(ISUB.EQ.84) THEN
22060C...g + gamma -> Q + Qbar
22061 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
22062 THQ=-0.5D0*SH*(1D0-BE34*CTH)
22063 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
22064 FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
22065 & (THQ**2+UHQ**2+4D0*SQMAVG*SH*(1D0-SQMAVG*SH/(THQ*UHQ)))/
22066 & (THQ*UHQ)
22067 IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQMAVG,0D0)
22068 WID2=1D0
22069 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
22070 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
22071 FACQQ=FACQQ*WID2
22072 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
22073 NCHN=NCHN+1
22074 ISIG(NCHN,1)=21
22075 ISIG(NCHN,2)=22
22076 ISIG(NCHN,3)=1
22077 SIGH(NCHN)=FACQQ
22078 ENDIF
22079 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
22080 NCHN=NCHN+1
22081 ISIG(NCHN,1)=22
22082 ISIG(NCHN,2)=21
22083 ISIG(NCHN,3)=1
22084 SIGH(NCHN)=FACQQ
22085 ENDIF
22086
22087 ELSEIF(ISUB.EQ.85) THEN
22088C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
22089 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
22090 THQ=-0.5D0*SH*(1D0-BE34*CTH)
22091 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
22092 FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
22093 & ((1D0-PARJ(131)*PARJ(132))*(THQ*UHQ-SQMAVG*SH)*
22094 & (UHQ**2+THQ**2+2D0*SQMAVG*SH)+(1D0+PARJ(131)*PARJ(132))*
22095 & SQMAVG*SH**2*(SH-2D0*SQMAVG))/(THQ*UHQ)**2
22096 IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF
22097 IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1)
22098 & FACFF=FACFF*PYHFTH(SH,SQMAVG,1D0)
22099 WID2=1D0
22100 IF(MINT(56).EQ.6) WID2=WIDS(6,1)
22101 IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1)
22102 IF(MINT(56).EQ.17) WID2=WIDS(17,1)
22103 FACFF=FACFF*WID2
22104 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
22105 NCHN=NCHN+1
22106 ISIG(NCHN,1)=22
22107 ISIG(NCHN,2)=22
22108 ISIG(NCHN,3)=1
22109 SIGH(NCHN)=FACFF
22110 ENDIF
22111
22112 ELSEIF(ISUB.EQ.86) THEN
22113C...g + g -> J/Psi + g
22114 FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)*
22115 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
22116 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
22117 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
22118 NCHN=NCHN+1
22119 ISIG(NCHN,1)=21
22120 ISIG(NCHN,2)=21
22121 ISIG(NCHN,3)=1
22122 SIGH(NCHN)=FACQQG
22123 ENDIF
22124
22125 ELSEIF(ISUB.EQ.87) THEN
22126C...g + g -> chi_0c + g
22127 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
22128 QGTW=(SH*TH*UH)/SH**3
22129 RGTW=SQM3/SH
22130 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
22131 & (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
22132 & 6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)-
22133 & PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+
22134 & 2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/
22135 & (QGTW*(QGTW-RGTW*PGTW)**4)
22136 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
22137 NCHN=NCHN+1
22138 ISIG(NCHN,1)=21
22139 ISIG(NCHN,2)=21
22140 ISIG(NCHN,3)=1
22141 SIGH(NCHN)=FACQQG
22142 ENDIF
22143
22144 ELSEIF(ISUB.EQ.88) THEN
22145C...g + g -> chi_1c + g
22146 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
22147 QGTW=(SH*TH*UH)/SH**3
22148 RGTW=SQM3/SH
22149 FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
22150 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+
22151 & 5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/
22152 & (QGTW-RGTW*PGTW)**4
22153 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
22154 NCHN=NCHN+1
22155 ISIG(NCHN,1)=21
22156 ISIG(NCHN,2)=21
22157 ISIG(NCHN,3)=1
22158 SIGH(NCHN)=FACQQG
22159 ENDIF
22160
22161 ELSEIF(ISUB.EQ.89) THEN
22162C...g + g -> chi_2c + g
22163 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
22164 QGTW=(SH*TH*UH)/SH**3
22165 RGTW=SQM3/SH
22166 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
22167 & (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
22168 & 3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+
22169 & 2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+
22170 & RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2*
22171 & QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
22172 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
22173 NCHN=NCHN+1
22174 ISIG(NCHN,1)=21
22175 ISIG(NCHN,2)=21
22176 ISIG(NCHN,3)=1
22177 SIGH(NCHN)=FACQQG
22178 ENDIF
22179 ENDIF
22180
22181 ELSEIF(ISUB.LE.200) THEN
22182 IF(ISUB.EQ.104) THEN
22183C...g + g -> chi_c0.
22184 KC=PYCOMP(10441)
22185 FACBW=COMFAC*12D0*AS**2*PARP(39)*PMAS(KC,2)/
22186 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
22187 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
22188 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
22189 NCHN=NCHN+1
22190 ISIG(NCHN,1)=21
22191 ISIG(NCHN,2)=21
22192 ISIG(NCHN,3)=1
22193 SIGH(NCHN)=FACBW
22194 ENDIF
22195
22196 ELSEIF(ISUB.EQ.105) THEN
22197C...g + g -> chi_c2.
22198 KC=PYCOMP(445)
22199 FACBW=COMFAC*16D0*AS**2*PARP(39)*PMAS(KC,2)/
22200 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
22201 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
22202 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
22203 NCHN=NCHN+1
22204 ISIG(NCHN,1)=21
22205 ISIG(NCHN,2)=21
22206 ISIG(NCHN,3)=1
22207 SIGH(NCHN)=FACBW
22208 ENDIF
22209
22210 ELSEIF(ISUB.EQ.106) THEN
22211C...g + g -> J/Psi + gamma.
22212 EQ=2D0/3D0
22213 FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)*
22214 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
22215 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
22216 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
22217 NCHN=NCHN+1
22218 ISIG(NCHN,1)=21
22219 ISIG(NCHN,2)=21
22220 ISIG(NCHN,3)=1
22221 SIGH(NCHN)=FACQQG
22222 ENDIF
22223
22224 ELSEIF(ISUB.EQ.107) THEN
22225C...g + gamma -> J/Psi + g.
22226 EQ=2D0/3D0
22227 FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)*
22228 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
22229 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
22230 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
22231 NCHN=NCHN+1
22232 ISIG(NCHN,1)=21
22233 ISIG(NCHN,2)=22
22234 ISIG(NCHN,3)=1
22235 SIGH(NCHN)=FACQQG
22236 ENDIF
22237 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
22238 NCHN=NCHN+1
22239 ISIG(NCHN,1)=22
22240 ISIG(NCHN,2)=21
22241 ISIG(NCHN,3)=1
22242 SIGH(NCHN)=FACQQG
22243 ENDIF
22244
22245 ELSEIF(ISUB.EQ.108) THEN
22246C...gamma + gamma -> J/Psi + gamma.
22247 EQ=2D0/3D0
22248 FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)*
22249 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
22250 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
22251 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
22252 NCHN=NCHN+1
22253 ISIG(NCHN,1)=22
22254 ISIG(NCHN,2)=22
22255 ISIG(NCHN,3)=1
22256 SIGH(NCHN)=FACQQG
22257 ENDIF
22258 ENDIF
22259 ENDIF
22260
22261 RETURN
22262 END
22263
22264C*********************************************************************
22265
22266C...PYSGWZ
22267C...Subprocess cross sections for W/Z processes,
22268C...except that longitudinal WW scattering is in Higgs sector.
22269C...Auxiliary to PYSIGH.
22270
22271 SUBROUTINE PYSGWZ(NCHN,SIGS)
22272
22273C...Double precision and integer declarations
22274 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22275 IMPLICIT INTEGER(I-N)
22276 INTEGER PYK,PYCHGE,PYCOMP
22277C...Parameter statement to help give large particle numbers.
22278 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
22279 &KEXCIT=4000000,KDIMEN=5000000)
22280C...Commonblocks
22281 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22282 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
22283 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
22284 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
22285 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22286 COMMON/PYINT1/MINT(400),VINT(400)
22287 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
22288 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
22289 COMMON/PYINT4/MWID(500),WIDS(500,5)
22290 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
22291 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
22292 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
22293 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
22294 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
22295 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
22296 &/PYINT2/,/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
22297C...Local arrays and complex numbers
22298 DIMENSION WDTP(0:400),WDTE(0:400,0:5),HGZ(6,3),HL3(3),HR3(3),
22299 &HL4(3),HR4(3)
22300 COMPLEX*16 COULCK,COULCP,COULCD,COULCR,COULCS
22301
22302C...Differential cross section expressions.
22303
22304 IF(ISUB.LE.20) THEN
22305 IF(ISUB.EQ.1) THEN
22306C...f + fbar -> gamma*/Z0
22307 MINT(61)=2
22308 CALL PYWIDT(23,SH,WDTP,WDTE)
22309 HS=SHR*WDTP(0)
22310 FACZ=4D0*COMFAC*3D0
22311 HP0=AEM/3D0*SH
22312 HP1=AEM/3D0*XWC*SH
22313 DO 100 I=MMINA,MMAXA
22314 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
22315 EI=KCHG(IABS(I),1)/3D0
22316 AI=SIGN(1D0,EI)
22317 VI=AI-4D0*EI*XWV
22318 HI0=HP0
22319 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
22320 HI1=HP1
22321 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
22322 NCHN=NCHN+1
22323 ISIG(NCHN,1)=I
22324 ISIG(NCHN,2)=-I
22325 ISIG(NCHN,3)=1
22326 SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+
22327 & EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*
22328 & (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/
22329 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114))
22330 100 CONTINUE
22331
22332 ELSEIF(ISUB.EQ.2) THEN
22333C...f + fbar' -> W+/-
22334 CALL PYWIDT(24,SH,WDTP,WDTE)
22335 HS=SHR*WDTP(0)
22336 FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0
22337 HP=AEM/(24D0*XW)*SH
22338 DO 120 I=MMIN1,MMAX1
22339 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
22340 IA=IABS(I)
22341 DO 110 J=MMIN2,MMAX2
22342 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
22343 JA=IABS(J)
22344 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
22345 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
22346 & GOTO 110
22347 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
22348 HI=HP*2D0
22349 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
22350 NCHN=NCHN+1
22351 ISIG(NCHN,1)=I
22352 ISIG(NCHN,2)=J
22353 ISIG(NCHN,3)=1
22354 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
22355 SIGH(NCHN)=HI*FACBW*HF
22356 110 CONTINUE
22357 120 CONTINUE
22358
22359 ELSEIF(ISUB.EQ.15) THEN
22360C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
22361 FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
22362C...gamma, gamma/Z interference and Z couplings to final fermion pairs
22363 HFGG=0D0
22364 HFGZ=0D0
22365 HFZZ=0D0
22366 RADC4=1D0+PYALPS(SQM4)/PARU(1)
22367 DO 130 I=1,MIN(16,MDCY(23,3))
22368 IDC=I+MDCY(23,2)-1
22369 IF(MDME(IDC,1).LT.0) GOTO 130
22370 IMDM=0
22371 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
22372 & IMDM=1
22373 IF(I.LE.8) THEN
22374 EF=KCHG(I,1)/3D0
22375 AF=SIGN(1D0,EF+0.1D0)
22376 VF=AF-4D0*EF*XWV
22377 ELSEIF(I.LE.16) THEN
22378 EF=KCHG(I+2,1)/3D0
22379 AF=SIGN(1D0,EF+0.1D0)
22380 VF=AF-4D0*EF*XWV
22381 ENDIF
22382 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
22383 IF(4D0*RM1.LT.1D0) THEN
22384 FCOF=1D0
22385 IF(I.LE.8) FCOF=3D0*RADC4
22386 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
22387 IF(IMDM.EQ.1) THEN
22388 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
22389 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
22390 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
22391 & AF**2*(1D0-4D0*RM1))*BE34
22392 ENDIF
22393 ENDIF
22394 130 CONTINUE
22395C...Propagators: as simulated in PYOFSH and as desired
22396 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
22397 MINT15=MINT(15)
22398 MINT(15)=1
22399 MINT(61)=1
22400 CALL PYWIDT(23,SQM4,WDTP,WDTE)
22401 MINT(15)=MINT15
22402 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
22403 HFGG=HFGG*HFAEM*VINT(111)/SQM4
22404 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
22405 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
22406C...Loop over flavours; consider full gamma/Z structure
22407 DO 140 I=MMINA,MMAXA
22408 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
22409 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
22410 EI=KCHG(IABS(I),1)/3D0
22411 AI=SIGN(1D0,EI)
22412 VI=AI-4D0*EI*XWV
22413 NCHN=NCHN+1
22414 ISIG(NCHN,1)=I
22415 ISIG(NCHN,2)=-I
22416 ISIG(NCHN,3)=1
22417 SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+
22418 & (VI**2+AI**2)*HFZZ)/HBW4
22419 140 CONTINUE
22420
22421 ELSEIF(ISUB.EQ.16) THEN
22422C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
22423 FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
22424C...Propagators: as simulated in PYOFSH and as desired
22425 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
22426 CALL PYWIDT(24,SQM4,WDTP,WDTE)
22427 GMMWC=SQRT(SQM4)*WDTP(0)
22428 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
22429 FACWG=FACWG*HBW4C/HBW4
22430 DO 160 I=MMIN1,MMAX1
22431 IA=IABS(I)
22432 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 160
22433 DO 150 J=MMIN2,MMAX2
22434 JA=IABS(J)
22435 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 150
22436 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 150
22437 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
22438 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
22439 FCKM=VCKM((IA+1)/2,(JA+1)/2)
22440 NCHN=NCHN+1
22441 ISIG(NCHN,1)=I
22442 ISIG(NCHN,2)=J
22443 ISIG(NCHN,3)=1
22444 SIGH(NCHN)=FACWG*FCKM*WIDSC
22445 150 CONTINUE
22446 160 CONTINUE
22447
22448 ELSEIF(ISUB.EQ.19) THEN
22449C...f + fbar -> gamma + (gamma*/Z0)
22450 FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
22451C...gamma, gamma/Z interference and Z couplings to final fermion pairs
22452 HFGG=0D0
22453 HFGZ=0D0
22454 HFZZ=0D0
22455 RADC4=1D0+PYALPS(SQM4)/PARU(1)
22456 DO 170 I=1,MIN(16,MDCY(23,3))
22457 IDC=I+MDCY(23,2)-1
22458 IF(MDME(IDC,1).LT.0) GOTO 170
22459 IMDM=0
22460 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
22461 & IMDM=1
22462 IF(I.LE.8) THEN
22463 EF=KCHG(I,1)/3D0
22464 AF=SIGN(1D0,EF+0.1D0)
22465 VF=AF-4D0*EF*XWV
22466 ELSEIF(I.LE.16) THEN
22467 EF=KCHG(I+2,1)/3D0
22468 AF=SIGN(1D0,EF+0.1D0)
22469 VF=AF-4D0*EF*XWV
22470 ENDIF
22471 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
22472 IF(4D0*RM1.LT.1D0) THEN
22473 FCOF=1D0
22474 IF(I.LE.8) FCOF=3D0*RADC4
22475 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
22476 IF(IMDM.EQ.1) THEN
22477 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
22478 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
22479 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
22480 & AF**2*(1D0-4D0*RM1))*BE34
22481 ENDIF
22482 ENDIF
22483 170 CONTINUE
22484C...Propagators: as simulated in PYOFSH and as desired
22485 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
22486 MINT15=MINT(15)
22487 MINT(15)=1
22488 MINT(61)=1
22489 CALL PYWIDT(23,SQM4,WDTP,WDTE)
22490 MINT(15)=MINT15
22491 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
22492 HFGG=HFGG*HFAEM*VINT(111)/SQM4
22493 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
22494 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
22495C...Loop over flavours; consider full gamma/Z structure
22496 DO 180 I=MMINA,MMAXA
22497 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180
22498 EI=KCHG(IABS(I),1)/3D0
22499 AI=SIGN(1D0,EI)
22500 VI=AI-4D0*EI*XWV
22501 FCOI=1D0
22502 IF(IABS(I).LE.10) FCOI=FACA/3D0
22503 NCHN=NCHN+1
22504 ISIG(NCHN,1)=I
22505 ISIG(NCHN,2)=-I
22506 ISIG(NCHN,3)=1
22507 SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+
22508 & (VI**2+AI**2)*HFZZ)/HBW4
22509 180 CONTINUE
22510
22511 ELSEIF(ISUB.EQ.20) THEN
22512C...f + fbar' -> gamma + W+/-
22513 FACGW=COMFAC*0.5D0*AEM**2/XW
22514C...Propagators: as simulated in PYOFSH and as desired
22515 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
22516 CALL PYWIDT(24,SQM4,WDTP,WDTE)
22517 GMMWC=SQRT(SQM4)*WDTP(0)
22518 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
22519 FACGW=FACGW*HBW4C/HBW4
22520C...Anomalous couplings
22521 TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
22522 TERM2=0D0
22523 TERM3=0D0
22524 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
22525 TERM2=RTCM(46)*(TH-UH)/(TH+UH)
22526 TERM3=0.5D0*RTCM(46)**2*(TH*UH+(TH2+UH2)*SH/
22527 & (4D0*SQMW))/(TH+UH)**2
22528 ENDIF
22529 DO 200 I=MMIN1,MMAX1
22530 IA=IABS(I)
22531 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 200
22532 DO 190 J=MMIN2,MMAX2
22533 JA=IABS(J)
22534 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 190
22535 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 190
22536 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
22537 & GOTO 190
22538 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
22539 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
22540 IF(IA.LE.10) THEN
22541 FACWR=UH/(TH+UH)-1D0/3D0
22542 FCKM=VCKM((IA+1)/2,(JA+1)/2)
22543 FCOI=FACA/3D0
22544 ELSE
22545 FACWR=-TH/(TH+UH)
22546 FCKM=1D0
22547 FCOI=1D0
22548 ENDIF
22549 FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3
22550 NCHN=NCHN+1
22551 ISIG(NCHN,1)=I
22552 ISIG(NCHN,2)=J
22553 ISIG(NCHN,3)=1
22554 SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC
22555 190 CONTINUE
22556 200 CONTINUE
22557 ENDIF
22558
22559 ELSEIF(ISUB.LE.40) THEN
22560 IF(ISUB.EQ.22) THEN
22561C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
22562C...Kinematics dependence
22563 FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)-
22564 & SQM3*SQM4*(1D0/TH2+1D0/UH2))
22565C...gamma, gamma/Z interference and Z couplings to final fermion pairs
22566 DO 220 I=1,6
22567 DO 210 J=1,3
22568 HGZ(I,J)=0D0
22569 210 CONTINUE
22570 220 CONTINUE
22571 RADC3=1D0+PYALPS(SQM3)/PARU(1)
22572 RADC4=1D0+PYALPS(SQM4)/PARU(1)
22573 DO 230 I=1,MIN(16,MDCY(23,3))
22574 IDC=I+MDCY(23,2)-1
22575 IF(MDME(IDC,1).LT.0) GOTO 230
22576 IMDM=0
22577 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1
22578 IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2
22579 IF(I.LE.8) THEN
22580 EF=KCHG(I,1)/3D0
22581 AF=SIGN(1D0,EF+0.1D0)
22582 VF=AF-4D0*EF*XWV
22583 ELSEIF(I.LE.16) THEN
22584 EF=KCHG(I+2,1)/3D0
22585 AF=SIGN(1D0,EF+0.1D0)
22586 VF=AF-4D0*EF*XWV
22587 ENDIF
22588 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3
22589 IF(4D0*RM1.LT.1D0) THEN
22590 FCOF=1D0
22591 IF(I.LE.8) FCOF=3D0*RADC3
22592 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
22593 IF(IMDM.GE.1) THEN
22594 HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
22595 HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
22596 HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
22597 & AF**2*(1D0-4D0*RM1))*BE34
22598 ENDIF
22599 ENDIF
22600 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
22601 IF(4D0*RM1.LT.1D0) THEN
22602 FCOF=1D0
22603 IF(I.LE.8) FCOF=3D0*RADC4
22604 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
22605 IF(IMDM.GE.1) THEN
22606 HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
22607 HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
22608 HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
22609 & AF**2*(1D0-4D0*RM1))*BE34
22610 ENDIF
22611 ENDIF
22612 230 CONTINUE
22613C...Propagators: as simulated in PYOFSH and as desired
22614 HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
22615 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
22616 MINT15=MINT(15)
22617 MINT(15)=1
22618 MINT(61)=1
22619 CALL PYWIDT(23,SQM3,WDTP,WDTE)
22620 MINT(15)=MINT15
22621 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
22622 DO 240 J=1,3
22623 HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3
22624 HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3
22625 HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3
22626 240 CONTINUE
22627 MINT15=MINT(15)
22628 MINT(15)=1
22629 MINT(61)=1
22630 CALL PYWIDT(23,SQM4,WDTP,WDTE)
22631 MINT(15)=MINT15
22632 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
22633 DO 250 J=1,3
22634 HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4
22635 HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4
22636 HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4
22637 250 CONTINUE
22638C...Loop over flavours; separate left- and right-handed couplings
22639 DO 270 I=MMINA,MMAXA
22640 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 270
22641 EI=KCHG(IABS(I),1)/3D0
22642 AI=SIGN(1D0,EI)
22643 VI=AI-4D0*EI*XWV
22644 VALI=VI-AI
22645 VARI=VI+AI
22646 FCOI=1D0
22647 IF(IABS(I).LE.10) FCOI=FACA/3D0
22648 DO 260 J=1,3
22649 HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J)
22650 HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J)
22651 HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J)
22652 HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J)
22653 260 CONTINUE
22654 FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+
22655 & HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+
22656 & HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+
22657 & HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3)
22658 NCHN=NCHN+1
22659 ISIG(NCHN,1)=I
22660 ISIG(NCHN,2)=-I
22661 ISIG(NCHN,3)=1
22662 SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4)
22663 270 CONTINUE
22664
22665 ELSEIF(ISUB.EQ.23) THEN
22666C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.)
22667 FACZW=COMFAC*0.5D0*(AEM/XW)**2
22668 FACZW=FACZW*WIDS(23,2)
22669 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
22670 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
22671 DO 290 I=MMIN1,MMAX1
22672 IA=IABS(I)
22673 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 290
22674 DO 280 J=MMIN2,MMAX2
22675 JA=IABS(J)
22676 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 280
22677 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 280
22678 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
22679 & GOTO 280
22680 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
22681 EI=KCHG(IA,1)/3D0
22682 AI=SIGN(1D0,EI+0.1D0)
22683 VI=AI-4D0*EI*XWV
22684 EJ=KCHG(JA,1)/3D0
22685 AJ=SIGN(1D0,EJ+0.1D0)
22686 VJ=AJ-4D0*EJ*XWV
22687 IF(VI+AI.GT.0) THEN
22688 VISAV=VI
22689 AISAV=AI
22690 VI=VJ
22691 AI=AJ
22692 VJ=VISAV
22693 AJ=AISAV
22694 ENDIF
22695 FCKM=1D0
22696 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
22697 FCOI=1D0
22698 IF(IA.LE.10) FCOI=FACA/3D0
22699 NCHN=NCHN+1
22700 ISIG(NCHN,1)=I
22701 ISIG(NCHN,2)=J
22702 ISIG(NCHN,3)=1
22703 SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+
22704 & (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))*
22705 & (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
22706 & THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
22707 & SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))*
22708 & WIDS(24,(5-KCHW)/2)
22709C***Protect against slightly negative cross sections. (Reason yet to be
22710C***sorted out. One possibility: addition of width to the W propagator.)
22711 SIGH(NCHN)=MAX(0D0,SIGH(NCHN))
22712 280 CONTINUE
22713 290 CONTINUE
22714
22715 ELSEIF(ISUB.EQ.25) THEN
22716C...f + fbar -> W+ + W-
22717C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
22718 GMMZC=GMMZ
22719 HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2)
22720 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
22721 CALL PYWIDT(24,SQM3,WDTP,WDTE)
22722 GMMW3=SQRT(SQM3)*WDTP(0)
22723 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
22724 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
22725 CALL PYWIDT(24,SQM4,WDTP,WDTE)
22726 GMMW4=SQRT(SQM4)*WDTP(0)
22727 HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2)
22728C...Kinematical functions
22729 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
22730 THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4)
22731 GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2
22732 GT=THUH34+4D0*THUH/TH2
22733 GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH
22734 GU=THUH34+4D0*THUH/UH2
22735 GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH
22736C...Common factors and couplings
22737 FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)
22738 FACWW=FACWW*WIDS(24,1)
22739 CGG=AEM**2/2D0
22740 CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH)
22741 CZZ=AEM**2/(32D0*XW**2)*HBWZC
22742 CNG=AEM**2/(4D0*XW)
22743 CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH)
22744 CNN=AEM**2/(16D0*XW**2)
22745C...Coulomb factor for W+W- pair
22746 IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
22747 COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1))
22748 COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH))
22749 IF(COULE.LT.100D0*PMAS(24,2)) THEN
22750 COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
22751 & PMAS(24,2)**2)-COULE))
22752 ELSE
22753 COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE))
22754 ENDIF
22755 IF(COULE.GT.-100D0*PMAS(24,2)) THEN
22756 COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
22757 & PMAS(24,2)**2)+COULE))
22758 ELSE
22759 COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/
22760 & ABS(COULE)))
22761 ENDIF
22762 IF(MSTP(40).EQ.1) THEN
22763 COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/
22764 & MAX(1D-10,2D0*COULP*COULP1))
22765 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
22766 ELSEIF(MSTP(40).EQ.2) THEN
22767 COULCK=DCMPLX(DBLE(COULP1),DBLE(COULP2))
22768 COULCP=DCMPLX(0D0,DBLE(COULP))
22769 COULCD=(COULCK+COULCP)/(COULCK-COULCP)
22770 COULCR=1D0+DBLE(PARU(101)*SQRT(SH))/
22771 & (4D0*COULCP)*LOG(COULCD)
22772 COULCS=DCMPLX(0D0,0D0)
22773 NSTP=100
22774 DO 300 ISTP=1,NSTP
22775 COULXX=(ISTP-0.5)/NSTP
22776 COULCS=COULCS+(1D0/COULXX)*LOG((1D0+COULXX*COULCD)/
22777 & (1D0+COULXX/COULCD))
22778 300 CONTINUE
22779 COULCR=COULCR+DBLE(PARU(101)**2*SH)/(16D0*COULCP*COULCK)*
22780 & (COULCS/NSTP)
22781 FACCOU=ABS(COULCR)**2
22782 ELSEIF(MSTP(40).EQ.3) THEN
22783 COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+
22784 & COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1))
22785 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
22786 ENDIF
22787 ELSEIF(MSTP(40).EQ.4) THEN
22788 FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34)
22789 ELSE
22790 FACCOU=1D0
22791 ENDIF
22792 VINT(95)=FACCOU
22793 FACWW=FACWW*FACCOU
22794C...Loop over allowed flavours
22795 DO 310 I=MMINA,MMAXA
22796 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
22797 EI=KCHG(IABS(I),1)/3D0
22798 AI=SIGN(1D0,EI+0.1D0)
22799 VI=AI-4D0*EI*XWV
22800 FCOI=1D0
22801 IF(IABS(I).LE.10) FCOI=FACA/3D0
22802 IF(MSTP(50).LE.0.OR.IABS(I).LE.10) THEN
22803 IF(AI.LT.0D0) THEN
22804 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+
22805 & (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT
22806 ELSE
22807 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS-
22808 & (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU
22809 ENDIF
22810 ELSE
22811 XMW02=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
22812 BET=SQRT(1D0-4D0*XMW02/SH)
22813 GAT=1D0/SQRT(1D0-BET**2)
22814 STHE2=1D0-CTH**2
22815 AMPZG=BET**3*(16D0+(4D0*BET**2*GAT**2+3D0/GAT**2)*STHE2)
22816 AMPNU=BET*(2D0+BET**2*GAT**2*STHE2/2D0+
22817 & 2D0*BET**2*(1D0-BET**2)*STHE2/(1D0-2D0*BET*CTH+BET**2)**2)
22818 AMPNG=BET*((1D0+BET**2)*(4D0+BET**2*GAT**2*STHE2)+
22819 & 2D0*(1D0-BET**2)*(BET**2*STHE2-2D0*(1D0-BET**2))/
22820 & (1D0-2D0*BET*CTH+BET**2))
22821 PROPI1=(0.25D0*SQMZ/XMW02)*HBWZC*(1D0-SQMZ/SH)
22822 PROPI2=(0.25D0*SQMZ/XMW02)**2*HBWZC
22823 A0=(2D0*(XMW02/SQMZ)-(1D0-BET**2)*XW)*POLL
22824 A1=(2D0*(XMW02/SQMZ)**2-2*XMW02/SQMZ*(1D0-BET**2)*XW)*POLL
22825 A2=(1D0-BET**2)**2*XW**2*(POLR+POLL)/2D0
22826 ATOT=AMPNU*POLL+(A1+A2)*PROPI2*AMPZG-A0*PROPI1*AMPNG
22827 ATOT=ATOT*CNN/SQMW*SH/BET*2D0
22828 DSIGWW=ATOT
22829 ENDIF
22830 NCHN=NCHN+1
22831 ISIG(NCHN,1)=I
22832 ISIG(NCHN,2)=-I
22833 ISIG(NCHN,3)=1
22834 SIGH(NCHN)=FACWW*FCOI*DSIGWW
22835 310 CONTINUE
22836
22837 ELSEIF(ISUB.EQ.30) THEN
22838C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
22839 FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/
22840 & (-SH*UH)
22841C...gamma, gamma/Z interference and Z couplings to final fermion pairs
22842 HFGG=0D0
22843 HFGZ=0D0
22844 HFZZ=0D0
22845 RADC4=1D0+PYALPS(SQM4)/PARU(1)
22846 DO 320 I=1,MIN(16,MDCY(23,3))
22847 IDC=I+MDCY(23,2)-1
22848 IF(MDME(IDC,1).LT.0) GOTO 320
22849 IMDM=0
22850 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
22851 & IMDM=1
22852 IF(I.LE.8) THEN
22853 EF=KCHG(I,1)/3D0
22854 AF=SIGN(1D0,EF+0.1D0)
22855 VF=AF-4D0*EF*XWV
22856 ELSEIF(I.LE.16) THEN
22857 EF=KCHG(I+2,1)/3D0
22858 AF=SIGN(1D0,EF+0.1D0)
22859 VF=AF-4D0*EF*XWV
22860 ENDIF
22861 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
22862 IF(4D0*RM1.LT.1D0) THEN
22863 FCOF=1D0
22864 IF(I.LE.8) FCOF=3D0*RADC4
22865 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
22866 IF(IMDM.EQ.1) THEN
22867 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
22868 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
22869 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
22870 & AF**2*(1D0-4D0*RM1))*BE34
22871 ENDIF
22872 ENDIF
22873 320 CONTINUE
22874C...Propagators: as simulated in PYOFSH and as desired
22875 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
22876 MINT15=MINT(15)
22877 MINT(15)=1
22878 MINT(61)=1
22879 CALL PYWIDT(23,SQM4,WDTP,WDTE)
22880 MINT(15)=MINT15
22881 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
22882 HFGG=HFGG*HFAEM*VINT(111)/SQM4
22883 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
22884 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
22885C...Loop over flavours; consider full gamma/Z structure
22886 DO 340 I=MMINA,MMAXA
22887 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
22888 EI=KCHG(IABS(I),1)/3D0
22889 AI=SIGN(1D0,EI)
22890 VI=AI-4D0*EI*XWV
22891 FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+
22892 & (VI**2+AI**2)*HFZZ)/HBW4
22893 DO 330 ISDE=1,2
22894 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
22895 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
22896 NCHN=NCHN+1
22897 ISIG(NCHN,ISDE)=I
22898 ISIG(NCHN,3-ISDE)=21
22899 ISIG(NCHN,3)=1
22900 SIGH(NCHN)=FACZQ
22901 330 CONTINUE
22902 340 CONTINUE
22903
22904 ELSEIF(ISUB.EQ.31) THEN
22905C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
22906 FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0*
22907 & (SH2+UH2+2D0*SQM4*TH)/(-SH*UH)
22908C...Propagators: as simulated in PYOFSH and as desired
22909 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
22910 CALL PYWIDT(24,SQM4,WDTP,WDTE)
22911 GMMWC=SQRT(SQM4)*WDTP(0)
22912 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
22913 FACWQ=FACWQ*HBW4C/HBW4
22914 DO 360 I=MMINA,MMAXA
22915 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
22916 IA=IABS(I)
22917 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
22918 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
22919 DO 350 ISDE=1,2
22920 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
22921 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
22922 NCHN=NCHN+1
22923 ISIG(NCHN,ISDE)=I
22924 ISIG(NCHN,3-ISDE)=21
22925 ISIG(NCHN,3)=1
22926 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
22927 350 CONTINUE
22928 360 CONTINUE
22929
22930 ELSEIF(ISUB.EQ.35) THEN
22931C...f + gamma -> f + (gamma*/Z0)
22932 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) THEN
22933 FZQN=SH2+UH2+2D0*(SQM4-VINT(3)**2)*TH
22934 FZQDTM=VINT(3)**2*SQM4-SH*(UH-VINT(4)**2)
22935 ELSEIF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) THEN
22936 FZQN=SH2+UH2+2D0*(SQM4-VINT(4)**2)*TH
22937 FZQDTM=VINT(4)**2*SQM4-SH*(UH-VINT(3)**2)
22938 ELSE
22939 FZQN=SH2+UH2+2D0*SQM4*TH
22940 FZQDTM=-SH*UH
22941 ENDIF
22942 FZQN=COMFAC*2D0*AEM**2*MAX(0D0,FZQN)
22943C...gamma, gamma/Z interference and Z couplings to final fermion pairs
22944 HFGG=0D0
22945 HFGZ=0D0
22946 HFZZ=0D0
22947 RADC4=1D0+PYALPS(SQM4)/PARU(1)
22948 DO 370 I=1,MIN(16,MDCY(23,3))
22949 IDC=I+MDCY(23,2)-1
22950 IF(MDME(IDC,1).LT.0) GOTO 370
22951 IMDM=0
22952 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
22953 & IMDM=1
22954 IF(I.LE.8) THEN
22955 EF=KCHG(I,1)/3D0
22956 AF=SIGN(1D0,EF+0.1D0)
22957 VF=AF-4D0*EF*XWV
22958 ELSEIF(I.LE.16) THEN
22959 EF=KCHG(I+2,1)/3D0
22960 AF=SIGN(1D0,EF+0.1D0)
22961 VF=AF-4D0*EF*XWV
22962 ENDIF
22963 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
22964 IF(4D0*RM1.LT.1D0) THEN
22965 FCOF=1D0
22966 IF(I.LE.8) FCOF=3D0*RADC4
22967 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
22968 IF(IMDM.EQ.1) THEN
22969 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
22970 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
22971 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
22972 & AF**2*(1D0-4D0*RM1))*BE34
22973 ENDIF
22974 ENDIF
22975 370 CONTINUE
22976C...Propagators: as simulated in PYOFSH and as desired
22977 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
22978 MINT15=MINT(15)
22979 MINT(15)=1
22980 MINT(61)=1
22981 CALL PYWIDT(23,SQM4,WDTP,WDTE)
22982 MINT(15)=MINT15
22983 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
22984 HFGG=HFGG*HFAEM*VINT(111)/SQM4
22985 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
22986 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
22987C...Loop over flavours; consider full gamma/Z structure
22988 DO 390 I=MMINA,MMAXA
22989 IF(I.EQ.0) GOTO 390
22990 EI=KCHG(IABS(I),1)/3D0
22991 AI=SIGN(1D0,EI)
22992 VI=AI-4D0*EI*XWV
22993 FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+
22994 & (VI**2+AI**2)*HFZZ)/HBW4
22995 FZQD=MAX(PMAS(IABS(I),1)**2*SQM4,FZQDTM)
22996 DO 380 ISDE=1,2
22997 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 380
22998 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 380
22999 NCHN=NCHN+1
23000 ISIG(NCHN,ISDE)=I
23001 ISIG(NCHN,3-ISDE)=22
23002 ISIG(NCHN,3)=1
23003 SIGH(NCHN)=FACZQ*FZQN/FZQD
23004 380 CONTINUE
23005 390 CONTINUE
23006
23007 ELSEIF(ISUB.EQ.36) THEN
23008C...f + gamma -> f' + W+/-
23009 FWQ=COMFAC*AEM**2/(2D0*XW)*
23010 & (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH)
23011C...Propagators: as simulated in PYOFSH and as desired
23012 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
23013 CALL PYWIDT(24,SQM4,WDTP,WDTE)
23014 GMMWC=SQRT(SQM4)*WDTP(0)
23015 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
23016 FWQ=FWQ*HBW4C/HBW4
23017 DO 410 I=MMINA,MMAXA
23018 IF(I.EQ.0) GOTO 410
23019 IA=IABS(I)
23020 EIA=ABS(KCHG(IABS(I),1)/3D0)
23021 FACWQ=FWQ*(EIA-SH/(SH+UH))**2
23022 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
23023 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
23024 DO 400 ISDE=1,2
23025 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 400
23026 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 400
23027 NCHN=NCHN+1
23028 ISIG(NCHN,ISDE)=I
23029 ISIG(NCHN,3-ISDE)=22
23030 ISIG(NCHN,3)=1
23031 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
23032 400 CONTINUE
23033 410 CONTINUE
23034 ENDIF
23035
23036 ELSEIF(ISUB.LE.100) THEN
23037 IF(ISUB.EQ.69) THEN
23038C...gamma + gamma -> W+ + W-
23039 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
23040 FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
23041 FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+
23042 & FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1)
23043 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 420
23044 NCHN=NCHN+1
23045 ISIG(NCHN,1)=22
23046 ISIG(NCHN,2)=22
23047 ISIG(NCHN,3)=1
23048 SIGH(NCHN)=FACWW
23049 420 CONTINUE
23050
23051 ELSEIF(ISUB.EQ.70) THEN
23052C...gamma + W+/- -> Z0 + W+/-
23053 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
23054 FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH))
23055 FACZW=COMFAC*6D0*AEM**2*(XW1/XW)*
23056 & (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+
23057 & FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2)
23058 DO 440 KCHW=1,-1,-2
23059 DO 430 ISDE=1,2
23060 IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 430
23061 NCHN=NCHN+1
23062 ISIG(NCHN,ISDE)=22
23063 ISIG(NCHN,3-ISDE)=24*KCHW
23064 ISIG(NCHN,3)=1
23065 SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2)
23066 430 CONTINUE
23067 440 CONTINUE
23068 ENDIF
23069 ENDIF
23070
23071 RETURN
23072 END
23073
23074C*********************************************************************
23075
23076C...PYSGHG
23077C...Subprocess cross sections for Higgs processes,
23078C...except Higgs pairs in PYSGSU, but including WW scattering.
23079C...Auxiliary to PYSIGH.
23080
23081 SUBROUTINE PYSGHG(NCHN,SIGS)
23082
23083C...Double precision and integer declarations
23084 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23085 IMPLICIT INTEGER(I-N)
23086 INTEGER PYK,PYCHGE,PYCOMP
23087C...Parameter statement to help give large particle numbers.
23088 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
23089 &KEXCIT=4000000,KDIMEN=5000000)
23090C...Commonblocks
23091 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23092 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23093 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23094 COMMON/PYINT1/MINT(400),VINT(400)
23095 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
23096 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
23097 COMMON/PYINT4/MWID(500),WIDS(500,5)
23098 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
23099 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
23100 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
23101 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
23102 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
23103 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
23104 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
23105 &/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/
23106C...Local arrays and complex variables
23107 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
23108 COMPLEX*16 A004,A204,A114,A00U,A20U,A11U
23109 COMPLEX*16 CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF
23110
23111C...Convert H or A process into equivalent h one
23112 IHIGG=1
23113 KFHIGG=25
23114 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
23115 &ISUB.LE.190)) THEN
23116 IHIGG=2
23117 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
23118 KFHIGG=33+IHIGG
23119 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
23120 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
23121 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
23122 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
23123 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
23124 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
23125 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
23126 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
23127 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
23128 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
23129 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
23130 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
23131 ENDIF
23132 SQMH=PMAS(KFHIGG,1)**2
23133 GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2)
23134
23135C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
23136 IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ.
23137 &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN
23138C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
23139 IF(MSTP(46).LE.4) THEN
23140 HDTLH=LOG(PMAS(25,1)/PARP(44))
23141 HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0
23142 HDTNR=-1D0/18D0+HDTLH/6D0
23143 ELSE
23144 HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2)
23145 HDTLQ=LOG(PARP(45)/PARP(44))
23146 HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0
23147 HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0
23148 ENDIF
23149
23150C...Calculate lowest and next-to-lowest order partial wave amplitudes
23151 HDTV=1D0/(16D0*PARU(1)*PARP(47)**2)
23152 A00L=DBLE(HDTV*SH)
23153 A20L=-0.5D0*A00L
23154 A11L=A00L/6D0
23155 HDTLS=LOG(SH/PARP(44)**2)
23156 A004=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
23157 & CMPLX(DBLE((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0-
23158 & (50D0/9D0)*HDTLS),DBLE(4D0*PARU(1)))
23159 A204=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
23160 & CMPLX(DBLE(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0-
23161 & (20D0/9D0)*HDTLS),DBLE(PARU(1)))
23162 A114=DBLE((HDTV*SH)**2/(6D0*PARU(1)))*
23163 & CMPLX(DBLE(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),DBLE(PARU(1)/6D0))
23164
23165C...Unitarize partial wave amplitudes with Pade or K-matrix method
23166 IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN
23167 A00U=A00L/(1D0-A004/A00L)
23168 A20U=A20L/(1D0-A204/A20L)
23169 A11U=A11L/(1D0-A114/A11L)
23170 ELSE
23171 A00U=(A00L+DBLE(A004))/(1D0-DCMPLX(0.D0,A00L+DBLE(A004)))
23172 A20U=(A20L+DBLE(A204))/(1D0-DCMPLX(0.D0,A20L+DBLE(A204)))
23173 A11U=(A11L+DBLE(A114))/(1D0-DCMPLX(0.D0,A11L+DBLE(A114)))
23174 ENDIF
23175 ENDIF
23176
23177C...Differential cross section expressions.
23178
23179 IF(ISUB.LE.60) THEN
23180 IF(ISUB.EQ.3) THEN
23181C...f + fbar -> h0 (or H0, or A0)
23182 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
23183 HS=SHR*WDTP(0)
23184 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
23185 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
23186 & FACBW=0D0
23187 HP=AEM/(8D0*XW)*SH/SQMW*SH
23188 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
23189 DO 100 I=MMINA,MMAXA
23190 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
23191 IA=IABS(I)
23192 RMQ=PYMRUN(IA,SH)**2/SH
23193 HI=HP*RMQ
23194 IF(IA.LE.10) HI=HP*RMQ*FACA/3D0
23195 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
23196 IKFI=1
23197 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
23198 IF(IA.GT.10) IKFI=3
23199 HI=HI*PARU(150+10*IHIGG+IKFI)**2
23200 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
23201 HI=HI/(1D0+RMSS(41))**2
23202 IF(IHIGG.NE.3) THEN
23203 HI=HI*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
23204 & PARU(151+10*IHIGG))**2
23205 ENDIF
23206 ENDIF
23207 ENDIF
23208 NCHN=NCHN+1
23209 ISIG(NCHN,1)=I
23210 ISIG(NCHN,2)=-I
23211 ISIG(NCHN,3)=1
23212 SIGH(NCHN)=HI*FACBW*HF
23213 100 CONTINUE
23214
23215 ELSEIF(ISUB.EQ.5) THEN
23216C...Z0 + Z0 -> h0
23217 CALL PYWIDT(25,SH,WDTP,WDTE)
23218 HS=SHR*WDTP(0)
23219 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
23220 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
23221 HP=AEM/(8D0*XW)*SH/SQMW*SH
23222 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
23223 HI=HP/4D0
23224 FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2
23225 DO 120 I=MMIN1,MMAX1
23226 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
23227 DO 110 J=MMIN2,MMAX2
23228 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
23229 EI=KCHG(IABS(I),1)/3D0
23230 AI=SIGN(1D0,EI)
23231 VI=AI-4D0*EI*XWV
23232 EJ=KCHG(IABS(J),1)/3D0
23233 AJ=SIGN(1D0,EJ)
23234 VJ=AJ-4D0*EJ*XWV
23235 NCHN=NCHN+1
23236 ISIG(NCHN,1)=I
23237 ISIG(NCHN,2)=J
23238 ISIG(NCHN,3)=1
23239 SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF
23240 110 CONTINUE
23241 120 CONTINUE
23242
23243 ELSEIF(ISUB.EQ.8) THEN
23244C...W+ + W- -> h0
23245 CALL PYWIDT(25,SH,WDTP,WDTE)
23246 HS=SHR*WDTP(0)
23247 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
23248 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
23249 HP=AEM/(8D0*XW)*SH/SQMW*SH
23250 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
23251 HI=HP/2D0
23252 FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2
23253 DO 140 I=MMIN1,MMAX1
23254 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
23255 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
23256 DO 130 J=MMIN2,MMAX2
23257 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
23258 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
23259 IF(EI*EJ.GT.0D0) GOTO 130
23260 NCHN=NCHN+1
23261 ISIG(NCHN,1)=I
23262 ISIG(NCHN,2)=J
23263 ISIG(NCHN,3)=1
23264 SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF
23265 130 CONTINUE
23266 140 CONTINUE
23267
23268 ELSEIF(ISUB.EQ.24) THEN
23269C...f + fbar -> Z0 + h0 (or H0, or A0)
23270C...Propagators: Z0, h0 as simulated in PYOFSH and as desired
23271 HBW3=GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
23272 CALL PYWIDT(23,SQM3,WDTP,WDTE)
23273 GMMZ3=SQRT(SQM3)*WDTP(0)
23274 HBW3C=GMMZ3/((SQM3-SQMZ)**2+GMMZ3**2)
23275 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
23276 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
23277 GMMH4=SQRT(SQM4)*WDTP(0)
23278 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
23279 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
23280 FACHZ=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*8D0*(AEM*XWC)**2*
23281 & (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2)
23282 FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2)
23283 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
23284 & PARU(154+10*IHIGG)**2
23285 DO 150 I=MMINA,MMAXA
23286 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
23287 EI=KCHG(IABS(I),1)/3D0
23288 AI=SIGN(1D0,EI)
23289 VI=AI-4D0*EI*XWV
23290 FCOI=1D0
23291 IF(IABS(I).LE.10) FCOI=FACA/3D0
23292 NCHN=NCHN+1
23293 ISIG(NCHN,1)=I
23294 ISIG(NCHN,2)=-I
23295 ISIG(NCHN,3)=1
23296 SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2)
23297 150 CONTINUE
23298
23299 ELSEIF(ISUB.EQ.26) THEN
23300C...f + fbar' -> W+/- + h0 (or H0, or A0)
23301C...Propagators: W+-, h0 as simulated in PYOFSH and as desired
23302 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
23303 CALL PYWIDT(24,SQM3,WDTP,WDTE)
23304 GMMW3=SQRT(SQM3)*WDTP(0)
23305 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
23306 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
23307 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
23308 GMMH4=SQRT(SQM4)*WDTP(0)
23309 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
23310 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
23311 FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/
23312 & ((SH-SQMW)**2+GMMW**2)*(HBW3C/HBW3)*(HBW4C/HBW4)
23313 FACHW=FACHW*WIDS(KFHIGG,2)
23314 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
23315 & PARU(155+10*IHIGG)**2
23316 DO 170 I=MMIN1,MMAX1
23317 IA=IABS(I)
23318 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 170
23319 DO 160 J=MMIN2,MMAX2
23320 JA=IABS(J)
23321 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 160
23322 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 160
23323 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
23324 & GOTO 160
23325 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
23326 FCKM=1D0
23327 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
23328 FCOI=1D0
23329 IF(IA.LE.10) FCOI=FACA/3D0
23330 NCHN=NCHN+1
23331 ISIG(NCHN,1)=I
23332 ISIG(NCHN,2)=J
23333 ISIG(NCHN,3)=1
23334 SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2)
23335 160 CONTINUE
23336 170 CONTINUE
23337
23338 ELSEIF(ISUB.EQ.32) THEN
23339C...f + g -> f + h0 (q + g -> q + h0 only)
23340 SQMHC=PMAS(25,1)**2
23341 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24D0
23342 DO 190 I=MMINA,MMAXA
23343 IA=IABS(I)
23344 IF(IA.NE.5) GOTO 190
23345 SQML=PMAS(IA,1)**2
23346 IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) SQML=SQML*
23347 & (LOG(MAX(4D0,PARP(37)**2*SQML/PARU(117)**2))/
23348 & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
23349 IUA=IA+MOD(IA,2)
23350 SQMQ=SQML
23351 FACHCQ=FHCQ*SQML/SQMW*
23352 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH+
23353 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
23354 & (SQMHC-SQMQ-SH)/SH)
23355 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
23356 DO 180 ISDE=1,2
23357 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
23358 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,1).EQ.0) GOTO 180
23359 NCHN=NCHN+1
23360 ISIG(NCHN,ISDE)=I
23361 ISIG(NCHN,3-ISDE)=21
23362 ISIG(NCHN,3)=1
23363 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
23364 180 CONTINUE
23365 190 CONTINUE
23366 ENDIF
23367
23368 ELSEIF(ISUB.LE.80) THEN
23369 IF(ISUB.EQ.71) THEN
23370C...Z0 + Z0 -> Z0 + Z0
23371 IF(SH.LE.4.01D0*SQMZ) GOTO 220
23372
23373 IF(MSTP(46).LE.2) THEN
23374C...Exact scattering ME:s for on-mass-shell gauge bosons
23375 BE2=1D0-4D0*SQMZ/SH
23376 TH=-0.5D0*SH*BE2*(1D0-CTH)
23377 UH=-0.5D0*SH*BE2*(1D0+CTH)
23378 IF(MAX(TH,UH).GT.-1D0) GOTO 220
23379 SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2
23380 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
23381 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
23382 THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2
23383 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
23384 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
23385 UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2
23386 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
23387 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
23388 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
23389 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
23390 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
23391 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+
23392 & (ASHIM+ATHIM+AUHIM)**2)
23393 IF(MSTP(46).EQ.2) FACZZ=0D0
23394
23395 ELSE
23396C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
23397 FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
23398 & ABS(A00U+2D0*A20U)**2
23399 ENDIF
23400 FACZZ=FACZZ*WIDS(23,1)
23401
23402 DO 210 I=MMIN1,MMAX1
23403 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 210
23404 EI=KCHG(IABS(I),1)/3D0
23405 AI=SIGN(1D0,EI)
23406 VI=AI-4D0*EI*XWV
23407 AVI=AI**2+VI**2
23408 DO 200 J=MMIN2,MMAX2
23409 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 200
23410 EJ=KCHG(IABS(J),1)/3D0
23411 AJ=SIGN(1D0,EJ)
23412 VJ=AJ-4D0*EJ*XWV
23413 AVJ=AJ**2+VJ**2
23414 NCHN=NCHN+1
23415 ISIG(NCHN,1)=I
23416 ISIG(NCHN,2)=J
23417 ISIG(NCHN,3)=1
23418 SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ
23419 200 CONTINUE
23420 210 CONTINUE
23421 220 CONTINUE
23422
23423 ELSEIF(ISUB.EQ.72) THEN
23424C...Z0 + Z0 -> W+ + W-
23425 IF(SH.LE.4.01D0*SQMZ) GOTO 250
23426
23427 IF(MSTP(46).LE.2) THEN
23428C...Exact scattering ME:s for on-mass-shell gauge bosons
23429 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
23430 CTH2=CTH**2
23431 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
23432 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
23433 IF(MAX(TH,UH).GT.-1D0) GOTO 250
23434 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
23435 & (1D0-2D0*SQMZ/SH)
23436 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
23437 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
23438 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
23439 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
23440 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
23441 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
23442 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
23443 ATWIM=0D0
23444 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
23445 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
23446 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
23447 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
23448 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
23449 AUWIM=0D0
23450 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
23451 A4IM=0D0
23452 FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
23453 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
23454 IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2)
23455 IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+
23456 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
23457 IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+
23458 & (ATWIM+AUWIM+A4IM)**2)
23459
23460 ELSE
23461C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
23462 FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
23463 & ABS(A00U-A20U)**2
23464 ENDIF
23465 FACWW=FACWW*WIDS(24,1)
23466
23467 DO 240 I=MMIN1,MMAX1
23468 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 240
23469 EI=KCHG(IABS(I),1)/3D0
23470 AI=SIGN(1D0,EI)
23471 VI=AI-4D0*EI*XWV
23472 AVI=AI**2+VI**2
23473 DO 230 J=MMIN2,MMAX2
23474 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 230
23475 EJ=KCHG(IABS(J),1)/3D0
23476 AJ=SIGN(1D0,EJ)
23477 VJ=AJ-4D0*EJ*XWV
23478 AVJ=AJ**2+VJ**2
23479 NCHN=NCHN+1
23480 ISIG(NCHN,1)=I
23481 ISIG(NCHN,2)=J
23482 ISIG(NCHN,3)=1
23483 SIGH(NCHN)=FACWW*AVI*AVJ
23484 230 CONTINUE
23485 240 CONTINUE
23486 250 CONTINUE
23487
23488 ELSEIF(ISUB.EQ.73) THEN
23489C...Z0 + W+/- -> Z0 + W+/-
23490 IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 280
23491
23492 IF(MSTP(46).LE.2) THEN
23493C...Exact scattering ME:s for on-mass-shell gauge bosons
23494 BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
23495 EP1=1D0-(SQMZ-SQMW)/SH
23496 EP2=1D0+(SQMZ-SQMW)/SH
23497 TH=-0.5D0*SH*BE2*(1D0-CTH)
23498 UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH)
23499 IF(MAX(TH,UH).GT.-1D0) GOTO 280
23500 THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH)
23501 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
23502 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
23503 ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
23504 & 1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+
23505 & 2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
23506 & 1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
23507 ASWIM=0D0
23508 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
23509 & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
23510 & (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)-
23511 & BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0*
23512 & (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+
23513 & 1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
23514 & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
23515 & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
23516 & (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*
23517 & (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2*
23518 & ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW*
23519 & (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
23520 AUWIM=0D0
23521 A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)-
23522 & 2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2)
23523 A4IM=0D0
23524 FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4*
23525 & (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2
23526 IF(MSTP(46).LE.0) FACZW=0D0
23527 IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+
23528 & (ATHIM+ASWIM+AUWIM+A4IM)**2)
23529 IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+
23530 & (ASWIM+AUWIM+A4IM)**2)
23531
23532 ELSE
23533C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
23534 FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0*
23535 & ABS(A20U+3D0*A11U*DBLE(CTH))**2
23536 ENDIF
23537 FACZW=FACZW*WIDS(23,2)
23538
23539 DO 270 I=MMIN1,MMAX1
23540 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 270
23541 EI=KCHG(IABS(I),1)/3D0
23542 AI=SIGN(1D0,EI)
23543 VI=AI-4D0*EI*XWV
23544 AVI=AI**2+VI**2
23545 KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I))
23546 DO 260 J=MMIN2,MMAX2
23547 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 260
23548 EJ=KCHG(IABS(J),1)/3D0
23549 AJ=SIGN(1D0,EJ)
23550 VJ=AI-4D0*EJ*XWV
23551 AVJ=AJ**2+VJ**2
23552 KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J))
23553 NCHN=NCHN+1
23554 ISIG(NCHN,1)=I
23555 ISIG(NCHN,2)=J
23556 ISIG(NCHN,3)=1
23557 SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2)
23558 NCHN=NCHN+1
23559 ISIG(NCHN,1)=I
23560 ISIG(NCHN,2)=J
23561 ISIG(NCHN,3)=2
23562 SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ
23563 260 CONTINUE
23564 270 CONTINUE
23565 280 CONTINUE
23566
23567 ELSEIF(ISUB.EQ.75) THEN
23568C...W+ + W- -> gamma + gamma
23569
23570 ELSEIF(ISUB.EQ.76) THEN
23571C...W+ + W- -> Z0 + Z0
23572 IF(SH.LE.4.01D0*SQMZ) GOTO 310
23573
23574 IF(MSTP(46).LE.2) THEN
23575C...Exact scattering ME:s for on-mass-shell gauge bosons
23576 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
23577 CTH2=CTH**2
23578 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
23579 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
23580 IF(MAX(TH,UH).GT.-1D0) GOTO 310
23581 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
23582 & (1D0-2D0*SQMZ/SH)
23583 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
23584 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
23585 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
23586 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
23587 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
23588 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
23589 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
23590 ATWIM=0D0
23591 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
23592 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
23593 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
23594 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
23595 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
23596 AUWIM=0D0
23597 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
23598 A4IM=0D0
23599 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
23600 & (SH/SQMW)**2*SH2
23601 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
23602 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+
23603 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
23604 IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+
23605 & (ATWIM+AUWIM+A4IM)**2)
23606
23607 ELSE
23608C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
23609 FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
23610 & ABS(A00U-A20U)**2
23611 ENDIF
23612 FACZZ=FACZZ*WIDS(23,1)
23613
23614 DO 300 I=MMIN1,MMAX1
23615 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 300
23616 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
23617 DO 290 J=MMIN2,MMAX2
23618 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 290
23619 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
23620 IF(EI*EJ.GT.0D0) GOTO 290
23621 NCHN=NCHN+1
23622 ISIG(NCHN,1)=I
23623 ISIG(NCHN,2)=J
23624 ISIG(NCHN,3)=1
23625 SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J)
23626 290 CONTINUE
23627 300 CONTINUE
23628 310 CONTINUE
23629
23630 ELSEIF(ISUB.EQ.77) THEN
23631C...W+/- + W+/- -> W+/- + W+/-
23632 IF(SH.LE.4.01D0*SQMW) GOTO 340
23633
23634 IF(MSTP(46).LE.2) THEN
23635C...Exact scattering ME:s for on-mass-shell gauge bosons
23636 BE2=1D0-4D0*SQMW/SH
23637 BE4=BE2**2
23638 CTH2=CTH**2
23639 CTH3=CTH**3
23640 TH=-0.5D0*SH*BE2*(1D0-CTH)
23641 UH=-0.5D0*SH*BE2*(1D0+CTH)
23642 IF(MAX(TH,UH).GT.-1D0) GOTO 340
23643 SHANG=(1D0+BE2)**2
23644 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
23645 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
23646 THANG=(BE2-CTH)**2
23647 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
23648 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
23649 UHANG=(BE2+CTH)**2
23650 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
23651 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
23652 SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH
23653 ASGRE=XW*SGZANG
23654 ASGIM=0D0
23655 ASZRE=XW1*SH/(SH-SQMZ)*SGZANG
23656 ASZIM=0D0
23657 TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+
23658 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3)
23659 ATGRE=0.5D0*XW*SH/TH*TGZANG
23660 ATGIM=0D0
23661 ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG
23662 ATZIM=0D0
23663 UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+
23664 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3)
23665 AUGRE=0.5D0*XW*SH/UH*UGZANG
23666 AUGIM=0D0
23667 AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG
23668 AUZIM=0D0
23669 A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2)
23670 A4AIM=0D0
23671 A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2)
23672 A4SIM=0D0
23673 FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
23674 & (SH/SQMW)**2*SH2
23675 IF(MSTP(46).LE.0) THEN
23676 AWWARE=ASHRE
23677 AWWAIM=ASHIM
23678 AWWSRE=0D0
23679 AWWSIM=0D0
23680 ELSEIF(MSTP(46).EQ.1) THEN
23681 AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
23682 AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
23683 AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
23684 AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
23685 ELSE
23686 AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
23687 AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
23688 AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
23689 AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
23690 ENDIF
23691 AWWA2=AWWARE**2+AWWAIM**2
23692 AWWS2=AWWSRE**2+AWWSIM**2
23693
23694 ELSE
23695C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
23696 FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
23697 & ABS(A00U+0.5D0*A20U+4.5D0*A11U*DBLE(CTH))**2
23698 FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2
23699 ENDIF
23700
23701 DO 330 I=MMIN1,MMAX1
23702 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 330
23703 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
23704 DO 320 J=MMIN2,MMAX2
23705 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 320
23706 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
23707 IF(EI*EJ.LT.0D0) THEN
23708C...W+W-
23709 IF(MSTP(45).EQ.1) GOTO 320
23710 IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1)
23711 IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1)
23712 ELSE
23713C...W+W+/W-W-
23714 IF(MSTP(45).EQ.2) GOTO 320
23715 IF(MSTP(46).LE.2) FACWW=FWW*AWWS2
23716 IF(MSTP(46).GE.3) FACWW=FWWS
23717 IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4)
23718 IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5)
23719 ENDIF
23720 NCHN=NCHN+1
23721 ISIG(NCHN,1)=I
23722 ISIG(NCHN,2)=J
23723 ISIG(NCHN,3)=1
23724 SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J)
23725 IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN)
23726 320 CONTINUE
23727 330 CONTINUE
23728 340 CONTINUE
23729 ENDIF
23730
23731 ELSEIF(ISUB.LE.120) THEN
23732 IF(ISUB.EQ.102) THEN
23733C...g + g -> h0 (or H0, or A0)
23734 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
23735 HS=SHR*WDTP(0)
23736 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
23737 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
23738 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
23739 & FACBW=0D0
23740 HI=SHR*WDTP(13)/32D0
23741 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 350
23742 NCHN=NCHN+1
23743 ISIG(NCHN,1)=21
23744 ISIG(NCHN,2)=21
23745 ISIG(NCHN,3)=1
23746 SIGH(NCHN)=HI*FACBW*HF
23747 350 CONTINUE
23748
23749 ELSEIF(ISUB.EQ.103) THEN
23750C...gamma + gamma -> h0 (or H0, or A0)
23751 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
23752 HS=SHR*WDTP(0)
23753 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
23754 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
23755 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
23756 & FACBW=0D0
23757 HI=SHR*WDTP(14)*2D0
23758 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 360
23759 NCHN=NCHN+1
23760 ISIG(NCHN,1)=22
23761 ISIG(NCHN,2)=22
23762 ISIG(NCHN,3)=1
23763 SIGH(NCHN)=HI*FACBW*HF
23764 360 CONTINUE
23765
23766 ELSEIF(ISUB.EQ.110) THEN
23767C...f + fbar -> gamma + h0
23768 THUH=MAX(TH*UH,SH*CKIN(3)**2)
23769 FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH
23770 FACHG=FACHG*WIDS(KFHIGG,2)
23771C...Calculate loop contributions for intermediate gamma* and Z0
23772 CIGTOT=DCMPLX(0D0,0D0)
23773 CIZTOT=DCMPLX(0D0,0D0)
23774 JMAX=3*MSTP(1)+1
23775 DO 370 J=1,JMAX
23776 IF(J.LE.2*MSTP(1)) THEN
23777 FNC=1D0
23778 EJ=KCHG(J,1)/3D0
23779 AJ=SIGN(1D0,EJ+0.1D0)
23780 VJ=AJ-4D0*EJ*XWV
23781 BALP=SQM4/(2D0*PMAS(J,1))**2
23782 BBET=SH/(2D0*PMAS(J,1))**2
23783 ELSEIF(J.LE.3*MSTP(1)) THEN
23784 FNC=3D0
23785 JL=2*(J-2*MSTP(1))-1
23786 EJ=KCHG(10+JL,1)/3D0
23787 AJ=SIGN(1D0,EJ+0.1D0)
23788 VJ=AJ-4D0*EJ*XWV
23789 BALP=SQM4/(2D0*PMAS(10+JL,1))**2
23790 BBET=SH/(2D0*PMAS(10+JL,1))**2
23791 ELSE
23792 BALP=SQM4/(2D0*PMAS(24,1))**2
23793 BBET=SH/(2D0*PMAS(24,1))**2
23794 ENDIF
23795 BABI=1D0/(BALP-BBET)
23796 IF(BALP.LT.1D0) THEN
23797 F0ALP=DCMPLX(DBLE(ASIN(SQRT(BALP))),0D0)
23798 F1ALP=F0ALP**2
23799 ELSE
23800 F0ALP=DCMPLX(DBLE(LOG(SQRT(BALP)+SQRT(BALP-1D0))),
23801 & -DBLE(0.5D0*PARU(1)))
23802 F1ALP=-F0ALP**2
23803 ENDIF
23804 F2ALP=DBLE(SQRT(ABS(BALP-1D0)/BALP))*F0ALP
23805 IF(BBET.LT.1D0) THEN
23806 F0BET=DCMPLX(DBLE(ASIN(SQRT(BBET))),0D0)
23807 F1BET=F0BET**2
23808 ELSE
23809 F0BET=DCMPLX(DBLE(LOG(SQRT(BBET)+SQRT(BBET-1D0))),
23810 & -DBLE(0.5D0*PARU(1)))
23811 F1BET=-F0BET**2
23812 ENDIF
23813 F2BET=DBLE(SQRT(ABS(BBET-1D0)/BBET))*F0BET
23814 IF(J.LE.3*MSTP(1)) THEN
23815 FIF=DBLE(0.5D0*BABI)+DBLE(BABI**2)*(DBLE(0.5D0*(1D0-BALP+
23816 & BBET))*(F1BET-F1ALP)+DBLE(BBET)*(F2BET-F2ALP))
23817 CIGTOT=CIGTOT+DBLE(FNC*EJ**2)*FIF
23818 CIZTOT=CIZTOT+DBLE(FNC*EJ*VJ)*FIF
23819 ELSE
23820 TXW=XW/XW1
23821 CIGTOT=CIGTOT-0.5*(DBLE(BABI*(1.5D0+BALP))+DBLE(BABI**2)*
23822 & (DBLE(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+
23823 & DBLE(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP)))
23824 CIZTOT=CIZTOT-DBLE(0.5D0*BABI*XW1)*(DBLE(5D0-TXW+2D0*BALP*
23825 & (1D0-TXW))*(1D0+DBLE(2D0*BABI*BBET)*(F2BET-F2ALP))+
23826 & DBLE(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))*
23827 & (F1BET-F1ALP))
23828 ENDIF
23829 370 CONTINUE
23830 CIGTOT=CIGTOT/DBLE(SH)
23831 CIZTOT=CIZTOT*DBLE(XWC)/DCMPLX(DBLE(SH-SQMZ),DBLE(GMMZ))
23832C...Loop over initial flavours
23833 DO 380 I=MMINA,MMAXA
23834 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
23835 EI=KCHG(IABS(I),1)/3D0
23836 AI=SIGN(1D0,EI)
23837 VI=AI-4D0*EI*XWV
23838 FCOI=1D0
23839 IF(IABS(I).LE.10) FCOI=FACA/3D0
23840 NCHN=NCHN+1
23841 ISIG(NCHN,1)=I
23842 ISIG(NCHN,2)=-I
23843 ISIG(NCHN,3)=1
23844 SIGH(NCHN)=FACHG*FCOI*(ABS(DBLE(EI)*CIGTOT+DBLE(VI)*
23845 & CIZTOT)**2+AI**2*ABS(CIZTOT)**2)
23846 380 CONTINUE
23847
23848 ELSEIF(ISUB.EQ.111) THEN
23849C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
23850 IF(MSTP(38).NE.0) THEN
23851C...Simple case: only do gg <-> h exactly.
23852 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
23853 FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP(13)/SQRT(SQM4))*
23854 & (TH**2+UH**2)/(SH*SQM4)
23855C...Propagators: as simulated in PYOFSH and as desired
23856 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
23857 GMMHC=SQRT(SQM4)*WDTP(0)
23858 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
23859 & ((SQM4-SQMH)**2+GMMHC**2)
23860 FACGH=FACGH*HBW4C/HBW4
23861 ELSE
23862C...Messy case: do full loop integrals
23863 A5STUR=0D0
23864 A5STUI=0D0
23865 DO 390 I=1,2*MSTP(1)
23866 SQMQ=PMAS(I,1)**2
23867 EPSS=4D0*SQMQ/SH
23868 EPSH=4D0*SQMQ/SQMH
23869 CALL PYWAUX(1,EPSS,W1SR,W1SI)
23870 CALL PYWAUX(1,EPSH,W1HR,W1HI)
23871 CALL PYWAUX(2,EPSS,W2SR,W2SI)
23872 CALL PYWAUX(2,EPSH,W2HR,W2HI)
23873 A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+
23874 & (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR))
23875 A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+
23876 & (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI))
23877 390 CONTINUE
23878 FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
23879 & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
23880 FACGH=FACGH*WIDS(25,2)
23881 ENDIF
23882 DO 400 I=MMINA,MMAXA
23883 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
23884 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
23885 NCHN=NCHN+1
23886 ISIG(NCHN,1)=I
23887 ISIG(NCHN,2)=-I
23888 ISIG(NCHN,3)=1
23889 SIGH(NCHN)=FACGH
23890 400 CONTINUE
23891
23892 ELSEIF(ISUB.EQ.112) THEN
23893C...f + g -> f + h0 (q + g -> q + h0 only)
23894 IF(MSTP(38).NE.0) THEN
23895C...Simple case: only do gg <-> h exactly.
23896 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
23897 FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP(13)/SQRT(SQM4))*
23898 & (SH**2+UH**2)/(-TH*SQM4)
23899C...Propagators: as simulated in PYOFSH and as desired
23900 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
23901 GMMHC=SQRT(SQM4)*WDTP(0)
23902 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
23903 & ((SQM4-SQMH)**2+GMMHC**2)
23904 FACQH=FACQH*HBW4C/HBW4
23905 ELSE
23906C...Messy case: do full loop integrals
23907 A5TSUR=0D0
23908 A5TSUI=0D0
23909 DO 410 I=1,2*MSTP(1)
23910 SQMQ=PMAS(I,1)**2
23911 EPST=4D0*SQMQ/TH
23912 EPSH=4D0*SQMQ/SQMH
23913 CALL PYWAUX(1,EPST,W1TR,W1TI)
23914 CALL PYWAUX(1,EPSH,W1HR,W1HI)
23915 CALL PYWAUX(2,EPST,W2TR,W2TI)
23916 CALL PYWAUX(2,EPSH,W2HR,W2HI)
23917 A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+
23918 & (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR))
23919 A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+
23920 & (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI))
23921 410 CONTINUE
23922 FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
23923 & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
23924 FACQH=FACQH*WIDS(25,2)
23925 ENDIF
23926 DO 430 I=MMINA,MMAXA
23927 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
23928 DO 420 ISDE=1,2
23929 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 420
23930 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 420
23931 NCHN=NCHN+1
23932 ISIG(NCHN,ISDE)=I
23933 ISIG(NCHN,3-ISDE)=21
23934 ISIG(NCHN,3)=1
23935 SIGH(NCHN)=FACQH
23936 420 CONTINUE
23937 430 CONTINUE
23938
23939 ELSEIF(ISUB.EQ.113) THEN
23940C...g + g -> g + h0
23941 IF(MSTP(38).NE.0) THEN
23942C...Simple case: only do gg <-> h exactly.
23943 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
23944 FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP(13)/SQRT(SQM4))*
23945 & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
23946C...Propagators: as simulated in PYOFSH and as desired
23947 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
23948 GMMHC=SQRT(SQM4)*WDTP(0)
23949 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
23950 & ((SQM4-SQMH)**2+GMMHC**2)
23951 FACGH=FACGH*HBW4C/HBW4
23952 ELSE
23953C...Messy case: do full loop integrals
23954 A2STUR=0D0
23955 A2STUI=0D0
23956 A2USTR=0D0
23957 A2USTI=0D0
23958 A2TUSR=0D0
23959 A2TUSI=0D0
23960 A4STUR=0D0
23961 A4STUI=0D0
23962 DO 440 I=1,2*MSTP(1)
23963 SQMQ=PMAS(I,1)**2
23964 EPSS=4D0*SQMQ/SH
23965 EPST=4D0*SQMQ/TH
23966 EPSU=4D0*SQMQ/UH
23967 EPSH=4D0*SQMQ/SQMH
23968 IF(EPSH.LT.1D-6) GOTO 440
23969 CALL PYWAUX(1,EPSS,W1SR,W1SI)
23970 CALL PYWAUX(1,EPST,W1TR,W1TI)
23971 CALL PYWAUX(1,EPSU,W1UR,W1UI)
23972 CALL PYWAUX(1,EPSH,W1HR,W1HI)
23973 CALL PYWAUX(2,EPSS,W2SR,W2SI)
23974 CALL PYWAUX(2,EPST,W2TR,W2TI)
23975 CALL PYWAUX(2,EPSU,W2UR,W2UI)
23976 CALL PYWAUX(2,EPSH,W2HR,W2HI)
23977 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
23978 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
23979 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
23980 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
23981 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
23982 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
23983 CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI)
23984 CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI)
23985 CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI)
23986 CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI)
23987 CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI)
23988 CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI)
23989 W3STUR=YHSTUR-Y3STUR-Y3UTSR
23990 W3STUI=YHSTUI-Y3STUI-Y3UTSI
23991 W3SUTR=YHSUTR-Y3SUTR-Y3TUSR
23992 W3SUTI=YHSUTI-Y3SUTI-Y3TUSI
23993 W3TSUR=YHTSUR-Y3TSUR-Y3USTR
23994 W3TSUI=YHTSUI-Y3TSUI-Y3USTI
23995 W3TUSR=YHTUSR-Y3TUSR-Y3SUTR
23996 W3TUSI=YHTUSI-Y3TUSI-Y3SUTI
23997 W3USTR=YHUSTR-Y3USTR-Y3TSUR
23998 W3USTI=YHUSTI-Y3USTI-Y3TSUI
23999 W3UTSR=YHUTSR-Y3UTSR-Y3STUR
24000 W3UTSI=YHUTSI-Y3UTSI-Y3STUI
24001 B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH*
24002 & (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)*
24003 & (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/
24004 & (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH*
24005 & (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR)
24006 B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2*
24007 & (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+
24008 & W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))*
24009 & (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0*
24010 & (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI)
24011 B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH*
24012 & (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)*
24013 & (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/
24014 & (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH*
24015 & (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR)
24016 B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2*
24017 & (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+
24018 & W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))*
24019 & (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0*
24020 & (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI)
24021 B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH*
24022 & (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)*
24023 & (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/
24024 & (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH*
24025 & (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR)
24026 B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2*
24027 & (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+
24028 & W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))*
24029 & (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0*
24030 & (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI)
24031 B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH*
24032 & (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)*
24033 & (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/
24034 & (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH*
24035 & (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR)
24036 B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2*
24037 & (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+
24038 & W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))*
24039 & (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0*
24040 & (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI)
24041 B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH*
24042 & (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)*
24043 & (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/
24044 & (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH*
24045 & (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR)
24046 B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2*
24047 & (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+
24048 & W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))*
24049 & (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0*
24050 & (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI)
24051 B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH*
24052 & (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)*
24053 & (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/
24054 & (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH*
24055 & (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR)
24056 B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2*
24057 & (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+
24058 & W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))*
24059 & (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0*
24060 & (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI)
24061 B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
24062 & (W2SR-W2HR+W3STUR))
24063 B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI)
24064 B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
24065 & (W2TR-W2HR+W3TUSR))
24066 B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI)
24067 B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
24068 & (W2UR-W2HR+W3USTR))
24069 B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI)
24070 A2STUR=A2STUR+B2STUR+B2SUTR
24071 A2STUI=A2STUI+B2STUI+B2SUTI
24072 A2USTR=A2USTR+B2USTR+B2UTSR
24073 A2USTI=A2USTI+B2USTI+B2UTSI
24074 A2TUSR=A2TUSR+B2TUSR+B2TSUR
24075 A2TUSI=A2TUSI+B2TUSI+B2TSUI
24076 A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
24077 A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
24078 440 CONTINUE
24079 FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3*
24080 & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
24081 & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
24082 FACGH=FACGH*WIDS(25,2)
24083 ENDIF
24084 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 450
24085 NCHN=NCHN+1
24086 ISIG(NCHN,1)=21
24087 ISIG(NCHN,2)=21
24088 ISIG(NCHN,3)=1
24089 SIGH(NCHN)=FACGH
24090 450 CONTINUE
24091 ENDIF
24092
24093 ELSEIF(ISUB.LE.170) THEN
24094 IF(ISUB.EQ.121) THEN
24095C...g + g -> Q + Qbar + h0
24096 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 460
24097 IA=KFPR(ISUBSV,2)
24098 PMF=PYMRUN(IA,SH)
24099 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
24100 & (0.5D0*PMF/PMAS(24,1))**2
24101 WID2=1D0
24102 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
24103 FACQQH=FACQQH*WID2
24104 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24105 IKFI=1
24106 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
24107 IF(IA.GT.10) IKFI=3
24108 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
24109 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
24110 FACQQH=FACQQH/(1D0+RMSS(41))**2
24111 IF(IHIGG.NE.3) THEN
24112 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
24113 & PARU(151+10*IHIGG))**2
24114 ENDIF
24115 ENDIF
24116 ENDIF
24117 CALL PYQQBH(WTQQBH)
24118 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
24119 HS=SHR*WDTP(0)
24120 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24121 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
24122 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
24123 & FACBW=0D0
24124 NCHN=NCHN+1
24125 ISIG(NCHN,1)=21
24126 ISIG(NCHN,2)=21
24127 ISIG(NCHN,3)=1
24128 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
24129 460 CONTINUE
24130
24131 ELSEIF(ISUB.EQ.122) THEN
24132C...q + qbar -> Q + Qbar + h0
24133 IA=KFPR(ISUBSV,2)
24134 PMF=PYMRUN(IA,SH)
24135 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
24136 & (0.5D0*PMF/PMAS(24,1))**2
24137 WID2=1D0
24138 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
24139 FACQQH=FACQQH*WID2
24140 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24141 IKFI=1
24142 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
24143 IF(IA.GT.10) IKFI=3
24144 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
24145 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
24146 FACQQH=FACQQH/(1D0+RMSS(41))**2
24147 IF(IHIGG.NE.3) THEN
24148 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
24149 & PARU(151+10*IHIGG))**2
24150 ENDIF
24151 ENDIF
24152 ENDIF
24153 CALL PYQQBH(WTQQBH)
24154 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
24155 HS=SHR*WDTP(0)
24156 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24157 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
24158 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
24159 & FACBW=0D0
24160 DO 470 I=MMINA,MMAXA
24161 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
24162 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 470
24163 NCHN=NCHN+1
24164 ISIG(NCHN,1)=I
24165 ISIG(NCHN,2)=-I
24166 ISIG(NCHN,3)=1
24167 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
24168 470 CONTINUE
24169
24170 ELSEIF(ISUB.EQ.123) THEN
24171C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
24172C...inner process)
24173 FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0
24174 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
24175 & PARU(154+10*IHIGG)**2
24176 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
24177 & (VINT(216)-VINT(209)**2))**2
24178 FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
24179 FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218)
24180 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
24181 HS=SHR*WDTP(0)
24182 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24183 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
24184 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
24185 & FACBW=0D0
24186 DO 490 I=MMIN1,MMAX1
24187 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 490
24188 IA=IABS(I)
24189 DO 480 J=MMIN2,MMAX2
24190 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 480
24191 JA=IABS(J)
24192 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
24193 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
24194 VI=AI-4D0*EI*XWV
24195 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
24196 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
24197 VJ=AJ-4D0*EJ*XWV
24198 FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ
24199 FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ
24200 NCHN=NCHN+1
24201 ISIG(NCHN,1)=I
24202 ISIG(NCHN,2)=J
24203 ISIG(NCHN,3)=1
24204 SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW
24205 480 CONTINUE
24206 490 CONTINUE
24207
24208 ELSEIF(ISUB.EQ.124) THEN
24209C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
24210C...inner process)
24211 FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW
24212 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
24213 & PARU(155+10*IHIGG)**2
24214 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
24215 & (VINT(216)-VINT(209)**2))**2
24216 FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
24217 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
24218 HS=SHR*WDTP(0)
24219 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24220 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
24221 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
24222 & FACBW=0D0
24223 DO 510 I=MMIN1,MMAX1
24224 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 510
24225 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
24226 DO 500 J=MMIN2,MMAX2
24227 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 500
24228 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
24229 IF(EI*EJ.GT.0D0) GOTO 500
24230 FACLR=VINT(180+I)*VINT(180+J)
24231 NCHN=NCHN+1
24232 ISIG(NCHN,1)=I
24233 ISIG(NCHN,2)=J
24234 ISIG(NCHN,3)=1
24235 SIGH(NCHN)=FACLR*FACWW*FACBW
24236 500 CONTINUE
24237 510 CONTINUE
24238
24239 ELSEIF(ISUB.EQ.143) THEN
24240C...f + fbar' -> H+/-
24241 SQMHC=PMAS(37,1)**2
24242 CALL PYWIDT(37,SH,WDTP,WDTE)
24243 HS=SHR*WDTP(0)
24244 FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2)
24245 HP=AEM/(8D0*XW)*SH/SQMW*SH
24246 DO 530 I=MMIN1,MMAX1
24247 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 530
24248 IA=IABS(I)
24249 IM=(MOD(IA,10)+1)/2
24250 DO 520 J=MMIN2,MMAX2
24251 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 520
24252 JA=IABS(J)
24253 JM=(MOD(JA,10)+1)/2
24254 IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 520
24255 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
24256 & GOTO 520
24257 IF(MOD(IA,2).EQ.0) THEN
24258 IU=IA
24259 IL=JA
24260 ELSE
24261 IU=JA
24262 IL=IA
24263 ENDIF
24264 RML=PYMRUN(IL,SH)**2/SH
24265 RMU=PYMRUN(IU,SH)**2/SH
24266 HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2)
24267 IF(IA.LE.10) HI=HI*FACA/3D0
24268 KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
24269 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
24270 NCHN=NCHN+1
24271 ISIG(NCHN,1)=I
24272 ISIG(NCHN,2)=J
24273 ISIG(NCHN,3)=1
24274 SIGH(NCHN)=HI*FACBW*HF
24275 520 CONTINUE
24276 530 CONTINUE
24277
24278 ELSEIF(ISUB.EQ.161) THEN
24279C...f + g -> f' + H+/- (b + g -> t + H+/- only)
24280C...(choice of only b and t to avoid kinematics problems)
24281 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24
24282C...H propagator: as simulated in PYOFSH and as desired
24283 SQMHC=PMAS(37,1)**2
24284 GMMHC=PMAS(37,1)*PMAS(37,2)
24285 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
24286 CALL PYWIDT(37,SQM4,WDTP,WDTE)
24287 GMMHCC=SQRT(SQM4)*WDTP(0)
24288 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
24289 FHCQ=FHCQ*HBW4C/HBW4
24290 DO 550 I=MMINA,MMAXA
24291 IA=IABS(I)
24292 IF(IA.NE.5) GOTO 550
24293 SQML=PYMRUN(IA,SH)**2
24294 IUA=IA+MOD(IA,2)
24295 SQMQ=PYMRUN(IUA,SH)**2
24296 FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW*
24297 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH+
24298 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
24299 & (SQMHC-SQMQ-SH)/SH)
24300 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
24301 DO 540 ISDE=1,2
24302 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 540
24303 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,1).EQ.0) GOTO 540
24304 NCHN=NCHN+1
24305 ISIG(NCHN,ISDE)=I
24306 ISIG(NCHN,3-ISDE)=21
24307 ISIG(NCHN,3)=1
24308 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
24309 540 CONTINUE
24310 550 CONTINUE
24311 ENDIF
24312 ENDIF
24313
24314 RETURN
24315 END
24316
24317C*********************************************************************
24318
24319C...PYSGSU
24320C...Subprocess cross sections for SUSY processes,
24321C...including Higgs pair production.
24322C...Auxiliary to PYSIGH.
24323
24324 SUBROUTINE PYSGSU(NCHN,SIGS)
24325
24326C...Double precision and integer declarations
24327 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24328 IMPLICIT INTEGER(I-N)
24329 INTEGER PYK,PYCHGE,PYCOMP
24330C...Parameter statement to help give large particle numbers.
24331 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
24332 &KEXCIT=4000000,KDIMEN=5000000)
24333C...Commonblocks
24334 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24335 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
24336 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24337 COMMON/PYINT1/MINT(400),VINT(400)
24338 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
24339 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
24340 COMMON/PYINT4/MWID(500),WIDS(500,5)
24341 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
24342 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
24343 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
24344 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
24345 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
24346 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
24347 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
24348 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
24349 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYSGCM/
24350C...Local arrays and complex variables
24351 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
24352 COMPLEX*16 OLPP,ORPP,OLP,ORP,OL,OR,QLL,QLR
24353 COMPLEX*16 QRR,QRL,GLIJ,GRIJ,PROPW,PROPZ
24354 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
24355
24356CMRENNA++
24357C...Z and W width, combinations of weak mixing angle
24358 ZWID=PMAS(23,2)
24359 WWID=PMAS(24,2)
24360 TANW=SQRT(XW/XW1)
24361 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
24362
24363C...Convert almost equivalent SUSY processes into each other
24364C...Extract differences in flavours and couplings
24365
24366C...Sleptons and sneutrinos
24367 IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN
24368 KFID=MOD(KFPR(ISUB,1),KSUSY1)
24369 ISUB=201
24370 ILR=0
24371 ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN
24372 KFID=MOD(KFPR(ISUB,1),KSUSY1)
24373 ISUB=201
24374 ILR=1
24375 ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN
24376 KFID=MOD(KFPR(ISUB,1),KSUSY1)
24377 ISUB=203
24378 ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN
24379 IF(ISUB.EQ.210) THEN
24380 RKF=2.0D0
24381 ELSEIF(ISUB.EQ.211) THEN
24382 RKF=SFMIX(15,1)**2
24383 ELSEIF(ISUB.EQ.212) THEN
24384 RKF=SFMIX(15,2)**2
24385 ENDIF
24386 ISUB=210
24387 ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN
24388 IF(ISUB.EQ.213) THEN
24389 KFID=MOD(KFPR(ISUB,1),KSUSY1)
24390 RKF=2.0D0
24391 ELSEIF(ISUB.EQ.214) THEN
24392 KFID=16
24393 RKF=1.0D0
24394 ENDIF
24395 ISUB=213
24396
24397C...Neutralinos
24398 ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN
24399 IF(ISUB.EQ.216) THEN
24400 IZID1=1
24401 IZID2=1
24402 ELSEIF(ISUB.EQ.217) THEN
24403 IZID1=2
24404 IZID2=2
24405 ELSEIF(ISUB.EQ.218) THEN
24406 IZID1=3
24407 IZID2=3
24408 ELSEIF(ISUB.EQ.219) THEN
24409 IZID1=4
24410 IZID2=4
24411 ELSEIF(ISUB.EQ.220) THEN
24412 IZID1=1
24413 IZID2=2
24414 ELSEIF(ISUB.EQ.221) THEN
24415 IZID1=1
24416 IZID2=3
24417 ELSEIF(ISUB.EQ.222) THEN
24418 IZID1=1
24419 IZID2=4
24420 ELSEIF(ISUB.EQ.223) THEN
24421 IZID1=2
24422 IZID2=3
24423 ELSEIF(ISUB.EQ.224) THEN
24424 IZID1=2
24425 IZID2=4
24426 ELSEIF(ISUB.EQ.225) THEN
24427 IZID1=3
24428 IZID2=4
24429 ENDIF
24430 ISUB=216
24431
24432C...Charginos
24433 ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN
24434 IF(ISUB.EQ.226) THEN
24435 IZID1=1
24436 IZID2=1
24437 ELSEIF(ISUB.EQ.227) THEN
24438 IZID1=2
24439 IZID2=2
24440 ELSEIF(ISUB.EQ.228) THEN
24441 IZID1=1
24442 IZID2=2
24443 ENDIF
24444 ISUB=226
24445
24446C...Neutralino + chargino
24447 ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN
24448 IF(ISUB.EQ.229) THEN
24449 IZID1=1
24450 IZID2=1
24451 ELSEIF(ISUB.EQ.230) THEN
24452 IZID1=1
24453 IZID2=2
24454 ELSEIF(ISUB.EQ.231) THEN
24455 IZID1=1
24456 IZID2=3
24457 ELSEIF(ISUB.EQ.232) THEN
24458 IZID1=1
24459 IZID2=4
24460 ELSEIF(ISUB.EQ.233) THEN
24461 IZID1=2
24462 IZID2=1
24463 ELSEIF(ISUB.EQ.234) THEN
24464 IZID1=2
24465 IZID2=2
24466 ELSEIF(ISUB.EQ.235) THEN
24467 IZID1=2
24468 IZID2=3
24469 ELSEIF(ISUB.EQ.236) THEN
24470 IZID1=2
24471 IZID2=4
24472 ENDIF
24473 ISUB=229
24474
24475C...Gluino + neutralino
24476 ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN
24477 IF(ISUB.EQ.237) THEN
24478 IZID=1
24479 ELSEIF(ISUB.EQ.238) THEN
24480 IZID=2
24481 ELSEIF(ISUB.EQ.239) THEN
24482 IZID=3
24483 ELSEIF(ISUB.EQ.240) THEN
24484 IZID=4
24485 ENDIF
24486 ISUB=237
24487
24488C...Gluino + chargino
24489 ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN
24490 IF(ISUB.EQ.241) THEN
24491 IZID=1
24492 ELSEIF(ISUB.EQ.242) THEN
24493 IZID=2
24494 ENDIF
24495 ISUB=241
24496
24497C...Squark + neutralino
24498 ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN
24499 ILR=0
24500 IF(MOD(ISUB,2).NE.0) ILR=1
24501 IF(ISUB.LE.247) THEN
24502 IZID=1
24503 ELSEIF(ISUB.LE.249) THEN
24504 IZID=2
24505 ELSEIF(ISUB.LE.251) THEN
24506 IZID=3
24507 ELSEIF(ISUB.LE.253) THEN
24508 IZID=4
24509 ENDIF
24510 ISUB=246
24511 RKF=5D0
24512
24513C...Squark + chargino
24514 ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN
24515 IF(ISUB.LE.255) THEN
24516 IZID=1
24517 ELSEIF(ISUB.LE.257) THEN
24518 IZID=2
24519 ENDIF
24520 IF(MOD(ISUB,2).EQ.0) THEN
24521 ILR=0
24522 ELSE
24523 ILR=1
24524 ENDIF
24525 ISUB=254
24526 RKF=5D0
24527
24528C...Squark + gluino
24529 ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN
24530 ISUB=258
24531 RKF=4D0
24532
24533C...Stops
24534 ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN
24535 ILR=0
24536 IF(ISUB.EQ.262) ILR=1
24537 ISUB=261
24538 ELSEIF(ISUB.EQ.265) THEN
24539 ISUB=264
24540
24541C...Squarks
24542 ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN
24543 ILR=0
24544 IF(ISUB.LE.273) THEN
24545 IF(ISUB.EQ.273) ILR=1
24546 ISUB=271
24547 RKF=16D0
24548 ELSEIF(ISUB.LE.276) THEN
24549 IF(ISUB.EQ.276) ILR=1
24550 ISUB=274
24551 RKF=16D0
24552 ELSEIF(ISUB.LE.278) THEN
24553 IF(ISUB.EQ.278) ILR=1
24554 ISUB=277
24555 RKF=4D0
24556 ELSE
24557 IF(ISUB.EQ.280) ILR=1
24558 ISUB=279
24559 RKF=4D0
24560 ENDIF
24561C...Sbottoms
24562 ELSEIF(ISUB.GE.281.AND.ISUB.LE.296) THEN
24563 ILR=0
24564 IF(ISUB.LE.283) THEN
24565 IF(ISUB.EQ.283) ILR=1
24566 ISUB=271
24567 RKF=4D0
24568 ELSEIF(ISUB.LE.286) THEN
24569 IF(ISUB.EQ.286) ILR=1
24570 ISUB=274
24571 RKF=4D0
24572 ELSEIF(ISUB.LE.288) THEN
24573 IF(ISUB.EQ.288) ILR=1
24574 ISUB=277
24575 RKF=1D0
24576 ELSEIF(ISUB.LE.290) THEN
24577 IF(ISUB.EQ.290) ILR=1
24578 ISUB=279
24579 RKF=1D0
24580 ELSEIF(ISUB.LE.293) THEN
24581 IF(ISUB.EQ.293) ILR=1
24582 ISUB=271
24583 RKF=1D0
24584 ELSEIF(ISUB.EQ.296) THEN
24585 ILR=1
24586 ISUB=274
24587 RKF=1D0
24588C...Squark + gluino
24589 ELSEIF(ISUB.EQ.294.OR.ISUB.EQ.295) THEN
24590 ISUB=258
24591 RKF=1D0
24592 ENDIF
24593C...H+/- + H0
24594 ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
24595 IF(ISUB.EQ.297) THEN
24596 RKF=.5D0*PARU(195)**2
24597 ELSEIF(ISUB.EQ.298) THEN
24598 RKF=.5D0*(1D0-PARU(195)**2)
24599 ENDIF
24600 ISUB=210
24601C...A0 + H0
24602 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
24603 IF(ISUB.EQ.299) THEN
24604 RKF=PARU(186)**2
24605 KFID=25
24606 ELSEIF(ISUB.EQ.300) THEN
24607 RKF=PARU(187)**2
24608 KFID=35
24609 ENDIF
24610 ISUB=213
24611C...H+ + H-
24612 ELSEIF(ISUB.EQ.301) THEN
24613 KFID=37
24614 RKF=1D0
24615 ISUB=201
24616 ENDIF
24617
24618C...Supersymmetric processes - all of type 2 -> 2 :
24619C...correct final-state Breit-Wigners from fixed to running width.
24620 IF(MSTP(42).GT.0) THEN
24621 DO 100 I=1,2
24622 KFLW=KFPR(ISUBSV,I)
24623 KCW=PYCOMP(KFLW)
24624 IF(PMAS(KCW,2).LT.PARP(41)) GOTO 100
24625 IF(I.EQ.1) SQMI=SQM3
24626 IF(I.EQ.2) SQMI=SQM4
24627 SQMS=PMAS(KCW,1)**2
24628 GMMS=PMAS(KCW,1)*PMAS(KCW,2)
24629 HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2)
24630 CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
24631 GMMI=SQRT(SQMI)*WDTP(0)
24632 HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2)
24633 COMFAC=COMFAC*(HBWI/HBWS)
24634 100 CONTINUE
24635 ENDIF
24636
24637C...Differential cross section expressions.
24638
24639 IF(ISUB.LE.210) THEN
24640 IF(ISUB.EQ.201) THEN
24641C...f + fbar -> e_L + e_Lbar
24642 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
24643 DO 130 I=MMIN1,MMAX1
24644 IA=IABS(I)
24645 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 130
24646 EI=KCHG(IA,1)/3D0
24647 TT3I=SIGN(1D0,EI+1D-6)/2D0
24648 EJ=-1D0
24649 TT3J=-1D0/2D0
24650 FCOL=1D0
24651C...Color factor for e+ e-
24652 IF(IA.GE.11) FCOL=3D0
24653 IF(ISUBSV.EQ.301) THEN
24654 A1=1D0
24655 A2=0D0
24656 ELSEIF(ILR.EQ.1) THEN
24657 A1=SFMIX(KFID,3)**2
24658 A2=SFMIX(KFID,4)**2
24659 ELSEIF(ILR.EQ.0) THEN
24660 A1=SFMIX(KFID,1)**2
24661 A2=SFMIX(KFID,2)**2
24662 ENDIF
24663 XLQ=(TT3J-EJ*XW)*A1
24664 XRQ=(-EJ*XW)*A2
24665 XLF=(TT3I-EI*XW)
24666 XRF=(-EI*XW)
24667 TAA=(EI*EJ)**2*(POLL+POLR)
24668 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ+XRQ)**2/XW**2/XW1**2
24669 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
24670 TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF*POLL+XRF*POLR)/XW/XW1
24671 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
24672 TNN=0.0D0
24673 TAN=0.0D0
24674 TZN=0.0D0
24675 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
24676 FAC2=SQRT(2D0)
24677 TNN1=0D0
24678 TNN2=0D0
24679 TNN3=0D0
24680 DO 120 II=1,4
24681 DK=1D0/(TH-SMZ(II)**2)
24682 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
24683 & ZMIX(II,1))
24684 FREK=FAC2*TANW*EI*ZMIX(II,1)
24685 TNN1=TNN1+FLEK**2*DK
24686 TNN2=TNN2+FREK**2*DK
24687 DO 110 JJ=1,4
24688 DL=1D0/(TH-SMZ(JJ)**2)
24689 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
24690 & ZMIX(JJ,1))
24691 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
24692 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
24693 110 CONTINUE
24694 120 CONTINUE
24695 TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2*POLL+
24696 & A2**2*TNN2**2*POLR)
24697 TNN=(TNN+SH*A1*A2*TNN3*((1D0-PARJ(131))*(1D0-PARJ(132))+
24698 & (1D0+PARJ(131))*(1D0+PARJ(132))))/4D0/XW**2
24699 TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
24700 & (TNN1*XLF*A1*POLL+TNN2*XRF*A2*POLR)
24701 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
24702 & (1D0-SQMZ/SH)/SH
24703 TZN=TZN/XW**2/XW1
24704 TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1*POLL+
24705 & A2*TNN2*POLR)/XW
24706 ENDIF
24707 FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0
24708 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2
24709 FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0
24710 NCHN=NCHN+1
24711 ISIG(NCHN,1)=I
24712 ISIG(NCHN,2)=-I
24713 ISIG(NCHN,3)=1
24714 SIGH(NCHN)=FACQQ1+FACQQ2
24715 130 CONTINUE
24716
24717 ELSEIF(ISUB.EQ.203) THEN
24718C...f + fbar -> e_L + e_Rbar
24719 DO 160 I=MMIN1,MMAX1
24720 IA=IABS(I)
24721 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
24722 EI=KCHG(IABS(I),1)/3D0
24723 TT3I=SIGN(1D0,EI)/2D0
24724 EJ=-1
24725 TT3J=-1D0/2D0
24726 FCOL=1D0
24727C...Color factor for e+ e-
24728 IF(IA.GE.11) FCOL=3D0
24729 A1=SFMIX(KFID,1)**2
24730 A2=SFMIX(KFID,2)**2
24731 XLQ=(TT3J-EJ*XW)
24732 XRQ=(-EJ*XW)
24733 XLF=(TT3I-EI*XW)
24734 XRF=(-EI*XW)
24735 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ-XRQ)**2
24736 & /XW**2/XW1**2*A1*A2
24737 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
24738 TNN=0.0D0
24739 TZN=0.0D0
24740 TNNA=0D0
24741 TNNB=0D0
24742 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
24743 FAC2=SQRT(2D0)
24744 TNN1=0D0
24745 TNN2=0D0
24746 TNN3=0D0
24747 DO 150 II=1,4
24748 DK=1D0/(TH-SMZ(II)**2)
24749 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
24750 & ZMIX(II,1))
24751 FREK=FAC2*TANW*EI*ZMIX(II,1)
24752 TNN1=TNN1+FLEK**2*DK
24753 TNN2=TNN2+FREK**2*DK
24754 DO 140 JJ=1,4
24755 DL=1D0/(TH-SMZ(JJ)**2)
24756 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
24757 & ZMIX(JJ,1))
24758 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
24759 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
24760 140 CONTINUE
24761 150 CONTINUE
24762 TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2*POLR+TNN1**2*POLL)
24763 TNNA=(TNN+SH*(A1**2*POLLL+A2**2*POLRR)*TNN3)/4D0
24764 TNNB=(TNN+SH*(A1**2*POLRR+A2**2*POLLL)*TNN3)/4D0
24765 TZN=(UH*TH-SQM3*SQM4)*A1*A2
24766 TZN=TZN*(XLQ-XRQ)*(XLF*TNN1*POLL-XRF*TNN2*POLR)/XW1
24767 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
24768 & (1D0-SQMZ/SH)/SH
24769 ENDIF
24770 FACQQ0=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
24771 FACQQ2=COMFAC*AEM**2/XW**2*(TNNA+TZN)*FCOL/3D0
24772 FACQQ1=COMFAC*AEM**2/XW**2*(TNNB+TZN)*FCOL/3D0
24773C%%%%%%%%%%%
24774 NCHN=NCHN+1
24775 ISIG(NCHN,1)=I
24776 ISIG(NCHN,2)=-I
24777 ISIG(NCHN,3)=1
24778 SIGH(NCHN)=(FACQQ0+FACQQ1)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
24779 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
24780 NCHN=NCHN+1
24781 ISIG(NCHN,1)=I
24782 ISIG(NCHN,2)=-I
24783 ISIG(NCHN,3)=2
24784 SIGH(NCHN)=(FACQQ0+FACQQ2)*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
24785 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
24786 160 CONTINUE
24787
24788 ELSEIF(ISUB.EQ.210) THEN
24789C...q + qbar' -> W*- > ~l_L + ~nu_L
24790 FAC0=RKF*COMFAC*AEM**2/XW**2/12D0
24791 FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW)
24792 DO 180 I=MMIN1,MMAX1
24793 IA=IABS(I)
24794 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 180
24795 DO 170 J=MMIN2,MMAX2
24796 JA=IABS(J)
24797 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 170
24798 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 170
24799 FCKM=3D0
24800 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
24801 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
24802 KCHW=2
24803 IF(KCHSUM.LT.0) KCHW=3
24804 NCHN=NCHN+1
24805 ISIG(NCHN,1)=I
24806 ISIG(NCHN,2)=J
24807 ISIG(NCHN,3)=1
24808 IF(ISUBSV.EQ.297.OR.ISUBSV.EQ.298) THEN
24809 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
24810 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
24811 ELSE
24812 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
24813 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
24814 ENDIF
24815 SIGH(NCHN)=FAC0*FAC1*FCKM*FACR
24816 170 CONTINUE
24817 180 CONTINUE
24818 ENDIF
24819
24820 ELSEIF(ISUB.LE.220) THEN
24821 IF(ISUB.EQ.213) THEN
24822C...f + fbar -> ~nu_L + ~nu_Lbar
24823 IF(ISUBSV.EQ.299.OR.ISUBSV.EQ.300) THEN
24824 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
24825 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
24826 ELSE
24827 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
24828 ENDIF
24829 COMFAC=COMFAC*FACR
24830 PROPZ2=(SH-SQMZ)**2+ZWID**2*SQMZ
24831 XLL=0.5D0
24832 XLR=0.0D0
24833 DO 190 I=MMIN1,MMAX1
24834 IA=IABS(I)
24835 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 190
24836 EI=KCHG(IA,1)/3D0
24837 FCOL=1D0
24838C...Color factor for e+ e-
24839 IF(IA.GE.11) FCOL=3D0
24840 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
24841 XRQ=-EI*XW
24842 TZC=0.0D0
24843 TCC=0.0D0
24844 IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN
24845 TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/
24846 & (TH-SMW(2)**2)
24847 TCC=TZC**2
24848 TZC=TZC/XW1*(SH-SQMZ)/PROPZ2*XLQ*XLL
24849 ENDIF
24850 FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ2
24851 FACQQ2=TZC+TCC/4D0
24852 NCHN=NCHN+1
24853 ISIG(NCHN,1)=I
24854 ISIG(NCHN,2)=-I
24855 ISIG(NCHN,3)=1
24856 SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC
24857 & *AEM**2*FCOL/3D0/XW**2
24858 190 CONTINUE
24859
24860 ELSEIF(ISUB.EQ.216) THEN
24861C...q + qbar -> ~chi0_1 + ~chi0_1
24862 IF(IZID1.EQ.IZID2) THEN
24863 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
24864 ELSE
24865 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
24866 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
24867 ENDIF
24868 FACXX=COMFAC*AEM**2/3D0/XW**2
24869 IF(IZID1.EQ.IZID2) FACXX=FACXX/2D0
24870 ZM12=SQM3
24871 ZM22=SQM4
24872 WU2 = (UH-ZM12)*(UH-ZM22)
24873 WT2 = (TH-ZM12)*(TH-ZM22)
24874 WS2 = SMZ(IZID1)*SMZ(IZID2)*SH
24875 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
24876 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
24877 DO 200 I=1,4
24878 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
24879 IF(IZID2.NE.IZID1) THEN
24880 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
24881 ENDIF
24882 200 CONTINUE
24883 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
24884 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
24885 ORPP=DCONJG(OLPP)
24886 DO 210 I=MMINA,MMAXA
24887 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210
24888 EI=KCHG(IABS(I),1)/3D0
24889 T3I=SIGN(1D0,EI+1D-6)/2D0
24890 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2
24891 XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2
24892 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
24893 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
24894 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
24895 QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
24896 QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
24897 & /DCMPLX(TH-XML2)
24898 QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
24899 QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
24900 & -DCONJG(GRIJ)/DCMPLX(UH-XMR2)
24901 FCOL=1D0
24902 IF(IABS(I).GE.11) FCOL=3D0
24903 FACGG1=(ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
24904 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
24905 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
24906 & QRL*DCONJG(QRR)*POLR)*WS2
24907 NCHN=NCHN+1
24908 ISIG(NCHN,1)=I
24909 ISIG(NCHN,2)=-I
24910 ISIG(NCHN,3)=1
24911 SIGH(NCHN)=FACXX*FACGG1*FCOL
24912 210 CONTINUE
24913 ENDIF
24914
24915 ELSEIF(ISUB.LE.230) THEN
24916 IF(ISUB.EQ.226) THEN
24917C...f + fbar -> ~chi+_1 + ~chi-_1
24918 FACXX=COMFAC*AEM**2/3D0
24919 ZM12=SQM3
24920 ZM22=SQM4
24921 WU2 = (UH-ZM12)*(UH-ZM22)
24922 WT2 = (TH-ZM12)*(TH-ZM22)
24923 WS2 = SMW(IZID1)*SMW(IZID2)*SH
24924 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
24925 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
24926 DIFF=0D0
24927 IF(IZID1.EQ.IZID2) DIFF=1D0
24928 DO 220 I=1,2
24929 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
24930 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
24931 IF(IZID2.NE.IZID1) THEN
24932 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
24933 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
24934 ENDIF
24935 220 CONTINUE
24936 OLP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
24937 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0+DCMPLX(XW*DIFF)
24938 ORP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
24939 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0+DCMPLX(XW*DIFF)
24940 DO 230 I=MMINA,MMAXA
24941 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 230
24942 EI=KCHG(IABS(I),1)/3D0
24943 T3I=SIGN(1D0,EI+1D-6)/2D0
24944 QRL=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*ORP
24945 QLL=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*PROPZ*ORP
24946 QRR=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*OLP
24947 IF(MOD(I,2).EQ.0) THEN
24948 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
24949 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
24950 & PROPZ*OLP-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*
24951 & DCMPLX(T3I/XW/(TH-XML2))
24952 ELSE
24953 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2
24954 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
24955 & PROPZ*OLP-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*
24956 & DCMPLX(T3I/XW/(TH-XML2))
24957 ENDIF
24958 FCOL=1D0
24959 IF(IABS(I).GE.11) FCOL=3D0
24960 FACSUM=((ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
24961 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
24962 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
24963 & QRL*DCONJG(QRR)*POLR)*WS2)*FACXX*FCOL
24964 NCHN=NCHN+1
24965 ISIG(NCHN,1)=I
24966 ISIG(NCHN,2)=-I
24967 ISIG(NCHN,3)=1
24968 IF(IZID1.EQ.IZID2) THEN
24969 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
24970 ELSE
24971 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
24972 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
24973 NCHN=NCHN+1
24974 ISIG(NCHN,1)=I
24975 ISIG(NCHN,2)=-I
24976 ISIG(NCHN,3)=2
24977 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
24978 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
24979 ENDIF
24980 230 CONTINUE
24981
24982 ELSEIF(ISUB.EQ.229) THEN
24983C...q + qbar' -> ~chi0_1 + ~chi+-_1
24984 FACXX=COMFAC*AEM**2/6D0/XW**2
24985 ZM12=SQM3
24986 ZM22=SQM4
24987 WU2 = (UH-ZM12)*(UH-ZM22)
24988 WT2 = (TH-ZM12)*(TH-ZM22)
24989 WS2 = SMW(IZID1)*SMZ(IZID2)*SH
24990 RT2I = 1D0/SQRT(2D0)
24991 PROPW = DCMPLX(SH-SQMW,-WWID*PMAS(24,1))/
24992 & DCMPLX((SH-SQMW)**2+WWID**2*SQMW,0D0)
24993 DO 240 I=1,2
24994 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
24995 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
24996 240 CONTINUE
24997 DO 250 I=1,4
24998 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
24999 250 CONTINUE
25000 OL=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
25001 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)*PROPW
25002 OR=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
25003 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)*PROPW
25004
25005 DO 270 I=MMIN1,MMAX1
25006 IA=IABS(I)
25007 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 270
25008 EI=KCHG(IA,1)/3D0
25009 T3I=SIGN(1D0,EI+1D-6)/2D0
25010 DO 260 J=MMIN2,MMAX2
25011 JA=IABS(J)
25012 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 260
25013 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 260
25014 EJ=KCHG(JA,1)/3D0
25015 T3J=SIGN(1D0,EJ+1D-6)/2D0
25016 FCKM=3D0
25017 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
25018 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
25019 KCHW=2
25020 IF(KCHSUM.LT.0) KCHW=3
25021 IF(MOD(IA,2).EQ.0) THEN
25022 ZMI2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
25023 ZMJ2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
25024 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
25025 & TANW+ZMIXC(IZID2,2)*T3I)/DCMPLX(UH-ZMI2)
25026 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
25027 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
25028 & /DCMPLX(TH-ZMJ2)
25029 ELSE
25030 ZMI2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
25031 ZMJ2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
25032 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
25033 & TANW+ZMIXC(IZID2,2)*T3J)/DCMPLX(UH-ZMJ2)
25034 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
25035 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
25036 & /DCMPLX(TH-ZMI2)
25037 ENDIF
25038 ZINTR=DBLE(QLR*DCONJG(QLL))
25039 FACGG1=FACXX*(ABS(QLL)**2*WU2+ABS(QLR)**2*WT2+
25040 & 2D0*ZINTR*WS2)
25041 NCHN=NCHN+1
25042 ISIG(NCHN,1)=I
25043 ISIG(NCHN,2)=J
25044 ISIG(NCHN,3)=1
25045 SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25046 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
25047 260 CONTINUE
25048 270 CONTINUE
25049 ENDIF
25050
25051 ELSEIF(ISUB.LE.240) THEN
25052 IF(ISUB.EQ.237) THEN
25053C...q + qbar -> gluino + ~chi0_1
25054 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25055 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25056 FAC0=COMFAC*AS*AEM*4D0/9D0/XW
25057 GM2=SQM3
25058 ZM2=SQM4
25059 DO 280 I=MMINA,MMAXA
25060 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 280
25061 EI=KCHG(IABS(I),1)/3D0
25062 IA=IABS(I)
25063 XLQC = -TANW*EI*ZMIX(IZID,1)
25064 XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
25065 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
25066 XLQ2=XLQC**2
25067 XRQ2=XRQC**2
25068 XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2
25069 XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2
25070 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2
25071 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2
25072 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2)
25073 SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN)
25074 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2
25075 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2
25076 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2)
25077 SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN)
25078 NCHN=NCHN+1
25079 ISIG(NCHN,1)=I
25080 ISIG(NCHN,2)=-I
25081 ISIG(NCHN,3)=1
25082 SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR)
25083 280 CONTINUE
25084 ENDIF
25085
25086 ELSEIF(ISUB.LE.250) THEN
25087 IF(ISUB.EQ.241) THEN
25088C...q + qbar' -> ~chi+-_1 + gluino
25089 FACWG=COMFAC*AS*AEM/XW*2D0/9D0
25090 GM2=SQM3
25091 ZM2=SQM4
25092 FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1)
25093 FAC0=UMIX(IZID,1)**2
25094 FAC1=VMIX(IZID,1)**2
25095 DO 300 I=MMIN1,MMAX1
25096 IA=IABS(I)
25097 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 300
25098 DO 290 J=MMIN2,MMAX2
25099 JA=IABS(J)
25100 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 290
25101 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 290
25102 FCKM=1D0
25103 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
25104 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
25105 KCHW=2
25106 IF(KCHSUM.LT.0) KCHW=3
25107 XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2
25108 XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2
25109 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2
25110 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2
25111 ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2)
25112 XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2
25113 XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2
25114 ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0
25115 AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0
25116 ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)*
25117 & SH/(TH-XMU2)/(UH-XMD2))/2D0
25118 NCHN=NCHN+1
25119 ISIG(NCHN,1)=I
25120 ISIG(NCHN,2)=J
25121 ISIG(NCHN,3)=1
25122 SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN-
25123 & FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25124 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
25125 290 CONTINUE
25126 300 CONTINUE
25127
25128 ELSEIF(ISUB.EQ.243) THEN
25129C...q + qbar -> gluino + gluino
25130 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25131 XMT=SQM3-TH
25132 XMU=SQM3-UH
25133 DO 310 I=MMINA,MMAXA
25134 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
25135 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
25136 NCHN=NCHN+1
25137 XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH
25138 XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH
25139 FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
25140 & 2D0*SQM3*SH)/SH2 +4D0/9D0*(XMT**2/XST**2+
25141 & XMU**2/XSU**2) - (XMT**2+SH*SQM3)/SH/XST +
25142 & SQM3*SH/XST/XSU/9D0- (XMU**2+SH*SQM3)/SH/XSU )
25143 XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
25144 XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
25145 FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
25146 & 2D0*SQM3*SH)/SH2 +4D0/9D0*(XMT**2/XST**2+
25147 & XMU**2/XSU**2) - (XMT**2+SH*SQM3)/SH/XST +
25148 & SQM3*SH/XST/XSU/9D0- (XMU**2+SH*SQM3)/SH/XSU )
25149 ISIG(NCHN,1)=I
25150 ISIG(NCHN,2)=-I
25151 ISIG(NCHN,3)=1
25152C...1/2 for identical particles
25153 SIGH(NCHN)=0.25D0*(FACGG1+FACGG2)
25154 310 CONTINUE
25155
25156 ELSEIF(ISUB.EQ.244) THEN
25157C...g + g -> gluino + gluino
25158 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25159 XMT=SQM3-TH
25160 XMU=SQM3-UH
25161 FACQQ1=COMFAC*AS**2*9D0/4D0*(
25162 & (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 -
25163 & (XMT*XMU+SQM3*(UH-TH))/SH/XMT )
25164 FACQQ2=COMFAC*AS**2*9D0/4D0*(
25165 & (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 -
25166 & (XMU*XMT+SQM3*(TH-UH))/SH/XMU )
25167 FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 +
25168 & SQM3*(SH-4D0*SQM3)/XMT/XMU)
25169 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 320
25170 NCHN=NCHN+1
25171 ISIG(NCHN,1)=21
25172 ISIG(NCHN,2)=21
25173 ISIG(NCHN,3)=1
25174 SIGH(NCHN)=FACQQ1/2D0
25175 NCHN=NCHN+1
25176 ISIG(NCHN,1)=21
25177 ISIG(NCHN,2)=21
25178 ISIG(NCHN,3)=2
25179 SIGH(NCHN)=FACQQ2/2D0
25180 NCHN=NCHN+1
25181 ISIG(NCHN,1)=21
25182 ISIG(NCHN,2)=21
25183 ISIG(NCHN,3)=3
25184 SIGH(NCHN)=FACQQ3/2D0
25185 320 CONTINUE
25186
25187 ELSEIF(ISUB.EQ.246) THEN
25188C...g + q_j -> ~chi0_1 + ~q_j
25189 FAC0=COMFAC*AS*AEM/6D0/XW
25190 ZM2=SQM4
25191 QM2=SQM3
25192 FACZQ0=FAC0*( (ZM2-TH)/SH +
25193 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
25194 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
25195 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
25196 DO 340 I=-KFNSQ,KFNSQ,2*KFNSQ
25197 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 340
25198 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
25199 EI=KCHG(IABS(I),1)/3D0
25200 IA=IABS(I)
25201 XRQZ = -TANW*EI*ZMIX(IZID,1)
25202 XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
25203 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
25204 IF(ILR.EQ.0) THEN
25205 BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2
25206 ELSE
25207 BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2
25208 ENDIF
25209 FACZQ=FACZQ0*BS
25210 KCHQ=2
25211 IF(I.LT.0) KCHQ=3
25212 DO 330 ISDE=1,2
25213 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
25214 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
25215 NCHN=NCHN+1
25216 ISIG(NCHN,ISDE)=I
25217 ISIG(NCHN,3-ISDE)=21
25218 ISIG(NCHN,3)=1
25219 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25220 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25221 330 CONTINUE
25222 340 CONTINUE
25223 ENDIF
25224
25225 ELSEIF(ISUB.LE.260) THEN
25226 IF(ISUB.EQ.254) THEN
25227C...g + q_j -> ~chi1_1 + ~q_i
25228 FAC0=COMFAC*AS*AEM/12D0/XW
25229 ZM2=SQM4
25230 QM2=SQM3
25231 AU=UMIX(IZID,1)**2
25232 AD=VMIX(IZID,1)**2
25233 FACZQ0=FAC0*( (ZM2-TH)/SH +
25234 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
25235 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
25236 KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1)
25237 IF(MOD(KFNSQ1,2).EQ.0) THEN
25238 KFNSQ=KFNSQ1-1
25239 KCHW=2
25240 ELSE
25241 KFNSQ=KFNSQ1+1
25242 KCHW=3
25243 ENDIF
25244 DO 360 I=-KFNSQ,KFNSQ,2*KFNSQ
25245 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 360
25246 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
25247 IA=IABS(I)
25248 IF(MOD(IA,2).EQ.0) THEN
25249 FACZQ=FACZQ0*AU
25250 ELSE
25251 FACZQ=FACZQ0*AD
25252 ENDIF
25253 FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2
25254 KCHQ=2
25255 IF(I.LT.0) KCHQ=3
25256 KCHWQ=KCHW
25257 IF(I.LT.0) KCHWQ=5-KCHW
25258 DO 350 ISDE=1,2
25259 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
25260 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
25261 NCHN=NCHN+1
25262 ISIG(NCHN,ISDE)=I
25263 ISIG(NCHN,3-ISDE)=21
25264 ISIG(NCHN,3)=1
25265 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25266 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ)
25267 350 CONTINUE
25268 360 CONTINUE
25269
25270 ELSEIF(ISUB.EQ.258) THEN
25271C...g + q_j -> gluino + ~q_i
25272 XG2=SQM4
25273 XQ2=SQM3
25274 XMT=XG2-TH
25275 XMU=XG2-UH
25276 XST=XQ2-TH
25277 XSU=XQ2-UH
25278 FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 -
25279 & ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) +
25280 & 0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) +
25281 & (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU
25282 FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0*
25283 & (SH*(UH+XG2)
25284 & +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH +
25285 & 0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+
25286 & (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU
25287 FACQG1=COMFAC*AS**2*FACQG1/2D0
25288 FACQG2=COMFAC*AS**2*FACQG2/2D0
25289 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
25290 DO 380 I=-KFNSQ,KFNSQ,2*KFNSQ
25291 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 380
25292 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 380
25293 KCHQ=2
25294 IF(I.LT.0) KCHQ=3
25295 FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25296 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25297 DO 370 ISDE=1,2
25298 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 370
25299 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 370
25300 NCHN=NCHN+1
25301 ISIG(NCHN,ISDE)=I
25302 ISIG(NCHN,3-ISDE)=21
25303 ISIG(NCHN,3)=1
25304 SIGH(NCHN)=FACQG1*FACSEL
25305 NCHN=NCHN+1
25306 ISIG(NCHN,ISDE)=I
25307 ISIG(NCHN,3-ISDE)=21
25308 ISIG(NCHN,3)=2
25309 SIGH(NCHN)=FACQG2*FACSEL
25310 370 CONTINUE
25311 380 CONTINUE
25312 ENDIF
25313
25314 ELSEIF(ISUB.LE.270) THEN
25315 IF(ISUB.EQ.261) THEN
25316C...q_i + q_ibar -> ~t_1 + ~t_1bar
25317 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )*
25318 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25319 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
25320 FAC0=AS**2*4D0/9D0
25321 DO 390 I=MMIN1,MMAX1
25322 IA=IABS(I)
25323 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 390
25324 IF(IA.GE.11.AND.IA.LE.18) THEN
25325 EI=KCHG(IA,1)/3D0
25326 EJ=KCHG(KFNSQ,1)/3D0
25327 T3I=SIGN(1D0,EI)/2D0
25328 T3J=SIGN(1D0,EJ)/2D0
25329 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2
25330 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2
25331 XLF=2D0*(T3I-EI*XW)
25332 XRF=2D0*(-EI*XW)
25333 TAA=0.5D0*(EI*EJ)**2
25334 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
25335 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
25336 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
25337 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
25338 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
25339 ENDIF
25340 NCHN=NCHN+1
25341 ISIG(NCHN,1)=I
25342 ISIG(NCHN,2)=-I
25343 ISIG(NCHN,3)=1
25344 SIGH(NCHN)=FACQQ1*FAC0
25345 390 CONTINUE
25346
25347 ELSEIF(ISUB.EQ.263) THEN
25348C...f + fbar -> ~t1 + ~t2bar
25349 DO 400 I=MMIN1,MMAX1
25350 IA=IABS(I)
25351 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
25352 EI=KCHG(IABS(I),1)/3D0
25353 TT3I=SIGN(1D0,EI)/2D0
25354 EJ=2D0/3D0
25355 TT3J=1D0/2D0
25356 FCOL=1D0
25357C...Color factor for e+ e-
25358 IF(IA.GE.11) FCOL=3D0
25359 XLQ=2D0*(TT3J-EJ*XW)
25360 XRQ=2D0*(-EJ*XW)
25361 XLF=2D0*(TT3I-EI*XW)
25362 XRF=2D0*(-EI*XW)
25363 TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2
25364 TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2
25365 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
25366C...Factor of 2 for t1 t2bar + t2 t1bar
25367 FACQQ1=2D0*COMFAC*AEM**2*TZZ*FCOL*4D0
25368 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2
25369 NCHN=NCHN+1
25370 ISIG(NCHN,1)=I
25371 ISIG(NCHN,2)=-I
25372 ISIG(NCHN,3)=1
25373 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25374 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
25375 NCHN=NCHN+1
25376 ISIG(NCHN,1)=I
25377 ISIG(NCHN,2)=-I
25378 ISIG(NCHN,3)=2
25379 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
25380 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25381 400 CONTINUE
25382
25383 ELSEIF(ISUB.EQ.264) THEN
25384C...g + g -> ~t_1 + ~t_1bar
25385 XSU=SQM3-UH
25386 XST=SQM3-TH
25387 FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0*
25388 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25389 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
25390 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
25391 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
25392 NCHN=NCHN+1
25393 ISIG(NCHN,1)=21
25394 ISIG(NCHN,2)=21
25395 ISIG(NCHN,3)=1
25396 SIGH(NCHN)=FACQQ1
25397 NCHN=NCHN+1
25398 ISIG(NCHN,1)=21
25399 ISIG(NCHN,2)=21
25400 ISIG(NCHN,3)=2
25401 SIGH(NCHN)=FACQQ2
25402 410 CONTINUE
25403 ENDIF
25404
25405 ELSEIF(ISUB.LE.280) THEN
25406 IF(ISUB.EQ.271) THEN
25407C...q + q' -> ~q + ~q' (~g exchange)
25408 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
25409 XMT=XMG2-TH
25410 XMU=XMG2-UH
25411 XSU1=SQM3-UH
25412 XSU2=SQM4-UH
25413 XST1=SQM3-TH
25414 XST2=SQM4-TH
25415 IF(ILR.EQ.1) THEN
25416 FACQQ1=COMFAC*AS**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 )
25417 FACQQ2=COMFAC*AS**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 )
25418 FACQQB=0.0D0
25419 ELSE
25420 FACQQ1=0.5D0*COMFAC*AS**2*4D0/9D0*( SH*XMG2/XMT**2 )
25421 FACQQ2=0.5D0*COMFAC*AS**2*4D0/9D0*( SH*XMG2/XMU**2 )
25422 FACQQB=0.5D0*COMFAC*AS**2*4D0/9D0*( -2D0*SH*XMG2/3D0/
25423 & XMT/XMU )
25424 ENDIF
25425 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
25426 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
25427 DO 430 I=-KFNSQI,KFNSQI,2*KFNSQI
25428 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 430
25429 IA=IABS(I)
25430 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
25431 KCHQ=2
25432 IF(I.LT.0) KCHQ=3
25433 DO 420 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
25434 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 420
25435 JA=IABS(J)
25436 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
25437 IF(I*J.LT.0) GOTO 420
25438 NCHN=NCHN+1
25439 ISIG(NCHN,1)=I
25440 ISIG(NCHN,2)=J
25441 ISIG(NCHN,3)=1
25442 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25443 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
25444 IF(I.EQ.J) THEN
25445 IF(ILR.EQ.0) THEN
25446 SIGH(NCHN)=0.5D0*(FACQQ1+0.5D0*FACQQB)*RKF*
25447 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
25448 ELSE
25449 SIGH(NCHN)=0.5D0*FACQQ1*RKF*
25450 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25451 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
25452 ENDIF
25453 NCHN=NCHN+1
25454 ISIG(NCHN,1)=I
25455 ISIG(NCHN,2)=J
25456 ISIG(NCHN,3)=2
25457 IF(ILR.EQ.0) THEN
25458 SIGH(NCHN)=0.5D0*(FACQQ2+0.5D0*FACQQB)*RKF*
25459 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
25460 ELSE
25461 SIGH(NCHN)=0.5D0*FACQQ2*RKF*
25462 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25463 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
25464 ENDIF
25465 ENDIF
25466 420 CONTINUE
25467 430 CONTINUE
25468
25469 ELSEIF(ISUB.EQ.274) THEN
25470C...q + qbar' -> ~q + ~qbar'
25471 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
25472 XMT=XMG2-TH
25473 XMU=XMG2-UH
25474 IF(ILR.EQ.0) THEN
25475C...Mrenna...Normalization.and.1/XMT
25476 FACQQ1=COMFAC*AS**2*2D0/9D0*(
25477 & (UH*TH-SQM3*SQM4)/XMT**2 )
25478 FACQQB=COMFAC*AS**2*2D0/9D0*(
25479 & (UH*TH-SQM3*SQM4)/SH2*(2D0-2D0/3D0*SH/XMT))
25480 FACQQB=FACQQB+FACQQ1
25481 ELSE
25482 FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )
25483 FACQQB=FACQQ1
25484 ENDIF
25485 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
25486 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
25487 DO 450 I=-KFNSQI,KFNSQI,2*KFNSQI
25488 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 450
25489 IA=IABS(I)
25490 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 450
25491 KCHQ=2
25492 IF(I.LT.0) KCHQ=3
25493 DO 440 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
25494 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 440
25495 JA=IABS(J)
25496 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 440
25497 IF(I*J.GT.0) GOTO 440
25498 NCHN=NCHN+1
25499 ISIG(NCHN,1)=I
25500 ISIG(NCHN,2)=J
25501 ISIG(NCHN,3)=1
25502 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25503 & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
25504 IF(I.EQ.-J) SIGH(NCHN)=FACQQB*RKF*
25505 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25506 440 CONTINUE
25507 450 CONTINUE
25508
25509 ELSEIF(ISUB.EQ.277) THEN
25510C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
25511C...if i .eq. j covered in 274
25512 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )
25513 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
25514 FAC0=0D0
25515 DO 460 I=MMIN1,MMAX1
25516 IA=IABS(I)
25517 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.
25518 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
25519 IF(IA.EQ.KFNSQ) GOTO 460
25520 IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN
25521 EI=KCHG(IA,1)/3D0
25522 EJ=KCHG(KFNSQ,1)/3D0
25523 T3J=SIGN(0.5D0,EJ)
25524 T3I=SIGN(1D0,EI)/2D0
25525 IF(ILR.EQ.0) THEN
25526 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1)
25527 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2)
25528 ELSE
25529 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3)
25530 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4)
25531 ENDIF
25532 XLF=2D0*(T3I-EI*XW)
25533 XRF=2D0*(-EI*XW)
25534 IF(ILR.EQ.0) THEN
25535 XRQ=0D0
25536 ELSE
25537 XLQ=0D0
25538 ENDIF
25539 TAA=0.5D0*(EI*EJ)**2
25540 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
25541 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
25542 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
25543 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
25544 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
25545 ELSEIF(IA.LE.6) THEN
25546 FAC0=AS**2*8D0/9D0/2D0
25547 ENDIF
25548 NCHN=NCHN+1
25549 ISIG(NCHN,1)=I
25550 ISIG(NCHN,2)=-I
25551 ISIG(NCHN,3)=1
25552 SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25553 460 CONTINUE
25554
25555 ELSEIF(ISUB.EQ.279) THEN
25556C...g + g -> ~q_j + ~q_jbar
25557 XSU=SQM3-UH
25558 XST=SQM3-TH
25559C...5=RKF because ~t ~tbar treated separately
25560 FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )
25561 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
25562 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
25563 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 470
25564 NCHN=NCHN+1
25565 ISIG(NCHN,1)=21
25566 ISIG(NCHN,2)=21
25567 ISIG(NCHN,3)=1
25568 SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25569 NCHN=NCHN+1
25570 ISIG(NCHN,1)=21
25571 ISIG(NCHN,2)=21
25572 ISIG(NCHN,3)=2
25573 SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25574 470 CONTINUE
25575
25576 ENDIF
25577 ENDIF
25578CMRENNA--
25579
25580 RETURN
25581 END
25582
25583C*********************************************************************
25584
25585C...PYSGTC
25586C...Subprocess cross sections for Technicolor processes.
25587C...Auxiliary to PYSIGH.
25588
25589 SUBROUTINE PYSGTC(NCHN,SIGS)
25590
25591C...Double precision and integer declarations
25592 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25593 IMPLICIT INTEGER(I-N)
25594 INTEGER PYK,PYCHGE,PYCOMP
25595C...Parameter statement to help give large particle numbers.
25596 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
25597 &KEXCIT=4000000,KDIMEN=5000000)
25598C...Commonblocks
25599 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
25600 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
25601 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
25602 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
25603 COMMON/PYINT1/MINT(400),VINT(400)
25604 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
25605 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
25606 COMMON/PYINT4/MWID(500),WIDS(500,5)
25607 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
25608 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
25609 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
25610 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
25611 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
25612 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
25613 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
25614C...Local arrays and complex variables
25615 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
25616 COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME
25617 COMPLEX*16 DAA,DZZ,DAZ,DWW,DWRHO
25618 COMPLEX*16 ZTC(6,6),YTC(6,6),DGGS,DGGT,DGGU,DGVS,DGVT,DGVU
25619 COMPLEX*16 DQQS,DQQT,DQQU,DQTS,DQGS,DTGS
25620 COMPLEX*16 DVVS,DVVT,DVVU
25621 INTEGER INDX(6)
25622
25623C...Combinations of weak mixing angle.
25624 TANW=SQRT(XW/XW1)
25625 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
25626
25627C...Convert almost equivalent technicolor processes into
25628C...a few basic processes, and set distinguishing parameters.
25629 IF(ISUB.GE.361.AND.ISUB.LE.379) THEN
25630 SQTV=RTCM(12)**2
25631 SQTA=RTCM(13)**2
25632 SN2W=2D0*SQRT(PARU(102)*(1D0-PARU(102)))
25633 CS2W=1D0-2D0*PARU(102)
25634 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
25635 CT2W=CS2W/SN2W
25636 CSXI=COS(ASIN(RTCM(3)))
25637 CSXIP=COS(ASIN(RTCM(4)))
25638 QUPD=2D0*RTCM(2)-1D0
25639 Q2UD=RTCM(2)**2+(RTCM(2)-1D0)**2
25640C... rho_tc0 -> W_L W_L
25641 IF(ISUB.EQ.361) THEN
25642 KFA=24
25643 KFB=24
25644 CAB2=RTCM(3)**4
25645C... rho_tc0 -> W_L pi_tc-
25646 ELSEIF(ISUB.EQ.362) THEN
25647 KFA=24
25648 KFB=KTECHN+211
25649 ISUB=361
25650 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
25651C... pi_tc pi_tc
25652 ELSEIF(ISUB.EQ.363) THEN
25653 KFA=KTECHN+211
25654 KFB=KTECHN+211
25655 ISUB=361
25656 CAB2=(1D0-RTCM(3)**2)**2
25657C... rho_tc0/omega_tc -> gamma pi_tc
25658 ELSEIF(ISUB.EQ.364) THEN
25659 KFA=22
25660 KFB=KTECHN+111
25661 VOGP=CSXI/RTCM(12)
25662C..........!!!
25663 VRGP=VOGP*QUPD
25664 AOGP=0D0
25665 ARGP=0D0
25666 VAGP=2D0*QUPD*CSXI
25667 VZGP=QUPD*CSXI*(1D0-4D0*PARU(102))/SN2W
25668C... gamma pi_tc'
25669 ELSEIF(ISUB.EQ.365) THEN
25670 KFA=22
25671 KFB=KTECHN+221
25672 ISUB=364
25673 VRGP=CSXIP/RTCM(12)
25674C..........!!!!
25675 VOGP=VRGP*QUPD
25676 AOGP=0D0
25677 ARGP=0D0
25678 VAGP=2D0*Q2UD*CSXIP
25679 VZGP=CSXIP/SN2W*(1D0-4D0*PARU(102)*Q2UD)
25680C... Z pi_tc
25681 ELSEIF(ISUB.EQ.366) THEN
25682 KFA=23
25683 KFB=KTECHN+111
25684 ISUB=364
25685 VOGP=CSXI*CT2W/RTCM(12)
25686 VRGP=-QUPD*CSXI*TANW/RTCM(12)
25687 AOGP=0D0
25688 ARGP=0D0
25689 VAGP=QUPD*CSXI*(1D0-4D0*PARU(102))/SN2W
25690 VZGP=-QUPD*CSXI*CS2W/(1D0-PARU(102))
25691C... Z pi_tc'
25692 ELSEIF(ISUB.EQ.367) THEN
25693 KFA=23
25694 KFB=KTECHN+221
25695 ISUB=364
25696 VRGP=CSXIP*CT2W/RTCM(12)
25697 VOGP=-QUPD*CSXIP*TANW/RTCM(12)
25698 AOGP=0D0
25699 ARGP=0D0
25700 VAGP=CSXIP*(1D0-4D0*Q2UD*PARU(102))/SN2W
25701 VZGP=2D0*CSXIP*(CS2W+4D0*Q2UD*PARU(102)**2)/SN2W**2
25702C... W_T pi_tc
25703 ELSEIF(ISUB.EQ.368) THEN
25704 KFA=24
25705 KFB=KTECHN+211
25706 ISUB=364
25707 VOGP=CSXI/(2D0*SQRT(PARU(102)))/RTCM(12)
25708 VRGP=0D0
25709 AOGP=0D0
25710C..........!!!!
25711 ARGP=-CSXI/(2D0*SQRT(PARU(102)))/RTCM(13)
25712 VAGP=QUPD*CSXI/(2D0*SQRT(PARU(102)))
25713 VZGP=-QUPD*CSXI/(2D0*SQRT(1D0-PARU(102)))
25714C... rho_tc+ -> W_L Z_L
25715 ELSEIF(ISUB.EQ.370) THEN
25716 KFA=24
25717 KFB=23
25718 CAB2=RTCM(3)**4
25719C... W_L pi_tc0
25720 ELSEIF(ISUB.EQ.371) THEN
25721 KFA=24
25722 KFB=KTECHN+111
25723 ISUB=370
25724 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
25725C... Z_L pi_tc+
25726 ELSEIF(ISUB.EQ.372) THEN
25727 KFA=KTECHN+211
25728 KFB=23
25729 ISUB=370
25730 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
25731C... pi_tc+ pi_tc0
25732 ELSEIF(ISUB.EQ.373) THEN
25733 KFA=KTECHN+211
25734 KFB=KTECHN+111
25735 ISUB=370
25736 CAB2=(1D0-RTCM(3)**2)**2
25737C... gamma pi_tc+
25738 ELSEIF(ISUB.EQ.374) THEN
25739 KFA=KTECHN+211
25740 KFB=22
25741 VRGP=QUPD*CSXI
25742 ARGP=0D0
25743 VWGP=QUPD*CSXI/(2D0*SQRT(PARU(102)))
25744C... Z_T pi_tc+
25745 ELSEIF(ISUB.EQ.375) THEN
25746 KFA=KTECHN+211
25747 KFB=23
25748 ISUB=374
25749 VRGP=-QUPD*CSXI*TANW
25750 ARGP=CSXI/(2D0*SQRT(PARU(102)*(1D0-PARU(102))))
25751 VWGP=-QUPD*CSXI/(2D0*SQRT(1D0-PARU(102)))
25752C... W_T pi_tc0
25753 ELSEIF(ISUB.EQ.376) THEN
25754 KFA=24
25755 KFB=KTECHN+111
25756 ISUB=374
25757 VRGP=0D0
25758 ARGP=-CSXI/(2D0*SQRT(PARU(102)))
25759 VWGP=0D0
25760C... W_T pi_tc0'
25761 ELSEIF(ISUB.EQ.377) THEN
25762 KFA=24
25763 KFB=KTECHN+221
25764 ISUB=374
25765 ARGP=0D0
25766 VRGP=CSXIP/(2D0*SQRT(PARU(102)))
25767 VWGP=CSXIP/(2D0*PARU(102))
25768 ENDIF
25769 ENDIF
25770
25771C...QCD 2 -> 2 processes: corrections from virtual technicolor exchange.
25772 IF(ISUB.GE.381.AND.ISUB.LE.388) THEN
25773 IF(ITCM(5).LE.4) THEN
25774 SQDQQS=1D0/SH2
25775 SQDQQT=1D0/TH2
25776 SQDQQU=1D0/UH2
25777 SQDGGS=SQDQQS
25778 SQDGGT=SQDQQT
25779 SQDGGU=SQDQQU
25780 REDGGS=1D0/SH
25781 REDGGT=1D0/TH
25782 REDGGU=1D0/UH
25783 REDGTU=1D0/UH/TH
25784 REDGSU=1D0/SH/UH
25785 REDGST=1D0/SH/TH
25786 REDQST=1D0/SH/TH
25787 REDQTU=1D0/UH/TH
25788 SQDLGS=0D0
25789 SQDLGT=0D0
25790 SQDQTS=SQDQQS
25791 ELSEIF(ITCM(5).EQ.5) THEN
25792 TANT3=RTCM(21)
25793 IF(ITCM(2).EQ.0) THEN
25794 IMDL=1
25795 ELSE
25796 IMDL=2
25797 ENDIF
25798 ALPRHT=2.91D0*(3D0/ITCM(1))
25799 SIN2T=2D0*TANT3/(TANT3**2+1D0)
25800 SINT3=TANT3/SQRT(TANT3**2+1D0)
25801 XIG=SQRT(PYALPS(SH)/ALPRHT)
25802 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
25803 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)/SIN2T
25804 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
25805 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)/SIN2T
25806 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
25807 & SINT3**2)*2D0/SIN2T
25808 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
25809 & SINT3**2)*2D0/SIN2T
25810
25811 SM1122=.5D0*(2D0-RTCM(29)**2-RTCM(31)**2)*RTCM(28)**2
25812 SM1112=X12*RTCM(28)**2*SIN2T
25813 SM1121=-X21*RTCM(28)**2*SIN2T
25814 SM2212=-SM1112
25815 SM2221=-SM1121
25816 SM1221=-.5D0*((1D0-RTCM(29)**2)*SIN(2D0*RTCM(30))+
25817 & (1D0-RTCM(31)**2)*SIN(2D0*RTCM(32)))*RTCM(28)**2
25818
25819C.........SH LOOP
25820 ZTC(1,1)=DCMPLX(SH,0D0)
25821 CALL PYWIDT(3100021,SH,WDTP,WDTE)
25822 IF(WDTP(0).GT.RTCM(33)*SHR) WDTP(0)=RTCM(33)*SHR
25823 ZTC(2,2)=DCMPLX(SH-PMAS(PYCOMP(3100021),1)**2,-SHR*WDTP(0))
25824 CALL PYWIDT(3100113,SH,WDTP,WDTE)
25825 ZTC(3,3)=DCMPLX(SH-PMAS(PYCOMP(3100113),1)**2,-SHR*WDTP(0))
25826 CALL PYWIDT(3400113,SH,WDTP,WDTE)
25827 ZTC(4,4)=DCMPLX(SH-PMAS(PYCOMP(3400113),1)**2,-SHR*WDTP(0))
25828 CALL PYWIDT(3200113,SH,WDTP,WDTE)
25829 ZTC(5,5)=DCMPLX(SH-PMAS(PYCOMP(3200113),1)**2,-SHR*WDTP(0))
25830 CALL PYWIDT(3300113,SH,WDTP,WDTE)
25831 ZTC(6,6)=DCMPLX(SH-PMAS(PYCOMP(3300113),1)**2,-SHR*WDTP(0))
25832 ZTC(1,2)=(0D0,0D0)
25833 ZTC(1,3)=DCMPLX(SH*XIG,0D0)
25834 ZTC(1,4)=ZTC(1,3)
25835 ZTC(1,5)=ZTC(1,2)
25836 ZTC(1,6)=ZTC(1,2)
25837 ZTC(2,3)=DCMPLX(SH*XIG*X11,0D0)
25838 ZTC(2,4)=DCMPLX(SH*XIG*X22,0D0)
25839 ZTC(2,5)=DCMPLX(SH*XIG*X12,0D0)
25840 ZTC(2,6)=DCMPLX(SH*XIG*X21,0D0)
25841 ZTC(3,4)=-SM1122
25842 ZTC(3,5)=-SM1112
25843 ZTC(3,6)=-SM1121
25844 ZTC(4,5)=-SM2212
25845 ZTC(4,6)=-SM2221
25846 ZTC(5,6)=-SM1221
25847
25848 DO 110 I=1,5
25849 DO 100 J=I+1,6
25850 ZTC(J,I)=ZTC(I,J)
25851 100 CONTINUE
25852 110 CONTINUE
25853 CALL PYLDCM(ZTC,6,6,INDX,D)
25854 DO 130 I=1,6
25855 DO 120 J=1,6
25856 YTC(I,J)=(0D0,0D0)
25857 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
25858 120 CONTINUE
25859 130 CONTINUE
25860
25861 DO 140 I=1,6
25862 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
25863 140 CONTINUE
25864 DGGS=YTC(1,1)
25865 DVVS=YTC(2,2)
25866 DGVS=YTC(1,2)
25867
25868 XIG=SQRT(PYALPS(-TH)/ALPRHT)
25869C.........TH LOOP
25870 ZTC(1,1)=DCMPLX(TH)
25871 ZTC(2,2)=DCMPLX(TH-PMAS(PYCOMP(3100021),1)**2)
25872 ZTC(3,3)=DCMPLX(TH-PMAS(PYCOMP(3100113),1)**2)
25873 ZTC(4,4)=DCMPLX(TH-PMAS(PYCOMP(3400113),1)**2)
25874 ZTC(5,5)=DCMPLX(TH-PMAS(PYCOMP(3200113),1)**2)
25875 ZTC(6,6)=DCMPLX(TH-PMAS(PYCOMP(3300113),1)**2)
25876 ZTC(1,2)=(0D0,0D0)
25877 ZTC(1,3)=DCMPLX(TH*XIG,0D0)
25878 ZTC(1,4)=ZTC(1,3)
25879 ZTC(1,5)=ZTC(1,2)
25880 ZTC(1,6)=ZTC(1,2)
25881 ZTC(2,3)=DCMPLX(TH*XIG*X11,0D0)
25882 ZTC(2,4)=DCMPLX(TH*XIG*X22,0D0)
25883 ZTC(2,5)=DCMPLX(TH*XIG*X12,0D0)
25884 ZTC(2,6)=DCMPLX(TH*XIG*X21,0D0)
25885 ZTC(3,4)=-SM1122
25886 ZTC(3,5)=-SM1112
25887 ZTC(3,6)=-SM1121
25888 ZTC(4,5)=-SM2212
25889 ZTC(4,6)=-SM2221
25890 ZTC(5,6)=-SM1221
25891 DO 160 I=1,5
25892 DO 150 J=I+1,6
25893 ZTC(J,I)=ZTC(I,J)
25894 150 CONTINUE
25895 160 CONTINUE
25896 CALL PYLDCM(ZTC,6,6,INDX,D)
25897 DO 180 I=1,6
25898 DO 170 J=1,6
25899 YTC(I,J)=(0D0,0D0)
25900 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
25901 170 CONTINUE
25902 180 CONTINUE
25903 DO 190 I=1,6
25904 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
25905 190 CONTINUE
25906 DGGT=YTC(1,1)
25907 DVVT=YTC(2,2)
25908 DGVT=YTC(1,2)
25909
25910 XIG=SQRT(PYALPS(-UH)/ALPRHT)
25911C.........UH LOOP
25912 ZTC(1,1)=DCMPLX(UH,0D0)
25913 ZTC(2,2)=DCMPLX(UH-PMAS(PYCOMP(3100021),1)**2)
25914 ZTC(3,3)=DCMPLX(UH-PMAS(PYCOMP(3100113),1)**2)
25915 ZTC(4,4)=DCMPLX(UH-PMAS(PYCOMP(3400113),1)**2)
25916 ZTC(5,5)=DCMPLX(UH-PMAS(PYCOMP(3200113),1)**2)
25917 ZTC(6,6)=DCMPLX(UH-PMAS(PYCOMP(3300113),1)**2)
25918 ZTC(1,2)=(0D0,0D0)
25919 ZTC(1,3)=DCMPLX(UH*XIG,0D0)
25920 ZTC(1,4)=ZTC(1,3)
25921 ZTC(1,5)=ZTC(1,2)
25922 ZTC(1,6)=ZTC(1,2)
25923 ZTC(2,3)=DCMPLX(UH*XIG*X11,0D0)
25924 ZTC(2,4)=DCMPLX(UH*XIG*X22,0D0)
25925 ZTC(2,5)=DCMPLX(UH*XIG*X12,0D0)
25926 ZTC(2,6)=DCMPLX(UH*XIG*X21,0D0)
25927 ZTC(3,4)=-SM1122
25928 ZTC(3,5)=-SM1112
25929 ZTC(3,6)=-SM1121
25930 ZTC(4,5)=-SM2212
25931 ZTC(4,6)=-SM2221
25932 ZTC(5,6)=-SM1221
25933 DO 210 I=1,5
25934 DO 200 J=I+1,6
25935 ZTC(J,I)=ZTC(I,J)
25936 200 CONTINUE
25937 210 CONTINUE
25938 CALL PYLDCM(ZTC,6,6,INDX,D)
25939 DO 230 I=1,6
25940 DO 220 J=1,6
25941 YTC(I,J)=(0D0,0D0)
25942 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
25943 220 CONTINUE
25944 230 CONTINUE
25945 DO 240 I=1,6
25946 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
25947 240 CONTINUE
25948 DGGU=YTC(1,1)
25949 DVVU=YTC(2,2)
25950 DGVU=YTC(1,2)
25951
25952 IF(IMDL.EQ.1) THEN
25953 DQQS=DGGS+DVVS*DCMPLX(TANT3**2)-DGVS*DCMPLX(2D0*TANT3)
25954 DQQT=DGGT+DVVT*DCMPLX(TANT3**2)-DGVT*DCMPLX(2D0*TANT3)
25955 DQQU=DGGU+DVVU*DCMPLX(TANT3**2)-DGVU*DCMPLX(2D0*TANT3)
25956 DQTS=DGGS-DVVS-DGVS*DCMPLX(TANT3-1D0/TANT3)
25957 DQGS=DGGS-DGVS*DCMPLX(TANT3)
25958 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
25959 ELSE
25960 DQQS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
25961 DQQT=DGGT+DVVT*DCMPLX(1D0/TANT3**2)+DGVT*DCMPLX(2D0/TANT3)
25962 DQQU=DGGU+DVVU*DCMPLX(1D0/TANT3**2)+DGVU*DCMPLX(2D0/TANT3)
25963 DQTS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
25964 DQGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
25965 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
25966 ENDIF
25967
25968 SQDQTS=ABS(DQTS)**2
25969 SQDQQS=ABS(DQQS)**2
25970 SQDQQT=ABS(DQQT)**2
25971 SQDQQU=ABS(DQQU)**2
25972 SQDLGS=ABS(DCMPLX(SH)*DQGS-DCMPLX(1D0))**2
25973 REDLGS=DBLE(DQGS)
25974 SQDHGS=ABS(DCMPLX(SH)*DTGS-DCMPLX(1D0))**2
25975 REDHGS=DBLE(DTGS)
25976 SQDLGT=ABS(DCMPLX(TH)*DGGT-DCMPLX(1D0))**2
25977
25978 SQDGGS=ABS(DGGS)**2
25979 SQDGGT=ABS(DGGT)**2
25980 SQDGGU=ABS(DGGU)**2
25981 REDGGS=DBLE(DGGS)
25982 REDGGT=DBLE(DGGT)
25983 REDGGU=DBLE(DGGU)
25984 REDGTU=DBLE(DGGU*DCONJG(DGGT))
25985 REDGSU=DBLE(DGGU*DCONJG(DGGS))
25986 REDGST=DBLE(DGGS*DCONJG(DGGT))
25987 REDQST=DBLE(DQQS*DCONJG(DQQT))
25988 REDQTU=DBLE(DQQT*DCONJG(DQQU))
25989 ENDIF
25990 ENDIF
25991
25992
25993C...Differential cross section expressions.
25994
25995 IF(ISUB.LE.190) THEN
25996 IF(ISUB.EQ.149) THEN
25997C...g + g -> eta_tc
25998 KCTC=PYCOMP(KTECHN+331)
25999 CALL PYWIDT(KTECHN+331,SH,WDTP,WDTE)
26000 HS=SHR*WDTP(0)
26001 FACBW=COMFAC*0.5D0/((SH-PMAS(KCTC,1)**2)**2+HS**2)
26002 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
26003 HP=SH
26004 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 250
26005 HI=HP*WDTP(3)
26006 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26007 NCHN=NCHN+1
26008 ISIG(NCHN,1)=21
26009 ISIG(NCHN,2)=21
26010 ISIG(NCHN,3)=1
26011 SIGH(NCHN)=HI*FACBW*HF
26012 250 CONTINUE
26013
26014 ELSEIF(ISUB.EQ.165) THEN
26015C...q + qbar -> l+ + l- (including contact term for compositeness)
26016 ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26017 ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26018 KFF=IABS(KFPR(ISUB,1))
26019 EF=KCHG(KFF,1)/3D0
26020 AF=SIGN(1D0,EF+0.1D0)
26021 VF=AF-4D0*EF*XWV
26022 VALF=VF+AF
26023 VARF=VF-AF
26024 FCOF=1D0
26025 IF(KFF.LE.10) FCOF=3D0
26026 WID2=1D0
26027 IF(KFF.EQ.6) WID2=WIDS(6,1)
26028 IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1)
26029 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
26030 DO 260 I=MMINA,MMAXA
26031 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 260
26032 EI=KCHG(IABS(I),1)/3D0
26033 AI=SIGN(1D0,EI+0.1D0)
26034 VI=AI-4D0*EI*XWV
26035 VALI=VI+AI
26036 VARI=VI-AI
26037 FCOI=1D0
26038 IF(IABS(I).LE.10) FCOI=FACA/3D0
26039 IF((ITCM(5).EQ.1.AND.IABS(I).LE.2).OR.ITCM(5).EQ.2) THEN
26040 FGZA=(EI*EF+VALI*VALF*ZRATR+RTCM(42)*SH/
26041 & (AEM*RTCM(41)**2))**2+(VALI*VALF*ZRATI)**2+
26042 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
26043 ELSE
26044 FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+
26045 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
26046 ENDIF
26047 FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+
26048 & (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2
26049 FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2)
26050 IF((ITCM(5).EQ.3.AND.IABS(I).EQ.2).OR.(ITCM(5).EQ.4.AND.
26051 & MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*RTCM(41)**4)
26052 NCHN=NCHN+1
26053 ISIG(NCHN,1)=I
26054 ISIG(NCHN,2)=-I
26055 ISIG(NCHN,3)=1
26056 SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2
26057 260 CONTINUE
26058
26059 ELSEIF(ISUB.EQ.166) THEN
26060C...q + q'bar -> l + nu_l (including contact term for compositeness)
26061 WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2)
26062 WCIFAC=WFAC+SH2/(4D0*RTCM(41)**4)
26063 KFF=IABS(KFPR(ISUB,1))
26064 FCOF=1D0
26065 IF(KFF.LE.10) FCOF=3D0
26066 DO 280 I=MMIN1,MMAX1
26067 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 280
26068 IA=IABS(I)
26069 DO 270 J=MMIN2,MMAX2
26070 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 270
26071 JA=IABS(J)
26072 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 270
26073 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
26074 & GOTO 270
26075 FCOI=1D0
26076 IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
26077 WID2=1D0
26078 IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND.
26079 & MOD(J,2).EQ.0)) THEN
26080 IF(KFF.EQ.5) WID2=WIDS(6,2)
26081 IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3)
26082 IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3)
26083 ELSE
26084 IF(KFF.EQ.5) WID2=WIDS(6,3)
26085 IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2)
26086 IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2)
26087 ENDIF
26088 NCHN=NCHN+1
26089 ISIG(NCHN,1)=I
26090 ISIG(NCHN,2)=J
26091 ISIG(NCHN,3)=1
26092 SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2
26093 IF((ITCM(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.ITCM(5).EQ.4)
26094 & SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2
26095 270 CONTINUE
26096 280 CONTINUE
26097 ENDIF
26098
26099 ELSEIF(ISUB.LE.200) THEN
26100 IF(ISUB.EQ.191) THEN
26101C...q + qbar -> rho_tc0.
26102 KCTC=PYCOMP(KTECHN+113)
26103 SQMRHT=PMAS(KCTC,1)**2
26104 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
26105 HS=SHR*WDTP(0)
26106 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
26107 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
26108 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26109 ALPRHT=2.91D0*(3D0/ITCM(1))
26110 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)
26111 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
26112 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26113 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26114 DO 290 I=MMINA,MMAXA
26115 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 290
26116 IA=IABS(I)
26117 EI=KCHG(IABS(I),1)/3D0
26118 AI=SIGN(1D0,EI+0.1D0)
26119 VI=AI-4D0*EI*XWV
26120 VALI=0.5D0*(VI+AI)
26121 VARI=0.5D0*(VI-AI)
26122 HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
26123 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
26124 IF(IA.LE.10) HI=HI*FACA/3D0
26125 NCHN=NCHN+1
26126 ISIG(NCHN,1)=I
26127 ISIG(NCHN,2)=-I
26128 ISIG(NCHN,3)=1
26129 SIGH(NCHN)=HI*FACBW*HF
26130 290 CONTINUE
26131
26132 ELSEIF(ISUB.EQ.192) THEN
26133C...q + qbar' -> rho_tc+/-.
26134 KCTC=PYCOMP(KTECHN+213)
26135 SQMRHT=PMAS(KCTC,1)**2
26136 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
26137 HS=SHR*WDTP(0)
26138 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
26139 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
26140 ALPRHT=2.91D0*(3D0/ITCM(1))
26141 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)*
26142 & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
26143 DO 310 I=MMIN1,MMAX1
26144 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 310
26145 IA=IABS(I)
26146 DO 300 J=MMIN2,MMAX2
26147 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 300
26148 JA=IABS(J)
26149 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 300
26150 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
26151 & GOTO 300
26152 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
26153 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4))
26154 HI=HP
26155 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
26156 NCHN=NCHN+1
26157 ISIG(NCHN,1)=I
26158 ISIG(NCHN,2)=J
26159 ISIG(NCHN,3)=1
26160 SIGH(NCHN)=HI*FACBW*HF
26161 300 CONTINUE
26162 310 CONTINUE
26163
26164 ELSEIF(ISUB.EQ.193) THEN
26165C...q + qbar -> omega_tc0.
26166 KCTC=PYCOMP(KTECHN+223)
26167 SQMOMT=PMAS(KCTC,1)**2
26168 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
26169 HS=SHR*WDTP(0)
26170 FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2)
26171 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
26172 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26173 ALPRHT=2.91D0*(3D0/ITCM(1))
26174 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)*
26175 & (2D0*RTCM(2)-1D0)**2
26176 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26177 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26178 DO 320 I=MMINA,MMAXA
26179 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
26180 IA=IABS(I)
26181 EI=KCHG(IABS(I),1)/3D0
26182 AI=SIGN(1D0,EI+0.1D0)
26183 VI=AI-4D0*EI*XWV
26184 VALI=0.5D0*(VI+AI)
26185 VARI=0.5D0*(VI-AI)
26186 HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
26187 & (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
26188 IF(IA.LE.10) HI=HI*FACA/3D0
26189 NCHN=NCHN+1
26190 ISIG(NCHN,1)=I
26191 ISIG(NCHN,2)=-I
26192 ISIG(NCHN,3)=1
26193 SIGH(NCHN)=HI*FACBW*HF
26194 320 CONTINUE
26195
26196 ELSEIF(ISUB.EQ.194) THEN
26197C...f + fbar -> f' + fbar' via s-channel rho_tc and omega_tc.
26198 KFA=KFPR(ISUBSV,1)
26199 ALPRHT=2.91D0*(3D0/ITCM(1))
26200 HP=AEM**2*COMFAC
26201 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
26202 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
26203
26204 QUPD=2D0*RTCM(2)-1D0
26205 FAR=SQRT(AEM/ALPRHT)
26206 FAO=FAR*QUPD
26207 FZR=FAR*CT2W
26208 FZO=-FAO*TANW
26209 SFAR=FAR**2
26210 SFAO=FAO**2
26211 SFZR=FZR**2
26212 SFZO=FZO**2
26213 CALL PYWIDT(23,SH,WDTP,WDTE)
26214 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
26215 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
26216 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
26217 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
26218 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
26219 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
26220 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
26221 DAA=(-Sfzr*SSMO - Sfzo*SSMR + SSMO*SSMR*SSMZ)/DETD/SH
26222 DZZ=(-Sfar*SSMO - Sfao*SSMR + SSMO*SSMR)/DETD/SH
26223 DAZ=(far*fzr*SSMO + fao*fzo*SSMR)/DETD/SH
26224
26225 XWRHT=1D0/(4D0*XW*(1D0-XW))
26226 KFF=IABS(KFPR(ISUB,1))
26227 EF=KCHG(KFF,1)/3D0
26228 AF=SIGN(1D0,EF+0.1D0)
26229 VF=AF-4D0*EF*XWV
26230 VALF=0.5D0*(VF+AF)
26231 VARF=0.5D0*(VF-AF)
26232 FCOF=1D0
26233 IF(KFF.LE.10) FCOF=3D0
26234
26235 WID2=1D0
26236 IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1)
26237 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
26238 DZZ=DZZ*DCMPLX(XWRHT,0D0)
26239 DAZ=DAZ*DCMPLX(SQRT(XWRHT),0D0)
26240
26241 DO 330 I=MMINA,MMAXA
26242 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 330
26243 EI=KCHG(IABS(I),1)/3D0
26244 AI=SIGN(1D0,EI+0.1D0)
26245 VI=AI-4D0*EI*XWV
26246 VALI=0.5D0*(VI+AI)
26247 VARI=0.5D0*(VI-AI)
26248 FCOI=FCOF
26249 IF(IABS(I).LE.10) FCOI=FCOI/3D0
26250 DIFLL=ABS(EI*EF*DAA+VALI*VALF*DZZ+DAZ*(EI*VALF+EF*VALI))**2
26251 DIFRR=ABS(EI*EF*DAA+VARI*VARF*DZZ+DAZ*(EI*VARF+EF*VARI))**2
26252 DIFLR=ABS(EI*EF*DAA+VALI*VARF*DZZ+DAZ*(EI*VARF+EF*VALI))**2
26253 DIFRL=ABS(EI*EF*DAA+VARI*VALF*DZZ+DAZ*(EI*VALF+EF*VARI))**2
26254 FACSIG=(DIFLL+DIFRR)*((UH-SQM4)**2+SH*SQM4)+
26255 & (DIFLR+DIFRL)*((TH-SQM3)**2+SH*SQM3)
26256 NCHN=NCHN+1
26257 ISIG(NCHN,1)=I
26258 ISIG(NCHN,2)=-I
26259 ISIG(NCHN,3)=1
26260 SIGH(NCHN)=HP*FCOI*FACSIG*WID2
26261 330 CONTINUE
26262
26263 ELSEIF(ISUB.EQ.195) THEN
26264C...f + fbar' -> f'' + fbar''' via s-channel rho_tc+
26265 KFA=KFPR(ISUBSV,1)
26266 KFB=KFA+1
26267 ALPRHT=2.91D0*(3D0/ITCM(1))
26268 FACTC=COMFAC*(AEM**2/12D0/XW**2)*(UH-SQM3)*(UH-SQM4)*3D0
26269
26270 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
26271 CALL PYWIDT(24,SH,WDTP,WDTE)
26272 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
26273 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
26274 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
26275
26276 FCOF=1D0
26277 IF(KFA.LE.8) FCOF=3D0
26278 DETD=SSMZ*SSMR-DCMPLX(FWR**2,0D0)
26279 HP=FACTC*ABS(SSMR/DETD)**2/SH**2*FCOF
26280
26281 DO 350 I=MMIN1,MMAX1
26282 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 350
26283 IA=IABS(I)
26284 DO 340 J=MMIN2,MMAX2
26285 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 340
26286 JA=IABS(J)
26287 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 340
26288 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
26289 & GOTO 340
26290 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
26291 HI=HP
26292 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
26293 NCHN=NCHN+1
26294 ISIG(NCHN,1)=I
26295 ISIG(NCHN,2)=J
26296 ISIG(NCHN,3)=1
26297 SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,(5+KCHR)/2)
26298 340 CONTINUE
26299 350 CONTINUE
26300 ENDIF
26301
26302 ELSEIF(ISUB.LE.380) THEN
26303 IF(ISUB.EQ.361) THEN
26304C...f + fbar -> W_L W_L, W_L pi_tc, pi_tc pi_tc
26305 FACA=(SH**2*BE34**2-(TH-UH)**2)
26306 ALPRHT=2.91D0*(3D0/ITCM(1))
26307 HP=(1D0/12D0)*AEM**2*CAB2*COMFAC*FACA*3D0
26308 FAR=SQRT(AEM/ALPRHT)
26309 FAO=FAR*QUPD
26310 FZR=FAR*CT2W
26311 FZO=-FAO*TANW
26312 SFAR=FAR**2
26313 SFAO=FAO**2
26314 SFZR=FZR**2
26315 SFZO=FZO**2
26316 CALL PYWIDT(23,SH,WDTP,WDTE)
26317 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
26318 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
26319 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
26320 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
26321 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
26322 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
26323 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
26324 DARHO=-(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)/DETD/SH
26325 DZRHO=-(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH
26326 DAA=-(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)/DETD/SH
26327 DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH
26328 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH
26329
26330 DO 360 I=MMINA,MMAXA
26331 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 360
26332 IA=IABS(I)
26333 EI=KCHG(IABS(I),1)/3D0
26334 AI=SIGN(1D0,EI+0.1D0)
26335 VI=AI-4D0*EI*XWV
26336 VALI=0.25D0*(VI+AI)
26337 VARI=0.25D0*(VI-AI)
26338 F2L=EI*(DARHO/FAR+DAA+CT2W*DAZ)+
26339 $ VALI*(CT2W*DZRHO/FZR+CT2W*DZZ+DAZ)/SQRT(XW*XW1)
26340 F2R=EI*(DARHO/FAR+DAA+CT2W*DAZ)+
26341 $ VARI*(CT2W*DZRHO/FZR+CT2W*DZZ+DAZ)/SQRT(XW*XW1)
26342 HI=ABS(F2L)**2+ABS(F2R)**2
26343 IF(IA.LE.10) HI=HI/3D0
26344 NCHN=NCHN+1
26345 ISIG(NCHN,1)=I
26346 ISIG(NCHN,2)=-I
26347 ISIG(NCHN,3)=1
26348 IF(KFA.EQ.KFB) THEN
26349 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),1)
26350 ELSE
26351 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
26352 NCHN=NCHN+1
26353 ISIG(NCHN,1)=I
26354 ISIG(NCHN,2)=-I
26355 ISIG(NCHN,3)=2
26356 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
26357 ENDIF
26358 360 CONTINUE
26359
26360 ELSEIF(ISUB.EQ.364) THEN
26361C...f + fbar -> gamma pi_tc, gamma pi_tc', Z pi_tc, Z pi_tc',
26362C...W pi_tc
26363 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
26364 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
26365 FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
26366
26367 ALPRHT=2.91D0*(3D0/ITCM(1))
26368 HP=(1D0/24D0)*AEM**2*COMFAC*3D0*SH
26369 FAR=SQRT(AEM/ALPRHT)
26370 FAO=FAR*QUPD
26371 FZR=FAR*CT2W
26372 FZO=-FAO*TANW
26373 SFAR=FAR**2
26374 SFAO=FAO**2
26375 SFZR=FZR**2
26376 SFZO=FZO**2
26377 CALL PYWIDT(23,SH,WDTP,WDTE)
26378 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
26379 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
26380 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
26381 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
26382 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
26383 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
26384 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
26385 DARHO=(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)/DETD/SH
26386 DZRHO=(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH
26387 DAOME=(-FAO*SFZR+FAR*FZO*FZR+FAO*SSMR*SSMZ)/DETD/SH
26388 DZOME=(-FZO*SFAR+FAR*FAO*FZR+FZO*SSMR)/DETD/SH
26389 DAA=(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)/DETD/SH
26390 DZZ=(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH
26391 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH
26392
26393 DO 370 I=MMINA,MMAXA
26394 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 370
26395 IA=IABS(I)
26396 EI=KCHG(IABS(I),1)/3D0
26397 AI=SIGN(1D0,EI+0.1D0)
26398 VI=AI-4D0*EI*XWV
26399 VALI=0.25D0*(VI+AI)
26400 VARI=0.25D0*(VI-AI)
26401C...........Add in anomaly contribution
26402 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*VRGP
26403 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*VOGP
26404 F2L=F2L+FANOM*(VAGP*(EI*DAA+VALI*DAZ/SQRT(XW*XW1))+
26405 $ VZGP*(EI*DAZ+VALI*DZZ/SQRT(XW*XW1)))
26406 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*VRGP
26407 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*VOGP
26408 F2R=F2R+FANOM*(VAGP*(EI*DAA+VARI*DAZ/SQRT(XW*XW1))+
26409 $ VZGP*(EI*DAZ+VARI*DZZ/SQRT(XW*XW1)))
26410 HI=(ABS(F2L)**2+ABS(F2R)**2)*VFAC
26411 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*ARGP
26412 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*AOGP
26413 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*ARGP
26414 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*AOGP
26415 HJ=(ABS(F2L)**2+ABS(F2R)**2)*AFAC
26416 HI=HI+HJ
26417 IF(IA.LE.10) HI=HI/3D0
26418 NCHN=NCHN+1
26419 ISIG(NCHN,1)=I
26420 ISIG(NCHN,2)=-I
26421 ISIG(NCHN,3)=1
26422 IF(ISUBSV.NE.368) THEN
26423 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),2)
26424 ELSE
26425 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
26426 NCHN=NCHN+1
26427 ISIG(NCHN,1)=I
26428 ISIG(NCHN,2)=-I
26429 ISIG(NCHN,3)=2
26430 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
26431 ENDIF
26432 370 CONTINUE
26433
26434 ELSEIF(ISUB.EQ.370) THEN
26435C...f + fbar' -> W_L Z_L, W_L pi_tc, Z_L pi_tc, pi_tc pi_tc
26436
26437 FACA=(SH**2*BE34**2-(TH-UH)**2)
26438 ALPRHT=2.91D0*(3D0/ITCM(1))
26439 HP=(1D0/96D0)*AEM**2*CAB2*COMFAC*FACA*3D0/XW**2
26440 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
26441 CALL PYWIDT(24,SH,WDTP,WDTE)
26442 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
26443 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
26444 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
26445 DETD=SSMZ*SSMR-DCMPLX(FWR**2,0D0)
26446 DWW=SSMR/DETD/SH
26447 DWRHO=-1D0/DETD/SH
26448 HP=HP*ABS(DWW+DWRHO)**2
26449 DO 390 I=MMIN1,MMAX1
26450 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 390
26451 IA=IABS(I)
26452 DO 380 J=MMIN2,MMAX2
26453 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 380
26454 JA=IABS(J)
26455 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 380
26456 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
26457 & GOTO 380
26458 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
26459 HI=HP
26460 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
26461 NCHN=NCHN+1
26462 ISIG(NCHN,1)=I
26463 ISIG(NCHN,2)=J
26464 ISIG(NCHN,3)=1
26465 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
26466 & WIDS(PYCOMP(KFB),2)
26467 380 CONTINUE
26468 390 CONTINUE
26469
26470 ELSEIF(ISUB.EQ.374) THEN
26471C...f + fbar' -> gamma pi_tc
26472 FANOM=SQRT(AEM)*ITCM(1)/2D0/PARU(2)/RTCM(1)
26473 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
26474 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)/SQTA*ARGP**2
26475 ALPRHT=2.91D0*(3D0/ITCM(1))
26476 HP=(1D0/48D0)*AEM**2/XW*COMFAC*3D0*SH
26477 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
26478 CALL PYWIDT(24,SH,WDTP,WDTE)
26479 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
26480 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
26481 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
26482 DETD=SSMZ*SSMR-DCMPLX(FWR**2,0D0)
26483 DWW=SSMR/DETD/SH
26484 DWRHO=-DCMPLX(FWR,0D0)/DETD/SH
26485 HP=HP*(AFAC*ABS(DWRHO)**2+
26486 $ VFAC*ABS(FANOM*DWW*VWGP+DWRHO*VRGP/SQRT(SQTV))**2)
26487 DO 410 I=MMIN1,MMAX1
26488 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410
26489 IA=IABS(I)
26490 DO 400 J=MMIN2,MMAX2
26491 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 400
26492 JA=IABS(J)
26493 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 400
26494 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
26495 & GOTO 400
26496 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
26497 HI=HP
26498 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
26499 NCHN=NCHN+1
26500 ISIG(NCHN,1)=I
26501 ISIG(NCHN,2)=J
26502 ISIG(NCHN,3)=1
26503 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
26504 & WIDS(PYCOMP(KFB),2)
26505 400 CONTINUE
26506 410 CONTINUE
26507 ENDIF
26508
26509 ELSEIF(ISUB.LE.390) THEN
26510 IF(ISUB.EQ.381) THEN
26511C...f + f' -> f + f' (g exchange)
26512 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)*SQDQQT
26513 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)*SQDQQT*FACA-
26514 & MSTP(34)*2D0/3D0*UH2*REDQST)
26515 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)*SQDQQU
26516 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
26517 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
26518 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
26519C...Modifications from contact interactions (compositeness)
26520 FACCI1=FACQQ1+COMFAC*(SH2/RTCM(41)**4)
26521 FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
26522 & (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/RTCM(41)**4)
26523 FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
26524 & (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/RTCM(41)**4)
26525 FACCI3=FACQQ1+COMFAC*(UH2/RTCM(41)**4)
26526 RATCII=(FACCI1*FACCI2+FACQQI)/(FACCI1+FACCI2)
26527 ELSEIF(ITCM(5).EQ.5) THEN
26528 FACCI1=FACQQ1
26529 FACCIB=FACQQB
26530 FACCI2=FACQQ2
26531 FACCI3=FACQQ1
26532CSM.......Check this change from
26533CSM RATCII=1D0
26534 RATCII=RATQQI
26535 ENDIF
26536 DO 430 I=MMIN1,MMAX1
26537 IA=IABS(I)
26538 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
26539 DO 420 J=MMIN2,MMAX2
26540 JA=IABS(J)
26541 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
26542 NCHN=NCHN+1
26543 ISIG(NCHN,1)=I
26544 ISIG(NCHN,2)=J
26545 ISIG(NCHN,3)=1
26546 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.(IA.GE.3.OR.
26547 & JA.GE.3))) THEN
26548 SIGH(NCHN)=FACQQ1
26549 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
26550 ELSE
26551 SIGH(NCHN)=FACCI1
26552 IF(I*J.LT.0) SIGH(NCHN)=FACCI3
26553 IF(I.EQ.-J) SIGH(NCHN)=FACCIB
26554 ENDIF
26555 IF(I.EQ.J) THEN
26556 NCHN=NCHN+1
26557 ISIG(NCHN,1)=I
26558 ISIG(NCHN,2)=J
26559 ISIG(NCHN,3)=2
26560 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IA.GE.3)) THEN
26561 SIGH(NCHN-1)=0.5D0*FACQQ1*RATQQI
26562 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
26563 ELSE
26564 SIGH(NCHN-1)=0.5D0*FACCI1*RATCII
26565 SIGH(NCHN)=0.5D0*FACCI2*RATCII
26566 ENDIF
26567 ENDIF
26568 420 CONTINUE
26569 430 CONTINUE
26570
26571 ELSEIF(ISUB.EQ.382) THEN
26572C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
26573 CALL PYWIDT(21,SH,WDTP,WDTE)
26574 FACQQF=COMFAC*AS**2*4D0/9D0*(TH2+UH2)
26575 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26576 IF(ITCM(5).EQ.1) THEN
26577C...Modifications from contact interactions (compositeness)
26578 FACCIB=FACQQB
26579 DO 440 I=1,2
26580 FACCIB=FACCIB+COMFAC*(UH2/RTCM(41)**4)*(WDTE(I,1)+
26581 & WDTE(I,2)+WDTE(I,4))
26582 440 CONTINUE
26583 ELSEIF(ITCM(5).GE.2.AND.ITCM(5).LE.4) THEN
26584 FACCIB=FACQQB+COMFAC*(UH2/RTCM(41)**4)*
26585 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26586 ELSEIF(ITCM(5).EQ.5) THEN
26587 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)-
26588 & WDTE(5,1)-WDTE(5,2)-WDTE(5,4))
26589 FACCIB=FACQQF*SQDQTS*(WDTE(5,1)+WDTE(5,2)+WDTE(5,4))
26590 ENDIF
26591 DO 450 I=MMINA,MMAXA
26592 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
26593 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 450
26594 NCHN=NCHN+1
26595 ISIG(NCHN,1)=I
26596 ISIG(NCHN,2)=-I
26597 ISIG(NCHN,3)=1
26598 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IABS(I).GE.3)) THEN
26599 SIGH(NCHN)=FACQQB
26600 ELSEIF(ITCM(5).EQ.5) THEN
26601 SIGH(NCHN)=FACQQB
26602 NCHN=NCHN+1
26603 ISIG(NCHN,1)=I
26604 ISIG(NCHN,2)=-I
26605 ISIG(NCHN,3)=2
26606 SIGH(NCHN)=FACCIB
26607 ELSE
26608 SIGH(NCHN)=FACCIB
26609 ENDIF
26610 450 CONTINUE
26611
26612 ELSEIF(ISUB.EQ.383) THEN
26613C...f + fbar -> g + g (q + qbar -> g + g only)
26614 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
26615 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
26616 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
26617 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
26618 IF(ITCM(5).EQ.5) THEN
26619 FACGG3=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
26620 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
26621 FACGG4=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
26622 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
26623 ENDIF
26624 DO 460 I=MMINA,MMAXA
26625 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
26626 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
26627 NCHN=NCHN+1
26628 ISIG(NCHN,1)=I
26629 ISIG(NCHN,2)=-I
26630 ISIG(NCHN,3)=1
26631 SIGH(NCHN)=0.5D0*FACGG1
26632 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG3
26633 NCHN=NCHN+1
26634 ISIG(NCHN,1)=I
26635 ISIG(NCHN,2)=-I
26636 ISIG(NCHN,3)=2
26637 SIGH(NCHN)=0.5D0*FACGG2
26638 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG4
26639 460 CONTINUE
26640
26641 ELSEIF(ISUB.EQ.384) THEN
26642C...f + g -> f + g (q + g -> q + g only)
26643 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
26644 & UH/SH-9D0/4D0*SH*UH/TH2*SQDLGT)*FACA
26645 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
26646 & SH/UH-9D0/4D0*SH*UH/TH2*SQDLGT)
26647 DO 480 I=MMINA,MMAXA
26648 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 480
26649 DO 470 ISDE=1,2
26650 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 470
26651 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 470
26652 NCHN=NCHN+1
26653 ISIG(NCHN,ISDE)=I
26654 ISIG(NCHN,3-ISDE)=21
26655 ISIG(NCHN,3)=1
26656 SIGH(NCHN)=FACQG1
26657 NCHN=NCHN+1
26658 ISIG(NCHN,ISDE)=I
26659 ISIG(NCHN,3-ISDE)=21
26660 ISIG(NCHN,3)=2
26661 SIGH(NCHN)=FACQG2
26662 470 CONTINUE
26663 480 CONTINUE
26664
26665 ELSEIF(ISUB.EQ.385) THEN
26666C...g + g -> f + fbar (g + g -> q + qbar only)
26667 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 500
26668 IDC0=MDCY(21,2)-1
26669C...Begin by d, u, s flavours.
26670 FLAVWT=0D0
26671 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
26672 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
26673 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
26674 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
26675 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
26676 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
26677 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
26678 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
26679 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
26680 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
26681 NCHN=NCHN+1
26682 ISIG(NCHN,1)=21
26683 ISIG(NCHN,2)=21
26684 ISIG(NCHN,3)=1
26685 SIGH(NCHN)=FACQQ1
26686 NCHN=NCHN+1
26687 ISIG(NCHN,1)=21
26688 ISIG(NCHN,2)=21
26689 ISIG(NCHN,3)=2
26690 SIGH(NCHN)=FACQQ2
26691C...Next c and b flavours: modified that and uhat for fixed
26692C...cos(theta-hat).
26693 DO 490 IFL=4,5
26694 SQMAVG=PMAS(IFL,1)**2
26695 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
26696 BE34=SQRT(1D0-4D0*SQMAVG/SH)
26697 THQ=-0.5D0*SH*(1D0-BE34*CTH)
26698 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
26699 THUHQ=THQ*UHQ-SQMAVG*SH
26700 IF(MSTP(34).EQ.0) THEN
26701 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
26702 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
26703 ELSE
26704 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
26705 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
26706 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
26707 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
26708 ENDIF
26709 IF(ITCM(5).GE.5) THEN
26710 IF(IFL.EQ.4) THEN
26711 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
26712 & 2.25D0*THQ*UHQ/SH2*SQDLGS
26713 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
26714 & 2.25D0*THQ*UHQ/SH2*SQDLGS
26715 ELSE
26716 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
26717 & 2.25D0*THQ*UHQ/SH2*SQDHGS
26718 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
26719 & 2.25D0*THQ*UHQ/SH2*SQDHGS
26720 ENDIF
26721 ENDIF
26722 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
26723 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
26724 NCHN=NCHN+1
26725 ISIG(NCHN,1)=21
26726 ISIG(NCHN,2)=21
26727 ISIG(NCHN,3)=1+2*(IFL-3)
26728 SIGH(NCHN)=FACQQ1
26729 NCHN=NCHN+1
26730 ISIG(NCHN,1)=21
26731 ISIG(NCHN,2)=21
26732 ISIG(NCHN,3)=2+2*(IFL-3)
26733 SIGH(NCHN)=FACQQ2
26734 ENDIF
26735 490 CONTINUE
26736 500 CONTINUE
26737
26738 ELSEIF(ISUB.EQ.386) THEN
26739C...g + g -> g + g
26740 IF(ITCM(5).LE.4) THEN
26741 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
26742 & 2D0*TH/SH+TH2/SH2)*FACA
26743 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
26744 & 2D0*SH/UH+SH2/UH2)*FACA
26745 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+
26746 & 2D0*UH/TH+UH2/TH2)
26747 ELSE
26748 GST= (12D0 + 40D0*TH/SH + 56D0*TH2/SH2 + 32D0*TH**3/SH**3 +
26749 & 16D0*TH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*TH + 16D0*TH2)+
26750 & 4D0*REDGST*(SH + 2D0*TH)*
26751 & (2D0*SH**3 - 3D0*SH2*TH - 2D0*SH*TH2 + 2D0*TH**3)/SH2 +
26752 & 2D0*REDGGS*(2D0*SH - 12D0*TH2/SH - 8D0*TH**3/SH2) +
26753 & 2D0*REDGGT*(4D0*SH - 22D0*TH - 68D0*TH2/SH - 60D0*TH**3/SH2-
26754 & 32D0*TH**4/SH**3 - 16D0*TH**5/SH**4) +
26755 & SQDGGT*(16D0*SH2 + 16D0*SH*TH + 68D0*TH2 + 144D0*TH**3/SH +
26756 & 96D0*TH**4/SH2 + 32D0*TH**5/SH**3 + 16D0*TH**6/SH**4))/16D0
26757 GSU= (12D0 + 40D0*UH/SH + 56D0*UH2/SH2 + 32D0*UH**3/SH**3 +
26758 & 16D0*UH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*UH + 16D0*UH2)+
26759 & 4D0*REDGSU*(SH + 2D0*UH)*
26760 & (2D0*SH**3 - 3D0*SH2*UH - 2D0*SH*UH2 + 2D0*UH**3)/SH2 +
26761 & 2D0*REDGGS*(2D0*SH - 12D0*UH2/SH - 8D0*UH**3/SH2) +
26762 & 2D0*REDGGU*(4D0*SH - 22D0*UH - 68D0*UH2/SH - 60D0*UH**3/SH2-
26763 & 32D0*UH**4/SH**3 - 16D0*UH**5/SH**4) +
26764 & SQDGGU*(16D0*SH2 + 16D0*SH*UH + 68D0*UH2 + 144D0*UH**3/SH +
26765 & 96D0*UH**4/SH2 + 32D0*UH**5/SH**3 + 16D0*UH**6/SH**4))/16D0
26766 GUT= (12D0 - 16D0*TH*(TH - UH)**2*UH/SH**4 +
26767 & 4D0*REDGGU*(2D0*TH**5 - 15D0*TH**4*UH - 48D0*TH**3*UH2 -
26768 & 58D0*TH2*UH**3 - 10D0*TH*UH**4 + UH**5)/SH**4 +
26769 & 4D0*REDGGT*(TH**5 - 10D0*TH**4*UH - 58D0*TH**3*UH2 -
26770 & 48D0*TH2*UH**3 - 15D0*TH*UH**4 + 2D0*UH**5)/SH**4 +
26771 & 4D0*SQDGGU*(4D0*TH**6 + 20D0*TH**5*UH + 57D0*TH**4*UH2 +
26772 & 72D0*TH**3*UH**3+ 38D0*TH2*UH**4+4D0*TH*UH**5 +UH**6)/SH**4+
26773 & 4D0*SQDGGT*(4D0*UH**6 + 4D0*TH**5*UH + 38D0*TH**4*UH2 +
26774 & 72D0*TH**3*UH**3 +57D0*TH2*UH**4+20D0*TH*UH**5+TH**6)/SH**4+
26775 & 2D0*REDGTU*((TH - UH)**2* (TH**4 + 20D0*TH**3*UH +
26776 & 30D0*TH2*UH2 + 20D0*TH*UH**3 + UH**4) +
26777 & SH2*(7D0*TH**4 + 52D0*TH**3*UH + 274D0*TH2*UH2 +
26778 & 52D0*TH*UH**3 + 7D0*UH**4))/(2D0*SH**4))/16D0
26779 FACGG1=COMFAC*AS**2*9D0/4D0*GST*FACA
26780 FACGG2=COMFAC*AS**2*9D0/4D0*GSU*FACA
26781 FACGG3=COMFAC*AS**2*9D0/4D0*GUT
26782 ENDIF
26783 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 510
26784 NCHN=NCHN+1
26785 ISIG(NCHN,1)=21
26786 ISIG(NCHN,2)=21
26787 ISIG(NCHN,3)=1
26788 SIGH(NCHN)=0.5D0*FACGG1
26789 NCHN=NCHN+1
26790 ISIG(NCHN,1)=21
26791 ISIG(NCHN,2)=21
26792 ISIG(NCHN,3)=2
26793 SIGH(NCHN)=0.5D0*FACGG2
26794 NCHN=NCHN+1
26795 ISIG(NCHN,1)=21
26796 ISIG(NCHN,2)=21
26797 ISIG(NCHN,3)=3
26798 SIGH(NCHN)=0.5D0*FACGG3
26799 510 CONTINUE
26800
26801 ELSEIF(ISUB.EQ.387) THEN
26802C...q + qbar -> Q + Qbar
26803 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
26804 THQ=-0.5D0*SH*(1D0-BE34*CTH)
26805 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
26806 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
26807 & 2D0*SQMAVG/SH)
26808 IF(ITCM(5).GE.5) THEN
26809 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
26810 FACQQB=FACQQB*SH2*SQDQTS
26811 ELSE
26812 FACQQB=FACQQB*SH2*SQDQQS
26813 ENDIF
26814 ENDIF
26815 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
26816 WID2=1D0
26817 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
26818 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
26819 FACQQB=FACQQB*WID2
26820 DO 520 I=MMINA,MMAXA
26821 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
26822 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 520
26823 NCHN=NCHN+1
26824 ISIG(NCHN,1)=I
26825 ISIG(NCHN,2)=-I
26826 ISIG(NCHN,3)=1
26827 SIGH(NCHN)=FACQQB
26828 520 CONTINUE
26829
26830 ELSEIF(ISUB.EQ.388) THEN
26831C...g + g -> Q + Qbar
26832 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
26833 THQ=-0.5D0*SH*(1D0-BE34*CTH)
26834 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
26835 THUHQ=THQ*UHQ-SQMAVG*SH
26836 IF(MSTP(34).EQ.0) THEN
26837 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
26838 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
26839 ELSE
26840 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
26841 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
26842 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
26843 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
26844 ENDIF
26845 IF(ITCM(5).GE.5) THEN
26846 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
26847 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
26848 & 2.25D0*THQ*UHQ/SH2*SQDHGS
26849 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
26850 & 2.25D0*THQ*UHQ/SH2*SQDHGS
26851 ELSE
26852 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
26853 & 2.25D0*THQ*UHQ/SH2*SQDLGS
26854 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
26855 & 2.25D0*THQ*UHQ/SH2*SQDLGS
26856 ENDIF
26857 ENDIF
26858 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
26859 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
26860 IF(MSTP(35).GE.1) THEN
26861 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
26862 FACQQ1=FACQQ1*FATRE
26863 FACQQ2=FACQQ2*FATRE
26864 ENDIF
26865 WID2=1D0
26866 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
26867 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
26868 FACQQ1=FACQQ1*WID2
26869 FACQQ2=FACQQ2*WID2
26870 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 530
26871 NCHN=NCHN+1
26872 ISIG(NCHN,1)=21
26873 ISIG(NCHN,2)=21
26874 ISIG(NCHN,3)=1
26875 SIGH(NCHN)=FACQQ1
26876 NCHN=NCHN+1
26877 ISIG(NCHN,1)=21
26878 ISIG(NCHN,2)=21
26879 ISIG(NCHN,3)=2
26880 SIGH(NCHN)=FACQQ2
26881 530 CONTINUE
26882 ENDIF
26883 ENDIF
26884
26885CMRENNA--
26886
26887 RETURN
26888 END
26889
26890C*********************************************************************
26891
26892C...PYSGEX
26893C...Subprocess cross sections for assorted exotic processes,
26894C...including Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*.
26895C...Auxiliary to PYSIGH.
26896
26897 SUBROUTINE PYSGEX(NCHN,SIGS)
26898
26899C...Double precision and integer declarations
26900 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26901 IMPLICIT INTEGER(I-N)
26902 INTEGER PYK,PYCHGE,PYCOMP
26903C...Parameter statement to help give large particle numbers.
26904 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
26905 &KEXCIT=4000000,KDIMEN=5000000)
26906C...Commonblocks
26907 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
26908 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
26909 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
26910 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
26911 COMMON/PYINT1/MINT(400),VINT(400)
26912 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
26913 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
26914 COMMON/PYINT4/MWID(500),WIDS(500,5)
26915 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
26916 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
26917 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
26918 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
26919 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
26920 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
26921 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
26922C...Local arrays
26923 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
26924
26925C...Differential cross section expressions.
26926
26927 IF(ISUB.LE.160) THEN
26928 IF(ISUB.EQ.141) THEN
26929C...f + fbar -> gamma*/Z0/Z'0
26930 SQMZP=PMAS(32,1)**2
26931 MINT(61)=2
26932 CALL PYWIDT(32,SH,WDTP,WDTE)
26933 HP0=AEM/3D0*SH
26934 HP1=AEM/3D0*XWC*SH
26935 HP2=HP1
26936 HS=SHR*VINT(117)
26937 HSP=SHR*WDTP(0)
26938 FACZP=4D0*COMFAC*3D0
26939 DO 100 I=MMINA,MMAXA
26940 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
26941 EI=KCHG(IABS(I),1)/3D0
26942 AI=SIGN(1D0,EI)
26943 VI=AI-4D0*EI*XWV
26944 IA=IABS(I)
26945 IF(IA.LT.10) THEN
26946 IF(IA.LE.2) THEN
26947 VPI=PARU(123-2*MOD(IABS(I),2))
26948 API=PARU(124-2*MOD(IABS(I),2))
26949 ELSEIF(IA.LE.4) THEN
26950 VPI=PARJ(182-2*MOD(IABS(I),2))
26951 API=PARJ(183-2*MOD(IABS(I),2))
26952 ELSE
26953 VPI=PARJ(190-2*MOD(IABS(I),2))
26954 API=PARJ(191-2*MOD(IABS(I),2))
26955 ENDIF
26956 ELSE
26957 IF(IA.LE.12) THEN
26958 VPI=PARU(127-2*MOD(IABS(I),2))
26959 API=PARU(128-2*MOD(IABS(I),2))
26960 ELSEIF(IA.LE.14) THEN
26961 VPI=PARJ(186-2*MOD(IABS(I),2))
26962 API=PARJ(187-2*MOD(IABS(I),2))
26963 ELSE
26964 VPI=PARJ(194-2*MOD(IABS(I),2))
26965 API=PARJ(195-2*MOD(IABS(I),2))
26966 ENDIF
26967 ENDIF
26968 HI0=HP0
26969 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
26970 HI1=HP1
26971 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
26972 HI2=HP2
26973 IF(IABS(I).LE.10) HI2=HI2*FACA/3D0
26974 NCHN=NCHN+1
26975 ISIG(NCHN,1)=I
26976 ISIG(NCHN,2)=-I
26977 ISIG(NCHN,3)=1
26978 SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI*
26979 & (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)*
26980 & VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)*
26981 & (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/
26982 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)*
26983 & ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)*
26984 & ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+
26985 & (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116))
26986 100 CONTINUE
26987
26988 ELSEIF(ISUB.EQ.142) THEN
26989C...f + fbar' -> W'+/-
26990 SQMWP=PMAS(34,1)**2
26991 CALL PYWIDT(34,SH,WDTP,WDTE)
26992 HS=SHR*WDTP(0)
26993 FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0
26994 HP=AEM/(24D0*XW)*SH
26995 DO 120 I=MMIN1,MMAX1
26996 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
26997 IA=IABS(I)
26998 DO 110 J=MMIN2,MMAX2
26999 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
27000 JA=IABS(J)
27001 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
27002 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
27003 & GOTO 110
27004 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
27005 HI=HP*(PARU(133)**2+PARU(134)**2)
27006 IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)*
27007 & VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
27008 NCHN=NCHN+1
27009 ISIG(NCHN,1)=I
27010 ISIG(NCHN,2)=J
27011 ISIG(NCHN,3)=1
27012 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
27013 SIGH(NCHN)=HI*FACBW*HF
27014 110 CONTINUE
27015 120 CONTINUE
27016
27017 ELSEIF(ISUB.EQ.144) THEN
27018C...f + fbar' -> R
27019 SQMR=PMAS(41,1)**2
27020 CALL PYWIDT(41,SH,WDTP,WDTE)
27021 HS=SHR*WDTP(0)
27022 FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0
27023 HP=AEM/(12D0*XW)*SH
27024 DO 140 I=MMIN1,MMAX1
27025 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
27026 IA=IABS(I)
27027 DO 130 J=MMIN2,MMAX2
27028 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
27029 JA=IABS(J)
27030 IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 130
27031 HI=HP
27032 IF(IA.LE.10) HI=HI*FACA/3D0
27033 HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
27034 NCHN=NCHN+1
27035 ISIG(NCHN,1)=I
27036 ISIG(NCHN,2)=J
27037 ISIG(NCHN,3)=1
27038 SIGH(NCHN)=HI*FACBW*HF
27039 130 CONTINUE
27040 140 CONTINUE
27041
27042 ELSEIF(ISUB.EQ.145) THEN
27043C...q + l -> LQ (leptoquark)
27044 SQMLQ=PMAS(42,1)**2
27045 CALL PYWIDT(42,SH,WDTP,WDTE)
27046 HS=SHR*WDTP(0)
27047 FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2)
27048 IF(ABS(SHR-PMAS(42,1)).GT.PARP(48)*PMAS(42,2)) FACBW=0D0
27049 HP=AEM/4D0*SH
27050 KFLQQ=KFDP(MDCY(42,2),1)
27051 KFLQL=KFDP(MDCY(42,2),2)
27052 DO 160 I=MMIN1,MMAX1
27053 IF(KFAC(1,I).EQ.0) GOTO 160
27054 IA=IABS(I)
27055 IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 160
27056 DO 150 J=MMIN2,MMAX2
27057 IF(KFAC(2,J).EQ.0) GOTO 150
27058 JA=IABS(J)
27059 IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 150
27060 IF(I*J.NE.KFLQQ*KFLQL) GOTO 150
27061 IF(JA.EQ.IA) GOTO 150
27062 IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I)
27063 IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J)
27064 HI=HP*PARU(151)
27065 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4))
27066 NCHN=NCHN+1
27067 ISIG(NCHN,1)=I
27068 ISIG(NCHN,2)=J
27069 ISIG(NCHN,3)=1
27070 SIGH(NCHN)=HI*FACBW*HF
27071 150 CONTINUE
27072 160 CONTINUE
27073
27074 ELSEIF(ISUB.EQ.146) THEN
27075C...e + gamma* -> e* (excited lepton)
27076 KFQSTR=KFPR(ISUB,1)
27077 KCQSTR=PYCOMP(KFQSTR)
27078 KFQEXC=MOD(KFQSTR,KEXCIT)
27079 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
27080 HS=SHR*WDTP(0)
27081 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
27082 QF=-RTCM(43)/2D0-RTCM(44)/2D0
27083 FACBW=FACBW*AEM*QF**2*SH/RTCM(41)**2
27084 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
27085 & FACBW=0D0
27086 HP=SH
27087 DO 180 I=-KFQEXC,KFQEXC,2*KFQEXC
27088 DO 170 ISDE=1,2
27089 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 170
27090 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 170
27091 HI=HP
27092 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27093 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
27094 NCHN=NCHN+1
27095 ISIG(NCHN,ISDE)=I
27096 ISIG(NCHN,3-ISDE)=22
27097 ISIG(NCHN,3)=1
27098 SIGH(NCHN)=HI*FACBW*HF
27099 170 CONTINUE
27100 180 CONTINUE
27101
27102 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
27103C...d + g -> d* and u + g -> u* (excited quarks)
27104 KFQSTR=KFPR(ISUB,1)
27105 KCQSTR=PYCOMP(KFQSTR)
27106 KFQEXC=MOD(KFQSTR,KEXCIT)
27107 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
27108 HS=SHR*WDTP(0)
27109 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
27110 FACBW=FACBW*AS*RTCM(45)**2*SH/(3D0*RTCM(41)**2)
27111 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
27112 & FACBW=0D0
27113 HP=SH
27114 DO 200 I=-KFQEXC,KFQEXC,2*KFQEXC
27115 DO 190 ISDE=1,2
27116 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 190
27117 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 190
27118 HI=HP
27119 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27120 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
27121 NCHN=NCHN+1
27122 ISIG(NCHN,ISDE)=I
27123 ISIG(NCHN,3-ISDE)=21
27124 ISIG(NCHN,3)=1
27125 SIGH(NCHN)=HI*FACBW*HF
27126 190 CONTINUE
27127 200 CONTINUE
27128 ENDIF
27129
27130 ELSEIF(ISUB.LE.190) THEN
27131 IF(ISUB.EQ.162) THEN
27132C...q + g -> LQ + lbar; LQ=leptoquark
27133 SQMLQ=PMAS(42,1)**2
27134 FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)*
27135 & (UH2+SQMLQ**2)/(UH-SQMLQ)**2
27136 KFLQQ=KFDP(MDCY(42,2),1)
27137 DO 220 I=MMINA,MMAXA
27138 IF(IABS(I).NE.KFLQQ) GOTO 220
27139 KCHLQ=ISIGN(1,I)
27140 DO 210 ISDE=1,2
27141 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 210
27142 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 210
27143 NCHN=NCHN+1
27144 ISIG(NCHN,ISDE)=I
27145 ISIG(NCHN,3-ISDE)=21
27146 ISIG(NCHN,3)=1
27147 SIGH(NCHN)=FACLQ*WIDS(42,(5-KCHLQ)/2)
27148 210 CONTINUE
27149 220 CONTINUE
27150
27151 ELSEIF(ISUB.EQ.163) THEN
27152C...g + g -> LQ + LQbar; LQ=leptoquark
27153 SQMLQ=PMAS(42,1)**2
27154 FACLQ=COMFAC*FACA*WIDS(42,1)*(AS**2/2D0)*
27155 & (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/
27156 & (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/
27157 & ((TH-SQMLQ)*(UH-SQMLQ)))
27158 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 230
27159 NCHN=NCHN+1
27160 ISIG(NCHN,1)=21
27161 ISIG(NCHN,2)=21
27162C...Since don't know proper colour flow, randomize between alternatives
27163 ISIG(NCHN,3)=INT(1.5D0+PYR(0))
27164 SIGH(NCHN)=FACLQ
27165 230 CONTINUE
27166
27167 ELSEIF(ISUB.EQ.164) THEN
27168C...q + qbar -> LQ + LQbar; LQ=leptoquark
27169 DELTA=0.25D0*(SQM3-SQM4)**2/SH
27170 SQMLQ=0.5D0*(SQM3+SQM4)-DELTA
27171 TH=TH-DELTA
27172 UH=UH-DELTA
27173C SQMLQ=PMAS(42,1)**2
27174 FACLQA=COMFAC*WIDS(42,1)*(AS**2/9D0)*
27175 & (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2
27176 FACLQS=COMFAC*WIDS(42,1)*((PARU(151)**2*AEM**2/8D0)*
27177 & (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)*
27178 & ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH))
27179 KFLQQ=KFDP(MDCY(42,2),1)
27180 DO 240 I=MMINA,MMAXA
27181 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
27182 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 240
27183 NCHN=NCHN+1
27184 ISIG(NCHN,1)=I
27185 ISIG(NCHN,2)=-I
27186 ISIG(NCHN,3)=1
27187 SIGH(NCHN)=FACLQA
27188 IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS
27189 240 CONTINUE
27190
27191 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
27192C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks)
27193 KFQSTR=KFPR(ISUB,2)
27194 KCQSTR=PYCOMP(KFQSTR)
27195 KFQEXC=MOD(KFQSTR,KEXCIT)
27196 FACQSA=COMFAC*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)
27197 FACQSB=COMFAC*0.25D0*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
27198 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
27199C...Propagators: as simulated in PYOFSH and as desired
27200 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
27201 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
27202 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
27203 GMMQC=SQRT(SQM4)*WDTP(0)
27204 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
27205 FACQSA=FACQSA*HBW4C/HBW4
27206 FACQSB=FACQSB*HBW4C/HBW4
27207C...Branching ratios.
27208 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
27209 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
27210 DO 260 I=MMIN1,MMAX1
27211 IA=IABS(I)
27212 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 260
27213 DO 250 J=MMIN2,MMAX2
27214 JA=IABS(J)
27215 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 250
27216 IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN
27217 NCHN=NCHN+1
27218 ISIG(NCHN,1)=I
27219 ISIG(NCHN,2)=J
27220 ISIG(NCHN,3)=1
27221 IF(I.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
27222 IF(I.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
27223 NCHN=NCHN+1
27224 ISIG(NCHN,1)=I
27225 ISIG(NCHN,2)=J
27226 ISIG(NCHN,3)=2
27227 IF(J.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
27228 IF(J.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
27229 ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN
27230 NCHN=NCHN+1
27231 ISIG(NCHN,1)=I
27232 ISIG(NCHN,2)=J
27233 ISIG(NCHN,3)=1
27234 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
27235 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSA*BRPOS
27236 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSA*BRNEG
27237 ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN
27238 NCHN=NCHN+1
27239 ISIG(NCHN,1)=I
27240 ISIG(NCHN,2)=J
27241 ISIG(NCHN,3)=1
27242 IF(I.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
27243 IF(I.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
27244 NCHN=NCHN+1
27245 ISIG(NCHN,1)=I
27246 ISIG(NCHN,2)=J
27247 ISIG(NCHN,3)=2
27248 IF(J.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
27249 IF(J.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
27250 ELSEIF(I.EQ.-J) THEN
27251 NCHN=NCHN+1
27252 ISIG(NCHN,1)=I
27253 ISIG(NCHN,2)=J
27254 ISIG(NCHN,3)=1
27255 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
27256 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
27257 NCHN=NCHN+1
27258 ISIG(NCHN,1)=I
27259 ISIG(NCHN,2)=J
27260 ISIG(NCHN,3)=2
27261 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
27262 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
27263 ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN
27264 NCHN=NCHN+1
27265 ISIG(NCHN,1)=I
27266 ISIG(NCHN,2)=J
27267 ISIG(NCHN,3)=1
27268 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
27269 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSB*BRPOS
27270 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSB*BRNEG
27271 ENDIF
27272 250 CONTINUE
27273 260 CONTINUE
27274
27275 ELSEIF(ISUB.EQ.169) THEN
27276C...q + qbar -> e + e* (excited lepton)
27277 KFQSTR=KFPR(ISUB,2)
27278 KCQSTR=PYCOMP(KFQSTR)
27279 KFQEXC=MOD(KFQSTR,KEXCIT)
27280 FACQSB=(COMFAC/12D0)*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
27281 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
27282C...Propagators: as simulated in PYOFSH and as desired
27283 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
27284 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
27285 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
27286 GMMQC=SQRT(SQM4)*WDTP(0)
27287 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
27288 FACQSB=FACQSB*HBW4C/HBW4
27289C...Branching ratios.
27290 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
27291 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
27292 DO 270 I=MMIN1,MMAX1
27293 IA=IABS(I)
27294 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 270
27295 J=-I
27296 JA=IABS(J)
27297 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 270
27298 NCHN=NCHN+1
27299 ISIG(NCHN,1)=I
27300 ISIG(NCHN,2)=J
27301 ISIG(NCHN,3)=1
27302 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
27303 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
27304 NCHN=NCHN+1
27305 ISIG(NCHN,1)=I
27306 ISIG(NCHN,2)=J
27307 ISIG(NCHN,3)=2
27308 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
27309 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
27310 270 CONTINUE
27311 ENDIF
27312
27313 ELSEIF(ISUB.LE.360) THEN
27314 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
27315C...l + l -> H_L++/-- or H_R++/--.
27316 KFRES=KFPR(ISUB,1)
27317 KFREC=PYCOMP(KFRES)
27318 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
27319 HS=SHR*WDTP(0)
27320 FACBW=8D0*COMFAC/((SH-PMAS(KFREC,1)**2)**2+HS**2)
27321 DO 290 I=MMIN1,MMAX1
27322 IA=IABS(I)
27323 IF((IA.NE.11.AND.IA.NE.13.AND.IA.NE.15).OR.KFAC(1,I).EQ.0)
27324 & GOTO 290
27325 DO 280 J=MMIN2,MMAX2
27326 JA=IABS(J)
27327 IF((JA.NE.11.AND.JA.NE.13.AND.JA.NE.15).OR.KFAC(2,J).EQ.0)
27328 & GOTO 280
27329 IF(I*J.LT.0) GOTO 280
27330 KCHH=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
27331 NCHN=NCHN+1
27332 ISIG(NCHN,1)=I
27333 ISIG(NCHN,2)=J
27334 ISIG(NCHN,3)=1
27335 HI=SH*PARP(181+3*((IA-11)/2)+(JA-11)/2)**2/(8D0*PARU(1))
27336 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
27337 SIGH(NCHN)=HI*FACBW*HF
27338 280 CONTINUE
27339 290 CONTINUE
27340
27341 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
27342C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'.
27343 KFRES=KFPR(ISUB,1)
27344 KFREC=PYCOMP(KFRES)
27345C...Propagators: as simulated in PYOFSH and as desired
27346 HBW3=PMAS(KFREC,1)*PMAS(KFREC,2)/((SQM3-PMAS(KFREC,1)**2)**2+
27347 & (PMAS(KFREC,1)*PMAS(KFREC,2))**2)
27348 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
27349 GMMC=SQRT(SQM3)*WDTP(0)
27350 HBW3C=GMMC/((SQM3-PMAS(KFREC,1)**2)**2+GMMC**2)
27351 FHCC=COMFAC*AEM*HBW3C/HBW3
27352 DO 310 I=MMINA,MMAXA
27353 IA=IABS(I)
27354 IF(IA.NE.11.AND.IA.NE.13.AND.IA.NE.15) GOTO 310
27355 SQML=PMAS(IA,1)**2
27356 J=ISIGN(KFPR(ISUB,2),-I)
27357 KCHH=ISIGN(2,KCHG(IA,1)*ISIGN(1,I))
27358 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))/WDTP(0)
27359 SMM1=8D0*(SH+TH-SQM3)*(SH+TH-2D0*SQM3-SQML-SQM4)/
27360 & (UH-SQM3)**2
27361 SMM2=2D0*((2D0*SQM3-3D0*SQML)*SQM4+(SQML-2D0*SQM4)*TH-
27362 & (TH-SQM4)*SH)/(TH-SQM4)**2
27363 SMM3=2D0*((2D0*SQM3-3D0*SQM4+TH)*SQML-(2D0*SQML-SQM4+TH)*
27364 & SH)/(SH-SQML)**2
27365 SMM12=4D0*((2D0*SQML-SQM4-2D0*SQM3+TH)*SH+(TH-3D0*SQM3-
27366 & 3D0*SQM4)*TH+(2D0*SQM3-2D0*SQML+3D0*SQM4)*SQM3)/
27367 & ((UH-SQM3)*(TH-SQM4))
27368 SMM13=-4D0*((TH+SQML-2D0*SQM4)*TH-(SQM3+3D0*SQML-2D0*SQM4)*
27369 & SQM3+(SQM3+3D0*SQML+TH)*SH-(TH-SQM3+SH)**2)/
27370 & ((UH-SQM3)*(SH-SQML))
27371 SMM23=-4D0*((SQML-SQM4+SQM3)*TH-SQM3**2+SQM3*(SQML+SQM4)-
27372 & 3D0*SQML*SQM4-(SQML-SQM4-SQM3+TH)*SH)/
27373 & ((SH-SQML)*(TH-SQM4))
27374 SMM=(SH/(SH-SQML))**2*(SMM1+SMM2+SMM3+SMM12+SMM13+SMM23)*
27375 & PARP(181+3*((IA-11)/2)+(IABS(J)-11)/2)**2/(4D0*PARU(1))
27376 DO 300 ISDE=1,2
27377 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 300
27378 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 300
27379 NCHN=NCHN+1
27380 ISIG(NCHN,ISDE)=I
27381 ISIG(NCHN,3-ISDE)=22
27382 ISIG(NCHN,3)=0
27383 SIGH(NCHN)=FHCC*SMM*WIDSC
27384 300 CONTINUE
27385 310 CONTINUE
27386
27387 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
27388C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R--
27389 KFRES=KFPR(ISUB,1)
27390 KFREC=PYCOMP(KFRES)
27391 SQMH=PMAS(KFREC,1)**2
27392 GMMH=PMAS(KFREC,1)*PMAS(KFREC,2)
27393C...Propagators: H++/-- as simulated in PYOFSH and as desired
27394 HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2)
27395 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
27396 GMMH3=SQRT(SQM3)*WDTP(0)
27397 HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2)
27398 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
27399 CALL PYWIDT(KFRES,SQM4,WDTP,WDTE)
27400 GMMH4=SQRT(SQM4)*WDTP(0)
27401 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
27402C...Kinematical and coupling functions
27403 FACHH=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*(TH*UH-SQM3*SQM4)
27404 XWHH=(1D0-2D0*XWV)/(8D0*XWV*(1D0-XWV))
27405C...Loop over allowed flavours
27406 DO 320 I=MMINA,MMAXA
27407 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
27408 EI=KCHG(IABS(I),1)/3D0
27409 AI=SIGN(1D0,EI+0.1D0)
27410 VI=AI-4D0*EI*XWV
27411 FCOI=1D0
27412 IF(IABS(I).LE.10) FCOI=FACA/3D0
27413 IF(ISUB.EQ.349) THEN
27414 HBWZ=1D0/((SH-SQMZ)**2+GMMZ**2)
27415 IF(IABS(I).LT.10) THEN
27416 DSIGHH=8D0*AEM**2*(EI**2/SH2+
27417 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
27418 & (VI**2+AI**2)*XWHH**2*HBWZ)
27419 ELSE
27420 IAOFF=181+3*((IABS(I)-11)/2)
27421 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
27422 & (4D0*PARU(1))
27423 DSIGHH=8D0*AEM**2*(EI**2/SH2+
27424 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
27425 & (VI**2+AI**2)*XWHH**2*HBWZ)+
27426 & 8D0*AEM*(EI*HSUM/(SH*TH)+
27427 & (VI+AI)*XWHH*HSUM*(SH-SQMZ)*HBWZ/TH)+
27428 & 4D0*HSUM**2/TH2
27429 ENDIF
27430 ELSE
27431 IF(IABS(I).LT.10) THEN
27432 DSIGHH=8D0*AEM**2*EI**2/SH2
27433 ELSE
27434 IAOFF=181+3*((IABS(I)-11)/2)
27435 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
27436 & (4D0*PARU(1))
27437 DSIGHH=8D0*AEM**2*EI**2/SH2+8D0*AEM*EI*HSUM/(SH*TH)+
27438 & 4D0*HSUM**2/TH2
27439 ENDIF
27440 ENDIF
27441 NCHN=NCHN+1
27442 ISIG(NCHN,1)=I
27443 ISIG(NCHN,2)=-I
27444 ISIG(NCHN,3)=1
27445 SIGH(NCHN)=FACHH*FCOI*DSIGHH
27446 320 CONTINUE
27447
27448 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
27449C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process)
27450 KFRES=KFPR(ISUB,1)
27451 KFREC=PYCOMP(KFRES)
27452 SQMH=PMAS(KFREC,1)**2
27453 IF(ISUB.EQ.351) FACNOR=PARP(190)**8*PARP(192)**2
27454 IF(ISUB.EQ.352) FACNOR=PARP(191)**6*2D0*
27455 & PMAS(PYCOMP(9900024),1)**2
27456 FACWW=COMFAC*FACNOR*TAUP*VINT(2)*VINT(219)
27457 FACPRT=1D0/((VINT(204)**2-VINT(215))*
27458 & (VINT(209)**2-VINT(216)))
27459 FACPRU=1D0/((VINT(204)**2+2D0*VINT(217))*
27460 & (VINT(209)**2+2D0*VINT(218)))
27461 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
27462 HS=SHR*WDTP(0)
27463 FACBW=(1D0/PARU(1))*VINT(2)/((SH-SQMH)**2+HS**2)
27464 IF(ABS(SHR-PMAS(KFREC,1)).GT.PARP(48)*PMAS(KFREC,2))
27465 & FACBW=0D0
27466 DO 340 I=MMIN1,MMAX1
27467 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 340
27468 IF(ISUB.EQ.352.AND.IABS(I).GT.10) GOTO 340
27469 KCHWI=(1-2*MOD(IABS(I),2))*ISIGN(1,I)
27470 DO 330 J=MMIN2,MMAX2
27471 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 330
27472 IF(ISUB.EQ.352.AND.IABS(J).GT.10) GOTO 330
27473 KCHWJ=(1-2*MOD(IABS(J),2))*ISIGN(1,J)
27474 KCHH=KCHWI+KCHWJ
27475 IF(IABS(KCHH).NE.2) GOTO 330
27476 FACLR=VINT(180+I)*VINT(180+J)
27477 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
27478 IF(I.EQ.J.AND.IABS(I).GT.10) THEN
27479 FACPRP=0.5D0*(FACPRT+FACPRU)**2
27480 ELSE
27481 FACPRP=FACPRT**2
27482 ENDIF
27483 NCHN=NCHN+1
27484 ISIG(NCHN,1)=I
27485 ISIG(NCHN,2)=J
27486 ISIG(NCHN,3)=1
27487 SIGH(NCHN)=FACLR*FACWW*FACPRP*FACBW*HF
27488 330 CONTINUE
27489 340 CONTINUE
27490
27491 ELSEIF(ISUB.EQ.353) THEN
27492C...f + fbar -> Z_R0
27493 SQMZR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
27494 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
27495 HS=SHR*WDTP(0)
27496 FACBW=4D0*COMFAC/((SH-SQMZR)**2+HS**2)*3D0
27497 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27498 HP=(AEM/(3D0*(1D0-2D0*XW)))*XWC*SH
27499 DO 350 I=MMINA,MMAXA
27500 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
27501 IF(IABS(I).LE.8) THEN
27502 EI=KCHG(IABS(I),1)/3D0
27503 AI=SIGN(1D0,EI+0.1D0)*(1D0-2D0*XW)
27504 VI=SIGN(1D0,EI+0.1D0)-4D0*EI*XW
27505 ELSE
27506 AI=-(1D0-2D0*XW)
27507 VI=-1D0+4D0*XW
27508 ENDIF
27509 HI=HP*(VI**2+AI**2)
27510 IF(IABS(I).LE.10) HI=HI*FACA/3D0
27511 NCHN=NCHN+1
27512 ISIG(NCHN,1)=I
27513 ISIG(NCHN,2)=-I
27514 ISIG(NCHN,3)=1
27515 SIGH(NCHN)=HI*FACBW*HF
27516 350 CONTINUE
27517
27518 ELSEIF(ISUB.EQ.354) THEN
27519C...f + fbar' -> W_R+/-
27520 SQMWR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
27521 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
27522 HS=SHR*WDTP(0)
27523 FACBW=4D0*COMFAC/((SH-SQMWR)**2+HS**2)*3D0
27524 HP=AEM/(24D0*XW)*SH
27525 DO 370 I=MMIN1,MMAX1
27526 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 370
27527 IA=IABS(I)
27528 DO 360 J=MMIN2,MMAX2
27529 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 360
27530 JA=IABS(J)
27531 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
27532 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
27533 & GOTO 360
27534 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
27535 HI=HP*2D0
27536 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
27537 NCHN=NCHN+1
27538 ISIG(NCHN,1)=I
27539 ISIG(NCHN,2)=J
27540 ISIG(NCHN,3)=1
27541 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
27542 SIGH(NCHN)=HI*FACBW*HF
27543 360 CONTINUE
27544 370 CONTINUE
27545 ENDIF
27546
27547 ELSEIF(ISUB.LE.400) THEN
27548 IF(ISUB.EQ.391) THEN
27549C...f + fbar -> G*.
27550 KFGSTR=KFPR(ISUB,1)
27551 KCGSTR=PYCOMP(KFGSTR)
27552 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
27553 HS=SHR*WDTP(0)
27554 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27555 FACG=COMFAC*PARP(50)**2/(16D0*PARU(1))*SH*HF/
27556 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
27557 DO 380 I=MMINA,MMAXA
27558 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
27559 HI=1D0
27560 IF(IABS(I).LE.10) HI=HI*FACA/3D0
27561 NCHN=NCHN+1
27562 ISIG(NCHN,1)=I
27563 ISIG(NCHN,2)=-I
27564 ISIG(NCHN,3)=1
27565 SIGH(NCHN)=FACG*HI
27566 380 CONTINUE
27567
27568 ELSEIF(ISUB.EQ.392) THEN
27569C...g + g -> G*.
27570 KFGSTR=KFPR(ISUB,1)
27571 KCGSTR=PYCOMP(KFGSTR)
27572 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
27573 HS=SHR*WDTP(0)
27574 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27575 FACG=COMFAC*PARP(50)**2/(32D0*PARU(1))*SH*HF/
27576 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
27577 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 390
27578 NCHN=NCHN+1
27579 ISIG(NCHN,1)=21
27580 ISIG(NCHN,2)=21
27581 ISIG(NCHN,3)=1
27582 SIGH(NCHN)=FACG
27583 390 CONTINUE
27584
27585 ELSEIF(ISUB.EQ.393) THEN
27586C...q + qbar -> g + G*.
27587 KFGSTR=KFPR(ISUB,2)
27588 KCGSTR=PYCOMP(KFGSTR)
27589 FACG=COMFAC*PARP(50)**2*AS*SH/(72D0*PARU(1)*SQM4)*
27590 & (4D0*(TH2+UH2)/SH2+9D0*(TH+UH)/SH+(TH2/UH+UH2/TH)/SH+
27591 & 3D0*(4D0+TH/UH+UH/TH)+4D0*(SH/UH+SH/TH)+
27592 & 2D0*SH2/(TH*UH))
27593C...Propagators: as simulated in PYOFSH and as desired
27594 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
27595 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
27596 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
27597 HS=SQRT(SQM4)*WDTP(0)
27598 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27599 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
27600 FACG=FACG*HBW4C/HBW4
27601 DO 400 I=MMINA,MMAXA
27602 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
27603 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
27604 NCHN=NCHN+1
27605 ISIG(NCHN,1)=I
27606 ISIG(NCHN,2)=-I
27607 ISIG(NCHN,3)=1
27608 SIGH(NCHN)=FACG
27609 400 CONTINUE
27610
27611 ELSEIF(ISUB.EQ.394) THEN
27612C...q + g -> q + G*.
27613 KFGSTR=KFPR(ISUB,2)
27614 KCGSTR=PYCOMP(KFGSTR)
27615 FACG=-COMFAC*PARP(50)**2*AS*SH/(192D0*PARU(1)*SQM4)*
27616 & (4D0*(SH2+UH2)/(TH*SH)+9D0*(SH+UH)/SH+SH/UH+UH2/SH2+
27617 & 3D0*TH*(4D0+SH/UH+UH/SH)/SH+4D0*TH2*(1D0/UH+1D0/SH)/SH+
27618 & 2D0*TH2*TH/(UH*SH2))
27619C...Propagators: as simulated in PYOFSH and as desired
27620 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
27621 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
27622 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
27623 HS=SQRT(SQM4)*WDTP(0)
27624 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27625 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
27626 FACG=FACG*HBW4C/HBW4
27627 DO 420 I=MMINA,MMAXA
27628 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 420
27629 DO 410 ISDE=1,2
27630 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 410
27631 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 410
27632 NCHN=NCHN+1
27633 ISIG(NCHN,ISDE)=I
27634 ISIG(NCHN,3-ISDE)=21
27635 ISIG(NCHN,3)=1
27636 SIGH(NCHN)=FACG
27637 410 CONTINUE
27638 420 CONTINUE
27639
27640 ELSEIF(ISUB.EQ.395) THEN
27641C...g + g -> g + G*.
27642 KFGSTR=KFPR(ISUB,2)
27643 KCGSTR=PYCOMP(KFGSTR)
27644 FACG=COMFAC*3D0*PARP(50)**2*AS*SH/(32D0*PARU(1)*SQM4)*
27645 & ((TH2+TH*UH+UH2)**2/(SH2*TH*UH)+2D0*(TH2/UH+UH2/TH)/SH+
27646 & 3D0*(TH/UH+UH/TH)+2D0*(SH/UH+SH/TH)+SH2/(TH*UH))
27647C...Propagators: as simulated in PYOFSH and as desired
27648 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
27649 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
27650 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
27651 HS=SQRT(SQM4)*WDTP(0)
27652 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27653 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
27654 FACG=FACG*HBW4C/HBW4
27655 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
27656 NCHN=NCHN+1
27657 ISIG(NCHN,1)=21
27658 ISIG(NCHN,2)=21
27659 ISIG(NCHN,3)=1
27660 SIGH(NCHN)=FACG
27661 ENDIF
27662 ENDIF
27663 ENDIF
27664
27665 RETURN
27666 END
27667
27668C*********************************************************************
27669
27670C...PYPDFU
27671C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon
27672C...parton distributions according to a few different parametrizations.
27673C...Note that what is coded is x times the probability distribution,
27674C...i.e. xq(x,Q2) etc.
27675
27676 SUBROUTINE PYPDFU(KF,X,Q2,XPQ)
27677
27678C...Double precision and integer declarations.
27679 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27680 IMPLICIT INTEGER(I-N)
27681 INTEGER PYK,PYCHGE,PYCOMP
27682C...Commonblocks.
27683 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27684 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27685 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27686 COMMON/PYINT1/MINT(400),VINT(400)
27687 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
27688 &XPDIR(-6:6)
27689 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/
27690C...Local arrays.
27691 DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
27692 &XPPI(-6:6),XPPR(-6:6)
27693
27694C...Interface to PDFLIB.
81935ff8 27695 COMMON/LW50513/XMIN,XMAX,Q2MIN,Q2MAX
27696 SAVE /LW50513/
2dfa57d1 27697 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
27698 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
27699 CHARACTER*20 PARM(20)
27700 DATA VALUE/20*0D0/,PARM/20*' '/
27701
27702C...Data related to Schuler-Sjostrand photon distributions.
27703 DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
27704
27705C...Reset parton distributions.
27706 MINT(92)=0
27707 DO 100 KFL=-25,25
27708 XPQ(KFL)=0D0
27709 100 CONTINUE
27710
27711C...Check x and particle species.
27712 IF(X.LE.0D0.OR.X.GE.1D0) THEN
27713 WRITE(MSTU(11),5000) X
27714 RETURN
27715 ENDIF
27716 KFA=IABS(KF)
27717 IF(KFA.NE.11.AND.KFA.NE.13.AND.KFA.NE.15.AND.KFA.NE.22.AND.
27718 &KFA.NE.211.AND.KFA.NE.2112.AND.KFA.NE.2212.AND.KFA.NE.3122.AND.
27719 &KFA.NE.3112.AND.KFA.NE.3212.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.
27720 &KFA.NE.3322.AND.KFA.NE.3334.AND.KFA.NE.111.AND.KFA.NE.321.AND.
27721 &KFA.NE.310.AND.KFA.NE.130) THEN
27722 WRITE(MSTU(11),5100) KF
27723 RETURN
27724 ENDIF
27725
27726C...Electron (or muon or tau) parton distribution call.
27727 IF(KFA.EQ.11.OR.KFA.EQ.13.OR.KFA.EQ.15) THEN
27728 CALL PYPDEL(KFA,X,Q2,XPEL)
27729 DO 110 KFL=-25,25
27730 XPQ(KFL)=XPEL(KFL)
27731 110 CONTINUE
27732
27733C...Photon parton distribution call (VDM+anomalous).
27734 ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
27735 IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
27736 CALL PYPDGA(X,Q2,XPGA)
27737 DO 120 KFL=-6,6
27738 XPQ(KFL)=XPGA(KFL)
27739 120 CONTINUE
27740 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
27741 Q2MX=Q2
27742 P2MX=0.36D0
27743 IF(MSTP(55).GE.7) P2MX=4.0D0
27744 IF(MSTP(57).EQ.0) Q2MX=P2MX
27745 P2=0D0
27746 IF(VINT(120).LT.0D0) P2=VINT(120)**2
27747 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
27748 DO 130 KFL=-6,6
27749 XPQ(KFL)=XPGA(KFL)
27750 130 CONTINUE
27751 VINT(231)=P2MX
27752 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
27753 Q2MX=Q2
27754 P2MX=0.36D0
27755 IF(MSTP(55).GE.11) P2MX=4.0D0
27756 IF(MSTP(57).EQ.0) Q2MX=P2MX
27757 P2=0D0
27758 IF(VINT(120).LT.0D0) P2=VINT(120)**2
27759 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
27760 DO 140 KFL=-6,6
27761 XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
27762 140 CONTINUE
27763 VINT(231)=P2MX
27764 ELSEIF(MSTP(56).EQ.2) THEN
27765C...Call PDFLIB parton distributions.
27766 PARM(1)='NPTYPE'
27767 VALUE(1)=3
27768 PARM(2)='NGROUP'
27769 VALUE(2)=MSTP(55)/1000
27770 PARM(3)='NSET'
27771 VALUE(3)=MOD(MSTP(55),1000)
27772 IF(MINT(93).NE.3000000+MSTP(55)) THEN
27773 CALL PDFSET(PARM,VALUE)
27774 MINT(93)=3000000+MSTP(55)
27775 ENDIF
27776 XX=X
27777 QQ2=MAX(0D0,Q2MIN,Q2)
27778 IF(MSTP(57).EQ.0) QQ2=Q2MIN
27779 P2=0D0
27780 IF(VINT(120).LT.0D0) P2=VINT(120)**2
27781 IP2=MSTP(60)
27782 IF(MSTP(55).EQ.5004) THEN
27783 IF(5D0*P2.LT.QQ2.AND.
27784 & QQ2.GT.0.6D0.AND.QQ2.LT.5D4.AND.
27785 & P2.GE.0D0.AND.P2.LT.10D0.AND.
27786 & XX.GT.1D-4.AND.XX.LT.1D0) THEN
27787 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
27788 & BOT,TOP,GLU)
27789 ELSE
27790 UPV=0D0
27791 DNV=0D0
27792 USEA=0D0
27793 DSEA=0D0
27794 STR=0D0
27795 CHM=0D0
27796 BOT=0D0
27797 TOP=0D0
27798 GLU=0D0
27799 ENDIF
27800 ELSE
27801 IF(P2.LT.QQ2) THEN
27802 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
27803 & BOT,TOP,GLU)
27804 ELSE
27805 UPV=0D0
27806 DNV=0D0
27807 USEA=0D0
27808 DSEA=0D0
27809 STR=0D0
27810 CHM=0D0
27811 BOT=0D0
27812 TOP=0D0
27813 GLU=0D0
27814 ENDIF
27815 ENDIF
27816 VINT(231)=Q2MIN
27817 XPQ(0)=GLU
27818 XPQ(1)=DNV
27819 XPQ(-1)=DNV
27820 XPQ(2)=UPV
27821 XPQ(-2)=UPV
27822 XPQ(3)=STR
27823 XPQ(-3)=STR
27824 XPQ(4)=CHM
27825 XPQ(-4)=CHM
27826 XPQ(5)=BOT
27827 XPQ(-5)=BOT
27828 XPQ(6)=TOP
27829 XPQ(-6)=TOP
27830 ELSE
27831 WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
27832 ENDIF
27833
27834C...Pion/gammaVDM parton distribution call.
27835 ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.KFA.EQ.321.OR.KFA.EQ.130.OR.
27836 &KFA.EQ.310.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
27837 IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
27838 & MSTP(55).LE.12) THEN
27839 ISET=1+MOD(MSTP(55)-1,4)
27840 Q2MX=Q2
27841 P2MX=0.36D0
27842 IF(ISET.GE.3) P2MX=4.0D0
27843 IF(MSTP(57).EQ.0) Q2MX=P2MX
27844 P2=0D0
27845 IF(VINT(120).LT.0D0) P2=VINT(120)**2
27846 CALL PYGGAM(ISET,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
27847 DO 150 KFL=-6,6
27848 XPQ(KFL)=XPVMD(KFL)
27849 150 CONTINUE
27850 VINT(231)=P2MX
27851 ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
27852 CALL PYPDPI(X,Q2,XPPI)
27853 DO 160 KFL=-6,6
27854 XPQ(KFL)=XPPI(KFL)
27855 160 CONTINUE
27856 ELSEIF(MSTP(54).EQ.2) THEN
27857C...Call PDFLIB parton distributions.
27858 PARM(1)='NPTYPE'
27859 VALUE(1)=2
27860 PARM(2)='NGROUP'
27861 VALUE(2)=MSTP(53)/1000
27862 PARM(3)='NSET'
27863 VALUE(3)=MOD(MSTP(53),1000)
27864 IF(MINT(93).NE.2000000+MSTP(53)) THEN
27865 CALL PDFSET(PARM,VALUE)
27866 MINT(93)=2000000+MSTP(53)
27867 ENDIF
27868 XX=X
27869 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
27870 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
27871 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
27872 VINT(231)=Q2MIN
27873 XPQ(0)=GLU
27874 XPQ(1)=DSEA
27875 XPQ(-1)=UPV+DSEA
27876 XPQ(2)=UPV+USEA
27877 XPQ(-2)=USEA
27878 XPQ(3)=STR
27879 XPQ(-3)=STR
27880 XPQ(4)=CHM
27881 XPQ(-4)=CHM
27882 XPQ(5)=BOT
27883 XPQ(-5)=BOT
27884 XPQ(6)=TOP
27885 XPQ(-6)=TOP
27886 ELSE
27887 WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
27888 ENDIF
27889
27890C...Anomalous photon parton distribution call.
27891 ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
27892 Q2MX=Q2
27893 P2MX=PARP(15)**2
27894 IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
27895 IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
27896 IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
27897 IF(MSTP(57).EQ.0) Q2MX=P2MX
27898 P2=0D0
27899 IF(VINT(120).LT.0D0) P2=VINT(120)**2
27900 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
27901 DO 170 KFL=-6,6
27902 XPQ(KFL)=XPANL(KFL)+XPANH(KFL)
27903 170 CONTINUE
27904 VINT(231)=P2MX
27905 ELSEIF(MSTP(56).EQ.1) THEN
27906 IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
27907 IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
27908 IF(MSTP(57).EQ.0) Q2MX=P2MX
27909 P2=0D0
27910 IF(VINT(120).LT.0D0) P2=VINT(120)**2
27911 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
27912 DO 180 KFL=-6,6
27913 XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
27914 180 CONTINUE
27915 VINT(231)=P2MX
27916 ELSEIF(MSTP(56).EQ.2) THEN
27917 IF(MSTP(57).EQ.0) Q2MX=P2MX
27918 CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
27919 DO 190 KFL=-6,6
27920 XPQ(KFL)=XPGA(KFL)
27921 190 CONTINUE
27922 VINT(231)=P2MX
27923 ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
27924 IF(MSTP(57).EQ.0) Q2MX=P2MX
27925 CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
27926 DO 200 KFL=-6,6
27927 XPQ(KFL)=XPGA(KFL)
27928 200 CONTINUE
27929 VINT(231)=P2MX
27930 ELSE
27931 210 RKF=11D0*PYR(0)
27932 KFR=1
27933 IF(RKF.GT.1D0) KFR=2
27934 IF(RKF.GT.5D0) KFR=3
27935 IF(RKF.GT.6D0) KFR=4
27936 IF(RKF.GT.10D0) KFR=5
27937 IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 210
27938 IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 210
27939 IF(MSTP(57).EQ.0) Q2MX=P2MX
27940 CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
27941 DO 220 KFL=-6,6
27942 XPQ(KFL)=XPGA(KFL)
27943 220 CONTINUE
27944 VINT(231)=P2MX
27945 ENDIF
27946
27947C...Proton parton distribution call.
27948 ELSE
27949 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
27950 CALL PYPDPR(X,Q2,XPPR)
27951 DO 230 KFL=-6,6
27952 XPQ(KFL)=XPPR(KFL)
27953 230 CONTINUE
27954 ELSEIF(MSTP(52).EQ.2) THEN
27955C...Call PDFLIB parton distributions.
27956 PARM(1)='NPTYPE'
27957 VALUE(1)=1
27958 PARM(2)='NGROUP'
27959 VALUE(2)=MSTP(51)/1000
27960 PARM(3)='NSET'
27961 VALUE(3)=MOD(MSTP(51),1000)
27962 IF(MINT(93).NE.1000000+MSTP(51)) THEN
27963 CALL PDFSET_ALICE(PARM,VALUE)
27964 MINT(93)=1000000+MSTP(51)
27965 ENDIF
27966 XX=X
27967 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
27968 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
27969 CALL STRUCTM_ALICE
27970 + (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
27971 VINT(231)=Q2MIN
27972 XPQ(0)=GLU
27973 XPQ(1)=DNV+DSEA
27974 XPQ(-1)=DSEA
27975 XPQ(2)=UPV+USEA
27976 XPQ(-2)=USEA
27977 XPQ(3)=STR
27978 XPQ(-3)=STR
27979 XPQ(4)=CHM
27980 XPQ(-4)=CHM
27981 XPQ(5)=BOT
27982 XPQ(-5)=BOT
27983 XPQ(6)=TOP
27984 XPQ(-6)=TOP
27985 ELSE
27986 WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
27987 ENDIF
27988 ENDIF
27989
27990C...Isospin average for pi0/gammaVDM.
27991 IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
27992 IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
27993 XPV=XPQ(2)-XPQ(1)
27994 XPQ(2)=XPQ(1)
27995 XPQ(-2)=XPQ(-1)
27996 ELSE
27997 XPS=0.5D0*(XPQ(1)+XPQ(-2))
27998 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
27999 XPQ(2)=XPS
28000 XPQ(-1)=XPS
28001 ENDIF
28002 IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
28003 XPQ(1)=XPQ(1)+0.2D0*XPV
28004 XPQ(-1)=XPQ(-1)+0.2D0*XPV
28005 XPQ(2)=XPQ(2)+0.8D0*XPV
28006 XPQ(-2)=XPQ(-2)+0.8D0*XPV
28007 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
28008 XPQ(3)=XPQ(3)+XPV
28009 XPQ(-3)=XPQ(-3)+XPV
28010 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
28011 XPQ(4)=XPQ(4)+XPV
28012 XPQ(-4)=XPQ(-4)+XPV
28013 IF(MSTP(55).GE.9) THEN
28014 DO 240 KFL=-6,6
28015 XPQ(KFL)=0D0
28016 240 CONTINUE
28017 ENDIF
28018 ELSE
28019 XPQ(1)=XPQ(1)+0.5D0*XPV
28020 XPQ(-1)=XPQ(-1)+0.5D0*XPV
28021 XPQ(2)=XPQ(2)+0.5D0*XPV
28022 XPQ(-2)=XPQ(-2)+0.5D0*XPV
28023 ENDIF
28024
28025C...Rescale for gammaVDM by effective gamma -> rho coupling.
28026C+++Do not rescale?
28027 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND..NOT.(MSTP(56).EQ.1
28028 & .AND.MSTP(55).GE.5.AND.MSTP(55).LE.12)) THEN
28029 DO 250 KFL=-6,6
28030 XPQ(KFL)=VINT(281)*XPQ(KFL)
28031 250 CONTINUE
28032 VINT(232)=VINT(281)*XPV
28033 ENDIF
28034
28035C...Simple recipes for kaons.
28036 ELSEIF(KFA.EQ.321) THEN
28037 XPQ(-3)=XPQ(-3)+XPQ(-1)-XPQ(1)
28038 XPQ(-1)=XPQ(1)
28039 ELSEIF(KFA.EQ.130.OR.KFA.EQ.310) THEN
28040 XPS=0.5D0*(XPQ(1)+XPQ(-2))
28041 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
28042 XPQ(2)=XPS
28043 XPQ(-1)=XPS
28044 XPQ(1)=XPQ(1)+0.5D0*XPV
28045 XPQ(-1)=XPQ(-1)+0.5D0*XPV
28046 XPQ(3)=XPQ(3)+0.5D0*XPV
28047 XPQ(-3)=XPQ(-3)+0.5D0*XPV
28048
28049C...Isospin conjugation for neutron.
28050 ELSEIF(KFA.EQ.2112) THEN
28051 XPS=XPQ(1)
28052 XPQ(1)=XPQ(2)
28053 XPQ(2)=XPS
28054 XPS=XPQ(-1)
28055 XPQ(-1)=XPQ(-2)
28056 XPQ(-2)=XPS
28057
28058C...Simple recipes for hyperon (average valence parton distribution).
28059 ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
28060 & .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
28061 XPVAL=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
28062 XPSEA=0.5D0*(XPQ(-1)+XPQ(-2))
28063 XPQ(1)=XPSEA
28064 XPQ(2)=XPSEA
28065 XPQ(-1)=XPSEA
28066 XPQ(-2)=XPSEA
28067 XPQ(KFA/1000)=XPQ(KFA/1000)+XPVAL
28068 XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPVAL
28069 XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPVAL
28070 ENDIF
28071
28072C...Charge conjugation for antiparticle.
28073 IF(KF.LT.0) THEN
28074 DO 260 KFL=1,25
28075 IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 260
28076 XPS=XPQ(KFL)
28077 XPQ(KFL)=XPQ(-KFL)
28078 XPQ(-KFL)=XPS
28079 260 CONTINUE
28080 ENDIF
28081
28082C...Allow gluon also in position 21.
28083 XPQ(21)=XPQ(0)
28084
28085C...Check positivity and reset above maximum allowed flavour.
28086 DO 270 KFL=-25,25
28087 XPQ(KFL)=MAX(0D0,XPQ(KFL))
28088 IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0
28089 270 CONTINUE
28090
28091C...Formats for error printouts.
28092 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
28093 5100 FORMAT(' Error: illegal particle code for parton distribution;',
28094 &' KF =',I5)
28095 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
28096 &3I5)
28097
28098 RETURN
28099 END
28100
28101C*********************************************************************
28102
28103C...PYPDFL
28104C...Gives proton parton distribution at small x and/or Q^2 according to
28105C...correct limiting behaviour.
28106
28107 SUBROUTINE PYPDFL(KF,X,Q2,XPQ)
28108
28109C...Double precision and integer declarations.
28110 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28111 IMPLICIT INTEGER(I-N)
28112 INTEGER PYK,PYCHGE,PYCOMP
28113C...Commonblocks.
28114 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28115 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28116 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28117 COMMON/PYINT1/MINT(400),VINT(400)
28118 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
28119C...Local arrays.
28120 DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3)
28121 DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/
28122
28123C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
28124 MINT(92)=0
28125 KFA=IABS(KF)
28126 IACC=0
28127 IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1
28128 IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1
28129 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1
28130 IF(IACC.EQ.0) THEN
28131 CALL PYPDFU(KF,X,Q2,XPQ)
28132 RETURN
28133 ENDIF
28134
28135C...Reset. Check x.
28136 DO 100 KFL=-25,25
28137 XPQ(KFL)=0D0
28138 100 CONTINUE
28139 IF(X.LE.0D0.OR.X.GE.1D0) THEN
28140 WRITE(MSTU(11),5000) X
28141 RETURN
28142 ENDIF
28143
28144C...Define valence content.
28145 KFC=KF
28146 NV1=2
28147 NV2=1
28148 IF(KF.EQ.2212) THEN
28149 KFV1=2
28150 KFV2=1
28151 ELSEIF(KF.EQ.-2212) THEN
28152 KFV1=-2
28153 KFV2=-1
28154 ELSEIF(KF.EQ.2112) THEN
28155 KFV1=1
28156 KFV2=2
28157 ELSEIF(KF.EQ.-2112) THEN
28158 KFV1=-1
28159 KFV2=-2
28160 ELSEIF(KF.EQ.211) THEN
28161 NV1=1
28162 KFV1=2
28163 KFV2=-1
28164 ELSEIF(KF.EQ.-211) THEN
28165 NV1=1
28166 KFV1=-2
28167 KFV2=1
28168 ELSEIF(MINT(105).LE.223) THEN
28169 KFV1=1
28170 WTV1=0.2D0
28171 KFV2=2
28172 WTV2=0.8D0
28173 ELSEIF(MINT(105).EQ.333) THEN
28174 KFV1=3
28175 WTV1=1.0D0
28176 KFV2=1
28177 WTV2=0.0D0
28178 ELSEIF(MINT(105).EQ.443) THEN
28179 KFV1=4
28180 WTV1=1.0D0
28181 KFV2=1
28182 WTV2=0.0D0
28183 ENDIF
28184
28185C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
28186 CALL PYPDFU(KFC,X,Q2,XPA)
28187 Q2MN=MAX(3D0,VINT(231))
28188 Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X))))
28189 XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0
28190
28191C...Large Q2 and large x: naive call is enough.
28192 IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN
28193 DO 110 KFL=-25,25
28194 XPQ(KFL)=XPA(KFL)
28195 110 CONTINUE
28196 MINT(92)=1
28197
28198C...Small Q2 and large x: dampen boundary value.
28199 ELSEIF(X.GT.XMN) THEN
28200
28201C...Evaluate at boundary and define dampening factors.
28202 CALL PYPDFU(KFC,X,Q2MN,XPA)
28203 FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN))
28204 FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0
28205
28206C...Separate valence and sea parts of parton distribution.
28207 IF(KFA.NE.22) THEN
28208 XFV1=XPA(KFV1)-XPA(-KFV1)
28209 XPA(KFV1)=XPA(-KFV1)
28210 XFV2=XPA(KFV2)-XPA(-KFV2)
28211 XPA(KFV2)=XPA(-KFV2)
28212 ELSE
28213 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
28214 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
28215 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
28216 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
28217 ENDIF
28218
28219C...Dampen valence and sea separately. Put back together.
28220 DO 120 KFL=-25,25
28221 XPQ(KFL)=FS*XPA(KFL)
28222 120 CONTINUE
28223 IF(KFA.NE.22) THEN
28224 XPQ(KFV1)=XPQ(KFV1)+FV*XFV1
28225 XPQ(KFV2)=XPQ(KFV2)+FV*XFV2
28226 ELSE
28227 XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232)
28228 XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232)
28229 XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232)
28230 XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232)
28231 ENDIF
28232 MINT(92)=2
28233
28234C...Large Q2 and small x: interpolate behaviour.
28235 ELSEIF(Q2.GT.Q2MN) THEN
28236
28237C...Evaluate at extremes and define coefficients for interpolation.
28238 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
28239 VI232A=VINT(232)
28240 CALL PYPDFU(KFC,X,Q2B,XPB)
28241 VI232B=VINT(232)
28242 FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN)
28243 FVA=(X/XMN)**0.45D0*FLA
28244 FSA=(X/XMN)**(-0.08D0)*FLA
28245 FB=1D0-FLA
28246
28247C...Separate valence and sea parts of parton distribution.
28248 IF(KFA.NE.22) THEN
28249 XFVA1=XPA(KFV1)-XPA(-KFV1)
28250 XPA(KFV1)=XPA(-KFV1)
28251 XFVA2=XPA(KFV2)-XPA(-KFV2)
28252 XPA(KFV2)=XPA(-KFV2)
28253 XFVB1=XPB(KFV1)-XPB(-KFV1)
28254 XPB(KFV1)=XPB(-KFV1)
28255 XFVB2=XPB(KFV2)-XPB(-KFV2)
28256 XPB(KFV2)=XPB(-KFV2)
28257 ELSE
28258 XPA(KFV1)=XPA(KFV1)-WTV1*VI232A
28259 XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A
28260 XPA(KFV2)=XPA(KFV2)-WTV2*VI232A
28261 XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A
28262 XPB(KFV1)=XPB(KFV1)-WTV1*VI232B
28263 XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B
28264 XPB(KFV2)=XPB(KFV2)-WTV2*VI232B
28265 XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B
28266 ENDIF
28267
28268C...Interpolate for valence and sea. Put back together.
28269 DO 130 KFL=-25,25
28270 XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL)
28271 130 CONTINUE
28272 IF(KFA.NE.22) THEN
28273 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1)
28274 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2)
28275 ELSE
28276 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
28277 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
28278 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
28279 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
28280 ENDIF
28281 MINT(92)=3
28282
28283C...Small Q2 and small x: dampen boundary value and add term.
28284 ELSE
28285
28286C...Evaluate at boundary and define dampening factors.
28287 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
28288 FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN)
28289 FA=1D0-FB
28290 FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0
28291 FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0
28292 FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0
28293 FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0
28294 FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0
28295 FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0
28296
28297C...Separate valence and sea parts of parton distribution.
28298 IF(KFA.NE.22) THEN
28299 XFV1=XPA(KFV1)-XPA(-KFV1)
28300 XPA(KFV1)=XPA(-KFV1)
28301 XFV2=XPA(KFV2)-XPA(-KFV2)
28302 XPA(KFV2)=XPA(-KFV2)
28303 ELSE
28304 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
28305 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
28306 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
28307 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
28308 ENDIF
28309
28310C...Dampen valence and sea separately. Add constant terms.
28311C...Put back together.
28312 DO 140 KFL=-25,25
28313 XPQ(KFL)=FSA*XPA(KFL)
28314 140 CONTINUE
28315 IF(KFA.NE.22) THEN
28316 DO 150 KFL=-3,3
28317 XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL)
28318 150 CONTINUE
28319 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1)
28320 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2)
28321 ELSE
28322 DO 160 KFL=-3,3
28323 XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL)
28324 160 CONTINUE
28325 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
28326 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
28327 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
28328 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
28329 ENDIF
28330 XPQ(21)=XPQ(0)
28331 MINT(92)=4
28332 ENDIF
28333
28334C...Format for error printout.
28335 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
28336
28337 RETURN
28338 END
28339
28340C*********************************************************************
28341
28342C...PYPDEL
28343C...Gives electron (or muon, or tau) parton distribution.
28344
28345 SUBROUTINE PYPDEL(KFA,X,Q2,XPEL)
28346
28347C...Double precision and integer declarations.
28348 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28349 IMPLICIT INTEGER(I-N)
28350 INTEGER PYK,PYCHGE,PYCOMP
28351C...Commonblocks.
28352 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28353 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28354 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28355 COMMON/PYINT1/MINT(400),VINT(400)
28356 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
28357C...Local arrays.
28358 DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6)
28359
28360C...Interface to PDFLIB.
81935ff8 28361 COMMON/LW50513/XMIN,XMAX,Q2MIN,Q2MAX
28362 SAVE /LW50513/
2dfa57d1 28363 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
28364 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
28365 CHARACTER*20 PARM(20)
28366 DATA VALUE/20*0D0/,PARM/20*' '/
28367
28368C...Some common constants.
28369 DO 100 KFL=-25,25
28370 XPEL(KFL)=0D0
28371 100 CONTINUE
28372 AEM=PARU(101)
28373 PME=PMAS(11,1)
28374 IF(KFA.EQ.13) PME=PMAS(13,1)
28375 IF(KFA.EQ.15) PME=PMAS(15,1)
28376 XL=LOG(MAX(1D-10,X))
28377 X1L=LOG(MAX(1D-10,1D0-X))
28378 HLE=LOG(MAX(3D0,Q2/PME**2))
28379 HBE2=(AEM/PARU(1))*(HLE-1D0)
28380
28381C...Electron inside electron, see R. Kleiss et al., in Z physics at
28382C...LEP 1, CERN 89-08, p. 34
28383 IF(MSTP(59).LE.1) THEN
28384 HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2*
28385 & (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0)
28386 HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))-
28387 & 0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)-
28388 & 4D0*XL/(1D0-X)-5D0-X)
28389 ELSE
28390 HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/
28391 & PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*
28392 & (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X)
28393 ENDIF
28394C...Zero distribution for very large x and rescale it for intermediate.
28395 IF(X.GT.1D0-1D-10) THEN
28396 HEE=0D0
28397 ELSEIF(X.GT.1D0-1D-7) THEN
28398 HEE=HEE*1000D0**HBE2/(1000D0**HBE2-1D0)
28399 ENDIF
28400 XPEL(KFA)=X*HEE
28401
28402C...Photon and (transverse) W- inside electron.
28403 AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2)
28404 IF(MSTP(13).LE.1) THEN
28405 HLG=HLE
28406 ELSE
28407 HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2))
28408 ENDIF
28409 XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2)
28410 HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102))
28411 XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2)
28412
28413C...Electron or positron inside photon inside electron.
28414 IF(KFA.EQ.11.AND.MSTP(12).EQ.1) THEN
28415 XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+
28416 & 2D0*X*(1D0+X)*XL)
28417 XPEL(11)=XPEL(11)+XFSEA
28418 XPEL(-11)=XFSEA
28419
28420C...Initialize PDFLIB photon parton distributions.
28421 IF(MSTP(56).EQ.2) THEN
28422 PARM(1)='NPTYPE'
28423 VALUE(1)=3
28424 PARM(2)='NGROUP'
28425 VALUE(2)=MSTP(55)/1000
28426 PARM(3)='NSET'
28427 VALUE(3)=MOD(MSTP(55),1000)
28428 IF(MINT(93).NE.3000000+MSTP(55)) THEN
28429 CALL PDFSET(PARM,VALUE)
28430 MINT(93)=3000000+MSTP(55)
28431 ENDIF
28432 ENDIF
28433
28434C...Quarks and gluons inside photon inside electron:
28435C...numerical convolution required.
28436 DO 110 KFL=0,6
28437 SXP(KFL)=0D0
28438 110 CONTINUE
28439 SUMXPP=0D0
28440 ITER=-1
28441 120 ITER=ITER+1
28442 SUMXP=SUMXPP
28443 NSTP=2**(ITER-1)
28444 IF(ITER.EQ.0) NSTP=2
28445 DO 130 KFL=0,6
28446 SXP(KFL)=0.5D0*SXP(KFL)
28447 130 CONTINUE
28448 WTSTP=0.5D0/NSTP
28449 IF(ITER.EQ.0) WTSTP=0.5D0
28450C...Pick grid of x_{gamma} values logarithmically even.
28451 DO 150 ISTP=1,NSTP
28452 IF(ITER.EQ.0) THEN
28453 XLE=XL*(ISTP-1)
28454 ELSE
28455 XLE=XL*(ISTP-0.5D0)/NSTP
28456 ENDIF
28457 XE=MIN(1D0-1D-10,EXP(XLE))
28458 XG=MIN(1D0-1D-10,X/XE)
28459C...Evaluate photon inside electron parton distribution for convolution.
28460 XPGP=1D0+(1D0-XE)**2
28461 IF(MSTP(13).LE.1) THEN
28462 XPGP=XPGP*HLE
28463 ELSE
28464 XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2))
28465 ENDIF
28466C...Evaluate photon parton distributions for convolution.
28467 IF(MSTP(56).EQ.1) THEN
28468 IF(MSTP(55).EQ.1) THEN
28469 CALL PYPDGA(XG,Q2,XPGA)
28470 ELSEIF(MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
28471 Q2MX=Q2
28472 P2MX=0.36D0
28473 IF(MSTP(55).GE.7) P2MX=4.0D0
28474 IF(MSTP(57).EQ.0) Q2MX=P2MX
28475 P2=0D0
28476 IF(VINT(120).LT.0D0) P2=VINT(120)**2
28477 CALL PYGGAM(MSTP(55)-4,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
28478 VINT(231)=P2MX
28479 ELSEIF(MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
28480 Q2MX=Q2
28481 P2MX=0.36D0
28482 IF(MSTP(55).GE.11) P2MX=4.0D0
28483 IF(MSTP(57).EQ.0) Q2MX=P2MX
28484 P2=0D0
28485 IF(VINT(120).LT.0D0) P2=VINT(120)**2
28486 CALL PYGGAM(MSTP(55)-8,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
28487 VINT(231)=P2MX
28488 ENDIF
28489 DO 140 KFL=0,5
28490 SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL)
28491 140 CONTINUE
28492 ELSEIF(MSTP(56).EQ.2) THEN
28493C...Call PDFLIB parton distributions.
28494 XX=XG
28495 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
28496 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
28497 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
28498 SXP(0)=SXP(0)+WTSTP*XPGP*GLU
28499 SXP(1)=SXP(1)+WTSTP*XPGP*DNV
28500 SXP(2)=SXP(2)+WTSTP*XPGP*UPV
28501 SXP(3)=SXP(3)+WTSTP*XPGP*STR
28502 SXP(4)=SXP(4)+WTSTP*XPGP*CHM
28503 SXP(5)=SXP(5)+WTSTP*XPGP*BOT
28504 SXP(6)=SXP(6)+WTSTP*XPGP*TOP
28505 ENDIF
28506 150 CONTINUE
28507 SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2)
28508 IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT.
28509 & PARP(14)*(SUMXPP+SUMXP))) GOTO 120
28510
28511C...Put convolution into output arrays.
28512 FCONV=AEMP*(-XL)
28513 XPEL(0)=FCONV*SXP(0)
28514 DO 160 KFL=1,6
28515 XPEL(KFL)=FCONV*SXP(KFL)
28516 XPEL(-KFL)=XPEL(KFL)
28517 160 CONTINUE
28518 ENDIF
28519
28520 RETURN
28521 END
28522
28523C*********************************************************************
28524
28525C...PYPDGA
28526C...Gives photon parton distribution.
28527
28528 SUBROUTINE PYPDGA(X,Q2,XPGA)
28529
28530C...Double precision and integer declarations.
28531 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28532 IMPLICIT INTEGER(I-N)
28533 INTEGER PYK,PYCHGE,PYCOMP
28534C...Commonblocks.
28535 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28536 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28537 COMMON/PYINT1/MINT(400),VINT(400)
28538 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
28539C...Local arrays.
28540 DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3),
28541 &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3),
28542 &DGCS(4,3),DGDS(4,3),DGES(4,3)
28543
28544C...The following data lines are coefficients needed in the
28545C...Drees and Grassie photon parton distribution parametrization.
28546 DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0,
28547 &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/
28548 DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0,
28549 &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/
28550 DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0,
28551 &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/
28552 DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0,
28553 &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/
28554 DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0,
28555 &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/
28556 DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1,
28557 &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/
28558 DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0,
28559 &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/
28560 DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0,
28561 &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/
28562 DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0,
28563 &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/
28564 DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0,
28565 &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/
28566 DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0,
28567 &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/
28568 DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0,
28569 &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/
28570 DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0,
28571 &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/
28572
28573C...Photon parton distribution from Drees and Grassie.
28574C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
28575 DO 100 KFL=-6,6
28576 XPGA(KFL)=0D0
28577 100 CONTINUE
28578 VINT(231)=1D0
28579 IF(MSTP(57).LE.0) THEN
28580 T=LOG(1D0/0.16D0)
28581 ELSE
28582 T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0)
28583 ENDIF
28584 X1=1D0-X
28585 NF=3
28586 IF(Q2.GT.25D0) NF=4
28587 IF(Q2.GT.300D0) NF=5
28588 NFE=NF-2
28589 AEM=PARU(101)
28590
28591C...Evaluate gluon content.
28592 DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE))
28593 DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE))
28594 DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE))
28595 XPGL=DGA*X**DGB*X1**DGC
28596
28597C...Evaluate up- and down-type quark content.
28598 DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE))
28599 DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE))
28600 DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE))
28601 DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE))
28602 DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE))
28603 XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
28604 DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE))
28605 DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE))
28606 DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE))
28607 DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE))
28608 DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE))
28609 DGF=9D0
28610 IF(NF.EQ.4) DGF=10D0
28611 IF(NF.EQ.5) DGF=55D0/6D0
28612 XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
28613 IF(NF.LE.3) THEN
28614 XPQU=(XPQS+9D0*XPQN)/6D0
28615 XPQD=(XPQS-4.5D0*XPQN)/6D0
28616 ELSEIF(NF.EQ.4) THEN
28617 XPQU=(XPQS+6D0*XPQN)/8D0
28618 XPQD=(XPQS-6D0*XPQN)/8D0
28619 ELSE
28620 XPQU=(XPQS+7.5D0*XPQN)/10D0
28621 XPQD=(XPQS-5D0*XPQN)/10D0
28622 ENDIF
28623
28624C...Put into output arrays.
28625 XPGA(0)=AEM*XPGL
28626 XPGA(1)=AEM*XPQD
28627 XPGA(2)=AEM*XPQU
28628 XPGA(3)=AEM*XPQD
28629 IF(NF.GE.4) XPGA(4)=AEM*XPQU
28630 IF(NF.GE.5) XPGA(5)=AEM*XPQD
28631 DO 110 KFL=1,6
28632 XPGA(-KFL)=XPGA(KFL)
28633 110 CONTINUE
28634
28635 RETURN
28636 END
28637
28638C*********************************************************************
28639
28640C...PYGGAM
28641C...Constructs the F2 and parton distributions of the photon
28642C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
28643C...For F2, c and b are included by the Bethe-Heitler formula;
28644C...in the 'MSbar' scheme additionally a Cgamma term is added.
28645C...Contains the SaS sets 1D, 1M, 2D and 2M.
28646C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
28647
28648 SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
28649
28650C...Double precision and integer declarations.
28651 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28652 IMPLICIT INTEGER(I-N)
28653 INTEGER PYK,PYCHGE,PYCOMP
28654C...Commonblocks.
28655 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
28656 &XPDIR(-6:6)
28657 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
28658 SAVE /PYINT8/,/PYINT9/
28659C...Local arrays.
28660 DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6)
28661C...Charm and bottom masses (low to compensate for J/psi etc.).
28662 DATA PMC/1.3D0/, PMB/4.6D0/
28663C...alpha_em and alpha_em/(2*pi).
28664 DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/
28665C...Lambda value for 4 flavours.
28666 DATA ALAM/0.20D0/
28667C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
28668 DATA FRACU/0.8D0/
28669C...VMD couplings f_V**2/(4*pi).
28670 DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/
28671C...Masses for rho (=omega) and phi.
28672 DATA PMRHO/0.770D0/, PMPHI/1.020D0/
28673C...Number of points in integration for IP2=1.
28674 DATA NSTEP/100/
28675
28676C...Reset output.
28677 F2GM=0D0
28678 DO 100 KFL=-6,6
28679 XPDFGM(KFL)=0D0
28680 XPVMD(KFL)=0D0
28681 XPANL(KFL)=0D0
28682 XPANH(KFL)=0D0
28683 XPBEH(KFL)=0D0
28684 XPDIR(KFL)=0D0
28685 VXPVMD(KFL)=0D0
28686 VXPANL(KFL)=0D0
28687 VXPANH(KFL)=0D0
28688 VXPDGM(KFL)=0D0
28689 100 CONTINUE
28690
28691C...Set Q0 cut-off parameter as function of set used.
28692 IF(ISET.LE.2) THEN
28693 Q0=0.6D0
28694 ELSE
28695 Q0=2D0
28696 ENDIF
28697 Q02=Q0**2
28698
28699C...Scale choice for off-shell photon; common factors.
28700 Q2A=Q2
28701 FACNOR=1D0
28702 IF(IP2.EQ.1) THEN
28703 P2MX=P2+Q02
28704 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
28705 FACNOR=LOG(Q2/Q02)/NSTEP
28706 ELSEIF(IP2.EQ.2) THEN
28707 P2MX=MAX(P2,Q02)
28708 ELSEIF(IP2.EQ.3) THEN
28709 P2MX=P2+Q02
28710 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
28711 ELSEIF(IP2.EQ.4) THEN
28712 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
28713 & ((Q2+P2)*(Q02+P2)))
28714 ELSEIF(IP2.EQ.5) THEN
28715 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
28716 & ((Q2+P2)*(Q02+P2)))
28717 P2MX=Q0*SQRT(P2MXA)
28718 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
28719 ELSEIF(IP2.EQ.6) THEN
28720 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
28721 & ((Q2+P2)*(Q02+P2)))
28722 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
28723 ELSE
28724 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
28725 & ((Q2+P2)*(Q02+P2)))
28726 P2MX=Q0*SQRT(P2MXA)
28727 P2MXB=P2MX
28728 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
28729 P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA
28730 IF(ABS(Q2-Q02).GT.1D-6) THEN
28731 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
28732 ELSEIF(P2.LT.Q02) THEN
28733 FACNOR=Q02**3/(Q02+P2)/(Q02**2-P2**2/2D0)
28734 ELSE
28735 FACNOR=1D0
28736 ENDIF
28737 ENDIF
28738
28739C...Call VMD parametrization for d quark and use to give rho, omega,
28740C...phi. Note dipole dampening for off-shell photon.
28741 CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
28742 XFVAL=VXPGA(1)
28743 XPGA(1)=XPGA(2)
28744 XPGA(-1)=XPGA(-2)
28745 FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
28746 FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
28747 DO 110 KFL=-5,5
28748 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
28749 110 CONTINUE
28750 XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL
28751 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
28752 XPVMD(3)=XPVMD(3)+FACS*XFVAL
28753 XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL
28754 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
28755 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
28756 VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL
28757 VXPVMD(2)=FRACU*FACUD*XFVAL
28758 VXPVMD(3)=FACS*XFVAL
28759 VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL
28760 VXPVMD(-2)=FRACU*FACUD*XFVAL
28761 VXPVMD(-3)=FACS*XFVAL
28762
28763 IF(IP2.NE.1) THEN
28764C...Anomalous parametrizations for different strategies
28765C...for off-shell photons; except full integration.
28766
28767C...Call anomalous parametrization for d + u + s.
28768 CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
28769 DO 120 KFL=-5,5
28770 XPANL(KFL)=FACNOR*XPGA(KFL)
28771 VXPANL(KFL)=FACNOR*VXPGA(KFL)
28772 120 CONTINUE
28773
28774C...Call anomalous parametrization for c and b.
28775 CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
28776 DO 130 KFL=-5,5
28777 XPANH(KFL)=FACNOR*XPGA(KFL)
28778 VXPANH(KFL)=FACNOR*VXPGA(KFL)
28779 130 CONTINUE
28780 CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
28781 DO 140 KFL=-5,5
28782 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
28783 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
28784 140 CONTINUE
28785
28786 ELSE
28787C...Special option: loop over flavours and integrate over k2.
28788 DO 170 KF=1,5
28789 DO 160 ISTEP=1,NSTEP
28790 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP)
28791 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
28792 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
28793 CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
28794 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
28795 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0)
28796 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0)
28797 DO 150 KFL=-5,5
28798 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
28799 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
28800 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
28801 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
28802 150 CONTINUE
28803 160 CONTINUE
28804 170 CONTINUE
28805 ENDIF
28806
28807C...Call Bethe-Heitler term expression for charm and bottom.
28808 CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH)
28809 XPBEH(4)=XPBH
28810 XPBEH(-4)=XPBH
28811 CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH)
28812 XPBEH(5)=XPBH
28813 XPBEH(-5)=XPBH
28814
28815C...For MSbar subtraction call C^gamma term expression for d, u, s.
28816 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
28817 CALL PYGDIR(X,Q2,P2,Q02,XPGA)
28818 DO 180 KFL=-5,5
28819 XPDIR(KFL)=XPGA(KFL)
28820 180 CONTINUE
28821 ENDIF
28822
28823C...Store result in output array.
28824 DO 190 KFL=-5,5
28825 CHSQ=1D0/9D0
28826 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0
28827 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
28828 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
28829 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
28830 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
28831 190 CONTINUE
28832
28833 RETURN
28834 END
28835
28836C*********************************************************************
28837
28838C...PYGVMD
28839C...Evaluates the VMD parton distributions of a photon,
28840C...evolved homogeneously from an initial scale P2 to Q2.
28841C...Does not include dipole suppression factor.
28842C...ISET is parton distribution set, see above;
28843C...additionally ISET=0 is used for the evolution of an anomalous photon
28844C...which branched at a scale P2 and then evolved homogeneously to Q2.
28845C...ALAM is the 4-flavour Lambda, which is automatically converted
28846C...to 3- and 5-flavour equivalents as needed.
28847C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
28848
28849 SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
28850
28851C...Double precision and integer declarations.
28852 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28853 IMPLICIT INTEGER(I-N)
28854 INTEGER PYK,PYCHGE,PYCOMP
28855C...Local arrays and data.
28856 DIMENSION XPGA(-6:6), VXPGA(-6:6)
28857 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
28858
28859C...Reset output.
28860 DO 100 KFL=-6,6
28861 XPGA(KFL)=0D0
28862 VXPGA(KFL)=0D0
28863 100 CONTINUE
28864 KFA=IABS(KF)
28865
28866C...Calculate Lambda; protect against unphysical Q2 and P2 input.
28867 ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
28868 ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
28869 P2EFF=MAX(P2,1.2D0*ALAM3**2)
28870 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
28871 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
28872 Q2EFF=MAX(Q2,P2EFF)
28873
28874C...Find number of flavours at lower and upper scale.
28875 NFP=4
28876 IF(P2EFF.LT.PMC**2) NFP=3
28877 IF(P2EFF.GT.PMB**2) NFP=5
28878 NFQ=4
28879 IF(Q2EFF.LT.PMC**2) NFQ=3
28880 IF(Q2EFF.GT.PMB**2) NFQ=5
28881
28882C...Find s as sum of 3-, 4- and 5-flavour parts.
28883 S=0D0
28884 IF(NFP.EQ.3) THEN
28885 Q2DIV=PMC**2
28886 IF(NFQ.EQ.3) Q2DIV=Q2EFF
28887 S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
28888 ENDIF
28889 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
28890 P2DIV=P2EFF
28891 IF(NFP.EQ.3) P2DIV=PMC**2
28892 Q2DIV=Q2EFF
28893 IF(NFQ.EQ.5) Q2DIV=PMB**2
28894 S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
28895 ENDIF
28896 IF(NFQ.EQ.5) THEN
28897 P2DIV=PMB**2
28898 IF(NFP.EQ.5) P2DIV=P2EFF
28899 S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
28900 ENDIF
28901
28902C...Calculate frequent combinations of x and s.
28903 X1=1D0-X
28904 XL=-LOG(X)
28905 S2=S**2
28906 S3=S**3
28907 S4=S**4
28908
28909C...Evaluate homogeneous anomalous parton distributions below or
28910C...above threshold.
28911 IF(ISET.EQ.0) THEN
28912 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
28913 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
28914 XVAL = X * 1.5D0 * (X**2+X1**2)
28915 XGLU = 0D0
28916 XSEA = 0D0
28917 ELSE
28918 XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
28919 & (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
28920 & 5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
28921 & X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
28922 XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
28923 & X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
28924 & ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
28925 XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
28926 & X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
28927 & ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
28928 & (2D0*X-1D0)*X*XL**2)
28929 ENDIF
28930
28931C...Evaluate set 1D parton distributions below or above threshold.
28932 ELSEIF(ISET.EQ.1) THEN
28933 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
28934 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
28935 XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
28936 XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
28937 XSEA = 0.100D0 * X1**3.76D0
28938 ELSE
28939 XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
28940 & X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
28941 XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
28942 & X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
28943 & XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
28944 & X**0.40D0 * X1**(1.76D0+3D0*S)
28945 XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
28946 & (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
28947 & X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
28948 XSEA0 = 0.100D0 * X1**3.76D0
28949 ENDIF
28950
28951C...Evaluate set 1M parton distributions below or above threshold.
28952 ELSEIF(ISET.EQ.2) THEN
28953 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
28954 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
28955 XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
28956 XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
28957 XSEA = 0D0
28958 ELSE
28959 XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
28960 & X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
28961 XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
28962 & EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
28963 & X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
28964 & EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
28965 XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
28966 & X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
28967 & XL**(2.8D0*S)
28968 XSEA0 = 0D0
28969 ENDIF
28970
28971C...Evaluate set 2D parton distributions below or above threshold.
28972 ELSEIF(ISET.EQ.3) THEN
28973 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
28974 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
28975 XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
28976 XGLU = 1.925D0 * X1**2
28977 XSEA = 0.242D0 * X1**4
28978 ELSE
28979 XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
28980 & X**(0.46D0+0.25D0*S) *
28981 & X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
28982 & (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
28983 XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
28984 & EXP(-18.67D0*S) *
28985 & X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
28986 & * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
28987 & XL**(9.3D0*S/(1D0+1.7D0*S))
28988 XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
28989 & (1D0-0.607D0*S+21.95D0*S2) *
28990 & X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
28991 XSEA0 = 0.242D0 * X1**4
28992 ENDIF
28993
28994C...Evaluate set 2M parton distributions below or above threshold.
28995 ELSEIF(ISET.EQ.4) THEN
28996 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
28997 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
28998 XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
28999 XGLU = 1.808D0 * X1**2
29000 XSEA = 0.209D0 * X1**4
29001 ELSE
29002 XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
29003 & X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
29004 & X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
29005 & XL**(5.15D0*S/(1D0+2D0*S)) +
29006 & (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
29007 XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
29008 & X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
29009 & X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
29010 & XL**(10.9D0*S/(1D0+2.5D0*S))
29011 XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
29012 & X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
29013 & X1**(4D0+S) * XL**(0.45D0*S)
29014 XSEA0 = 0.209D0 * X1**4
29015 ENDIF
29016 ENDIF
29017
29018C...Threshold factors for c and b sea.
29019 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
29020 XCHM=0D0
29021 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
29022 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
29023 IF(ISET.EQ.0) THEN
29024 XCHM=XSEA*(1D0-(SCH/SLL)**2)
29025 ELSE
29026 XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
29027 ENDIF
29028 ENDIF
29029 XBOT=0D0
29030 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
29031 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
29032 IF(ISET.EQ.0) THEN
29033 XBOT=XSEA*(1D0-(SBT/SLL)**2)
29034 ELSE
29035 XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
29036 ENDIF
29037 ENDIF
29038
29039C...Fill parton distributions.
29040 XPGA(0)=XGLU
29041 XPGA(1)=XSEA
29042 XPGA(2)=XSEA
29043 XPGA(3)=XSEA
29044 XPGA(4)=XCHM
29045 XPGA(5)=XBOT
29046 XPGA(KFA)=XPGA(KFA)+XVAL
29047 DO 110 KFL=1,5
29048 XPGA(-KFL)=XPGA(KFL)
29049 110 CONTINUE
29050 VXPGA(KFA)=XVAL
29051 VXPGA(-KFA)=XVAL
29052
29053 RETURN
29054 END
29055
29056C*********************************************************************
29057
29058C...PYGANO
29059C...Evaluates the parton distributions of the anomalous photon,
29060C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
29061C...KF=0 gives the sum over (up to) 5 flavours,
29062C...KF<0 limits to flavours up to abs(KF),
29063C...KF>0 is for flavour KF only.
29064C...ALAM is the 4-flavour Lambda, which is automatically converted
29065C...to 3- and 5-flavour equivalents as needed.
29066C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
29067
29068 SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
29069
29070C...Double precision and integer declarations.
29071 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29072 IMPLICIT INTEGER(I-N)
29073 INTEGER PYK,PYCHGE,PYCOMP
29074C...Local arrays and data.
29075 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
29076 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
29077
29078C...Reset output.
29079 DO 100 KFL=-6,6
29080 XPGA(KFL)=0D0
29081 VXPGA(KFL)=0D0
29082 100 CONTINUE
29083 IF(Q2.LE.P2) RETURN
29084 KFA=IABS(KF)
29085
29086C...Calculate Lambda; protect against unphysical Q2 and P2 input.
29087 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2
29088 ALAMSQ(4)=ALAM**2
29089 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2
29090 P2EFF=MAX(P2,1.2D0*ALAMSQ(3))
29091 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
29092 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
29093 Q2EFF=MAX(Q2,P2EFF)
29094 XL=-LOG(X)
29095
29096C...Find number of flavours at lower and upper scale.
29097 NFP=4
29098 IF(P2EFF.LT.PMC**2) NFP=3
29099 IF(P2EFF.GT.PMB**2) NFP=5
29100 NFQ=4
29101 IF(Q2EFF.LT.PMC**2) NFQ=3
29102 IF(Q2EFF.GT.PMB**2) NFQ=5
29103
29104C...Define range of flavour loop.
29105 IF(KF.EQ.0) THEN
29106 KFLMN=1
29107 KFLMX=5
29108 ELSEIF(KF.LT.0) THEN
29109 KFLMN=1
29110 KFLMX=KFA
29111 ELSE
29112 KFLMN=KFA
29113 KFLMX=KFA
29114 ENDIF
29115
29116C...Loop over flavours the photon can branch into.
29117 DO 110 KFL=KFLMN,KFLMX
29118
29119C...Light flavours: calculate t range and (approximate) s range.
29120 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
29121 TDIFF=LOG(Q2EFF/P2EFF)
29122 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
29123 & LOG(P2EFF/ALAMSQ(NFQ)))
29124 IF(NFQ.GT.NFP) THEN
29125 Q2DIV=PMB**2
29126 IF(NFQ.EQ.4) Q2DIV=PMC**2
29127 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
29128 & LOG(P2EFF/ALAMSQ(NFQ)))
29129 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
29130 & LOG(P2EFF/ALAMSQ(NFQ-1)))
29131 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
29132 ENDIF
29133 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
29134 Q2DIV=PMC**2
29135 SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
29136 & LOG(P2EFF/ALAMSQ(4)))
29137 SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
29138 & LOG(P2EFF/ALAMSQ(3)))
29139 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
29140 ENDIF
29141
29142C...u and s quark do not need a separate treatment when d has been done.
29143 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
29144
29145C...Charm: as above, but only include range above c threshold.
29146 ELSEIF(KFL.EQ.4) THEN
29147 IF(Q2.LE.PMC**2) GOTO 110
29148 P2EFF=MAX(P2EFF,PMC**2)
29149 Q2EFF=MAX(Q2EFF,P2EFF)
29150 TDIFF=LOG(Q2EFF/P2EFF)
29151 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
29152 & LOG(P2EFF/ALAMSQ(NFQ)))
29153 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
29154 Q2DIV=PMB**2
29155 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
29156 & LOG(P2EFF/ALAMSQ(NFQ)))
29157 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
29158 & LOG(P2EFF/ALAMSQ(NFQ-1)))
29159 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
29160 ENDIF
29161
29162C...Bottom: as above, but only include range above b threshold.
29163 ELSEIF(KFL.EQ.5) THEN
29164 IF(Q2.LE.PMB**2) GOTO 110
29165 P2EFF=MAX(P2EFF,PMB**2)
29166 Q2EFF=MAX(Q2,P2EFF)
29167 TDIFF=LOG(Q2EFF/P2EFF)
29168 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
29169 & LOG(P2EFF/ALAMSQ(NFQ)))
29170 ENDIF
29171
29172C...Evaluate flavour-dependent prefactor (charge^2 etc.).
29173 CHSQ=1D0/9D0
29174 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0
29175 FAC=AEM2PI*2D0*CHSQ*TDIFF
29176
29177C...Evaluate parton distributions (normalized to unit momentum sum).
29178 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
29179 XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 +
29180 & (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 +
29181 & 1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) *
29182 & X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S))
29183 XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) *
29184 & X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) *
29185 & ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL)
29186 XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) *
29187 & X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) *
29188 & ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 +
29189 & (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2)
29190
29191C...Threshold factors for c and b sea.
29192 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
29193 XCHM=0D0
29194 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
29195 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
29196 XCHM=XSEA*(1D0-(SCH/SLL)**3)
29197 ENDIF
29198 XBOT=0D0
29199 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
29200 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
29201 XBOT=XSEA*(1D0-(SBT/SLL)**3)
29202 ENDIF
29203 ENDIF
29204
29205C...Add contribution of each valence flavour.
29206 XPGA(0)=XPGA(0)+FAC*XGLU
29207 XPGA(1)=XPGA(1)+FAC*XSEA
29208 XPGA(2)=XPGA(2)+FAC*XSEA
29209 XPGA(3)=XPGA(3)+FAC*XSEA
29210 XPGA(4)=XPGA(4)+FAC*XCHM
29211 XPGA(5)=XPGA(5)+FAC*XBOT
29212 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
29213 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
29214 110 CONTINUE
29215 DO 120 KFL=1,5
29216 XPGA(-KFL)=XPGA(KFL)
29217 VXPGA(-KFL)=VXPGA(KFL)
29218 120 CONTINUE
29219
29220 RETURN
29221 END
29222
29223C*********************************************************************
29224
29225C...PYGBEH
29226C...Evaluates the Bethe-Heitler cross section for heavy flavour
29227C...production.
29228C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
29229
29230 SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)
29231
29232C...Double precision and integer declarations.
29233 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29234 IMPLICIT INTEGER(I-N)
29235 INTEGER PYK,PYCHGE,PYCOMP
29236
29237C...Local data.
29238 DATA AEM2PI/0.0011614D0/
29239
29240C...Reset output.
29241 XPBH=0D0
29242 SIGBH=0D0
29243
29244C...Check kinematics limits.
29245 IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
29246 W2=Q2*(1D0-X)/X-P2
29247 BETA2=1D0-4D0*PM2/W2
29248 IF(BETA2.LT.1D-10) RETURN
29249 BETA=SQRT(BETA2)
29250 RMQ=4D0*PM2/Q2
29251
29252C...Simple case: P2 = 0.
29253 IF(P2.LT.1D-4) THEN
29254 IF(BETA.LT.0.99D0) THEN
29255 XBL=LOG((1D0+BETA)/(1D0-BETA))
29256 ELSE
29257 XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
29258 ENDIF
29259 SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
29260 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)
29261
29262C...Complicated case: P2 > 0, based on approximation of
29263C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
29264 ELSE
29265 RPQ=1D0-4D0*X**2*P2/Q2
29266 IF(RPQ.GT.1D-10) THEN
29267 RPBE=SQRT(RPQ*BETA2)
29268 IF(RPBE.LT.0.99D0) THEN
29269 XBL=LOG((1D0+RPBE)/(1D0-RPBE))
29270 XBI=2D0*RPBE/(1D0-RPBE**2)
29271 ELSE
29272 RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
29273 XBL=LOG((1D0+RPBE)**2/RPBESN)
29274 XBI=2D0*RPBE/RPBESN
29275 ENDIF
29276 SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
29277 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
29278 & XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
29279 ENDIF
29280 ENDIF
29281
29282C...Multiply by charge-squared etc. to get parton distribution.
29283 CHSQ=1D0/9D0
29284 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0
29285 XPBH=3D0*CHSQ*AEM2PI*X*SIGBH
29286
29287 RETURN
29288 END
29289
29290C*********************************************************************
29291
29292C...PYGDIR
29293C...Evaluates the direct contribution, i.e. the C^gamma term,
29294C...as needed in MSbar parametrizations.
29295C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
29296
29297 SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA)
29298
29299C...Double precision and integer declarations.
29300 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29301 IMPLICIT INTEGER(I-N)
29302 INTEGER PYK,PYCHGE,PYCOMP
29303C...Local array and data.
29304 DIMENSION XPGA(-6:6)
29305 DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/
29306
29307C...Reset output.
29308 DO 100 KFL=-6,6
29309 XPGA(KFL)=0D0
29310 100 CONTINUE
29311
29312C...Evaluate common x-dependent expression.
29313 XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0
29314 CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X))
29315
29316C...d, u, s part by simple charge factor.
29317 XPGA(1)=(1D0/9D0)*CGAM
29318 XPGA(2)=(4D0/9D0)*CGAM
29319 XPGA(3)=(1D0/9D0)*CGAM
29320
29321C...Also fill for antiquarks.
29322 DO 110 KF=1,5
29323 XPGA(-KF)=XPGA(KF)
29324 110 CONTINUE
29325
29326 RETURN
29327 END
29328
29329C*********************************************************************
29330
29331C...PYPDPI
29332C...Gives pi+ parton distribution according to two different
29333C...parametrizations.
29334
29335 SUBROUTINE PYPDPI(X,Q2,XPPI)
29336
29337C...Double precision and integer declarations.
29338 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29339 IMPLICIT INTEGER(I-N)
29340 INTEGER PYK,PYCHGE,PYCOMP
29341C...Commonblocks.
29342 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29343 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29344 COMMON/PYINT1/MINT(400),VINT(400)
29345 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
29346C...Local arrays.
29347 DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6)
29348
29349C...The following data lines are coefficients needed in the
29350C...Owens pion parton distribution parametrizations, see below.
29351C...Expansion coefficients for up and down valence quark distributions.
29352 DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
29353 &4.0000D-01, 7.0000D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
29354 &-6.2120D-02, 6.4780D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
29355 &-7.1090D-03, 1.3350D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
29356 DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
29357 &4.0000D-01, 6.2800D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
29358 &-5.9090D-02, 6.4360D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
29359 &-6.5240D-03, 1.4510D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
29360C...Expansion coefficients for gluon distribution.
29361 DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
29362 &8.8800D-01, 0.0000D+00, 3.1100D+00, 6.0000D+00, 0.0000D+00,
29363 &-1.8020D+00, -1.5760D+00, -1.3170D-01, 2.8010D+00, -1.7280D+01,
29364 &1.8120D+00, 1.2000D+00, 5.0680D-01, -1.2160D+01, 2.0490D+01/
29365 DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
29366 &7.9400D-01, 0.0000D+00, 2.8900D+00, 6.0000D+00, 0.0000D+00,
29367 &-9.1440D-01, -1.2370D+00, 5.9660D-01, -3.6710D+00, -8.1910D+00,
29368 &5.9660D-01, 6.5820D-01, -2.5500D-01, -2.3040D+00, 7.7580D+00/
29369C...Expansion coefficients for (up+down+strange) quark sea distribution.
29370 DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
29371 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
29372 &-2.4280D-01, -2.1200D-01, 8.6730D-01, 1.2660D+00, 2.3820D+00,
29373 &1.3860D-01, 3.6710D-03, 4.7470D-02, -2.2150D+00, 3.4820D-01/
29374 DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
29375 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
29376 &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00, 5.6210D-01,
29377 &-1.7400D-01, -9.6230D-02, 1.5750D+00, 1.3780D+00, -2.7010D-01/
29378C...Expansion coefficients for charm quark sea distribution.
29379 DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
29380 &0.0000D+00, -2.2120D-02, 2.8940D+00, 0.0000D+00, 0.0000D+00,
29381 &7.9280D-02, -3.7850D-01, 9.4330D+00, 5.2480D+00, 8.3880D+00,
29382 &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/
29383 DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
29384 &0.0000D+00, -8.8200D-02, 1.9240D+00, 0.0000D+00, 0.0000D+00,
29385 &6.2290D-02, -2.8920D-01, 2.4240D-01, -4.4630D+00, -8.3670D-01,
29386 &-4.0990D-02, -1.0820D-01, 2.0360D+00, 5.2090D+00, -4.8400D-02/
29387
29388C...Euler's beta function, requires ordinary Gamma function
29389 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
29390
29391C...Reset output array.
29392 DO 100 KFL=-6,6
29393 XPPI(KFL)=0D0
29394 100 CONTINUE
29395
29396 IF(MSTP(53).LE.2) THEN
29397C...Pion parton distributions from Owens.
29398C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
29399
29400C...Determine set, Lambda and s expansion variable.
29401 NSET=MSTP(53)
29402 IF(NSET.EQ.1) ALAM=0.2D0
29403 IF(NSET.EQ.2) ALAM=0.4D0
29404 VINT(231)=4D0
29405 IF(MSTP(57).LE.0) THEN
29406 SD=0D0
29407 ELSE
29408 Q2IN=MIN(2D3,MAX(4D0,Q2))
29409 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
29410 ENDIF
29411
29412C...Calculate parton distributions.
29413 DO 120 KFL=1,4
29414 DO 110 IS=1,5
29415 TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
29416 & COW(3,IS,KFL,NSET)*SD**2
29417 110 CONTINUE
29418 IF(KFL.EQ.1) THEN
29419 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0)
29420 ELSE
29421 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
29422 & TS(5)*X**2)
29423 ENDIF
29424 120 CONTINUE
29425
29426C...Put into output array.
29427 XPPI(0)=XQ(2)
29428 XPPI(1)=XQ(3)/6D0
29429 XPPI(2)=XQ(1)+XQ(3)/6D0
29430 XPPI(3)=XQ(3)/6D0
29431 XPPI(4)=XQ(4)
29432 XPPI(-1)=XQ(1)+XQ(3)/6D0
29433 XPPI(-2)=XQ(3)/6D0
29434 XPPI(-3)=XQ(3)/6D0
29435 XPPI(-4)=XQ(4)
29436
29437C...Leading order pion parton distributions from Glueck, Reya and Vogt.
29438C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
29439C...10^-5 < x < 1.
29440 ELSE
29441
29442C...Determine s expansion variable and some x expressions.
29443 VINT(231)=0.25D0
29444 IF(MSTP(57).LE.0) THEN
29445 SD=0D0
29446 ELSE
29447 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
29448 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
29449 ENDIF
29450 SD2=SD**2
29451 XL=-LOG(X)
29452 XS=SQRT(X)
29453
29454C...Evaluate valence, gluon and sea distributions.
29455 XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)*
29456 & (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD)
29457 XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0*
29458 & SD-0.175D0*SD2)+
29459 & (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+
29460 & SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0*
29461 & XL)))*
29462 & (1D0-X)**(0.390D0+1.053D0*SD)
29463 XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0-
29464 & X)**3.359D0*
29465 & EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0*
29466 & XL))/
29467 & XL**(2.538D0-0.763D0*SD)
29468 IF(SD.LE.0.888D0) THEN
29469 XFCHM=0D0
29470 ELSE
29471 XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+
29472 & 0.771D0*SD)*
29473 & EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0*
29474 & XL))
29475 ENDIF
29476 IF(SD.LE.1.351D0) THEN
29477 XFBOT=0D0
29478 ELSE
29479 XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)*
29480 & EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0*
29481 & XL))
29482 ENDIF
29483
29484C...Put into output array.
29485 XPPI(0)=XFGLU
29486 XPPI(1)=XFSEA
29487 XPPI(2)=XFSEA
29488 XPPI(3)=XFSEA
29489 XPPI(4)=XFCHM
29490 XPPI(5)=XFBOT
29491 DO 130 KFL=1,5
29492 XPPI(-KFL)=XPPI(KFL)
29493 130 CONTINUE
29494 XPPI(2)=XPPI(2)+XFVAL
29495 XPPI(-1)=XPPI(-1)+XFVAL
29496 ENDIF
29497
29498 RETURN
29499 END
29500
29501C*********************************************************************
29502
29503C...PYPDPR
29504C...Gives proton parton distributions according to a few different
29505C...parametrizations.
29506
29507 SUBROUTINE PYPDPR(X,Q2,XPPR)
29508
29509C...Double precision and integer declarations.
29510 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29511 IMPLICIT INTEGER(I-N)
29512 INTEGER PYK,PYCHGE,PYCOMP
29513C...Commonblocks.
29514 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29515 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29516 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29517 COMMON/PYINT1/MINT(400),VINT(400)
29518 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
29519C...Arrays and data.
29520 DIMENSION XPPR(-6:6),Q2MIN(16)
29521 DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0,
29522 &1.0D0, 1.0D0, 2*0D0, 0.25D0, 5D0, 5D0, 4D0, 4D0, 0D0/
29523
29524C...Reset output array.
29525 DO 100 KFL=-6,6
29526 XPPR(KFL)=0D0
29527 100 CONTINUE
29528
29529C...Common preliminaries.
29530 NSET=MAX(1,MIN(16,MSTP(51)))
29531 IF(NSET.EQ.9.OR.NSET.EQ.10) NSET=6
29532 VINT(231)=Q2MIN(NSET)
29533 IF(MSTP(57).EQ.0) THEN
29534 Q2L=Q2MIN(NSET)
29535 ELSE
29536 Q2L=MAX(Q2MIN(NSET),Q2)
29537 ENDIF
29538
29539 IF(NSET.GE.1.AND.NSET.LE.3) THEN
29540C...Interface to the CTEQ 3 parton distributions.
29541 QRT=SQRT(MAX(1D0,Q2L))
29542
29543C...Loop over flavours.
29544 DO 110 I=-6,6
29545 IF(I.LE.0) THEN
29546 XPPR(I)=PYCTEQ(NSET,I,X,QRT)
29547 ELSEIF(I.LE.2) THEN
29548 XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I)
29549 ELSE
29550 XPPR(I)=XPPR(-I)
29551 ENDIF
29552 110 CONTINUE
29553
29554 ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN
29555C...Interface to the GRV 94 distributions.
29556 IF(NSET.EQ.4) THEN
29557 CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
29558 ELSEIF(NSET.EQ.5) THEN
29559 CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
29560 ELSE
29561 CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
29562 ENDIF
29563
29564C...Put into output array.
29565 XPPR(0)=GL
29566 XPPR(-1)=0.5D0*(UDB+DEL)
29567 XPPR(-2)=0.5D0*(UDB-DEL)
29568 XPPR(-3)=SB
29569 XPPR(-4)=CHM
29570 XPPR(-5)=BOT
29571 XPPR(1)=DV+XPPR(-1)
29572 XPPR(2)=UV+XPPR(-2)
29573 XPPR(3)=SB
29574 XPPR(4)=CHM
29575 XPPR(5)=BOT
29576
29577 ELSEIF(NSET.EQ.7) THEN
29578C...Interface to the CTEQ 5L parton distributions.
29579C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by
29580C...freezing x*f(x,Q2) at borders.
29581 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
29582 XIN=MAX(1D-6,MIN(1D0,X))
29583
29584C...Loop over flavours (with u <-> d notation mismatch).
29585 SUMUDB=PYCT5L(-1,XIN,QRT)
29586 RATUDB=PYCT5L(-2,XIN,QRT)
29587 DO 120 I=-5,2
29588 IF(I.EQ.1) THEN
29589 XPPR(I)=XIN*PYCT5L(2,XIN,QRT)
29590 ELSEIF(I.EQ.2) THEN
29591 XPPR(I)=XIN*PYCT5L(1,XIN,QRT)
29592 ELSEIF(I.EQ.-1) THEN
29593 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
29594 ELSEIF(I.EQ.-2) THEN
29595 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
29596 ELSE
29597 XPPR(I)=XIN*PYCT5L(I,XIN,QRT)
29598 IF(I.LT.0) XPPR(-I)=XPPR(I)
29599 ENDIF
29600 120 CONTINUE
29601
29602 ELSEIF(NSET.EQ.8) THEN
29603C...Interface to the CTEQ 5M1 parton distributions.
29604 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
29605 XIN=MAX(1D-6,MIN(1D0,X))
29606
29607C...Loop over flavours (with u <-> d notation mismatch).
29608 SUMUDB=PYCT5M(-1,XIN,QRT)
29609 RATUDB=PYCT5M(-2,XIN,QRT)
29610 DO 130 I=-5,2
29611 IF(I.EQ.1) THEN
29612 XPPR(I)=XIN*PYCT5M(2,XIN,QRT)
29613 ELSEIF(I.EQ.2) THEN
29614 XPPR(I)=XIN*PYCT5M(1,XIN,QRT)
29615 ELSEIF(I.EQ.-1) THEN
29616 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
29617 ELSEIF(I.EQ.-2) THEN
29618 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
29619 ELSE
29620 XPPR(I)=XIN*PYCT5M(I,XIN,QRT)
29621 IF(I.LT.0) XPPR(-I)=XPPR(I)
29622 ENDIF
29623 130 CONTINUE
29624
29625 ELSEIF(NSET.GE.11.AND.NSET.LE.15) THEN
29626C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions:
29627C...obsolete but offers backwards compatibility.
29628 CALL PYPDPO(X,Q2L,XPPR)
29629
29630C...Symmetric choice for debugging only
29631 ELSEIF(NSET.EQ.16) THEN
29632 XPPR(0)=.5D0/X
29633 XPPR(1)=.05D0/X
29634 XPPR(2)=.05D0/X
29635 XPPR(3)=.05D0/X
29636 XPPR(4)=.05D0/X
29637 XPPR(5)=.05D0/X
29638 XPPR(-1)=.05D0/X
29639 XPPR(-2)=.05D0/X
29640 XPPR(-3)=.05D0/X
29641 XPPR(-4)=.05D0/X
29642 XPPR(-5)=.05D0/X
29643
29644 ENDIF
29645
29646 RETURN
29647 END
29648
29649C*********************************************************************
29650
29651C...PYCTEQ
29652C...Gives the CTEQ 3 parton distribution function sets in
29653C...parametrized form, of October 24, 1994.
29654C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
29655C...J. Qiu, W.K. Tung and H. Weerts.
29656
29657 FUNCTION PYCTEQ (ISET, IPRT, X, Q)
29658
29659C...Double precision declaration.
29660 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29661 IMPLICIT INTEGER(I-N)
29662
29663C...Data on Lambda values of fits, minimum Q and quark masses.
29664 DIMENSION ALM(3), QMS(4:6)
29665 DATA ALM / 0.177D0, 0.239D0, 0.247D0 /
29666 DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 /
29667
29668C....Check flavour thresholds. Set up QI for SB.
29669 IP = IABS(IPRT)
29670 IF(IP .GE. 4) THEN
29671 IF(Q .LE. QMS(IP)) THEN
29672 PYCTEQ = 0D0
29673 RETURN
29674 ENDIF
29675 QI = QMS(IP)
29676 ELSE
29677 QI = QMN
29678 ENDIF
29679
29680C...Use "standard lambda" of parametrization program for expansion.
29681 ALAM = ALM (ISET)
29682 SBL = LOG(Q/ALAM) / LOG(QI/ALAM)
29683 SB = LOG (SBL)
29684 SB2 = SB*SB
29685 SB3 = SB2*SB
29686
29687C...Expansion for CTEQ3L.
29688 IF(ISET .EQ. 1) THEN
29689 IF(IPRT .EQ. 2) THEN
29690 A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2-
29691 & 0.3171D+00*SB3)
29692 A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3
29693 A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3
29694 A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3
29695 A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3
29696 A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3
29697 ELSEIF(IPRT .EQ. 1) THEN
29698 A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+
29699 & 0.7728D+00*SB3)
29700 A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3
29701 A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3
29702 A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3
29703 A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3
29704 A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3
29705 ELSEIF(IPRT .EQ. 0) THEN
29706 A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+
29707 & 0.5343D+00*SB3)
29708 A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3
29709 A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3
29710 A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3
29711 A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3
29712 A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3
29713 ELSEIF(IPRT .EQ. -1) THEN
29714 A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2-
29715 & 0.2031D+01*SB3)
29716 A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3
29717 A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3
29718 A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3
29719 A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3
29720 A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3
29721 ELSEIF(IPRT .EQ. -2) THEN
29722 A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2-
29723 & 0.9872D-01*SB3)
29724 A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3
29725 A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3
29726 A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3
29727 A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3
29728 A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3
29729 ELSEIF(IPRT .EQ. -3) THEN
29730 A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+
29731 & 0.8390D+00*SB3)
29732 A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3
29733 A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3
29734 A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3
29735 A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3
29736 A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3
29737 ELSEIF(IPRT .EQ. -4) THEN
29738 A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB +
29739 & 0.1651D-01*SB2)
29740 A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3
29741 A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3
29742 A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3
29743 A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3
29744 A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3
29745 ELSEIF(IPRT .EQ. -5) THEN
29746 A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB +
29747 & 0.3702D+01*SB2)
29748 A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3
29749 A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3
29750 A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3
29751 A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3
29752 A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3
29753 ELSEIF(IPRT .EQ. -6) THEN
29754 A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB -
29755 & 0.6943D+00*SB2)
29756 A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3
29757 A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3
29758 A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3
29759 A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3
29760 A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3
29761 ENDIF
29762
29763C...Expansion for CTEQ3M.
29764 ELSEIF(ISET .EQ. 2) THEN
29765 IF(IPRT .EQ. 2) THEN
29766 A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2-
29767 & 0.2935D+00*SB3)
29768 A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3
29769 A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3
29770 A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3
29771 A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3
29772 A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3
29773 ELSEIF(IPRT .EQ. 1) THEN
29774 A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2-
29775 & 0.4305D-01*SB3)
29776 A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3
29777 A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3
29778 A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3
29779 A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3
29780 A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3
29781 ELSEIF(IPRT .EQ. 0) THEN
29782 A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+
29783 & 0.1037D-01*SB3)
29784 A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3
29785 A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3
29786 A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3
29787 A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3
29788 A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3
29789 ELSEIF(IPRT .EQ. -1) THEN
29790 A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2-
29791 & 0.1602D+01*SB3)
29792 A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3
29793 A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3
29794 A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3
29795 A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3
29796 A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3
29797 ELSEIF(IPRT .EQ. -2) THEN
29798 A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+
29799 & 0.2496D+00*SB3)
29800 A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3
29801 A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3
29802 A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3
29803 A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3
29804 A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3
29805 ELSEIF(IPRT .EQ. -3) THEN
29806 A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+
29807 & 0.1936D+01*SB3)
29808 A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3
29809 A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3
29810 A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3
29811 A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3
29812 A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3
29813 ELSEIF(IPRT .EQ. -4) THEN
29814 A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB +
29815 & 0.5348D+00*SB2)
29816 A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3
29817 A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3
29818 A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3
29819 A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3
29820 A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3
29821 ELSEIF(IPRT .EQ. -5) THEN
29822 A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB +
29823 & 0.1569D+01*SB2)
29824 A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3
29825 A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3
29826 A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3
29827 A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3
29828 A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3
29829 ELSEIF(IPRT .EQ. -6) THEN
29830 A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB +
29831 & 0.8838D+01*SB2)
29832 A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3
29833 A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3
29834 A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3
29835 A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3
29836 A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3
29837 ENDIF
29838
29839C...Expansion for CTEQ3D.
29840 ELSEIF(ISET .EQ. 3) THEN
29841 IF(IPRT .EQ. 2) THEN
29842 A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2-
29843 & 0.2902D+00*SB3)
29844 A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3
29845 A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3
29846 A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3
29847 A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3
29848 A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3
29849 ELSEIF(IPRT .EQ. 1) THEN
29850 A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+
29851 & 0.7257D+00*SB3)
29852 A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3
29853 A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3
29854 A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3
29855 A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3
29856 A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3
29857 ELSEIF(IPRT .EQ. 0) THEN
29858 A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2-
29859 & 0.2734D-04*SB3)
29860 A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3
29861 A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3
29862 A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3
29863 A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3
29864 A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3
29865 ELSEIF(IPRT .EQ. -1) THEN
29866 A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2-
29867 & 0.1671D+01*SB3)
29868 A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3
29869 A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3
29870 A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3
29871 A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3
29872 A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3
29873 ELSEIF(IPRT .EQ. -2) THEN
29874 A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+
29875 & 0.2223D+00*SB3)
29876 A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3
29877 A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3
29878 A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3
29879 A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3
29880 A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3
29881 ELSEIF(IPRT .EQ. -3) THEN
29882 A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+
29883 & 0.1937D+01*SB3)
29884 A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3
29885 A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3
29886 A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3
29887 A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3
29888 A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3
29889 ELSEIF(IPRT .EQ. -4) THEN
29890 A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB +
29891 & 0.5137D+00*SB2)
29892 A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3
29893 A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3
29894 A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3
29895 A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3
29896 A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3
29897 ELSEIF(IPRT .EQ. -5) THEN
29898 A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB +
29899 & 0.2143D+01*SB2)
29900 A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3
29901 A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3
29902 A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3
29903 A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3
29904 A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3
29905 ELSEIF(IPRT .EQ. -6) THEN
29906 A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB +
29907 & 0.9998D+01*SB2)
29908 A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3
29909 A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3
29910 A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3
29911 A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3
29912 A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3
29913 ENDIF
29914 ENDIF
29915
29916C...Calculation of x * f(x, Q).
29917 PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4))
29918 & *(LOG(1D0+1D0/X))**A5 )
29919
29920 RETURN
29921 END
29922
29923C*********************************************************************
29924
29925C...PYGRVL
29926C...Gives the GRV 94 L (leading order) parton distribution function set
29927C...in parametrized form.
29928C...Authors: M. Glueck, E. Reya and A. Vogt.
29929
29930 SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
29931
29932C...Double precision declaration.
29933 IMPLICIT DOUBLE PRECISION (A - Z)
29934
29935C...Common expressions.
29936 MU2 = 0.23D0
29937 LAM2 = 0.2322D0 * 0.2322D0
29938 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
29939 DS = SQRT (S)
29940 S2 = S * S
29941 S3 = S2 * S
29942
29943C...uv :
29944 NU = 2.284D0 + 0.802D0 * S + 0.055D0 * S2
29945 AKU = 0.590D0 - 0.024D0 * S
29946 BKU = 0.131D0 + 0.063D0 * S
29947 AU = -0.449D0 - 0.138D0 * S - 0.076D0 * S2
29948 BU = 0.213D0 + 2.669D0 * S - 0.728D0 * S2
29949 CU = 8.854D0 - 9.135D0 * S + 1.979D0 * S2
29950 DU = 2.997D0 + 0.753D0 * S - 0.076D0 * S2
29951 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
29952
29953C...dv :
29954 ND = 0.371D0 + 0.083D0 * S + 0.039D0 * S2
29955 AKD = 0.376D0
29956 BKD = 0.486D0 + 0.062D0 * S
29957 AD = -0.509D0 + 3.310D0 * S - 1.248D0 * S2
29958 BD = 12.41D0 - 10.52D0 * S + 2.267D0 * S2
29959 CD = 6.373D0 - 6.208D0 * S + 1.418D0 * S2
29960 DD = 3.691D0 + 0.799D0 * S - 0.071D0 * S2
29961 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
29962
29963C...del :
29964 NE = 0.082D0 + 0.014D0 * S + 0.008D0 * S2
29965 AKE = 0.409D0 - 0.005D0 * S
29966 BKE = 0.799D0 + 0.071D0 * S
29967 AE = -38.07D0 + 36.13D0 * S - 0.656D0 * S2
29968 BE = 90.31D0 - 74.15D0 * S + 7.645D0 * S2
29969 CE = 0.0D0
29970 DE = 7.486D0 + 1.217D0 * S - 0.159D0 * S2
29971 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
29972
29973C...udb :
29974 ALX = 1.451D0
29975 BEX = 0.271D0
29976 AKX = 0.410D0 - 0.232D0 * S
29977 BKX = 0.534D0 - 0.457D0 * S
29978 AGX = 0.890D0 - 0.140D0 * S
29979 BGX = -0.981D0
29980 CX = 0.320D0 + 0.683D0 * S
29981 DX = 4.752D0 + 1.164D0 * S + 0.286D0 * S2
29982 EX = 4.119D0 + 1.713D0 * S
29983 ESX = 0.682D0 + 2.978D0 * S
29984 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
29985 & DX, EX, ESX)
29986
29987C...sb :
29988 STS = 0D0
29989 ALS = 0.914D0
29990 BES = 0.577D0
29991 AKS = 1.798D0 - 0.596D0 * S
29992 AS = -5.548D0 + 3.669D0 * DS - 0.616D0 * S
29993 BS = 18.92D0 - 16.73D0 * DS + 5.168D0 * S
29994 DST = 6.379D0 - 0.350D0 * S + 0.142D0 * S2
29995 EST = 3.981D0 + 1.638D0 * S
29996 ESS = 6.402D0
29997 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
29998
29999C...cb :
30000 STC = 0.888D0
30001 ALC = 1.01D0
30002 BEC = 0.37D0
30003 AKC = 0D0
30004 AC = 0D0
30005 BC = 4.24D0 - 0.804D0 * S
30006 DCT = 3.46D0 - 1.076D0 * S
30007 ECT = 4.61D0 + 1.49D0 * S
30008 ESC = 2.555D0 + 1.961D0 * S
30009 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
30010
30011C...bb :
30012 STB = 1.351D0
30013 ALB = 1.00D0
30014 BEB = 0.51D0
30015 AKB = 0D0
30016 AB = 0D0
30017 BB = 1.848D0
30018 DBT = 2.929D0 + 1.396D0 * S
30019 EBT = 4.71D0 + 1.514D0 * S
30020 ESB = 4.02D0 + 1.239D0 * S
30021 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
30022
30023C...gl :
30024 ALG = 0.524D0
30025 BEG = 1.088D0
30026 AKG = 1.742D0 - 0.930D0 * S
30027 BKG = - 0.399D0 * S2
30028 AG = 7.486D0 - 2.185D0 * S
30029 BG = 16.69D0 - 22.74D0 * S + 5.779D0 * S2
30030 CG = -25.59D0 + 29.71D0 * S - 7.296D0 * S2
30031 DG = 2.792D0 + 2.215D0 * S + 0.422D0 * S2 - 0.104D0 * S3
30032 EG = 0.807D0 + 2.005D0 * S
30033 ESG = 3.841D0 + 0.316D0 * S
30034 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG,
30035 & DG, EG, ESG)
30036
30037 RETURN
30038 END
30039
30040C*********************************************************************
30041
30042C...PYGRVM
30043C...Gives the GRV 94 M (MSbar) parton distribution function set
30044C...in parametrized form.
30045C...Authors: M. Glueck, E. Reya and A. Vogt.
30046
30047 SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
30048
30049C...Double precision declaration.
30050 IMPLICIT DOUBLE PRECISION (A - Z)
30051
30052C...Common expressions.
30053 MU2 = 0.34D0
30054 LAM2 = 0.248D0 * 0.248D0
30055 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
30056 DS = SQRT (S)
30057 S2 = S * S
30058 S3 = S2 * S
30059
30060C...uv :
30061 NU = 1.304D0 + 0.863D0 * S
30062 AKU = 0.558D0 - 0.020D0 * S
30063 BKU = 0.183D0 * S
30064 AU = -0.113D0 + 0.283D0 * S - 0.321D0 * S2
30065 BU = 6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3
30066 CU = 7.771D0 - 10.09D0 * S + 2.630D0 * S2
30067 DU = 3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3
30068 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
30069
30070C...dv :
30071 ND = 0.102D0 - 0.017D0 * S + 0.005D0 * S2
30072 AKD = 0.270D0 - 0.019D0 * S
30073 BKD = 0.260D0
30074 AD = 2.393D0 + 6.228D0 * S - 0.881D0 * S2
30075 BD = 46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3
30076 CD = 17.83D0 - 53.47D0 * S + 21.24D0 * S2
30077 DD = 4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3
30078 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
30079
30080C...del :
30081 NE = 0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3
30082 AKE = 0.409D0 - 0.007D0 * S
30083 BKE = 0.782D0 + 0.082D0 * S
30084 AE = -29.65D0 + 26.49D0 * S + 5.429D0 * S2
30085 BE = 90.20D0 - 74.97D0 * S + 4.526D0 * S2
30086 CE = 0.0D0
30087 DE = 8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3
30088 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
30089
30090C...udb :
30091 ALX = 0.877D0
30092 BEX = 0.561D0
30093 AKX = 0.275D0
30094 BKX = 0.0D0
30095 AGX = 0.997D0
30096 BGX = 3.210D0 - 1.866D0 * S
30097 CX = 7.300D0
30098 DX = 9.010D0 + 0.896D0 * DS + 0.222D0 * S2
30099 EX = 3.077D0 + 1.446D0 * S
30100 ESX = 3.173D0 - 2.445D0 * DS + 2.207D0 * S
30101 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
30102 & DX, EX, ESX)
30103
30104C...sb :
30105 STS = 0D0
30106 ALS = 0.756D0
30107 BES = 0.216D0
30108 AKS = 1.690D0 + 0.650D0 * DS - 0.922D0 * S
30109 AS = -4.329D0 + 1.131D0 * S
30110 BS = 9.568D0 - 1.744D0 * S
30111 DST = 9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2
30112 EST = 3.031D0 + 1.639D0 * S
30113 ESS = 5.837D0 + 0.815D0 * S
30114 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
30115
30116C...cb :
30117 STC = 0.820D0
30118 ALC = 0.98D0
30119 BEC = 0D0
30120 AKC = -0.625D0 - 0.523D0 * S
30121 AC = 0D0
30122 BC = 1.896D0 + 1.616D0 * S
30123 DCT = 4.12D0 + 0.683D0 * S
30124 ECT = 4.36D0 + 1.328D0 * S
30125 ESC = 0.677D0 + 0.679D0 * S
30126 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
30127
30128C...bb :
30129 STB = 1.297D0
30130 ALB = 0.99D0
30131 BEB = 0D0
30132 AKB = - 0.193D0 * S
30133 AB = 0D0
30134 BB = 0D0
30135 DBT = 3.447D0 + 0.927D0 * S
30136 EBT = 4.68D0 + 1.259D0 * S
30137 ESB = 1.892D0 + 2.199D0 * S
30138 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
30139
30140C...gl :
30141 ALG = 1.014D0
30142 BEG = 1.738D0
30143 AKG = 1.724D0 + 0.157D0 * S
30144 BKG = 0.800D0 + 1.016D0 * S
30145 AG = 7.517D0 - 2.547D0 * S
30146 BG = 34.09D0 - 52.21D0 * DS + 17.47D0 * S
30147 CG = 4.039D0 + 1.491D0 * S
30148 DG = 3.404D0 + 0.830D0 * S
30149 EG = -1.112D0 + 3.438D0 * S - 0.302D0 * S2
30150 ESG = 3.256D0 - 0.436D0 * S
30151 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
30152
30153 RETURN
30154 END
30155
30156C*********************************************************************
30157
30158C...PYGRVD
30159C...Gives the GRV 94 D (DIS) parton distribution function set
30160C...in parametrized form.
30161C...Authors: M. Glueck, E. Reya and A. Vogt.
30162
30163 SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
30164
30165C...Double precision declaration.
30166 IMPLICIT DOUBLE PRECISION (A - Z)
30167
30168C...Common expressions.
30169 MU2 = 0.34D0
30170 LAM2 = 0.248D0 * 0.248D0
30171 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
30172 DS = SQRT (S)
30173 S2 = S * S
30174 S3 = S2 * S
30175
30176C...uv :
30177 NU = 2.484D0 + 0.116D0 * S + 0.093D0 * S2
30178 AKU = 0.563D0 - 0.025D0 * S
30179 BKU = 0.054D0 + 0.154D0 * S
30180 AU = -0.326D0 - 0.058D0 * S - 0.135D0 * S2
30181 BU = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3
30182 CU = 11.52D0 - 12.99D0 * S + 3.161D0 * S2
30183 DU = 2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3
30184 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
30185
30186C...dv :
30187 ND = 0.156D0 - 0.017D0 * S
30188 AKD = 0.299D0 - 0.022D0 * S
30189 BKD = 0.259D0 - 0.015D0 * S
30190 AD = 3.445D0 + 1.278D0 * S + 0.326D0 * S2
30191 BD = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3
30192 CD = 55.45D0 - 69.92D0 * S + 20.78D0 * S2
30193 DD = 3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3
30194 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
30195
30196C...del :
30197 NE = 0.099D0 + 0.019D0 * S + 0.002D0 * S2
30198 AKE = 0.419D0 - 0.013D0 * S
30199 BKE = 1.064D0 - 0.038D0 * S
30200 AE = -44.00D0 + 98.70D0 * S - 14.79D0 * S2
30201 BE = 28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3
30202 CE = 84.57D0 - 108.8D0 * S + 31.52D0 * S2
30203 DE = 7.469D0 + 2.480D0 * S - 0.866D0 * S2
30204 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
30205
30206C...udb :
30207 ALX = 1.215D0
30208 BEX = 0.466D0
30209 AKX = 0.326D0 + 0.150D0 * S
30210 BKX = 0.956D0 + 0.405D0 * S
30211 AGX = 0.272D0
30212 BGX = 3.794D0 - 2.359D0 * DS
30213 CX = 2.014D0
30214 DX = 7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2
30215 EX = 3.049D0 + 1.597D0 * S
30216 ESX = 4.396D0 - 4.594D0 * DS + 3.268D0 * S
30217 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
30218 & DX, EX, ESX)
30219
30220C...sb :
30221 STS = 0D0
30222 ALS = 0.175D0
30223 BES = 0.344D0
30224 AKS = 1.415D0 - 0.641D0 * DS
30225 AS = 0.580D0 - 9.763D0 * DS + 6.795D0 * S - 0.558D0 * S2
30226 BS = 5.617D0 + 5.709D0 * DS - 3.972D0 * S
30227 DST = 13.78D0 - 9.581D0 * S + 5.370D0 * S2 - 0.996D0 * S3
30228 EST = 4.546D0 + 0.372D0 * S2
30229 ESS = 5.053D0 - 1.070D0 * S + 0.805D0 * S2
30230 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
30231
30232C...cb :
30233 STC = 0.820D0
30234 ALC = 0.98D0
30235 BEC = 0D0
30236 AKC = -0.625D0 - 0.523D0 * S
30237 AC = 0D0
30238 BC = 1.896D0 + 1.616D0 * S
30239 DCT = 4.12D0 + 0.683D0 * S
30240 ECT = 4.36D0 + 1.328D0 * S
30241 ESC = 0.677D0 + 0.679D0 * S
30242 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
30243
30244C...bb :
30245 STB = 1.297D0
30246 ALB = 0.99D0
30247 BEB = 0D0
30248 AKB = - 0.193D0 * S
30249 AB = 0D0
30250 BB = 0D0
30251 DBT = 3.447D0 + 0.927D0 * S
30252 EBT = 4.68D0 + 1.259D0 * S
30253 ESB = 1.892D0 + 2.199D0 * S
30254 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
30255
30256C...gl :
30257 ALG = 1.258D0
30258 BEG = 1.846D0
30259 AKG = 2.423D0
30260 BKG = 2.427D0 + 1.311D0 * S - 0.153D0 * S2
30261 AG = 25.09D0 - 7.935D0 * S
30262 BG = -14.84D0 - 124.3D0 * DS + 72.18D0 * S
30263 CG = 590.3D0 - 173.8D0 * S
30264 DG = 5.196D0 + 1.857D0 * S
30265 EG = -1.648D0 + 3.988D0 * S - 0.432D0 * S2
30266 ESG = 3.232D0 - 0.542D0 * S
30267 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
30268
30269 RETURN
30270 END
30271
30272C*********************************************************************
30273
30274C...PYGRVV
30275C...Auxiliary for the GRV 94 parton distribution functions
30276C...for u and d valence and d-u sea.
30277C...Authors: M. Glueck, E. Reya and A. Vogt.
30278
30279 FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D)
30280
30281C...Double precision declaration.
30282 IMPLICIT DOUBLE PRECISION (A - Z)
30283
30284C...Evaluation.
30285 DX = SQRT (X)
30286 PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) *
30287 & (1D0- X)**D
30288
30289 RETURN
30290 END
30291
30292C*********************************************************************
30293
30294C...PYGRVW
30295C...Auxiliary for the GRV 94 parton distribution functions
30296C...for d+u sea and gluon.
30297C...Authors: M. Glueck, E. Reya and A. Vogt.
30298
30299 FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
30300
30301C...Double precision declaration.
30302 IMPLICIT DOUBLE PRECISION (A - Z)
30303
30304C...Evaluation.
30305 LX = LOG (1D0/X)
30306 PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
30307 & * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D
30308
30309 RETURN
30310 END
30311
30312C*********************************************************************
30313
30314C...PYGRVS
30315C...Auxiliary for the GRV 94 parton distribution functions
30316C...for s, c and b sea.
30317C...Authors: M. Glueck, E. Reya and A. Vogt.
30318
30319 FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
30320
30321C...Double precision declaration.
30322 IMPLICIT DOUBLE PRECISION (A - Z)
30323
30324C...Evaluation.
30325 IF(S.LE.STH) THEN
30326 PYGRVS = 0D0
30327 ELSE
30328 DX = SQRT (X)
30329 LX = LOG (1D0/X)
30330 PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) *
30331 & (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX))
30332 ENDIF
30333
30334 RETURN
30335 END
30336
30337C*********************************************************************
30338
30339C...PYCT5L
30340C...Auxiliary function for parametrization of CTEQ5L.
30341C...Author: J. Pumplin 9/99.
30342
30343C...CTEQ5M1 and CTEQ5L Parton Distribution Functions
30344C...in Parametrized Form
30345C... September 15, 1999
30346C
30347C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON:
30348C... CTEQ5 PPARTON DISTRIBUTIONS"
30349C...hep-ph/9903282
30350
30351C...The CTEQ5M1 set given here is an updated version of the original
30352C...CTEQ5M set posted, in the table version, on the Web page of CTEQ.
30353C...The differences between CTEQ5M and CTEQ5M1 are insignificant for
30354C...almost all applications.
30355C...The improvement is in the QCD evolution which is now more
30356C...accurate, and which agrees completely with the benchmark work
30357C...of the HERA 96/97 Workshop.
30358C...The differences between the parametrized and the corresponding
30359C...table versions (on which it is based) are of similar order as
30360C...between the two version.
30361
30362C...!! Because accurate parametrizations over a wide range of (x,Q)
30363C...is hard to obtain, only the most widely used sets CTEQ5M and
30364C...CTEQ5L are available in parametrized form for now.
30365
30366C...These parametrizations were obtained by Jon Pumplin.
30367
30368C Iset PDF Description Alpha_s(Mz) Lam4 Lam5
30369C -------------------------------------------------------------------
30370C 1 CTEQ5M1 Standard NLO MSbar scheme 0.118 326 226
30371C 3 CTEQ5L Leading Order 0.127 192 146
30372C -------------------------------------------------------------------
30373C...Note the Qcd-lambda values given for CTEQ5L is for the leading
30374C...order form of Alpha_s!! Alpha_s(Mz) gives the absolute
30375C...calibration.
30376
30377C...The two Iset value are adopted to agree with the standard table
30378C...versions.
30379
30380C...Range of validity:
30381C...The range of (x, Q) covered by this parametrization of the QCD
30382C...evolved parton distributions is 1E-6 < x < 1 ;
30383C...1.1 GeV < Q < 10 TeV. Of course, the PDF's are constrained by
30384C...data only in a subset of that region; and the assumed DGLAP
30385C...evolution is unlikely to be valid for all of it either.
30386
30387C...The range of (x, Q) used in the CTEQ5 round of global analysis is
30388C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for
30389C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and
30390C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data.
30391
30392 FUNCTION PYCT5L(IFL,X,Q)
30393
30394C...Double precision declaration.
30395 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30396 IMPLICIT INTEGER(I-N)
30397
30398 PARAMETER (NEX=8, NLF=2)
30399 DIMENSION AM(0:NEX,0:NLF,-5:2)
30400 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
30401 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
30402 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
30403 DIMENSION AF(0:NEX)
30404
30405 DATA MEXVEC( 2) / 8 /
30406 DATA MLFVEC( 2) / 2 /
30407 DATA UT1VEC( 2) / 0.4971265E+01 /
30408 DATA UT2VEC( 2) / -0.1105128E+01 /
30409 DATA ALFVEC( 2) / 0.2987216E+00 /
30410 DATA QMAVEC( 2) / 0.0000000E+00 /
30411 DATA (AM( 0,K, 2),K=0, 2)
30412 & / 0.5292616E+01, -0.2751910E+01, -0.2488990E+01 /
30413 DATA (AM( 1,K, 2),K=0, 2)
30414 & / 0.9714424E+00, 0.1011827E-01, -0.1023660E-01 /
30415 DATA (AM( 2,K, 2),K=0, 2)
30416 & / -0.1651006E+02, 0.7959721E+01, 0.8810563E+01 /
30417 DATA (AM( 3,K, 2),K=0, 2)
30418 & / -0.1643394E+02, 0.5892854E+01, 0.9348874E+01 /
30419 DATA (AM( 4,K, 2),K=0, 2)
30420 & / 0.3067422E+02, 0.4235796E+01, -0.5112136E+00 /
30421 DATA (AM( 5,K, 2),K=0, 2)
30422 & / 0.2352526E+02, -0.5305168E+01, -0.1169174E+02 /
30423 DATA (AM( 6,K, 2),K=0, 2)
30424 & / -0.1095451E+02, 0.3006577E+01, 0.5638136E+01 /
30425 DATA (AM( 7,K, 2),K=0, 2)
30426 & / -0.1172251E+02, -0.2183624E+01, 0.4955794E+01 /
30427 DATA (AM( 8,K, 2),K=0, 2)
30428 & / 0.1662533E-01, 0.7622870E-02, -0.4895887E-03 /
30429
30430 DATA MEXVEC( 1) / 8 /
30431 DATA MLFVEC( 1) / 2 /
30432 DATA UT1VEC( 1) / 0.2612618E+01 /
30433 DATA UT2VEC( 1) / -0.1258304E+06 /
30434 DATA ALFVEC( 1) / 0.3407552E+00 /
30435 DATA QMAVEC( 1) / 0.0000000E+00 /
30436 DATA (AM( 0,K, 1),K=0, 2)
30437 & / 0.9905300E+00, -0.4502235E+00, 0.1624441E+00 /
30438 DATA (AM( 1,K, 1),K=0, 2)
30439 & / 0.8867534E+00, 0.1630829E-01, -0.4049085E-01 /
30440 DATA (AM( 2,K, 1),K=0, 2)
30441 & / 0.8547974E+00, 0.3336301E+00, 0.1371388E+00 /
30442 DATA (AM( 3,K, 1),K=0, 2)
30443 & / 0.2941113E+00, -0.1527905E+01, 0.2331879E+00 /
30444 DATA (AM( 4,K, 1),K=0, 2)
30445 & / 0.3384235E+02, 0.3715315E+01, 0.8276930E+00 /
30446 DATA (AM( 5,K, 1),K=0, 2)
30447 & / 0.6230115E+01, 0.3134639E+01, -0.1729099E+01 /
30448 DATA (AM( 6,K, 1),K=0, 2)
30449 & / -0.1186928E+01, -0.3282460E+00, 0.1052020E+00 /
30450 DATA (AM( 7,K, 1),K=0, 2)
30451 & / -0.8545702E+01, -0.6247947E+01, 0.3692561E+01 /
30452 DATA (AM( 8,K, 1),K=0, 2)
30453 & / 0.1724598E-01, 0.7120465E-02, 0.4003646E-04 /
30454
30455 DATA MEXVEC( 0) / 8 /
30456 DATA MLFVEC( 0) / 2 /
30457 DATA UT1VEC( 0) / -0.4656819E+00 /
30458 DATA UT2VEC( 0) / -0.2742390E+03 /
30459 DATA ALFVEC( 0) / 0.4491863E+00 /
30460 DATA QMAVEC( 0) / 0.0000000E+00 /
30461 DATA (AM( 0,K, 0),K=0, 2)
30462 & / 0.1193572E+03, -0.3886845E+01, -0.1133965E+01 /
30463 DATA (AM( 1,K, 0),K=0, 2)
30464 & / -0.9421449E+02, 0.3995885E+01, 0.1607363E+01 /
30465 DATA (AM( 2,K, 0),K=0, 2)
30466 & / 0.4206383E+01, 0.2485954E+00, 0.2497468E+00 /
30467 DATA (AM( 3,K, 0),K=0, 2)
30468 & / 0.1210557E+03, -0.3015765E+01, -0.1423651E+01 /
30469 DATA (AM( 4,K, 0),K=0, 2)
30470 & / -0.1013897E+03, -0.7113478E+00, 0.2621865E+00 /
30471 DATA (AM( 5,K, 0),K=0, 2)
30472 & / -0.1312404E+01, -0.9297691E+00, -0.1562531E+00 /
30473 DATA (AM( 6,K, 0),K=0, 2)
30474 & / 0.1627137E+01, 0.4954111E+00, -0.6387009E+00 /
30475 DATA (AM( 7,K, 0),K=0, 2)
30476 & / 0.1537698E+00, -0.2487878E+00, 0.8305947E+00 /
30477 DATA (AM( 8,K, 0),K=0, 2)
30478 & / 0.2496448E-01, 0.2457823E-02, 0.8234276E-03 /
30479
30480 DATA MEXVEC(-1) / 8 /
30481 DATA MLFVEC(-1) / 2 /
30482 DATA UT1VEC(-1) / 0.3862583E+01 /
30483 DATA UT2VEC(-1) / -0.1265969E+01 /
30484 DATA ALFVEC(-1) / 0.2457668E+00 /
30485 DATA QMAVEC(-1) / 0.0000000E+00 /
30486 DATA (AM( 0,K,-1),K=0, 2)
30487 & / 0.2647441E+02, 0.1059277E+02, -0.9176654E+00 /
30488 DATA (AM( 1,K,-1),K=0, 2)
30489 & / 0.1990636E+01, 0.8558918E-01, 0.4248667E-01 /
30490 DATA (AM( 2,K,-1),K=0, 2)
30491 & / -0.1476095E+02, -0.3276255E+02, 0.1558110E+01 /
30492 DATA (AM( 3,K,-1),K=0, 2)
30493 & / -0.2966889E+01, -0.3649037E+02, 0.1195914E+01 /
30494 DATA (AM( 4,K,-1),K=0, 2)
30495 & / -0.1000519E+03, -0.2464635E+01, 0.1964849E+00 /
30496 DATA (AM( 5,K,-1),K=0, 2)
30497 & / 0.3718331E+02, 0.4700389E+02, -0.2772142E+01 /
30498 DATA (AM( 6,K,-1),K=0, 2)
30499 & / -0.1872722E+02, -0.2291189E+02, 0.1089052E+01 /
30500 DATA (AM( 7,K,-1),K=0, 2)
30501 & / -0.1628146E+02, -0.1823993E+02, 0.2537369E+01 /
30502 DATA (AM( 8,K,-1),K=0, 2)
30503 & / -0.1156300E+01, -0.1280495E+00, 0.5153245E-01 /
30504
30505 DATA MEXVEC(-2) / 7 /
30506 DATA MLFVEC(-2) / 2 /
30507 DATA UT1VEC(-2) / 0.1895615E+00 /
30508 DATA UT2VEC(-2) / -0.3069097E+01 /
30509 DATA ALFVEC(-2) / 0.5293999E+00 /
30510 DATA QMAVEC(-2) / 0.0000000E+00 /
30511 DATA (AM( 0,K,-2),K=0, 2)
30512 & / -0.6556775E+00, 0.2490190E+00, 0.3966485E-01 /
30513 DATA (AM( 1,K,-2),K=0, 2)
30514 & / 0.1305102E+01, -0.1188925E+00, -0.4600870E-02 /
30515 DATA (AM( 2,K,-2),K=0, 2)
30516 & / -0.2371436E+01, 0.3566814E+00, -0.2834683E+00 /
30517 DATA (AM( 3,K,-2),K=0, 2)
30518 & / -0.6152826E+01, 0.8339877E+00, -0.7233230E+00 /
30519 DATA (AM( 4,K,-2),K=0, 2)
30520 & / -0.8346558E+01, 0.2892168E+01, 0.2137099E+00 /
30521 DATA (AM( 5,K,-2),K=0, 2)
30522 & / 0.1279530E+02, 0.1021114E+00, 0.5787439E+00 /
30523 DATA (AM( 6,K,-2),K=0, 2)
30524 & / 0.5858816E+00, -0.1940375E+01, -0.4029269E+00 /
30525 DATA (AM( 7,K,-2),K=0, 2)
30526 & / -0.2795725E+02, -0.5263392E+00, 0.1290229E+01 /
30527
30528 DATA MEXVEC(-3) / 7 /
30529 DATA MLFVEC(-3) / 2 /
30530 DATA UT1VEC(-3) / 0.3753257E+01 /
30531 DATA UT2VEC(-3) / -0.1113085E+01 /
30532 DATA ALFVEC(-3) / 0.3713141E+00 /
30533 DATA QMAVEC(-3) / 0.0000000E+00 /
30534 DATA (AM( 0,K,-3),K=0, 2)
30535 & / 0.1580931E+01, -0.2273826E+01, -0.1822245E+01 /
30536 DATA (AM( 1,K,-3),K=0, 2)
30537 & / 0.2702644E+01, 0.6763243E+00, 0.7231586E-02 /
30538 DATA (AM( 2,K,-3),K=0, 2)
30539 & / -0.1857924E+02, 0.3907500E+01, 0.5850109E+01 /
30540 DATA (AM( 3,K,-3),K=0, 2)
30541 & / -0.3044793E+02, 0.2639332E+01, 0.5566644E+01 /
30542 DATA (AM( 4,K,-3),K=0, 2)
30543 & / -0.4258011E+01, -0.5429244E+01, 0.4418946E+00 /
30544 DATA (AM( 5,K,-3),K=0, 2)
30545 & / 0.3465259E+02, -0.5532604E+01, -0.4904153E+01 /
30546 DATA (AM( 6,K,-3),K=0, 2)
30547 & / -0.1658858E+02, 0.2923275E+01, 0.2266286E+01 /
30548 DATA (AM( 7,K,-3),K=0, 2)
30549 & / -0.1149263E+02, 0.2877475E+01, -0.7999105E+00 /
30550
30551 DATA MEXVEC(-4) / 7 /
30552 DATA MLFVEC(-4) / 2 /
30553 DATA UT1VEC(-4) / 0.4400772E+01 /
30554 DATA UT2VEC(-4) / -0.1356116E+01 /
30555 DATA ALFVEC(-4) / 0.3712017E-01 /
30556 DATA QMAVEC(-4) / 0.1300000E+01 /
30557 DATA (AM( 0,K,-4),K=0, 2)
30558 & / -0.8293661E+00, -0.3982375E+01, -0.6494283E-01 /
30559 DATA (AM( 1,K,-4),K=0, 2)
30560 & / 0.2754618E+01, 0.8338636E+00, -0.6885160E-01 /
30561 DATA (AM( 2,K,-4),K=0, 2)
30562 & / -0.1657987E+02, 0.1439143E+02, -0.6887240E+00 /
30563 DATA (AM( 3,K,-4),K=0, 2)
30564 & / -0.2800703E+02, 0.1535966E+02, -0.7377693E+00 /
30565 DATA (AM( 4,K,-4),K=0, 2)
30566 & / -0.6460216E+01, -0.4783019E+01, 0.4913297E+00 /
30567 DATA (AM( 5,K,-4),K=0, 2)
30568 & / 0.3141830E+02, -0.3178031E+02, 0.7136013E+01 /
30569 DATA (AM( 6,K,-4),K=0, 2)
30570 & / -0.1802509E+02, 0.1862163E+02, -0.4632843E+01 /
30571 DATA (AM( 7,K,-4),K=0, 2)
30572 & / -0.1240412E+02, 0.2565386E+02, -0.1066570E+02 /
30573
30574 DATA MEXVEC(-5) / 6 /
30575 DATA MLFVEC(-5) / 2 /
30576 DATA UT1VEC(-5) / 0.5562568E+01 /
30577 DATA UT2VEC(-5) / -0.1801317E+01 /
30578 DATA ALFVEC(-5) / 0.4952010E-02 /
30579 DATA QMAVEC(-5) / 0.4500000E+01 /
30580 DATA (AM( 0,K,-5),K=0, 2)
30581 & / -0.6031237E+01, 0.1992727E+01, -0.1076331E+01 /
30582 DATA (AM( 1,K,-5),K=0, 2)
30583 & / 0.2933912E+01, 0.5839674E+00, 0.7509435E-01 /
30584 DATA (AM( 2,K,-5),K=0, 2)
30585 & / -0.8284919E+01, 0.1488593E+01, -0.8251678E+00 /
30586 DATA (AM( 3,K,-5),K=0, 2)
30587 & / -0.1925986E+02, 0.2805753E+01, -0.3015446E+01 /
30588 DATA (AM( 4,K,-5),K=0, 2)
30589 & / -0.9480483E+01, -0.9767837E+00, -0.1165544E+01 /
30590 DATA (AM( 5,K,-5),K=0, 2)
30591 & / 0.2193195E+02, -0.1788518E+02, 0.9460908E+01 /
30592 DATA (AM( 6,K,-5),K=0, 2)
30593 & / -0.1327377E+02, 0.1201754E+02, -0.6277844E+01 /
30594
30595 IF(Q .LE. QMAVEC(IFL)) THEN
30596 PYCT5L = 0.D0
30597 RETURN
30598 ENDIF
30599
30600 IF(X .GE. 1.D0) THEN
30601 PYCT5L = 0.D0
30602 RETURN
30603 ENDIF
30604
30605 TMP = LOG(Q/ALFVEC(IFL))
30606 IF(TMP .LE. 0.D0) THEN
30607 PYCT5L = 0.D0
30608 RETURN
30609 ENDIF
30610
30611 SB = LOG(TMP)
30612 SB1 = SB - 1.2D0
30613 SB2 = SB1*SB1
30614
30615 DO 110 I = 0, NEX
30616 AF(I) = 0.D0
30617 SBX = 1.D0
30618 DO 100 K = 0, MLFVEC(IFL)
30619 AF(I) = AF(I) + SBX*AM(I,K,IFL)
30620 SBX = SB1*SBX
30621 100 CONTINUE
30622 110 CONTINUE
30623
30624 Y = -LOG(X)
30625 U = LOG(X/0.00001D0)
30626
30627 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
30628 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
30629 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
30630 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
30631 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
30632
30633 PYCT5L = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
30634
30635C...Include threshold factor.
30636 PYCT5L = PYCT5L * (1.D0 - QMAVEC(IFL)/Q)
30637
30638 RETURN
30639 END
30640
30641C*********************************************************************
30642
30643C...PYCT5M
30644C...Auxiliary function for parametrization of CTEQ5M1.
30645C...Author: J. Pumplin 9/99.
30646
30647 FUNCTION PYCT5M(IFL,X,Q)
30648
30649C...Double precision declaration.
30650 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30651 IMPLICIT INTEGER(I-N)
30652
30653 PARAMETER (NEX=8, NLF=2)
30654 DIMENSION AM(0:NEX,0:NLF,-5:2)
30655 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
30656 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
30657 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
30658 DIMENSION AF(0:NEX)
30659
30660 DATA MEXVEC( 2) / 8 /
30661 DATA MLFVEC( 2) / 2 /
30662 DATA UT1VEC( 2) / 0.5141718E+01 /
30663 DATA UT2VEC( 2) / -0.1346944E+01 /
30664 DATA ALFVEC( 2) / 0.5260555E+00 /
30665 DATA QMAVEC( 2) / 0.0000000E+00 /
30666 DATA (AM( 0,K, 2),K=0, 2)
30667 & / 0.4289071E+01, -0.2536870E+01, -0.1259948E+01 /
30668 DATA (AM( 1,K, 2),K=0, 2)
30669 & / 0.9839410E+00, 0.4168426E-01, -0.5018952E-01 /
30670 DATA (AM( 2,K, 2),K=0, 2)
30671 & / -0.1651961E+02, 0.9246261E+01, 0.5996400E+01 /
30672 DATA (AM( 3,K, 2),K=0, 2)
30673 & / -0.2077936E+02, 0.9786469E+01, 0.7656465E+01 /
30674 DATA (AM( 4,K, 2),K=0, 2)
30675 & / 0.3054926E+02, 0.1889536E+01, 0.1380541E+01 /
30676 DATA (AM( 5,K, 2),K=0, 2)
30677 & / 0.3084695E+02, -0.1212303E+02, -0.1053551E+02 /
30678 DATA (AM( 6,K, 2),K=0, 2)
30679 & / -0.1426778E+02, 0.6239537E+01, 0.5254819E+01 /
30680 DATA (AM( 7,K, 2),K=0, 2)
30681 & / -0.1909811E+02, 0.3695678E+01, 0.5495729E+01 /
30682 DATA (AM( 8,K, 2),K=0, 2)
30683 & / 0.1889751E-01, 0.5027193E-02, 0.6624896E-03 /
30684
30685 DATA MEXVEC( 1) / 8 /
30686 DATA MLFVEC( 1) / 2 /
30687 DATA UT1VEC( 1) / 0.4138426E+01 /
30688 DATA UT2VEC( 1) / -0.3221374E+01 /
30689 DATA ALFVEC( 1) / 0.4960962E+00 /
30690 DATA QMAVEC( 1) / 0.0000000E+00 /
30691 DATA (AM( 0,K, 1),K=0, 2)
30692 & / 0.1332497E+01, -0.3703718E+00, 0.1288638E+00 /
30693 DATA (AM( 1,K, 1),K=0, 2)
30694 & / 0.7544687E+00, 0.3255075E-01, -0.4706680E-01 /
30695 DATA (AM( 2,K, 1),K=0, 2)
30696 & / -0.7638814E+00, 0.5008313E+00, -0.9237374E-01 /
30697 DATA (AM( 3,K, 1),K=0, 2)
30698 & / -0.3689889E+00, -0.1055098E+01, -0.4645065E+00 /
30699 DATA (AM( 4,K, 1),K=0, 2)
30700 & / 0.3991610E+02, 0.1979881E+01, 0.1775814E+01 /
30701 DATA (AM( 5,K, 1),K=0, 2)
30702 & / 0.6201080E+01, 0.2046288E+01, 0.3804571E+00 /
30703 DATA (AM( 6,K, 1),K=0, 2)
30704 & / -0.8027900E+00, -0.7011688E+00, -0.8049612E+00 /
30705 DATA (AM( 7,K, 1),K=0, 2)
30706 & / -0.8631305E+01, -0.3981200E+01, 0.6970153E+00 /
30707 DATA (AM( 8,K, 1),K=0, 2)
30708 & / 0.2371230E-01, 0.5372683E-02, 0.1118701E-02 /
30709
30710 DATA MEXVEC( 0) / 8 /
30711 DATA MLFVEC( 0) / 2 /
30712 DATA UT1VEC( 0) / -0.1026789E+01 /
30713 DATA UT2VEC( 0) / -0.9051707E+01 /
30714 DATA ALFVEC( 0) / 0.9462977E+00 /
30715 DATA QMAVEC( 0) / 0.0000000E+00 /
30716 DATA (AM( 0,K, 0),K=0, 2)
30717 & / 0.1191990E+03, -0.8548739E+00, -0.1963040E+01 /
30718 DATA (AM( 1,K, 0),K=0, 2)
30719 & / -0.9449972E+02, 0.1074771E+01, 0.2056055E+01 /
30720 DATA (AM( 2,K, 0),K=0, 2)
30721 & / 0.3701064E+01, -0.1167947E-02, 0.1933573E+00 /
30722 DATA (AM( 3,K, 0),K=0, 2)
30723 & / 0.1171345E+03, -0.1064540E+01, -0.1875312E+01 /
30724 DATA (AM( 4,K, 0),K=0, 2)
30725 & / -0.1014453E+03, -0.5707427E+00, 0.4511242E-01 /
30726 DATA (AM( 5,K, 0),K=0, 2)
30727 & / 0.6365168E+01, 0.1275354E+01, -0.4964081E+00 /
30728 DATA (AM( 6,K, 0),K=0, 2)
30729 & / -0.3370693E+01, -0.1122020E+01, 0.5947751E-01 /
30730 DATA (AM( 7,K, 0),K=0, 2)
30731 & / -0.5327270E+01, -0.9293556E+00, 0.6629940E+00 /
30732 DATA (AM( 8,K, 0),K=0, 2)
30733 & / 0.2437513E-01, 0.1600939E-02, 0.6855336E-03 /
30734
30735 DATA MEXVEC(-1) / 8 /
30736 DATA MLFVEC(-1) / 2 /
30737 DATA UT1VEC(-1) / 0.5243571E+01 /
30738 DATA UT2VEC(-1) / -0.2870513E+01 /
30739 DATA ALFVEC(-1) / 0.6701448E+00 /
30740 DATA QMAVEC(-1) / 0.0000000E+00 /
30741 DATA (AM( 0,K,-1),K=0, 2)
30742 & / 0.2428863E+02, 0.1907035E+01, -0.4606457E+00 /
30743 DATA (AM( 1,K,-1),K=0, 2)
30744 & / 0.2006810E+01, -0.1265915E+00, 0.7153556E-02 /
30745 DATA (AM( 2,K,-1),K=0, 2)
30746 & / -0.1884546E+02, -0.2339471E+01, 0.5740679E+01 /
30747 DATA (AM( 3,K,-1),K=0, 2)
30748 & / -0.2527892E+02, -0.2044124E+01, 0.1280470E+02 /
30749 DATA (AM( 4,K,-1),K=0, 2)
30750 & / -0.1013824E+03, -0.1594199E+01, 0.2216401E+00 /
30751 DATA (AM( 5,K,-1),K=0, 2)
30752 & / 0.8070930E+02, 0.1792072E+01, -0.2164364E+02 /
30753 DATA (AM( 6,K,-1),K=0, 2)
30754 & / -0.4641050E+02, 0.1977338E+00, 0.1273014E+02 /
30755 DATA (AM( 7,K,-1),K=0, 2)
30756 & / -0.3910568E+02, 0.1719632E+01, 0.1086525E+02 /
30757 DATA (AM( 8,K,-1),K=0, 2)
30758 & / -0.1185496E+01, -0.1905847E+00, -0.8744118E-03 /
30759
30760 DATA MEXVEC(-2) / 7 /
30761 DATA MLFVEC(-2) / 2 /
30762 DATA UT1VEC(-2) / 0.4782210E+01 /
30763 DATA UT2VEC(-2) / -0.1976856E+02 /
30764 DATA ALFVEC(-2) / 0.7558374E+00 /
30765 DATA QMAVEC(-2) / 0.0000000E+00 /
30766 DATA (AM( 0,K,-2),K=0, 2)
30767 & / -0.6216935E+00, 0.2369963E+00, -0.7909949E-02 /
30768 DATA (AM( 1,K,-2),K=0, 2)
30769 & / 0.1245440E+01, -0.1031510E+00, 0.4916523E-02 /
30770 DATA (AM( 2,K,-2),K=0, 2)
30771 & / -0.7060824E+01, -0.3875283E-01, 0.1784981E+00 /
30772 DATA (AM( 3,K,-2),K=0, 2)
30773 & / -0.7430595E+01, 0.1964572E+00, -0.1284999E+00 /
30774 DATA (AM( 4,K,-2),K=0, 2)
30775 & / -0.6897810E+01, 0.2620543E+01, 0.8012553E-02 /
30776 DATA (AM( 5,K,-2),K=0, 2)
30777 & / 0.1507713E+02, 0.2340307E-01, 0.2482535E+01 /
30778 DATA (AM( 6,K,-2),K=0, 2)
30779 & / -0.1815341E+01, -0.1538698E+01, -0.2014208E+01 /
30780 DATA (AM( 7,K,-2),K=0, 2)
30781 & / -0.2571932E+02, 0.2903941E+00, -0.2848206E+01 /
30782
30783 DATA MEXVEC(-3) / 7 /
30784 DATA MLFVEC(-3) / 2 /
30785 DATA UT1VEC(-3) / 0.4518239E+01 /
30786 DATA UT2VEC(-3) / -0.2690590E+01 /
30787 DATA ALFVEC(-3) / 0.6124079E+00 /
30788 DATA QMAVEC(-3) / 0.0000000E+00 /
30789 DATA (AM( 0,K,-3),K=0, 2)
30790 & / -0.2734458E+01, -0.7245673E+00, -0.6351374E+00 /
30791 DATA (AM( 1,K,-3),K=0, 2)
30792 & / 0.2927174E+01, 0.4822709E+00, -0.1088787E-01 /
30793 DATA (AM( 2,K,-3),K=0, 2)
30794 & / -0.1771017E+02, -0.1416635E+01, 0.8467622E+01 /
30795 DATA (AM( 3,K,-3),K=0, 2)
30796 & / -0.4972782E+02, -0.3348547E+01, 0.1767061E+02 /
30797 DATA (AM( 4,K,-3),K=0, 2)
30798 & / -0.7102770E+01, -0.3205337E+01, 0.4101704E+00 /
30799 DATA (AM( 5,K,-3),K=0, 2)
30800 & / 0.7169698E+02, -0.2205985E+01, -0.2463931E+02 /
30801 DATA (AM( 6,K,-3),K=0, 2)
30802 & / -0.4090347E+02, 0.2103486E+01, 0.1416507E+02 /
30803 DATA (AM( 7,K,-3),K=0, 2)
30804 & / -0.2952639E+02, 0.5376136E+01, 0.7825585E+01 /
30805
30806 DATA MEXVEC(-4) / 7 /
30807 DATA MLFVEC(-4) / 2 /
30808 DATA UT1VEC(-4) / 0.2783230E+01 /
30809 DATA UT2VEC(-4) / -0.1746328E+01 /
30810 DATA ALFVEC(-4) / 0.1115653E+01 /
30811 DATA QMAVEC(-4) / 0.1300000E+01 /
30812 DATA (AM( 0,K,-4),K=0, 2)
30813 & / -0.1743872E+01, -0.1128921E+01, -0.2841969E+00 /
30814 DATA (AM( 1,K,-4),K=0, 2)
30815 & / 0.3345755E+01, 0.3187765E+00, 0.1378124E+00 /
30816 DATA (AM( 2,K,-4),K=0, 2)
30817 & / -0.2037615E+02, 0.4121687E+01, 0.2236520E+00 /
30818 DATA (AM( 3,K,-4),K=0, 2)
30819 & / -0.4703104E+02, 0.5353087E+01, -0.1455347E+01 /
30820 DATA (AM( 4,K,-4),K=0, 2)
30821 & / -0.1060230E+02, -0.1551122E+01, -0.1078863E+01 /
30822 DATA (AM( 5,K,-4),K=0, 2)
30823 & / 0.5088892E+02, -0.8197304E+01, 0.8083451E+01 /
30824 DATA (AM( 6,K,-4),K=0, 2)
30825 & / -0.2819070E+02, 0.4554086E+01, -0.5890995E+01 /
30826 DATA (AM( 7,K,-4),K=0, 2)
30827 & / -0.1098238E+02, 0.2590096E+01, -0.8062879E+01 /
30828
30829 DATA MEXVEC(-5) / 6 /
30830 DATA MLFVEC(-5) / 2 /
30831 DATA UT1VEC(-5) / 0.1619654E+02 /
30832 DATA UT2VEC(-5) / -0.3367346E+01 /
30833 DATA ALFVEC(-5) / 0.5109891E-02 /
30834 DATA QMAVEC(-5) / 0.4500000E+01 /
30835 DATA (AM( 0,K,-5),K=0, 2)
30836 & / -0.6800138E+01, 0.2493627E+01, -0.1075724E+01 /
30837 DATA (AM( 1,K,-5),K=0, 2)
30838 & / 0.3036555E+01, 0.3324733E+00, 0.2008298E+00 /
30839 DATA (AM( 2,K,-5),K=0, 2)
30840 & / -0.5203879E+01, -0.8493476E+01, -0.4523208E+01 /
30841 DATA (AM( 3,K,-5),K=0, 2)
30842 & / -0.1524239E+01, -0.3411912E+01, -0.1771867E+02 /
30843 DATA (AM( 4,K,-5),K=0, 2)
30844 & / -0.1099444E+02, 0.1320930E+01, -0.2353831E+01 /
30845 DATA (AM( 5,K,-5),K=0, 2)
30846 & / 0.1699299E+02, -0.3565802E+02, 0.3566872E+02 /
30847 DATA (AM( 6,K,-5),K=0, 2)
30848 & / -0.1465793E+02, 0.2703365E+02, -0.2176372E+02 /
30849
30850 IF(Q .LE. QMAVEC(IFL)) THEN
30851 PYCT5M = 0.D0
30852 RETURN
30853 ENDIF
30854
30855 IF(X .GE. 1.D0) THEN
30856 PYCT5M = 0.D0
30857 RETURN
30858 ENDIF
30859
30860 TMP = LOG(Q/ALFVEC(IFL))
30861 IF(TMP .LE. 0.D0) THEN
30862 PYCT5M = 0.D0
30863 RETURN
30864 ENDIF
30865
30866 SB = LOG(TMP)
30867 SB1 = SB - 1.2D0
30868 SB2 = SB1*SB1
30869
30870 DO 110 I = 0, NEX
30871 AF(I) = 0.D0
30872 SBX = 1.D0
30873 DO 100 K = 0, MLFVEC(IFL)
30874 AF(I) = AF(I) + SBX*AM(I,K,IFL)
30875 SBX = SB1*SBX
30876 100 CONTINUE
30877 110 CONTINUE
30878
30879 Y = -LOG(X)
30880 U = LOG(X/0.00001D0)
30881
30882 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
30883 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
30884 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
30885 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
30886 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
30887
30888 PYCT5M = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
30889
30890C...Include threshold factor.
30891 PYCT5M = PYCT5M * (1.D0 - QMAVEC(IFL)/Q)
30892
30893 RETURN
30894 END
30895
30896C*********************************************************************
30897
30898C...PYPDPO
30899C...Auxiliary to PYPDPR. Gives proton parton distributions according to
30900C...a few older parametrizations, now obsolete but convenient for
30901C...backwards checks.
30902
30903 SUBROUTINE PYPDPO(X,Q2,XPPR)
30904
30905C...Double precision and integer declarations.
30906 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30907 IMPLICIT INTEGER(I-N)
30908 INTEGER PYK,PYCHGE,PYCOMP
30909C...Commonblocks.
30910 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30911 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30912 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30913 COMMON/PYINT1/MINT(400),VINT(400)
30914 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
30915 DIMENSION XPPR(-6:6),XQ(9),TX(6),TT(6),TS(6),NEHLQ(8,2),
30916 &CEHLQ(6,6,2,8,2),CDO(3,6,5,2)
30917
30918
30919C...The following data lines are coefficients needed in the
30920C...Eichten, Hinchliffe, Lane, Quigg proton structure function
30921C...parametrizations, see below.
30922C...Powers of 1-x in different cases.
30923 DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
30924C...Expansion coefficients for up valence quark distribution.
30925 DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
30926 1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04,
30927 2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03,
30928 3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03,
30929 4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03,
30930 5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03,
30931 6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04,
30932 1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04,
30933 2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03,
30934 3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04,
30935 4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04,
30936 5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05,
30937 6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/
30938 DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
30939 1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04,
30940 2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03,
30941 3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03,
30942 4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03,
30943 5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03,
30944 6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04,
30945 1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04,
30946 2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03,
30947 3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04,
30948 4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04,
30949 5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05,
30950 6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/
30951C...Expansion coefficients for down valence quark distribution.
30952 DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
30953 1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04,
30954 2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03,
30955 3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03,
30956 4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03,
30957 5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04,
30958 6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04,
30959 1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04,
30960 2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03,
30961 3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04,
30962 4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04,
30963 5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05,
30964 6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/
30965 DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
30966 1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04,
30967 2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03,
30968 3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03,
30969 4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03,
30970 5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04,
30971 6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04,
30972 1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04,
30973 2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03,
30974 3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04,
30975 4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04,
30976 5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05,
30977 6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/
30978C...Expansion coefficients for up and down sea quark distributions.
30979 DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
30980 1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04,
30981 2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03,
30982 3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05,
30983 4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04,
30984 5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04,
30985 6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05,
30986 1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04,
30987 2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03,
30988 3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04,
30989 4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05,
30990 5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00,
30991 6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/
30992 DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
30993 1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04,
30994 2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03,
30995 3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04,
30996 4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04,
30997 5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04,
30998 6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04,
30999 1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03,
31000 2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03,
31001 3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04,
31002 4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05,
31003 5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05,
31004 6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/
31005C...Expansion coefficients for gluon distribution.
31006 DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
31007 1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02,
31008 2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02,
31009 3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02,
31010 4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03,
31011 5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04,
31012 6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03,
31013 1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02,
31014 2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02,
31015 3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02,
31016 4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03,
31017 5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03,
31018 6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/
31019 DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
31020 1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02,
31021 2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02,
31022 3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02,
31023 4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02,
31024 5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02,
31025 6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02,
31026 1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02,
31027 2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01,
31028 3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02,
31029 4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03,
31030 5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03,
31031 6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/
31032C...Expansion coefficients for strange sea quark distribution.
31033 DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
31034 1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04,
31035 2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03,
31036 3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04,
31037 4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04,
31038 5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04,
31039 6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05,
31040 1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04,
31041 2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03,
31042 3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04,
31043 4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05,
31044 5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00,
31045 6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/
31046 DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
31047 1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04,
31048 2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03,
31049 3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04,
31050 4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04,
31051 5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04,
31052 6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04,
31053 1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03,
31054 2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03,
31055 3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04,
31056 4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05,
31057 5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05,
31058 6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/
31059C...Expansion coefficients for charm sea quark distribution.
31060 DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
31061 1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03,
31062 2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03,
31063 3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04,
31064 4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05,
31065 5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05,
31066 6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05,
31067 1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04,
31068 2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03,
31069 3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04,
31070 4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04,
31071 5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05,
31072 6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/
31073 DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
31074 1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03,
31075 2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03,
31076 3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04,
31077 4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05,
31078 5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05,
31079 6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05,
31080 1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03,
31081 2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03,
31082 3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04,
31083 4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04,
31084 5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05,
31085 6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/
31086C...Expansion coefficients for bottom sea quark distribution.
31087 DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
31088 1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03,
31089 2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04,
31090 3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04,
31091 4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05,
31092 5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05,
31093 6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05,
31094 1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03,
31095 2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03,
31096 3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04,
31097 4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05,
31098 5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05,
31099 6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/
31100 DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
31101 1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03,
31102 2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04,
31103 3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04,
31104 4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05,
31105 5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00,
31106 6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05,
31107 1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03,
31108 2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03,
31109 3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04,
31110 4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05,
31111 5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05,
31112 6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/
31113C...Expansion coefficients for top sea quark distribution.
31114 DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
31115 1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04,
31116 2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04,
31117 3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04,
31118 4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00,
31119 5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05,
31120 6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
31121 1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03,
31122 2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03,
31123 3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04,
31124 4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05,
31125 5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00,
31126 6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/
31127 DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
31128 1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04,
31129 2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04,
31130 3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04,
31131 4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00,
31132 5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05,
31133 6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
31134 1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03,
31135 2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03,
31136 3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04,
31137 4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05,
31138 5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00,
31139 6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/
31140
31141C...The following data lines are coefficients needed in the
31142C...Duke, Owens proton structure function parametrizations, see below.
31143C...Expansion coefficients for (up+down) valence quark distribution.
31144 DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/
31145 1 4.190D-01, 3.460D+00, 4.400D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31146 2 4.000D-03, 7.240D-01,-4.860D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31147 3-7.000D-03,-6.600D-02, 1.330D+00, 0.000D+00, 0.000D+00, 0.000D+00/
31148 DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/
31149 1 3.740D-01, 3.330D+00, 6.030D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31150 2 1.400D-02, 7.530D-01,-6.220D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31151 3 0.000D+00,-7.600D-02, 1.560D+00, 0.000D+00, 0.000D+00, 0.000D+00/
31152C...Expansion coefficients for down valence quark distribution.
31153 DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/
31154 1 7.630D-01, 4.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31155 2-2.370D-01, 6.270D-01,-4.210D-01, 0.000D+00, 0.000D+00, 0.000D+00,
31156 3 2.600D-02,-1.900D-02, 3.300D-02, 0.000D+00, 0.000D+00, 0.000D+00/
31157 DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/
31158 1 7.610D-01, 3.830D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31159 2-2.320D-01, 6.270D-01,-4.180D-01, 0.000D+00, 0.000D+00, 0.000D+00,
31160 3 2.300D-02,-1.900D-02, 3.600D-02, 0.000D+00, 0.000D+00, 0.000D+00/
31161C...Expansion coefficients for (up+down+strange) sea quark distribution.
31162 DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/
31163 1 1.265D+00, 0.000D+00, 8.050D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31164 2-1.132D+00,-3.720D-01, 1.590D+00, 6.310D+00,-1.050D+01, 1.470D+01,
31165 3 2.930D-01,-2.900D-02,-1.530D-01,-2.730D-01,-3.170D+00, 9.800D+00/
31166 DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/
31167 1 1.670D+00, 0.000D+00, 9.150D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31168 2-1.920D+00,-2.730D-01, 5.300D-01, 1.570D+01,-1.010D+02, 2.230D+02,
31169 3 5.820D-01,-1.640D-01,-7.630D-01,-2.830D+00, 4.470D+01,-1.170D+02/
31170C...Expansion coefficients for charm sea quark distribution.
31171 DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/
31172 1 0.000D+00,-3.600D-02, 6.350D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31173 2 1.350D-01,-2.220D-01, 3.260D+00,-3.030D+00, 1.740D+01,-1.790D+01,
31174 3-7.500D-02,-5.800D-02,-9.090D-01, 1.500D+00,-1.130D+01, 1.560D+01/
31175 DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/
31176 1 0.000D+00,-1.200D-01, 3.510D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31177 2 6.700D-02,-2.330D-01, 3.660D+00,-4.740D-01, 9.500D+00,-1.660D+01,
31178 3-3.100D-02,-2.300D-02,-4.530D-01, 3.580D-01,-5.430D+00, 1.550D+01/
31179C...Expansion coefficients for gluon distribution.
31180 DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/
31181 1 1.560D+00, 0.000D+00, 6.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
31182 2-1.710D+00,-9.490D-01, 1.440D+00,-7.190D+00,-1.650D+01, 1.530D+01,
31183 3 6.380D-01, 3.250D-01,-1.050D+00, 2.550D-01, 1.090D+01,-1.010D+01/
31184 DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/
31185 1 8.790D-01, 0.000D+00, 4.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
31186 2-9.710D-01,-1.160D+00, 1.230D+00,-5.640D+00,-7.540D+00,-5.960D-01,
31187 3 4.340D-01, 4.760D-01,-2.540D-01,-8.170D-01, 5.500D+00, 1.260D-01/
31188
31189C...Euler's beta function, requires ordinary Gamma function
31190 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
31191
31192C...Leading order proton parton distributions from Glueck, Reya and
31193C...Vogt. Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
31194C...10^-5 < x < 1.
31195 IF(MSTP(51).EQ.11) THEN
31196
31197C...Determine s expansion variable and some x expressions.
31198 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
31199 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
31200 SD2=SD**2
31201 XL=-LOG(X)
31202 XS=SQRT(X)
31203
31204C...Evaluate valence, gluon and sea distributions.
31205 XFVUD=(0.663D0+0.191D0*SD-0.041D0*SD2+0.031D0*SD**3)*
31206 & X**0.326D0*(1D0+(-1.97D0+6.74D0*SD-1.96D0*SD2)*XS+
31207 & (24.4D0-20.7D0*SD+4.08D0*SD2)*X)*
31208 & (1D0-X)**(2.86D0+0.70D0*SD-0.02D0*SD2)
31209 XFVDD=(0.579D0+0.283D0*SD+0.047D0*SD2)*X**(0.523D0-0.015D0*SD)*
31210 & (1D0+(2.22D0-0.59D0*SD-0.27D0*SD2)*XS+(5.95D0-6.19D0*SD+
31211 & 1.55D0*SD2)*X)*(1D0-X)**(3.57D0+0.94D0*SD-0.16D0*SD2)
31212 XFGLU=(X**(1.00D0-0.17D0*SD)*((4.879D0*SD-1.383D0*SD2)+
31213 & (25.92D0-28.97D0*SD+5.596D0*SD2)*X+(-25.69D0+23.68D0*SD-
31214 & 1.975D0*SD2)*X**2)+SD**0.558D0*EXP(-(0.595D0+2.138D0*SD)+
31215 & SQRT(4.066D0*SD**1.218D0*XL)))*
31216 & (1D0-X)**(2.537D0+1.718D0*SD+0.353D0*SD2)
31217 XFSEA=(X**(0.412D0-0.171D0*SD)*(0.363D0-1.196D0*X+(1.029D0+
31218 & 1.785D0*SD-0.459D0*SD2)*X**2)*XL**(0.566D0-0.496D0*SD)+
31219 & SD**1.396D0*EXP(-(3.838D0+1.944D0*SD)+SQRT(2.845D0*SD**1.331D0*
31220 & XL)))*(1D0-X)**(4.696D0+2.109D0*SD)
31221 XFSTR=SD**0.803D0*(1D0+(-3.055D0+1.024D0*SD**0.67D0)*XS+
31222 & (27.4D0-20.0D0*SD**0.154D0)*X)*(1D0-X)**6.22D0*
31223 & EXP(-(4.33D0+1.408D0*SD)+SQRT((8.27D0-0.437D0*SD)*
31224 & SD**0.563D0*XL))/XL**(2.082D0-0.577D0*SD)
31225 IF(SD.LE.0.888D0) THEN
31226 XFCHM=0D0
31227 ELSE
31228 XFCHM=(SD-0.888D0)**1.01D0*(1.+(4.24D0-0.804D0*SD)*X)*
31229 & (1D0-X)**(3.46D0+1.076D0*SD)*EXP(-(4.61D0+1.49D0*SD)+
31230 & SQRT((2.555D0+1.961D0*SD)*SD**0.37D0*XL))
31231 ENDIF
31232 IF(SD.LE.1.351D0) THEN
31233 XFBOT=0D0
31234 ELSE
31235 XFBOT=(SD-1.351D0)*(1D0+1.848D0*X)*(1D0-X)**(2.929D0+
31236 & 1.396D0*SD)*EXP(-(4.71D0+1.514D0*SD)+
31237 & SQRT((4.02D0+1.239D0*SD)*SD**0.51D0*XL))
31238 ENDIF
31239
31240C...Put into output array.
31241 XPPR(0)=XFGLU
31242 XPPR(1)=XFVDD+XFSEA
31243 XPPR(2)=XFVUD-XFVDD+XFSEA
31244 XPPR(3)=XFSTR
31245 XPPR(4)=XFCHM
31246 XPPR(5)=XFBOT
31247 XPPR(-1)=XFSEA
31248 XPPR(-2)=XFSEA
31249 XPPR(-3)=XFSTR
31250 XPPR(-4)=XFCHM
31251 XPPR(-5)=XFBOT
31252
31253C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg.
31254C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1
31255 ELSEIF(MSTP(51).EQ.12.OR.MSTP(51).EQ.13) THEN
31256
31257C...Determine set, Lambda and x and t expansion variables.
31258 NSET=MSTP(51)-11
31259 IF(NSET.EQ.1) ALAM=0.2D0
31260 IF(NSET.EQ.2) ALAM=0.29D0
31261 TMIN=LOG(5D0/ALAM**2)
31262 TMAX=LOG(1D8/ALAM**2)
31263 T=LOG(MAX(1D0,Q2/ALAM**2))
31264 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
31265 NX=1
31266 IF(X.LE.0.1D0) NX=2
31267 IF(NX.EQ.1) VX=(2D0*X-1.1D0)/0.9D0
31268 IF(NX.EQ.2) VX=MAX(-1D0,(2D0*LOG(X)+11.51293D0)/6.90776D0)
31269
31270C...Chebyshev polynomials for x and t expansion.
31271 TX(1)=1D0
31272 TX(2)=VX
31273 TX(3)=2D0*VX**2-1D0
31274 TX(4)=4D0*VX**3-3D0*VX
31275 TX(5)=8D0*VX**4-8D0*VX**2+1D0
31276 TX(6)=16D0*VX**5-20D0*VX**3+5D0*VX
31277 TT(1)=1D0
31278 TT(2)=VT
31279 TT(3)=2D0*VT**2-1D0
31280 TT(4)=4D0*VT**3-3D0*VT
31281 TT(5)=8D0*VT**4-8D0*VT**2+1D0
31282 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
31283
31284C...Calculate structure functions.
31285 DO 120 KFL=1,6
31286 XQSUM=0D0
31287 DO 110 IT=1,6
31288 DO 100 IX=1,6
31289 XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)
31290 100 CONTINUE
31291 110 CONTINUE
31292 XQ(KFL)=XQSUM*(1D0-X)**NEHLQ(KFL,NSET)
31293 120 CONTINUE
31294
31295C...Put into output array.
31296 XPPR(0)=XQ(4)
31297 XPPR(1)=XQ(2)+XQ(3)
31298 XPPR(2)=XQ(1)+XQ(3)
31299 XPPR(3)=XQ(5)
31300 XPPR(4)=XQ(6)
31301 XPPR(-1)=XQ(3)
31302 XPPR(-2)=XQ(3)
31303 XPPR(-3)=XQ(5)
31304 XPPR(-4)=XQ(6)
31305
31306C...Special expansion for bottom (threshold effects).
31307 IF(MSTP(58).GE.5) THEN
31308 IF(NSET.EQ.1) TMIN=8.1905D0
31309 IF(NSET.EQ.2) TMIN=7.4474D0
31310 IF(T.GT.TMIN) THEN
31311 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
31312 TT(1)=1D0
31313 TT(2)=VT
31314 TT(3)=2D0*VT**2-1D0
31315 TT(4)=4D0*VT**3-3D0*VT
31316 TT(5)=8D0*VT**4-8D0*VT**2+1D0
31317 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
31318 XQSUM=0D0
31319 DO 140 IT=1,6
31320 DO 130 IX=1,6
31321 XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)
31322 130 CONTINUE
31323 140 CONTINUE
31324 XPPR(5)=XQSUM*(1D0-X)**NEHLQ(7,NSET)
31325 XPPR(-5)=XPPR(5)
31326 ENDIF
31327 ENDIF
31328
31329C...Special expansion for top (threshold effects).
31330 IF(MSTP(58).GE.6) THEN
31331 IF(NSET.EQ.1) TMIN=11.5528D0
31332 IF(NSET.EQ.2) TMIN=10.8097D0
31333 TMIN=TMIN+2D0*LOG(PMAS(6,1)/30D0)
31334 TMAX=TMAX+2D0*LOG(PMAS(6,1)/30D0)
31335 IF(T.GT.TMIN) THEN
31336 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
31337 TT(1)=1D0
31338 TT(2)=VT
31339 TT(3)=2D0*VT**2-1D0
31340 TT(4)=4D0*VT**3-3D0*VT
31341 TT(5)=8D0*VT**4-8D0*VT**2+1D0
31342 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
31343 XQSUM=0D0
31344 DO 160 IT=1,6
31345 DO 150 IX=1,6
31346 XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)
31347 150 CONTINUE
31348 160 CONTINUE
31349 XPPR(6)=XQSUM*(1D0-X)**NEHLQ(8,NSET)
31350 XPPR(-6)=XPPR(6)
31351 ENDIF
31352 ENDIF
31353
31354C...Proton parton distributions from Duke, Owens.
31355C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2.
31356 ELSEIF(MSTP(51).EQ.14.OR.MSTP(51).EQ.15) THEN
31357
31358C...Determine set, Lambda and s expansion parameter.
31359 NSET=MSTP(51)-13
31360 IF(NSET.EQ.1) ALAM=0.2D0
31361 IF(NSET.EQ.2) ALAM=0.4D0
31362 Q2IN=MIN(1D6,MAX(4D0,Q2))
31363 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
31364
31365C...Calculate structure functions.
31366 DO 180 KFL=1,5
31367 DO 170 IS=1,6
31368 TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+
31369 & CDO(3,IS,KFL,NSET)*SD**2
31370 170 CONTINUE
31371 IF(KFL.LE.2) THEN
31372 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)*(1D0+TS(3)*X)/(EULBET(TS(1),
31373 & TS(2)+1D0)*(1D0+TS(3)*TS(1)/(TS(1)+TS(2)+1D0)))
31374 ELSE
31375 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
31376 & TS(5)*X**2+TS(6)*X**3)
31377 ENDIF
31378 180 CONTINUE
31379
31380C...Put into output arrays.
31381 XPPR(0)=XQ(5)
31382 XPPR(1)=XQ(2)+XQ(3)/6D0
31383 XPPR(2)=3D0*XQ(1)-XQ(2)+XQ(3)/6D0
31384 XPPR(3)=XQ(3)/6D0
31385 XPPR(4)=XQ(4)
31386 XPPR(-1)=XQ(3)/6D0
31387 XPPR(-2)=XQ(3)/6D0
31388 XPPR(-3)=XQ(3)/6D0
31389 XPPR(-4)=XQ(4)
31390
31391 ENDIF
31392
31393 RETURN
31394 END
31395
31396C*********************************************************************
31397
31398C...PYHFTH
31399C...Gives threshold attractive/repulsive factor for heavy flavour
31400C...production.
31401
31402 FUNCTION PYHFTH(SH,SQM,FRATT)
31403
31404C...Double precision and integer declarations.
31405 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31406 IMPLICIT INTEGER(I-N)
31407 INTEGER PYK,PYCHGE,PYCOMP
31408C...Commonblocks.
31409 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31410 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
31411 COMMON/PYINT1/MINT(400),VINT(400)
31412 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
31413
31414C...Value for alpha_strong.
31415 IF(MSTP(35).LE.1) THEN
31416 ALSSG=PARP(35)
31417 ELSE
31418 MST115=MSTU(115)
31419 MSTU(115)=MSTP(36)
31420 Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+
31421 & PARP(36)**2)))
31422 ALSSG=PYALPS(Q2BN)
31423 MSTU(115)=MST115
31424 ENDIF
31425
31426C...Evaluate attractive and repulsive factors.
31427 XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
31428 FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
31429 XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
31430 FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
31431 PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU
31432 VINT(138)=PYHFTH
31433
31434 RETURN
31435 END
31436
31437C*********************************************************************
31438
31439C...PYSPLI
31440C...Splits a hadron remnant into two (partons or hadron + parton)
31441C...in case it is more complicated than just a quark or a diquark.
31442
31443 SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
31444
31445C...Double precision and integer declarations.
31446 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31447 IMPLICIT INTEGER(I-N)
31448 INTEGER PYK,PYCHGE,PYCOMP
31449C...Commonblocks. PYDAT1 temporary
31450 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
31451 COMMON/PYINT1/MINT(400),VINT(400)
31452 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31453 SAVE /PYPARS/,/PYINT1/,/PYDAT1/
31454C...Local array.
31455 DIMENSION KFL(3)
31456
31457C...Preliminaries. Parton composition.
31458 KFA=IABS(KF)
31459 KFS=ISIGN(1,KF)
31460 KFL(1)=MOD(KFA/1000,10)
31461 KFL(2)=MOD(KFA/100,10)
31462 KFL(3)=MOD(KFA/10,10)
31463 IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
31464 KFL(2)=INT(1.5D0+PYR(0))
31465 IF(MINT(105).EQ.333) KFL(2)=3
31466 IF(MINT(105).EQ.443) KFL(2)=4
31467 KFL(3)=KFL(2)
31468 ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN
31469 KFL(2)=2
31470 KFL(3)=2
31471 ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN
31472 KFL(2)=1
31473 KFL(3)=1
31474 ELSEIF((KFA.EQ.130.OR.KFA.EQ.310).AND.PYR(0).GT.0.5D0) THEN
31475 KFL(2)=MOD(KFA/10,10)
31476 KFL(3)=MOD(KFA/100,10)
31477 ENDIF
31478 IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN
31479 KFLR=KFLIN*KFS
31480 ELSE
31481 KFLR=KFLIN
31482 ENDIF
31483 KFLCH=0
31484
31485C...Subdivide lepton.
31486 IF(KFA.GE.11.AND.KFA.LE.18) THEN
31487 IF(KFLR.EQ.KFA) THEN
31488 KFLSP=KFS*22
31489 ELSEIF(KFLR.EQ.22) THEN
31490 KFLSP=KFA
31491 ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN
31492 KFLSP=KFA+1
31493 ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN
31494 KFLSP=KFA-1
31495 ELSEIF(KFLR.EQ.21) THEN
31496 KFLSP=KFA
31497 KFLCH=KFS*21
31498 ELSE
31499 KFLSP=KFA
31500 KFLCH=-KFLR
31501 ENDIF
31502
31503C...Subdivide photon.
31504 ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN
31505 IF(KFLR.NE.21) THEN
31506 KFLSP=-KFLR
31507 ELSE
31508 RAGR=0.75D0*PYR(0)
31509 KFLSP=1
31510 IF(RAGR.GT.0.125D0) KFLSP=2
31511 IF(RAGR.GT.0.625D0) KFLSP=3
31512 IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP
31513 KFLCH=-KFLSP
31514 ENDIF
31515
31516C...Subdivide Reggeon or Pomeron.
31517 ELSEIF(KFA.EQ.110.OR.KFA.EQ.990) THEN
31518 IF(KFLIN.EQ.21) THEN
31519 KFLSP=KFS*21
31520 ELSE
31521 KFLSP=-KFLIN
31522 ENDIF
31523
31524C...Subdivide meson.
31525 ELSEIF(KFL(1).EQ.0) THEN
31526 KFL(2)=KFL(2)*(-1)**KFL(2)
31527 KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
31528 IF(KFLR.EQ.KFL(2)) THEN
31529 KFLSP=KFL(3)
31530 ELSEIF(KFLR.EQ.KFL(3)) THEN
31531 KFLSP=KFL(2)
31532 ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN
31533 KFLSP=KFL(2)
31534 KFLCH=KFL(3)
31535 ELSEIF(KFLR.EQ.21) THEN
31536 KFLSP=KFL(3)
31537 KFLCH=KFL(2)
31538 ELSEIF(KFLR*KFL(2).GT.0) THEN
31539 NTRY=0
31540 100 NTRY=NTRY+1
31541 CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
31542 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
31543 GOTO 100
31544 ELSEIF(KFLCH.EQ.0) THEN
31545 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
31546 MINT(51)=1
31547 RETURN
31548 ENDIF
31549 KFLSP=KFL(3)
31550 ELSE
31551 NTRY=0
31552 110 NTRY=NTRY+1
31553 CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
31554 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
31555 GOTO 110
31556 ELSEIF(KFLCH.EQ.0) THEN
31557 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
31558 MINT(51)=1
31559 RETURN
31560 ENDIF
31561 KFLSP=KFL(2)
31562 ENDIF
31563
31564C...Subdivide baryon.
31565 ELSE
31566 NAGR=0
31567 DO 120 J=1,3
31568 IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
31569 120 CONTINUE
31570 IF(NAGR.GE.1) THEN
31571 RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0)
31572 IAGR=0
31573 DO 130 J=1,3
31574 IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0
31575 IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J
31576 130 CONTINUE
31577 ELSE
31578 IAGR=1.00001D0+2.99998D0*PYR(0)
31579 ENDIF
31580 ID1=1
31581 IF(IAGR.EQ.1) ID1=2
31582 IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
31583 ID2=6-IAGR-ID1
31584 KSP=3
31585 IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
31586 IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1
31587 ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
31588 IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1
31589 ELSEIF(MOD(KFA,10).EQ.2) THEN
31590 IF(IAGR.EQ.1) KSP=1
31591 IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1
31592 ENDIF
31593 KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
31594 IF(KFLR.EQ.21) THEN
31595 KFLCH=KFL(IAGR)
31596 ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
31597 NTRY=0
31598 140 NTRY=NTRY+1
31599 CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
31600 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
31601 GOTO 140
31602 ELSEIF(KFLCH.EQ.0) THEN
31603 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
31604 MINT(51)=1
31605 RETURN
31606 ENDIF
31607 ELSEIF(NAGR.EQ.0) THEN
31608 NTRY=0
31609 150 NTRY=NTRY+1
31610 CALL PYKFDI(10000*KFL(ID1)+KFLSP,-KFLR,KFDUMP,KFLCH)
31611 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
31612 GOTO 150
31613 ELSEIF(KFLCH.EQ.0) THEN
31614 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
31615 MINT(51)=1
31616 RETURN
31617 ENDIF
31618 KFLSP=KFL(IAGR)
31619 ENDIF
31620 ENDIF
31621
31622C...Add on correct sign for result.
31623 KFLCH=KFLCH*KFS
31624 KFLSP=KFLSP*KFS
31625
31626 RETURN
31627 END
31628
31629C*********************************************************************
31630
31631C...PYGAMM
31632C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
31633C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
31634C...(Dover, 1965) 6.1.36.
31635
31636 FUNCTION PYGAMM(X)
31637
31638C...Double precision and integer declarations.
31639 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31640 IMPLICIT INTEGER(I-N)
31641 INTEGER PYK,PYCHGE,PYCOMP
31642C...Local array and data.
31643 DIMENSION B(8)
31644 DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
31645 &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/
31646
31647 NX=INT(X)
31648 DX=X-NX
31649
31650 PYGAMM=1D0
31651 DXP=1D0
31652 DO 100 I=1,8
31653 DXP=DXP*DX
31654 PYGAMM=PYGAMM+B(I)*DXP
31655 100 CONTINUE
31656 IF(X.LT.1D0) THEN
31657 PYGAMM=PYGAMM/X
31658 ELSE
31659 DO 110 IX=1,NX-1
31660 PYGAMM=(X-IX)*PYGAMM
31661 110 CONTINUE
31662 ENDIF
31663
31664 RETURN
31665 END
31666
31667C***********************************************************************
31668
31669C...PYWAUX
31670C...Calculates real and imaginary parts of the auxiliary functions W1
31671C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
31672C...der Bij, Nucl. Phys. B297 (1988) 221.
31673
31674 SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)
31675
31676C...Double precision and integer declarations.
31677 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31678 IMPLICIT INTEGER(I-N)
31679 INTEGER PYK,PYCHGE,PYCOMP
31680C...Commonblocks.
31681 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31682 SAVE /PYDAT1/
31683
31684 ASINH(X)=LOG(X+SQRT(X**2+1D0))
31685 ACOSH(X)=LOG(X+SQRT(X**2-1D0))
31686
31687 IF(EPS.LT.0D0) THEN
31688 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
31689 IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
31690 WIM=0D0
31691 ELSEIF(EPS.LT.1D0) THEN
31692 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
31693 IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
31694 IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
31695 IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
31696 ELSE
31697 IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
31698 IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
31699 WIM=0D0
31700 ENDIF
31701
31702 RETURN
31703 END
31704
31705C***********************************************************************
31706
31707C...PYI3AU
31708C...Calculates real and imaginary parts of the auxiliary function I3;
31709C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
31710C...Nucl. Phys. B297 (1988) 221.
31711
31712 SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM)
31713
31714C...Double precision and integer declarations.
31715 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31716 IMPLICIT INTEGER(I-N)
31717 INTEGER PYK,PYCHGE,PYCOMP
31718C...Commonblocks.
31719 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31720 SAVE /PYDAT1/
31721
31722 BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS))
31723 IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS))
31724
31725 IF(EPS.LT.0D0) THEN
31726 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
31727 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
31728 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
31729 & PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)-
31730 & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-
31731 & LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)*
31732 & LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+
31733 & LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)*
31734 & EPS))
31735 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
31736 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
31737 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
31738 & PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)-
31739 & PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+
31740 & 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+
31741 & LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+
31742 & LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS))
31743 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
31744 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
31745 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
31746 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)-
31747 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+
31748 & 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+
31749 & LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+
31750 & LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS))
31751 ELSE
31752 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
31753 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)-
31754 & PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2-
31755 & LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+
31756 & LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0))
31757 ENDIF
31758 F3IM=0D0
31759 ELSEIF(EPS.LT.1D0) THEN
31760 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
31761 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
31762 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
31763 & PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)-
31764 & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
31765 & (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
31766 & (0.25D0*(RAT+1D0)*EPS))
31767 F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
31768 & (0.25D0*(RAT+1D0)*EPS))
31769 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
31770 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
31771 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
31772 & PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)-
31773 & PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+
31774 & LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))*
31775 & LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
31776 F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
31777 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
31778 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
31779 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
31780 & PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)-
31781 & PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+
31782 & LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/
31783 & (1D0+0.25D0*RAT*EPS-GA))
31784 F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/
31785 & (1D0+0.25D0*RAT*EPS-GA))
31786 ELSE
31787 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
31788 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)-
31789 & PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))*
31790 & LOG((GA+BE-1D0)/(BE-GA))
31791 F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA))
31792 ENDIF
31793 ELSE
31794 RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2)
31795 RCTHE=RSQ*(1D0-2D0*BE/EPS)
31796 RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2))
31797 RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS)
31798 RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2))
31799 R=SQRT(RSQ)
31800 THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R)))
31801 PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R)))
31802 F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
31803 & PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
31804 & (PHI-THE)*(PHI+THE-PARU(1))
31805 F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
31806 & PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
31807 ENDIF
31808
31809 Y3RE=2D0/(2D0*BE-1D0)*F3RE
31810 Y3IM=2D0/(2D0*BE-1D0)*F3IM
31811
31812 RETURN
31813 END
31814
31815C***********************************************************************
31816
31817C...PYSPEN
31818C...Calculates real and imaginary part of Spence function; see
31819C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
31820
31821 FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
31822
31823C...Double precision and integer declarations.
31824 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31825 IMPLICIT INTEGER(I-N)
31826 INTEGER PYK,PYCHGE,PYCOMP
31827C...Commonblocks.
31828 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31829 SAVE /PYDAT1/
31830C...Local array and data.
31831 DIMENSION B(0:14)
31832 DATA B/
31833 &1.000000D+00, -5.000000D-01, 1.666667D-01,
31834 &0.000000D+00, -3.333333D-02, 0.000000D+00,
31835 &2.380952D-02, 0.000000D+00, -3.333333D-02,
31836 &0.000000D+00, 7.575757D-02, 0.000000D+00,
31837 &-2.531135D-01, 0.000000D+00, 1.166667D+00/
31838
31839 XRE=XREIN
31840 XIM=XIMIN
31841 IF(ABS(1D0-XRE).LT.1D-6.AND.ABS(XIM).LT.1D-6) THEN
31842 IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
31843 IF(IREIM.EQ.2) PYSPEN=0D0
31844 RETURN
31845 ENDIF
31846
31847 XMOD=SQRT(XRE**2+XIM**2)
31848 IF(XMOD.LT.1D-6) THEN
31849 IF(IREIM.EQ.1) PYSPEN=0D0
31850 IF(IREIM.EQ.2) PYSPEN=0D0
31851 RETURN
31852 ENDIF
31853
31854 XARG=SIGN(ACOS(XRE/XMOD),XIM)
31855 SP0RE=0D0
31856 SP0IM=0D0
31857 SGN=1D0
31858 IF(XMOD.GT.1D0) THEN
31859 ALGXRE=LOG(XMOD)
31860 ALGXIM=XARG-SIGN(PARU(1),XARG)
31861 SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
31862 SP0IM=-ALGXRE*ALGXIM
31863 SGN=-1D0
31864 XMOD=1D0/XMOD
31865 XARG=-XARG
31866 XRE=XMOD*COS(XARG)
31867 XIM=XMOD*SIN(XARG)
31868 ENDIF
31869 IF(XRE.GT.0.5D0) THEN
31870 ALGXRE=LOG(XMOD)
31871 ALGXIM=XARG
31872 XRE=1D0-XRE
31873 XIM=-XIM
31874 XMOD=SQRT(XRE**2+XIM**2)
31875 XARG=SIGN(ACOS(XRE/XMOD),XIM)
31876 ALGYRE=LOG(XMOD)
31877 ALGYIM=XARG
31878 SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
31879 SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
31880 SGN=-SGN
31881 ENDIF
31882
31883 XRE=1D0-XRE
31884 XIM=-XIM
31885 XMOD=SQRT(XRE**2+XIM**2)
31886 XARG=SIGN(ACOS(XRE/XMOD),XIM)
31887 ZRE=-LOG(XMOD)
31888 ZIM=-XARG
31889
31890 SPRE=0D0
31891 SPIM=0D0
31892 SAVERE=1D0
31893 SAVEIM=0D0
31894 DO 100 I=0,14
31895 IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
31896 TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
31897 TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
31898 SAVERE=TERMRE
31899 SAVEIM=TERMIM
31900 SPRE=SPRE+B(I)*TERMRE
31901 SPIM=SPIM+B(I)*TERMIM
31902 100 CONTINUE
31903
31904 110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
31905 IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
31906
31907 RETURN
31908 END
31909
31910C***********************************************************************
31911
31912C...PYQQBH
31913C...Calculates the matrix element for the processes
31914C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
31915C...REDUCE output and part of the rest courtesy Z. Kunszt, see
31916C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
31917
31918 SUBROUTINE PYQQBH(WTQQBH)
31919
31920C...Double precision and integer declarations.
31921 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31922 IMPLICIT INTEGER(I-N)
31923 INTEGER PYK,PYCHGE,PYCOMP
31924C...Commonblocks.
31925 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31926 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31927 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
31928 COMMON/PYINT1/MINT(400),VINT(400)
31929 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
31930 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/
31931C...Local arrays and function.
31932 DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8)
31933 DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)-
31934 &PP(I,3)*PP(J,3)
31935
31936C...Mass parameters.
31937 WTQQBH=0D0
31938 ISUB=MINT(1)
31939 SHPR=SQRT(VINT(26))*VINT(1)
31940 PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1)
31941 PH=SQRT(VINT(21))*VINT(1)
31942 SPQ=PQ**2
31943 SPH=PH**2
31944
31945C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
31946 DO 100 I=1,2
31947 PT=SQRT(MAX(0D0,VINT(197+5*I)))
31948 PP(I,1)=PT*COS(VINT(198+5*I))
31949 PP(I,2)=PT*SIN(VINT(198+5*I))
31950 100 CONTINUE
31951 PP(3,1)=-PP(1,1)-PP(2,1)
31952 PP(3,2)=-PP(1,2)-PP(2,2)
31953 PMS1=SPQ+PP(1,1)**2+PP(1,2)**2
31954 PMS2=SPQ+PP(2,1)**2+PP(2,2)**2
31955 PMS3=SPH+PP(3,1)**2+PP(3,2)**2
31956 PMT3=SQRT(PMS3)
31957 PP(3,3)=PMT3*SINH(VINT(211))
31958 PP(3,4)=PMT3*COSH(VINT(211))
31959 PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2
31960 PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
31961 &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12)
31962 PP(2,3)=-PP(1,3)-PP(3,3)
31963 PP(1,4)=SQRT(PMS1+PP(1,3)**2)
31964 PP(2,4)=SQRT(PMS2+PP(2,3)**2)
31965
31966C...Set up incoming kinematics and derived momentum combinations.
31967 DO 110 I=4,5
31968 PP(I,1)=0D0
31969 PP(I,2)=0D0
31970 PP(I,3)=-0.5D0*SHPR*(-1)**I
31971 PP(I,4)=-0.5D0*SHPR
31972 110 CONTINUE
31973 DO 120 J=1,4
31974 PP(6,J)=PP(1,J)+PP(2,J)
31975 PP(7,J)=PP(1,J)+PP(3,J)
31976 PP(8,J)=PP(1,J)+PP(4,J)
31977 PP(9,J)=PP(1,J)+PP(5,J)
31978 PP(10,J)=-PP(2,J)-PP(3,J)
31979 PP(11,J)=-PP(2,J)-PP(4,J)
31980 PP(12,J)=-PP(2,J)-PP(5,J)
31981 PP(13,J)=-PP(4,J)-PP(5,J)
31982 120 CONTINUE
31983
31984C...Derived kinematics invariants.
31985 X1=DOT(1,2)
31986 X2=DOT(1,3)
31987 X3=DOT(1,4)
31988 X4=DOT(1,5)
31989 X5=DOT(2,3)
31990 X6=DOT(2,4)
31991 X7=DOT(2,5)
31992 X8=DOT(3,4)
31993 X9=DOT(3,5)
31994 X10=DOT(4,5)
31995
31996C...Propagators.
31997 SS1=DOT(7,7)-SPQ
31998 SS2=DOT(8,8)-SPQ
31999 SS3=DOT(9,9)-SPQ
32000 SS4=DOT(10,10)-SPQ
32001 SS5=DOT(11,11)-SPQ
32002 SS6=DOT(12,12)-SPQ
32003 SS7=DOT(13,13)
32004 DX(1)=SS1*SS6
32005 DX(2)=SS2*SS6
32006 DX(3)=SS2*SS4
32007 DX(4)=SS1*SS5
32008 DX(5)=SS3*SS5
32009 DX(6)=SS3*SS4
32010 DX(7)=SS7*SS1
32011 DX(8)=SS7*SS4
32012
32013C...Define colour coefficients for g + g -> Q + Qbar + H.
32014 IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN
32015 DO 140 I=1,3
32016 DO 130 J=1,3
32017 CLR(I,J)=16D0/3D0
32018 CLR(I+3,J+3)=16D0/3D0
32019 CLR(I,J+3)=-2D0/3D0
32020 CLR(I+3,J)=-2D0/3D0
32021 130 CONTINUE
32022 140 CONTINUE
32023 DO 160 L=1,2
32024 DO 150 I=1,3
32025 CLR(I,6+L)=-6D0
32026 CLR(I+3,6+L)=6D0
32027 CLR(6+L,I)=-6D0
32028 CLR(6+L,I+3)=6D0
32029 150 CONTINUE
32030 160 CONTINUE
32031 DO 180 K1=1,2
32032 DO 170 K2=1,2
32033 CLR(6+K1,6+K2)=12D0
32034 170 CONTINUE
32035 180 CONTINUE
32036
32037C...Evaluate matrix elements for g + g -> Q + Qbar + H.
32038 FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2*
32039 & X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2*
32040 & X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7
32041 FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2
32042 & *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2*
32043 & X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+
32044 & X10)
32045 FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4*
32046 & X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10
32047 & +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
32048 & -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7
32049 & -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+
32050 & X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6)
32051 FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10-
32052 & X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6
32053 & )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+
32054 & 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2*
32055 & X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6)
32056 FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1*
32057 & X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1*
32058 & X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4
32059 & *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1**
32060 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4*
32061 & X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7
32062 & +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5-
32063 & X4*X6*X5)
32064 FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4-
32065 & X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3*
32066 & X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2
32067 & *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5
32068 & +X4*X9*X5+X4*X5**2)
32069 FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2*
32070 & PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1*
32071 & X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3*
32072 & X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7*
32073 & X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7-
32074 & X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5)
32075 FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2*
32076 & PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+
32077 & 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8*
32078 & X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6
32079 & +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8*
32080 & X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4*
32081 & X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2*
32082 & X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+
32083 & X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2)
32084 FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*(
32085 & X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7
32086 FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2
32087 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3*
32088 & X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+
32089 & X6)
32090 FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1*
32091 & X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1*
32092 & X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4
32093 & *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1
32094 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4
32095 & *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3*
32096 & X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6*
32097 & X5+X4*X6*X5)
32098 FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1
32099 & *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3-
32100 & 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4-
32101 & X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1*
32102 & X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3
32103 & *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4*
32104 & X6**2)
32105 FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1*
32106 & X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1*
32107 & X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4*
32108 & X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1**
32109 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4*
32110 & X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7
32111 & -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5-
32112 & X4*X6*X5)
32113 FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
32114 & 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
32115 & X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3*
32116 & X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2
32117 & *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5
32118 & +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
32119 & -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1*
32120 & X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1*
32121 & X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3*
32122 & X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3
32123 & *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5)
32124 FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
32125 & 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
32126 & X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2*
32127 & X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4
32128 & *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5-
32129 & X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
32130 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9-
32131 & X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9
32132 & *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10*
32133 & X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3*
32134 & X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5)
32135 FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6
32136 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3*
32137 & X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5
32138 FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3-
32139 & X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3*
32140 & X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2
32141 & *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5
32142 & +X3*X8*X5+X3*X5**2)
32143 FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1*
32144 & X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1*
32145 & X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3
32146 & *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1
32147 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3
32148 & *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3*
32149 & X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7*
32150 & X5+X4*X6*X5)
32151 FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+
32152 & X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6
32153 & )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2*
32154 & X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2*
32155 & X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10)
32156 FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2*
32157 & PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4*
32158 & X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+
32159 & X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4*
32160 & X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+
32161 & X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3*
32162 & X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2
32163 & *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7
32164 & +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5)
32165 FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2*
32166 & PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+
32167 & 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7
32168 & +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9*
32169 & X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4
32170 & *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8)
32171 FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2*
32172 & X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2*
32173 & X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6
32174 FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4
32175 & *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+
32176 & X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+
32177 & X10)
32178 FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2*
32179 & X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10
32180 & +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
32181 & -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7
32182 & -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+
32183 & X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7)
32184 FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2
32185 & *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1*
32186 & X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3*
32187 & X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7*
32188 & X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2*
32189 & X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5)
32190 FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2
32191 & *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9
32192 & +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4
32193 & *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4*
32194 & X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2
32195 & *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3
32196 & *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2
32197 & *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9*
32198 & X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2)
32199 FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*(
32200 & X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6
32201 FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2
32202 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4*
32203 & X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+
32204 & X7)
32205 FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
32206 & 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
32207 & X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+
32208 & 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+
32209 & 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+
32210 & 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(-
32211 & X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3
32212 & *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10*
32213 & X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2*
32214 & X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4
32215 & *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5)
32216 FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
32217 & 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
32218 & X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+
32219 & 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2*
32220 & X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+
32221 & 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(
32222 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3*
32223 & X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9
32224 & *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10*
32225 & X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+
32226 & X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5)
32227 FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7
32228 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4*
32229 & X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5
32230 FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2
32231 & *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4
32232 & -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9
32233 & -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+
32234 & 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9
32235 & *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4
32236 & *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2
32237 & **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+
32238 & 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5)
32239 FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2
32240 & *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*
32241 & X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12*
32242 & X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9
32243 & *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2*
32244 & X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8)
32245 FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9*
32246 & X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7*
32247 & X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2
32248 & *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8
32249 & *X6)
32250 FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+
32251 & 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4*
32252 & X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9*
32253 & X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3*
32254 & X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2
32255 & +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+
32256 & 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5)
32257 FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2
32258 & *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4
32259 & *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2*
32260 & X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4*
32261 & X8)
32262 FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
32263 & X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6
32264 & )+2*X2*(-X10*X5+X9*X6+X8*X7)
32265 FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
32266 & X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2
32267 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3*
32268 & X9*X5)
32269 FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
32270 & X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2
32271 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4*
32272 & X8*X5)
32273 FM(9,10)=0.5D0*(FMXX+FM(9,10))
32274 FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
32275 & X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6
32276 & )+2*X5*(-X10*X2+X9*X3+X8*X4)
32277
32278C...Repackage matrix elements.
32279 DO 200 I=1,8
32280 DO 190 J=1,8
32281 RM(I,J)=FM(I,J)
32282 190 CONTINUE
32283 200 CONTINUE
32284 RM(7,7)=FM(7,7)-2D0*FM(9,9)
32285 RM(7,8)=FM(7,8)-2D0*FM(9,10)
32286 RM(8,8)=FM(8,8)-2D0*FM(10,10)
32287
32288C...Produce final result: matrix elements * colours * propagators.
32289 DO 220 I=1,8
32290 DO 210 J=I,8
32291 FAC=8D0
32292 IF(I.EQ.J)FAC=4D0
32293 WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J))
32294 210 CONTINUE
32295 220 CONTINUE
32296 WTQQBH=-WTQQBH/256D0
32297
32298 ELSE
32299C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
32300 A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3
32301 & *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9
32302 & *X6+X8*X7)
32303 A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8-
32304 & 2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7
32305 & +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8*
32306 & X5)
32307 A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3*
32308 & X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3
32309 & *X9+X4*X8)
32310
32311C...Produce final result: matrix elements * propagators.
32312 A11=A11/DX(7)**2
32313 A12=A12/(DX(7)*DX(8))
32314 A22=A22/DX(8)**2
32315 WTQQBH=-(A11+A22+2D0*A12)*8D0/9D0
32316 ENDIF
32317
32318 RETURN
32319 END
32320
32321C*********************************************************************
32322
32323C...PYMSIN
32324C...Initializes supersymmetry: finds sparticle masses and
32325C...branching ratios and stores this information.
32326C...AUTHOR: STEPHEN MRENNA
32327C...Baryon- and lepton-number violating parameters by P. Z. Skands.
32328
32329 SUBROUTINE PYMSIN
32330
32331C...Double precision and integer declarations.
32332 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32333 IMPLICIT INTEGER(I-N)
32334 INTEGER PYK,PYCHGE,PYCOMP
32335C...Parameter statement to help give large particle numbers.
32336 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
32337 &KEXCIT=4000000,KDIMEN=5000000)
32338C...Commonblocks.
32339 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32340 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32341 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
32342 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
32343 COMMON/PYINT4/MWID(500),WIDS(500,5)
32344 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
32345 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
32346 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
32347 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
32348 COMMON/PYHTRI/HHH(7)
32349 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT4/,/PYMSSM/,
32350 &/PYMSRV/,/PYSSMT/
32351
32352C...Local variables.
32353 DOUBLE PRECISION ALFA,BETA
32354 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
32355 INTEGER I,J,J1,I1,K1
32356 INTEGER KC,LKNT,IDLAM(400,3)
32357 DOUBLE PRECISION XLAM(0:400)
32358 DOUBLE PRECISION WDTP(0:400),WDTE(0:400,0:5)
32359 DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
32360 DOUBLE PRECISION DELM,XMDIF
32361 DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
32362 DOUBLE PRECISION ARG,SGNMU,R
32363 INTEGER IMSSM
32364 INTEGER IRPRTY
32365 INTEGER KFSUSY(36),MWIDSU(36),MDCYSU(36)
32366 SAVE MWIDSU,MDCYSU
32367 DATA KFSUSY/
32368 &1000001,2000001,1000002,2000002,1000003,2000003,
32369 &1000004,2000004,1000005,2000005,1000006,2000006,
32370 &1000011,2000011,1000012,2000012,1000013,2000013,
32371 &1000014,2000014,1000015,2000015,1000016,2000016,
32372 &1000021,1000022,1000023,1000025,1000035,1000024,
32373 &1000037,1000039, 25, 35, 36, 37/
32374 DATA INIT/0/
32375
32376C...Do nothing if SUSY not requested.
32377 IMSSM=IMSS(1)
32378 IF(IMSSM.EQ.0) RETURN
32379
32380C...Save copy of MWID(KC) and MDCY(KC,1) values before
32381C...they are set to zero for the LSP.
32382 IF(INIT.EQ.0) THEN
32383 INIT=1
32384 DO 100 I=1,36
32385 KF=KFSUSY(I)
32386 KC=PYCOMP(KF)
32387 MWIDSU(I)=MWID(KC)
32388 MDCYSU(I)=MDCY(KC,1)
32389 100 CONTINUE
32390 ENDIF
32391
32392C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP.
32393 DO 110 I=1,36
32394 KF=KFSUSY(I)
32395 KC=PYCOMP(KF)
32396 IF(MDCY(KC,1).EQ.0.AND.MDCYSU(I).NE.0) THEN
32397 MWID(KC)=MWIDSU(I)
32398 MDCY(KC,1)=MDCYSU(I)
32399 ENDIF
32400 110 CONTINUE
32401
32402C...First part of routine: set masses and couplings.
32403
32404C...Reset mixing values in sfermion sector to pure left/right.
32405 DO 120 I=1,16
32406 SFMIX(I,1)=1D0
32407 SFMIX(I,4)=1D0
32408 SFMIX(I,2)=0D0
32409 SFMIX(I,3)=0D0
32410 120 CONTINUE
32411
32412C...Common couplings.
32413 TANB=RMSS(5)
32414 BETA=ATAN(TANB)
32415 COSB=COS(BETA)
32416 SINB=TANB*COSB
32417 COS2B=COS(2D0*BETA)
32418 ALFA=RMSS(18)
32419 XMW2=PMAS(24,1)**2
32420 XMZ2=PMAS(23,1)**2
32421 XW=PARU(102)
32422
32423C...Define sparticle masses for a general MSSM simulation.
32424 IF(IMSSM.EQ.1) THEN
32425 IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9)
32426 DO 130 I=1,5,2
32427 KC=PYCOMP(KSUSY1+I)
32428 PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0)
32429 KC=PYCOMP(KSUSY2+I)
32430 PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0)
32431 KC=PYCOMP(KSUSY1+I+1)
32432 PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0)
32433 KC=PYCOMP(KSUSY2+I+1)
32434 PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0)
32435 130 CONTINUE
32436 XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA))
32437 IF(XARG.LT.0D0) THEN
32438 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
32439 & ' FROM THE SUM RULE. '
32440 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
32441 RETURN
32442 ELSE
32443 XARG=SQRT(XARG)
32444 ENDIF
32445 DO 140 I=11,15,2
32446 PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6)
32447 PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7)
32448 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
32449 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
32450 140 CONTINUE
32451 IF(IMSS(8).EQ.1) THEN
32452 RMSS(13)=RMSS(6)
32453 RMSS(14)=RMSS(7)
32454 ENDIF
32455
32456C...Alternatively derive masses from SUGRA relations.
32457 ELSEIF(IMSSM.EQ.2) THEN
32458 CALL PYAPPS
32459C...Or use ISASUSY
32460 ELSEIF(IMSSM.EQ.12) THEN
32461 CALL PYSUGI
32462 ALFA=RMSS(18)
32463 GOTO 170
32464 ENDIF
32465
32466C...Add in extra D-term contributions.
32467 IF(IMSS(7).EQ.1) THEN
32468 R=0.43D0
32469 DX=RMSS(23)
32470 DY=RMSS(24)
32471 DS=RMSS(25)
32472 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
32473 WRITE(MSTU(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
32474 WRITE(MSTU(11),*) 'C IN A U(B-L) THEORY '
32475 WRITE(MSTU(11),*) 'C DX = ',DX
32476 WRITE(MSTU(11),*) 'C DY = ',DY
32477 WRITE(MSTU(11),*) 'C DS = ',DS
32478 WRITE(MSTU(11),*) 'C '
32479 DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS
32480 WRITE(MSTU(11),*) 'C DY AT THE WEAK SCALE = ',DY
32481 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
32482 DQ2=DY/6D0-DX/3D0-DS/3D0
32483 DU2=-2D0*DY/3D0-DX/3D0-DS/3D0
32484 DD2=DY/3D0+DX-2D0*DS/3D0
32485 DL2=-DY/2D0+DX-2D0*DS/3D0
32486 DE2=DY-DX/3D0-DS/3D0
32487 DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0
32488 DHD2=-DY/2D0-2D0*DX/3D0+DS
32489 DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS)
32490 & /ABS(COS2B)
32491 DMA2 = 2D0*DMU2+DHU2+DHD2
32492 DO 150 I=1,5,2
32493 KC=PYCOMP(KSUSY1+I)
32494 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
32495 KC=PYCOMP(KSUSY2+I)
32496 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2)
32497 KC=PYCOMP(KSUSY1+I+1)
32498 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
32499 KC=PYCOMP(KSUSY2+I+1)
32500 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2)
32501 150 CONTINUE
32502 DO 160 I=11,15,2
32503 KC=PYCOMP(KSUSY1+I)
32504 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
32505 KC=PYCOMP(KSUSY2+I)
32506 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2)
32507 KC=PYCOMP(KSUSY1+I+1)
32508 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
32509 160 CONTINUE
32510 IF(RMSS(4)**2+DMU2.LT.0D0) THEN
32511 WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE '
32512 STOP
32513 ENDIF
32514 SGNMU=SIGN(1D0,RMSS(4))
32515 RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2)
32516 ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2
32517 RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
32518 ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2
32519 RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
32520 ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2
32521 RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
32522 ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2
32523 RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
32524 ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2
32525 RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG)
32526 IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN
32527 WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW '
32528 STOP
32529 ENDIF
32530 RMSS(19)=SQRT(RMSS(19)**2+DMA2)
32531 RMSS(6)=SQRT(RMSS(6)**2+DL2)
32532 RMSS(7)=SQRT(RMSS(7)**2+DE2)
32533 WRITE(MSTU(11),*) ' MTL = ',RMSS(10)
32534 WRITE(MSTU(11),*) ' MBR = ',RMSS(11)
32535 WRITE(MSTU(11),*) ' MTR = ',RMSS(12)
32536 WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13)
32537 WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14)
32538 ENDIF
32539
32540C...Fix the third generation sfermions.
32541 CALL PYTHRG
32542
32543C...Fix the neutralino--chargino--gluino sector.
32544 CALL PYINOM
32545
32546C...Fix the Higgs sector.
32547 CALL PYHGGM(ALFA)
32548
32549C...Choose the Gunion-Haber convention.
32550 ALFA=-ALFA
32551 RMSS(18)=ALFA
32552
32553C...Print information on mass parameters.
32554 IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN
32555 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
32556 WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
32557 WRITE(MSTU(11),*) ' M0 = ',RMSS(8)
32558 WRITE(MSTU(11),*) ' M1/2=',RMSS(1)
32559 WRITE(MSTU(11),*) ' TANB=',RMSS(5)
32560 WRITE(MSTU(11),*) ' MU = ',RMSS(4)
32561 WRITE(MSTU(11),*) ' AT = ',RMSS(16)
32562 WRITE(MSTU(11),*) ' MA = ',RMSS(19)
32563 WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1)
32564 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
32565 ENDIF
32566 IF(IMSS(20).EQ.1) THEN
32567 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
32568 WRITE(MSTU(11),*) ' DEBUG MODE '
32569 WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2),
32570 & UMIX(2,1),UMIX(2,2)
32571 WRITE(MSTU(11),*) ' UMIXI = ',UMIXI(1,1),UMIXI(1,2),
32572 & UMIXI(2,1),UMIXI(2,2)
32573 WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2),
32574 & VMIX(2,1),VMIX(2,2)
32575 WRITE(MSTU(11),*) ' VMIXI = ',VMIXI(1,1),VMIXI(1,2),
32576 & VMIXI(2,1),VMIXI(2,2)
32577 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(1,I),I=1,4)
32578 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(1,I),I=1,4)
32579 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(2,I),I=1,4)
32580 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(2,I),I=1,4)
32581 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(3,I),I=1,4)
32582 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(3,I),I=1,4)
32583 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(4,I),I=1,4)
32584 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(4,I),I=1,4)
32585 WRITE(MSTU(11),*) ' ALFA = ',ALFA
32586 WRITE(MSTU(11),*) ' BETA = ',BETA
32587 WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4)
32588 WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4)
32589 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
32590 ENDIF
32591
32592C...Set up the Higgs couplings - needed here since initialization
32593C...in PYINRE did not yet occur when PYWIDT is called below.
32594 170 AL=ALFA
32595 BE=BETA
32596 SINA=SIN(AL)
32597 COSA=COS(AL)
32598 COSB=COS(BE)
32599 SINB=TANB*COSB
32600 SBMA=SIN(BE-AL)
32601 SAPB=SIN(AL+BE)
32602 CAPB=COS(AL+BE)
32603 CBMA=COS(BE-AL)
32604 C2A=COS(2D0*AL)
32605 C2B=COSB**2-SINB**2
32606C...tanb (used for H+)
32607 PARU(141)=TANB
32608
32609C...Firstly: h
32610C...Coupling to d-type quarks
32611 PARU(161)=SINA/COSB
32612C...Coupling to u-type quarks
32613 PARU(162)=-COSA/SINB
32614C...Coupling to leptons
32615 PARU(163)=PARU(161)
32616C...Coupling to Z
32617 PARU(164)=SBMA
32618C...Coupling to W
32619 PARU(165)=PARU(164)
32620
32621C...Secondly: H
32622C...Coupling to d-type quarks
32623 PARU(171)=-COSA/COSB
32624C...Coupling to u-type quarks
32625 PARU(172)=-SINA/SINB
32626C...Coupling to leptons
32627 PARU(173)=PARU(171)
32628C...Coupling to Z
32629 PARU(174)=CBMA
32630C...Coupling to W
32631 PARU(175)=PARU(174)
32632C...Coupling to h
32633 IF(IMSS(4).EQ.2) THEN
32634 PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
32635 ELSE
32636 HHH(3)=HHH(3)+HHH(4)+HHH(5)
32637 PARU(176)=-3D0/HHH(1)*(HHH(1)*SINA**2*COSB*COSA+
32638 1 HHH(2)*COSA**2*SINB*SINA+HHH(3)*(SINA**3*SINB+COSA**3*COSB-
32639 2 2D0/3D0*CBMA)-HHH(6)*SINA*(COSB*C2A+COSA*CAPB)+
32640 3 HHH(7)*COSA*(SINB*C2A+SINA*CAPB))
32641 ENDIF
32642C...Coupling to H+
32643C...Define later
32644 IF(IMSS(4).EQ.2) THEN
32645 PARU(168)=-SBMA-COS(2D0*BE)*SAPB/2D0/(1D0-XW)
32646 ELSE
32647 PARU(168)=1D0/HHH(1)*(HHH(1)*SINB**2*COSB*SINA-
32648 1 HHH(2)*COSB**2*SINB*COSA-HHH(3)*(SINB**3*COSA-COSB**3*SINA)+
32649 2 2D0*HHH(5)*SBMA-HHH(6)*SINB*(COSB*SAPB+SINA*C2B)-
32650 3 HHH(7)*COSB*(COSA*C2B-SINB*SAPB)-(HHH(5)-HHH(4))*SBMA)
32651 ENDIF
32652C...Coupling to A
32653 IF(IMSS(4).EQ.2) THEN
32654 PARU(177)=COS(2D0*BE)*COS(BE+AL)
32655 ELSE
32656 PARU(177)=-1D0/HHH(1)*(HHH(1)*SINB**2*COSB*COSA+
32657 1 HHH(2)*COSB**2*SINB*SINA+HHH(3)*(SINB**3*SINA+COSB**3*COSA)-
32658 2 2D0*HHH(5)*CBMA-HHH(6)*SINB*(COSB*CAPB+COSA*C2B)+
32659 3 HHH(7)*COSB*(SINB*CAPB+SINA*C2B))
32660 ENDIF
32661C...Coupling to H+
32662 IF(IMSS(4).EQ.2) THEN
32663 PARU(178)=PARU(177)
32664 ELSE
32665 PARU(178)=PARU(177)-(HHH(5)-HHH(4))/HHH(1)*CBMA
32666 ENDIF
32667C...Thirdly, A
32668C...Coupling to d-type quarks
32669 PARU(181)=TANB
32670C...Coupling to u-type quarks
32671 PARU(182)=1D0/PARU(181)
32672C...Coupling to leptons
32673 PARU(183)=PARU(181)
32674 PARU(184)=0D0
32675 PARU(185)=0D0
32676C...Coupling to Z h
32677 PARU(186)=COS(BE-AL)
32678C...Coupling to Z H
32679 PARU(187)=SIN(BE-AL)
32680 PARU(188)=0D0
32681 PARU(189)=0D0
32682 PARU(190)=0D0
32683
32684C...Finally: H+
32685C...Coupling to W h
32686 PARU(195)=COS(BE-AL)
32687
32688C...Tell that all Higgs couplings have been set.
32689 MSTP(4)=1
32690
32691C...Set R-Violating couplings.
32692C...Set lambda couplings to common value or "natural values".
32693 IF ((IMSS(51).NE.3).AND.(IMSS(51).NE.0)) THEN
32694 VIR3=1D0/(126D0)**3
32695 DO 200 IRK=1,3
32696 DO 190 IRI=1,3
32697 DO 180 IRJ=1,3
32698 IF (IRI.NE.IRJ) THEN
32699 IF (IRI.LT.IRJ) THEN
32700 RVLAM(IRI,IRJ,IRK)=RMSS(51)
32701 IF (IMSS(51).EQ.2) RVLAM(IRI,IRJ,IRK)=RMSS(51)*
32702 & SQRT(PMAS(9+2*IRI,1)*PMAS(9+2*IRJ,1)*
32703 & PMAS(9+2*IRK,1)*VIR3)
32704 ELSE
32705 RVLAM(IRI,IRJ,IRK)=-RVLAM(IRJ,IRI,IRK)
32706 ENDIF
32707 ELSE
32708 RVLAM(IRI,IRJ,IRK)=0D0
32709 ENDIF
32710 180 CONTINUE
32711 190 CONTINUE
32712 200 CONTINUE
32713 ENDIF
32714C...Set lambda' couplings to common value or "natural values".
32715 IF ((IMSS(52).NE.3).AND.(IMSS(52).NE.0)) THEN
32716 VIR3=1D0/(126D0)**3
32717 DO 230 IRI=1,3
32718 DO 220 IRJ=1,3
32719 DO 210 IRK=1,3
32720 RVLAMP(IRI,IRJ,IRK)=RMSS(52)
32721 IF (IMSS(52).EQ.2) RVLAMP(IRI,IRJ,IRK)=RMSS(52)*
32722 & SQRT(PMAS(9+2*IRI,1)*0.5D0*(PMAS(2*IRJ,1)+
32723 & PMAS(2*IRJ-1,1))*PMAS(2*IRK-1,1)*VIR3)
32724 210 CONTINUE
32725 220 CONTINUE
32726 230 CONTINUE
32727 ENDIF
32728C...Set lambda'' couplings to common value or "natural values".
32729 IF ((IMSS(53).NE.3).AND.(IMSS(53).NE.0)) THEN
32730 VIR3=1D0/(126D0)**3
32731 DO 260 IRI=1,3
32732 DO 250 IRJ=1,3
32733 DO 240 IRK=1,3
32734 IF (IRJ.NE.IRK) THEN
32735 IF (IRJ.LT.IRK) THEN
32736 RVLAMB(IRI,IRJ,IRK)=RMSS(53)
32737 IF (IMSS(53).EQ.2) RVLAMB(IRI,IRJ,IRK)=
32738 & RMSS(53)*SQRT(PMAS(2*IRI,1)*PMAS(2*IRJ-1,1)*
32739 & PMAS(2*IRK-1,1)*VIR3)
32740 ELSE
32741 RVLAMB(IRI,IRJ,IRK)=-RVLAMB(IRI,IRK,IRJ)
32742 ENDIF
32743 ELSE
32744 RVLAMB(IRI,IRJ,IRK) = 0D0
32745 ENDIF
32746 240 CONTINUE
32747 250 CONTINUE
32748 260 CONTINUE
32749 ENDIF
32750
32751C...Antisymmetrize couplings set by user
32752 IF (IMSS(51).EQ.3.OR.IMSS(53).EQ.3) THEN
32753 DO 290 IRI=1,3
32754 DO 280 IRJ=1,3
32755 DO 270 IRK=1,3
32756 IF (RVLAM(IRI,IRJ,IRK).NE.-RVLAM(IRJ,IRI,IRK)) THEN
32757 RVLAM(IRJ,IRI,IRK)=-RVLAM(IRI,IRJ,IRK)
32758 IF (IRI.EQ.IRJ) RVLAM(IRI,IRJ,IRK)=0D0
32759 ENDIF
32760 IF (RVLAMB(IRI,IRJ,IRK).NE.-RVLAMB(IRI,IRK,IRJ)) THEN
32761 RVLAMB(IRI,IRK,IRJ)=-RVLAMB(IRI,IRJ,IRK)
32762 IF (IRJ.EQ.IRK) RVLAMB(IRI,IRJ,IRK)=0D0
32763 ENDIF
32764 270 CONTINUE
32765 280 CONTINUE
32766 290 CONTINUE
32767 ENDIF
32768
32769C...Second part of routine: set decay modes and branching ratios.
32770
32771C...Allow chi10 -> gravitino + gamma or not.
32772 KC=PYCOMP(KSUSY1+39)
32773 IF( IMSS(11) .NE. 0 ) THEN
32774 PMAS(KC,1)=RMSS(21)/1000000000D0
32775 PMAS(KC,2)=0.0001D0
32776 IRPRTY=0
32777 WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
32778 ELSE IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
32779 IRPRTY=0
32780 IF (IMSS(51).GE.1) WRITE(MSTU(11),*)
32781 & ' ALLOWING SUSY LLE DECAYS'
32782 IF (IMSS(52).GE.1) WRITE(MSTU(11),*)
32783 & ' ALLOWING SUSY LQD DECAYS'
32784 IF (IMSS(53).GE.1) WRITE(MSTU(11),*)
32785 & ' ALLOWING SUSY UDD DECAYS'
32786 IF (IMSS(53).GE.1.AND.IMSS(52).GE.1) WRITE(MSTU(11),*)
32787 & ' --- Warning: R-Violating couplings possibly',
32788 & ' incompatible with proton decay'
32789 ELSE
32790 PMAS(KC,1)=9999D0
32791 IRPRTY=1
32792 ENDIF
32793
32794C...Loop over sparticle and Higgs species.
32795 PMCHI1=PMAS(PYCOMP(KSUSY1+22),1)
32796C...Find the LSP or NLSP for a gravitino LSP
32797 ILSP=0
32798 PMLSP=1D20
32799 DO 300 I=1,36
32800 KF=KFSUSY(I)
32801 IF(KF.EQ.1000039) GOTO 300
32802 KC=PYCOMP(KF)
32803 IF(PMAS(KC,1).LT.PMLSP) THEN
32804 ILSP=I
32805 PMLSP=PMAS(KC,1)
32806 ENDIF
32807 300 CONTINUE
32808 DO 370 I=1,36
32809 KF=KFSUSY(I)
32810 KC=PYCOMP(KF)
32811 LKNT=0
32812
32813C...Sfermion decays.
32814 IF(I.LE.24) THEN
32815C...First check to see if sneutrino is lighter than chi10.
32816 IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND.
32817 & PMAS(KC,1).LT.PMCHI1) THEN
32818 ELSE
32819 CALL PYSFDC(KF,XLAM,IDLAM,LKNT)
32820 ENDIF
32821
32822C...Gluino decays.
32823 ELSEIF(I.EQ.25) THEN
32824 CALL PYGLUI(KF,XLAM,IDLAM,LKNT)
32825 IF(I.EQ.ILSP.AND.IRPRTY.EQ.1) LKNT=0
32826
32827C...Neutralino decays.
32828 ELSEIF(I.GE.26.AND.I.LE.29) THEN
32829 CALL PYNJDC(KF,XLAM,IDLAM,LKNT)
32830C...chi10 stable or chi10 -> gravitino + gamma.
32831 IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN
32832 PMAS(KC,2)=1D-6
32833 MDCY(KC,1)=0
32834 MWID(KC)=0
32835 ENDIF
32836
32837C...Chargino decays.
32838 ELSEIF(I.GE.30.AND.I.LE.31) THEN
32839 CALL PYCJDC(KF,XLAM,IDLAM,LKNT)
32840
32841C...Gravitino is stable.
32842 ELSEIF(I.EQ.32) THEN
32843 MDCY(KC,1)=0
32844 MWID(KC)=0
32845
32846C...Higgs decays.
32847 ELSEIF(I.GE.33.AND.I.LE.36) THEN
32848C...Calculate decays to non-SUSY particles.
32849 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
32850 LKNT=0
32851 DO 310 I1=0,100
32852 XLAM(I1)=0D0
32853 310 CONTINUE
32854 DO 330 I1=1,MDCY(KC,3)
32855 K1=MDCY(KC,2)+I1-1
32856 IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR.
32857 & IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 330
32858 XLAM(I1)=WDTP(I1)
32859 XLAM(0)=XLAM(0)+XLAM(I1)
32860 DO 320 J1=1,3
32861 IDLAM(I1,J1)=KFDP(K1,J1)
32862 320 CONTINUE
32863 LKNT=LKNT+1
32864 330 CONTINUE
32865C...Add the decays to SUSY particles.
32866 CALL PYHEXT(KF,XLAM,IDLAM,LKNT)
32867 ENDIF
32868C...Zero the branching ratios for use in loop mode
32869C...thanks to K. Matchev (FNAL)
32870 DO 340 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
32871 BRAT(IDC)=0D0
32872 340 CONTINUE
32873
32874C...Set stable particles.
32875 IF(LKNT.EQ.0) THEN
32876 MDCY(KC,1)=0
32877 MWID(KC)=0
32878 PMAS(KC,2)=1D-6
32879 PMAS(KC,3)=1D-5
32880 PMAS(KC,4)=0D0
32881
32882C...Store branching ratios in the standard tables.
32883 ELSE
32884 IDC=MDCY(KC,2)+MDCY(KC,3)-1
32885 DELM=1D6
32886 DO 360 IL=1,LKNT
32887 IDCSV=IDC
32888 350 IDC=IDC+1
32889 BRAT(IDC)=0D0
32890 IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2)
32891 IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ.
32892 & KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN
32893 BRAT(IDC)=XLAM(IL)/XLAM(0)
32894 XMDIF=PMAS(KC,1)
32895 IF(MDME(IDC,1).GE.1) THEN
32896 XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)-
32897 & PMAS(PYCOMP(KFDP(IDC,2)),1)
32898 IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF-
32899 & PMAS(PYCOMP(KFDP(IDC,3)),1)
32900 ENDIF
32901 IF(I.LE.32) THEN
32902 IF(XMDIF.GE.0D0) THEN
32903 DELM=MIN(DELM,XMDIF)
32904 ELSE
32905 WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF
32906 WRITE(MSTU(11),*) ' KF = ',KF
32907 WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3)
32908 ENDIF
32909 ENDIF
32910 GOTO 360
32911 ELSEIF(IDC.EQ.IDCSV) THEN
32912 WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ',
32913 & 'channel not recognized:'
32914 WRITE(MSTU(11),*) KF,' -> ',(IDLAM(I,J),J=1,3)
32915 GOTO 360
32916 ELSE
32917 GOTO 350
32918 ENDIF
32919 360 CONTINUE
32920
32921C...Store width, cutoff and lifetime.
32922 PMAS(KC,2)=XLAM(0)
32923 IF(PMAS(KC,2).LT.0.1D0*DELM) THEN
32924 PMAS(KC,3)=PMAS(KC,2)*10D0
32925 ELSE
32926 PMAS(KC,3)=0.95D0*DELM
32927 ENDIF
32928 IF(PMAS(KC,2).NE.0D0) THEN
32929 PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12
32930 ENDIF
32931 ENDIF
32932 370 CONTINUE
32933
32934 RETURN
32935 END
32936
32937C*********************************************************************
32938
32939C...PYAPPS
32940C...Uses approximate analytical formulae to determine the full set of
32941C...MSSM parameters from SUGRA input.
32942C...See M. Drees and S.P. Martin, hep-ph/9504124
32943
32944 SUBROUTINE PYAPPS
32945
32946C...Double precision and integer declarations.
32947 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32948 IMPLICIT INTEGER(I-N)
32949 INTEGER PYK,PYCHGE,PYCOMP
32950C...Parameter statement to help give large particle numbers.
32951 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
32952 &KEXCIT=4000000,KDIMEN=5000000)
32953C...Commonblocks.
32954 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32955 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32956 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
32957 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/
32958
32959 IMSS(5)=0
32960 IMSS(8)=0
32961 XMT=PMAS(6,1)
32962 XMZ2=PMAS(23,1)**2
32963 XMW2=PMAS(24,1)**2
32964 TANB=RMSS(5)
32965 BETA=ATAN(TANB)
32966 XW=PARU(102)
32967 XMG=RMSS(1)
32968 XMG2=XMG*XMG
32969 XM0=RMSS(8)
32970 XM02=XM0*XM0
32971 AT=-RMSS(16)
32972 RMSS(15)=AT
32973 RMSS(17)=AT
32974 SINB=TANB/SQRT(TANB**2+1D0)
32975 COSB=SINB/TANB
32976
32977 DTERM=XMZ2*COS(2D0*BETA)
32978 XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM)
32979 XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM)
32980 RMSS(6)=XMEL
32981 RMSS(7)=XMER
32982 XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM))
32983 XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM))
32984 XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM))
32985 XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM))
32986 DO 100 I=1,5,2
32987 PMAS(PYCOMP(KSUSY1+I),1)=XMDL
32988 PMAS(PYCOMP(KSUSY2+I),1)=XMDR
32989 PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL
32990 PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR
32991 100 CONTINUE
32992 XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA))
32993 IF(XARG.LT.0D0) THEN
32994 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
32995 & ' FROM THE SUM RULE. '
32996 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
32997 RETURN
32998 ELSE
32999 XARG=SQRT(XARG)
33000 ENDIF
33001 DO 110 I=11,15,2
33002 PMAS(PYCOMP(KSUSY1+I),1)=XMEL
33003 PMAS(PYCOMP(KSUSY2+I),1)=XMER
33004 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
33005 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
33006 110 CONTINUE
33007 RMT=PYMRUN(6,PMAS(6,1)**2)
33008 XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+
33009 &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG))
33010 RMB=PYMRUN(5,PMAS(6,1)**2)
33011 XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+
33012 &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG))
33013 XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0)
33014 ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/
33015 &SINB)**2)
33016 RMSS(16)=-ATP
33017 XMU2=-.5D0*XMZ2+(SINB**2*(XM02+.52D0*XMG2-XTOP)-
33018 &COSB**2*(XM02+.52D0*XMG2-XBOT-XTAU/3D0))/(COSB**2-SINB**2)
33019 XMA2=2D0*(XM02+.52D0*XMG2+XMU2)-XTOP-XBOT-XTAU/3D0
33020 XMU=SIGN(SQRT(XMU2),RMSS(4))
33021 RMSS(4)=XMU
33022 IF(XMA2.GT.0D0) THEN
33023 RMSS(19)=SQRT(XMA2)
33024 ELSE
33025 WRITE(MSTU(11),*) ' PYAPPS:: PSEUDOSCALAR MASS**2 < 0 '
33026 STOP
33027 ENDIF
33028 ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM
33029 IF(ARG.GT.0D0) THEN
33030 RMSS(14)=SQRT(ARG)
33031 ELSE
33032 WRITE(MSTU(11),*) ' PYAPPS:: RIGHT STAU MASS**2 < 0 '
33033 STOP
33034 ENDIF
33035 ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM
33036 IF(ARG.GT.0D0) THEN
33037 RMSS(13)=SQRT(ARG)
33038 ELSE
33039 WRITE(MSTU(11),*) ' PYAPPS:: LEFT STAU MASS**2 < 0 '
33040 STOP
33041 ENDIF
33042 ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0)
33043 IF(ARG.GT.0D0) THEN
33044 RMSS(10)=SQRT(ARG)
33045 ELSE
33046 RMSS(10)=-SQRT(-ARG)
33047 ENDIF
33048 ARG=PYRNMQ(2,-2D0*XTOP/3D0)
33049 IF(ARG.GT.0D0) THEN
33050 RMSS(12)=SQRT(ARG)
33051 ELSE
33052 RMSS(12)=-SQRT(-ARG)
33053 ENDIF
33054 ARG=PYRNMQ(3,-2D0*XBOT/3D0)
33055 IF(ARG.GT.0D0) THEN
33056 RMSS(11)=SQRT(ARG)
33057 ELSE
33058 RMSS(11)=-SQRT(-ARG)
33059 ENDIF
33060
33061 RETURN
33062 END
33063
33064C*********************************************************************
33065
33066C...PYSUGI
33067C...Interface to ISASUSY version 7.61.
33068C...Warning: if you use earlier versions, change dimension to
33069C...SUPER(66) in /SSPAR/ and remove MHPNEG and ASM3 from /SUGPAS/.
33070C...Calls SUGRA (in ISAJET) to perform RGE evolution.
33071C...Then converts to Gunion-Haber conventions.
33072
33073 SUBROUTINE PYSUGI
33074 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33075
33076 INTEGER PYK,PYCHGE,PYCOMP
33077 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
33078 &KEXCIT=4000000,KDIMEN=5000000)
33079
33080C...Date of Change
33081 CHARACTER DOC*11
33082 PARAMETER (DOC='22 Nov 2002')
33083
33084C...ISASUGRA Input:
33085 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
33086C...ISASUGRA Output
33087 CHARACTER*40 ISAVER,VISAJE
33088 REAL SUPER
33089 COMMON /SSPAR/ SUPER(69)
33090 COMMON /SUGMG/ MSS(32),GSS(29),MGUTSS,GGUTSS,AGUTSS,FTGUT,
33091 $FBGUT,FTAGUT,FNGUT
33092 REAL MSS,GSS,MGUTSS,GGUTSS,AGUTSS,FTGUT,FBGUT,FTAGUT,FNGUT
33093 COMMON /SUGPAS/ XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
33094 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
33095 $FNMZ,AMNRMJ,NOGOOD,IAL3UN,ITACHY,MHPNEG,ASM3
33096 REAL XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
33097 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
33098 $FNMZ,AMNRMJ,ASM3
33099 INTEGER NOGOOD,IAL3UN,ITACHY,MHPNEG
33100C SUPER: Filled by ISASUGRA.
33101C SUPER(1) = mass of ~g
33102C SUPER(2:17) = mass of ~u_L,~u_R,~d_L,~d_R,~s_L,~s_R,~c_L,~c_R,~b_L
33103C ,~b_R,~b_1,~b_2,~t_L,~t_R,~t_1,~t_2
33104C SUPER(18:25) = mass of ~e_L,~e_R,~mu_L,~mu_R,~tau_L,~tau_R,~tau_1
33105C ,~tau_2
33106C SUPER(26:28) = mass of ~nu_e,~nu_mu,~nu_tau
33107C SUPER(29) = Higgsino mass = - mu
33108C SUPER(30) = ratio v2/v1 of vev's
33109C SUPER(31:34) = Signed neutralino masses
33110C SUPER(35:50) = Neutralino mixing matrix
33111C SUPER(51:52) = Signed chargino masses
33112C SUPER(53:54) = Chargino left, right mixing angles
33113C SUPER(55:58) = mass of h0, H0, A0, H+
33114C SUPER(59) = Higgs mixing angle alpha
33115C SUPER(60:65) = A_t, theta_t, A_b, theta_b, A_tau, theta_tau
33116C SUPER(66) = Gravitino mass
33117C GSS: Filled by ISASUGRA
33118C GSS( 1) = g_1 GSS( 2) = g_2 GSS( 3) = g_3
33119C GSS( 4) = y_tau GSS( 5) = y_b GSS( 6) = y_t
33120C GSS( 7) = M_1 GSS( 8) = M_2 GSS( 9) = M_3
33121C GSS(10) = A_tau GSS(11) = A_b GSS(12) = A_t
33122C GSS(13) = M_h1^2 GSS(14) = M_h2^2 GSS(15) = M_er^2
33123C GSS(16) = M_el^2 GSS(17) = M_dnr^2 GSS(18) = M_upr^2
33124C GSS(19) = M_upl^2 GSS(20) = M_taur^2 GSS(21) = M_taul^2
33125C GSS(22) = M_btr^2 GSS(23) = M_tpr^2 GSS(24) = M_tpl^2
33126C GSS(25) = mu GSS(26) = B GSS(27) = Y_N
33127C GSS(28) = M_nr GSS(29) = A_n
33128C MSS: Filled by ISASUGRA
33129C MSS( 1) = glss MSS( 2) = upl MSS( 3) = upr
33130C MSS( 4) = dnl MSS( 5) = dnr MSS( 6) = stl
33131C MSS( 7) = str MSS( 8) = chl MSS( 9) = chr
33132C MSS(10) = b1 MSS(11) = b2 MSS(12) = t1
33133C MSS(13) = t2 MSS(14) = nuel MSS(15) = numl
33134C MSS(16) = nutl MSS(17) = el- MSS(18) = er-
33135C MSS(19) = mul- MSS(20) = mur- MSS(21) = tau1
33136C MSS(22) = tau2 MSS(23) = z1ss MSS(24) = z2ss
33137C MSS(25) = z3ss MSS(26) = z4ss MSS(27) = w1ss
33138C MSS(28) = w2ss MSS(29) = hl0 MSS(30) = hh0
33139C MSS(31) = ha0 MSS(32) = h+
33140C Unification, filled by ISASUGRA if applicable.
33141C MGUTSS = M_GUT GGUTSS = g_GUT AGUTSS = alpha_GUTC
33142C...SPYTHIA Input/Output:
33143 INTEGER IMSS
33144 DOUBLE PRECISION RMSS
33145 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
33146 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
33147 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
33148 SAVE /SUGMG/,/SSPAR/
33149C
33150C...PYTHIA common blocks
33151C...Parameters.
33152 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33153 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
33154C...Particle properties + some flavour parameters.
33155 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33156 SAVE /PYDAT2/,/PYSSMT/
33157
33158C...Start by checking for incompatibilities/inconsistencies:
33159 DO 100 ICHK=2,9
33160 IF (ICHK.NE.8.AND.ICHK.NE.4.AND.IMSS(ICHK).NE.0) THEN
33161 WRITE (MSTU(11),*) '(PYSUGI:) IMSS(',ICHK,')=',IMSS(ICHK)
33162 & ,' option not used by PYSUGI'
33163 ENDIF
33164 100 CONTINUE
33165C...ISAJET works with REAL numbers.
33166 MZERO=REAL(RMSS(8))
33167 MHLF=REAL(RMSS(1))
33168 AZERO=REAL(RMSS(16))
33169 TANB=REAL(RMSS(5))
33170 SGNMU=REAL(RMSS(4))
33171 MTOP=REAL(PMAS(6,1))
33172C...Initialize MSSM parameter array
33173 DO 110 IPAR=1,66
33174 SUPER(IPAR)=0.0
33175 110 CONTINUE
33176C...Call ISASUGRA
33177 CALL SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,1)
33178C...Check whether ISASUSY thought the model was OK.
33179 IF (NOGOOD.NE.0) THEN
33180 IF (NOGOOD.EQ.1) CALL PYERRM(26
33181 & ,'(PYSUGI:) SUSY parameters give tachyonic particles.')
33182 IF (NOGOOD.EQ.2) CALL PYERRM(26
33183 & ,'(PYSUGI:) SUSY parameters give no EWSB.')
33184 IF (NOGOOD.EQ.3) CALL PYERRM(26
33185 & ,'(PYSUGI:) SUSY parameters give m(A0) < 0.')
33186 IF (NOGOOD.EQ.4) CALL PYERRM(26
33187 & ,'(PYSUGI:) SUSY parameters give Yukawa > 100.')
33188 IF (NOGOOD.EQ.7) CALL PYERRM(26
33189 & ,'(PYSUGI:) SUSY parameters give x_T EWSB bad.')
33190 IF (NOGOOD.EQ.8) CALL PYERRM(26
33191 & ,'(PYSUGI:) SUSY parameters give m(h0)^2 < 0.')
33192C...Give warning, but don't stop, if LSP not ~chi_10.
33193 IF (NOGOOD.EQ.5) CALL PYERRM(16
33194 & ,'(PYSUGI:) SUSY parameters give ~chi_10 not LSP.')
33195 ENDIF
33196C...Warn about possible GUT scale tachyons.
33197 IF (ITACHY.NE.0) CALL PYERRM(16,
33198 & '(PYSUGI:) Tachyonic sleptons at GUT scale.')
33199
33200C...M1 and M2.
33201 RMSS(1)=GSS(7)
33202 RMSS(2)=GSS(8)
33203C...Gluino Mass.
33204 RMSS(3)=SUPER(1)
33205C...Mu = - Higgsino mass.
33206 RMSS(4)=-SUPER(29)
33207 RMSS(5)=TANB
33208C...Slepton and squark masses. 2 first generations.
33209 RMSS(6)=0.5*(SUPER(18)+SUPER(20))
33210 RMSS(7)=0.5*(SUPER(19)+SUPER(21))
33211 RMSS(8)=0.25*(SUPER(2)+SUPER(4)+SUPER(6)+SUPER(8))
33212 RMSS(9)=0.25*(SUPER(3)+SUPER(5)+SUPER(7)+SUPER(9))
33213C...Third generation.
33214 RMSS(10)=0.5*(SUPER(14)+SUPER(10))
33215 RMSS(11)=SUPER(11)
33216 RMSS(12)=SUPER(15)
33217 RMSS(13)=SUPER(22)
33218 RMSS(14)=SUPER(23)
33219C...~b, ~t, and ~tau trilinear couplings and mixing angles.
33220 RMSS(15)=SUPER(62)
33221 RMSS(16)=SUPER(60)
33222 RMSS(17)=SUPER(64)
33223 RMSS(26)=SUPER(63)
33224 RMSS(27)=SUPER(61)
33225 RMSS(28)=SUPER(65)
33226C...Higgs mixing angle alpha (Gunion-Haber convention).
33227 RMSS(18)=-SUPER(59)
33228C...A0 mass.
33229 RMSS(19)=SUPER(57)
33230C...GUT scale coupling
33231 RMSS(20)=AGUTSS
33232C...Gravitino mass (for future compatibility)
33233 RMSS(21)=SUPER(66)
33234
33235C...Now we're done with RMSS. Time to fill PMAS (m > 0 required).
33236C...Higgs sector.
33237 PMAS(PYCOMP(25),1)=ABS(SUPER(55))
33238 PMAS(PYCOMP(35),1)=ABS(SUPER(56))
33239 PMAS(PYCOMP(36),1)=ABS(SUPER(57))
33240 PMAS(PYCOMP(37),1)=ABS(SUPER(58))
33241C...Gluino.
33242 PMAS(PYCOMP(KSUSY1+21),1)=ABS(SUPER(1))
33243C...Squarks and Sleptons.
33244 DO 120 ILR=1,2
33245 ILRM=ILR-1
33246 PMAS(PYCOMP(ILR*KSUSY1+1),1)=ABS(SUPER(4+ILRM))
33247 PMAS(PYCOMP(ILR*KSUSY1+2),1)=ABS(SUPER(2+ILRM))
33248 PMAS(PYCOMP(ILR*KSUSY1+3),1)=ABS(SUPER(6+ILRM))
33249 PMAS(PYCOMP(ILR*KSUSY1+4),1)=ABS(SUPER(8+ILRM))
33250 PMAS(PYCOMP(ILR*KSUSY1+5),1)=ABS(SUPER(12+ILRM))
33251 PMAS(PYCOMP(ILR*KSUSY1+6),1)=ABS(SUPER(16+ILRM))
33252 PMAS(PYCOMP(ILR*KSUSY1+11),1)=ABS(SUPER(18+ILRM))
33253 PMAS(PYCOMP(ILR*KSUSY1+13),1)=ABS(SUPER(20+ILRM))
33254 PMAS(PYCOMP(ILR*KSUSY1+15),1)=ABS(SUPER(24+ILRM))
33255 120 CONTINUE
33256 PMAS(PYCOMP(KSUSY1+12),1)=ABS(SUPER(26))
33257 PMAS(PYCOMP(KSUSY1+14),1)=ABS(SUPER(27))
33258 PMAS(PYCOMP(KSUSY1+16),1)=ABS(SUPER(28))
33259C...Neutralinos.
33260 PMAS(PYCOMP(KSUSY1+22),1)=ABS(SUPER(31))
33261 PMAS(PYCOMP(KSUSY1+23),1)=ABS(SUPER(32))
33262 PMAS(PYCOMP(KSUSY1+25),1)=ABS(SUPER(33))
33263 PMAS(PYCOMP(KSUSY1+35),1)=ABS(SUPER(34))
33264C...Signed masses (extra minus from going to G-H convention).
33265 SMZ(1)=-SUPER(31)
33266 SMZ(2)=-SUPER(32)
33267 SMZ(3)=-SUPER(33)
33268 SMZ(4)=-SUPER(34)
33269C...Charginos
33270 PMAS(PYCOMP(KSUSY1+24),1)=ABS(SUPER(51))
33271 PMAS(PYCOMP(KSUSY1+37),1)=ABS(SUPER(52))
33272C...Signed masses (extra minus from going to G-H convention).
33273 SMW(1)=-SUPER(51)
33274 SMW(2)=-SUPER(52)
33275
33276C... Neutralino Mixing.
33277 DO 130 IN=1,4
33278 ZMIX(IN,1)= SUPER(38+4*(IN-1))
33279 ZMIX(IN,2)= SUPER(37+4*(IN-1))
33280 ZMIX(IN,3)=-SUPER(36+4*(IN-1))
33281 ZMIX(IN,4)=-SUPER(35+4*(IN-1))
33282 130 CONTINUE
33283C...Chargino Mixing (PYTHIA same angle as HERWIG).
33284 THX=1D0
33285 THY=1D0
33286 IF (SUPER(53).GT.0) THX=-1D0
33287 IF (SUPER(54).GT.0) THY=-1D0
33288 UMIX(1,1) = -SIN(SUPER(53))
33289 UMIX(1,2) = -COS(SUPER(53))
33290 UMIX(2,1) = -THX*COS(SUPER(53))
33291 UMIX(2,2) = THX*SIN(SUPER(53))
33292 VMIX(1,1) = -SIN(SUPER(54))
33293 VMIX(1,2) = -COS(SUPER(54))
33294 VMIX(2,1) = -THY*COS(SUPER(54))
33295 VMIX(2,2) = THY*SIN(SUPER(54))
33296C...Sfermion mixing (PYTHIA same angle as ISAJET)
33297 SFMIX(5,1)=COS(SUPER(63))
33298 SFMIX(5,2)=SIN(SUPER(63))
33299 SFMIX(5,3)=-SIN(SUPER(63))
33300 SFMIX(5,4)=COS(SUPER(63))
33301 SFMIX(6,1)=COS(SUPER(61))
33302 SFMIX(6,2)=SIN(SUPER(61))
33303 SFMIX(6,3)=-SIN(SUPER(61))
33304 SFMIX(6,4)=COS(SUPER(61))
33305 SFMIX(15,1)=COS(SUPER(65))
33306 SFMIX(15,2)=SIN(SUPER(65))
33307 SFMIX(15,3)=-SIN(SUPER(65))
33308 SFMIX(15,4)=COS(SUPER(65))
33309
33310 IF (MSTP(122).NE.0) THEN
33311C...Print a few lines to make the user know what's happening
33312 ISAVER=VISAJE()
33313 WRITE(MSTU(11),5000) DOC, ISAVER
33314 WRITE(MSTU(11),5100)
33315 WRITE(MSTU(11),5200) MZERO, MHLF, AZERO, TANB, NINT(SGNMU), MTOP
33316 WRITE(MSTU(11),5300)
33317 WRITE(MSTU(11),5500) 'EW scale masses'
33318 WRITE(MSTU(11),5700) (SUPER(IP),IP=2,16,2),(SUPER(IP),IP=3,17,2)
33319 WRITE(MSTU(11),5800) (SUPER(IP),IP=18,24,2),(SUPER(IP),IP=26,28)
33320 & ,(SUPER(IP),IP=19,25,2)
33321 WRITE(MSTU(11),5900) SUPER(1),(SMZ(IP),IP=1,4), (SMW(IP)
33322 & ,IP=1,2)
33323 WRITE(MSTU(11),6000) (SUPER(IP),IP=55,58)
33324 WRITE(MSTU(11),5400)
33325 WRITE(MSTU(11),5500) 'Mixing structure'
33326 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
33327 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
33328 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
33329 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
33330 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
33331 & ),(SFMIX(15,J),J=3,4)
33332 WRITE(MSTU(11),5400)
33333 WRITE(MSTU(11),5500) 'Couplings'
33334 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17),RMSS(20)
33335 WRITE(MSTU(11),5400)
33336 WRITE(MSTU(11),6500)
33337 ENDIF
33338
33339C...Fix the higgs sector (in PYMSIN) using the masses and mixing angle
33340C...output by ISASUGRA.
33341 IMSS(4)=2
33342
33343 5000 FORMAT(1x,19('*'),1x,'PYSUGI v1.1: PYTHIA/ISASUGRA '
33344 & ,'INTERFACE',1x,19('*')/1x,'*',3x,'PYSUGI: Last Change',1x,A
33345 & ,1x,'-',1x,'P.Z. Skands'/1x,'*',2x,A/1x,'*')
33346 5100 FORMAT(1x,'*',1x,'ISASUGRA Input:'/1x,'*',1x,'----------------')
33347 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
33348 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
33349 5300 FORMAT(1x,'*'/1x,'*',1x,'ISASUGRA Output:'/1x,'*',1x
33350 & ,'----------------')
33351 5400 FORMAT(1x,'*',1x,A)
33352 5500 FORMAT(1x,'*',1x,A,':')
33353 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
33354 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
33355 5700 FORMAT(1x,'*',4x,4x,'~u',2x,1x,4x,'~d',2x,1x,4x,'~s',2x,1x,
33356 & 4x,'~c',2x,1x,4x,'~b',2x,1x,2x,'~b(12)',1x,4x,'~t',2x,1x, 2x,
33357 & '~t(12)'/1x,'*',2x,'L',1x,8(F8.2,1x)/1x,'*',2x,'R',1x,8(F8.2
33358 & ,1x))
33359 5800 FORMAT(1x,'*'/1x,'*',4x,4x,'~e',2x,1x,3x,'~mu',2x,1x,3x,'~tau',1x
33360 & ,1x,'~tau(12)',1x,2x,'~nu_e',1x,1x,1x,'~nu_mu',1x,1x,1x
33361 & ,'~nu_tau'/1x,'*',2x,'L',1x,7(F8.2,1x)/1x,'*',2x,'R',1x,4(F8
33362 & .2,1x))
33363 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
33364 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
33365 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
33366 6000 FORMAT(1x,'*'/1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
33367 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x))
33368 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
33369 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
33370 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
33371 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
33372 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
33373 & ,1x,F6.3,1x),'|')
33374 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
33375 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
33376 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
33377 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
33378 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
33379 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
33380 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
33381 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
33382 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
33383 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
33384 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
33385 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
33386 6400 FORMAT(1x,'*',3x,'A_b = ',F8.2,4x,'A_t = ',F8.2,4x,'A_tau = ',F8.2
33387 & ,4x,'Alpha_GUT = ',F8.2)
33388 6500 FORMAT(1x,32('*'),1x,'END OF PYSUGI',1x,31('*'))
33389 END
33390
33391C*********************************************************************
33392
33393C...PYRNMQ
33394C...Determines the running mass of Squarks.
33395
33396 FUNCTION PYRNMQ(ID,DTERM)
33397
33398C...Double precision and integer declarations.
33399 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33400 IMPLICIT INTEGER(I-N)
33401 INTEGER PYK,PYCHGE,PYCOMP
33402C...Commonblock.
33403 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
33404 SAVE /PYMSSM/
33405
33406C...Local variables.
33407 DOUBLE PRECISION PI,R
33408 DOUBLE PRECISION TOL
33409 DOUBLE PRECISION CI(3)
33410 EXTERNAL PYALPS
33411 DOUBLE PRECISION PYALPS
33412 DATA TOL/0.001D0/
33413 DATA PI,R/3.141592654D0,.61803399D0/
33414 DATA CI/0.47D0,0.07D0,0.02D0/
33415
33416 C=1D0-R
33417 CA=CI(ID)
33418 AG=(0.71D0)**2/4D0/PI
33419 AG=RMSS(20)
33420 XM0=RMSS(8)
33421 XMG=RMSS(1)
33422 XM02=XM0*XM0
33423 XMG2=XMG*XMG
33424
33425 AS=PYALPS(XM02+6D0*XMG2)
33426 CG=8D0/9D0*((AS/AG)**2-1D0)
33427 BX=XM02+(CA+CG)*XMG2+DTERM
33428 AX=MIN(50D0**2,0.5D0*BX)
33429 CX=MAX(2000D0**2,2D0*BX)
33430
33431 X0=AX
33432 X3=CX
33433 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
33434 X1=BX
33435 X2=BX+C*(CX-BX)
33436 ELSE
33437 X2=BX
33438 X1=BX-C*(BX-AX)
33439 ENDIF
33440 AS1=PYALPS(X1)
33441 CG=8D0/9D0*((AS1/AG)**2-1D0)
33442 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
33443 AS2=PYALPS(X2)
33444 CG=8D0/9D0*((AS2/AG)**2-1D0)
33445 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
33446 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
33447 IF(F2.LT.F1) THEN
33448 X0=X1
33449 X1=X2
33450 X2=R*X1+C*X3
33451 F1=F2
33452 AS2=PYALPS(X2)
33453 CG=8D0/9D0*((AS2/AG)**2-1D0)
33454 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
33455 ELSE
33456 X3=X2
33457 X2=X1
33458 X1=R*X2+C*X0
33459 F2=F1
33460 AS1=PYALPS(X1)
33461 CG=8D0/9D0*((AS1/AG)**2-1D0)
33462 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
33463 ENDIF
33464 GOTO 100
33465 ENDIF
33466 IF(F1.LT.F2) THEN
33467 PYRNMQ=X1
33468 XMIN=X1
33469 ELSE
33470 PYRNMQ=X2
33471 XMIN=X2
33472 ENDIF
33473
33474 RETURN
33475 END
33476
33477C*********************************************************************
33478
33479C...PYTHRG
33480C...Calculates the mass eigenstates of the third generation sfermions.
33481C...Created: 5-31-96
33482
33483 SUBROUTINE PYTHRG
33484
33485C...Double precision and integer declarations.
33486 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33487 IMPLICIT INTEGER(I-N)
33488 INTEGER PYK,PYCHGE,PYCOMP
33489C...Parameter statement to help give large particle numbers.
33490 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
33491 &KEXCIT=4000000,KDIMEN=5000000)
33492C...Commonblocks.
33493 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33494 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33495 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
33496 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
33497 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
33498 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
33499
33500C...Local variables.
33501 DOUBLE PRECISION BETA
33502 DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
33503 DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
33504 DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
33505 DOUBLE PRECISION ATR,AMQR,AMQL
33506 INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
33507 INTEGER IF,I,J,II,JJ,IT,L
33508 LOGICAL DTERM
33509 DATA SMALL/1D-3/
33510 DATA ID1/10,10,13/
33511 DATA ID2/5,6,15/
33512 DATA ID3/15,16,17/
33513 DATA ID4/11,12,14/
33514 DATA DTERM/.TRUE./
33515
33516 XMZ2=PMAS(23,1)**2
33517 XMW2=PMAS(24,1)**2
33518 TANB=RMSS(5)
33519 XMU=-RMSS(4)
33520 BETA=ATAN(TANB)
33521 COS2B=COS(2D0*BETA)
33522
33523C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
33524
33525 IOPT=IMSS(5)
33526 IF(IOPT.EQ.1) THEN
33527 CTT=DCOS(RMSS(27))
33528 CTT2=CTT**2
33529 STT=DSIN(RMSS(27))
33530 STT2=STT**2
33531 XM12=RMSS(10)**2
33532 XM22=RMSS(12)**2
33533 XMQL2=CTT2*XM12+STT2*XM22
33534 XMQR2=STT2*XM12+CTT2*XM22
33535 XMF2=PYMRUN(6,PMAS(6,1)**2)**2
33536 ATOP=-XMU/TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
33537 RMSS(16)=ATOP
33538C......SUBTRACT OUT D-TERM AND FERMION MASS
33539 XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0
33540 XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0
33541 IF(XMQL2.GE.0D0) THEN
33542 RMSS(10)=SQRT(XMQL2)
33543 ELSE
33544 RMSS(10)=-SQRT(-XMQL2)
33545 ENDIF
33546 IF(XMQR2.GE.0D0) THEN
33547 RMSS(12)=SQRT(XMQR2)
33548 ELSE
33549 RMSS(12)=-SQRT(-XMQR2)
33550 ENDIF
33551
33552C SAME FOR BOTTOM SQUARK
33553 CTT=DCOS(RMSS(26))
33554 CTT2=CTT**2
33555 STT=DSIN(RMSS(26))
33556 STT2=STT**2
33557 XM22=RMSS(11)**2
33558 XMF2=PYMRUN(5,PMAS(6,1)**2)**2
33559 XMQL2=SIGN(RMSS(10)**2,RMSS(10))-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2
33560 IF(ABS(CTT).GE..9999D0) THEN
33561 ABOT=-XMU*TANB
33562 XMQR2=RMSS(11)**2
33563 ELSEIF(ABS(CTT).LE.1D-4) THEN
33564 ABOT=-XMU*TANB
33565 XMQR2=RMSS(11)**2
33566 ELSE
33567 XM12=(XMQL2-STT2*XM22)/CTT2
33568 XMQR2=STT2*XM12+CTT2*XM22
33569 ABOT=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
33570 ENDIF
33571 RMSS(15)=ABOT
33572C......SUBTRACT OUT D-TERM AND FERMION MASS
33573 XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2
33574 IF(XMQR2.GE.0D0) THEN
33575 RMSS(11)=SQRT(XMQR2)
33576 ELSE
33577 RMSS(11)=-SQRT(-XMQR2)
33578 ENDIF
33579C SAME FOR TAU SLEPTON
33580 CTT=DCOS(RMSS(28))
33581 CTT2=CTT**2
33582 STT=DSIN(RMSS(28))
33583 STT2=STT**2
33584 XM12=RMSS(13)**2
33585 XM22=RMSS(14)**2
33586 XMQL2=CTT2*XM12+STT2*XM22
33587 XMQR2=STT2*XM12+CTT2*XM22
33588 XMFR=PMAS(15,1)
33589 XMF2=XMFR**2
33590 ATAU=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
33591 RMSS(17)=ATAU
33592C......SUBTRACT OUT D-TERM AND FERMION MASS
33593 XMQL2=XMQL2-XMF2+(-.5D0*XMZ2+XMW2)*COS2B
33594 XMQR2=XMQR2-XMF2+(XMZ2-XMW2)*COS2B
33595 IF(XMQL2.GE.0D0) THEN
33596 RMSS(13)=SQRT(XMQL2)
33597 ELSE
33598 RMSS(13)=-SQRT(-XMQL2)
33599 ENDIF
33600 IF(XMQR2.GE.0D0) THEN
33601 RMSS(14)=SQRT(XMQR2)
33602 ELSE
33603 RMSS(14)=-SQRT(-XMQR2)
33604 ENDIF
33605 ENDIF
33606 DO 170 L=1,3
33607 AMQL=RMSS(ID1(L))
33608 IF(AMQL.LT.0D0) THEN
33609 XMQL2=-AMQL**2
33610 ELSE
33611 XMQL2=AMQL**2
33612 ENDIF
33613 ATR=RMSS(ID3(L))
33614 AMQR=RMSS(ID4(L))
33615 IF(AMQR.LT.0D0) THEN
33616 XMQR2=-AMQR**2
33617 ELSE
33618 XMQR2=AMQR**2
33619 ENDIF
33620 IF=ID2(L)
33621 XMF=PYMRUN(IF,PMAS(6,1)**2)
33622 XMF2=XMF**2
33623 AM2(1,1)=XMQL2+XMF2
33624 AM2(2,2)=XMQR2+XMF2
33625 IF(AM2(1,1).EQ.AM2(2,2)) AM2(2,2)=AM2(2,2)*1.00001D0
33626 IF(DTERM) THEN
33627 IF(L.EQ.1) THEN
33628 AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0
33629 AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
33630 AM2(1,2)=XMF*(ATR+XMU*TANB)
33631 ELSEIF(L.EQ.2) THEN
33632 AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0
33633 AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0
33634 AM2(1,2)=XMF*(ATR+XMU/TANB)
33635 ELSEIF(L.EQ.3) THEN
33636 IF(IMSS(8).EQ.1) THEN
33637 AM2(1,1)=RMSS(6)**2
33638 AM2(2,2)=RMSS(7)**2
33639 AM2(1,2)=0D0
33640 RMSS(13)=RMSS(6)
33641 RMSS(14)=RMSS(7)
33642 ELSE
33643 AM2(1,1)=AM2(1,1)-(-.5D0*XMZ2+XMW2)*COS2B
33644 AM2(2,2)=AM2(2,2)-(XMZ2-XMW2)*COS2B
33645 AM2(1,2)=XMF*(ATR+XMU*TANB)
33646 ENDIF
33647 ENDIF
33648 ENDIF
33649 AM2(2,1)=AM2(1,2)
33650 DETM=AM2(1,1)*AM2(2,2)-AM2(2,1)**2
33651 IF(DETM.LT.0D0) THEN
33652 WRITE(MSTU(11),*) ID2(L),DETM,AM2
33653 CALL PYERRM(30,' NEGATIVE**2 MASS FOR SFERMION IN PYTHRG ')
33654 ENDIF
33655 SAME=0.5D0*(AM2(1,1)+AM2(2,2))
33656 DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1))
33657 XMF12=SAME-DIFF
33658 XMF22=SAME+DIFF
33659 IT=0
33660 IF(XMF22-XMF12.GT.0D0) THEN
33661 RT(1,1) = SQRT(MAX(0D0,(XMF22-AM2(1,1))/(XMF22-XMF12)))
33662 RT(2,2) = RT(1,1)
33663 RT(1,2) = -SIGN(SQRT(MAX(0D0,1D0-RT(1,1)**2)),
33664 & AM2(1,2)/(XMF22-XMF12))
33665 RT(2,1) = -RT(1,2)
33666 ELSE
33667 RT(1,1) = 1D0
33668 RT(2,2) = RT(1,1)
33669 RT(1,2) = 0D0
33670 RT(2,1) = -RT(1,2)
33671 ENDIF
33672 100 CONTINUE
33673 IT=IT+1
33674
33675 DO 140 I=1,2
33676 DO 130 JJ=1,2
33677 DI(I,JJ)=0D0
33678 DO 120 II=1,2
33679 DO 110 J=1,2
33680 DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II)
33681 110 CONTINUE
33682 120 CONTINUE
33683 130 CONTINUE
33684 140 CONTINUE
33685
33686 IF(DI(1,1).GT.DI(2,2)) THEN
33687 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION '
33688 WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22)
33689 WRITE(MSTU(11),*) AM2
33690 WRITE(MSTU(11),*) DI
33691 WRITE(MSTU(11),*) RT
33692 DI(1,1)=-RT(2,1)
33693 DI(2,2)=RT(1,2)
33694 DI(1,2)=-RT(2,2)
33695 DI(2,1)=RT(1,1)
33696 DO 160 I=1,2
33697 DO 150 J=1,2
33698 RT(I,J)=DI(I,J)
33699 150 CONTINUE
33700 160 CONTINUE
33701 GOTO 100
33702 ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN
33703 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
33704 & ' OFF DIAGONAL ELEMENTS '
33705 WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22)
33706 WRITE(MSTU(11),*) DI
33707 WRITE(MSTU(11),*) ' ROTATION = ',RT
33708C...STOP
33709 ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN
33710 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
33711 & ' NEGATIVE MASSES '
33712 STOP
33713 ENDIF
33714 PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12)
33715 PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22)
33716 SFMIX(IF,1)=RT(1,1)
33717 SFMIX(IF,2)=RT(1,2)
33718 SFMIX(IF,3)=RT(2,1)
33719 SFMIX(IF,4)=RT(2,2)
33720 170 CONTINUE
33721
33722C.....TAU SNEUTRINO MASS...L=3
33723
33724 XARG=AM2(1,1)+XMW2*COS2B
33725 IF(XARG.LT.0D0) THEN
33726 WRITE(MSTU(11),*) ' PYTHRG:: TAU SNEUTRINO MASS IS NEGATIVE'//
33727 & ' FROM THE SUM RULE. '
33728 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
33729 RETURN
33730 ELSE
33731 PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG)
33732 ENDIF
33733
33734 RETURN
33735 END
33736
33737C*********************************************************************
33738
33739C...PYINOM
33740C...Finds the mass eigenstates and mixing matrices for neutralinos
33741C...and charginos.
33742
33743 SUBROUTINE PYINOM
33744
33745C...Double precision and integer declarations.
33746 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33747 IMPLICIT INTEGER(I-N)
33748 INTEGER PYCOMP
33749C...Parameter statement to help give large particle numbers.
33750 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
33751 &KEXCIT=4000000,KDIMEN=5000000)
33752C...Commonblocks.
33753 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33754 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33755 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
33756 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
33757 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
33758 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
33759
33760C...Local variables.
33761 DOUBLE PRECISION XMW,XMZ,XM(4)
33762 DOUBLE PRECISION AR(4,4),WR(4),ZR(4,4),ZI(4,4),AI(4,4)
33763 DOUBLE PRECISION WI(4),FV1(4),FV2(4),FV3(4)
33764 DOUBLE PRECISION COSW,SINW
33765 DOUBLE PRECISION XMU
33766 DOUBLE PRECISION TANB,COSB,SINB
33767 DOUBLE PRECISION XM1,XM2,XM3,BETA
33768 DOUBLE PRECISION Q2,AEM,A1,A2,AQ,RM1,RM2
33769 DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
33770 DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
33771 DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
33772 DOUBLE PRECISION PYALPS,PYALEM
33773 DOUBLE PRECISION PYRNM3
33774 COMPLEX*16 CAR(4,4),CAI(4,4),CA1,CA2
33775 INTEGER IERR,INDEX(4),I,J,K,IOPT,ILR,KFNCHI(4)
33776 DATA KFNCHI/1000022,1000023,1000025,1000035/
33777
33778 IOPT=IMSS(2)
33779 IF(IMSS(1).EQ.2) THEN
33780 IOPT=1
33781 ENDIF
33782C...M1, M2, AND M3 ARE INDEPENDENT
33783 IF(IOPT.EQ.0) THEN
33784 XM1=RMSS(1)
33785 XM2=RMSS(2)
33786 XM3=RMSS(3)
33787 ELSEIF(IOPT.GE.1) THEN
33788 Q2=PMAS(23,1)**2
33789 AEM=PYALEM(Q2)
33790 A2=AEM/PARU(102)
33791 A1=AEM/(1D0-PARU(102))
33792 XM1=RMSS(1)
33793 XM2=RMSS(2)
33794 IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0
33795 IF(IOPT.EQ.1) THEN
33796 XM2=XM1*A2/A1*3D0/5D0
33797 RMSS(2)=XM2
33798 ELSEIF(IOPT.EQ.3) THEN
33799 XM1=XM2*5D0/3D0*A1/A2
33800 RMSS(1)=XM1
33801 ENDIF
33802 XM3=PYRNM3(XM2/A2)
33803 RMSS(3)=XM3
33804 IF(XM3.LE.0D0) THEN
33805 WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3
33806 STOP
33807 ENDIF
33808 ENDIF
33809
33810C...GLUINO MASS
33811 IF(IMSS(3).EQ.1) THEN
33812 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)
33813 ELSE
33814 AQ=0D0
33815 DO 110 I=1,4
33816 DO 100 ILR=1,2
33817 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
33818 AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0)
33819 & +(1D0-RM1)**2*LOG(ABS(1D0-RM1)))
33820 100 CONTINUE
33821 110 CONTINUE
33822
33823 DO 130 I=5,6
33824 DO 120 ILR=1,2
33825 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
33826 RM2=PMAS(I,1)**2/XM3**2
33827 ARG=(RM1-RM2-1D0)**2-4D0*RM2**2
33828 IF(ARG.GE.0D0) THEN
33829 X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG))
33830 AX0=ABS(X0)
33831 X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG))
33832 AX1=ABS(X1)
33833 IF(X0.EQ.1D0) THEN
33834 AT=-1D0
33835 BT=0.25D0
33836 ELSEIF(X0.EQ.0D0) THEN
33837 AT=0D0
33838 BT=-0.25D0
33839 ELSE
33840 AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+
33841 & 0.5D0*X0**2*LOG(AX0)
33842 BT=(-1D0-2D0*X0)/4D0
33843 ENDIF
33844 IF(X1.EQ.1D0) THEN
33845 AT=-1D0+AT
33846 BT=0.25D0+BT
33847 ELSEIF(X1.EQ.0D0) THEN
33848 AT=0D0+AT
33849 BT=-0.25D0+BT
33850 ELSE
33851 AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0*
33852 & X1**2*LOG(AX1)+AT
33853 BT=(-1D0-2D0*X1)/4D0+BT
33854 ENDIF
33855 AQ=AQ+AT+BT
33856 ELSE
33857 X0=0.5D0*(1D0+RM2-RM1)
33858 Y0=-0.5D0*SQRT(-ARG)
33859 AMGX0=SQRT(X0**2+Y0**2)
33860 AM1X0=SQRT((1D0-X0)**2+Y0**2)
33861 ARGX0=ATAN2(-X0,-Y0)
33862 AR1X0=ATAN2(1D0-X0,Y0)
33863 X1=X0
33864 Y1=-Y0
33865 AMGX1=AMGX0
33866 AM1X1=AM1X0
33867 ARGX1=ATAN2(-X1,-Y1)
33868 AR1X1=ATAN2(1D0-X1,Y1)
33869 AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2)
33870 & +0.5D0*(X0**2-Y0**2)*LOG(AMGX0)
33871 BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 )
33872 AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2)
33873 & +0.5D0*(X1**2-Y1**2)*LOG(AMGX1)
33874 BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 )
33875 AQ=AQ+AT+BT
33876 ENDIF
33877 120 CONTINUE
33878 130 CONTINUE
33879 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)*(1D0+PYALPS(XM3**2)
33880 & /(2D0*PARU(2))*(15D0+AQ))
33881 ENDIF
33882
33883C...NEUTRALINO MASSES
33884 DO 150 I=1,4
33885 DO 140 J=1,4
33886 AI(I,J)=0D0
33887 140 CONTINUE
33888 150 CONTINUE
33889 XMZ=PMAS(23,1)
33890 XMW=PMAS(24,1)
33891 XMU=RMSS(4)
33892 SINW=SQRT(PARU(102))
33893 COSW=SQRT(1D0-PARU(102))
33894 TANB=RMSS(5)
33895 BETA=ATAN(TANB)
33896 COSB=COS(BETA)
33897 SINB=TANB*COSB
33898
33899C... Definitions:
33900C... psi^0 =(-i bino^0, -i wino^0, h_d^0(=H_1^0), h_u^0(=H_2^0))
33901C... => L_neutralino = -1/2*(psi^0)^T * [AR] * psi^0 + h.c.
33902 AR(1,1) = XM1*COS(RMSS(30))
33903 AI(1,1) = XM1*SIN(RMSS(30))
33904 AR(2,2) = XM2*COS(RMSS(31))
33905 AI(2,2) = XM2*SIN(RMSS(31))
33906 AR(3,3) = 0D0
33907 AR(4,4) = 0D0
33908 AR(1,2) = 0D0
33909 AR(2,1) = 0D0
33910 AR(1,3) = -XMZ*SINW*COSB
33911 AR(3,1) = AR(1,3)
33912 AR(1,4) = XMZ*SINW*SINB
33913 AR(4,1) = AR(1,4)
33914 AR(2,3) = XMZ*COSW*COSB
33915 AR(3,2) = AR(2,3)
33916 AR(2,4) = -XMZ*COSW*SINB
33917 AR(4,2) = AR(2,4)
33918 AR(3,4) = -XMU*COS(RMSS(33))
33919 AI(3,4) = -XMU*SIN(RMSS(33))
33920 AR(4,3) = -XMU*COS(RMSS(33))
33921 AI(4,3) = -XMU*SIN(RMSS(33))
33922C CALL PYEIG4(AR,WR,ZR)
33923 CALL PYEICG(4,4,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
33924 IF(IERR.NE.0) THEN
33925 WRITE(MSTU(11),*) ' PROBLEM WITH PYEICG IN PYINOM '
33926 ENDIF
33927 DO 160 I=1,4
33928 INDEX(I)=I
33929 XM(I)=ABS(WR(I))
33930 160 CONTINUE
33931 DO 180 I=2,4
33932 K=I
33933 DO 170 J=I-1,1,-1
33934 IF(XM(K).LT.XM(J)) THEN
33935 ITMP=INDEX(J)
33936 XTMP=XM(J)
33937 INDEX(J)=INDEX(K)
33938 XM(J)=XM(K)
33939 INDEX(K)=ITMP
33940 XM(K)=XTMP
33941 K=K-1
33942 ELSE
33943 GOTO 180
33944 ENDIF
33945 170 CONTINUE
33946 180 CONTINUE
33947
33948
33949 DO 210 I=1,4
33950 K=INDEX(I)
33951 SMZ(I)=WR(K)
33952 PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I))
33953 S=0D0
33954 DO 190 J=1,4
33955 S=S+ZR(J,K)**2+ZI(J,K)**2
33956 190 CONTINUE
33957 DO 200 J=1,4
33958 ZMIX(I,J)=ZR(J,K)/SQRT(S)
33959 ZMIXI(I,J)=ZI(J,K)/SQRT(S)
33960 IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0
33961 IF(ABS(ZMIXI(I,J)).LT.1D-6) ZMIXI(I,J)=0D0
33962 200 CONTINUE
33963 210 CONTINUE
33964
33965C...CHARGINO MASSES
33966C.....Find eigenvectors of X X^*
33967 AI(1,1) = 0D0
33968 AI(2,2) = 0D0
33969 AR(1,1) = XM2**2+2D0*XMW**2*SINB**2
33970 AR(2,2) = XMU**2+2D0*XMW**2*COSB**2
33971 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
33972 &XMU*COS(RMSS(33))*SINB)
33973 AI(1,2) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*COSB-
33974 &XMU*SIN(RMSS(33))*SINB)
33975 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
33976 &XMU*COS(RMSS(33))*SINB)
33977 AI(2,1) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*COSB+
33978 &XMU*SIN(RMSS(33))*SINB)
33979 CALL PYEICG(4,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
33980 IF(IERR.NE.0) THEN
33981 WRITE(MSTU(11),*) ' PROBLEM WITH PYEICG IN PYINOM '
33982 ENDIF
33983 INDEX(1)=1
33984 INDEX(2)=2
33985 IF(WR(2).LT.WR(1)) THEN
33986 INDEX(1)=2
33987 INDEX(2)=1
33988 ENDIF
33989
33990 DO 240 I=1,2
33991 K=INDEX(I)
33992 SMW(I)=SQRT(WR(K))
33993 S=0D0
33994 DO 220 J=1,2
33995 S=S+ZR(J,K)**2+ZI(J,K)**2
33996 220 CONTINUE
33997 DO 230 J=1,2
33998 UMIX(I,J)=ZR(J,K)/SQRT(S)
33999 UMIXI(I,J)=-ZI(J,K)/SQRT(S)
34000 IF(ABS(UMIX(I,J)).LT.1D-6) UMIX(I,J)=0D0
34001 IF(ABS(UMIXI(I,J)).LT.1D-6) UMIXI(I,J)=0D0
34002 230 CONTINUE
34003 240 CONTINUE
34004 IF(ABS(SMW(1)).LT.ABS(SMZ(1))) THEN
34005 SMW(1)=SIGN(ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1),SMW(1))
34006 ENDIF
34007 PMAS(PYCOMP(KSUSY1+24),1)=SMW(1)
34008 PMAS(PYCOMP(KSUSY1+37),1)=SMW(2)
34009
34010C.....Find eigenvectors of X^* X
34011 AI(1,1) = 0D0
34012 AI(2,2) = 0D0
34013 AR(1,1) = XM2**2+2D0*XMW**2*COSB**2
34014 AR(2,2) = XMU**2+2D0*XMW**2*SINB**2
34015 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
34016 &XMU*COS(RMSS(33))*COSB)
34017 AI(1,2) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*SINB+
34018 &XMU*SIN(RMSS(33))*COSB)
34019 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
34020 &XMU*COS(RMSS(33))*COSB)
34021 AI(2,1) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*SINB-
34022 &XMU*SIN(RMSS(33))*COSB)
34023 CALL PYEICG(4,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
34024 IF(IERR.NE.0) THEN
34025 WRITE(MSTU(11),*) ' PROBLEM WITH PYEICG IN PYINOM '
34026 ENDIF
34027 INDEX(1)=1
34028 INDEX(2)=2
34029 IF(WR(2).LT.WR(1)) THEN
34030 INDEX(1)=2
34031 INDEX(2)=1
34032 ENDIF
34033
34034 DO 270 I=1,2
34035 K=INDEX(I)
34036 S=0D0
34037 DO 250 J=1,2
34038 S=S+ZR(J,K)**2+ZI(J,K)**2
34039 250 CONTINUE
34040 DO 260 J=1,2
34041 VMIX(I,J)=ZR(J,K)/SQRT(S)
34042 VMIXI(I,J)=-ZI(J,K)/SQRT(S)
34043 IF(ABS(VMIX(I,J)).LT.1D-6) VMIX(I,J)=0D0
34044 IF(ABS(VMIXI(I,J)).LT.1D-6) VMIXI(I,J)=0D0
34045 260 CONTINUE
34046 270 CONTINUE
34047
34048
34049 RETURN
34050 END
34051
34052C*********************************************************************
34053
34054C...PYRNM3
34055C...Calculates the running of M3, the SU(3) gluino mass parameter.
34056
34057 FUNCTION PYRNM3(RGUT)
34058
34059C...Double precision and integer declarations.
34060 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34061 IMPLICIT INTEGER(I-N)
34062 INTEGER PYK,PYCHGE,PYCOMP
34063
34064C...Local variables.
34065 DOUBLE PRECISION R
34066 DOUBLE PRECISION TOL
34067 EXTERNAL PYALPS
34068 DOUBLE PRECISION PYALPS
34069 DATA TOL/0.001D0/
34070 DATA R/0.61803399D0/
34071
34072 C=1D0-R
34073
34074 BX=RGUT*PYALPS(RGUT**2)
34075 AX=MIN(50D0,BX*0.5D0)
34076 CX=MAX(2000D0,2D0*BX)
34077
34078 X0=AX
34079 X3=CX
34080 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
34081 X1=BX
34082 X2=BX+C*(CX-BX)
34083 ELSE
34084 X2=BX
34085 X1=BX-C*(BX-AX)
34086 ENDIF
34087 AS1=PYALPS(X1**2)
34088 F1=ABS(X1-RGUT*AS1)
34089 AS2=PYALPS(X2**2)
34090 F2=ABS(X2-RGUT*AS2)
34091 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
34092 IF(F2.LT.F1) THEN
34093 X0=X1
34094 X1=X2
34095 X2=R*X1+C*X3
34096 F1=F2
34097 AS2=PYALPS(X2**2)
34098 F2=ABS(X2-RGUT*AS2)
34099 ELSE
34100 X3=X2
34101 X2=X1
34102 X1=R*X2+C*X0
34103 F2=F1
34104 AS1=PYALPS(X1**2)
34105 F1=ABS(X1-RGUT*AS1)
34106 ENDIF
34107 GOTO 100
34108 ENDIF
34109 IF(F1.LT.F2) THEN
34110 PYRNM3=X1
34111 XMIN=X1
34112 ELSE
34113 PYRNM3=X2
34114 XMIN=X2
34115 ENDIF
34116
34117 RETURN
34118 END
34119
34120C*********************************************************************
34121
34122C...PYEIG4
34123C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
34124C...Specific application: mixing in neutralino sector.
34125
34126 SUBROUTINE PYEIG4(A,W,Z)
34127
34128C...Double precision and integer declarations.
34129 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34130 IMPLICIT INTEGER(I-N)
34131 INTEGER PYK,PYCHGE,PYCOMP
34132
34133C...Arrays: in call and local.
34134 DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)
34135
34136C...Coefficients of fourth-degree equation from matrix.
34137C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
34138 B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
34139 B2=0D0
34140 DO 110 I=1,3
34141 DO 100 J=I+1,4
34142 B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
34143 100 CONTINUE
34144 110 CONTINUE
34145 B1=0D0
34146 B0=0D0
34147 DO 120 I=1,4
34148 I1=MOD(I,4)+1
34149 I2=MOD(I+1,4)+1
34150 I3=MOD(I+2,4)+1
34151 B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
34152 & A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
34153 & A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
34154 B0=B0+(-1D0)**(I+1)*A(1,I)*(
34155 & A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
34156 & A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
34157 & A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
34158 120 CONTINUE
34159
34160C...Coefficients of third-degree equation needed for
34161C...separation into two second-degree equations.
34162C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
34163 C2=-B2
34164 C1=B1*B3-4D0*B0
34165 C0=-B1**2-B0*B3**2+4D0*B0*B2
34166 CQ=C1/3D0-C2**2/9D0
34167 CR=C1*C2/6D0-C0/2D0-C2**3/27D0
34168 CQR=CQ**3+CR**2
34169
34170C...Cases with one or three real roots.
34171 IF(CQR.GE.0D0) THEN
34172 S1=(CR+SQRT(CQR))**(1D0/3D0)
34173 S2=(CR-SQRT(CQR))**(1D0/3D0)
34174 U=S1+S2-C2/3D0
34175 ELSE
34176 SABS=SQRT(-CQ)
34177 THE=ACOS(CR/SABS**3)/3D0
34178 SRE=SABS*COS(THE)
34179 U=2D0*SRE-C2/3D0
34180 ENDIF
34181
34182C...Find and solve two second-degree equations.
34183 P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
34184 P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
34185 Q1=U/2D0+SQRT(U**2/4D0-B0)
34186 Q2=U/2D0-SQRT(U**2/4D0-B0)
34187 IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
34188 QSAV=Q1
34189 Q1=Q2
34190 Q2=QSAV
34191 ENDIF
34192 X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
34193 X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
34194 X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
34195 X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)
34196
34197C...Order eigenvalues in asceding mass.
34198 W(1)=X(1)
34199 DO 150 I1=2,4
34200 DO 130 I2=I1-1,1,-1
34201 IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
34202 W(I2+1)=W(I2)
34203 130 CONTINUE
34204 140 W(I2+1)=X(I1)
34205 150 CONTINUE
34206
34207C...Find equation system for eigenvectors.
34208 DO 250 I=1,4
34209 DO 170 J1=1,4
34210 D(J1,J1)=A(J1,J1)-W(I)
34211 DO 160 J2=J1+1,4
34212 D(J1,J2)=A(J1,J2)
34213 D(J2,J1)=A(J2,J1)
34214 160 CONTINUE
34215 170 CONTINUE
34216
34217C...Find largest element in matrix.
34218 DAMAX=0D0
34219 DO 190 J1=1,4
34220 DO 180 J2=1,4
34221 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
34222 JA=J1
34223 JB=J2
34224 DAMAX=ABS(D(J1,J2))
34225 180 CONTINUE
34226 190 CONTINUE
34227
34228C...Subtract others by multiple of row selected above.
34229 DAMAX=0D0
34230 DO 210 J3=JA+1,JA+3
34231 J1=J3-4*((J3-1)/4)
34232 RL=D(J1,JB)/D(JA,JB)
34233 DO 200 J2=1,4
34234 D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
34235 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
34236 JC=J1
34237 JD=J2
34238 DAMAX=ABS(D(J1,J2))
34239 200 CONTINUE
34240 210 CONTINUE
34241
34242C...Do one more subtraction of a row.
34243 DAMAX=0D0
34244 DO 230 J3=JC+1,JC+3
34245 J1=J3-4*((J3-1)/4)
34246 IF(J1.EQ.JA) GOTO 230
34247 RL=D(J1,JD)/D(JC,JD)
34248 DO 220 J2=1,4
34249 IF(J2.EQ.JB) GOTO 220
34250 D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
34251 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
34252 JE=J1
34253 DAMAX=ABS(D(J1,J2))
34254 220 CONTINUE
34255 230 CONTINUE
34256
34257C...Construct unnormalized eigenvector.
34258 JF1=JD+1-4*(JD/4)
34259 JF2=JD+2-4*((JD+1)/4)
34260 IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
34261 IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
34262 E(JF1)=-D(JE,JF2)
34263 E(JF2)=D(JE,JF1)
34264 E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
34265 E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
34266 & D(JA,JB)
34267
34268C...Normalize and fill in final array.
34269 EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
34270 SGN=(-1D0)**INT(PYR(0)+0.5D0)
34271 DO 240 J=1,4
34272 Z(I,J)=SGN*E(J)/EA
34273 240 CONTINUE
34274 250 CONTINUE
34275
34276 RETURN
34277 END
34278
34279C*********************************************************************
34280
34281C...PYHGGM
34282C...Determines the Higgs boson mass spectrum using several inputs.
34283
34284 SUBROUTINE PYHGGM(ALPHA)
34285
34286C...Double precision and integer declarations.
34287 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34288 IMPLICIT INTEGER(I-N)
34289 INTEGER PYK,PYCHGE,PYCOMP
34290C...Parameter statement to help give large particle numbers.
34291 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
34292 &KEXCIT=4000000,KDIMEN=5000000)
34293C...Commonblocks.
34294 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34295 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34296 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
34297 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
34298 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/
34299
34300C...Local variables.
34301 DOUBLE PRECISION AT,AB,XMU,TANB
34302 DOUBLE PRECISION ALPHA
34303 INTEGER IHOPT
34304 DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
34305 DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
34306 DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
34307 DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
34308
34309 IHOPT=IMSS(4)
34310 IF(IHOPT.EQ.2) THEN
34311 ALPHA=RMSS(18)
34312 RETURN
34313 ENDIF
34314 AT=RMSS(16)
34315 AB=RMSS(15)
34316 DMGL=RMSS(3)
34317 XMU=RMSS(4)
34318 TANB=RMSS(5)
34319
34320 DMA=RMSS(19)
34321 DTANB=TANB
34322 DMQ=RMSS(10)
34323 DMUR=RMSS(12)
34324 DMDR=RMSS(11)
34325 DMTOP=PMAS(6,1)
34326 DMC=PMAS(PYCOMP(KSUSY1+37),1)
34327 DAU=AT
34328 DAD=AB
34329 DMU=XMU
34330 RMSS(40)=0D0
34331 RMSS(41)=0D0
34332
34333 IF(IHOPT.EQ.0) THEN
34334 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
34335 & DMHCH,DSA,DCA,DTANBA)
34336 ELSEIF(IHOPT.EQ.1) THEN
34337 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
34338 & DMHCH,DSA,DCA,DTANBA)
34339 CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU,
34340 & DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA,
34341 & DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA,DMGL,DDT,DDB)
34342 RMSS(40)=DDT
34343 RMSS(41)=DDB
34344 DMH=DMHP
34345 DHM=DHMP
34346 DMA=DAMP
34347 IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.5D-1) THEN
34348 WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
34349 WRITE(MSTU(11),*) ' STOP1 MASSES = ',
34350 & PMAS(PYCOMP(1000006),1),DSTOP2
34351 ENDIF
34352 IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.5D-1) THEN
34353 WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
34354 WRITE(MSTU(11),*) ' STOP2 MASSES = ',
34355 & PMAS(PYCOMP(2000006),1),DSTOP1
34356 ENDIF
34357 IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.5D-1) THEN
34358 WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
34359 WRITE(MSTU(11),*) ' SBOT1 MASSES = ',
34360 & PMAS(PYCOMP(1000005),1),DSBOT2
34361 ENDIF
34362 IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.5D-1) THEN
34363 WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
34364 WRITE(MSTU(11),*) ' SBOT2 MASSES = ',
34365 & PMAS(PYCOMP(2000005),1),DSBOT1
34366 ENDIF
34367
34368 ENDIF
34369
34370 ALPHA=ACOS(DCA)
34371
34372 PMAS(25,1)=DMH
34373 PMAS(35,1)=DHM
34374 PMAS(36,1)=DMA
34375 PMAS(37,1)=DMHCH
34376
34377 RETURN
34378 END
34379
34380C*********************************************************************
34381
34382C...PYSUBH
34383C...This routine computes the renormalization group improved
34384C...values of Higgs masses and couplings in the MSSM.
34385
34386C...Program based on the work by M. Carena, J.R. Espinosa,
34387c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
34388
34389C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
34390C...All masses in GeV units. MA is the CP-odd Higgs mass,
34391C...MTOP is the physical top mass, MQ and MUR are the soft
34392C...supersymmetry breaking mass parameters of left handed
34393C...and right handed stops respectively, AU and AD are the
34394C...stop and sbottom trilinear soft breaking terms,
34395C...respectively, and MU is the supersymmetric
34396C...Higgs mass parameter. We use the conventions from
34397C...the physics report of Haber and Kane: left right
34398C...stop mixing term proportional to (AU - MU/TANB)
34399C...We use as input TANB defined at the scale MTOP
34400
34401C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
34402C...where MH and HM are the lightest and heaviest CP-even
34403C...Higgs masses, MHCH is the charged Higgs mass and
34404C...ALPHA is the Higgs mixing angle
34405C...TANBA is the angle TANB at the CP-odd Higgs mass scale
34406
34407C...Range of validity:
34408C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
34409C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
34410C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
34411C...are the sbottom mass eigenvalues, respectively. This
34412C...range automatically excludes the existence of tachyons.
34413C...For the charged Higgs mass computation, the method is
34414C...valid if
34415C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
34416C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
34417C...where M_SUSY**2 is the average of the squared stop mass
34418C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
34419C...masses have been assumed to be of order of the stop ones
34420C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
34421
34422 SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
34423 &XMHCH,SA,CA,TANBA)
34424
34425C...Double precision and integer declarations.
34426 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34427 IMPLICIT INTEGER(I-N)
34428 INTEGER PYK,PYCHGE,PYCOMP
34429C...Parameter statement to help give large particle numbers.
34430 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
34431 &KEXCIT=4000000,KDIMEN=5000000)
34432C...Commonblocks.
34433 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34434 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34435 COMMON/PYHTRI/HHH(7)
34436 SAVE /PYDAT1/,/PYDAT2/
34437
34438C...Local variables.
34439 DOUBLE PRECISION PYALEM,PYALPS
34440 DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
34441 DOUBLE PRECISION XMHCH,SA,CA
34442 DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
34443 DOUBLE PRECISION Q02
34444 DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
34445 DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
34446 DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
34447 DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
34448 DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
34449 DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
34450 DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
34451 DOUBLE PRECISION AU2,XMU2,XMZ,XMS3
34452
34453 XMZ = PMAS(23,1)
34454 Q02=XMZ**2
34455 AEM=PYALEM(Q02)
34456 ALP1=AEM/(1D0-PARU(102))
34457 ALP2=AEM/PARU(102)
34458 ALPH3Z=PYALPS(Q02)
34459
34460 ALP1 = 0.0101D0
34461 ALP2 = 0.0337D0
34462 ALPH3Z = 0.12D0
34463
34464 V = 174.1D0
34465 PI = PARU(1)
34466 TANBA = TANB
34467 TANBT = TANB
34468
34469C...MBOTTOM(MTOP) = 3. GEV
34470 XMB = PYMRUN(5,XMTOP**2)
34471 ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z*
34472 &LOG(XMTOP**2/XMZ**2))
34473
34474C...RMTOP= RUNNING TOP QUARK MASS
34475 RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
34476 XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0
34477 T = LOG(XMS**2/XMTOP**2)
34478 SINB = TANB/((1D0 + TANB**2)**0.5D0)
34479 COSB = SINB/TANB
34480C...IF(MA.LE.XMTOP) TANBA = TANBT
34481 IF(XMA.GT.XMTOP)
34482 &TANBA = TANBT*(1D0-3D0/32D0/PI**2*
34483 &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
34484 &LOG(XMA**2/XMTOP**2))
34485
34486 SINBT = TANBT/SQRT(1D0 + TANBT**2)
34487 COSBT = 1D0/SQRT(1D0 + TANBT**2)
34488C COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
34489 G1 = SQRT(ALP1*4D0*PI)
34490 G2 = SQRT(ALP2*4D0*PI)
34491 G3 = SQRT(ALP3*4D0*PI)
34492 HU = RMTOP/V/SINBT
34493 HD = XMB/V/COSBT
34494 HU2=HU*HU
34495 HD2=HD*HD
34496 HU4=HU2*HU2
34497 HD4=HD2*HD2
34498 AU2=AU**2
34499 AD2=AD**2
34500 XMS2=XMS**2
34501 XMS3=XMS**3
34502 XMS4=XMS2*XMS2
34503 XMU2=XMU*XMU
34504 PI2=PI*PI
34505
34506 XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2)
34507 XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2)
34508 AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4
34509 &+ 3D0*(AU + AD)**2/XMS2)/6D0
34510 XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2)
34511 &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
34512 &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2)
34513 &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2
34514 &- 16D0*G3**2) *T/16D0/PI2)
34515 XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2)
34516 &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
34517 &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2)
34518 &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2
34519 &- 16D0*G3**2) *T/16D0/PI2)
34520 XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
34521 &(HU2 + HD2)*T/16D0/PI2)
34522 &+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
34523 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
34524 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
34525 &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0
34526 &- 16D0*G3**2) *T/16D0/PI2)
34527 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
34528 &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2
34529 &- 16D0*G3**2) *T/16D0/PI2)
34530 XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2)
34531 &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
34532 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
34533 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
34534 &XMS4)*
34535 &(1+ (6D0*HU2 -2D0* HD2
34536 &- 16D0*G3**2) *T/16D0/PI2)
34537 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
34538 &XMS4)*
34539 &(1+ (6D0*HD2 -2D0* HU2/2D0
34540 &- 16D0*G3**2) *T/16D0/PI2)
34541 XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) *
34542 &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2)
34543 &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) *
34544 &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2)
34545 XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) *
34546 &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
34547 &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) *
34548 &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
34549 XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) *
34550 &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
34551 &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) *
34552 &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
34553 HHH(1)=XLAM1
34554 HHH(2)=XLAM2
34555 HHH(3)=XLAM3
34556 HHH(4)=XLAM4
34557 HHH(5)=XLAM5
34558 HHH(6)=XLAM6
34559 HHH(7)=XLAM7
34560 TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 +
34561 &2D0* XLAM6*SINBT*COSBT
34562 &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT
34563 &+ XLAM5*COSBT**2)
34564 DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) +
34565 &XLAM6*COSBT**2
34566 &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 +
34567 &2D0* XLAM6* COSBT*SINBT
34568 &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
34569 &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 *
34570 &((XLAM1* COSBT**2 +2D0*
34571 &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 +
34572 &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2)
34573 &*SINBT**2
34574 &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3
34575 &+ XLAM4) + XLAM6*COSBT**2
34576 &+ XLAM7* SINBT**2))
34577
34578 XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0
34579 XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0
34580 XHM = SQRT(XHM2)
34581 XMH = SQRT(XMH2)
34582 XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2
34583 XMHCH = SQRT(XMHCH2)
34584
34585 SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) -
34586 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
34587 &XLAM6* COSBT*SINBT
34588 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
34589 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
34590 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/
34591 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0
34592
34593 COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) +
34594 &XLAM6*COSBT**2 + XLAM7* SINBT**2) -
34595 &XMA**2*SINBT*COSBT))/2D0**0.5D0/
34596 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)*
34597 &(((TRM2**2 - 4D0* DETM2)**0.5D0) -
34598 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
34599 &XLAM6* COSBT*SINBT
34600 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
34601 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
34602 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2))))
34603
34604 SA = -SINALP
34605 CA = -COSALP
34606
34607 100 CONTINUE
34608
34609 RETURN
34610 END
34611
34612C*********************************************************************
34613
34614C...PYPOLE
34615C...This subroutine computes the CP-even higgs and CP-odd pole
34616c...Higgs masses and mixing angles.
34617
34618C...Program based on the work by M. Carena, M. Quiros
34619C...and C.E.M. Wagner, "Effective potential methods and
34620C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
34621
34622C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
34623C...AT,AB,MU
34624C...where MCHI is the largest chargino mass, MA is the running
34625C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
34626C...expectaion values at the scale MTOP, MQ is the third generation
34627C...left handed squark mass parameter, MUR is the third generation
34628C...right handed stop mass parameter, MDR is the third generation
34629C...right handed sbottom mass parameter, MTOP is the pole top quark
34630C...mass; AT,AB are the soft supersymmetry breaking trilinear
34631C...couplings of the stop and sbottoms, respectively, and MU is the
34632C...supersymmetric mass parameter
34633
34634C...The parameter IHIGGS=0,1,2,3 corresponds to the number of
34635C...Higgses whose pole mass is computed. If IHIGGS=0 only running
34636C...masses are given, what makes the running of the program
34637c...much faster and it is quite generally a good approximation
34638c...(for a theoretical discussion see ref. above). If IHIGGS=1,
34639C...only the pole mass for H is computed. If IHIGGS=2, then h and H,
34640c...and if IHIGGS=3, then h,H,A polarizations are computed
34641
34642C...Output: MH and MHP which are the lightest CP-even Higgs running
34643C...and pole masses, respectively; HM and HMP are the heaviest CP-even
34644C...Higgs running and pole masses, repectively; SA and CA are the
34645C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
34646C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
34647C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
34648C...the value of TANB at the CP-odd Higgs mass scale
34649
34650C...This subroutine makes use of CERN library subroutine
34651C...integration package, which makes the computation of the
34652C...pole Higgs masses somewhat faster. We thank P. Janot for this
34653C...improvement. Those who are not able to call the CERN
34654C...libraries, please use the subroutine SUBHPOLE2.F, which
34655C...although somewhat slower, gives identical results
34656
34657 SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
34658 &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA,XMG,DT,DB)
34659
34660C...Double precision and integer declarations.
34661 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34662 IMPLICIT INTEGER(I-N)
34663
34664C...Parameters.
34665 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34666 SAVE /PYDAT1/
34667 INTEGER PYK,PYCHGE,PYCOMP
34668
34669C...Local variables.
34670 DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
34671 &SSBOT2(2),B(2,2),COUPB(2,2),
34672 &HCOUPT(2,2),HCOUPB(2,2),
34673 &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
34674
34675 DELTA(1,1) = 1D0
34676 DELTA(2,2) = 1D0
34677 DELTA(1,2) = 0D0
34678 DELTA(2,1) = 0D0
34679 V = 174.1D0
34680 XMZ=91.18D0
34681 PI=PARU(1)
34682 RXMT=PYMRUN(6,XMT**2)
34683 CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
34684 &XMU,XMH,HM,XMCH,SA,CA,SAB,CAB,TANBA,XMG,DT,DB)
34685
34686 SINB = TANB/(TANB**2+1D0)**0.5D0
34687 COSB = 1D0/(TANB**2+1D0)**0.5D0
34688 COS2B = SINB**2 - COSB**2
34689 SINBPA = SINB*CA + COSB*SA
34690 COSBPA = COSB*CA - SINB*SA
34691 RMBOT = PYMRUN(5,XMT**2)
34692 XMQ2 = XMQ**2
34693 XMUR2 = XMUR**2
34694 IF(XMUR.LT.0D0) XMUR2=-XMUR2
34695 XMDR2 = XMDR**2
34696 XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B
34697 XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
34698 IF(XMST11.LT.0D0) GOTO 500
34699 IF(XMST22.LT.0D0) GOTO 500
34700 XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B
34701 XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
34702 IF(XMSB11.LT.0D0) GOTO 500
34703 IF(XMSB22.LT.0D0) GOTO 500
34704C WMST11 = RXMT**2 + XMQ2
34705C WMST22 = RXMT**2 + XMUR2
34706 XMST12 = RXMT*(AT - XMU/TANB)
34707 XMSB12 = RMBOT*(AB - XMU*TANB)
34708
34709CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34710C...STOP EIGENVALUES CALCULATION
34711CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34712
34713 STOP12 = 0.5D0*(XMST11+XMST22) +
34714 &0.5D0*((XMST11+XMST22)**2 -
34715 &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
34716 STOP22 = 0.5D0*(XMST11+XMST22) -
34717 &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
34718 &XMST12**2))**0.5D0
34719
34720 IF(STOP22.LT.0D0) GOTO 500
34721 SSTOP2(1) = STOP12
34722 SSTOP2(2) = STOP22
34723 STOP1 = STOP12**0.5D0
34724 STOP2 = STOP22**0.5D0
34725C STOP1W = STOP1
34726C STOP2W = STOP2
34727
34728 IF(XMST12.EQ.0D0) XST11 = 1D0
34729 IF(XMST12.EQ.0D0) XST12 = 0D0
34730 IF(XMST12.EQ.0D0) XST21 = 0D0
34731 IF(XMST12.EQ.0D0) XST22 = 1D0
34732
34733 IF(XMST12.EQ.0D0) GOTO 110
34734
34735 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
34736 XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
34737 XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
34738 XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
34739
34740 110 T(1,1) = XST11
34741 T(2,2) = XST22
34742 T(1,2) = XST12
34743 T(2,1) = XST21
34744
34745 SBOT12 = 0.5D0*(XMSB11+XMSB22) +
34746 &0.5D0*((XMSB11+XMSB22)**2 -
34747 &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
34748 SBOT22 = 0.5D0*(XMSB11+XMSB22) -
34749 &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
34750 &XMSB12**2))**0.5D0
34751 IF(SBOT22.LT.0D0) GOTO 500
34752 SBOT1 = SBOT12**0.5D0
34753 SBOT2 = SBOT22**0.5D0
34754
34755 SSBOT2(1) = SBOT12
34756 SSBOT2(2) = SBOT22
34757
34758 IF(XMSB12.EQ.0D0) XSB11 = 1D0
34759 IF(XMSB12.EQ.0D0) XSB12 = 0D0
34760 IF(XMSB12.EQ.0D0) XSB21 = 0D0
34761 IF(XMSB12.EQ.0D0) XSB22 = 1D0
34762
34763 IF(XMSB12.EQ.0D0) GOTO 130
34764
34765 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
34766 XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
34767 XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
34768 XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
34769
34770 130 B(1,1) = XSB11
34771 B(2,2) = XSB22
34772 B(1,2) = XSB12
34773 B(2,1) = XSB21
34774
34775
34776 SINT = 0.2320D0
34777 SQR = DSQRT(2D0)
34778 VP = 174.1D0*SQR
34779
34780CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34781C...STARTING OF LIGHT HIGGS
34782CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34783
34784 IF(IHIGGS.EQ.0) GOTO 490
34785
34786 DO 150 I = 1,2
34787 DO 140 J = 1,2
34788 COUPT(I,J) =
34789 & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
34790 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
34791 & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
34792 & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
34793 & T(1,J)*T(2,I))
34794 140 CONTINUE
34795 150 CONTINUE
34796
34797
34798 DO 170 I = 1,2
34799 DO 160 J = 1,2
34800 COUPB(I,J) =
34801 & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
34802 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
34803 & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
34804 & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
34805 & B(1,J)*B(2,I))
34806 160 CONTINUE
34807 170 CONTINUE
34808
34809 PRUN = XMH
34810 EPS = 1D-4*PRUN
34811 ITER = 0
34812 180 ITER = ITER + 1
34813 DO 230 I3 = 1,3
34814
34815 PR(I3)=PRUN+(I3-2)*EPS/2
34816 P2=PR(I3)**2
34817 POLT = 0D0
34818 DO 200 I = 1,2
34819 DO 190 J = 1,2
34820 POLT = POLT + COUPT(I,J)**2*3D0*
34821 & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
34822 190 CONTINUE
34823 200 CONTINUE
34824
34825 POLB = 0D0
34826 DO 220 I = 1,2
34827 DO 210 J = 1,2
34828 POLB = POLB + COUPB(I,J)**2*3D0*
34829 & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
34830 210 CONTINUE
34831 220 CONTINUE
34832C RXMT2 = RXMT**2
34833 XMT2=XMT**2
34834
34835 POLTT =
34836 & 3D0*RXMT**2/8D0/PI**2/ V **2*
34837 & CA**2/SINB**2 *
34838 & (-2D0*XMT**2+0.5D0*P2)*
34839 & PYFINT(P2,XMT2,XMT2)
34840
34841 POL = POLT + POLB + POLTT
34842 POLAR(I3) = P2 - XMH**2 - POL
34843 230 CONTINUE
34844 DERIV = (POLAR(3)-POLAR(1))/EPS
34845 DRUN = - POLAR(2)/DERIV
34846 PRUN = PRUN + DRUN
34847 P2 = PRUN**2
34848 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 240
34849 GOTO 180
34850 240 CONTINUE
34851
34852 XMHP = DSQRT(P2)
34853
34854CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34855C...END OF LIGHT HIGGS
34856CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34857
34858 250 IF(IHIGGS.EQ.1) GOTO 490
34859
34860CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34861C... STARTING OF HEAVY HIGGS
34862CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34863
34864 DO 270 I = 1,2
34865 DO 260 J = 1,2
34866 HCOUPT(I,J) =
34867 & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
34868 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
34869 & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
34870 & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
34871 & T(1,J)*T(2,I))
34872 260 CONTINUE
34873 270 CONTINUE
34874
34875 DO 290 I = 1,2
34876 DO 280 J = 1,2
34877 HCOUPB(I,J) =
34878 & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
34879 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
34880 & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
34881 & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
34882 & B(1,J)*B(2,I))
34883 HCOUPB(I,J)=0D0
34884 280 CONTINUE
34885 290 CONTINUE
34886
34887 PRUN = HM
34888 EPS = 1D-4*PRUN
34889 ITER = 0
34890 300 ITER = ITER + 1
34891 DO 350 I3 = 1,3
34892 PR(I3)=PRUN+(I3-2)*EPS/2
34893 HP2=PR(I3)**2
34894
34895 HPOLT = 0D0
34896 DO 320 I = 1,2
34897 DO 310 J = 1,2
34898 HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
34899 & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
34900 310 CONTINUE
34901 320 CONTINUE
34902
34903 HPOLB = 0D0
34904 DO 340 I = 1,2
34905 DO 330 J = 1,2
34906 HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
34907 & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
34908 330 CONTINUE
34909 340 CONTINUE
34910
34911C RXMT2 = RXMT**2
34912 XMT2 = XMT**2
34913
34914 HPOLTT =
34915 & 3D0*RXMT**2/8D0/PI**2/ V **2*
34916 & SA**2/SINB**2 *
34917 & (-2D0*XMT**2+0.5D0*HP2)*
34918 & PYFINT(HP2,XMT2,XMT2)
34919
34920 HPOL = HPOLT + HPOLB + HPOLTT
34921 POLAR(I3) =HP2-HM**2-HPOL
34922 350 CONTINUE
34923 DERIV = (POLAR(3)-POLAR(1))/EPS
34924 DRUN = - POLAR(2)/DERIV
34925 PRUN = PRUN + DRUN
34926 HP2 = PRUN**2
34927 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 360
34928 GOTO 300
34929 360 CONTINUE
34930
34931
34932 370 CONTINUE
34933 HMP = HP2**0.5D0
34934
34935CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34936C... END OF HEAVY HIGGS
34937CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34938
34939 IF(IHIGGS.EQ.2) GOTO 490
34940
34941CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34942C...BEGINNING OF PSEUDOSCALAR HIGGS
34943CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34944
34945 DO 390 I = 1,2
34946 DO 380 J = 1,2
34947 ACOUPT(I,J) =
34948 & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
34949 & (T(1,I)*T(2,J) -T(1,J)*T(2,I))
34950 380 CONTINUE
34951 390 CONTINUE
34952 DO 410 I = 1,2
34953 DO 400 J = 1,2
34954 ACOUPB(I,J) =
34955 & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
34956 & (B(1,I)*B(2,J) -B(1,J)*B(2,I))
34957 400 CONTINUE
34958 410 CONTINUE
34959
34960 PRUN = XMA
34961 EPS = 1D-4*PRUN
34962 ITER = 0
34963 420 ITER = ITER + 1
34964 DO 470 I3 = 1,3
34965 PR(I3)=PRUN+(I3-2)*EPS/2
34966 AP2=PR(I3)**2
34967 APOLT = 0D0
34968 DO 440 I = 1,2
34969 DO 430 J = 1,2
34970 APOLT = APOLT + ACOUPT(I,J)**2*3D0*
34971 & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
34972 430 CONTINUE
34973 440 CONTINUE
34974 APOLB = 0D0
34975 DO 460 I = 1,2
34976 DO 450 J = 1,2
34977 APOLB = APOLB + ACOUPB(I,J)**2*3D0*
34978 & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
34979 450 CONTINUE
34980 460 CONTINUE
34981C RXMT2 = RXMT**2
34982 XMT2=XMT**2
34983 APOLTT =
34984 & 3D0*RXMT**2/8D0/PI**2/ V **2*
34985 & COSB**2/SINB**2 *
34986 & (-0.5D0*AP2)*
34987 & PYFINT(AP2,XMT2,XMT2)
34988 APOL = APOLT + APOLB + APOLTT
34989 POLAR(I3) = AP2 - XMA**2 -APOL
34990 470 CONTINUE
34991 DERIV = (POLAR(3)-POLAR(1))/EPS
34992 DRUN = - POLAR(2)/DERIV
34993 PRUN = PRUN + DRUN
34994 AP2 = PRUN**2
34995 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 480
34996 GOTO 420
34997 480 CONTINUE
34998
34999 AMP = DSQRT(AP2)
35000
35001CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35002C...END OF PSEUDOSCALAR HIGGS
35003CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35004
35005 IF(IHIGGS.EQ.3) GOTO 490
35006
35007 490 CONTINUE
35008 RETURN
35009 500 CONTINUE
35010 WRITE(MSTU(11),*) ' EXITING IN PYPOLE '
35011 WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
35012 WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
35013 WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
35014 STOP
35015 END
35016
35017C*********************************************************************
35018
35019C...PYRGHM
35020C...Auxiliary to PYPOLE.
35021
35022 SUBROUTINE PYRGHM(MCHI,MA,TANB,MQ,MUR,MD,MTOP,AU,AD,MU,
35023 * MHP,HMP,MCH,SA,CA,SAB,CAB,TANBA,MGLU,DELTAMT,DELTAMB)
35024 IMPLICIT DOUBLE PRECISION(A-H,L,M,O-Z)
35025 DIMENSION VH(2,2),M2(2,2),M2P(2,2)
35026C...Parameters.
35027 INTEGER MSTU,MSTJ
35028 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35029 SAVE /PYDAT1/
35030
35031 MZ = 91.18D0
35032 PI = PARU(1)
35033 V = 174.1D0
35034 ALPHA1 = 0.0101D0
35035 ALPHA2 = 0.0337D0
35036 ALPHA3Z = 0.12D0
35037 TANBA = TANB
35038 TANBT = TANB
35039C MBOTTOM(MTOP) = 3. GEV
35040 MB = PYMRUN(5,MTOP**2)
35041 ALPHA3 = ALPHA3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPHA3Z*
35042 *LOG(MTOP**2/MZ**2))
35043C RMTOP= RUNNING TOP QUARK MASS
35044 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
35045 TQ = LOG((MQ**2+MTOP**2)/MTOP**2)
35046 TU = LOG((MUR**2 + MTOP**2)/MTOP**2)
35047 TD = LOG((MD**2 + MTOP**2)/MTOP**2)
35048CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35049C
35050C NEW DEFINITION, TGLU.
35051C
35052CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35053 TGLU = LOG(MGLU**2/MTOP**2)
35054 SINB = TANB/DSQRT(1D0 + TANB**2)
35055 COSB = SINB/TANB
35056 IF(MA.GT.MTOP)
35057 *TANBA = TANB*(1D0-3D0/32D0/PI**2*
35058 *(RMTOP**2/V**2/SINB**2-MB**2/V**2/COSB**2)*
35059 *LOG(MA**2/MTOP**2))
35060 IF(MA.LT.MTOP.OR.MA.EQ.MTOP) TANBT = TANBA
35061 SINB = TANBT/SQRT(1D0 + TANBT**2)
35062 COSB = 1D0/DSQRT(1D0 + TANBT**2)
35063 G1 = SQRT(ALPHA1*4D0*PI)
35064 G2 = SQRT(ALPHA2*4D0*PI)
35065 G3 = SQRT(ALPHA3*4D0*PI)
35066 HU = RMTOP/V/SINB
35067 HD = MB/V/COSB
35068 CALL PYGFXX(MA,TANBA,MQ,MUR,MD,MTOP,AU,AD,MU,MGLU,VH,STOP1,STOP2,
35069 *SBOT1,SBOT2,DELTAMT,DELTAMB)
35070 IF(MQ.GT.MUR) TP = TQ - TU
35071 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TP = TU - TQ
35072 IF(MQ.GT.MUR) TDP = TU
35073 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TDP = TQ
35074 IF(MQ.GT.MD) TPD = TQ - TD
35075 IF(MQ.LT.MD.OR.MQ.EQ.MD) TPD = TD - TQ
35076 IF(MQ.GT.MD) TDPD = TD
35077 IF(MQ.LT.MD.OR.MQ.EQ.MD) TDPD = TQ
35078
35079 IF(MQ.GT.MD) DLAMBDA1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD
35080 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA1 = 3D0/32D0/PI**2*
35081 * HD**2*(G1**2/3D0+G2**2)*TPD
35082
35083 IF(MQ.GT.MUR) DLAMBDA2 =12D0/96D0/PI**2*G1**2*HU**2*TP
35084 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA2 = 3D0/32D0/PI**2*
35085 * HU**2*(-G1**2/3D0+G2**2)*TP
35086
35087CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35088C
35089C DLAMBDAP1 AND DLAMBDAP2 ARE THE NEW LOG CORRECTIONS DUE TO
35090C THE PRESENCE OF THE GLUINO MASS. THEY ARE IN GENERAL VERY SMALL,
35091C AND ONLY PRESENT IF THERE IS A HIERARCHY OF MASSES BETWEEN THE
35092C TWO STOPS.
35093C
35094C
35095CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35096
35097 DLAMBDAP2 = 0D0
35098 IF(MGLU.LT.MUR.OR.MGLU.LT.MQ) THEN
35099 IF(MQ.GT.MUR.AND.MGLU.GT.MUR) THEN
35100 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TGLU**2)
35101 ENDIF
35102
35103 IF(MQ.GT.MUR.AND.MGLU.LT.MUR) THEN
35104 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
35105 ENDIF
35106
35107 IF(MQ.GT.MUR.AND.MGLU.EQ.MUR) THEN
35108 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
35109 ENDIF
35110
35111 IF(MUR.GT.MQ.AND.MGLU.GT.MQ) THEN
35112 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TGLU**2)
35113 ENDIF
35114
35115 IF(MUR.GT.MQ.AND.MGLU.LT.MQ) THEN
35116 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
35117 ENDIF
35118
35119 IF(MUR.GT.MQ.AND.MGLU.EQ.MQ) THEN
35120 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
35121 ENDIF
35122 ENDIF
35123 DLAMBDA3 = 0D0
35124 DLAMBDA4 = 0D0
35125 IF(MQ.GT.MD) DLAMBDA3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD
35126 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA3 = 3D0/64D0/PI**2*HD**2*
35127 *(G2**2-G1**2/3D0)*TPD
35128 IF(MQ.GT.MUR) DLAMBDA3 = DLAMBDA3 -
35129 *1D0/16D0/PI**2*G1**2*HU**2*TP
35130 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA3 = DLAMBDA3 +
35131 * 3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP
35132 IF(MQ.LT.MUR) DLAMBDA4 = -3D0/32D0/PI**2*G2**2*HU**2*TP
35133 IF(MQ.LT.MD) DLAMBDA4 = DLAMBDA4 - 3D0/32D0/PI**2*G2**2*
35134 *HD**2*TPD
35135 LAMBDA1 = ((G1**2 + G2**2)/4D0)*
35136 * (1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2)
35137 *+(3D0*HD**4D0/16D0/PI**2) *TPD*(1D0
35138 *+ (3D0*HD**2/2D0 + HU**2/2D0
35139 *- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2)
35140 *+(3D0*HD**4D0/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0
35141 *- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAMBDA1
35142 LAMBDA2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2*
35143 *(TP + TDP)/8D0/PI**2)
35144 *+(3D0*HU**4D0/16D0/PI**2) *TP*(1D0
35145 *+ (3D0*HU**2/2D0 + HD**2/2D0
35146 *- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2)
35147 *+(3D0*HU**4D0/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0
35148 *- 8D0*G3**2) * TDP/16D0/PI**2) + DLAMBDA2 + DLAMBDAP2
35149 LAMBDA3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
35150 *(HU**2)*(TP + TDP)/16D0/PI**2 -3D0*
35151 *(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA3
35152 LAMBDA4 = (- G2**2/2D0)*(1D0
35153 *-3D0*(HU**2)*(TP + TDP)/16D0/PI**2
35154 *-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA4
35155
35156 LAMBDA5 = 0D0
35157 LAMBDA6 = 0D0
35158 LAMBDA7 = 0D0
35159
35160 M2(1,1) = 2D0*V**2*(LAMBDA1*COSB**2+2D0*LAMBDA6*
35161 *COSB*SINB + LAMBDA5*SINB**2) + MA**2*SINB**2
35162
35163 M2(2,2) = 2D0*V**2*(LAMBDA5*COSB**2+2D0*LAMBDA7*
35164 *COSB*SINB + LAMBDA2*SINB**2) + MA**2*COSB**2
35165 M2(1,2) = 2D0*V**2*(LAMBDA6*COSB**2+(LAMBDA3+LAMBDA4)*
35166 *COSB*SINB + LAMBDA7*SINB**2) - MA**2*SINB*COSB
35167
35168 M2(2,1) = M2(1,2)
35169CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35170CCC THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
35171CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35172
35173 MSSUSY=DSQRT(.5D0*(MQ**2+MUR**2)+MTOP**2)
35174
35175 IF(MCHI.GT.MSSUSY) GOTO 100
35176 IF(MCHI.LT.MTOP) MCHI=MTOP
35177
35178 TCHAR=LOG(MSSUSY**2/MCHI**2)
35179
35180 DELTAL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR
35181 DELTAL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4
35182 *+4D0/32D0/PI**2*G1**2*G2**2)*TCHAR
35183
35184 DELTAM112=2D0*DELTAL12*V**2*COSB**2
35185 DELTAM222=2D0*DELTAL12*V**2*SINB**2
35186 DELTAM122=2D0*DELTAL3P4*V**2*SINB*COSB
35187
35188 M2(1,1)=M2(1,1)+DELTAM112
35189 M2(2,2)=M2(2,2)+DELTAM222
35190 M2(1,2)=M2(1,2)+DELTAM122
35191 M2(2,1)=M2(2,1)+DELTAM122
35192
35193 100 CONTINUE
35194
35195CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35196CCC END OF CHARGINOS/NEUTRALINOS
35197CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35198
35199 DO 120 I = 1,2
35200 DO 110 J = 1,2
35201 M2P(I,J) = M2(I,J) + VH(I,J)
35202 110 CONTINUE
35203 120 CONTINUE
35204 TRM2P = M2P(1,1) + M2P(2,2)
35205 DETM2P = M2P(1,1)*M2P(2,2) - M2P(1,2)*M2P(2,1)
35206 MH2P = (TRM2P - DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
35207 HM2P = (TRM2P + DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
35208 HMP = DSQRT(HM2P)
35209 MCH2=MA**2+(LAMBDA5-LAMBDA4)*V**2
35210 MCH=DSQRT(MCH2)
35211 IF(MH2P.LT.0.) GOTO 130
35212 MHP = SQRT(MH2P)
35213 SIN2ALPHA = 2D0*M2P(1,2)/SQRT(TRM2P**2-4D0*DETM2P)
35214 COS2ALPHA = (M2P(1,1)-M2P(2,2))/SQRT(TRM2P**2-4D0*DETM2P)
35215 IF(COS2ALPHA.GE.0.) THEN
35216 ALPHA = ASIN(SIN2ALPHA)/2D0
35217 ELSE
35218 ALPHA = -PI/2D0-ASIN(SIN2ALPHA)/2D0
35219 ENDIF
35220 SA = SIN(ALPHA)
35221 CA = COS(ALPHA)
35222CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35223C
35224C HERE THE VALUES OF SAB AND CAB ARE DEFINED, IN ORDER
35225C TO DEFINE THE NEW COUPLINGS OF THE LIGHTEST AND
35226C HEAVY CP-EVEN HIGGS TO THE BOTTOM QUARK.
35227C
35228C
35229CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35230 SAB = SA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0+CA/SA/TANB))
35231 CAB = CA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0-SA/CA/TANB))
35232 130 CONTINUE
35233 RETURN
35234 END
35235
35236C*********************************************************************
35237
35238C...PYGFXX
35239C...Auxiliary to PYRGHM.
35240
35241 SUBROUTINE PYGFXX(MA,TANB,MQ,MUR,MD,MTOP,AT,AB,XMU,XMGL,VH,
35242 * STOP1,STOP2,SBOT1,SBOT2,DELTAMT,DELTAMB)
35243 IMPLICIT DOUBLE PRECISION(A-H,M,O-Z)
35244 DIMENSION VH(2,2),VH3T(2,2),VH3B(2,2),AL(2,2)
35245C...Commonblocks.
35246 INTEGER MSTU,MSTJ,KCHG
35247 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35248 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35249 SAVE /PYDAT1/,/PYDAT2/
35250
35251 G(X,Y) = 2.D0 - (X+Y)/(X-Y)*DLOG(X/Y)
35252
35253 T(X,Y,Z) = (X**2*Y**2*LOG(X**2/Y**2) + X**2*Z**2*LOG(Z**2/X**2)
35254 * + Y**2*Z**2*LOG(Y**2/Z**2))/((X**2-Y**2)*(Y**2-Z**2)*(X**2-Z**2))
35255
35256 IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0
35257 MQ2 = MQ**2
35258 MUR2 = MUR**2
35259 MD2 = MD**2
35260 TANBA = TANB
35261 SINBA = TANBA/DSQRT(TANBA**2+1D0)
35262 COSBA = SINBA/TANBA
35263
35264 SINB = TANB/DSQRT(TANB**2+1D0)
35265 COSB = SINB/TANB
35266
35267 PI = PARU(1)
35268 MZ = PMAS(23,1)
35269 MW = PMAS(24,1)
35270 SW = 1D0-MW**2/MZ**2
35271 V = 174.1D0
35272
35273 ALPHA3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(MTOP**2/MZ**2))
35274 G2 = DSQRT(0.0336D0*4D0*PI)
35275 G1 = DSQRT(0.0101D0*4D0*PI)
35276
35277 IF(MQ.GT.MUR) MST = MQ
35278 IF(MUR.GT.MQ.OR.MUR.EQ.MQ) MST = MUR
35279
35280 MSUSYT = DSQRT(MST**2 + MTOP**2)
35281
35282 IF(MQ.GT.MD) MSB = MQ
35283 IF(MD.GT.MQ.OR.MD.EQ.MQ) MSB = MD
35284
35285 MB = PYMRUN(5,MSB**2)
35286 MSUSYB = DSQRT(MSB**2 + MB**2)
35287 TT = LOG(MSUSYT**2/MTOP**2)
35288 TB = LOG(MSUSYB**2/MTOP**2)
35289
35290 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
35291 HT = RMTOP/(V*SINB)
35292 HTST = RMTOP/V
35293 HB = MB/V/COSB
35294 G32 = ALPHA3*4D0*PI
35295 BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2
35296 BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2
35297 AL2 = 3D0/8D0/PI**2*HT**2
35298C BT2ST = -(8.*G32 - 9.*HTST**2/2.)/(4.*PI)**2
35299C ALST = 3./8./PI**2*HTST**2
35300 AL1 = 3D0/8D0/PI**2*HB**2
35301
35302 AL(1,1) = AL1
35303 AL(1,2) = (AL2+AL1)/2D0
35304 AL(2,1) = (AL2+AL1)/2D0
35305 AL(2,2) = AL2
35306
35307 IF(MA.GT.MTOP) THEN
35308 VI = V*(1D0 + 3D0/32D0/PI**2*HTST**2*
35309 * LOG(MTOP**2/MA**2))
35310 H1I = VI* COSBA
35311 H2I = VI*SINBA
35312 H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYT**2))**.25D0
35313 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYT**2))**.25D0
35314 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYB**2))**.25D0
35315 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYB**2))**.25D0
35316 ELSE
35317 VI = V
35318 H1I = VI*COSB
35319 H2I = VI*SINB
35320 H1T=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYT**2))**.25D0
35321 H2T=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYT**2))**.25D0
35322 H1B=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYB**2))**.25D0
35323 H2B=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYB**2))**.25D0
35324 ENDIF
35325
35326 TANBST = H2T/H1T
35327 SINBT = TANBST/DSQRT(1D0+TANBST**2)
35328
35329 TANBSB = H2B/H1B
35330 SINBB = TANBSB/DSQRT(1D0+TANBSB**2)
35331 COSBB = SINBB/TANBSB
35332
35333 DELTAMT = 0D0
35334 DELTAMB = 0D0
35335
35336 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
35337 MTOP2 = DSQRT(MTOP4)
35338 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
35339 * /(1D0+DELTAMB)**4
35340 MBOT2 = DSQRT(MBOT4)
35341
35342 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
35343 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
35344 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
35345 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
35346 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
35347 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
35348 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
35349 * MQ2 - MUR2)**2*0.25D0
35350 * + MTOP2*(AT-XMU/TANBST)**2)
35351 IF(STOP22.LT.0.) GOTO 120
35352 SBOT12 = (MQ2 + MD2)*.5D0
35353 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
35354 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
35355 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
35356 SBOT22 = (MQ2 + MD2)*.5D0
35357 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
35358 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
35359 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
35360 IF(SBOT22.LT.0.) SBOT22 = 10000D0
35361
35362 STOP1 = DSQRT(STOP12)
35363 STOP2 = DSQRT(STOP22)
35364 SBOT1 = DSQRT(SBOT12)
35365 SBOT2 = DSQRT(SBOT22)
35366
35367CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35368C
35369C HERE IS THE DEFINITION OF DELTAMB AND DELTAMT, WHICH
35370C ARE THE VERTEX CORRECTIONS TO THE BOTTOM AND TOP QUARK
35371C MASS, KEEPING THE DOMINANT QCD AND TOP YUKAWA COUPLING
35372C INDUCED CORRECTIONS.
35373C
35374CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35375
35376 X=SBOT1
35377 Y=SBOT2
35378 Z=XMGL
35379 IF(X.EQ.Y) X = X - 0.00001D0
35380 IF(X.EQ.Z) X = X - 0.00002D0
35381 IF(Y.EQ.Z) Y = Y - 0.00003D0
35382
35383 T1=T(X,Y,Z)
35384 X=STOP1
35385 Y=STOP2
35386 Z=XMU
35387 IF(X.EQ.Y) X = X - 0.00001D0
35388 IF(X.EQ.Z) X = X - 0.00002D0
35389 IF(Y.EQ.Z) Y = Y - 0.00003D0
35390 T2=T(X,Y,Z)
35391 DELTAMB = -2*ALPHA3/3D0/PI*XMGL*(AB-XMU*TANB)*T1
35392 * + HT**2/(4D0*PI)**2*(AT-XMU/TANB)*XMU*TANB*T2
35393 X=STOP1
35394 Y=STOP2
35395 Z=XMGL
35396 IF(X.EQ.Y) X = X - 0.00001D0
35397 IF(X.EQ.Z) X = X - 0.00002D0
35398 IF(Y.EQ.Z) Y = Y - 0.00003D0
35399 T3=T(X,Y,Z)
35400 DELTAMT = -2D0*ALPHA3/3D0/PI*(AT-XMU/TANB)*XMGL*T3
35401
35402CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35403C
35404C HERE THE NEW VALUES OF THE TOP AND BOTTOM QUARK MASSES AT
35405C THE SCALE MS ARE DEFINED, TO BE USED IN THE EFFECTIVE
35406C POTENTIAL APPROXIMATION. THEY ARE JUST THE OLD ONES, BUT
35407C INCLUDING THE FINITE CORRECTIONS DELTAMT AND DELTAMB.
35408C THE DELTAMB CORRECTIONS CAN BECOME LARGE AND ARE RESUMMED
35409C TO ALL ORDERS, AS SUGGESTED IN THE TWO RECENT WORKS BY M. CARENA,
35410C S. MRENNA AND C.E.M. WAGNER, AS WELL AS IN THE WORK BY M. CARENA,
35411C D. GARCIA, U. NIERSTE AND C.E.M. WAGNER, TO APPEAR. THE TOP
35412C QUARK MASS CORRECTIONS ARE SMALL AND ARE KEPT IN THE PERTURBATIVE
35413C FORMULATION. THE FUNCTION T(X,Y,Z) IS NECESSARY FOR THE
35414C CALCULATION. THE ENTRIES ARE MASSES AND NOT THEIR SQUARES !
35415C
35416C
35417CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35418
35419 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
35420 MTOP2 = DSQRT(MTOP4)
35421 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
35422 * /(1D0+DELTAMB)**4
35423 MBOT2 = DSQRT(MBOT4)
35424
35425 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
35426 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
35427 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
35428 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
35429 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
35430 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
35431 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
35432 * MQ2 - MUR2)**2*0.25D0
35433 * + MTOP2*(AT-XMU/TANBST)**2)
35434
35435 IF(STOP22.LT.0.) GOTO 120
35436 SBOT12 = (MQ2 + MD2)*.5D0
35437 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
35438 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
35439 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
35440 SBOT22 = (MQ2 + MD2)*.5D0
35441 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
35442 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
35443 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
35444 IF(SBOT22.LT.0.) GOTO 120
35445
35446
35447 STOP1 = DSQRT(STOP12)
35448 STOP2 = DSQRT(STOP22)
35449 SBOT1 = DSQRT(SBOT12)
35450 SBOT2 = DSQRT(SBOT22)
35451
35452CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35453CCC D-TERMS
35454CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35455 STW=SW
35456
35457 F1T=(MQ2-MUR2)/(STOP12-STOP22)*(.5D0-4D0/3D0*STW)*
35458 * LOG(STOP1/STOP2)
35459 * +(.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(MQ2+MTOP2))
35460 * + 2D0/3D0*STW*LOG(STOP1*STOP2/(MUR2+MTOP2))
35461
35462 F1B=(MQ2-MD2)/(SBOT12-SBOT22)*(-.5D0+2D0/3D0*STW)*
35463 * LOG(SBOT1/SBOT2)
35464 * +(-.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(MQ2+MBOT2))
35465 * - 1D0/3D0*STW*LOG(SBOT1*SBOT2/(MD2+MBOT2))
35466
35467 F2T=DSQRT(MTOP2)*(AT-XMU/TANBST)/(STOP12-STOP22)*
35468 * (-.5D0*LOG(STOP12/STOP22)
35469 * +(4D0/3D0*STW-.5D0)*(MQ2-MUR2)/(STOP12-STOP22)*
35470 * G(STOP12,STOP22))
35471
35472 F2B=DSQRT(MBOT2)*(AB-XMU*TANBSB)/(SBOT12-SBOT22)*
35473 * (.5D0*LOG(SBOT12/SBOT22)
35474 * +(-2D0/3D0*STW+.5D0)*(MQ2-MD2)/(SBOT12-SBOT22)*
35475 * G(SBOT12,SBOT22))
35476
35477 VH3B(1,1) = MBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/
35478 * (MQ2+MBOT2)/(MD2+MBOT2))
35479 * + 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))*
35480 * LOG(SBOT1**2/SBOT2**2)) +
35481 * MBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/
35482 * (SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22)
35483
35484 VH3T(1,1) =
35485 * MTOP4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2
35486 * -STOP2**2))**2*G(STOP12,STOP22)
35487
35488 VH3B(1,1)=VH3B(1,1)+
35489 * MZ**2*(2*MBOT2*F1B-DSQRT(MBOT2)*AB*F2B)
35490
35491 VH3T(1,1) = VH3T(1,1) +
35492 * MZ**2*(DSQRT(MTOP2)*XMU/TANBST*F2T)
35493
35494 VH3T(2,2) = MTOP4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/
35495 * (MQ2+MTOP2)/(MUR2+MTOP2))
35496 * + 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))*
35497 * LOG(STOP1**2/STOP2**2)) +
35498 * MTOP4/(SINBT**2)*(AT*(AT-XMU/TANBST)/
35499 * (STOP1**2-STOP2**2))**2*G(STOP12,STOP22)
35500
35501 VH3B(2,2) =
35502 * MBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2
35503 * -SBOT2**2))**2*G(SBOT12,SBOT22)
35504
35505 VH3T(2,2)=VH3T(2,2)+
35506 * MZ**2*(-2*MTOP2*F1T+DSQRT(MTOP2)*AT*F2T)
35507 VH3B(2,2) = VH3B(2,2) -MZ**2*DSQRT(MBOT2)*XMU*TANBSB*F2B
35508 VH3T(1,2) = -
35509 * MTOP4/(SINBT**2)*XMU*(AT-XMU/TANBST)/
35510 * (STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT*
35511 * (AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22))
35512
35513 VH3B(1,2) =
35514 * - MBOT4/(COSBB**2)*XMU*(AB-XMU*TANBSB)/
35515 * (SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB*
35516 * (AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22))
35517
35518
35519 VH3T(1,2)=VH3T(1,2) +
35520 *MZ**2*(MTOP2/TANBST*F1T-DSQRT(MTOP2)*(AT/TANBST+XMU)/2D0*F2T)
35521
35522 VH3B(1,2)=VH3B(1,2) +
35523 *MZ**2*(-MBOT2*TANBSB*F1B+DSQRT(MBOT2)*(AB*TANBSB+XMU)/2D0*F2B)
35524
35525 VH3T(2,1) = VH3T(1,2)
35526 VH3B(2,1) = VH3B(1,2)
35527
35528C TQ = LOG((MQ2 + MTOP2)/MTOP2)
35529C TU = LOG((MUR2+MTOP2)/MTOP2)
35530C TQD = LOG((MQ2 + MB**2)/MB**2)
35531C TD = LOG((MD2+MB**2)/MB**2)
35532
35533 DO 110 I = 1,2
35534 DO 100 J = 1,2
35535 VH(I,J) =
35536 * 6D0/(8D0*PI**2*(H1T**2+H2T**2))
35537 * *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) +
35538 * 6D0/(8D0*PI**2*(H1B**2+H2B**2))
35539 * *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0)
35540 100 CONTINUE
35541 110 CONTINUE
35542
35543 GOTO 150
35544 120 DO 140 I =1,2
35545 DO 130 J = 1,2
35546 VH(I,J) = -1D15
35547 130 CONTINUE
35548 140 CONTINUE
35549
35550
35551 150 RETURN
35552 END
35553
35554
35555
35556
35557
35558C*********************************************************************
35559
35560C...PYFINT
35561C...Auxiliary routine to PYPOLE for SUSY Higgs calculations.
35562
35563 FUNCTION PYFINT(A,B,C)
35564
35565C...Double precision and integer declarations.
35566 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35567 IMPLICIT INTEGER(I-N)
35568 INTEGER PYK,PYCHGE,PYCOMP
35569C...Commonblock.
35570 COMMON/PYINTS/XXM(20)
35571 SAVE/PYINTS/
35572
35573C...Local variables.
35574 EXTERNAL PYFISB
35575 DOUBLE PRECISION PYFISB
35576
35577 XXM(1)=A
35578 XXM(2)=B
35579 XXM(3)=C
35580 XLO=0D0
35581 XHI=1D0
35582 PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3)
35583
35584 RETURN
35585 END
35586
35587C*********************************************************************
35588
35589C...PYFISB
35590C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
35591
35592 FUNCTION PYFISB(X)
35593
35594C...Double precision and integer declarations.
35595 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35596 IMPLICIT INTEGER(I-N)
35597 INTEGER PYK,PYCHGE,PYCOMP
35598C...Commonblock.
35599 COMMON/PYINTS/XXM(20)
35600 SAVE/PYINTS/
35601
35602 PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/
35603 &(X*(XXM(2)-XXM(3))+XXM(3)))
35604
35605 RETURN
35606 END
35607
35608C*********************************************************************
35609
35610C...PYSFDC
35611C...Calculates decays of sfermions.
35612
35613 SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT)
35614
35615C...Double precision and integer declarations.
35616 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35617 IMPLICIT INTEGER(I-N)
35618 INTEGER PYK,PYCHGE,PYCOMP
35619C...Parameter statement to help give large particle numbers.
35620 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
35621 &KEXCIT=4000000,KDIMEN=5000000)
35622C...Commonblocks.
35623 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35624 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35625 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
35626 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
35627 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
35628 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
35629
35630C...Local variables.
35631 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2)
35632 COMPLEX*16 CAL,CAR,CBL,CBR,CALP,CARP,CBLP,CBRP,CA,CB
35633 INTEGER KFIN,KCIN
35634 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,AXMJ
35635 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
35636 DOUBLE PRECISION PYLAMF,XL
35637 DOUBLE PRECISION TANW,XW,AEM,C1,AS
35638 DOUBLE PRECISION AL,AR,BL,BR
35639 DOUBLE PRECISION CH1,CH2,CH3,CH4
35640 DOUBLE PRECISION XMBOT,XMTOP
35641 DOUBLE PRECISION XLAM(0:400)
35642 INTEGER IDLAM(400,3)
35643 INTEGER LKNT,IX,ILR,IDU,J,I,IKNT,IFL,II
35644 DOUBLE PRECISION SR2
35645 DOUBLE PRECISION CBETA,SBETA
35646 DOUBLE PRECISION CW
35647 DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
35648 DOUBLE PRECISION COSA,SINA,TANB
35649 DOUBLE PRECISION PYALEM,PI,PYALPS,EI
35650 DOUBLE PRECISION GHRR,GHLL,GHLR,XMB,BLR
35651 INTEGER IG,KF1,KF2
35652 INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
35653 DATA IGG/23,25,35,36/
35654 DATA PI/3.141592654D0/
35655 DATA SR2/1.4142136D0/
35656 DATA KFNCHI/1000022,1000023,1000025,1000035/
35657 DATA KFCCHI/1000024,1000037/
35658
35659C...COUNT THE NUMBER OF DECAY MODES
35660 LKNT=0
35661
35662C...NO NU_R DECAYS
35663 IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR.
35664 &KFIN.EQ.KSUSY2+16) RETURN
35665
35666 XMW=PMAS(24,1)
35667 XMW2=XMW**2
35668 XMZ=PMAS(23,1)
35669 XW=PARU(102)
35670 TANW = SQRT(XW/(1D0-XW))
35671 CW=SQRT(1D0-XW)
35672
35673 DO 110 I=1,4
35674 DO 100 J=1,4
35675 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
35676 100 CONTINUE
35677 110 CONTINUE
35678 DO 130 I=1,2
35679 DO 120 J=1,2
35680 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
35681 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
35682 120 CONTINUE
35683 130 CONTINUE
35684
35685C...KCIN
35686 KCIN=PYCOMP(KFIN)
35687C...ILR is 1 for left and 2 for right.
35688 ILR=KFIN/KSUSY1
35689C...IFL is matching non-SUSY flavour.
35690 IFL=MOD(KFIN,KSUSY1)
35691C...IDU is weak isospin, 1 for down and 2 for up.
35692 IDU=2-MOD(IFL,2)
35693
35694 XMI=PMAS(KCIN,1)
35695 XMI2=XMI**2
35696 AEM=PYALEM(XMI2)
35697 AS =PYALPS(XMI2)
35698 C1=AEM/XW
35699 XMI3=XMI**3
35700 EI=KCHG(IFL,1)/3D0
35701
35702 XMBOT=PYMRUN(5,XMI2)
35703 XMTOP=PYMRUN(6,XMI2)
35704
35705 TANB=RMSS(5)
35706 BETA=ATAN(TANB)
35707 ALFA=RMSS(18)
35708 CBETA=COS(BETA)
35709 SBETA=TANB*CBETA
35710 SINA=SIN(ALFA)
35711 COSA=COS(ALFA)
35712 XMU=-RMSS(4)
35713 ATRIT=RMSS(16)
35714 ATRIB=RMSS(15)
35715 ATRIL=RMSS(17)
35716
35717C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
35718
35719 IF(IMSS(11).EQ.1) THEN
35720 XMP=RMSS(29)
35721 IDG=39+KSUSY1
35722 XMGR=PMAS(PYCOMP(IDG),1)
35723 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
35724 IF(IFL.EQ.5) THEN
35725 XMF=XMBOT
35726 ELSEIF(IFL.EQ.6) THEN
35727 XMF=XMTOP
35728 ELSE
35729 XMF=PMAS(IFL,1)
35730 ENDIF
35731 IF(XMI.GT.XMGR+XMF) THEN
35732 LKNT=LKNT+1
35733 IDLAM(LKNT,1)=IDG
35734 IDLAM(LKNT,2)=IFL
35735 IDLAM(LKNT,3)=0
35736 XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4
35737 ENDIF
35738 ENDIF
35739
35740C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
35741
35742C...CHARGED DECAYS:
35743 DO 140 IX=1,2
35744C...DI -> U CHI1-,CHI2-
35745 IF(IDU.EQ.1) THEN
35746 XMFP=PMAS(IFL+1,1)
35747 XMF =PMAS(IFL,1)
35748C...UI -> D CHI1+,CHI2+
35749 ELSE
35750 XMFP=PMAS(IFL-1,1)
35751 XMF =PMAS(IFL,1)
35752 ENDIF
35753 XMJ=SMW(IX)
35754 AXMJ=ABS(XMJ)
35755 IF(XMI.GE.AXMJ+XMFP) THEN
35756 XMA2=XMJ**2
35757 XMB2=XMFP**2
35758 IF(IDU.EQ.2) THEN
35759 IF(IFL.EQ.6) THEN
35760 XMFP=XMBOT
35761 XMF =XMTOP
35762 ELSEIF(IFL.LT.6) THEN
35763 XMF=0D0
35764 XMFP=0D0
35765 ENDIF
35766 CBL=VMIXC(IX,1)
35767 CAL=-XMFP*UMIXC(IX,2)/SR2/XMW/CBETA
35768 CBR=-XMF*VMIXC(IX,2)/SR2/XMW/SBETA
35769 CAR=0D0
35770 ELSE
35771 IF(IFL.EQ.5) THEN
35772 XMF =XMBOT
35773 XMFP=XMTOP
35774 ELSEIF(IFL.LT.5) THEN
35775 XMF=0D0
35776 XMFP=0D0
35777 ENDIF
35778 CBL=UMIXC(IX,1)
35779 CAL=-XMFP*VMIXC(IX,2)/SR2/XMW/SBETA
35780 CBR=-XMF*UMIXC(IX,2)/SR2/XMW/CBETA
35781 CAR=0D0
35782 ENDIF
35783
35784 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
35785 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
35786 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
35787 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
35788 CAL=CALP
35789 CBL=CBLP
35790 CAR=CARP
35791 CBR=CBRP
35792
35793C...F1 -> F` CHI
35794 IF(ILR.EQ.1) THEN
35795 CA=CAL
35796 CB=CBL
35797C...F2 -> F` CHI
35798 ELSE
35799 CA=CAR
35800 CB=CBR
35801 ENDIF
35802 LKNT=LKNT+1
35803 XL=PYLAMF(XMI2,XMA2,XMB2)
35804C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
35805 XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
35806 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMFP)
35807 IDLAM(LKNT,3)=0
35808 IF(IDU.EQ.1) THEN
35809 IDLAM(LKNT,1)=-KFCCHI(IX)
35810 IDLAM(LKNT,2)=IFL+1
35811 ELSE
35812 IDLAM(LKNT,1)=KFCCHI(IX)
35813 IDLAM(LKNT,2)=IFL-1
35814 ENDIF
35815 ENDIF
35816 140 CONTINUE
35817
35818C...NEUTRAL DECAYS
35819 DO 150 IX=1,4
35820C...DI -> D CHI10
35821 XMF=PMAS(IFL,1)
35822 XMJ=SMZ(IX)
35823 AXMJ=ABS(XMJ)
35824 IF(XMI.GE.AXMJ+XMF) THEN
35825 XMA2=XMJ**2
35826 XMB2=XMF**2
35827 IF(IDU.EQ.1) THEN
35828 IF(IFL.EQ.5) THEN
35829 XMF=XMBOT
35830 ELSEIF(IFL.LT.5) THEN
35831 XMF=0D0
35832 ENDIF
35833 CBL=-ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI+1)
35834 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
35835 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
35836 CBR=CAL
35837 ELSE
35838 IF(IFL.EQ.6) THEN
35839 XMF=XMTOP
35840 ELSEIF(IFL.LT.5) THEN
35841 XMF=0D0
35842 ENDIF
35843 CBL=ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-1)
35844 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
35845 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
35846 CBR=CAL
35847 ENDIF
35848
35849 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
35850 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
35851 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
35852 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
35853 CAL=CALP
35854 CBL=CBLP
35855 CAR=CARP
35856 CBR=CBRP
35857
35858C...F1 -> F CHI
35859 IF(ILR.EQ.1) THEN
35860 CA=CAL
35861 CB=CBL
35862C...F2 -> F CHI
35863 ELSE
35864 CA=CAR
35865 CB=CBR
35866 ENDIF
35867 LKNT=LKNT+1
35868 XL=PYLAMF(XMI2,XMA2,XMB2)
35869C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
35870 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
35871 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMF)
35872 IDLAM(LKNT,1)=KFNCHI(IX)
35873 IDLAM(LKNT,2)=IFL
35874 IDLAM(LKNT,3)=0
35875 ENDIF
35876 150 CONTINUE
35877
35878C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
35879C...IG=23,25,35,36
35880 DO 160 II=1,4
35881 IG=IGG(II)
35882 IF(ILR.EQ.1) GOTO 160
35883 XMB=PMAS(IG,1)
35884 XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1)
35885 IF(XMI.LT.XMSF1+XMB) GOTO 160
35886 IF(IG.EQ.23) THEN
35887 BL=-SIGN(.5D0,EI)/CW+EI*XW/CW
35888 BR=EI*XW/CW
35889 BLR=0D0
35890 ELSEIF(IG.EQ.25) THEN
35891 IF(IFL.EQ.5) THEN
35892 XMF=XMBOT
35893 ELSEIF(IFL.EQ.6) THEN
35894 XMF=XMTOP
35895 ELSEIF(IFL.LT.5) THEN
35896 XMF=0D0
35897 ELSE
35898 XMF=PMAS(IFL,1)
35899 ENDIF
35900 IF(IDU.EQ.2) THEN
35901 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
35902 & XMF**2/XMW*COSA/SBETA
35903 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
35904 & XMF**2/XMW*COSA/SBETA
35905 ELSE
35906 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
35907 & XMF**2/XMW*(-SINA)/CBETA
35908 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
35909 & XMF**2/XMW*(-SINA)/CBETA
35910 ENDIF
35911 IF(IFL.EQ.5) THEN
35912 AT=ATRIB
35913 ELSEIF(IFL.EQ.6) THEN
35914 AT=ATRIT
35915 ELSEIF(IFL.EQ.15) THEN
35916 AT=ATRIL
35917 ELSE
35918 AT=0D0
35919 ENDIF
35920C.........need to complexify
35921 IF(IDU.EQ.2) THEN
35922 GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+
35923 & AT*COSA)
35924 ELSE
35925 GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA-
35926 & AT*SINA)
35927 ENDIF
35928 BL=GHLL
35929 BR=GHRR
35930 BLR=-GHLR
35931 ELSEIF(IG.EQ.35) THEN
35932 IF(IFL.EQ.5) THEN
35933 XMF=XMBOT
35934 ELSEIF(IFL.EQ.6) THEN
35935 XMF=XMTOP
35936 ELSEIF(IFL.LT.5) THEN
35937 XMF=0D0
35938 ELSE
35939 XMF=PMAS(IFL,1)
35940 ENDIF
35941 IF(IDU.EQ.2) THEN
35942 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
35943 & XMF**2/XMW*SINA/SBETA
35944 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
35945 & XMF**2/XMW*SINA/SBETA
35946 ELSE
35947 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
35948 & XMF**2/XMW*COSA/CBETA
35949 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
35950 & XMF**2/XMW*COSA/CBETA
35951 ENDIF
35952 IF(IFL.EQ.5) THEN
35953 AT=ATRIB
35954 ELSEIF(IFL.EQ.6) THEN
35955 AT=ATRIT
35956 ELSEIF(IFL.EQ.15) THEN
35957 AT=ATRIL
35958 ELSE
35959 AT=0D0
35960 ENDIF
35961C.........Need to complexify
35962 IF(IDU.EQ.2) THEN
35963 GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+
35964 & AT*SINA)
35965 ELSE
35966 GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+
35967 & AT*COSA)
35968 ENDIF
35969 BL=GHLL
35970 BR=GHRR
35971 BLR=GHLR
35972 ELSEIF(IG.EQ.36) THEN
35973 GHLL=0D0
35974 GHRR=0D0
35975 IF(IFL.EQ.5) THEN
35976 XMF=XMBOT
35977 ELSEIF(IFL.EQ.6) THEN
35978 XMF=XMTOP
35979 ELSEIF(IFL.LT.5) THEN
35980 XMF=0D0
35981 ELSE
35982 XMF=PMAS(IFL,1)
35983 ENDIF
35984 IF(IFL.EQ.5) THEN
35985 AT=ATRIB
35986 ELSEIF(IFL.EQ.6) THEN
35987 AT=ATRIT
35988 ELSEIF(IFL.EQ.15) THEN
35989 AT=ATRIL
35990 ELSE
35991 AT=0D0
35992 ENDIF
35993C.........Need to complexify
35994 IF(IDU.EQ.2) THEN
35995 GHLR=XMF/2D0/XMW*(-XMU+AT/TANB)
35996 ELSE
35997 GHLR=XMF/2D0/XMW/(-XMU+AT*TANB)
35998 ENDIF
35999 BL=GHLL
36000 BR=GHRR
36001 BLR=GHLR
36002 ENDIF
36003 AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+
36004 & SFMIX(IFL,2)*SFMIX(IFL,4)*BR+
36005 & (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR
36006 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
36007 LKNT=LKNT+1
36008 IF(IG.EQ.23) THEN
36009 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
36010 ELSE
36011 XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2
36012 ENDIF
36013 IDLAM(LKNT,3)=0
36014 IDLAM(LKNT,1)=KFIN-KSUSY1
36015 IDLAM(LKNT,2)=IG
36016 160 CONTINUE
36017
36018C...SF -> SF' + W
36019 XMB=PMAS(24,1)
36020 IF(MOD(IFL,2).EQ.0) THEN
36021 KF1=KSUSY1+IFL-1
36022 ELSE
36023 KF1=KSUSY1+IFL+1
36024 ENDIF
36025 KF2=KF1+KSUSY1
36026 XMSF1=PMAS(PYCOMP(KF1),1)
36027 XMSF2=PMAS(PYCOMP(KF2),1)
36028 IF(XMI.GT.XMB+XMSF1) THEN
36029 IF(MOD(IFL,2).EQ.0) THEN
36030 IF(ILR.EQ.1) THEN
36031 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1)
36032 ELSE
36033 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1)
36034 ENDIF
36035 ELSE
36036 IF(ILR.EQ.1) THEN
36037 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1)
36038 ELSE
36039 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1)
36040 ENDIF
36041 ENDIF
36042 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
36043 LKNT=LKNT+1
36044 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
36045 IDLAM(LKNT,3)=0
36046 IDLAM(LKNT,1)=KF1
36047 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
36048 ENDIF
36049 IF(XMI.GT.XMB+XMSF2) THEN
36050 IF(MOD(IFL,2).EQ.0) THEN
36051 IF(ILR.EQ.1) THEN
36052 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3)
36053 ELSE
36054 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3)
36055 ENDIF
36056 ELSE
36057 IF(ILR.EQ.1) THEN
36058 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3)
36059 ELSE
36060 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3)
36061 ENDIF
36062 ENDIF
36063 XL=PYLAMF(XMI2,XMSF2**2,XMB**2)
36064 LKNT=LKNT+1
36065 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
36066 IDLAM(LKNT,3)=0
36067 IDLAM(LKNT,1)=KF2
36068 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
36069 ENDIF
36070
36071C...SF -> SF' + HC
36072 XMB=PMAS(37,1)
36073 IF(MOD(IFL,2).EQ.0) THEN
36074 KF1=KSUSY1+IFL-1
36075 ELSE
36076 KF1=KSUSY1+IFL+1
36077 ENDIF
36078 KF2=KF1+KSUSY1
36079 XMSF1=PMAS(PYCOMP(KF1),1)
36080 XMSF2=PMAS(PYCOMP(KF2),1)
36081 IF(XMI.GT.XMB+XMSF1) THEN
36082 XMF=0D0
36083 XMFP=0D0
36084 AT=0D0
36085 AB=0D0
36086 IF(MOD(IFL,2).EQ.0) THEN
36087C...T1-> B1 HC
36088 IF(ILR.EQ.1) THEN
36089 CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1)
36090 CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2)
36091 CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2)
36092 CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1)
36093C...T2-> B1 HC
36094 ELSE
36095 CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1)
36096 CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2)
36097 CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2)
36098 CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1)
36099 ENDIF
36100 IF(IFL.EQ.6) THEN
36101 XMF=XMTOP
36102 XMFP=XMBOT
36103 AT=ATRIT
36104 AB=ATRIB
36105 ENDIF
36106 ELSE
36107C...B1 -> T1 HC
36108 IF(ILR.EQ.1) THEN
36109 CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1)
36110 CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2)
36111 CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2)
36112 CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1)
36113C...B2-> T1 HC
36114 ELSE
36115 CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1)
36116 CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2)
36117 CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1)
36118 CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2)
36119 ENDIF
36120 IF(IFL.EQ.5) THEN
36121 XMF=XMTOP
36122 XMFP=XMBOT
36123 AT=ATRIT
36124 AB=ATRIB
36125 ENDIF
36126 ENDIF
36127 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
36128 LKNT=LKNT+1
36129C.......Need to complexify
36130 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
36131 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
36132 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
36133 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
36134 IDLAM(LKNT,3)=0
36135 IDLAM(LKNT,1)=KF1
36136 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
36137 ENDIF
36138 IF(XMI.GT.XMB+XMSF2) THEN
36139 XMF=0D0
36140 XMFP=0D0
36141 AT=0D0
36142 AB=0D0
36143 IF(MOD(IFL,2).EQ.0) THEN
36144C...T1-> B2 HC
36145 IF(ILR.EQ.1) THEN
36146 CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1)
36147 CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2)
36148 CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1)
36149 CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2)
36150C...T2-> B2 HC
36151 ELSE
36152 CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3)
36153 CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4)
36154 CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4)
36155 CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3)
36156 ENDIF
36157 IF(IFL.EQ.6) THEN
36158 XMF=XMTOP
36159 XMFP=XMBOT
36160 AT=ATRIT
36161 AB=ATRIB
36162 ENDIF
36163 ELSE
36164C...B1 -> T2 HC
36165 IF(ILR.EQ.1) THEN
36166 CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1)
36167 CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2)
36168 CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2)
36169 CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1)
36170C...B2-> T2 HC
36171 ELSE
36172 CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3)
36173 CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4)
36174 CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4)
36175 CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3)
36176 ENDIF
36177 IF(IFL.EQ.5) THEN
36178 XMF=XMTOP
36179 XMFP=XMBOT
36180 AT=ATRIT
36181 AB=ATRIB
36182 ENDIF
36183 ENDIF
36184 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
36185 LKNT=LKNT+1
36186C.......Need to complexify
36187 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
36188 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
36189 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
36190 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
36191 IDLAM(LKNT,3)=0
36192 IDLAM(LKNT,1)=KF2
36193 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
36194 ENDIF
36195
36196C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
36197
36198 IF(IFL.LE.6) THEN
36199 XMFP=0D0
36200 XMF=0D0
36201 IF(IFL.EQ.6) XMF=PMAS(6,1)
36202 IF(IFL.EQ.5) XMF=PMAS(5,1)
36203 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
36204 AXMJ=ABS(XMJ)
36205 IF(XMI.GE.AXMJ+XMF) THEN
36206 AL=-SFMIX(IFL,3)
36207 BL=SFMIX(IFL,1)
36208 AR=-SFMIX(IFL,4)
36209 BR=SFMIX(IFL,2)
36210C...F1 -> F CHI
36211 IF(ILR.EQ.1) THEN
36212 XCA=AL
36213 XCB=BL
36214C...F2 -> F CHI
36215 ELSE
36216 XCA=AR
36217 XCB=BR
36218 ENDIF
36219 LKNT=LKNT+1
36220 XMA2=XMJ**2
36221 XMB2=XMF**2
36222 XL=PYLAMF(XMI2,XMA2,XMB2)
36223 XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
36224 & (XCA**2+XCB**2)+4D0*XCA*XCB*XMJ*XMF)
36225 IDLAM(LKNT,1)=KSUSY1+21
36226 IDLAM(LKNT,2)=IFL
36227 IDLAM(LKNT,3)=0
36228 ENDIF
36229 ENDIF
36230
36231C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
36232 IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT.
36233 &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN
36234C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
36235C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
36236C...M*M = C1**2 * G**2/(16PI**2)
36237C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
36238 LKNT=LKNT+1
36239 XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
36240 XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL)
36241 IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3
36242 IDLAM(LKNT,1)=KSUSY1+22
36243 IDLAM(LKNT,2)=4
36244 IDLAM(LKNT,3)=0
36245 ENDIF
36246
36247C...R-violating sfermion decays (SKANDS).
36248 CALL PYRVSF(KFIN,XLAM,IDLAM,LKNT)
36249
36250 IKNT=LKNT
36251 XLAM(0)=0D0
36252 DO 170 I=1,IKNT
36253 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
36254 XLAM(0)=XLAM(0)+XLAM(I)
36255 170 CONTINUE
36256 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3
36257
36258 RETURN
36259 END
36260
36261C*********************************************************************
36262
36263C...PYGLUI
36264C...Calculates gluino decay modes.
36265
36266 SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT)
36267
36268C...Double precision and integer declarations.
36269 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36270 IMPLICIT INTEGER(I-N)
36271 INTEGER PYK,PYCHGE,PYCOMP
36272C...Parameter statement to help give large particle numbers.
36273 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
36274 &KEXCIT=4000000,KDIMEN=5000000)
36275C...Commonblocks.
36276 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36277 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36278 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
36279 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
36280 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
36281CC &SFMIX(16,4),
36282C COMMON/PYINTS/XXM(20)
36283 COMPLEX*16 CXC
36284 COMMON/PYINTC/XXC(10),CXC(8)
36285 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
36286
36287C...Local variables
36288 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
36289 DOUBLE PRECISION XMI,XMJ,XMF,AXMJ,AXMI
36290 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
36291 DOUBLE PRECISION PYLAMF,XL
36292 DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
36293 DOUBLE PRECISION CA,CB,AL,AR,BL,BR
36294 DOUBLE PRECISION XLAM(0:400)
36295 INTEGER IDLAM(400,3)
36296 INTEGER LKNT,IX,ILR,I,IKNT,IFL
36297 DOUBLE PRECISION SR2
36298 DOUBLE PRECISION GAM
36299 DOUBLE PRECISION PYALEM,PI,PYALPS,EI,T3I
36300 EXTERNAL PYGAUS,PYXXZ6
36301 DOUBLE PRECISION PYGAUS,PYXXZ6
36302 DOUBLE PRECISION PREC
36303 INTEGER KFNCHI(4),KFCCHI(2)
36304 DATA PI/3.141592654D0/
36305 DATA SR2/1.4142136D0/
36306 DATA PREC/1D-2/
36307 DATA KFNCHI/1000022,1000023,1000025,1000035/
36308 DATA KFCCHI/1000024,1000037/
36309
36310C...COUNT THE NUMBER OF DECAY MODES
36311 LKNT=0
36312 IF(KFIN.NE.KSUSY1+21) RETURN
36313 KCIN=PYCOMP(KFIN)
36314
36315 XW=PARU(102)
36316 TANW = SQRT(XW/(1D0-XW))
36317
36318 XMI=PMAS(KCIN,1)
36319 AXMI=ABS(XMI)
36320 XMI2=XMI**2
36321 AEM=PYALEM(XMI2)
36322 AS =PYALPS(XMI2)
36323 C1=AEM/XW
36324 XMI3=AXMI**3
36325
36326 XMI=SIGN(XMI,RMSS(3))
36327
36328C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
36329
36330 IF(IMSS(11).EQ.1) THEN
36331 XMP=RMSS(29)
36332 IDG=39+KSUSY1
36333 XMGR=PMAS(PYCOMP(IDG),1)
36334 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
36335 IF(AXMI.GT.XMGR) THEN
36336 LKNT=LKNT+1
36337 IDLAM(LKNT,1)=IDG
36338 IDLAM(LKNT,2)=21
36339 IDLAM(LKNT,3)=0
36340 XLAM(LKNT)=XFAC
36341 ENDIF
36342 ENDIF
36343
36344C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
36345
36346 DO 110 IFL=1,6
36347 DO 100 ILR=1,2
36348 XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1)
36349 AXMJ=ABS(XMJ)
36350 XMF=PMAS(IFL,1)
36351 IF(AXMI.GE.AXMJ+XMF) THEN
36352C...Minus sign difference from gluino-quark-squark feynman rules
36353 AL=SFMIX(IFL,1)
36354 BL=-SFMIX(IFL,3)
36355 AR=SFMIX(IFL,2)
36356 BR=-SFMIX(IFL,4)
36357C...F1 -> F CHI
36358 IF(ILR.EQ.1) THEN
36359 CA=AL
36360 CB=BL
36361C...F2 -> F CHI
36362 ELSE
36363 CA=AR
36364 CB=BR
36365 ENDIF
36366 LKNT=LKNT+1
36367 XMA2=XMJ**2
36368 XMB2=XMF**2
36369 XL=PYLAMF(XMI2,XMA2,XMB2)
36370 XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)*
36371 & (CA**2+CB**2)-4D0*CA*CB*XMI*XMF)
36372 IDLAM(LKNT,1)=ILR*KSUSY1+IFL
36373 IDLAM(LKNT,2)=-IFL
36374 IDLAM(LKNT,3)=0
36375 LKNT=LKNT+1
36376 XLAM(LKNT)=XLAM(LKNT-1)
36377 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36378 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36379 IDLAM(LKNT,3)=0
36380 ENDIF
36381 100 CONTINUE
36382 110 CONTINUE
36383
36384C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
36385C...GLUINO -> NI Q QBAR
36386 DO 170 IX=1,4
36387 XMJ=SMZ(IX)
36388 AXMJ=ABS(XMJ)
36389 IF(AXMI.GE.AXMJ) THEN
36390 DO 120 I=1,4
36391 ZMIXC(IX,I)=DCMPLX(ZMIX(IX,I),ZMIXI(IX,I))
36392 120 CONTINUE
36393 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))/SR2
36394 ORPP=DCONJG(OLPP)
36395 XXC(1)=0D0
36396 XXC(2)=XMJ
36397 XXC(3)=0D0
36398 XXC(4)=XMI
36399 IA=1
36400 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
36401 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
36402 XXC(7)=XXC(5)
36403 XXC(8)=XXC(6)
36404 XXC(9)=1D6
36405 XXC(10)=0D0
36406 EI=KCHG(IA,1)/3D0
36407 T3I=SIGN(1D0,EI+1D-6)/2D0
36408 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
36409 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
36410 CXC(1)=0D0
36411 CXC(2)=-GLIJ
36412 CXC(3)=0D0
36413 CXC(4)=DCONJG(GLIJ)
36414 CXC(5)=0D0
36415 CXC(6)=GRIJ
36416 CXC(7)=0D0
36417 CXC(8)=-DCONJG(GRIJ)
36418 S12MIN=0D0
36419 S12MAX=(AXMI-AXMJ)**2
36420 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 130
36421 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
36422 LKNT=LKNT+1
36423 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
36424 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
36425 IDLAM(LKNT,1)=KFNCHI(IX)
36426 IDLAM(LKNT,2)=1
36427 IDLAM(LKNT,3)=-1
36428 ENDIF
36429 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
36430 LKNT=LKNT+1
36431 XLAM(LKNT)=XLAM(LKNT-1)
36432 IDLAM(LKNT,1)=KFNCHI(IX)
36433 IDLAM(LKNT,2)=3
36434 IDLAM(LKNT,3)=-3
36435 ENDIF
36436 130 CONTINUE
36437 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
36438 PMOLD=PMAS(PYCOMP(KSUSY1+5),1)
36439 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+5),1)+PMAS(5,1)) THEN
36440 GOTO 140
36441 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) THEN
36442 PMAS(PYCOMP(KSUSY1+5),1)=100D0*XMI
36443 ENDIF
36444 CALL PYTBBN(IX,100,-1D0/3D0,XMI,GAM)
36445 LKNT=LKNT+1
36446 XLAM(LKNT)=GAM
36447 IDLAM(LKNT,1)=KFNCHI(IX)
36448 IDLAM(LKNT,2)=5
36449 IDLAM(LKNT,3)=-5
36450 PMAS(PYCOMP(KSUSY1+5),1)=PMOLD
36451 ENDIF
36452C...U-TYPE QUARKS
36453 140 CONTINUE
36454 IA=2
36455 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
36456 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
36457C IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 290
36458 XXC(7)=XXC(5)
36459 XXC(8)=XXC(6)
36460 EI=KCHG(IA,1)/3D0
36461 T3I=SIGN(1D0,EI+1D-6)/2D0
36462 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
36463 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
36464 CXC(2)=-GLIJ
36465 CXC(4)=DCONJG(GLIJ)
36466 CXC(6)=GRIJ
36467 CXC(8)=-DCONJG(GRIJ)
36468 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 150
36469 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
36470 LKNT=LKNT+1
36471 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
36472 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
36473 IDLAM(LKNT,1)=KFNCHI(IX)
36474 IDLAM(LKNT,2)=2
36475 IDLAM(LKNT,3)=-2
36476 ENDIF
36477 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
36478 LKNT=LKNT+1
36479 XLAM(LKNT)=XLAM(LKNT-1)
36480 IDLAM(LKNT,1)=KFNCHI(IX)
36481 IDLAM(LKNT,2)=4
36482 IDLAM(LKNT,3)=-4
36483 ENDIF
36484 150 CONTINUE
36485C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
36486C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
36487 XMF=PMAS(6,1)
36488 IF(AXMI.GE.AXMJ+2D0*XMF) THEN
36489 PMOLD=PMAS(PYCOMP(KSUSY1+6),1)
36490 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+6),1)+XMF) THEN
36491 GOTO 160
36492 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+6),1)+XMF) THEN
36493 PMAS(PYCOMP(KSUSY1+6),1)=100D0*XMI
36494 ENDIF
36495 CALL PYTBBN(IX,100,2D0/3D0,XMI,GAM)
36496 LKNT=LKNT+1
36497 XLAM(LKNT)=GAM
36498 IDLAM(LKNT,1)=KFNCHI(IX)
36499 IDLAM(LKNT,2)=6
36500 IDLAM(LKNT,3)=-6
36501 PMAS(PYCOMP(KSUSY1+6),1)=PMOLD
36502 ENDIF
36503 160 CONTINUE
36504 ENDIF
36505 170 CONTINUE
36506
36507C...GLUINO -> CI Q QBAR'
36508 DO 210 IX=1,2
36509 XMJ=SMW(IX)
36510 AXMJ=ABS(XMJ)
36511 IF(AXMI.GE.AXMJ) THEN
36512 DO 180 I=1,2
36513 VMIXC(IX,I)=DCMPLX(VMIX(IX,I),VMIXI(IX,I))
36514 UMIXC(IX,I)=DCMPLX(UMIX(IX,I),UMIXI(IX,I))
36515 180 CONTINUE
36516 S12MIN=0D0
36517 S12MAX=(AXMI-AXMJ)**2
36518 XXC(1)=0D0
36519 XXC(2)=XMJ
36520 XXC(3)=0D0
36521 XXC(4)=XMI
36522 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
36523 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
36524 XXC(9)=1D6
36525 XXC(10)=0D0
36526 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
36527 ORPP=DCONJG(OLPP)
36528 CXC(1)=DCMPLX(0D0,0D0)
36529 CXC(3)=DCMPLX(0D0,0D0)
36530 CXC(5)=DCMPLX(0D0,0D0)
36531 CXC(7)=DCMPLX(0D0,0D0)
36532 CXC(2)=UMIXC(IX,1)*OLPP/SR2
36533 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
36534 CXC(6)=DCMPLX(0D0,0D0)
36535 CXC(8)=DCMPLX(0D0,0D0)
36536 IF(XXC(5).LT.AXMI) THEN
36537 XXC(5)=1D6
36538 ELSEIF(XXC(6).LT.AXMI) THEN
36539 XXC(6)=1D6
36540 ENDIF
36541 XXC(7)=XXC(6)
36542 XXC(8)=XXC(5)
36543 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 190
36544 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
36545 LKNT=LKNT+1
36546 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
36547 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
36548 IDLAM(LKNT,1)=KFCCHI(IX)
36549 IDLAM(LKNT,2)=1
36550 IDLAM(LKNT,3)=-2
36551 LKNT=LKNT+1
36552 XLAM(LKNT)=XLAM(LKNT-1)
36553 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36554 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36555 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
36556 ENDIF
36557 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
36558 LKNT=LKNT+1
36559 XLAM(LKNT)=XLAM(LKNT-1)
36560 IDLAM(LKNT,1)=KFCCHI(IX)
36561 IDLAM(LKNT,2)=3
36562 IDLAM(LKNT,3)=-4
36563 LKNT=LKNT+1
36564 XLAM(LKNT)=XLAM(LKNT-1)
36565 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36566 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36567 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
36568 ENDIF
36569 190 CONTINUE
36570
36571 XMF=PMAS(6,1)
36572 XMFP=PMAS(5,1)
36573 IF(AXMI.GE.AXMJ+XMF+XMFP) THEN
36574 IF(XMI.GT.MIN(PMAS(PYCOMP(KSUSY1+5),1)+XMFP,
36575 $ PMAS(PYCOMP(KSUSY2+6),1)+XMF)) GOTO 200
36576 PMOLT2=PMAS(PYCOMP(KSUSY2+6),1)
36577 PMOLB2=PMAS(PYCOMP(KSUSY2+5),1)
36578 PMOLT1=PMAS(PYCOMP(KSUSY1+6),1)
36579 PMOLB1=PMAS(PYCOMP(KSUSY1+5),1)
36580 IF(XMI.GT.PMOLT2+XMF) PMOLT2=100D0*AXMI
36581 IF(XMI.GT.PMOLT1+XMF) PMOLT1=100D0*AXMI
36582 IF(XMI.GT.PMOLB2+XMFP) PMOLB2=100D0*AXMI
36583 IF(XMI.GT.PMOLB1+XMFP) PMOLB1=100D0*AXMI
36584 CALL PYTBBC(IX,100,XMI,GAM)
36585 LKNT=LKNT+1
36586 XLAM(LKNT)=GAM
36587 IDLAM(LKNT,1)=KFCCHI(IX)
36588 IDLAM(LKNT,2)=5
36589 IDLAM(LKNT,3)=-6
36590 LKNT=LKNT+1
36591 XLAM(LKNT)=XLAM(LKNT-1)
36592 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36593 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36594 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
36595 PMAS(PYCOMP(KSUSY2+6),1)=PMOLT2
36596 PMAS(PYCOMP(KSUSY2+5),1)=PMOLB2
36597 PMAS(PYCOMP(KSUSY1+6),1)=PMOLT1
36598 PMAS(PYCOMP(KSUSY1+5),1)=PMOLB1
36599 ENDIF
36600 200 CONTINUE
36601 ENDIF
36602 210 CONTINUE
36603
36604C...R-parity violating (3-body) decays.
36605 CALL PYRVGL(KFIN,XLAM,IDLAM,LKNT)
36606
36607 IKNT=LKNT
36608 XLAM(0)=0D0
36609 DO 220 I=1,IKNT
36610 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
36611 XLAM(0)=XLAM(0)+XLAM(I)
36612 220 CONTINUE
36613 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
36614
36615 RETURN
36616 END
36617
36618C*********************************************************************
36619
36620C...PYTBBN
36621C...Calculates the three-body decay of gluinos into
36622C...neutralinos and third generation fermions.
36623
36624 SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
36625
36626C...Double precision and integer declarations.
36627 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36628 IMPLICIT INTEGER(I-N)
36629 INTEGER PYK,PYCHGE,PYCOMP
36630C...Parameter statement to help give large particle numbers.
36631 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
36632 &KEXCIT=4000000,KDIMEN=5000000)
36633C...Commonblocks.
36634 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36635 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36636 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
36637 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
36638 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
36639 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
36640
36641C...Local variables.
36642 EXTERNAL PYSIMP,PYLAMF
36643 DOUBLE PRECISION PYSIMP,PYLAMF
36644 INTEGER LIN,NN
36645 DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
36646 DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
36647 DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
36648 DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
36649 DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
36650 DOUBLE PRECISION XLN1,XLN2,B1,B2
36651 DOUBLE PRECISION E,XMGLU,GAM
36652 DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
36653 SAVE HRB,HLB,FLB,FRB
36654 DOUBLE PRECISION ALPHAW,ALPHAS
36655 DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
36656 SAVE HLT,HRT,FLT,FRT
36657 DOUBLE PRECISION AMN(4),AN(4,4),ZN(3)
36658 SAVE AMN,AN,ZN
36659 DOUBLE PRECISION AMBOT,SINC,COSC
36660 DOUBLE PRECISION AMTOP,SINA,COSA
36661 DOUBLE PRECISION SINW,COSW,TANW
36662 DOUBLE PRECISION ROT1(4,4)
36663 LOGICAL IFIRST
36664 SAVE IFIRST
36665 DATA IFIRST/.TRUE./
36666
36667 TANB=RMSS(5)
36668 SINB=TANB/SQRT(1D0+TANB**2)
36669 COSB=SINB/TANB
36670 XW=PARU(102)
36671 SINW=SQRT(XW)
36672 COSW=SQRT(1D0-XW)
36673 TANW=SINW/COSW
36674 AMW=PMAS(24,1)
36675 COSC=SFMIX(5,1)
36676 SINC=SFMIX(5,3)
36677 COSA=SFMIX(6,1)
36678 SINA=SFMIX(6,3)
36679 AMBOT=PYMRUN(5,XMGLU**2)
36680 AMTOP=PYMRUN(6,XMGLU**2)
36681 W2=SQRT(2D0)
36682 FAKT1=AMBOT/W2/AMW/COSB
36683 FAKT2=AMTOP/W2/AMW/SINB
36684 IF(IFIRST) THEN
36685 DO 110 II=1,4
36686 AMN(II)=SMZ(II)
36687 DO 100 J=1,4
36688 ROT1(II,J)=0D0
36689 AN(II,J)=0D0
36690 100 CONTINUE
36691 110 CONTINUE
36692 ROT1(1,1)=COSW
36693 ROT1(1,2)=-SINW
36694 ROT1(2,1)=-ROT1(1,2)
36695 ROT1(2,2)=ROT1(1,1)
36696 ROT1(3,3)=COSB
36697 ROT1(3,4)=SINB
36698 ROT1(4,3)=-ROT1(3,4)
36699 ROT1(4,4)=ROT1(3,3)
36700 DO 140 II=1,4
36701 DO 130 J=1,4
36702 DO 120 JJ=1,4
36703 AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J)
36704 120 CONTINUE
36705 130 CONTINUE
36706 140 CONTINUE
36707 DO 150 J=1,4
36708 ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4))
36709 ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
36710 ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0*
36711 & XW)*AN(J,2)/COSW
36712 HRT(J)=ZN(1)*COSA-ZN(3)*SINA
36713 HLT(J)=ZN(1)*COSA+ZN(2)*SINA
36714 FLT(J)=ZN(3)*COSA+ZN(1)*SINA
36715 FRT(J)=ZN(2)*COSA-ZN(1)*SINA
36716C FLU(J)=ZN(3)
36717C FRU(J)=ZN(2)
36718 ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4))
36719 ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
36720 ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW
36721 HRB(J)=ZN(1)*COSC-ZN(3)*SINC
36722 HLB(J)=ZN(1)*COSC+ZN(2)*SINC
36723 FLB(J)=ZN(3)*COSC+ZN(1)*SINC
36724 FRB(J)=ZN(2)*COSC-ZN(1)*SINC
36725C FLD(J)=ZN(3)
36726C FRD(J)=ZN(2)
36727 150 CONTINUE
36728C AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
36729C AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
36730C AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
36731C AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
36732 IFIRST=.FALSE.
36733 ENDIF
36734
36735 IF(NINT(3D0*E).EQ.2) THEN
36736 HL=HLT(I)
36737 HR=HRT(I)
36738 FL=FLT(I)
36739 FR=FRT(I)
36740 COSD=SFMIX(6,1)
36741 SIND=SFMIX(6,3)
36742 XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2
36743 XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2
36744 XM=PMAS(6,1)
36745 ELSE
36746 HL=HLB(I)
36747 HR=HRB(I)
36748 FL=FLB(I)
36749 FR=FRB(I)
36750 COSD=SFMIX(5,1)
36751 SIND=SFMIX(5,3)
36752 XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2
36753 XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2
36754 XM=PMAS(5,1)
36755 ENDIF
36756 COSD2=COSD*COSD
36757 SIND2=SIND*SIND
36758 COS2D=COSD2-SIND2
36759 SIN2D=SIND*COSD*2D0
36760 HL2=HL*HL
36761 HR2=HR*HR
36762 FL2=FL*FL
36763 FR2=FR*FR
36764 FF=FL*FR
36765 HH=HL*HR
36766 HFL=HL*FL
36767 HFR=HR*FR
36768 HRFL=HR*FL
36769 HLFR=HL*FR
36770 XM2=XM*XM
36771 XMG=XMGLU
36772 XMG2=XMG*XMG
36773 ALPHAW=PYALEM(XMG2)
36774 ALPHAS=PYALPS(XMG2)
36775 XMR=AMN(I)
36776 XMR2=XMR*XMR
36777 XMQ4=XMG*XM2*XMR
36778 XM24=(XMG2+XM2)*(XM2+XMR2)
36779 SMIN=4D0*XM2
36780 SMAX=(XMG-ABS(XMR))**2
36781 XMQA=XMG2+2D0*XM2+XMR2
36782 DO 170 LIN=1,NN-1
36783 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
36784 GRS=SBAR-XMQA
36785 W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR)
36786 W=DSQRT(W)
36787 XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W)))
36788 XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W)))
36789 B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W)
36790 B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W)
36791 G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D
36792 & +2D0*(FF*SIND2-HH*COSD2))*W
36793 G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D)
36794 & +4D0*HFL*XM*XMR)*XLN1
36795 & +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24
36796 & +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D)
36797 & -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1))
36798 & +8D0*HFL*XMQ4*SIN2D)*B1
36799 G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D)
36800 & +4D0*HFR*XMR*XM)*XLN2
36801 & +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24
36802 & +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2))
36803 & +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2)
36804 & -8D0*HFR*XMQ4*SIN2D)*B2
36805 G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
36806 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR
36807 & -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2)
36808 & +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2)
36809 & -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1
36810 G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))*
36811 & (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2)
36812 & +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1))
36813 G(5)=(2D0*(HH*COSD2-FF*SIND2)
36814 & *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2
36815 & +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1)
36816 & +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR)
36817 & *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2)
36818 & +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2)
36819 & +COS2D*XM*(SBAR+XMG2-XMR2))
36820 & +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2))
36821 & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
36822 G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
36823 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR
36824 & -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2)
36825 & -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2)
36826 & -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2
36827 SUMME(LIN)=0D0
36828 DO 160 J=0,6
36829 SUMME(LIN)=SUMME(LIN)+G(J)
36830 160 CONTINUE
36831 170 CONTINUE
36832 SUMME(0)=0D0
36833 SUMME(NN)=0D0
36834 GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
36835 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
36836
36837 RETURN
36838 END
36839
36840C*********************************************************************
36841
36842C...PYTBBC
36843C...Calculates the three-body decay of gluinos into
36844C...charginos and third generation fermions.
36845
36846 SUBROUTINE PYTBBC(I,NN,XMGLU,GAM)
36847
36848C...Double precision and integer declarations.
36849 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36850 IMPLICIT INTEGER(I-N)
36851 INTEGER PYK,PYCHGE,PYCOMP
36852C...Parameter statement to help give large particle numbers.
36853 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
36854 &KEXCIT=4000000,KDIMEN=5000000)
36855C...Commonblocks.
36856 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36857 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36858 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
36859 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
36860 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
36861 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
36862
36863C...Local variables.
36864 EXTERNAL PYSIMP,PYLAMF
36865 DOUBLE PRECISION PYSIMP,PYLAMF
36866 INTEGER I,NN,LIN
36867 DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
36868 DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
36869 DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
36870 DOUBLE PRECISION SUMME(0:100),A(4,8)
36871 DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
36872 DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
36873 DOUBLE PRECISION XMGLU,GAM
36874 DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
36875 &DDD(2),EEE(2),FFF(2)
36876 SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF
36877 DOUBLE PRECISION ALPHAW,ALPHAS
36878 DOUBLE PRECISION AMC(2)
36879 SAVE AMC
36880 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
36881 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
36882 SAVE AMSB,AMST
36883 LOGICAL IFIRST
36884 SAVE IFIRST
36885 DATA IFIRST/.TRUE./
36886
36887 TANB=RMSS(5)
36888 SINB=TANB/SQRT(1D0+TANB**2)
36889 COSB=SINB/TANB
36890 XW=PARU(102)
36891 AMW=PMAS(24,1)
36892 COSC=SFMIX(5,1)
36893 SINC=SFMIX(5,3)
36894 COSA=SFMIX(6,1)
36895 SINA=SFMIX(6,3)
36896 AMBOT=PYMRUN(5,XMGLU**2)
36897 AMTOP=PYMRUN(6,XMGLU**2)
36898 W2=SQRT(2D0)
36899 AMW=PMAS(24,1)
36900 FAKT1=AMBOT/W2/AMW/COSB
36901 FAKT2=AMTOP/W2/AMW/SINB
36902 IF(IFIRST) THEN
36903 AMC(1)=SMW(1)
36904 AMC(2)=SMW(2)
36905 DO 100 JJ=1,2
36906 CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC
36907 EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC
36908 DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC
36909 FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC
36910 XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA
36911 AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA
36912 XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA
36913 BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA
36914 100 CONTINUE
36915 AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
36916 AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
36917 AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
36918 AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
36919 IFIRST=.FALSE.
36920 ENDIF
36921
36922 ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I)
36923 ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I)
36924 VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I)
36925 VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I)
36926
36927 COS2A=COSA**2-SINA**2
36928 SIN2A=SINA*COSA*2D0
36929 COS2C=COSC**2-SINC**2
36930 SIN2C=SINC*COSC*2D0
36931
36932 XMG=XMGLU
36933 XMT=PMAS(6,1)
36934 XMB=PMAS(5,1)
36935 XMR=AMC(I)
36936 XMG2=XMG*XMG
36937 ALPHAW=PYALEM(XMG2)
36938 ALPHAS=PYALPS(XMG2)
36939 XMT2=XMT*XMT
36940 XMB2=XMB*XMB
36941 XMR2=XMR*XMR
36942 XMQ2=XMG2+XMT2+XMB2+XMR2
36943 XMQ4=XMG*XMT*XMB*XMR
36944 XMQ3=XMG2*XMR2+XMT2*XMB2
36945 XMGBTR=(XMG2+XMB2)*(XMT2+XMR2)
36946 XMGTBR=(XMG2+XMT2)*(XMB2+XMR2)
36947
36948 XMST(1)=AMST(1)*AMST(1)
36949 XMST(2)=AMST(1)*AMST(1)
36950 XMST(3)=AMST(2)*AMST(2)
36951 XMST(4)=AMST(2)*AMST(2)
36952 XMSB(1)=AMSB(1)*AMSB(1)
36953 XMSB(2)=AMSB(2)*AMSB(2)
36954 XMSB(3)=AMSB(1)*AMSB(1)
36955 XMSB(4)=AMSB(2)*AMSB(2)
36956
36957 A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I)
36958 A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I))
36959 A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I))
36960 A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I))
36961 A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I))
36962 A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I))
36963 A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I))
36964 A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I))
36965
36966 A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I)
36967 A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I))
36968 A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I))
36969 A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I))
36970 A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I))
36971 A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I))
36972 A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I))
36973 A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I))
36974
36975 A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I)
36976 A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I))
36977 A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I))
36978 A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I))
36979 A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I))
36980 A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I))
36981 A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I))
36982 A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I))
36983
36984 A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I)
36985 A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I))
36986 A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I))
36987 A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I))
36988 A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I))
36989 A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I))
36990 A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I))
36991 A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I))
36992
36993 SMAX=(XMG-ABS(XMR))**2
36994 SMIN=(XMB+XMT)**2+0.1D0
36995
36996 DO 120 LIN=0,NN-1
36997 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
36998 AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR
36999 GRS=SBAR-XMQ2
37000 W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2)
37001 W=DSQRT(W)/2D0/SBAR
37002 ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W)))
37003 ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W)))
37004 ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W)))
37005 ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W)))
37006 SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A)
37007 & +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1
37008 & +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR
37009 & -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2))
37010 & +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2)
37011 & +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4)
37012 & *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W))
37013 SUMME(LIN)=SUMME(LIN)-ULR(2)*W
37014 & +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A)
37015 & -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2
37016 & +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR
37017 & +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2))
37018 & -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2)
37019 & +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4)
37020 & *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W))
37021 SUMME(LIN)=SUMME(LIN)-VLR(1)*W
37022 & +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C)
37023 & +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1
37024 & +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR
37025 & -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2))
37026 & +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2)
37027 & +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4)
37028 & *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W))
37029 SUMME(LIN)=SUMME(LIN)-VLR(2)*W
37030 & +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C)
37031 & -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2
37032 & +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR
37033 & +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2))
37034 & -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2)
37035 & +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4)
37036 & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
37037 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1))
37038 & *((AAA(I)*BBB(I)-XX1(I)*XX2(I))
37039 & *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1)
37040 & +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1))
37041 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1))
37042 & *((EEE(I)*FFF(I)-CCC(I)*DDD(I))
37043 & *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1)
37044 & +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1))
37045 DO 110 J=1,4
37046 SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W
37047 & +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3)
37048 & +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2)
37049 & +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2)
37050 & -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR)
37051 & -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8))
37052 & *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W)))
37053 & -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3)
37054 & +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2)
37055 & +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2)
37056 & -A(J,6)*(XMG2+XMR2-SBAR)
37057 & -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8))
37058 & *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W))))
37059 & /(GRS+XMSB(J)+XMST(J))
37060 110 CONTINUE
37061 120 CONTINUE
37062 SUMME(NN)=0D0
37063 GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
37064 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
37065
37066 RETURN
37067 END
37068
37069C*********************************************************************
37070
37071C...PYNJDC
37072C...Calculates decay widths for the neutralinos (admixtures of
37073C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
37074
37075C...Input: KCIN = KF code for particle
37076C...Output: XLAM = widths
37077C... IDLAM = KF codes for decay particles
37078C... IKNT = number of decay channels defined
37079C...AUTHOR: STEPHEN MRENNA
37080C...Last change:
37081C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
37082C...when CHIGAMMA .NE. 0
37083C...10 FEB 96: Calculate this decay for small tan(beta)
37084
37085 SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT)
37086
37087C...Double precision and integer declarations.
37088 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37089 IMPLICIT INTEGER(I-N)
37090 INTEGER PYK,PYCHGE,PYCOMP
37091C...Parameter statement to help give large particle numbers.
37092 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
37093 &KEXCIT=4000000,KDIMEN=5000000)
37094C...Commonblocks.
37095 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37096 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37097 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
37098c COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
37099c &SFMIX(16,4)
37100 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
37101 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
37102C COMMON/PYINTS/XXM(20)
37103 COMPLEX*16 CXC
37104 COMMON/PYINTC/XXC(10),CXC(8)
37105 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
37106
37107C...Local variables.
37108 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
37109 COMPLEX*16 QIJ,RIJ,F21K,F12K,CAL,CAR,CBL,CBR,CA,CB
37110 INTEGER KFIN
37111 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
37112 &XMZ,XMZ2,AXMJ,AXMI
37113 DOUBLE PRECISION S12MIN,S12MAX
37114 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2
37115 DOUBLE PRECISION PYLAMF,XL
37116 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I
37117 DOUBLE PRECISION PYX2XH,PYX2XG
37118 DOUBLE PRECISION XLAM(0:400)
37119 INTEGER IDLAM(400,3)
37120 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
37121 INTEGER ITH(3),KF1,KF2
37122 INTEGER ITHC
37123 DOUBLE PRECISION DH(3),EH(3)
37124 DOUBLE PRECISION SR2
37125 DOUBLE PRECISION CBETA,SBETA
37126 DOUBLE PRECISION GAMCON,XMT1,XMT2
37127 DOUBLE PRECISION PYALEM,PI,PYALPS
37128 DOUBLE PRECISION RAT1,RAT2
37129 DOUBLE PRECISION T3T,FCOL
37130 DOUBLE PRECISION ALFA,BETA,TANB
37131 DOUBLE PRECISION PYXXGA
37132 EXTERNAL PYGAUS,PYXXZ6
37133 DOUBLE PRECISION PYGAUS,PYXXZ6
37134 DOUBLE PRECISION PREC
37135 INTEGER KFNCHI(4),KFCCHI(2)
37136 DATA ITH/25,35,36/
37137 DATA ITHC/37/
37138 DATA PREC/1D-2/
37139 DATA PI/3.141592654D0/
37140 DATA SR2/1.4142136D0/
37141 DATA KFNCHI/1000022,1000023,1000025,1000035/
37142 DATA KFCCHI/1000024,1000037/
37143
37144C...COUNT THE NUMBER OF DECAY MODES
37145 LKNT=0
37146
37147 XMW=PMAS(24,1)
37148 XMW2=XMW**2
37149 XMZ=PMAS(23,1)
37150 XMZ2=XMZ**2
37151 XW=1D0-XMW2/XMZ2
37152 XW1=1D0-XW
37153 TANW = SQRT(XW/XW1)
37154
37155C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
37156 IX=1
37157 IF(KFIN.EQ.KFNCHI(2)) IX=2
37158 IF(KFIN.EQ.KFNCHI(3)) IX=3
37159 IF(KFIN.EQ.KFNCHI(4)) IX=4
37160
37161 XMI=SMZ(IX)
37162 XMI2=XMI**2
37163 AXMI=ABS(XMI)
37164 AEM=PYALEM(XMI2)
37165 AS =PYALPS(XMI2)
37166 C1=AEM/XW
37167 XMI3=ABS(XMI**3)
37168
37169 TANB=RMSS(5)
37170 BETA=ATAN(TANB)
37171 ALFA=RMSS(18)
37172 CBETA=COS(BETA)
37173 SBETA=TANB*CBETA
37174 CALFA=COS(ALFA)
37175 SALFA=SIN(ALFA)
37176
37177 DO 110 I=1,4
37178 DO 100 J=1,4
37179 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
37180 100 CONTINUE
37181 110 CONTINUE
37182 DO 130 I=1,2
37183 DO 120 J=1,2
37184 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
37185 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
37186 120 CONTINUE
37187 130 CONTINUE
37188
37189C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
37190 IF(IX.EQ.1.AND.IMSS(11).EQ.0) GOTO 300
37191
37192C...FORCE CHI0_2 -> CHI0_1 + GAMMA
37193 IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN
37194 XMJ=SMZ(1)
37195 AXMJ=ABS(XMJ)
37196 LKNT=LKNT+1
37197 GAMCON=AEM**3/8D0/PI/XMW2/XW
37198 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
37199 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
37200 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
37201 IDLAM(LKNT,1)=KSUSY1+22
37202 IDLAM(LKNT,2)=22
37203 IDLAM(LKNT,3)=0
37204 WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT)
37205 GOTO 340
37206 ENDIF
37207
37208C...GRAVITINO DECAY MODES
37209
37210 IF(IMSS(11).EQ.1) THEN
37211 XMP=RMSS(29)
37212 IDG=39+KSUSY1
37213 XMGR=PMAS(PYCOMP(IDG),1)
37214 SINW=SQRT(XW)
37215 COSW=SQRT(1D0-XW)
37216 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
37217 IF(AXMI.GT.XMGR+PMAS(22,1)) THEN
37218 LKNT=LKNT+1
37219 IDLAM(LKNT,1)=IDG
37220 IDLAM(LKNT,2)=22
37221 IDLAM(LKNT,3)=0
37222 XLAM(LKNT)=XFAC*ABS(ZMIXC(IX,1)*COSW+ZMIXC(IX,2)*SINW)**2
37223 ENDIF
37224 IF(AXMI.GT.XMGR+XMZ) THEN
37225 LKNT=LKNT+1
37226 IDLAM(LKNT,1)=IDG
37227 IDLAM(LKNT,2)=23
37228 IDLAM(LKNT,3)=0
37229 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,1)*SINW-ZMIXC(IX,2)*COSW)**2 +
37230 $ .5D0*ABS(ZMIXC(IX,3)*CBETA-ZMIXC(IX,4)*SBETA)**2)*
37231 & (1D0-XMZ2/XMI2)**4
37232 ENDIF
37233 IF(AXMI.GT.XMGR+PMAS(25,1)) THEN
37234 LKNT=LKNT+1
37235 IDLAM(LKNT,1)=IDG
37236 IDLAM(LKNT,2)=25
37237 IDLAM(LKNT,3)=0
37238 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SALFA-ZMIXC(IX,4)*CALFA)**2)*
37239 $ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4
37240 ENDIF
37241 IF(AXMI.GT.XMGR+PMAS(35,1)) THEN
37242 LKNT=LKNT+1
37243 IDLAM(LKNT,1)=IDG
37244 IDLAM(LKNT,2)=35
37245 IDLAM(LKNT,3)=0
37246 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*CALFA+ZMIXC(IX,4)*SALFA)**2)*
37247 $ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4
37248 ENDIF
37249 IF(AXMI.GT.XMGR+PMAS(36,1)) THEN
37250 LKNT=LKNT+1
37251 IDLAM(LKNT,1)=IDG
37252 IDLAM(LKNT,2)=36
37253 IDLAM(LKNT,3)=0
37254 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SBETA+ZMIXC(IX,4)*CBETA)**2)*
37255 $ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4
37256 ENDIF
37257 IF(IX.EQ.1) GOTO 300
37258 ENDIF
37259
37260 DO 220 IJ=1,IX-1
37261 XMJ=SMZ(IJ)
37262 AXMJ=ABS(XMJ)
37263 XMJ2=XMJ**2
37264
37265C...CHI0_I -> CHI0_J + GAMMA
37266 IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN
37267 RAT1=ABS(ZMIXC(IJ,1))**2+ABS(ZMIXC(IJ,2))**2
37268 RAT1=RAT1/( 1D-6+ABS(ZMIXC(IX,3))**2+ABS(ZMIXC(IX,4))**2 )
37269 RAT2=ABS(ZMIXC(IX,1))**2+ABS(ZMIXC(IX,2))**2
37270 RAT2=RAT2/( 1D-6+ABS(ZMIXC(IJ,3))**2+ABS(ZMIXC(IJ,4))**2 )
37271 IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR.
37272 & (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN
37273 LKNT=LKNT+1
37274 IDLAM(LKNT,1)=KFNCHI(IJ)
37275 IDLAM(LKNT,2)=22
37276 IDLAM(LKNT,3)=0
37277 GAMCON=AEM**3/8D0/PI/XMW2/XW
37278 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
37279 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
37280 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
37281 ENDIF
37282 ENDIF
37283
37284C...CHI0_I -> CHI0_J + Z0
37285 IF(AXMI.GE.AXMJ+XMZ) THEN
37286 LKNT=LKNT+1
37287 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
37288 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
37289 ORPP=-DCONJG(OLPP)
37290 GX2=ABS(OLPP)**2+ABS(ORPP)**2
37291 GLR=DBLE(OLPP*DCONJG(ORPP))
37292 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
37293 IDLAM(LKNT,1)=KFNCHI(IJ)
37294 IDLAM(LKNT,2)=23
37295 IDLAM(LKNT,3)=0
37296 ELSEIF(AXMI.GE.AXMJ) THEN
37297 XXC(1)=0D0
37298 XXC(2)=XMJ
37299 XXC(3)=0D0
37300 XXC(4)=XMI
37301 XXC(9)=XMZ
37302 XXC(10)=PMAS(23,2)
37303 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
37304 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
37305 ORPP=DCONJG(OLPP)
37306C...CHARGED LEPTONS
37307 FID=11
37308 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
37309 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
37310 EI=KCHG(FID,1)/3D0
37311 T3I=SIGN(1D0,EI+1D-6)/2D0
37312 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
37313 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
37314 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
37315 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
37316 CXC(2)=-GLIJ
37317 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
37318 CXC(4)=DCONJG(GLIJ)
37319 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
37320 CXC(6)=GRIJ
37321 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
37322 CXC(8)=-DCONJG(GRIJ)
37323 S12MIN=0D0
37324 S12MAX=(AXMI-AXMJ)**2
37325 IF( XXC(5).LT.AXMI ) THEN
37326 XXC(5)=1D6
37327 ENDIF
37328 IF(XXC(6).LT.AXMI ) THEN
37329 XXC(6)=1D6
37330 ENDIF
37331 XXC(7)=XXC(5)
37332 XXC(8)=XXC(6)
37333
37334 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
37335 LKNT=LKNT+1
37336 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37337 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
37338 IDLAM(LKNT,1)=KFNCHI(IJ)
37339 IDLAM(LKNT,2)=FID
37340 IDLAM(LKNT,3)=-FID
37341 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
37342 LKNT=LKNT+1
37343 XLAM(LKNT)=XLAM(LKNT-1)
37344 IDLAM(LKNT,1)=KFNCHI(IJ)
37345 IDLAM(LKNT,2)=13
37346 IDLAM(LKNT,3)=-13
37347 ENDIF
37348 ENDIF
37349 140 CONTINUE
37350 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
37351 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
37352 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
37353 ELSE
37354 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
37355 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
37356 ENDIF
37357 IF( XXC(5).LT.AXMI ) THEN
37358 XXC(5)=1D6
37359 ENDIF
37360 IF(XXC(6).LT.AXMI ) THEN
37361 XXC(6)=1D6
37362 ENDIF
37363 XXC(7)=XXC(5)
37364 XXC(8)=XXC(6)
37365
37366 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
37367 LKNT=LKNT+1
37368 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37369 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
37370 IDLAM(LKNT,1)=KFNCHI(IJ)
37371 IDLAM(LKNT,2)=15
37372 IDLAM(LKNT,3)=-15
37373 ENDIF
37374
37375C...NEUTRINOS
37376 150 CONTINUE
37377 FID=12
37378 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
37379 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
37380 EI=KCHG(FID,1)/3D0
37381 T3I=SIGN(1D0,EI+1D-6)/2D0
37382 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
37383 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
37384 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
37385 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
37386 CXC(2)=-GLIJ
37387 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
37388 CXC(4)=DCONJG(GLIJ)
37389 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
37390 CXC(6)=GRIJ
37391 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
37392 CXC(8)=-DCONJG(GRIJ)
37393 S12MIN=0D0
37394 S12MAX=(AXMI-AXMJ)**2
37395 IF( XXC(5).LT.AXMI ) THEN
37396 XXC(5)=1D6
37397 ENDIF
37398 IF( XXC(6).LT.AXMI ) THEN
37399 XXC(6)=1D6
37400 ENDIF
37401 XXC(7)=XXC(5)
37402 XXC(8)=XXC(6)
37403
37404 LKNT=LKNT+1
37405 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37406 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
37407 IDLAM(LKNT,1)=KFNCHI(IJ)
37408 IDLAM(LKNT,2)=12
37409 IDLAM(LKNT,3)=-12
37410 LKNT=LKNT+1
37411 XLAM(LKNT)=XLAM(LKNT-1)
37412 IDLAM(LKNT,1)=KFNCHI(IJ)
37413 IDLAM(LKNT,2)=14
37414 IDLAM(LKNT,3)=-14
37415 160 CONTINUE
37416
37417 IF(PMAS(PYCOMP(KSUSY1+16),1).NE.PMAS(PYCOMP(KSUSY1+12),1))
37418 & THEN
37419 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
37420 IF( XXC(5).LT.AXMI ) THEN
37421 XXC(5)=1D6
37422 ENDIF
37423 XXC(7)=XXC(5)
37424 LKNT=LKNT+1
37425 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37426 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
37427 ELSE
37428 LKNT=LKNT+1
37429 XLAM(LKNT)=XLAM(LKNT-1)
37430 ENDIF
37431 IDLAM(LKNT,1)=KFNCHI(IJ)
37432 IDLAM(LKNT,2)=16
37433 IDLAM(LKNT,3)=-16
37434C...D-TYPE QUARKS
37435 170 CONTINUE
37436 FID=1
37437 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
37438 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
37439 EI=KCHG(FID,1)/3D0
37440 T3I=SIGN(1D0,EI+1D-6)/2D0
37441 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
37442 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
37443 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
37444 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
37445 CXC(2)=-GLIJ
37446 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
37447 CXC(4)=DCONJG(GLIJ)
37448 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
37449 CXC(6)=GRIJ
37450 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
37451 CXC(8)=-DCONJG(GRIJ)
37452 S12MIN=0D0
37453 S12MAX=(AXMI-AXMJ)**2
37454 IF( XXC(5).LT.AXMI ) THEN
37455 XXC(5)=1D6
37456 ENDIF
37457 IF( XXC(6).LT.AXMI ) THEN
37458 XXC(6)=1D6
37459 ENDIF
37460 XXC(7)=XXC(5)
37461 XXC(8)=XXC(6)
37462
37463 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
37464 LKNT=LKNT+1
37465 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37466 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
37467 IDLAM(LKNT,1)=KFNCHI(IJ)
37468 IDLAM(LKNT,2)=1
37469 IDLAM(LKNT,3)=-1
37470 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
37471 LKNT=LKNT+1
37472 XLAM(LKNT)=XLAM(LKNT-1)
37473 IDLAM(LKNT,1)=KFNCHI(IJ)
37474 IDLAM(LKNT,2)=3
37475 IDLAM(LKNT,3)=-3
37476 ENDIF
37477 ENDIF
37478 180 CONTINUE
37479 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
37480 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
37481 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
37482 ELSE
37483 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
37484 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
37485 ENDIF
37486 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
37487 IF(XXC(5).LT.AXMI) THEN
37488 XXC(5)=1D6
37489 ELSEIF(XXC(6).LT.AXMI) THEN
37490 XXC(6)=1D6
37491 ENDIF
37492 XXC(7)=XXC(5)
37493 XXC(8)=XXC(6)
37494 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
37495 LKNT=LKNT+1
37496 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37497 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
37498 IDLAM(LKNT,1)=KFNCHI(IJ)
37499 IDLAM(LKNT,2)=5
37500 IDLAM(LKNT,3)=-5
37501 ENDIF
37502
37503C...U-TYPE QUARKS
37504 190 CONTINUE
37505 FID=2
37506 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
37507 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
37508 EI=KCHG(FID,1)/3D0
37509 T3I=SIGN(1D0,EI+1D-6)/2D0
37510 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
37511 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
37512 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
37513 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
37514 CXC(2)=-GLIJ
37515 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
37516 CXC(4)=DCONJG(GLIJ)
37517 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
37518 CXC(6)=GRIJ
37519 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
37520 CXC(8)=-DCONJG(GRIJ)
37521
37522 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 200
37523 IF(XXC(5).LT.AXMI) THEN
37524 XXC(5)=1D6
37525 ELSEIF(XXC(6).LT.AXMI) THEN
37526 XXC(6)=1D6
37527 ENDIF
37528 XXC(7)=XXC(5)
37529 XXC(8)=XXC(6)
37530
37531 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
37532 LKNT=LKNT+1
37533 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37534 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
37535 IDLAM(LKNT,1)=KFNCHI(IJ)
37536 IDLAM(LKNT,2)=2
37537 IDLAM(LKNT,3)=-2
37538 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
37539 LKNT=LKNT+1
37540 XLAM(LKNT)=XLAM(LKNT-1)
37541 IDLAM(LKNT,1)=KFNCHI(IJ)
37542 IDLAM(LKNT,2)=4
37543 IDLAM(LKNT,3)=-4
37544 ENDIF
37545 ENDIF
37546 200 CONTINUE
37547 ENDIF
37548
37549C...CHI0_I -> CHI0_J + H0_K
37550 EH(1)=SIN(ALFA)
37551 EH(2)=COS(ALFA)
37552 EH(3)=-SIN(BETA)
37553 DH(1)=COS(ALFA)
37554 DH(2)=-SIN(ALFA)
37555 DH(3)=COS(BETA)
37556 QIJ=ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,2))+
37557 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,2)-
37558 & TANW*(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,1))+
37559 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,1))
37560 RIJ=DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,2)+
37561 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,2))-
37562 & TANW*(DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,1)+
37563 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,1)))
37564 DO 210 IH=1,3
37565 XMH=PMAS(ITH(IH),1)
37566 XMH2=XMH**2
37567 IF(AXMI.GE.AXMJ+XMH) THEN
37568 LKNT=LKNT+1
37569 XL=PYLAMF(XMI2,XMJ2,XMH2)
37570 F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH))
37571 F12K=F21K
37572C...SIGN OF MASSES I,J
37573 XMK=XMJ
37574 IF(IH.EQ.3) XMK=-XMK
37575 GX2=ABS(F21K)**2+ABS(F12K)**2
37576 GLR=DBLE(F21K*DCONJG(F12K))
37577 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
37578 IDLAM(LKNT,1)=KFNCHI(IJ)
37579 IDLAM(LKNT,2)=ITH(IH)
37580 IDLAM(LKNT,3)=0
37581 ENDIF
37582 210 CONTINUE
37583 220 CONTINUE
37584
37585C...CHI0_I -> CHI+_J + W-
37586 DO 260 IJ=1,2
37587 XMJ=SMW(IJ)
37588 AXMJ=ABS(XMJ)
37589 XMJ2=XMJ**2
37590 IF(AXMI.GE.AXMJ+XMW) THEN
37591 LKNT=LKNT+1
37592 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
37593 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)/SR2)
37594 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
37595 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))/SR2)
37596 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
37597 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
37598 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
37599 IDLAM(LKNT,1)=KFCCHI(IJ)
37600 IDLAM(LKNT,2)=-24
37601 IDLAM(LKNT,3)=0
37602 LKNT=LKNT+1
37603 XLAM(LKNT)=XLAM(LKNT-1)
37604 IDLAM(LKNT,1)=-KFCCHI(IJ)
37605 IDLAM(LKNT,2)=24
37606 IDLAM(LKNT,3)=0
37607 ELSEIF(AXMI.GE.AXMJ) THEN
37608 S12MIN=0D0
37609 S12MAX=(AXMI-AXMJ)**2
37610 RT2I = 1D0/SQRT(2D0)
37611 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
37612 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)*RT2I)*RT2I
37613 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
37614 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))*RT2I)*RT2I
37615 CXC(5)=DCMPLX(0D0,0D0)
37616 CXC(7)=DCMPLX(0D0,0D0)
37617 IA=11
37618 JA=12
37619 EI=KCHG(IA,1)/3D0
37620 T3I=SIGN(1D0,EI+1D-6)/2D0
37621 EJ=KCHG(JA,1)/3D0
37622 T3J=SIGN(1D0,EJ+1D-6)/2D0
37623 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
37624 & TANW+ZMIXC(IX,2)*T3J)*RT2I
37625 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
37626 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)*RT2I
37627 CXC(6)=DCMPLX(0D0,0D0)
37628 CXC(8)=DCMPLX(0D0,0D0)
37629 XXC(1)=0D0
37630 XXC(2)=XMJ
37631 XXC(3)=0D0
37632 XXC(4)=XMI
37633 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
37634 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
37635 XXC(9)=PMAS(24,1)
37636 XXC(10)=PMAS(24,2)
37637 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 230
37638 IF(XXC(5).LT.AXMI) THEN
37639 XXC(5)=1D6
37640 ELSEIF(XXC(6).LT.AXMI) THEN
37641 XXC(6)=1D6
37642 ENDIF
37643 XXC(7)=XXC(6)
37644 XXC(8)=XXC(5)
37645 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
37646 LKNT=LKNT+1
37647 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37648 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
37649 IDLAM(LKNT,1)=KFCCHI(IJ)
37650 IDLAM(LKNT,2)=11
37651 IDLAM(LKNT,3)=-12
37652 LKNT=LKNT+1
37653 XLAM(LKNT)=XLAM(LKNT-1)
37654 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37655 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37656 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
37657 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
37658 LKNT=LKNT+1
37659 XLAM(LKNT)=XLAM(LKNT-1)
37660 IDLAM(LKNT,1)=KFCCHI(IJ)
37661 IDLAM(LKNT,2)=13
37662 IDLAM(LKNT,3)=-14
37663 LKNT=LKNT+1
37664 XLAM(LKNT)=XLAM(LKNT-1)
37665 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37666 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37667 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
37668 ENDIF
37669 ENDIF
37670 230 CONTINUE
37671 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
37672 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
37673 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
37674 ELSE
37675 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
37676 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
37677 ENDIF
37678 IF(XXC(5).LT.AXMI) THEN
37679 XXC(5)=1D6
37680 ENDIF
37681 IF(XXC(6).LT.AXMI) THEN
37682 XXC(6)=1D6
37683 ENDIF
37684 XXC(7)=XXC(6)
37685 XXC(8)=XXC(5)
37686 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
37687 LKNT=LKNT+1
37688 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37689 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
37690 XLAM(LKNT)=XLAM(LKNT-1)
37691 IDLAM(LKNT,1)=KFCCHI(IJ)
37692 IDLAM(LKNT,2)=15
37693 IDLAM(LKNT,3)=-16
37694 LKNT=LKNT+1
37695 XLAM(LKNT)=XLAM(LKNT-1)
37696 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37697 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37698 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
37699 ENDIF
37700
37701C...NOW, DO THE QUARKS
37702 240 CONTINUE
37703 IA=1
37704 JA=2
37705 EI=KCHG(IA,1)/3D0
37706 T3I=SIGN(1D0,EI+1D-6)/2D0
37707 EJ=KCHG(JA,1)/3D0
37708 T3J=SIGN(1D0,EJ+1D-6)/2D0
37709 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
37710 & TANW+ZMIXC(IX,2)*T3J)
37711 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
37712 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)
37713 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
37714 XXC(6)=PMAS(PYCOMP(KSUSY1+JA),1)
37715 IF(XXC(5).LT.AXMI) THEN
37716 XXC(5)=1D6
37717 ENDIF
37718 IF(XXC(6).LT.AXMI) THEN
37719 XXC(6)=1D6
37720 ENDIF
37721 XXC(7)=XXC(6)
37722 XXC(8)=XXC(5)
37723 IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN
37724 LKNT=LKNT+1
37725 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
37726 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
37727 IDLAM(LKNT,1)=KFCCHI(IJ)
37728 IDLAM(LKNT,2)=1
37729 IDLAM(LKNT,3)=-2
37730 LKNT=LKNT+1
37731 XLAM(LKNT)=XLAM(LKNT-1)
37732 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37733 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37734 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
37735 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
37736 LKNT=LKNT+1
37737 XLAM(LKNT)=XLAM(LKNT-1)
37738 IDLAM(LKNT,1)=KFCCHI(IJ)
37739 IDLAM(LKNT,2)=3
37740 IDLAM(LKNT,3)=-4
37741 LKNT=LKNT+1
37742 XLAM(LKNT)=XLAM(LKNT-1)
37743 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37744 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37745 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
37746 ENDIF
37747 ENDIF
37748 250 CONTINUE
37749 ENDIF
37750 260 CONTINUE
37751 270 CONTINUE
37752
37753C...CHI0_I -> CHI+_I + H-
37754 DO 280 IJ=1,2
37755 XMJ=SMW(IJ)
37756 AXMJ=ABS(XMJ)
37757 XMJ2=XMJ**2
37758 XMHP=PMAS(ITHC,1)
37759 IF(AXMI.GE.AXMJ+XMHP) THEN
37760 LKNT=LKNT+1
37761 OLPP=CBETA*(ZMIXC(IX,4)*DCONJG(VMIXC(IJ,1))+(ZMIXC(IX,2)+
37762 & ZMIXC(IX,1)*TANW)*DCONJG(VMIXC(IJ,2))/SR2)
37763 ORPP=SBETA*(DCONJG(ZMIXC(IX,3))*UMIXC(IJ,1)-
37764 & (DCONJG(ZMIXC(IX,2))+DCONJG(ZMIXC(IX,1))*TANW)*
37765 & UMIXC(IJ,2)/SR2)
37766 GX2=ABS(OLPP)**2+ABS(ORPP)**2
37767 GLR=DBLE(OLPP*DCONJG(ORPP))
37768 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
37769 IDLAM(LKNT,1)=KFCCHI(IJ)
37770 IDLAM(LKNT,2)=-ITHC
37771 IDLAM(LKNT,3)=0
37772 LKNT=LKNT+1
37773 XLAM(LKNT)=XLAM(LKNT-1)
37774 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37775 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37776 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
37777 ELSE
37778
37779 ENDIF
37780 280 CONTINUE
37781
37782C...2-BODY DECAYS TO FERMION SFERMION
37783 DO 290 J=1,16
37784 IF(J.GE.7.AND.J.LE.10) GOTO 290
37785 KF1=KSUSY1+J
37786 KF2=KSUSY2+J
37787 XMSF1=PMAS(PYCOMP(KF1),1)
37788 XMSF2=PMAS(PYCOMP(KF2),1)
37789 XMF=PMAS(J,1)
37790 IF(J.LE.6) THEN
37791 FCOL=3D0
37792 ELSE
37793 FCOL=1D0
37794 ENDIF
37795
37796 EI=KCHG(J,1)/3D0
37797 T3T=SIGN(1D0,EI)
37798 IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0
37799 IF(MOD(J,2).EQ.0) THEN
37800 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
37801 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
37802 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
37803 CBR=CAL
37804 ELSE
37805 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
37806 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
37807 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
37808 CBR=CAL
37809 ENDIF
37810
37811C...D~ D_L
37812 IF(AXMI.GE.XMF+XMSF1) THEN
37813 LKNT=LKNT+1
37814 XMA2=XMSF1**2
37815 XMB2=XMF**2
37816 XL=PYLAMF(XMI2,XMA2,XMB2)
37817 CA=CAL*SFMIX(J,1)+CAR*SFMIX(J,2)
37818 CB=CBL*SFMIX(J,1)+CBR*SFMIX(J,2)
37819 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
37820 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
37821 IDLAM(LKNT,1)=KF1
37822 IDLAM(LKNT,2)=-J
37823 IDLAM(LKNT,3)=0
37824 LKNT=LKNT+1
37825 XLAM(LKNT)=XLAM(LKNT-1)
37826 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37827 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37828 IDLAM(LKNT,3)=0
37829 ENDIF
37830
37831C...D~ D_R
37832 IF(AXMI.GE.XMF+XMSF2) THEN
37833 LKNT=LKNT+1
37834 XMA2=XMSF2**2
37835 XMB2=XMF**2
37836 CA=CAL*SFMIX(J,3)+CAR*SFMIX(J,4)
37837 CB=CBL*SFMIX(J,3)+CBR*SFMIX(J,4)
37838 XL=PYLAMF(XMI2,XMA2,XMB2)
37839 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
37840 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
37841 IDLAM(LKNT,1)=KF2
37842 IDLAM(LKNT,2)=-J
37843 IDLAM(LKNT,3)=0
37844 LKNT=LKNT+1
37845 XLAM(LKNT)=XLAM(LKNT-1)
37846 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37847 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37848 IDLAM(LKNT,3)=0
37849 ENDIF
37850 290 CONTINUE
37851 300 CONTINUE
37852C...3-BODY DECAY TO Q Q~ GLUINO
37853 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
37854 IF(AXMI.GE.XMJ) THEN
37855 RT2I = 1D0/SQRT(2D0)
37856 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))*RT2I
37857 ORPP=DCONJG(OLPP)
37858 AXMJ=ABS(XMJ)
37859 XXC(1)=0D0
37860 XXC(2)=XMJ
37861 XXC(3)=0D0
37862 XXC(4)=XMI
37863 FID=1
37864 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
37865 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
37866 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 310
37867 XXC(7)=XXC(5)
37868 XXC(8)=XXC(6)
37869 XXC(9)=1D6
37870 XXC(10)=0D0
37871 EI=KCHG(FID,1)/3D0
37872 T3I=SIGN(1D0,EI+1D-6)/2D0
37873 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
37874 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
37875 CXC(1)=0D0
37876 CXC(2)=-GLIJ
37877 CXC(3)=0D0
37878 CXC(4)=DCONJG(GLIJ)
37879 CXC(5)=0D0
37880 CXC(6)=GRIJ
37881 CXC(7)=0D0
37882 CXC(8)=-DCONJG(GRIJ)
37883 S12MIN=0D0
37884 S12MAX=(AXMI-AXMJ)**2
37885C...ALL QUARKS BUT T
37886 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
37887 LKNT=LKNT+1
37888 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
37889 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
37890 IDLAM(LKNT,1)=KSUSY1+21
37891 IDLAM(LKNT,2)=1
37892 IDLAM(LKNT,3)=-1
37893 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
37894 LKNT=LKNT+1
37895 XLAM(LKNT)=XLAM(LKNT-1)
37896 IDLAM(LKNT,1)=KSUSY1+21
37897 IDLAM(LKNT,2)=3
37898 IDLAM(LKNT,3)=-3
37899 ENDIF
37900 ENDIF
37901 310 CONTINUE
37902 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
37903 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
37904 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
37905 ELSE
37906 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
37907 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
37908 ENDIF
37909 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 320
37910 XXC(7)=XXC(5)
37911 XXC(8)=XXC(6)
37912 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
37913 LKNT=LKNT+1
37914 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
37915 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
37916 IDLAM(LKNT,1)=KSUSY1+21
37917 IDLAM(LKNT,2)=5
37918 IDLAM(LKNT,3)=-5
37919 ENDIF
37920C...U-TYPE QUARKS
37921 320 CONTINUE
37922 FID=2
37923 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
37924 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
37925 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 330
37926 XXC(7)=XXC(5)
37927 XXC(8)=XXC(6)
37928 EI=KCHG(FID,1)/3D0
37929 T3I=SIGN(1D0,EI+1D-6)/2D0
37930 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
37931 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
37932 CXC(2)=-GLIJ
37933 CXC(4)=DCONJG(GLIJ)
37934 CXC(6)=GRIJ
37935 CXC(8)=-DCONJG(GRIJ)
37936 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
37937 LKNT=LKNT+1
37938 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
37939 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
37940 IDLAM(LKNT,1)=KSUSY1+21
37941 IDLAM(LKNT,2)=2
37942 IDLAM(LKNT,3)=-2
37943 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
37944 LKNT=LKNT+1
37945 XLAM(LKNT)=XLAM(LKNT-1)
37946 IDLAM(LKNT,1)=KSUSY1+21
37947 IDLAM(LKNT,2)=4
37948 IDLAM(LKNT,3)=-4
37949 ENDIF
37950 ENDIF
37951 330 CONTINUE
37952 ENDIF
37953
37954C...R-violating decay modes (SKANDS).
37955 CALL PYRVNE(KFIN,XLAM,IDLAM,LKNT)
37956
37957 340 IKNT=LKNT
37958 XLAM(0)=0D0
37959 DO 350 I=1,IKNT
37960 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
37961 XLAM(0)=XLAM(0)+XLAM(I)
37962 350 CONTINUE
37963 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
37964
37965 RETURN
37966 END
37967
37968C*********************************************************************
37969
37970C...PYCJDC
37971C...Calculate decay widths for the charginos (admixtures of
37972C...charged Wino and charged Higgsino.
37973
37974C...Input: KCIN = KF code for particle
37975C...Output: XLAM = widths
37976C... IDLAM = KF codes for decay particles
37977C... IKNT = number of decay channels defined
37978C...AUTHOR: STEPHEN MRENNA
37979C...Last change:
37980C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
37981C...when CHIENU .NE. 0
37982
37983 SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT)
37984
37985C...Double precision and integer declarations.
37986 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37987 IMPLICIT INTEGER(I-N)
37988 INTEGER PYK,PYCHGE,PYCOMP
37989C...Parameter statement to help give large particle numbers.
37990 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
37991 &KEXCIT=4000000,KDIMEN=5000000)
37992C...Commonblocks.
37993 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37994 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37995 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
37996 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
37997 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
37998CC &SFMIX(16,4),
37999C COMMON/PYINTS/XXM(20)
38000 COMPLEX*16 CXC
38001 COMMON/PYINTC/XXC(10),CXC(8)
38002 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
38003
38004C...Local variables
38005 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
38006 COMPLEX*16 CAL,CBL,CAR,CBR,CA,CB
38007 INTEGER KFIN,KCIN
38008 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
38009 &XMZ,XMZ2,AXMJ,AXMI
38010 DOUBLE PRECISION S12MIN,S12MAX
38011 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2,XMK
38012 DOUBLE PRECISION PYLAMF,XL
38013 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I,BETA,ALFA
38014 DOUBLE PRECISION PYX2XH,PYX2XG
38015 DOUBLE PRECISION XLAM(0:400)
38016 INTEGER IDLAM(400,3)
38017 INTEGER LKNT,IX,IH,J,IJ,I,IKNT
38018 INTEGER ITH(3)
38019 INTEGER ITHC
38020 DOUBLE PRECISION ETAH(3),DH(3),EH(3)
38021 DOUBLE PRECISION SR2
38022 DOUBLE PRECISION CBETA,SBETA,TANB
38023
38024 DOUBLE PRECISION PYALEM,PI,PYALPS
38025 DOUBLE PRECISION FCOL
38026 INTEGER KF1,KF2,ISF
38027 INTEGER KFNCHI(4),KFCCHI(2)
38028
38029 DOUBLE PRECISION TEMP
38030 EXTERNAL PYGAUS,PYXXZ6
38031 DOUBLE PRECISION PYGAUS,PYXXZ6
38032 DOUBLE PRECISION PREC
38033 DATA ITH/25,35,36/
38034 DATA ITHC/37/
38035 DATA ETAH/1D0,1D0,-1D0/
38036 DATA SR2/1.4142136D0/
38037 DATA PI/3.141592654D0/
38038 DATA PREC/1D-2/
38039 DATA KFNCHI/1000022,1000023,1000025,1000035/
38040 DATA KFCCHI/1000024,1000037/
38041
38042C...COUNT THE NUMBER OF DECAY MODES
38043 LKNT=0
38044 XMW=PMAS(24,1)
38045 XMW2=XMW**2
38046 XMZ=PMAS(23,1)
38047 XMZ2=XMZ**2
38048 XW=1D0-XMW2/XMZ2
38049 XW1=1D0-XW
38050 TANW = SQRT(XW/XW1)
38051
38052C...1 OR 2 DEPENDING ON CHARGINO TYPE
38053 IX=1
38054 IF(KFIN.EQ.KFCCHI(2)) IX=2
38055 KCIN=PYCOMP(KFIN)
38056
38057 XMI=SMW(IX)
38058 XMI2=XMI**2
38059 AXMI=ABS(XMI)
38060 AEM=PYALEM(XMI2)
38061 AS =PYALPS(XMI2)
38062 C1=AEM/XW
38063 XMI3=ABS(XMI**3)
38064 TANB=RMSS(5)
38065 BETA=ATAN(TANB)
38066 CBETA=COS(BETA)
38067 SBETA=TANB*CBETA
38068 ALFA=RMSS(18)
38069
38070 DO 110 I=1,2
38071 DO 100 J=1,2
38072 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
38073 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
38074 100 CONTINUE
38075 110 CONTINUE
38076
38077C...GRAVITINO DECAY MODES
38078
38079 IF(IMSS(11).EQ.1) THEN
38080 XMP=RMSS(29)
38081 IDG=39+KSUSY1
38082 XMGR=PMAS(PYCOMP(IDG),1)
38083C SINW=SQRT(XW)
38084C COSW=SQRT(1D0-XW)
38085 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
38086 IF(AXMI.GT.XMGR+XMW) THEN
38087 LKNT=LKNT+1
38088 IDLAM(LKNT,1)=IDG
38089 IDLAM(LKNT,2)=24
38090 IDLAM(LKNT,3)=0
38091 XLAM(LKNT)=XFAC*(
38092 & .5D0*(ABS(VMIXC(IX,1))**2+ABS(UMIXC(IX,1))**2)+
38093 & .5D0*((ABS(VMIXC(IX,2))*SBETA)**2+(ABS(UMIXC(IX,2))*CBETA)**2))*
38094 & (1D0-XMW2/XMI2)**4
38095 ENDIF
38096 IF(AXMI.GT.XMGR+PMAS(37,1)) THEN
38097 LKNT=LKNT+1
38098 IDLAM(LKNT,1)=IDG
38099 IDLAM(LKNT,2)=37
38100 IDLAM(LKNT,3)=0
38101 XLAM(LKNT)=XFAC*(.5D0*((ABS(VMIXC(IX,2))*CBETA)**2+
38102 & (ABS(UMIXC(IX,2))*SBETA)**2))
38103 & *(1D0-PMAS(37,1)**2/XMI2)**4
38104 ENDIF
38105 ENDIF
38106
38107C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
38108 IF(IX.EQ.1) GOTO 170
38109 XMJ=SMW(1)
38110 AXMJ=ABS(XMJ)
38111 XMJ2=XMJ**2
38112
38113C...CHI_2+ -> CHI_1+ + Z0
38114 IF(AXMI.GE.AXMJ+XMZ) THEN
38115 LKNT=LKNT+1
38116 IJ=1
38117 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
38118 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
38119 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
38120 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
38121 GX2=ABS(OLPP)**2+ABS(ORPP)**2
38122 GLR=DBLE(OLPP*DCONJG(ORPP))
38123 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
38124 IDLAM(LKNT,1)=KFCCHI(1)
38125 IDLAM(LKNT,2)=23
38126 IDLAM(LKNT,3)=0
38127
38128C...CHARGED LEPTONS
38129 ELSEIF(AXMI.GE.AXMJ) THEN
38130 S12MIN=0D0
38131 S12MAX=(AXMI-AXMJ)**2
38132 IA=11
38133 JA=12
38134 EI=KCHG(IABS(IA),1)/3D0
38135 T3I=SIGN(1D0,EI+1D-6)/2D0
38136 XXC(1)=0D0
38137 XXC(2)=XMJ
38138 XXC(3)=0D0
38139 XXC(4)=XMI
38140 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
38141 XXC(6)=1D6
38142 XXC(9)=PMAS(23,1)
38143 XXC(10)=PMAS(23,2)
38144 IJ=1
38145 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
38146 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
38147 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
38148 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
38149 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
38150 CXC(2)=DCMPLX(0D0,0D0)
38151 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
38152 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
38153 CXC(5)=-DCMPLX(EI/XW1)*ORPP
38154 CXC(6)=DCMPLX(0D0,0D0)
38155 CXC(7)=-DCMPLX(EI/XW1)*OLPP
38156 CXC(8)=DCMPLX(0D0,0D0)
38157 IF( XXC(5).LT.AXMI ) THEN
38158 XXC(5)=1D6
38159 ENDIF
38160 XXC(7)=XXC(5)
38161 XXC(8)=XXC(6)
38162 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
38163 LKNT=LKNT+1
38164 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
38165 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38166 IDLAM(LKNT,1)=KFCCHI(1)
38167 IDLAM(LKNT,2)=11
38168 IDLAM(LKNT,3)=-11
38169 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
38170 LKNT=LKNT+1
38171 XLAM(LKNT)=XLAM(LKNT-1)
38172 IDLAM(LKNT,1)=KFCCHI(1)
38173 IDLAM(LKNT,2)=13
38174 IDLAM(LKNT,3)=-13
38175 ENDIF
38176 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
38177 LKNT=LKNT+1
38178 XLAM(LKNT)=XLAM(LKNT-1)
38179 IDLAM(LKNT,1)=KFCCHI(1)
38180 IDLAM(LKNT,2)=15
38181 IDLAM(LKNT,3)=-15
38182 ENDIF
38183 ENDIF
38184
38185C...NEUTRINOS
38186 120 CONTINUE
38187 IA=12
38188 JA=11
38189 EI=KCHG(IABS(IA),1)/3D0
38190 T3I=SIGN(1D0,EI+1D-6)/2D0
38191 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
38192 XXC(6)=1D6
38193 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
38194 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
38195 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
38196 CXC(5)=-DCMPLX(EI/XW1)*ORPP
38197 CXC(7)=-DCMPLX(EI/XW1)*OLPP
38198 IF( XXC(5).LT.AXMI ) THEN
38199 XXC(5)=1D6
38200 ENDIF
38201 XXC(7)=XXC(5)
38202 XXC(8)=XXC(6)
38203 IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN
38204 LKNT=LKNT+1
38205 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
38206 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38207 IDLAM(LKNT,1)=KFCCHI(1)
38208 IDLAM(LKNT,2)=12
38209 IDLAM(LKNT,3)=-12
38210 LKNT=LKNT+1
38211 XLAM(LKNT)=XLAM(LKNT-1)
38212 IDLAM(LKNT,1)=KFCCHI(1)
38213 IDLAM(LKNT,2)=14
38214 IDLAM(LKNT,3)=-14
38215 ENDIF
38216 IF(AXMI.GE.AXMJ+2D0*PMAS(16,1)) THEN
38217 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
38218 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
38219 ELSE
38220 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
38221 ENDIF
38222 IF( XXC(5).LT.AXMI ) THEN
38223 XXC(5)=1D6
38224 ENDIF
38225 XXC(7)=XXC(5)
38226 LKNT=LKNT+1
38227 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
38228 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38229 IDLAM(LKNT,1)=KFCCHI(1)
38230 IDLAM(LKNT,2)=16
38231 IDLAM(LKNT,3)=-16
38232 ENDIF
38233
38234C...D-TYPE QUARKS
38235 130 CONTINUE
38236 IA=1
38237 JA=2
38238 EI=KCHG(IABS(IA),1)/3D0
38239 T3I=SIGN(1D0,EI+1D-6)/2D0
38240 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
38241 XXC(6)=1D6
38242 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
38243 CXC(2)=DCMPLX(0D0,0D0)
38244 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
38245 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
38246 CXC(5)=-DCMPLX(EI/XW1)*ORPP
38247 CXC(6)=DCMPLX(0D0,0D0)
38248 CXC(7)=-DCMPLX(EI/XW1)*OLPP
38249 CXC(8)=DCMPLX(0D0,0D0)
38250 IF( XXC(5).LT.AXMI ) THEN
38251 XXC(5)=1D6
38252 ENDIF
38253 XXC(7)=XXC(5)
38254 XXC(8)=XXC(6)
38255 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
38256 LKNT=LKNT+1
38257 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
38258 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38259 IDLAM(LKNT,1)=KFCCHI(1)
38260 IDLAM(LKNT,2)=1
38261 IDLAM(LKNT,3)=-1
38262 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
38263 LKNT=LKNT+1
38264 XLAM(LKNT)=XLAM(LKNT-1)
38265 IDLAM(LKNT,1)=KFCCHI(1)
38266 IDLAM(LKNT,2)=3
38267 IDLAM(LKNT,3)=-3
38268 ENDIF
38269 ENDIF
38270 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
38271 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
38272 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
38273 ELSE
38274 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
38275 ENDIF
38276 IF( XXC(5).LT.AXMI ) THEN
38277 XXC(5)=1D6
38278 ENDIF
38279 XXC(7)=XXC(5)
38280 LKNT=LKNT+1
38281 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
38282 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38283 IDLAM(LKNT,1)=KFCCHI(1)
38284 IDLAM(LKNT,2)=5
38285 IDLAM(LKNT,3)=-5
38286 ENDIF
38287
38288C...U-TYPE QUARKS
38289 140 CONTINUE
38290 IA=2
38291 JA=1
38292 EI=KCHG(IABS(IA),1)/3D0
38293 T3I=SIGN(1D0,EI+1D-6)/2D0
38294 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
38295 XXC(6)=1D6
38296 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
38297 CXC(2)=DCMPLX(0D0,0D0)
38298 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
38299 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
38300 CXC(5)=-DCMPLX(EI/XW1)*ORPP
38301 CXC(6)=DCMPLX(0D0,0D0)
38302 CXC(7)=-DCMPLX(EI/XW1)*OLPP
38303 CXC(8)=DCMPLX(0D0,0D0)
38304 IF( XXC(5).LT.AXMI ) THEN
38305 XXC(5)=1D6
38306 ENDIF
38307 XXC(7)=XXC(5)
38308 XXC(8)=XXC(6)
38309 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
38310 LKNT=LKNT+1
38311 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
38312 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38313 IDLAM(LKNT,1)=KFCCHI(1)
38314 IDLAM(LKNT,2)=2
38315 IDLAM(LKNT,3)=-2
38316 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
38317 LKNT=LKNT+1
38318 XLAM(LKNT)=XLAM(LKNT-1)
38319 IDLAM(LKNT,1)=KFCCHI(1)
38320 IDLAM(LKNT,2)=4
38321 IDLAM(LKNT,3)=-4
38322 ENDIF
38323 ENDIF
38324 150 CONTINUE
38325 ENDIF
38326
38327C...CHI_2+ -> CHI_1+ + H0_K
38328 EH(2)=COS(ALFA)
38329 EH(1)=SIN(ALFA)
38330 EH(3)=-SBETA
38331 DH(2)=-SIN(ALFA)
38332 DH(1)=COS(ALFA)
38333 DH(3)=COS(BETA)
38334 DO 160 IH=1,3
38335 XMH=PMAS(ITH(IH),1)
38336 XMH2=XMH**2
38337C...NO 3-BODY OPTION
38338 IF(AXMI.GE.AXMJ+XMH) THEN
38339 LKNT=LKNT+1
38340 XL=PYLAMF(XMI2,XMJ2,XMH2)
38341 OLPP=(VMIXC(2,1)*DCONJG(UMIXC(1,2))*EH(IH) -
38342 & VMIXC(2,2)*DCONJG(UMIXC(1,1))*DH(IH))/SR2
38343 ORPP=(DCONJG(VMIXC(1,1))*UMIXC(2,2)*EH(IH) -
38344 & DCONJG(VMIXC(1,2))*UMIXC(2,1)*DH(IH))/SR2
38345 XMK=XMJ*ETAH(IH)
38346 GX2=ABS(OLPP)**2+ABS(ORPP)**2
38347 GLR=DBLE(OLPP*DCONJG(ORPP))
38348 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
38349 IDLAM(LKNT,1)=KFCCHI(1)
38350 IDLAM(LKNT,2)=ITH(IH)
38351 IDLAM(LKNT,3)=0
38352 ENDIF
38353 160 CONTINUE
38354
38355C...CHI1 JUMPS TO HERE
38356 170 CONTINUE
38357
38358C...CHI+_I -> CHI0_J + W+
38359 DO 220 IJ=1,4
38360 XMJ=SMZ(IJ)
38361 AXMJ=ABS(XMJ)
38362 XMJ2=XMJ**2
38363 IF(AXMI.GE.AXMJ+XMW) THEN
38364 LKNT=LKNT+1
38365 DO 180 I=1,4
38366 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
38367 180 CONTINUE
38368 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
38369 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)
38370 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
38371 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)
38372 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
38373 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
38374 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
38375 IDLAM(LKNT,1)=KFNCHI(IJ)
38376 IDLAM(LKNT,2)=24
38377 IDLAM(LKNT,3)=0
38378C...LEPTONS
38379 ELSEIF(AXMI.GE.AXMJ) THEN
38380 S12MIN=0D0
38381 S12MAX=(AXMI-AXMJ)**2
38382 DO 190 I=1,4
38383 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
38384 190 CONTINUE
38385 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
38386 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)/SR2
38387 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
38388 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)/SR2
38389 CXC(5)=DCMPLX(0D0,0D0)
38390 CXC(7)=DCMPLX(0D0,0D0)
38391 IA=11
38392 JA=12
38393 EI=KCHG(IA,1)/3D0
38394 T3I=SIGN(1D0,EI+1D-6)/2D0
38395 EJ=KCHG(JA,1)/3D0
38396 T3J=SIGN(1D0,EJ+1D-6)/2D0
38397 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
38398 & TANW+ZMIXC(IJ,2)*T3J)/SR2
38399 CXC(4)=-DCONJG(UMIXC(IX,1))*(
38400 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)/SR2
38401 CXC(6)=DCMPLX(0D0,0D0)
38402 CXC(8)=DCMPLX(0D0,0D0)
38403 XXC(1)=0D0
38404 XXC(2)=XMJ
38405 XXC(3)=0D0
38406 XXC(4)=XMI
38407 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
38408 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
38409 XXC(9)=PMAS(24,1)
38410 XXC(10)=PMAS(24,2)
38411CCC IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
38412 IF(XXC(5).LT.AXMI) THEN
38413 XXC(5)=1D6
38414 ELSEIF(XXC(6).LT.AXMI) THEN
38415 XXC(6)=1D6
38416 ENDIF
38417 XXC(7)=XXC(6)
38418 XXC(8)=XXC(5)
38419C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
38420C...--> 1/(16PI)/M**3*(AEM/XW)**2
38421 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
38422 LKNT=LKNT+1
38423 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38424 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
38425 IDLAM(LKNT,1)=KFNCHI(IJ)
38426 IDLAM(LKNT,2)=-11
38427 IDLAM(LKNT,3)=12
38428C...ONLY DECAY CHI+1 -> E+ NU_E
38429 IF( IMSS(12).NE. 0 ) GOTO 260
38430 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
38431 LKNT=LKNT+1
38432 XLAM(LKNT)=XLAM(LKNT-1)
38433 IDLAM(LKNT,1)=KFNCHI(IJ)
38434 IDLAM(LKNT,2)=-13
38435 IDLAM(LKNT,3)=14
38436 ENDIF
38437 ENDIF
38438 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
38439 LKNT=LKNT+1
38440 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
38441 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
38442 ELSE
38443 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
38444 ENDIF
38445 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
38446 IF(XXC(5).LT.AXMI) THEN
38447 XXC(5)=1D6
38448 ELSEIF(XXC(6).LT.AXMI) THEN
38449 XXC(6)=1D6
38450 ENDIF
38451 XXC(7)=XXC(6)
38452 XXC(8)=XXC(5)
38453 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38454 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
38455 IDLAM(LKNT,1)=KFNCHI(IJ)
38456 IDLAM(LKNT,2)=-15
38457 IDLAM(LKNT,3)=16
38458 ENDIF
38459
38460C...NOW, DO THE QUARKS
38461 200 CONTINUE
38462 IA=1
38463 JA=2
38464 EI=KCHG(IA,1)/3D0
38465 T3I=SIGN(1D0,EI+1D-6)/2D0
38466 EJ=KCHG(JA,1)/3D0
38467 T3J=SIGN(1D0,EJ+1D-6)/2D0
38468 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
38469 & TANW+ZMIXC(IX,2)*T3J)
38470 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
38471 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)
38472 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
38473 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
38474 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 210
38475 IF(XXC(5).LT.AXMI) THEN
38476 XXC(5)=1D6
38477 ENDIF
38478 IF(XXC(6).LT.AXMI) THEN
38479 XXC(6)=1D6
38480 ENDIF
38481 XXC(7)=XXC(6)
38482 XXC(8)=XXC(5)
38483 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
38484 LKNT=LKNT+1
38485 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
38486 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38487 IDLAM(LKNT,1)=KFNCHI(IJ)
38488 IDLAM(LKNT,2)=-1
38489 IDLAM(LKNT,3)=2
38490 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
38491 LKNT=LKNT+1
38492 XLAM(LKNT)=XLAM(LKNT-1)
38493 IDLAM(LKNT,1)=KFNCHI(IJ)
38494 IDLAM(LKNT,2)=-3
38495 IDLAM(LKNT,3)=4
38496 ENDIF
38497 ENDIF
38498 210 CONTINUE
38499 ENDIF
38500 220 CONTINUE
38501
38502C...CHI+_I -> CHI0_J + H+
38503 DO 230 IJ=1,4
38504 XMJ=SMZ(IJ)
38505 AXMJ=ABS(XMJ)
38506 XMJ2=XMJ**2
38507 XMHP=PMAS(ITHC,1)
38508 IF(AXMI.GE.AXMJ+XMHP) THEN
38509 LKNT=LKNT+1
38510 OLPP=CBETA*(ZMIXC(IJ,4)*DCONJG(VMIXC(IX,1))+(ZMIXC(IJ,2)+
38511 & ZMIXC(IJ,1)*TANW)*DCONJG(VMIXC(IX,2))/SR2)
38512 ORPP=SBETA*(DCONJG(ZMIXC(IJ,3))*UMIXC(IX,1)-
38513 & (DCONJG(ZMIXC(IJ,2))+DCONJG(ZMIXC(IJ,1))*TANW)*
38514 & UMIXC(IX,2)/SR2)
38515 GX2=ABS(OLPP)**2+ABS(ORPP)**2
38516 GLR=DBLE(OLPP*DCONJG(ORPP))
38517 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
38518 IDLAM(LKNT,1)=KFNCHI(IJ)
38519 IDLAM(LKNT,2)=ITHC
38520 IDLAM(LKNT,3)=0
38521 ELSE
38522
38523 ENDIF
38524 230 CONTINUE
38525
38526C...2-BODY DECAYS TO FERMION SFERMION
38527 DO 240 J=1,16
38528 IF(J.GE.7.AND.J.LE.10) GOTO 240
38529 IF(MOD(J,2).EQ.0) THEN
38530 KF1=KSUSY1+J-1
38531 ELSE
38532 KF1=KSUSY1+J+1
38533 ENDIF
38534 KF2=KF1+KSUSY1
38535 XMSF1=PMAS(PYCOMP(KF1),1)
38536 XMSF2=PMAS(PYCOMP(KF2),1)
38537 XMF=PMAS(J,1)
38538 IF(J.LE.6) THEN
38539 FCOL=3D0
38540 ELSE
38541 FCOL=1D0
38542 ENDIF
38543
38544C...U~ D_L
38545 IF(MOD(J,2).EQ.0) THEN
38546 XMFP=PMAS(J-1,1)
38547 CAL=UMIXC(IX,1)
38548 CBL=-XMF*VMIXC(IX,2)/XMW/SBETA/SR2
38549 CAR=-XMFP*UMIXC(IX,2)/XMW/CBETA/SR2
38550 CBR=0D0
38551 ISF=J-1
38552 ELSE
38553 XMFP=PMAS(J+1,1)
38554 CAL=VMIXC(IX,1)
38555 CBL=-XMF*UMIXC(IX,2)/XMW/CBETA/SR2
38556 CBR=0D0
38557 CAR=-XMFP*VMIXC(IX,2)/XMW/SBETA/SR2
38558 ISF=J+1
38559 ENDIF
38560
38561C...~U_L D
38562 IF(AXMI.GE.XMF+XMSF1) THEN
38563 LKNT=LKNT+1
38564 XMA2=XMSF1**2
38565 XMB2=XMF**2
38566 XL=PYLAMF(XMI2,XMA2,XMB2)
38567 CA=CAL*SFMIX(ISF,1)+CAR*SFMIX(ISF,2)
38568 CB=CBL*SFMIX(ISF,1)+CBR*SFMIX(ISF,2)
38569 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
38570 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
38571 IDLAM(LKNT,3)=0
38572 IF(MOD(J,2).EQ.0) THEN
38573 IDLAM(LKNT,1)=-KF1
38574 IDLAM(LKNT,2)=J
38575 ELSE
38576 IDLAM(LKNT,1)=KF1
38577 IDLAM(LKNT,2)=-J
38578 ENDIF
38579 ENDIF
38580
38581C...U~ D_R
38582 IF(AXMI.GE.XMF+XMSF2) THEN
38583 LKNT=LKNT+1
38584 XMA2=XMSF2**2
38585 XMB2=XMF**2
38586 CA=CAL*SFMIX(ISF,3)+CAR*SFMIX(ISF,4)
38587 CB=CBL*SFMIX(ISF,3)+CBR*SFMIX(ISF,4)
38588 XL=PYLAMF(XMI2,XMA2,XMB2)
38589 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
38590 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
38591 IDLAM(LKNT,3)=0
38592 IF(MOD(J,2).EQ.0) THEN
38593 IDLAM(LKNT,1)=-KF2
38594 IDLAM(LKNT,2)=J
38595 ELSE
38596 IDLAM(LKNT,1)=KF2
38597 IDLAM(LKNT,2)=-J
38598 ENDIF
38599 ENDIF
38600 240 CONTINUE
38601
38602C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
38603C...A 2-BODY -- 2-BODY CHAIN
38604 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
38605 IF(AXMI.GE.XMJ) THEN
38606 AXMJ=ABS(XMJ)
38607 S12MIN=0D0
38608 S12MAX=(AXMI-AXMJ)**2
38609 XXC(1)=0D0
38610 XXC(2)=XMJ
38611 XXC(3)=0D0
38612 XXC(4)=XMI
38613 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
38614 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
38615 XXC(9)=1D6
38616 XXC(10)=0D0
38617 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
38618 ORPP=DCONJG(OLPP)
38619 CXC(1)=DCMPLX(0D0,0D0)
38620 CXC(3)=DCMPLX(0D0,0D0)
38621 CXC(5)=DCMPLX(0D0,0D0)
38622 CXC(7)=DCMPLX(0D0,0D0)
38623 CXC(2)=UMIXC(IX,1)*OLPP/SR2
38624 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
38625 CXC(6)=DCMPLX(0D0,0D0)
38626 CXC(8)=DCMPLX(0D0,0D0)
38627 IF(XXC(5).LT.AXMI) THEN
38628 XXC(5)=1D6
38629 ELSEIF(XXC(6).LT.AXMI) THEN
38630 XXC(6)=1D6
38631 ENDIF
38632 XXC(7)=XXC(6)
38633 XXC(8)=XXC(5)
38634 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 250
38635 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
38636 LKNT=LKNT+1
38637 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
38638 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38639 IDLAM(LKNT,1)=KSUSY1+21
38640 IDLAM(LKNT,2)=-1
38641 IDLAM(LKNT,3)=2
38642 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
38643 LKNT=LKNT+1
38644 XLAM(LKNT)=XLAM(LKNT-1)
38645 IDLAM(LKNT,1)=KSUSY1+21
38646 IDLAM(LKNT,2)=-3
38647 IDLAM(LKNT,3)=4
38648 ENDIF
38649 ENDIF
38650 250 CONTINUE
38651 ENDIF
38652
38653C...R-violating decay modes (SKANDS).
38654 CALL PYRVCH(KFIN,XLAM,IDLAM,LKNT)
38655
38656 260 IKNT=LKNT
38657 XLAM(0)=0D0
38658 DO 270 I=1,IKNT
38659 XLAM(0)=XLAM(0)+XLAM(I)
38660 IF(XLAM(I).LT.0D0) THEN
38661 WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN,
38662 & (IDLAM(I,J),J=1,3)
38663 XLAM(I)=0D0
38664 ENDIF
38665 270 CONTINUE
38666 IF(XLAM(0).EQ.0D0) THEN
38667 XLAM(0)=1D-6
38668 WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0)
38669 WRITE(MSTU(11),*) LKNT
38670 WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT)
38671 ENDIF
38672
38673 RETURN
38674 END
38675
38676C*********************************************************************
38677
38678C...PYXXZ6
38679C...Used in the calculation of inoi -> inoj + f + ~f.
38680
38681 FUNCTION PYXXZ6(X)
38682
38683C...Double precision and integer declarations.
38684 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38685 IMPLICIT INTEGER(I-N)
38686 INTEGER PYK,PYCHGE,PYCOMP
38687C...Parameter statement to help give large particle numbers.
38688 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
38689 &KEXCIT=4000000,KDIMEN=5000000)
38690C...Commonblocks.
38691 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38692C COMMON/PYINTS/XXM(20)
38693 COMPLEX*16 CXC
38694 COMMON/PYINTC/XXC(10),CXC(8)
38695 SAVE /PYDAT1/,/PYINTC/
38696
38697C...Local variables.
38698 COMPLEX*16 QLLS,QRRS,QRLS,QLRS,QLLU,QRRU,QLRT,QRLT
38699 DOUBLE PRECISION PYXXZ6,X
38700 DOUBLE PRECISION XM12,XM22,XM32,S,S13,WPROP2
38701 DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
38702 DOUBLE PRECISION SIJ
38703 DOUBLE PRECISION XMV,XMG,XMSU1,XMSU2,XMSD1,XMSD2
38704 DOUBLE PRECISION OL2
38705 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
38706 INTEGER I
38707
38708C...Statement functions.
38709C...Integral from x to y of (t-a)(b-t) dt.
38710 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
38711C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
38712 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
38713 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
38714C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
38715 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
38716 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
38717C...Integral from x to y of (t-a)/(b-t) dt.
38718 UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
38719C...Integral from x to y of 1/(t-a) dt.
38720 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
38721
38722 XM12=XXC(1)**2
38723 XM22=XXC(2)**2
38724 XM32=XXC(3)**2
38725 S=XXC(4)**2
38726 S13=X
38727
38728 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
38729 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
38730 &( (X-XM22-S)**2 -4D0*XM22*S ) )
38731
38732 S23MIN=(S23AVE-S23DEL)
38733 S23MAX=(S23AVE+S23DEL)
38734
38735 XMSD1=XXC(5)**2
38736 XMSD2=XXC(7)**2
38737 XMSU1=XXC(6)**2
38738 XMSU2=XXC(8)**2
38739
38740 XMV=XXC(9)
38741 XMG=XXC(10)
38742 QLLS=CXC(1)
38743 QLLU=CXC(2)
38744 QLRS=CXC(3)
38745 QLRT=CXC(4)
38746 QRLS=CXC(5)
38747 QRLT=CXC(6)
38748 QRRS=CXC(7)
38749 QRRU=CXC(8)
38750 WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
38751 SIJ=2D0*XXC(2)*XXC(4)*S13
38752 IF(XMV.LE.1000D0) THEN
38753 OL2=ABS(QLLS)**2+ABS(QRRS)**2+ABS(QLRS)**2+ABS(QRLS)**2
38754 OLR=-2D0*DBLE(QLRS*DCONJG(QLLS)+QRLS*DCONJG(QRRS))
38755 WW=(OL2*2D0*TINT(S23MAX,S23MIN,XM22,S)
38756 & +OLR*SIJ*(S23MAX-S23MIN))/WPROP2
38757 IF(XXC(5).LE.10000D0) THEN
38758 WFL1=4D0*(DBLE(QLLS*DCONJG(QLLU))*
38759 & TINT2(S23MAX,S23MIN,XM22,S,XMSD1)-
38760 & .5D0*DBLE(QLLS*DCONJG(QLRT))*SIJ*TPROP(S23MAX,S23MIN,XMSD2)+
38761 & DBLE(QLRS*DCONJG(QLRT))*TINT2(S23MAX,S23MIN,XM22,S,XMSD2)-
38762 & .5D0*DBLE(QLRS*DCONJG(QLLU))*SIJ*TPROP(S23MAX,S23MIN,XMSD1))
38763 & *(S13-XMV**2)/WPROP2
38764 ELSE
38765 WFL1=0D0
38766 ENDIF
38767
38768 IF(XXC(6).LE.10000D0) THEN
38769 WFL2=4D0*(DBLE(QRRS*DCONJG(QRRU))*
38770 & TINT2(S23MAX,S23MIN,XM22,S,XMSU1)-
38771 & .5D0*DBLE(QRRS*DCONJG(QRLT))*SIJ*TPROP(S23MAX,S23MIN,XMSU2)+
38772 & DBLE(QRLS*DCONJG(QRLT))*TINT2(S23MAX,S23MIN,XM22,S,XMSU2)-
38773 & .5D0*DBLE(QRLS*DCONJG(QRRU))*SIJ*TPROP(S23MAX,S23MIN,XMSU1))
38774 & *(S13-XMV**2)/WPROP2
38775 ELSE
38776 WFL2=0D0
38777 ENDIF
38778 ELSE
38779 WW=0D0
38780 WFL1=0D0
38781 WFL2=0D0
38782 ENDIF
38783 IF(XXC(5).LE.10000D0) THEN
38784 WF1=2D0*ABS(QLLU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD1)
38785 & +2D0*ABS(QLRT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD2)
38786 & - 2D0*DBLE(QLRT*DCONJG(QLLU))*
38787 & SIJ*UTINT(S23MAX,S23MIN,XMSD1,XM22+S-S13-XMSD2)
38788 ELSE
38789 WF1=0D0
38790 ENDIF
38791 IF(XXC(6).LE.10000D0) THEN
38792 WF2=2D0*ABS(QRRU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU1)
38793 & +2D0*ABS(QRLT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU2)
38794 & - 2D0*DBLE(QRLT*DCONJG(QRRU))*
38795 & SIJ*UTINT(S23MAX,S23MIN,XMSU1,XM22+S-S13-XMSU2)
38796 ELSE
38797 WF2=0D0
38798 ENDIF
38799
38800 PYXXZ6=(WW+WF1+WF2+WFL1+WFL2)
38801
38802 IF(PYXXZ6.LT.0D0) THEN
38803 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ6 '
38804 WRITE(MSTU(11),*) XXc(1),XXc(2),XXc(3),XXc(4)
38805 WRITE(MSTU(11),*) (XXc(I),I=5,8)
38806 WRITE(MSTU(11),*) (XXc(I),I=9,12)
38807 WRITE(MSTU(11),*) (XXc(I),I=13,16)
38808 WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2
38809 WRITE(MSTU(11),*) S23MIN,S23MAX
38810 PYXXZ6=0D0
38811 ENDIF
38812
38813 RETURN
38814 END
38815
38816
38817C*********************************************************************
38818
38819C...PYXXGA
38820C...Calculates chi0_i -> chi0_j + gamma.
38821
38822 FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL)
38823
38824C...Double precision and integer declarations.
38825 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38826 IMPLICIT INTEGER(I-N)
38827 INTEGER PYK,PYCHGE,PYCOMP
38828
38829C...Local variables.
38830 DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
38831 DOUBLE PRECISION F1,F2
38832
38833 F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR)
38834 F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL)
38835 PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3
38836 PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2
38837
38838 RETURN
38839 END
38840
38841C*********************************************************************
38842
38843C...PYX2XG
38844C...Calculates the decay rate for ino -> ino + gauge boson.
38845
38846 FUNCTION PYX2XG(C1,XM1,XM2,XM3,GX2,GLR)
38847
38848C...Double precision and integer declarations.
38849 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38850 IMPLICIT INTEGER(I-N)
38851 INTEGER PYK,PYCHGE,PYCOMP
38852
38853C...Local variables.
38854 DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GX2,GLR
38855 DOUBLE PRECISION XL,PYLAMF,C1
38856 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
38857
38858 XMI2=XM1**2
38859 XMI3=ABS(XM1**3)
38860 XMJ2=XM2**2
38861 XMV2=XM3**2
38862 XL=PYLAMF(XMI2,XMJ2,XMV2)
38863 PYX2XG=C1/8D0/XMI3*SQRT(XL)
38864 &*(GX2*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))-
38865 &12D0*GLR*XM1*XM2*XMV2)
38866
38867 RETURN
38868 END
38869
38870C*********************************************************************
38871
38872C...PYX2XH
38873C...Calculates the decay rate for ino -> ino + H.
38874
38875 FUNCTION PYX2XH(C1,XM1,XM2,XM3,GX2,GLR)
38876
38877C...Double precision and integer declarations.
38878 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38879 IMPLICIT INTEGER(I-N)
38880 INTEGER PYK,PYCHGE,PYCOMP
38881
38882C...Local variables.
38883 DOUBLE PRECISION PYX2XH,XM1,XM2,XM3
38884 DOUBLE PRECISION XL,PYLAMF,C1
38885 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
38886
38887 XMI2=XM1**2
38888 XMI3=ABS(XM1**3)
38889 XMJ2=XM2**2
38890 XMV2=XM3**2
38891 XL=PYLAMF(XMI2,XMJ2,XMV2)
38892 PYX2XH=C1/8D0/XMI3*SQRT(XL)
38893 &*(GX2*(XMI2+XMJ2-XMV2)+
38894 &4D0*GLR*XM1*XM2)
38895
38896 RETURN
38897 END
38898
38899C*********************************************************************
38900
38901C...PYHEXT
38902C...Calculates the non-standard decay modes of the Higgs boson.
38903C...
38904C...Author: Stephen Mrenna
38905C...Last Update: April 2001
38906C......Allow complex values for Z,U, and V
38907
38908 SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT)
38909
38910C...Double precision and integer declarations.
38911 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38912 IMPLICIT INTEGER(I-N)
38913 INTEGER PYK,PYCHGE,PYCOMP
38914C...Parameter statement to help give large particle numbers.
38915 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
38916 &KEXCIT=4000000,KDIMEN=5000000)
38917C...Commonblocks.
38918 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38919 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38920 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38921 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
38922 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
38923 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
38924 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/
38925
38926C...Local variables.
38927 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
38928 COMPLEX*16 QIJ,RIJ,F21K,F12K
38929 INTEGER KFIN
38930 DOUBLE PRECISION XMI,XMJ,XMF,XMW,XMW2,XMZ,AXMJ,AXMI
38931 DOUBLE PRECISION XMI2,XMI3,XMJ2
38932 DOUBLE PRECISION PYLAMF,XL,CF,EI
38933 INTEGER IDU,IFL
38934 DOUBLE PRECISION TANW,XW,AEM,C1,AS
38935 DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
38936 DOUBLE PRECISION XLAM(0:400)
38937 INTEGER IDLAM(400,3)
38938 INTEGER LKNT,IH,J,IJ,I,IKNT,IK
38939 INTEGER ITH(4)
38940 INTEGER KFNCHI(4),KFCCHI(2)
38941 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
38942 DOUBLE PRECISION SR2
38943 DOUBLE PRECISION BETA,ALFA
38944 DOUBLE PRECISION CBETA,SBETA,GR,GL,TANB
38945 DOUBLE PRECISION PYALEM
38946 DOUBLE PRECISION AL,AR,ALR
38947 DOUBLE PRECISION XMK,AXMK,COSA,SINA,CW,XML
38948 DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
38949 DOUBLE PRECISION XMJL,XMJR,XM1,XM2
38950 DATA ITH/25,35,36,37/
38951 DATA ETAH/1D0,1D0,-1D0/
38952 DATA SR2/1.4142136D0/
38953 DATA KFNCHI/1000022,1000023,1000025,1000035/
38954 DATA KFCCHI/1000024,1000037/
38955
38956C...COUNT THE NUMBER OF DECAY MODES
38957 LKNT=IKNT
38958
38959 XMW=PMAS(24,1)
38960 XMW2=XMW**2
38961 XMZ=PMAS(23,1)
38962 XW=PARU(102)
38963 TANW = SQRT(XW/(1D0-XW))
38964 CW=SQRT(1D0-XW)
38965
38966C...1 - 4 DEPENDING ON Higgs species.
38967 IH=1
38968 IF(KFIN.EQ.ITH(2)) IH=2
38969 IF(KFIN.EQ.ITH(3)) IH=3
38970 IF(KFIN.EQ.ITH(4)) IH=4
38971
38972 XMI=PMAS(KFIN,1)
38973 XMI2=XMI**2
38974 AXMI=ABS(XMI)
38975 AEM=PYALEM(XMI2)
38976 C1=AEM/XW
38977 XMI3=ABS(XMI**3)
38978
38979 TANB=RMSS(5)
38980 BETA=ATAN(TANB)
38981 CBETA=COS(BETA)
38982 SBETA=TANB*CBETA
38983 ALFA=RMSS(18)
38984 COSA=COS(ALFA)
38985 SINA=SIN(ALFA)
38986 ATRIT=RMSS(16)
38987 ATRIB=RMSS(15)
38988 ATRIL=RMSS(17)
38989 XMUZ=-RMSS(4)
38990
38991 DO 110 I=1,4
38992 DO 100 J=1,4
38993 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
38994 100 CONTINUE
38995 110 CONTINUE
38996 DO 130 I=1,2
38997 DO 120 J=1,2
38998 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
38999 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
39000 120 CONTINUE
39001 130 CONTINUE
39002
39003
39004 IF(IH.EQ.4) GOTO 220
39005
39006C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
39007C...H0_K -> CHI0_I + CHI0_J
39008 EH(2)=SINA
39009 EH(1)=COSA
39010 EH(3)=CBETA
39011 DH(2)=COSA
39012 DH(1)=-SINA
39013 DH(3)=SBETA
39014 DO 150 IJ=1,4
39015 XMJ=SMZ(IJ)
39016 AXMJ=ABS(XMJ)
39017 DO 140 IK=1,IJ
39018 XMK=SMZ(IK)
39019 AXMK=ABS(XMK)
39020 IF(AXMI.GE.AXMJ+AXMK) THEN
39021 LKNT=LKNT+1
39022 QIJ=ZMIXC(IK,3)*ZMIXC(IJ,2)+
39023 & ZMIXC(IJ,3)*ZMIXC(IK,2)-
39024 & TANW*(ZMIXC(IK,3)*ZMIXC(IJ,1)+
39025 & ZMIXC(IJ,3)*ZMIXC(IK,1))
39026 RIJ=ZMIXC(IK,4)*ZMIXC(IJ,2)+
39027 & ZMIXC(IJ,4)*ZMIXC(IK,2)-
39028 & TANW*(ZMIXC(IK,4)*ZMIXC(IJ,1)+
39029 & ZMIXC(IJ,4)*ZMIXC(IK,1))
39030 F21K=0.5D0*DCONJG(QIJ*DH(IH)-RIJ*EH(IH))
39031 F12K=0.5D0*(QIJ*DH(IH)-RIJ*EH(IH))
39032C...SIGN OF MASSES I,J
39033 XML=XMK*ETAH(IH)
39034 GX2=ABS(F12K)**2+ABS(F21K)**2
39035 GLR=DBLE(F12K*DCONJG(F21K))
39036 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
39037 IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0
39038 IDLAM(LKNT,1)=KFNCHI(IJ)
39039 IDLAM(LKNT,2)=KFNCHI(IK)
39040 IDLAM(LKNT,3)=0
39041 ENDIF
39042 140 CONTINUE
39043 150 CONTINUE
39044
39045C...H0_K -> CHI+_I CHI-_J
39046 DO 170 IJ=1,2
39047 XMJ=SMW(IJ)
39048 AXMJ=ABS(XMJ)
39049 DO 160 IK=1,2
39050 XMK=SMW(IK)
39051 AXMK=ABS(XMK)
39052 IF(AXMI.GE.AXMJ+AXMK) THEN
39053 LKNT=LKNT+1
39054 OLPP=DCONJG(VMIXC(IJ,1)*UMIXC(IK,2)*DH(IH) +
39055 & VMIXC(IJ,2)*UMIXC(IK,1)*EH(IH))/SR2
39056 ORPP=(VMIXC(IK,1)*UMIXC(IJ,2)*DH(IH) +
39057 & VMIXC(IK,2)*UMIXC(IJ,1)*EH(IH))/SR2
39058 GX2=ABS(OLPP)**2+ABS(ORPP)**2
39059 GLR=DBLE(OLPP*DCONJG(ORPP))
39060 XML=XMK*ETAH(IH)
39061 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
39062 IDLAM(LKNT,1)=KFCCHI(IJ)
39063 IDLAM(LKNT,2)=-KFCCHI(IK)
39064 IDLAM(LKNT,3)=0
39065 ENDIF
39066 160 CONTINUE
39067 170 CONTINUE
39068
39069C...HIGGS TO SFERMION SFERMION
39070 DO 200 IFL=1,16
39071 IF(IFL.GE.7.AND.IFL.LE.10) GOTO 200
39072 IJ=KSUSY1+IFL
39073 XMJL=PMAS(PYCOMP(IJ),1)
39074 XMJR=PMAS(PYCOMP(IJ+KSUSY1),1)
39075 IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN
39076 XMJ=XMJL
39077 XMJ2=XMJ**2
39078 XL=PYLAMF(XMI2,XMJ2,XMJ2)
39079 XMF=PMAS(IFL,1)
39080 EI=KCHG(IFL,1)/3D0
39081 IDU=2-MOD(IFL,2)
39082
39083 IF(IH.EQ.1) THEN
39084 IF(IDU.EQ.1) THEN
39085 GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+
39086 & XMF**2/XMW*SINA/CBETA
39087 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+
39088 & XMF**2/XMW*SINA/CBETA
39089 IF(IFL.EQ.5) THEN
39090 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
39091 & ATRIB*SINA)
39092 ELSEIF(IFL.EQ.15) THEN
39093 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
39094 & ATRIL*SINA)
39095 ELSE
39096 GHLR=0D0
39097 ENDIF
39098 ELSE
39099 GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)-
39100 & XMF**2/XMW*COSA/SBETA
39101 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)-
39102 & XMF**2/XMW*COSA/SBETA
39103 IF(IFL.EQ.6) THEN
39104 GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA-
39105 & ATRIT*COSA)
39106 ELSE
39107 GHLR=0D0
39108 ENDIF
39109 ENDIF
39110
39111 ELSEIF(IH.EQ.2) THEN
39112 IF(IDU.EQ.1) THEN
39113 GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)-
39114 & XMF**2/XMW*COSA/CBETA
39115 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
39116 & XMF**2/XMW*COSA/CBETA
39117 IF(IFL.EQ.5) THEN
39118 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
39119 & ATRIB*COSA)
39120 ELSEIF(IFL.EQ.15) THEN
39121 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
39122 & ATRIL*COSA)
39123 ELSE
39124 GHLR=0D0
39125 ENDIF
39126 ELSE
39127 GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)-
39128 & XMF**2/XMW*SINA/SBETA
39129 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
39130 & XMF**2/XMW*SINA/SBETA
39131 IF(IFL.EQ.6) THEN
39132 GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+
39133 & ATRIT*SINA)
39134 ELSE
39135 GHLR=0D0
39136 ENDIF
39137 ENDIF
39138
39139 ELSEIF(IH.EQ.3) THEN
39140 GHLL=0D0
39141 GHRR=0D0
39142 GHLR=0D0
39143 IF(IDU.EQ.1) THEN
39144 IF(IFL.EQ.5) THEN
39145 GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ)
39146 ELSEIF(IFL.EQ.15) THEN
39147 GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ)
39148 ENDIF
39149 ELSE
39150 IF(IFL.EQ.6) THEN
39151 GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ)
39152 ENDIF
39153 ENDIF
39154 ENDIF
39155 IF(IH.EQ.3) GOTO 180
39156
39157 AL=SFMIX(IFL,1)**2
39158 AR=SFMIX(IFL,2)**2
39159 ALR=SFMIX(IFL,1)*SFMIX(IFL,2)
39160 IF(IFL.LE.6) THEN
39161 CF=3D0
39162 ELSE
39163 CF=1D0
39164 ENDIF
39165
39166 IF(AXMI.GE.2D0*XMJ) THEN
39167 LKNT=LKNT+1
39168 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
39169 & (GHLL*AL+GHRR*AR
39170 & +2D0*GHLR*ALR)**2
39171 IDLAM(LKNT,1)=IJ
39172 IDLAM(LKNT,2)=-IJ
39173 IDLAM(LKNT,3)=0
39174 ENDIF
39175
39176 IF(AXMI.GE.2D0*XMJR) THEN
39177 LKNT=LKNT+1
39178 AL=SFMIX(IFL,3)**2
39179 AR=SFMIX(IFL,4)**2
39180 ALR=SFMIX(IFL,3)*SFMIX(IFL,4)
39181 XMJ=XMJR
39182 XMJ2=XMJ**2
39183 XL=PYLAMF(XMI2,XMJ2,XMJ2)
39184 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
39185 & (GHLL*AL+GHRR*AR
39186 & +2D0*GHLR*ALR)**2
39187 IDLAM(LKNT,1)=IJ+KSUSY1
39188 IDLAM(LKNT,2)=-(IJ+KSUSY1)
39189 IDLAM(LKNT,3)=0
39190 ENDIF
39191 180 CONTINUE
39192
39193 IF(AXMI.GE.XMJL+XMJR) THEN
39194 LKNT=LKNT+1
39195 AL=SFMIX(IFL,1)*SFMIX(IFL,3)
39196 AR=SFMIX(IFL,2)*SFMIX(IFL,4)
39197 ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3)
39198 XMJ=XMJR
39199 XMJ2=XMJ**2
39200 XL=PYLAMF(XMI2,XMJ2,XMJL**2)
39201 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
39202 & (GHLL*AL+GHRR*AR)**2
39203 IDLAM(LKNT,1)=IJ
39204 IDLAM(LKNT,2)=-(IJ+KSUSY1)
39205 IDLAM(LKNT,3)=0
39206 LKNT=LKNT+1
39207 IDLAM(LKNT,1)=-IJ
39208 IDLAM(LKNT,2)=IJ+KSUSY1
39209 IDLAM(LKNT,3)=0
39210 XLAM(LKNT)=XLAM(LKNT-1)
39211 ENDIF
39212 ENDIF
39213 190 CONTINUE
39214 200 CONTINUE
39215 210 CONTINUE
39216
39217 GOTO 270
39218 220 CONTINUE
39219
39220C...H+ -> CHI+_I + CHI0_J
39221 DO 240 IJ=1,4
39222 XMJ=SMZ(IJ)
39223 AXMJ=ABS(XMJ)
39224 XMJ2=XMJ**2
39225 DO 230 IK=1,2
39226 XMK=SMW(IK)
39227 AXMK=ABS(XMK)
39228 IF(AXMI.GE.AXMJ+AXMK) THEN
39229 LKNT=LKNT+1
39230 OLPP=CBETA*DCONJG(ZMIXC(IJ,4)*VMIXC(IK,1)+(ZMIXC(IJ,2)+
39231 & ZMIXC(IJ,1)*TANW)*VMIXC(IK,2)/SR2)
39232 ORPP=SBETA*(ZMIXC(IJ,3)*UMIXC(IK,1)-
39233 & (ZMIXC(IJ,2)+ZMIXC(IJ,1)*TANW)*UMIXC(IK,2)/SR2)
39234 GX2=ABS(OLPP)**2+ABS(ORPP)**2
39235 GLR=DBLE(OLPP*DCONJG(ORPP))
39236 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GX2,GLR)
39237 IDLAM(LKNT,1)=KFNCHI(IJ)
39238 IDLAM(LKNT,2)=KFCCHI(IK)
39239 IDLAM(LKNT,3)=0
39240 ENDIF
39241 230 CONTINUE
39242 240 CONTINUE
39243
39244 GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2)
39245 GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB)
39246 AL=0D0
39247 AR=0D0
39248 CF=3D0
39249
39250C...H+ -> T_1 B_1~
39251 XM1=PMAS(PYCOMP(KSUSY1+6),1)
39252 XM2=PMAS(PYCOMP(KSUSY1+5),1)
39253 IF(XMI.GE.XM1+XM2) THEN
39254 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39255 LKNT=LKNT+1
39256 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
39257 & (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2
39258 IDLAM(LKNT,1)=KSUSY1+6
39259 IDLAM(LKNT,2)=-(KSUSY1+5)
39260 IDLAM(LKNT,3)=0
39261 ENDIF
39262
39263C...H+ -> T_2 B_1~
39264 XM1=PMAS(PYCOMP(KSUSY2+6),1)
39265 XM2=PMAS(PYCOMP(KSUSY1+5),1)
39266 IF(XMI.GE.XM1+XM2) THEN
39267 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39268 LKNT=LKNT+1
39269 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
39270 & (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2
39271 IDLAM(LKNT,1)=KSUSY2+6
39272 IDLAM(LKNT,2)=-(KSUSY1+5)
39273 IDLAM(LKNT,3)=0
39274 ENDIF
39275
39276C...H+ -> T_1 B_2~
39277 XM1=PMAS(PYCOMP(KSUSY1+6),1)
39278 XM2=PMAS(PYCOMP(KSUSY2+5),1)
39279 IF(XMI.GE.XM1+XM2) THEN
39280 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39281 LKNT=LKNT+1
39282 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
39283 & (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2
39284 IDLAM(LKNT,1)=KSUSY1+6
39285 IDLAM(LKNT,2)=-(KSUSY2+5)
39286 IDLAM(LKNT,3)=0
39287 ENDIF
39288
39289C...H+ -> T_2 B_2~
39290 XM1=PMAS(PYCOMP(KSUSY2+6),1)
39291 XM2=PMAS(PYCOMP(KSUSY2+5),1)
39292 IF(XMI.GE.XM1+XM2) THEN
39293 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39294 LKNT=LKNT+1
39295 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
39296 & (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2
39297 IDLAM(LKNT,1)=KSUSY2+6
39298 IDLAM(LKNT,2)=-(KSUSY2+5)
39299 IDLAM(LKNT,3)=0
39300 ENDIF
39301
39302C...H+ -> UL DL~
39303 GL=-XMW/SR2*SIN(2D0*BETA)
39304 DO 250 IJ=1,3,2
39305 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
39306 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
39307 IF(XMI.GE.XM1+XM2) THEN
39308 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39309 LKNT=LKNT+1
39310 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
39311 IDLAM(LKNT,1)=-(KSUSY1+IJ)
39312 IDLAM(LKNT,2)=KSUSY1+IJ+1
39313 IDLAM(LKNT,3)=0
39314 ENDIF
39315 250 CONTINUE
39316
39317C...H+ -> EL~ NUL
39318 CF=1D0
39319 DO 260 IJ=11,13,2
39320 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
39321 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
39322 IF(XMI.GE.XM1+XM2) THEN
39323 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39324 LKNT=LKNT+1
39325 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
39326 IDLAM(LKNT,1)=-(KSUSY1+IJ)
39327 IDLAM(LKNT,2)=KSUSY1+IJ+1
39328 IDLAM(LKNT,3)=0
39329 ENDIF
39330 260 CONTINUE
39331
39332C...H+ -> TAU1 NUTAUL
39333 XM1=PMAS(PYCOMP(KSUSY1+15),1)
39334 XM2=PMAS(PYCOMP(KSUSY1+16),1)
39335 IF(XMI.GE.XM1+XM2) THEN
39336 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39337 LKNT=LKNT+1
39338 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,1)**2
39339 IDLAM(LKNT,1)=-(KSUSY1+15)
39340 IDLAM(LKNT,2)= KSUSY1+16
39341 IDLAM(LKNT,3)=0
39342 ENDIF
39343
39344C...H+ -> TAU2 NUTAUL
39345 XM1=PMAS(PYCOMP(KSUSY2+15),1)
39346 XM2=PMAS(PYCOMP(KSUSY1+16),1)
39347 IF(XMI.GE.XM1+XM2) THEN
39348 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39349 LKNT=LKNT+1
39350 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,3)**2
39351 IDLAM(LKNT,1)=-(KSUSY2+15)
39352 IDLAM(LKNT,2)= KSUSY1+16
39353 IDLAM(LKNT,3)=0
39354 ENDIF
39355
39356 270 CONTINUE
39357 IKNT=LKNT
39358 XLAM(0)=0D0
39359 DO 280 I=1,IKNT
39360 IF(XLAM(I).LE.0D0) XLAM(I)=0D0
39361 XLAM(0)=XLAM(0)+XLAM(I)
39362 280 CONTINUE
39363 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
39364
39365 RETURN
39366 END
39367
39368C*********************************************************************
39369
39370C...PYH2XX
39371C...Calculates the decay rate for a Higgs to an ino pair.
39372
39373 FUNCTION PYH2XX(C1,XM1,XM2,XM3,GX2,GLR)
39374
39375C...Double precision and integer declarations.
39376 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39377 IMPLICIT INTEGER(I-N)
39378 INTEGER PYK,PYCHGE,PYCOMP
39379C...Commonblocks.
39380 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39381 SAVE /PYDAT1/
39382
39383C...Local variables.
39384 DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
39385 DOUBLE PRECISION XL,PYLAMF,C1
39386 DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
39387
39388 XMI2=XM1**2
39389 XMI3=ABS(XM1**3)
39390 XMJ2=XM2**2
39391 XMK2=XM3**2
39392 XL=PYLAMF(XMI2,XMJ2,XMK2)
39393 PYH2XX=C1/4D0/XMI3*SQRT(XL)
39394 &*(GX2*(XMI2-XMJ2-XMK2)-
39395 &4D0*GLR*XM3*XM2)
39396 IF(PYH2XX.LT.0D0) THEN
39397 WRITE(MSTU(11),*) ' NEGATIVE WIDTH IN PYH2XX '
39398 WRITE(MSTU(11),*) XMI2,XMJ2,XMK2,GX2,GLR,XM1,XM2,XM3
39399 STOP
39400 ENDIF
39401
39402 RETURN
39403 END
39404
39405C*********************************************************************
39406
39407C...PYGAUS
39408C...Integration by adaptive Gaussian quadrature.
39409C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
39410
39411 FUNCTION PYGAUS(F, A, B, EPS)
39412
39413C...Double precision and integer declarations.
39414 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39415 IMPLICIT INTEGER(I-N)
39416 INTEGER PYK,PYCHGE,PYCOMP
39417
39418C...Local declarations.
39419 EXTERNAL F
39420 DOUBLE PRECISION F,W(12), X(12)
39421 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
39422 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
39423 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
39424 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
39425 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
39426 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
39427 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
39428 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
39429 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
39430 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
39431 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
39432 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
39433
39434C...The Gaussian quadrature algorithm.
39435 H = 0D0
39436 IF(B .EQ. A) GOTO 140
39437 CONST = 5D-3 / ABS(B-A)
39438 BB = A
39439 100 CONTINUE
39440 AA = BB
39441 BB = B
39442 110 CONTINUE
39443 C1 = 0.5D0*(BB+AA)
39444 C2 = 0.5D0*(BB-AA)
39445 S8 = 0D0
39446 DO 120 I = 1, 4
39447 U = C2*X(I)
39448 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
39449 120 CONTINUE
39450 S16 = 0D0
39451 DO 130 I = 5, 12
39452 U = C2*X(I)
39453 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
39454 130 CONTINUE
39455 S16 = C2*S16
39456 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
39457 H = H + S16
39458 IF(BB .NE. B) GOTO 100
39459 ELSE
39460 BB = C1
39461 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
39462 H = 0D0
39463 CALL PYERRM(18,'(PYGAUS:) too high accuracy required')
39464 GOTO 140
39465 ENDIF
39466 140 CONTINUE
39467 PYGAUS = H
39468
39469 RETURN
39470 END
39471
39472C*********************************************************************
39473
39474C...PYGAU2
39475C...Integration by adaptive Gaussian quadrature.
39476C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
39477C...Carbon copy of PYGAUS, but avoids having to use it recursively.
39478
39479 FUNCTION PYGAU2(F, A, B, EPS)
39480
39481C...Double precision and integer declarations.
39482 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39483 IMPLICIT INTEGER(I-N)
39484 INTEGER PYK,PYCHGE,PYCOMP
39485
39486C...Local declarations.
39487 EXTERNAL F
39488 DOUBLE PRECISION F,W(12), X(12)
39489 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
39490 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
39491 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
39492 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
39493 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
39494 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
39495 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
39496 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
39497 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
39498 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
39499 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
39500 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
39501
39502C...The Gaussian quadrature algorithm.
39503 H = 0D0
39504 IF(B .EQ. A) GOTO 140
39505 CONST = 5D-3 / ABS(B-A)
39506 BB = A
39507 100 CONTINUE
39508 AA = BB
39509 BB = B
39510 110 CONTINUE
39511 C1 = 0.5D0*(BB+AA)
39512 C2 = 0.5D0*(BB-AA)
39513 S8 = 0D0
39514 DO 120 I = 1, 4
39515 U = C2*X(I)
39516 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
39517 120 CONTINUE
39518 S16 = 0D0
39519 DO 130 I = 5, 12
39520 U = C2*X(I)
39521 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
39522 130 CONTINUE
39523 S16 = C2*S16
39524 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
39525 H = H + S16
39526 IF(BB .NE. B) GOTO 100
39527 ELSE
39528 BB = C1
39529 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
39530 H = 0D0
39531 CALL PYERRM(18,'(PYGAU2:) too high accuracy required')
39532 GOTO 140
39533 ENDIF
39534 140 CONTINUE
39535 PYGAU2 = H
39536
39537 RETURN
39538 END
39539
39540C*********************************************************************
39541
39542C...PYSIMP
39543C...Simpson formula for an integral.
39544
39545 FUNCTION PYSIMP(Y,X0,X1,N)
39546
39547C...Double precision and integer declarations.
39548 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39549 IMPLICIT INTEGER(I-N)
39550 INTEGER PYK,PYCHGE,PYCOMP
39551
39552C...Local variables.
39553 DOUBLE PRECISION Y,X0,X1,H,S
39554 DIMENSION Y(0:N)
39555
39556 S=0D0
39557 H=(X1-X0)/N
39558 DO 100 I=0,N-2,2
39559 S=S+Y(I)+4D0*Y(I+1)+Y(I+2)
39560 100 CONTINUE
39561 PYSIMP=S*H/3D0
39562
39563 RETURN
39564 END
39565
39566C*********************************************************************
39567
39568C...PYLAMF
39569C...The standard lambda function.
39570
39571 FUNCTION PYLAMF(X,Y,Z)
39572
39573C...Double precision and integer declarations.
39574 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39575 IMPLICIT INTEGER(I-N)
39576 INTEGER PYK,PYCHGE,PYCOMP
39577
39578C...Local variables.
39579 DOUBLE PRECISION PYLAMF,X,Y,Z
39580
39581 PYLAMF=(X-(Y+Z))**2-4D0*Y*Z
39582 IF(PYLAMF.LT.0D0) PYLAMF=0D0
39583
39584 RETURN
39585 END
39586
39587C*********************************************************************
39588
39589C...PYTBDY
39590C...Generates 3-body decays of gauginos.
39591
39592 SUBROUTINE PYTBDY(IDIN)
39593
39594C...Double precision and integer declarations.
39595 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39596 IMPLICIT INTEGER(I-N)
39597 INTEGER PYK,PYCHGE,PYCOMP
39598C...Parameter statement to help give large particle numbers.
39599 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
39600 &KEXCIT=4000000,KDIMEN=5000000)
39601C...Commonblocks.
39602 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
39603 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39604 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39605C COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
39606C COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39607 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
39608 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
39609C SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYSSMT/
39610 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSSMT/
39611
39612C...Local variables.
39613 DOUBLE PRECISION XM(5)
39614 COMPLEX*16 OLPP,ORPP,QLL,QLR,QRR,QRL,GLIJ,GRIJ,PROPZ
39615 COMPLEX*16 QLLS,QRRS,QLRS,QRLS,QLLU,QRRU,QLRT,QRLT
39616 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
39617 DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
39618 DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
39619 DOUBLE PRECISION CPHI1,SPHI1
39620 DOUBLE PRECISION S23DEL,EPS
39621 DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
39622 PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3)
39623 DOUBLE PRECISION F1,F2,X0,X1,X2,X3
39624 INTEGER INOID(4)
39625 DATA INOID/22,23,25,35/
39626 DATA EPS/1D-6/
39627
39628 ID=IDIN
39629 ISKIP=1
39630 XM(1)=P(N+1,5)
39631 XM(2)=P(N+2,5)
39632 XM(3)=P(N+3,5)
39633 XM(5)=P(ID,5)
39634
39635C...GENERATE S12
39636 S12MIN=(XM(1)+XM(2))**2
39637 S12MAX=(XM(5)-XM(3))**2
39638 YJACO1=S12MAX-S12MIN
39639
39640C...Initialize some parameters
39641 XW=PARU(102)
39642 XW1=1D0-XW
39643 TANW=SQRT(XW/XW1)
39644 IZID1=0
39645 IWID1=0
39646 IZID2=0
39647 IWID2=0
39648 DO 100 I1=1,4
39649 IF(MOD(K(N+1,2),KSUSY1).EQ.INOID(I1)) IZID1=I1
39650 IF(MOD(K(ID,2),KSUSY1).EQ.INOID(I1)) IZID2=I1
39651 100 CONTINUE
39652 IF(MOD(K(N+1,2),KSUSY1).EQ.24) IWID1=1
39653 IF(MOD(K(N+1,2),KSUSY1).EQ.37) IWID1=2
39654 IF(MOD(K(ID,2),KSUSY1).EQ.24) IWID2=1
39655 IF(MOD(K(ID,2),KSUSY1).EQ.37) IWID2=2
39656 IA=K(N+2,2)
39657 JA=K(N+3,2)
39658 ZM12=XM(5)**2
39659 ZM22=XM(1)**2
39660 EI=KCHG(IABS(IA),1)/3D0
39661 T3I=SIGN(1D0,EI+1D-6)/2D0
39662 IF(MAX(ABS(IA),ABS(JA)).EQ.6) THEN
39663 ISKIP=0
39664 ELSEIF(IZID1*IZID2.NE.0) THEN
39665 SQMZ=PMAS(23,1)**2
39666 GMMZ=PMAS(23,1)*PMAS(23,2)
39667 DO 110 I=1,4
39668 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
39669 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
39670 110 CONTINUE
39671 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
39672 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
39673 ORPP=DCONJG(OLPP)
39674 XLL2=PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
39675 XLR2=XLL2
39676 XRR2=PMAS(PYCOMP(KSUSY2+IABS(IA)),1)**2
39677 XRL2=XRR2
39678 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
39679 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
39680 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
39681 XM1M2=SMZ(IZID1)*SMZ(IZID2)
39682 QLLS=DCMPLX((T3I-EI*XW)/XW1)*OLPP
39683 QLLU=-GLIJ
39684 QLRS=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
39685 QLRT=DCONJG(GLIJ)
39686 QRLS=-DCMPLX((EI*XW)/XW1)*OLPP
39687 QRLT=GRIJ
39688 QRRS=DCMPLX((EI*XW)/XW1)*ORPP
39689 QRRU=-DCONJG(GRIJ)
39690 ELSEIF(IZID1*IWID2.NE.0.OR.IZID2*IWID1.NE.0) THEN
39691 IF(IZID1.NE.0) THEN
39692 XM1M2=SMZ(IZID1)*SMW(IWID2)
39693 IZID1=IWID2
39694 IZID2=IZID1
39695 ELSE
39696 XM1M2=SMZ(IZID2)*SMW(IWID1)
39697 IZID1=IWID1
39698 ENDIF
39699 RT2I = 1D0/SQRT(2D0)
39700 SQMZ=PMAS(24,1)**2
39701 GMMZ=PMAS(24,1)*PMAS(24,2)
39702 DO 120 I=1,2
39703 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
39704 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
39705 120 CONTINUE
39706 DO 130 I=1,4
39707 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
39708 130 CONTINUE
39709 QLLS=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
39710 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)
39711 QLRS=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
39712 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)
39713 EJ=KCHG(JA,1)/3D0
39714 T3J=SIGN(1D0,EJ+1D-6)/2D0
39715 QRLS=DCMPLX(0D0,0D0)
39716 QRLT=QRLS
39717 QRRS=QRLS
39718 QRRU=QRLS
39719 XRR2=1D6**2
39720 XRL2=XRR2
39721 XLR2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
39722 XLL2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
39723 IF(MOD(IA,2).EQ.0) THEN
39724 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
39725 & TANW+ZMIXC(IZID2,2)*T3I)
39726 QLRT=-DCONJG(UMIXC(IZID1,1))*(
39727 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
39728 ELSE
39729 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
39730 & TANW+ZMIXC(IZID2,2)*T3J)
39731 QLRT=-DCONJG(UMIXC(IZID1,1))*(
39732 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
39733 ENDIF
39734 ELSEIF(IWID1*IWID2.NE.0) THEN
39735 IZID1=IWID1
39736 IZID2=IWID2
39737 XM1M2=SMW(IWID1)*SMW(IWID2)
39738 SQMZ=PMAS(23,1)**2
39739 GMMZ=PMAS(23,1)*PMAS(23,2)
39740 DO 140 I=1,2
39741 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
39742 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
39743 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
39744 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
39745 140 CONTINUE
39746 OLPP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
39747 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0
39748 ORPP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
39749 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0
39750 QRLS=-DCMPLX(EI/XW1)*ORPP
39751 QLLS=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
39752 QRRS=-DCMPLX(EI/XW1)*OLPP
39753 QLRS=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
39754 IF(MOD(IA,2).EQ.0) THEN
39755 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)-1),1)**2
39756 QLRT=-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*DCMPLX(T3I/XW)
39757 ELSE
39758 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)+1),1)**2
39759 QLRT=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*DCMPLX(T3I/XW)
39760 ENDIF
39761 ELSEIF(MOD(K(N+1,2),KSUSY1).EQ.21.OR.MOD(K(ID,2),KSUSY1).EQ.21)
39762 &THEN
39763 ISKIP=0
39764 ELSE
39765 ISKIP=0
39766 ENDIF
39767
39768 IF(ISKIP.NE.0) THEN
39769 WTMAX=0D0
39770 DO 160 KT=1,100
39771 S12=S12MIN+YJACO1*(KT-1)/99
39772 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
39773 & *(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
39774 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
39775 & -(2D0*XM(1)*XM(2))**2
39776 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
39777 & -(2D0*XM(3)*XM(5))**2
39778 S23DF1=S23DF1*EPS
39779 S23DF2=S23DF2*EPS
39780 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
39781 S23DEL=S23DEL/EPS
39782 S23MIN=S23AVE-S23DEL
39783 S23MAX=S23AVE+S23DEL
39784 YJACO2=S23MAX-S23MIN
39785 TH=S12
39786 DO 150 KS=1,100
39787 S23=S23MIN+YJACO2*(KS-1)/99
39788 SH=S23
39789 UH=ZM12+ZM22-SH-TH
39790 WU2 = (UH-ZM12)*(UH-ZM22)
39791 WT2 = (TH-ZM12)*(TH-ZM22)
39792 WS2 = XM1M2*SH
39793 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
39794 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
39795 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
39796 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
39797 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
39798 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
39799 WT0=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
39800 & (ABS(QRL)**2+ABS(QLR)**2)*WT2+
39801 & 2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
39802 IF(WT0.GT.WTMAX) WTMAX=WT0
39803 150 CONTINUE
39804 160 CONTINUE
39805
39806 WTMAX=WTMAX*1.05D0
39807 ENDIF
39808
39809C...FIND S12*
39810 AX=S12MIN
39811 CX=S12MAX
39812 BX=S12MIN+0.5D0*YJACO1
39813 X0=AX
39814 X3=CX
39815 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
39816 X1=BX
39817 X2=BX+C*(CX-BX)
39818 ELSE
39819 X2=BX
39820 X1=BX-C*(BX-AX)
39821 ENDIF
39822
39823C...SOLVE FOR F1 AND F2
39824 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
39825 &-(2D0*XM(1)*XM(2))**2
39826 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
39827 &-(2D0*XM(3)*XM(5))**2
39828 S23DF1=S23DF1*EPS
39829 S23DF2=S23DF2*EPS
39830 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
39831 F1=-2D0*S23DEL/EPS
39832 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
39833 &-(2D0*XM(1)*XM(2))**2
39834 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
39835 &-(2D0*XM(3)*XM(5))**2
39836 S23DF1=S23DF1*EPS
39837 S23DF2=S23DF2*EPS
39838 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
39839 F2=-2D0*S23DEL/EPS
39840
39841 170 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
39842C...Possibility of infinite loop with .LT.; changed to .LE. (SKANDS)
39843 IF(F2.LE.F1)THEN
39844 X0=X1
39845 X1=X2
39846 X2=R*X1+C*X3
39847 F1=F2
39848 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
39849 & -(2D0*XM(1)*XM(2))**2
39850 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
39851 & -(2D0*XM(3)*XM(5))**2
39852 S23DF1=S23DF1*EPS
39853 S23DF2=S23DF2*EPS
39854 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
39855 F2=-2D0*S23DEL/EPS
39856 ELSE
39857 X3=X2
39858 X2=X1
39859 X1=R*X2+C*X0
39860 F2=F1
39861 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
39862 & -(2D0*XM(1)*XM(2))**2
39863 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
39864 & -(2D0*XM(3)*XM(5))**2
39865 S23DF1=S23DF1*EPS
39866 S23DF2=S23DF2*EPS
39867 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
39868 F1=-2D0*S23DEL/EPS
39869 ENDIF
39870 GOTO 170
39871 ENDIF
39872C...WE WANT THE MAXIMUM, NOT THE MINIMUM
39873 IF(F1.LT.F2)THEN
39874 GOLDEN=-F1
39875 XMIN=X1
39876 ELSE
39877 GOLDEN=-F2
39878 XMIN=X2
39879 ENDIF
39880
39881 IKNT=0
39882 180 S12=S12MIN+PYR(0)*YJACO1
39883 IKNT=IKNT+1
39884C...GENERATE S23
39885 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
39886 &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
39887 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
39888 &-(2D0*XM(1)*XM(2))**2
39889 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
39890 &-(2D0*XM(3)*XM(5))**2
39891 S23DF1=S23DF1*EPS
39892 S23DF2=S23DF2*EPS
39893 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
39894 S23DEL=S23DEL/EPS
39895 S23MIN=S23AVE-S23DEL
39896 S23MAX=S23AVE+S23DEL
39897 YJACO2=S23MAX-S23MIN
39898 S23=S23MIN+PYR(0)*YJACO2
39899
39900C...CHECK THE SAMPLING
39901 IF(IKNT.GT.100) THEN
39902 WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY '
39903 GOTO 190
39904 ENDIF
39905 IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 180
39906
39907 IF(ISKIP.EQ.0) GOTO 190
39908
39909 SH=S23
39910 TH=S12
39911 UH=ZM12+ZM22-SH-TH
39912
39913 WU2 = (UH-ZM12)*(UH-ZM22)
39914 WT2 = (TH-ZM12)*(TH-ZM22)
39915 WS2 = XM1M2*SH
39916 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
39917 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
39918
39919 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
39920 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
39921 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
39922 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
39923c QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
39924c QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
39925c &/DCMPLX(TH-XML2)
39926c QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
39927c QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
39928c &-DCONJG(GRIJ)/DCMPLX(UH-XMR2)
39929 WT=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
39930 &(ABS(QRL)**2+ABS(QLR)**2)*WT2+
39931 &2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
39932
39933 IF(WT.LT.PYR(0)*WTMAX) GOTO 180
39934 IF(WT.GT.WTMAX) PRINT*,' WT > WTMAX ',WT,WTMAX
39935
39936 190 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5))
39937 D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5))
39938 D2=XM(5)-D1-D3
39939 P1=SQRT(D1*D1-XM(1)**2)
39940 P2=SQRT(D2*D2-XM(2)**2)
39941 P3=SQRT(D3*D3-XM(3)**2)
39942 CTHE1=2D0*PYR(0)-1D0
39943 ANG1=2D0*PYR(0)*PARU(1)
39944 CPHI1=COS(ANG1)
39945 SPHI1=SIN(ANG1)
39946 ARG=1D0-CTHE1**2
39947 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
39948 STHE1=SQRT(ARG)
39949 P(N+1,1)=P1*STHE1*CPHI1
39950 P(N+1,2)=P1*STHE1*SPHI1
39951 P(N+1,3)=P1*CTHE1
39952 P(N+1,4)=D1
39953
39954C...GET CPHI3
39955 ANG3=2D0*PYR(0)*PARU(1)
39956 CPHI3=COS(ANG3)
39957 SPHI3=SIN(ANG3)
39958 CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3
39959 ARG=1D0-CTHE3**2
39960 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
39961 STHE3=SQRT(ARG)
39962 P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1
39963 &+P3*STHE3*SPHI3*SPHI1
39964 &+P3*CTHE3*STHE1*CPHI1
39965 P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1
39966 &-P3*STHE3*SPHI3*CPHI1
39967 &+P3*CTHE3*STHE1*SPHI1
39968 P(N+3,3)=P3*STHE3*CPHI3*STHE1
39969 &+P3*CTHE3*CTHE1
39970 P(N+3,4)=D3
39971
39972 DO 200 I=1,3
39973 P(N+2,I)=-P(N+1,I)-P(N+3,I)
39974 200 CONTINUE
39975 P(N+2,4)=D2
39976
39977 RETURN
39978 END
39979
39980C*********************************************************************
39981
39982C...PYTECM
39983C...Finds the s-hat dependent eigenvalues of the inverse propagator
39984C...matrix for gamma, Z, techni-rho, and techni-omega to optimize the
39985C...phase space generation.
39986
39987 SUBROUTINE PYTECM(S1,S2)
39988
39989C...Double precision and integer declarations.
39990 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39991 IMPLICIT INTEGER(I-N)
39992 INTEGER PYK,PYCHGE,PYCOMP
39993C...Parameter statement to help give large particle numbers.
39994 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
39995 &KEXCIT=4000000,KDIMEN=5000000)
39996C...Commonblocks.
39997 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39998 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39999 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40000 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
40001 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYTCSM/
40002
40003C...Local variables.
40004 DOUBLE PRECISION AR(4,4),WR(4),ZR(4,4),ZI(4,4),WORK(12,12),
40005 &AT(4,4),WI(4),FV1(4),FV2(4),FV3(4),sh,aem,tanw,ct2w,qupd,alprht,
40006 &far,fao,fzr,fzo,shr,R1,R2,S1,S2,WDTP(0:400),WDTE(0:400,0:5)
40007 INTEGER i,j,ierr
40008
40009 SH=PMAS(PYCOMP(KTECHN+113),1)**2
40010 AEM=PYALEM(SH)
40011
40012 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
40013 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
40014 QUPD=2D0*RTCM(2)-1D0
40015
40016 ALPRHT=2.91D0*(3D0/DBLE(ITCM(1)))
40017 FAR=SQRT(AEM/ALPRHT)
40018 FAO=FAR*QUPD
40019 FZR=FAR*CT2W
40020 FZO=-FAO*TANW
40021
40022 AR(1,1) = SH
40023 AR(2,2) = SH-PMAS(23,1)**2
40024 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+113),1)**2
40025 AR(4,4) = SH-PMAS(PYCOMP(KTECHN+223),1)**2
40026 AR(1,2) = 0D0
40027 AR(2,1) = 0D0
40028 AR(1,3) = -SH*FAR
40029 AR(3,1) = AR(1,3)
40030 AR(1,4) = -SH*FAO
40031 AR(4,1) = AR(1,4)
40032 AR(2,3) = -SH*FZR
40033 AR(3,2) = AR(2,3)
40034 AR(2,4) = -SH*FZO
40035 AR(4,2) = AR(2,4)
40036 AR(3,4) = 0D0
40037 AR(4,3) = 0D0
40038CCCCCCCC
40039 DO 110 I=1,4
40040 DO 100 J=1,4
40041 AT(I,J)=0D0
40042 100 CONTINUE
40043 110 CONTINUE
40044 SHR=SQRT(SH)
40045 CALL PYWIDT(23,SH,WDTP,WDTE)
40046 AT(2,2) = WDTP(0)*SHR
40047 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
40048 AT(3,3) = WDTP(0)*SHR
40049 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
40050 AT(4,4) = WDTP(0)*SHR
40051CCCC
40052 CALL PYEICG(4,4,AR,AT,WR,WI,0,ZR,ZI,FV1,FV2,FV3,IERR)
40053 DO 120 I=1,4
40054 WI(I)=SQRT(ABS(SH-WR(I)))
40055 WR(I)=ABS(WR(I))
40056 120 CONTINUE
40057 R1=MIN(WR(1),WR(2),WR(3),WR(4))
40058 R2=1D20
40059 S1=0D0
40060 S2=0D0
40061 DO 130 I=1,4
40062 IF(ABS(WR(I)-R1).LT.1D-6) THEN
40063 S1=WI(I)
40064 GOTO 130
40065 ENDIF
40066 IF(WR(I).LE.R2) THEN
40067 R2=WR(I)
40068 S2=WI(I)
40069 ENDIF
40070 130 CONTINUE
40071 S1=S1**2
40072 S2=S2**2
40073 RETURN
40074 END
40075
40076C*********************************************************************
40077
40078C...PYEIGC
40079C...Finds eigenvalues of a general complex matrix
40080C
40081C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
40082C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
40083C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
40084C OF A COMPLEX GENERAL MATRIX.
40085C
40086C ON INPUT
40087C
40088C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
40089C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
40090C DIMENSION STATEMENT.
40091C
40092C N IS THE ORDER OF THE MATRIX A=(AR,AI).
40093C
40094C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
40095C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
40096C
40097C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
40098C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
40099C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
40100C
40101C ON OUTPUT
40102C
40103C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
40104C RESPECTIVELY, OF THE EIGENVALUES.
40105C
40106C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
40107C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
40108C
40109C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
40110C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
40111C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO.
40112C
40113C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS.
40114C
40115C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
40116C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
40117C
40118C THIS VERSION DATED AUGUST 1983.
40119C
40120
40121 SUBROUTINE PYEICG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
40122
40123 INTEGER N,NM,IS1,IS2,IERR,MATZ
40124 DOUBLE PRECISION AR(4,4),AI(4,4),WR(4),WI(4),ZR(4,4),ZI(4,4),
40125 X FV1(4),FV2(4),FV3(4)
40126 IF (N .LE. NM) GOTO 100
40127 IERR = 10 * N
40128 GOTO 120
40129C
40130 100 CALL PYCBAL(NM,N,AR,AI,IS1,IS2,FV1)
40131 CALL PYCRTH(NM,N,IS1,IS2,AR,AI,FV2,FV3)
40132 IF (MATZ .NE. 0) GOTO 110
40133C .......... FIND EIGENVALUES ONLY ..........
40134 CALL PYCMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR)
40135 GOTO 120
40136C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
40137 110 CALL PYCMQ2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR)
40138 IF (IERR .NE. 0) GOTO 120
40139 CALL PYCBA2(NM,N,IS1,IS2,FV1,N,ZR,ZI)
40140 120 RETURN
40141 END
40142
40143C*********************************************************************
40144
40145C...PYCMQR
40146C...Auxiliary to PYEICG.
40147C
40148C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
40149C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
40150C AND WILKINSON.
40151C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
40152C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
40153C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
40154C
40155C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
40156C UPPER HESSENBERG MATRIX BY THE QR METHOD.
40157C
40158C ON INPUT
40159C
40160C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
40161C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
40162C DIMENSION STATEMENT.
40163C
40164C N IS THE ORDER OF THE MATRIX.
40165C
40166C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
40167C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
40168C SET LOW=1, IGH=N.
40169C
40170C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
40171C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
40172C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
40173C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
40174C THE REDUCTION BY CORTH, IF PERFORMED.
40175C
40176C ON OUTPUT
40177C
40178C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
40179C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE
40180C CALLING COMQR IF SUBSEQUENT CALCULATION OF
40181C EIGENVECTORS IS TO BE PERFORMED.
40182C
40183C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
40184C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
40185C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
40186C FOR INDICES IERR+1,...,N.
40187C
40188C IERR IS SET TO
40189C ZERO FOR NORMAL RETURN,
40190C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
40191C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
40192C
40193C CALLS PYCDIV FOR COMPLEX DIVISION.
40194C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
40195C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
40196C
40197C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
40198C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
40199C
40200C THIS VERSION DATED AUGUST 1983.
40201C
40202
40203 SUBROUTINE PYCMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
40204
40205 INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
40206 DOUBLE PRECISION HR(4,4),HI(4,4),WR(4),WI(4)
40207 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
40208 X PYTHAG
40209
40210 IERR = 0
40211 IF (LOW .EQ. IGH) GOTO 130
40212C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
40213 L = LOW + 1
40214C
40215 DO 120 I = L, IGH
40216 LL = MIN0(I+1,IGH)
40217 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 120
40218 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
40219 YR = HR(I,I-1) / NORM
40220 YI = HI(I,I-1) / NORM
40221 HR(I,I-1) = NORM
40222 HI(I,I-1) = 0.0D0
40223C
40224 DO 100 J = I, IGH
40225 SI = YR * HI(I,J) - YI * HR(I,J)
40226 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
40227 HI(I,J) = SI
40228 100 CONTINUE
40229C
40230 DO 110 J = LOW, LL
40231 SI = YR * HI(J,I) + YI * HR(J,I)
40232 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
40233 HI(J,I) = SI
40234 110 CONTINUE
40235C
40236 120 CONTINUE
40237C .......... STORE ROOTS ISOLATED BY CBAL ..........
40238 130 DO 140 I = 1, N
40239 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
40240 WR(I) = HR(I,I)
40241 WI(I) = HI(I,I)
40242 140 CONTINUE
40243C
40244 EN = IGH
40245 TR = 0.0D0
40246 TI = 0.0D0
40247 ITN = 30*N
40248C .......... SEARCH FOR NEXT EIGENVALUE ..........
40249 150 IF (EN .LT. LOW) GOTO 320
40250 ITS = 0
40251 ENM1 = EN - 1
40252C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
40253C FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
40254 160 DO 170 LL = LOW, EN
40255 L = EN + LOW - LL
40256 IF (L .EQ. LOW) GOTO 180
40257 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
40258 X + DABS(HR(L,L)) + DABS(HI(L,L))
40259 TST2 = TST1 + DABS(HR(L,L-1))
40260 IF (TST2 .EQ. TST1) GOTO 180
40261 170 CONTINUE
40262C .......... FORM SHIFT ..........
40263 180 IF (L .EQ. EN) GOTO 300
40264 IF (ITN .EQ. 0) GOTO 310
40265 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 200
40266 SR = HR(EN,EN)
40267 SI = HI(EN,EN)
40268 XR = HR(ENM1,EN) * HR(EN,ENM1)
40269 XI = HI(ENM1,EN) * HR(EN,ENM1)
40270 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 210
40271 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
40272 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
40273 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
40274 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 190
40275 ZZR = -ZZR
40276 ZZI = -ZZI
40277 190 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
40278 SR = SR - XR
40279 SI = SI - XI
40280 GOTO 210
40281C .......... FORM EXCEPTIONAL SHIFT ..........
40282 200 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
40283 SI = 0.0D0
40284C
40285 210 DO 220 I = LOW, EN
40286 HR(I,I) = HR(I,I) - SR
40287 HI(I,I) = HI(I,I) - SI
40288 220 CONTINUE
40289C
40290 TR = TR + SR
40291 TI = TI + SI
40292 ITS = ITS + 1
40293 ITN = ITN - 1
40294C .......... REDUCE TO TRIANGLE (ROWS) ..........
40295 LP1 = L + 1
40296C
40297 DO 240 I = LP1, EN
40298 SR = HR(I,I-1)
40299 HR(I,I-1) = 0.0D0
40300 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
40301 XR = HR(I-1,I-1) / NORM
40302 WR(I-1) = XR
40303 XI = HI(I-1,I-1) / NORM
40304 WI(I-1) = XI
40305 HR(I-1,I-1) = NORM
40306 HI(I-1,I-1) = 0.0D0
40307 HI(I,I-1) = SR / NORM
40308C
40309 DO 230 J = I, EN
40310 YR = HR(I-1,J)
40311 YI = HI(I-1,J)
40312 ZZR = HR(I,J)
40313 ZZI = HI(I,J)
40314 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
40315 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
40316 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
40317 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
40318 230 CONTINUE
40319C
40320 240 CONTINUE
40321C
40322 SI = HI(EN,EN)
40323 IF (SI .EQ. 0.0D0) GOTO 250
40324 NORM = PYTHAG(HR(EN,EN),SI)
40325 SR = HR(EN,EN) / NORM
40326 SI = SI / NORM
40327 HR(EN,EN) = NORM
40328 HI(EN,EN) = 0.0D0
40329C .......... INVERSE OPERATION (COLUMNS) ..........
40330 250 DO 280 J = LP1, EN
40331 XR = WR(J-1)
40332 XI = WI(J-1)
40333C
40334 DO 270 I = L, J
40335 YR = HR(I,J-1)
40336 YI = 0.0D0
40337 ZZR = HR(I,J)
40338 ZZI = HI(I,J)
40339 IF (I .EQ. J) GOTO 260
40340 YI = HI(I,J-1)
40341 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
40342 260 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
40343 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
40344 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
40345 270 CONTINUE
40346C
40347 280 CONTINUE
40348C
40349 IF (SI .EQ. 0.0D0) GOTO 160
40350C
40351 DO 290 I = L, EN
40352 YR = HR(I,EN)
40353 YI = HI(I,EN)
40354 HR(I,EN) = SR * YR - SI * YI
40355 HI(I,EN) = SR * YI + SI * YR
40356 290 CONTINUE
40357C
40358 GOTO 160
40359C .......... A ROOT FOUND ..........
40360 300 WR(EN) = HR(EN,EN) + TR
40361 WI(EN) = HI(EN,EN) + TI
40362 EN = ENM1
40363 GOTO 150
40364C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
40365C CONVERGED AFTER 30*N ITERATIONS ..........
40366 310 IERR = EN
40367 320 RETURN
40368 END
40369
40370C*********************************************************************
40371
40372C...PYCMQ2
40373C...Auxiliary to PYEICG.
40374C
40375C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
40376C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
40377C AND WILKINSON.
40378C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
40379C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
40380C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
40381C
40382C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
40383C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
40384C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
40385C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE
40386C THIS GENERAL MATRIX TO HESSENBERG FORM.
40387C
40388C ON INPUT
40389C
40390C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
40391C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
40392C DIMENSION STATEMENT.
40393C
40394C N IS THE ORDER OF THE MATRIX.
40395C
40396C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
40397C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
40398C SET LOW=1, IGH=N.
40399C
40400C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
40401C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED.
40402C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS
40403C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
40404C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
40405C
40406C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
40407C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
40408C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
40409C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
40410C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF
40411C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
40412C ARBITRARY.
40413C
40414C ON OUTPUT
40415C
40416C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
40417C HAVE BEEN DESTROYED.
40418C
40419C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
40420C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
40421C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
40422C FOR INDICES IERR+1,...,N.
40423C
40424C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
40425C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS
40426C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF
40427C THE EIGENVECTORS HAS BEEN FOUND.
40428C
40429C IERR IS SET TO
40430C ZERO FOR NORMAL RETURN,
40431C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
40432C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
40433C
40434C CALLS PYCDIV FOR COMPLEX DIVISION.
40435C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
40436C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
40437C
40438C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
40439C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
40440C
40441C THIS VERSION DATED OCTOBER 1989.
40442C
40443C MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG)
40444C MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG)
40445C
40446
40447 SUBROUTINE PYCMQ2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
40448
40449 INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
40450 X ITN,ITS,LOW,LP1,ENM1,IEND,IERR
40451 DOUBLE PRECISION HR(4,4),HI(4,4),WR(4),WI(4),ZR(4,4),ZI(4,4),
40452 X ORTR(4),ORTI(4)
40453 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
40454 X PYTHAG
40455
40456 IERR = 0
40457C .......... INITIALIZE EIGENVECTOR MATRIX ..........
40458 DO 110 J = 1, N
40459C
40460 DO 100 I = 1, N
40461 ZR(I,J) = 0.0D0
40462 ZI(I,J) = 0.0D0
40463 100 CONTINUE
40464 ZR(J,J) = 1.0D0
40465 110 CONTINUE
40466C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
40467C FROM THE INFORMATION LEFT BY CORTH ..........
40468 IEND = IGH - LOW - 1
40469 IF (IEND.LT.0) GOTO 220
40470 IF (IEND.EQ.0) GOTO 170
40471C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
40472 DO 160 II = 1, IEND
40473 I = IGH - II
40474 IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GOTO 160
40475 IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GOTO 160
40476C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
40477 NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I)
40478 IP1 = I + 1
40479C
40480 DO 120 K = IP1, IGH
40481 ORTR(K) = HR(K,I-1)
40482 ORTI(K) = HI(K,I-1)
40483 120 CONTINUE
40484C
40485 DO 150 J = I, IGH
40486 SR = 0.0D0
40487 SI = 0.0D0
40488C
40489 DO 130 K = I, IGH
40490 SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J)
40491 SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J)
40492 130 CONTINUE
40493C
40494 SR = SR / NORM
40495 SI = SI / NORM
40496C
40497 DO 140 K = I, IGH
40498 ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K)
40499 ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K)
40500 140 CONTINUE
40501C
40502 150 CONTINUE
40503C
40504 160 CONTINUE
40505C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
40506 170 L = LOW + 1
40507C
40508 DO 210 I = L, IGH
40509 LL = MIN0(I+1,IGH)
40510 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 210
40511 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
40512 YR = HR(I,I-1) / NORM
40513 YI = HI(I,I-1) / NORM
40514 HR(I,I-1) = NORM
40515 HI(I,I-1) = 0.0D0
40516C
40517 DO 180 J = I, N
40518 SI = YR * HI(I,J) - YI * HR(I,J)
40519 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
40520 HI(I,J) = SI
40521 180 CONTINUE
40522C
40523 DO 190 J = 1, LL
40524 SI = YR * HI(J,I) + YI * HR(J,I)
40525 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
40526 HI(J,I) = SI
40527 190 CONTINUE
40528C
40529 DO 200 J = LOW, IGH
40530 SI = YR * ZI(J,I) + YI * ZR(J,I)
40531 ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I)
40532 ZI(J,I) = SI
40533 200 CONTINUE
40534C
40535 210 CONTINUE
40536C .......... STORE ROOTS ISOLATED BY CBAL ..........
40537 220 DO 230 I = 1, N
40538 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 230
40539 WR(I) = HR(I,I)
40540 WI(I) = HI(I,I)
40541 230 CONTINUE
40542C
40543 EN = IGH
40544 TR = 0.0D0
40545 TI = 0.0D0
40546 ITN = 30*N
40547C .......... SEARCH FOR NEXT EIGENVALUE ..........
40548 240 IF (EN .LT. LOW) GOTO 430
40549 ITS = 0
40550 ENM1 = EN - 1
40551C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
40552C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
40553 250 DO 260 LL = LOW, EN
40554 L = EN + LOW - LL
40555 IF (L .EQ. LOW) GOTO 270
40556 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
40557 X + DABS(HR(L,L)) + DABS(HI(L,L))
40558 TST2 = TST1 + DABS(HR(L,L-1))
40559 IF (TST2 .EQ. TST1) GOTO 270
40560 260 CONTINUE
40561C .......... FORM SHIFT ..........
40562 270 IF (L .EQ. EN) GOTO 420
40563 IF (ITN .EQ. 0) GOTO 550
40564 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 290
40565 SR = HR(EN,EN)
40566 SI = HI(EN,EN)
40567 XR = HR(ENM1,EN) * HR(EN,ENM1)
40568 XI = HI(ENM1,EN) * HR(EN,ENM1)
40569 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 300
40570 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
40571 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
40572 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
40573 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 280
40574 ZZR = -ZZR
40575 ZZI = -ZZI
40576 280 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
40577 SR = SR - XR
40578 SI = SI - XI
40579 GOTO 300
40580C .......... FORM EXCEPTIONAL SHIFT ..........
40581 290 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
40582 SI = 0.0D0
40583C
40584 300 DO 310 I = LOW, EN
40585 HR(I,I) = HR(I,I) - SR
40586 HI(I,I) = HI(I,I) - SI
40587 310 CONTINUE
40588C
40589 TR = TR + SR
40590 TI = TI + SI
40591 ITS = ITS + 1
40592 ITN = ITN - 1
40593C .......... REDUCE TO TRIANGLE (ROWS) ..........
40594 LP1 = L + 1
40595C
40596 DO 330 I = LP1, EN
40597 SR = HR(I,I-1)
40598 HR(I,I-1) = 0.0D0
40599 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
40600 XR = HR(I-1,I-1) / NORM
40601 WR(I-1) = XR
40602 XI = HI(I-1,I-1) / NORM
40603 WI(I-1) = XI
40604 HR(I-1,I-1) = NORM
40605 HI(I-1,I-1) = 0.0D0
40606 HI(I,I-1) = SR / NORM
40607C
40608 DO 320 J = I, N
40609 YR = HR(I-1,J)
40610 YI = HI(I-1,J)
40611 ZZR = HR(I,J)
40612 ZZI = HI(I,J)
40613 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
40614 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
40615 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
40616 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
40617 320 CONTINUE
40618C
40619 330 CONTINUE
40620C
40621 SI = HI(EN,EN)
40622 IF (SI .EQ. 0.0D0) GOTO 350
40623 NORM = PYTHAG(HR(EN,EN),SI)
40624 SR = HR(EN,EN) / NORM
40625 SI = SI / NORM
40626 HR(EN,EN) = NORM
40627 HI(EN,EN) = 0.0D0
40628 IF (EN .EQ. N) GOTO 350
40629 IP1 = EN + 1
40630C
40631 DO 340 J = IP1, N
40632 YR = HR(EN,J)
40633 YI = HI(EN,J)
40634 HR(EN,J) = SR * YR + SI * YI
40635 HI(EN,J) = SR * YI - SI * YR
40636 340 CONTINUE
40637C .......... INVERSE OPERATION (COLUMNS) ..........
40638 350 DO 390 J = LP1, EN
40639 XR = WR(J-1)
40640 XI = WI(J-1)
40641C
40642 DO 370 I = 1, J
40643 YR = HR(I,J-1)
40644 YI = 0.0D0
40645 ZZR = HR(I,J)
40646 ZZI = HI(I,J)
40647 IF (I .EQ. J) GOTO 360
40648 YI = HI(I,J-1)
40649 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
40650 360 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
40651 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
40652 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
40653 370 CONTINUE
40654C
40655 DO 380 I = LOW, IGH
40656 YR = ZR(I,J-1)
40657 YI = ZI(I,J-1)
40658 ZZR = ZR(I,J)
40659 ZZI = ZI(I,J)
40660 ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
40661 ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
40662 ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
40663 ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
40664 380 CONTINUE
40665C
40666 390 CONTINUE
40667C
40668 IF (SI .EQ. 0.0D0) GOTO 250
40669C
40670 DO 400 I = 1, EN
40671 YR = HR(I,EN)
40672 YI = HI(I,EN)
40673 HR(I,EN) = SR * YR - SI * YI
40674 HI(I,EN) = SR * YI + SI * YR
40675 400 CONTINUE
40676C
40677 DO 410 I = LOW, IGH
40678 YR = ZR(I,EN)
40679 YI = ZI(I,EN)
40680 ZR(I,EN) = SR * YR - SI * YI
40681 ZI(I,EN) = SR * YI + SI * YR
40682 410 CONTINUE
40683C
40684 GOTO 250
40685C .......... A ROOT FOUND ..........
40686 420 HR(EN,EN) = HR(EN,EN) + TR
40687 WR(EN) = HR(EN,EN)
40688 HI(EN,EN) = HI(EN,EN) + TI
40689 WI(EN) = HI(EN,EN)
40690 EN = ENM1
40691 GOTO 240
40692C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
40693C VECTORS OF UPPER TRIANGULAR FORM ..........
40694 430 NORM = 0.0D0
40695C
40696 DO 440 I = 1, N
40697C
40698 DO 440 J = I, N
40699 TR = DABS(HR(I,J)) + DABS(HI(I,J))
40700 IF (TR .GT. NORM) NORM = TR
40701 440 CONTINUE
40702C
40703 IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GOTO 560
40704C .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
40705 DO 500 NN = 2, N
40706 EN = N + 2 - NN
40707 XR = WR(EN)
40708 XI = WI(EN)
40709 HR(EN,EN) = 1.0D0
40710 HI(EN,EN) = 0.0D0
40711 ENM1 = EN - 1
40712C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
40713 DO 490 II = 1, ENM1
40714 I = EN - II
40715 ZZR = 0.0D0
40716 ZZI = 0.0D0
40717 IP1 = I + 1
40718C
40719 DO 450 J = IP1, EN
40720 ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
40721 ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
40722 450 CONTINUE
40723C
40724 YR = XR - WR(I)
40725 YI = XI - WI(I)
40726 IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GOTO 470
40727 TST1 = NORM
40728 YR = TST1
40729 460 YR = 0.01D0 * YR
40730 TST2 = NORM + YR
40731 IF (TST2 .GT. TST1) GOTO 460
40732 470 CONTINUE
40733 CALL PYCDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
40734C .......... OVERFLOW CONTROL ..........
40735 TR = DABS(HR(I,EN)) + DABS(HI(I,EN))
40736 IF (TR .EQ. 0.0D0) GOTO 490
40737 TST1 = TR
40738 TST2 = TST1 + 1.0D0/TST1
40739 IF (TST2 .GT. TST1) GOTO 490
40740 DO 480 J = I, EN
40741 HR(J,EN) = HR(J,EN)/TR
40742 HI(J,EN) = HI(J,EN)/TR
40743 480 CONTINUE
40744C
40745 490 CONTINUE
40746C
40747 500 CONTINUE
40748C .......... END BACKSUBSTITUTION ..........
40749C .......... VECTORS OF ISOLATED ROOTS ..........
40750 DO 520 I = 1, N
40751 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 520
40752C
40753 DO 510 J = I, N
40754 ZR(I,J) = HR(I,J)
40755 ZI(I,J) = HI(I,J)
40756 510 CONTINUE
40757C
40758 520 CONTINUE
40759C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
40760C VECTORS OF ORIGINAL FULL MATRIX.
40761C FOR J=N STEP -1 UNTIL LOW DO -- ..........
40762 DO 540 JJ = LOW, N
40763 J = N + LOW - JJ
40764 M = MIN0(J,IGH)
40765C
40766 DO 540 I = LOW, IGH
40767 ZZR = 0.0D0
40768 ZZI = 0.0D0
40769C
40770 DO 530 K = LOW, M
40771 ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
40772 ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
40773 530 CONTINUE
40774C
40775 ZR(I,J) = ZZR
40776 ZI(I,J) = ZZI
40777 540 CONTINUE
40778C
40779 GOTO 560
40780C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
40781C CONVERGED AFTER 30*N ITERATIONS ..........
40782 550 IERR = EN
40783 560 RETURN
40784 END
40785
40786C*********************************************************************
40787
40788C...PYCDIV
40789C...Auxiliary to PYCMQR
40790C
40791C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
40792C
40793
40794 SUBROUTINE PYCDIV(AR,AI,BR,BI,CR,CI)
40795
40796 DOUBLE PRECISION AR,AI,BR,BI,CR,CI
40797 DOUBLE PRECISION S,ARS,AIS,BRS,BIS
40798
40799 S = DABS(BR) + DABS(BI)
40800 ARS = AR/S
40801 AIS = AI/S
40802 BRS = BR/S
40803 BIS = BI/S
40804 S = BRS**2 + BIS**2
40805 CR = (ARS*BRS + AIS*BIS)/S
40806 CI = (AIS*BRS - ARS*BIS)/S
40807 RETURN
40808 END
40809
40810C*********************************************************************
40811
40812C...PYCSRT
40813C...Auxiliary to PYCMQR
40814C
40815C (YR,YI) = COMPLEX DSQRT(XR,XI)
40816C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
40817C
40818
40819 SUBROUTINE PYCSRT(XR,XI,YR,YI)
40820
40821 DOUBLE PRECISION XR,XI,YR,YI
40822 DOUBLE PRECISION S,TR,TI,PYTHAG
40823
40824 TR = XR
40825 TI = XI
40826 S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR)))
40827 IF (TR .GE. 0.0D0) YR = S
40828 IF (TI .LT. 0.0D0) S = -S
40829 IF (TR .LE. 0.0D0) YI = S
40830 IF (TR .LT. 0.0D0) YR = 0.5D0*(TI/YI)
40831 IF (TR .GT. 0.0D0) YI = 0.5D0*(TI/YR)
40832 RETURN
40833 END
40834
40835 DOUBLE PRECISION FUNCTION PYTHAG(A,B)
40836 DOUBLE PRECISION A,B
40837C
40838C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
40839C
40840 DOUBLE PRECISION P,R,S,T,U
40841 P = DMAX1(DABS(A),DABS(B))
40842 IF (P .EQ. 0.0D0) GOTO 110
40843 R = (DMIN1(DABS(A),DABS(B))/P)**2
40844 100 CONTINUE
40845 T = 4.0D0 + R
40846 IF (T .EQ. 4.0D0) GOTO 110
40847 S = R/T
40848 U = 1.0D0 + 2.0D0*S
40849 P = U*P
40850 R = (S/U)**2 * R
40851 GOTO 100
40852 110 PYTHAG = P
40853 RETURN
40854 END
40855
40856C*********************************************************************
40857
40858C...PYCBAL
40859C...Auxiliary to PYEICG
40860C
40861C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
40862C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
40863C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
40864C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
40865C
40866C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
40867C EIGENVALUES WHENEVER POSSIBLE.
40868C
40869C ON INPUT
40870C
40871C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
40872C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
40873C DIMENSION STATEMENT.
40874C
40875C N IS THE ORDER OF THE MATRIX.
40876C
40877C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
40878C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
40879C
40880C ON OUTPUT
40881C
40882C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
40883C RESPECTIVELY, OF THE BALANCED MATRIX.
40884C
40885C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
40886C ARE EQUAL TO ZERO IF
40887C (1) I IS GREATER THAN J AND
40888C (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
40889C
40890C SCALE CONTAINS INFORMATION DETERMINING THE
40891C PERMUTATIONS AND SCALING FACTORS USED.
40892C
40893C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
40894C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
40895C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
40896C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN
40897C SCALE(J) = P(J), FOR J = 1,...,LOW-1
40898C = D(J,J) J = LOW,...,IGH
40899C = P(J) J = IGH+1,...,N.
40900C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
40901C THEN 1 TO LOW-1.
40902C
40903C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
40904C
40905C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
40906C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
40907C K,L HAVE BEEN REVERSED.)
40908C
40909C ARITHMETIC IS REAL THROUGHOUT.
40910C
40911C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
40912C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
40913C
40914C THIS VERSION DATED AUGUST 1983.
40915C
40916
40917 SUBROUTINE PYCBAL(NM,N,AR,AI,LOW,IGH,SCALE)
40918
40919 INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
40920 DOUBLE PRECISION AR(4,4),AI(4,4),SCALE(4)
40921 DOUBLE PRECISION C,F,G,R,S,B2,RADIX
40922 LOGICAL NOCONV
40923
40924 RADIX = 16.0D0
40925C
40926 B2 = RADIX * RADIX
40927 K = 1
40928 L = N
40929 GOTO 150
40930C .......... IN-LINE PROCEDURE FOR ROW AND
40931C COLUMN EXCHANGE ..........
40932 100 SCALE(M) = J
40933 IF (J .EQ. M) GOTO 130
40934C
40935 DO 110 I = 1, L
40936 F = AR(I,J)
40937 AR(I,J) = AR(I,M)
40938 AR(I,M) = F
40939 F = AI(I,J)
40940 AI(I,J) = AI(I,M)
40941 AI(I,M) = F
40942 110 CONTINUE
40943C
40944 DO 120 I = K, N
40945 F = AR(J,I)
40946 AR(J,I) = AR(M,I)
40947 AR(M,I) = F
40948 F = AI(J,I)
40949 AI(J,I) = AI(M,I)
40950 AI(M,I) = F
40951 120 CONTINUE
40952C
40953 130 IF(IEXC.EQ.1) GOTO 140
40954 IF(IEXC.EQ.2) GOTO 180
40955C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
40956C AND PUSH THEM DOWN ..........
40957 140 IF (L .EQ. 1) GOTO 320
40958 L = L - 1
40959C .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
40960 150 DO 170 JJ = 1, L
40961 J = L + 1 - JJ
40962C
40963 DO 160 I = 1, L
40964 IF (I .EQ. J) GOTO 160
40965 IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GOTO 170
40966 160 CONTINUE
40967C
40968 M = L
40969 IEXC = 1
40970 GOTO 100
40971 170 CONTINUE
40972C
40973 GOTO 190
40974C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
40975C AND PUSH THEM LEFT ..........
40976 180 K = K + 1
40977C
40978 190 DO 210 J = K, L
40979C
40980 DO 200 I = K, L
40981 IF (I .EQ. J) GOTO 200
40982 IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GOTO 210
40983 200 CONTINUE
40984C
40985 M = K
40986 IEXC = 2
40987 GOTO 100
40988 210 CONTINUE
40989C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
40990 DO 220 I = K, L
40991 220 SCALE(I) = 1.0D0
40992C .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
40993 230 NOCONV = .FALSE.
40994C
40995 DO 310 I = K, L
40996 C = 0.0D0
40997 R = 0.0D0
40998C
40999 DO 240 J = K, L
41000 IF (J .EQ. I) GOTO 240
41001 C = C + DABS(AR(J,I)) + DABS(AI(J,I))
41002 R = R + DABS(AR(I,J)) + DABS(AI(I,J))
41003 240 CONTINUE
41004C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
41005 IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GOTO 310
41006 G = R / RADIX
41007 F = 1.0D0
41008 S = C + R
41009 250 IF (C .GE. G) GOTO 260
41010 F = F * RADIX
41011 C = C * B2
41012 GOTO 250
41013 260 G = R * RADIX
41014 270 IF (C .LT. G) GOTO 280
41015 F = F / RADIX
41016 C = C / B2
41017 GOTO 270
41018C .......... NOW BALANCE ..........
41019 280 IF ((C + R) / F .GE. 0.95D0 * S) GOTO 310
41020 G = 1.0D0 / F
41021 SCALE(I) = SCALE(I) * F
41022 NOCONV = .TRUE.
41023C
41024 DO 290 J = K, N
41025 AR(I,J) = AR(I,J) * G
41026 AI(I,J) = AI(I,J) * G
41027 290 CONTINUE
41028C
41029 DO 300 J = 1, L
41030 AR(J,I) = AR(J,I) * F
41031 AI(J,I) = AI(J,I) * F
41032 300 CONTINUE
41033C
41034 310 CONTINUE
41035C
41036 IF (NOCONV) GOTO 230
41037C
41038 320 LOW = K
41039 IGH = L
41040 RETURN
41041 END
41042
41043C*********************************************************************
41044
41045C...PYCBA2
41046C...Auxiliary to PYEICG.
41047C
41048C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
41049C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
41050C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
41051C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
41052C
41053C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
41054C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
41055C BALANCED MATRIX DETERMINED BY CBAL.
41056C
41057C ON INPUT
41058C
41059C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
41060C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
41061C DIMENSION STATEMENT.
41062C
41063C N IS THE ORDER OF THE MATRIX.
41064C
41065C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL.
41066C
41067C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
41068C AND SCALING FACTORS USED BY CBAL.
41069C
41070C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
41071C
41072C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
41073C RESPECTIVELY, OF THE EIGENVECTORS TO BE
41074C BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
41075C
41076C ON OUTPUT
41077C
41078C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
41079C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
41080C IN THEIR FIRST M COLUMNS.
41081C
41082C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
41083C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
41084C
41085C THIS VERSION DATED AUGUST 1983.
41086C
41087
41088 SUBROUTINE PYCBA2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
41089
41090 INTEGER I,J,K,M,N,II,NM,IGH,LOW
41091 DOUBLE PRECISION SCALE(4),ZR(4,4),ZI(4,4)
41092 DOUBLE PRECISION S
41093
41094 IF (M .EQ. 0) GOTO 150
41095 IF (IGH .EQ. LOW) GOTO 120
41096C
41097 DO 110 I = LOW, IGH
41098 S = SCALE(I)
41099C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
41100C IF THE FOREGOING STATEMENT IS REPLACED BY
41101C S=1.0D0/SCALE(I). ..........
41102 DO 100 J = 1, M
41103 ZR(I,J) = ZR(I,J) * S
41104 ZI(I,J) = ZI(I,J) * S
41105 100 CONTINUE
41106C
41107 110 CONTINUE
41108C .......... FOR I=LOW-1 STEP -1 UNTIL 1,
41109C IGH+1 STEP 1 UNTIL N DO -- ..........
41110 120 DO 140 II = 1, N
41111 I = II
41112 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
41113 IF (I .LT. LOW) I = LOW - II
41114 K = SCALE(I)
41115 IF (K .EQ. I) GOTO 140
41116C
41117 DO 130 J = 1, M
41118 S = ZR(I,J)
41119 ZR(I,J) = ZR(K,J)
41120 ZR(K,J) = S
41121 S = ZI(I,J)
41122 ZI(I,J) = ZI(K,J)
41123 ZI(K,J) = S
41124 130 CONTINUE
41125C
41126 140 CONTINUE
41127C
41128 150 RETURN
41129 END
41130
41131C*********************************************************************
41132
41133C...PYCRTH
41134C...Auxiliary to PYEICG.
41135C
41136C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
41137C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
41138C BY MARTIN AND WILKINSON.
41139C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
41140C
41141C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
41142C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
41143C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
41144C UNITARY SIMILARITY TRANSFORMATIONS.
41145C
41146C ON INPUT
41147C
41148C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
41149C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
41150C DIMENSION STATEMENT.
41151C
41152C N IS THE ORDER OF THE MATRIX.
41153C
41154C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
41155C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
41156C SET LOW=1, IGH=N.
41157C
41158C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
41159C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
41160C
41161C ON OUTPUT
41162C
41163C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
41164C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION
41165C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
41166C IS STORED IN THE REMAINING TRIANGLES UNDER THE
41167C HESSENBERG MATRIX.
41168C
41169C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
41170C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED.
41171C
41172C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
41173C
41174C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
41175C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
41176C
41177C THIS VERSION DATED AUGUST 1983.
41178C
41179
41180 SUBROUTINE PYCRTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
41181
41182 INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
41183 DOUBLE PRECISION AR(4,4),AI(4,4),ORTR(4),ORTI(4)
41184 DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG
41185
41186 LA = IGH - 1
41187 KP1 = LOW + 1
41188 IF (LA .LT. KP1) GOTO 210
41189C
41190 DO 200 M = KP1, LA
41191 H = 0.0D0
41192 ORTR(M) = 0.0D0
41193 ORTI(M) = 0.0D0
41194 SCALE = 0.0D0
41195C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
41196 DO 100 I = M, IGH
41197 100 SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1))
41198C
41199 IF (SCALE .EQ. 0.0D0) GOTO 200
41200 MP = M + IGH
41201C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
41202 DO 110 II = M, IGH
41203 I = MP - II
41204 ORTR(I) = AR(I,M-1) / SCALE
41205 ORTI(I) = AI(I,M-1) / SCALE
41206 H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I)
41207 110 CONTINUE
41208C
41209 G = DSQRT(H)
41210 F = PYTHAG(ORTR(M),ORTI(M))
41211 IF (F .EQ. 0.0D0) GOTO 120
41212 H = H + F * G
41213 G = G / F
41214 ORTR(M) = (1.0D0 + G) * ORTR(M)
41215 ORTI(M) = (1.0D0 + G) * ORTI(M)
41216 GOTO 130
41217C
41218 120 ORTR(M) = G
41219 AR(M,M-1) = SCALE
41220C .......... FORM (I-(U*UT)/H) * A ..........
41221 130 DO 160 J = M, N
41222 FR = 0.0D0
41223 FI = 0.0D0
41224C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
41225 DO 140 II = M, IGH
41226 I = MP - II
41227 FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J)
41228 FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J)
41229 140 CONTINUE
41230C
41231 FR = FR / H
41232 FI = FI / H
41233C
41234 DO 150 I = M, IGH
41235 AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I)
41236 AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I)
41237 150 CONTINUE
41238C
41239 160 CONTINUE
41240C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
41241 DO 190 I = 1, IGH
41242 FR = 0.0D0
41243 FI = 0.0D0
41244C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
41245 DO 170 JJ = M, IGH
41246 J = MP - JJ
41247 FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J)
41248 FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J)
41249 170 CONTINUE
41250C
41251 FR = FR / H
41252 FI = FI / H
41253C
41254 DO 180 J = M, IGH
41255 AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J)
41256 AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J)
41257 180 CONTINUE
41258C
41259 190 CONTINUE
41260C
41261 ORTR(M) = SCALE * ORTR(M)
41262 ORTI(M) = SCALE * ORTI(M)
41263 AR(M,M-1) = -G * AR(M,M-1)
41264 AI(M,M-1) = -G * AI(M,M-1)
41265 200 CONTINUE
41266C
41267 210 RETURN
41268 END
41269
41270C*********************************************************************
41271
41272C...PYLDCM
41273C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
41274C...processes.
41275
41276 SUBROUTINE PYLDCM(A,N,NP,INDX,D)
41277 IMPLICIT NONE
41278 INTEGER N,NP,INDX(N)
41279 REAL*8 D,TINY
41280 COMPLEX*16 A(NP,NP)
41281 PARAMETER (TINY=1.0D-20)
41282 INTEGER I,IMAX,J,K
41283 REAL*8 AAMAX,VV(6),DUM
41284 COMPLEX*16 SUM,DUMC
41285
41286 D=1D0
41287 DO 110 I=1,N
41288 AAMAX=0D0
41289 DO 100 J=1,N
41290 IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
41291 100 CONTINUE
41292 IF (AAMAX.EQ.0D0) PAUSE 'SINGULAR MATRIX IN PYLDCM'
41293 VV(I)=1D0/AAMAX
41294 110 CONTINUE
41295 DO 180 J=1,N
41296 DO 130 I=1,J-1
41297 SUM=A(I,J)
41298 DO 120 K=1,I-1
41299 SUM=SUM-A(I,K)*A(K,J)
41300 120 CONTINUE
41301 A(I,J)=SUM
41302 130 CONTINUE
41303 AAMAX=0D0
41304 DO 150 I=J,N
41305 SUM=A(I,J)
41306 DO 140 K=1,J-1
41307 SUM=SUM-A(I,K)*A(K,J)
41308 140 CONTINUE
41309 A(I,J)=SUM
41310 DUM=VV(I)*ABS(SUM)
41311 IF (DUM.GE.AAMAX) THEN
41312 IMAX=I
41313 AAMAX=DUM
41314 ENDIF
41315 150 CONTINUE
41316 IF (J.NE.IMAX)THEN
41317 DO 160 K=1,N
41318 DUMC=A(IMAX,K)
41319 A(IMAX,K)=A(J,K)
41320 A(J,K)=DUMC
41321 160 CONTINUE
41322 D=-D
41323 VV(IMAX)=VV(J)
41324 ENDIF
41325 INDX(J)=IMAX
41326 IF(ABS(A(J,J)).EQ.0D0) A(J,J)=DCMPLX(TINY,0D0)
41327 IF(J.NE.N)THEN
41328 DO 170 I=J+1,N
41329 A(I,J)=A(I,J)/A(J,J)
41330 170 CONTINUE
41331 ENDIF
41332 180 CONTINUE
41333
41334 RETURN
41335 END
41336
41337C*********************************************************************
41338
41339C...PYBKSB
41340C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
41341C...processes.
41342
41343 SUBROUTINE PYBKSB(A,N,NP,INDX,B)
41344 IMPLICIT NONE
41345 INTEGER N,NP,INDX(N)
41346 COMPLEX*16 A(NP,NP),B(N)
41347 INTEGER I,II,J,LL
41348 COMPLEX*16 SUM
41349
41350 II=0
41351 DO 110 I=1,N
41352 LL=INDX(I)
41353 SUM=B(LL)
41354 B(LL)=B(I)
41355 IF (II.NE.0)THEN
41356 DO 100 J=II,I-1
41357 SUM=SUM-A(I,J)*B(J)
41358 100 CONTINUE
41359 ELSE IF (ABS(SUM).NE.0D0) THEN
41360 II=I
41361 ENDIF
41362 B(I)=SUM
41363 110 CONTINUE
41364 DO 130 I=N,1,-1
41365 SUM=B(I)
41366 DO 120 J=I+1,N
41367 SUM=SUM-A(I,J)*B(J)
41368 120 CONTINUE
41369 B(I)=SUM/A(I,I)
41370 130 CONTINUE
41371 RETURN
41372 END
41373
41374C***********************************************************************
41375
41376C...PYWIDX
41377C...Calculates full and partial widths of resonances.
41378C....copy of PYWIDT, used for techniparticle widths
41379
41380 SUBROUTINE PYWIDX(KFLR,SH,WDTP,WDTE)
41381
41382C...Double precision and integer declarations.
41383 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41384 IMPLICIT INTEGER(I-N)
41385 INTEGER PYK,PYCHGE,PYCOMP
41386C...Parameter statement to help give large particle numbers.
41387 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
41388 &KEXCIT=4000000,KDIMEN=5000000)
41389C...Commonblocks.
41390 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41391 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41392 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
41393 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
41394 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
41395 COMMON/PYINT1/MINT(400),VINT(400)
41396 COMMON/PYINT4/MWID(500),WIDS(500,5)
41397 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
41398 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
41399 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
41400 &/PYINT4/,/PYMSSM/,/PYTCSM/
41401C...Local arrays and saved variables.
41402 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
41403 &WID2SV(3,2)
41404 SAVE MOFSV,WIDWSV,WID2SV
41405 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
41406
41407C...Compressed code and sign; mass.
41408 KFLA=IABS(KFLR)
41409 KFLS=ISIGN(1,KFLR)
41410 KC=PYCOMP(KFLA)
41411 SHR=SQRT(SH)
41412 PMR=PMAS(KC,1)
41413
41414C...Reset width information.
41415 DO 110 I=0,200
41416 WDTP(I)=0D0
41417 DO 100 J=0,5
41418 WDTE(I,J)=0D0
41419 100 CONTINUE
41420 110 CONTINUE
41421
41422C...Common electroweak and strong constants.
41423 XW=PARU(102)
41424 XWV=XW
41425 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
41426 XW1=1D0-XW
41427 AEM=PYALEM(SH)
41428 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
41429 AS=PYALPS(SH)
41430 RADC=1D0+AS/PARU(1)
41431
41432 IF(KFLA.EQ.23) THEN
41433C...Z0:
41434 ICASE=1
41435 XWC=1D0/(16D0*XW*XW1)
41436 FAC=(AEM*XWC/3D0)*SHR
41437 120 CONTINUE
41438 DO 130 I=1,MDCY(KC,3)
41439 IDC=I+MDCY(KC,2)-1
41440 IF(MDME(IDC,1).LT.0) GOTO 130
41441 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
41442 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
41443 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130
41444 WID2=1D0
41445 IF(I.LE.8) THEN
41446C...Z0 -> q + qbar
41447 EF=KCHG(I,1)/3D0
41448 AF=SIGN(1D0,EF+0.1D0)
41449 VF=AF-4D0*EF*XWV
41450 FCOF=3D0*RADC
41451 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
41452 IF(I.EQ.6) WID2=WIDS(6,1)
41453 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
41454 ELSEIF(I.LE.16) THEN
41455C...Z0 -> l+ + l-, nu + nubar
41456 EF=KCHG(I+2,1)/3D0
41457 AF=SIGN(1D0,EF+0.1D0)
41458 VF=AF-4D0*EF*XWV
41459 FCOF=1D0
41460 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
41461 ENDIF
41462 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
41463 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
41464 & BE34
41465 WDTP(0)=WDTP(0)+WDTP(I)
41466 IF(MDME(IDC,1).GT.0) THEN
41467 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
41468 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
41469 & WDTE(I,MDME(IDC,1))
41470 WDTE(I,0)=WDTE(I,MDME(IDC,1))
41471 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
41472 ENDIF
41473 130 CONTINUE
41474
41475
41476 ELSEIF(KFLA.EQ.24) THEN
41477C...W+/-:
41478 FAC=(AEM/(24D0*XW))*SHR
41479 DO 140 I=1,MDCY(KC,3)
41480 IDC=I+MDCY(KC,2)-1
41481 IF(MDME(IDC,1).LT.0) GOTO 140
41482 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
41483 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
41484 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
41485 WID2=1D0
41486 IF(I.LE.16) THEN
41487C...W+/- -> q + qbar'
41488 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
41489 IF(KFLR.GT.0) THEN
41490 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
41491 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
41492 IF(I.GE.13) WID2=WID2*WIDS(7,3)
41493 ELSE
41494 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
41495 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
41496 IF(I.GE.13) WID2=WID2*WIDS(7,2)
41497 ENDIF
41498 ELSEIF(I.LE.20) THEN
41499C...W+/- -> l+/- + nu
41500 FCOF=1D0
41501 IF(KFLR.GT.0) THEN
41502 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
41503 ELSE
41504 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
41505 ENDIF
41506 ENDIF
41507 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
41508 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
41509 WDTP(0)=WDTP(0)+WDTP(I)
41510 IF(MDME(IDC,1).GT.0) THEN
41511 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
41512 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
41513 WDTE(I,0)=WDTE(I,MDME(IDC,1))
41514 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
41515 ENDIF
41516 140 CONTINUE
41517
41518C.....V8 -> quark anti-quark
41519 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
41520 FAC=AS/6D0*SHR
41521 TANT3=RTCM(21)
41522 IF(ITCM(2).EQ.0) THEN
41523 IMDL=1
41524 ELSEIF(ITCM(2).EQ.1) THEN
41525 IMDL=2
41526 ENDIF
41527 DO 150 I=1,MDCY(KC,3)
41528 IDC=I+MDCY(KC,2)-1
41529 IF(MDME(IDC,1).LT.0) GOTO 150
41530 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
41531 RM1=PM1**2/SH
41532 IF(RM1.GT.0.25D0) GOTO 150
41533 WID2=1D0
41534 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
41535 FMIX=1D0/TANT3**2
41536 ELSE
41537 FMIX=TANT3**2
41538 ENDIF
41539 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
41540 IF(I.EQ.6) WID2=WIDS(6,1)
41541 WDTP(0)=WDTP(0)+WDTP(I)
41542 IF(MDME(IDC,1).GT.0) THEN
41543 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
41544 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
41545 WDTE(I,0)=WDTE(I,MDME(IDC,1))
41546 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
41547 ENDIF
41548 150 CONTINUE
41549 ENDIF
41550
41551 RETURN
41552 END
41553
41554C*********************************************************************
41555
41556C...PYRVSF
41557C...Calculates R-violating decays of sfermions.
41558C...P. Z. Skands
41559
41560 SUBROUTINE PYRVSF(KFIN,XLAM,IDLAM,LKNT)
41561
41562C...Double precision and integer declarations.
41563 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41564 IMPLICIT INTEGER(I-N)
41565C...Parameter statement to help give large particle numbers.
41566 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
41567 &KEXCIT=4000000,KDIMEN=5000000)
41568C...Commonblocks.
41569 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41570 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
41571 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
41572 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
41573 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
41574C...Local variables.
41575 DOUBLE PRECISION XLAM(0:400)
41576 INTEGER IDLAM(400,3), PYCOMP
41577 SAVE /PYMSRV/,/PYSSMT/,/PYMSSM/,/PYDAT2/
41578
41579C...IS R-VIOLATION ON ?
41580 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
41581C...Mass eigenstate counter
41582 ICNT=INT(KFIN/KSUSY1)
41583C...SM KF code of SUSY particle
41584 KFSM=KFIN-ICNT*KSUSY1
41585C...Squared Sparticle Mass
41586 SM=PMAS(PYCOMP(KFIN),1)**2
41587C... Squared mass of top quark
41588 SMT=PMAS(PYCOMP(6),1)**2
41589C...IS L-VIOLATION ON ?
41590 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1)) THEN
41591C...SLEPTON -> NU(BAR) + LEPTON and UBAR + D
41592 IF(ICNT.NE.0.AND.(KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15))
41593 & THEN
41594 K=INT((KFSM-9)/2)
41595 DO 110 I=1,3
41596 DO 100 J=1,3
41597 IF(I.NE.J) THEN
41598C...~e,~mu,~tau -> nu_I + lepton-_J
41599 LKNT = LKNT+1
41600 IDLAM(LKNT,1)= 12 +2*(I-1)
41601 IDLAM(LKNT,2)= 11 +2*(J-1)
41602 IDLAM(LKNT,3)= 0
41603 XLAM(LKNT)=0D0
41604 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
41605 IF (IMSS(51).NE.0) XLAM(LKNT) =
41606 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41607C...KINEMATICS CHECK
41608 IF (XLAM(LKNT).EQ.0D0) THEN
41609 LKNT=LKNT-1
41610 ENDIF
41611 ENDIF
41612 100 CONTINUE
41613 110 CONTINUE
41614C...~e,~mu,~tau -> nu_Ibar + lepton-_K
41615 J=INT((KFSM-9)/2)
41616 DO 130 I=1,3
41617 IF(I.NE.J) THEN
41618 DO 120 K=1,3
41619 LKNT = LKNT+1
41620 IDLAM(LKNT,1)=-12 -2*(I-1)
41621 IDLAM(LKNT,2)= 11 +2*(K-1)
41622 IDLAM(LKNT,3)= 0
41623 XLAM(LKNT)=0D0
41624 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
41625 IF (IMSS(51).NE.0) XLAM(LKNT) =
41626 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41627C...KINEMATICS CHECK
41628 IF (XLAM(LKNT).EQ.0D0) THEN
41629 LKNT=LKNT-1
41630 ENDIF
41631 120 CONTINUE
41632 ENDIF
41633 130 CONTINUE
41634C...~e,~mu,~tau -> u_Jbar + d_K
41635 I=INT((KFSM-9)/2)
41636 DO 150 J=1,3
41637 DO 140 K=1,3
41638 LKNT = LKNT+1
41639 IDLAM(LKNT,1)=-2 -2*(J-1)
41640 IDLAM(LKNT,2)= 1 +2*(K-1)
41641 IDLAM(LKNT,3)= 0
41642 XLAM(LKNT)=0
41643 IF (IMSS(52).NE.0) THEN
41644C...Use massive top quark
41645 IF (IDLAM(LKNT,1).EQ.-6) THEN
41646 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2
41647 & * (SM-SMT)
41648 XLAM(LKNT) =
41649 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
41650C...If no top quark, all decay products massless
41651 ELSE
41652 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
41653 XLAM(LKNT) =
41654 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41655 ENDIF
41656C...KINEMATICS CHECK
41657 IF (XLAM(LKNT).EQ.0D0) THEN
41658 LKNT=LKNT-1
41659 ENDIF
41660 ENDIF
41661 140 CONTINUE
41662 150 CONTINUE
41663 ENDIF
41664C * SNEUTRINO -> LEPTON+ + LEPTON- and DBAR + D
41665C...No right-handed neutrinos
41666 IF(ICNT.EQ.1) THEN
41667 IF(KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16) THEN
41668 J=INT((KFSM-10)/2)
41669 DO 170 I=1,3
41670 DO 160 K=1,3
41671 IF (I.NE.J) THEN
41672C...~nu_J -> lepton+_I + lepton-_K
41673 LKNT = LKNT+1
41674 IDLAM(LKNT,1)=-11 -2*(I-1)
41675 IDLAM(LKNT,2)= 11 +2*(K-1)
41676 IDLAM(LKNT,3)= 0
41677 XLAM(LKNT)=0D0
41678 RM2=RVLAM(I,J,K)**2 * SM
41679 IF (IMSS(51).NE.0) XLAM(LKNT) =
41680 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41681C...KINEMATICS CHECK
41682 IF (XLAM(LKNT).EQ.0D0) THEN
41683 LKNT=LKNT-1
41684 ENDIF
41685 ENDIF
41686 160 CONTINUE
41687 170 CONTINUE
41688C...~nu_I -> dbar_J + d_K
41689 I=INT((KFSM-10)/2)
41690 DO 190 J=1,3
41691 DO 180 K=1,3
41692 LKNT = LKNT+1
41693 IDLAM(LKNT,1)=-1 -2*(J-1)
41694 IDLAM(LKNT,2)= 1 +2*(K-1)
41695 IDLAM(LKNT,3)= 0
41696 XLAM(LKNT)=0D0
41697 RM2=3*RVLAMP(I,J,K)**2 * SM
41698 IF (IMSS(52).NE.0) XLAM(LKNT) =
41699 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41700C...KINEMATICS CHECK
41701 IF (XLAM(LKNT).EQ.0D0) THEN
41702 LKNT=LKNT-1
41703 ENDIF
41704 180 CONTINUE
41705 190 CONTINUE
41706 ENDIF
41707 ENDIF
41708C * SDOWN -> NU(BAR) + D and LEPTON- + U
41709 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
41710 J=INT((KFSM+1)/2)
41711 DO 210 I=1,3
41712 DO 200 K=1,3
41713C...~d_J -> nu_Ibar + d_K
41714 LKNT = LKNT+1
41715 IDLAM(LKNT,1)=-12 -2*(I-1)
41716 IDLAM(LKNT,2)= 1 +2*(K-1)
41717 IDLAM(LKNT,3)= 0
41718 XLAM(LKNT)=0D0
41719 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
41720 IF (IMSS(52).NE.0) XLAM(LKNT) =
41721 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41722C...KINEMATICS CHECK
41723 IF (XLAM(LKNT).EQ.0D0) THEN
41724 LKNT=LKNT-1
41725 ENDIF
41726 200 CONTINUE
41727 210 CONTINUE
41728 K=INT((KFSM+1)/2)
41729 DO 240 I=1,3
41730 DO 230 J=1,3
41731C...~d_K -> nu_I + d_J
41732 LKNT = LKNT+1
41733 IDLAM(LKNT,1)= 12 +2*(I-1)
41734 IDLAM(LKNT,2)= 1 +2*(J-1)
41735 IDLAM(LKNT,3)= 0
41736 XLAM(LKNT)=0D0
41737 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
41738 IF (IMSS(52).NE.0) XLAM(LKNT) =
41739 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41740C...KINEMATICS CHECK
41741 IF (XLAM(LKNT).EQ.0D0) THEN
41742 LKNT=LKNT-1
41743 ENDIF
41744C...~d_K -> lepton_I- + u_J
41745 220 LKNT = LKNT+1
41746 IDLAM(LKNT,1)= 11 +2*(I-1)
41747 IDLAM(LKNT,2)= 2 +2*(J-1)
41748 IDLAM(LKNT,3)= 0
41749 XLAM(LKNT)=0D0
41750 IF (IMSS(52).NE.0) THEN
41751C...Use massive top quark
41752 IF (IDLAM(LKNT,2).EQ.6) THEN
41753 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT)
41754 XLAM(LKNT) =
41755 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,2)
41756C...If no top quark, all decay products massless
41757 ELSE
41758 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
41759 XLAM(LKNT) =
41760 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41761 ENDIF
41762C...KINEMATICS CHECK
41763 IF (XLAM(LKNT).EQ.0D0) THEN
41764 LKNT=LKNT-1
41765 ENDIF
41766 ENDIF
41767 230 CONTINUE
41768 240 CONTINUE
41769 ENDIF
41770C * SUP -> LEPTON+ + D
41771 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
41772 J=NINT(KFSM/2.)
41773 DO 260 I=1,3
41774 DO 250 K=1,3
41775C...~u_J -> lepton_I+ + d_K
41776 LKNT = LKNT+1
41777 IDLAM(LKNT,1)=-11 -2*(I-1)
41778 IDLAM(LKNT,2)= 1 +2*(K-1)
41779 IDLAM(LKNT,3)= 0
41780 XLAM(LKNT)=0D0
41781 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
41782 IF (IMSS(52).NE.0) XLAM(LKNT) =
41783 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41784C...KINEMATICS CHECK
41785 IF (XLAM(LKNT).EQ.0D0) THEN
41786 LKNT=LKNT-1
41787 ENDIF
41788 250 CONTINUE
41789 260 CONTINUE
41790 ENDIF
41791 ENDIF
41792C...BARYON NUMBER VIOLATING DECAYS
41793 IF (IMSS(53).GE.1) THEN
41794C * SUP -> DBAR + DBAR
41795 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
41796 I = KFSM/2
41797 DO 280 J=1,3
41798 DO 270 K=1,3
41799C...~u_I -> dbar_J + dbar_K
41800 IF (J.LT.K) THEN
41801C...(anti-) symmetry J <-> K.
41802 LKNT = LKNT + 1
41803 IDLAM(LKNT,1) = -1 -2*(J-1)
41804 IDLAM(LKNT,2) = -1 -2*(K-1)
41805 IDLAM(LKNT,3) = 0
41806 XLAM(LKNT) = 0D0
41807 RM2 = 2.*(RVLAMB(I,J,K)**2)
41808 & * SFMIX(KFSM,2*ICNT)**2 * SM
41809 XLAM(LKNT) =
41810 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41811C...KINEMATICS CHECK
41812 IF (XLAM(LKNT).EQ.0D0) THEN
41813 LKNT = LKNT-1
41814 ENDIF
41815 ENDIF
41816 270 CONTINUE
41817 280 CONTINUE
41818 ENDIF
41819C * SDOWN -> UBAR + DBAR
41820 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
41821 K=(KFSM+1)/2
41822 DO 300 I=1,3
41823 DO 290 J=1,3
41824C...LAMB coupling antisymmetric in J and K.
41825 IF (J.NE.K) THEN
41826C...~d_K -> ubar_I + dbar_K
41827 LKNT = LKNT + 1
41828 IDLAM(LKNT,1)= -2 -2*(I-1)
41829 IDLAM(LKNT,2)= -1 -2*(J-1)
41830 IDLAM(LKNT,3)= 0
41831 XLAM(LKNT)=0D0
41832C...Use massive top quark
41833 IF (IDLAM(LKNT,1).EQ.-6) THEN
41834 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT
41835 & )
41836 XLAM(LKNT) =
41837 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
41838C...If no top quark, all decay products massless
41839 ELSE
41840 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
41841 XLAM(LKNT) =
41842 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41843 ENDIF
41844C...KINEMATICS CHECK
41845 IF (XLAM(LKNT).EQ.0D0) THEN
41846 LKNT=LKNT-1
41847 ENDIF
41848 ENDIF
41849 290 CONTINUE
41850 300 CONTINUE
41851 ENDIF
41852 ENDIF
41853 ENDIF
41854
41855 RETURN
41856 END
41857
41858C*********************************************************************
41859
41860C...PYRVNE
41861C...Calculates R-violating neutralino decay widths (pure 1->3 parts).
41862C...P. Z. Skands
41863
41864 SUBROUTINE PYRVNE(KFIN,XLAM,IDLAM,LKNT)
41865
41866C...Double precision and integer declarations.
41867 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41868 IMPLICIT INTEGER(I-N)
41869C...Parameter statement to help give large particle numbers.
41870 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
41871 &KEXCIT=4000000,KDIMEN=5000000)
41872C...Commonblocks.
41873 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41874 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41875 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
41876 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
41877 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
41878 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
41879C...Local variables.
41880 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
41881 & ,DCMASS,KFR(3)
41882 DOUBLE PRECISION XLAM(0:400)
41883 DOUBLE PRECISION ZPMIX(4,4), NMIX(4,4), RMQ(6)
41884 INTEGER IDLAM(400,3), PYCOMP
41885 LOGICAL DCMASS
41886 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/
41887
41888C...R-VIOLATING DECAYS
41889 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
41890 KFSM=KFIN-KSUSY1
41891 IF(KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
41892C...WHICH NEUTRALINO ?
41893 NCHI=1
41894 IF (KFSM.EQ.23) NCHI=2
41895 IF (KFSM.EQ.25) NCHI=3
41896 IF (KFSM.EQ.35) NCHI=4
41897C...SIGN OF MASS (Opposite convention as HERWIG)
41898 ISM = 1
41899 IF (SMZ(NCHI).LT.0D0) ISM = -ISM
41900
41901C...Useful parameters for the calculation of the A and B constants.
41902 WMASS = PMAS(PYCOMP(24),1)
41903 ECHG = 2*SQRT(PARU(103)*PARU(1))
41904 COSB=1/(SQRT(1+RMSS(5)**2))
41905 SINB=RMSS(5)/SQRT(1+RMSS(5)**2)
41906 COSW=SQRT(1-PARU(102))
41907 SINW=SQRT(PARU(102))
41908 GW=2D0*SQRT(PARU(103)*PARU(1))/SINW
41909C...Run quark masses to neutralino mass squared (for Higgs-type
41910C...couplings)
41911 SQMCHI=PMAS(PYCOMP(KFIN),1)**2
41912 DO 100 I=1,6
41913 RMQ(I)=PYMRUN(I,SQMCHI)
41914 100 CONTINUE
41915C...EXPRESS NEUTRALINO MIXING IN (photino,Zino,~H_u,~H_d) BASIS
41916 DO 110 NCHJ=1,4
41917 ZPMIX(NCHJ,1)= ZMIX(NCHJ,1)*COSW+ZMIX(NCHJ,2)*SINW
41918 ZPMIX(NCHJ,2)=-ZMIX(NCHJ,1)*SINW+ZMIX(NCHJ,2)*COSW
41919 ZPMIX(NCHJ,3)= ZMIX(NCHJ,3)
41920 ZPMIX(NCHJ,4)= ZMIX(NCHJ,4)
41921 110 CONTINUE
41922 C1=GW*ZPMIX(NCHI,3)/(2D0*COSB*WMASS)
41923 C1U=GW*ZPMIX(NCHI,4)/(2D0*SINB*WMASS)
41924 C2=ECHG*ZPMIX(NCHI,1)
41925 C3=GW*ZPMIX(NCHI,2)/COSW
41926 EU=2D0/3D0
41927 ED=-1D0/3D0
41928C... AB(x,y,z):
41929C x=1-2 : Select A or B constant (1:A ; 2:B)
41930C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
41931C 11-16:e,nu_e,mu,...)
41932C z=1-2 : Mass eigenstate number
41933C...CALCULATE COUPLINGS
41934 DO 120 I = 11,15,2
41935 CMS=PMAS(PYCOMP(I),1)
41936C...Intermediate sleptons
41937 AB(1,I,1)=ISM*(CMS*C1*SFMIX(I,1) + SFMIX(I,2)
41938 & *(C2-C3*SINW**2))
41939 AB(1,I,2)=ISM*(CMS*C1*SFMIX(I,3) + SFMIX(I,4)
41940 & *(C2-C3*SINW**2))
41941 AB(2,I,1)= CMS*C1*SFMIX(I,2) - SFMIX(I,1)*(C2+C3*(5D-1-SINW
41942 & **2))
41943 AB(2,I,2)=CMS*C1*SFMIX(I,4) - SFMIX(I,3)*(C2+C3*(5D-1-SINW
41944 & **2))
41945C...Inermediate sneutrinos
41946 AB(1,I+1,1)=0D0
41947 AB(2,I+1,1)=5D-1*C3
41948 AB(1,I+1,2)=0D0
41949 AB(2,I+1,2)=0D0
41950C...Inermediate sdown
41951 J=I-10
41952 CMS=RMQ(J)
41953 AB(1,J,1)=ISM*(CMS*C1*SFMIX(J,1) - SFMIX(J,2)
41954 & *ED*(C2-C3*SINW**2))
41955 AB(1,J,2)=ISM*(CMS*C1*SFMIX(J,3) - SFMIX(J,4)
41956 & *ED*(C2-C3*SINW**2))
41957 AB(2,J,1)=CMS*C1*SFMIX(J,2) + SFMIX(J,1)
41958 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
41959 AB(2,J,2)=CMS*C1*SFMIX(J,4) + SFMIX(J,3)
41960 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
41961C...Inermediate sup
41962 J=J+1
41963 CMS=RMQ(J)
41964 AB(1,J,1)=ISM*(CMS*C1U*SFMIX(J,1) - SFMIX(J,2)
41965 & *EU*(C2-C3*SINW**2))
41966 AB(1,J,2)=ISM*(CMS*C1U*SFMIX(J,3) - SFMIX(J,4)
41967 & *EU*(C2-C3*SINW**2))
41968 AB(2,J,1)=CMS*C1U*SFMIX(J,2) + SFMIX(J,1)
41969 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
41970 AB(2,J,2)=CMS*C1U*SFMIX(J,4) + SFMIX(J,3)
41971 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
41972 120 CONTINUE
41973
41974 IF (IMSS(51).GE.1) THEN
41975C...LAMBDA COUPLINGS (LLE TYPE R-VIOLATION)
41976C * CHI0_I -> NUBAR_I + LEPTON+_J + lEPTON-_K.
41977C...STEP IN I,J,K USING SINGLE COUNTER
41978 DO 130 ISC=0,26
41979C...LAMBDA COUPLING ASYM IN I,J
41980 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
41981 LKNT = LKNT+1
41982 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
41983 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
41984 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
41985 XLAM(LKNT) = 0D0
41986C...Set coupling, and decay product masses on/off
41987 RVLAMC = RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
41988 & ,MOD(ISC,3)+1)**2
41989 DCMASS=.FALSE.
41990 IF (IDLAM(LKNT,2).EQ.-15.OR.IDLAM(LKNT,3).EQ.15)
41991 & DCMASS = .TRUE.
41992C...Resonance KF codes (1=I,2=J,3=K)
41993 KFR(1)=-IDLAM(LKNT,1)
41994 KFR(2)=-IDLAM(LKNT,2)
41995 KFR(3)=-IDLAM(LKNT,3)
41996C...Calculate width.
41997 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
41998 & IDLAM(LKNT,3),XLAM(LKNT))
41999 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42000C...Charge conjugate mode.
42001 LKNT=LKNT+1
42002 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
42003 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
42004 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
42005 XLAM(LKNT)=XLAM(LKNT-1)
42006C...KINEMATICS CHECK
42007 IF (XLAM(LKNT).EQ.0D0) THEN
42008 LKNT=LKNT-2
42009 ENDIF
42010 ENDIF
42011 130 CONTINUE
42012 ENDIF
42013
42014 IF (IMSS(52).GE.1) THEN
42015C...LAMBDA' COUPLINGS. (LQD TYPE R-VIOLATION)
42016C * CHI0 -> NUBAR_I + DBAR_J + D_K
42017 DO 140 ISC=0,26
42018 LKNT = LKNT+1
42019 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
42020 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
42021 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
42022 XLAM(LKNT) = 0D0
42023C...Set coupling, and decay product masses on/off
42024 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
42025 & ,MOD(ISC,3)+1)**2
42026 DCMASS=.FALSE.
42027 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5)
42028 & DCMASS = .TRUE.
42029C...Resonance KF codes (1=I,2=J,3=K)
42030 KFR(1)=-IDLAM(LKNT,1)
42031 KFR(2)=-IDLAM(LKNT,2)
42032 KFR(3)=-IDLAM(LKNT,3)
42033C...Calculate width.
42034 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42035 & ,XLAM(LKNT))
42036 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42037C...Charge conjugate mode.
42038 LKNT=LKNT+1
42039 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
42040 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
42041 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
42042 XLAM(LKNT)=XLAM(LKNT-1)
42043C...KINEMATICS CHECK
42044 IF (XLAM(LKNT).EQ.0D0) THEN
42045 LKNT=LKNT-2
42046 ENDIF
42047
42048C * CHI0 -> LEPTON_I+ + UBAR_J + D_K
42049 LKNT = LKNT+1
42050 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
42051 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
42052 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
42053 XLAM(LKNT) = 0D0
42054C...Set coupling, and decay product masses on/off
42055 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
42056 & ,MOD(ISC,3)+1)**2
42057 DCMASS=.FALSE.
42058 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
42059 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
42060C...Resonance KF codes (1=I,2=J,3=K)
42061 KFR(1)=-IDLAM(LKNT,1)
42062 KFR(2)=-IDLAM(LKNT,2)
42063 KFR(3)=-IDLAM(LKNT,3)
42064C...Calculate width.
42065 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42066 & ,XLAM(LKNT))
42067 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42068C...Charge conjugate mode.
42069 LKNT=LKNT+1
42070 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
42071 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
42072 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
42073 XLAM(LKNT)=XLAM(LKNT-1)
42074C...KINEMATICS CHECK
42075 IF (XLAM(LKNT).EQ.0D0) THEN
42076 LKNT=LKNT-2
42077 ENDIF
42078 140 CONTINUE
42079 ENDIF
42080
42081 IF (IMSS(53).GE.1) THEN
42082C...LAMBDA'' COUPLINGS. (UDD TYPE R-VIOLATION)
42083C * CHI0 -> UBAR_I + DBAR_J + DBAR_K
42084 DO 150 ISC=0,26
42085C...Symmetry J<->K. Also, LAMB antisymmetric in J and K, so no J=K.
42086 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
42087 LKNT = LKNT+1
42088 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
42089 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
42090 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
42091 XLAM(LKNT) = 0D0
42092C...Set coupling, and decay product masses on/off
42093 RVLAMC = 6. * RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)
42094 & +1,MOD(ISC,3)+1)**2
42095 DCMASS=.FALSE.
42096 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
42097 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
42098C...Resonance KF codes (1=I,2=J,3=K)
42099 KFR(1) = IDLAM(LKNT,1)
42100 KFR(2) = IDLAM(LKNT,2)
42101 KFR(3) = IDLAM(LKNT,3)
42102C...Calculate width.
42103 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42104 & IDLAM(LKNT,3),XLAM(LKNT))
42105 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42106C...Charge conjugate mode.
42107 LKNT=LKNT+1
42108 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
42109 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
42110 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
42111 XLAM(LKNT)=XLAM(LKNT-1)
42112C...KINEMATICS CHECK
42113 IF (XLAM(LKNT).EQ.0D0) THEN
42114 LKNT=LKNT-2
42115 ENDIF
42116 ENDIF
42117 150 CONTINUE
42118 ENDIF
42119 ENDIF
42120 ENDIF
42121
42122 RETURN
42123 END
42124
42125C*********************************************************************
42126
42127C...PYRVCH
42128C...Calculates R-violating chargino decay widths.
42129C...P. Z. Skands
42130
42131 SUBROUTINE PYRVCH(KFIN,XLAM,IDLAM,LKNT)
42132
42133C...Double precision and integer declarations.
42134 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42135 IMPLICIT INTEGER(I-N)
42136C...Parameter statement to help give large particle numbers.
42137 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
42138 &KEXCIT=4000000,KDIMEN=5000000)
42139C...Commonblocks.
42140 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42141 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42142 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
42143 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
42144 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
42145 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
42146C...Local variables.
42147 DOUBLE PRECISION XLAM(0:400)
42148 INTEGER IDLAM(400,3), PYCOMP
42149C...Information from main routine to PYRVGW
42150 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
42151 & ,DCMASS,KFR(3)
42152C...Auxiliary variables needed for BV (RV Gauge STOre)
42153 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
42154 & ,RVLJKI,RVLJIK
42155C...Running quark masses
42156 DOUBLE PRECISION RMQ(6)
42157C...Decay product masses on/off
42158 LOGICAL DCMASS
42159 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
42160 & /RVGSTO/
42161
42162
42163C...IF R-VIOLATION ON.
42164 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
42165 KFSM=KFIN-KSUSY1
42166 IF(KFSM.EQ.24.OR.KFSM.EQ.37) THEN
42167C...WHICH CHARGINO ?
42168 NCHI = 1
42169 IF (KFSM.EQ.37) NCHI = 2
42170
42171C...Useful parameters for calculating the A and B constants.
42172C...SIGN OF MASS (Opposite convention as HERWIG)
42173 ISM = 1
42174 IF (SMW(NCHI).LT.0D0) ISM = -1
42175 WMASS = PMAS(PYCOMP(24),1)
42176 COSB = 1/(SQRT(1+RMSS(5)**2))
42177 SINB = RMSS(5)/SQRT(1+RMSS(5)**2)
42178 GW2 = 4*PARU(103)*PARU(1)/PARU(102)
42179 C1U = UMIX(NCHI,2)/(SQRT(2D0)*COSB*WMASS)
42180 C1V = VMIX(NCHI,2)/(SQRT(2D0)*SINB*WMASS)
42181 C2 = UMIX(NCHI,1)
42182 C3 = VMIX(NCHI,1)
42183C...Running masses at Q^2=MCHI^2.
42184 SQMCHI = PMAS(PYCOMP(KFSM),1)**2
42185 DO 100 I=1,6
42186 RMQ(I)=PYMRUN(I,SQMCHI)
42187 100 CONTINUE
42188
42189C... AB(x,y,z) coefficients:
42190C x=1-2 : A or B coefficient (1:A ; 2:B)
42191C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
42192C 11-16:e,nu_e,mu,...)
42193C z=1-2 : Mass eigenstate number
42194 DO 110 I = 11,15,2
42195C...Intermediate sleptons
42196 AB(1,I,1) = 0D0
42197 AB(1,I,2) = 0D0
42198 AB(2,I,1) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,2) +
42199 & SFMIX(I,1)*C2
42200 AB(2,I,2) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,4) +
42201 & SFMIX(I,3)*C2
42202C...Intermediate sneutrinos
42203 AB(1,I+1,1) = -PMAS(PYCOMP(I),1)*C1U
42204 AB(1,I+1,2) = 0D0
42205 AB(2,I+1,1) = ISM*C3
42206 AB(2,I+1,2) = 0D0
42207C...Intermediate sdown
42208 J=I-10
42209 AB(1,J,1) = -RMQ(J+1)*C1V*SFMIX(J,1)
42210 AB(1,J,2) = -RMQ(J+1)*C1V*SFMIX(J,3)
42211 AB(2,J,1) = -ISM*(RMQ(J)*C1U*SFMIX(J,2) - SFMIX(J,1)*C2)
42212 AB(2,J,2) = -ISM*(RMQ(J)*C1U*SFMIX(J,4) - SFMIX(J,3)*C2)
42213C...Intermediate sup
42214 J=J+1
42215 AB(1,J,1) = -RMQ(J-1)*C1U*SFMIX(J,1)
42216 AB(1,J,2) = -RMQ(J-1)*C1U*SFMIX(J,3)
42217 AB(2,J,1) = -ISM*(RMQ(J)*C1V*SFMIX(J,2) - SFMIX(J,1)*C3)
42218 AB(2,J,2) = -ISM*(RMQ(J)*C1V*SFMIX(J,4) - SFMIX(J,3)*C3)
42219 110 CONTINUE
42220
42221C...LLE TYPE R-VIOLATION
42222 IF (IMSS(51).GE.1) THEN
42223C...LOOP OVER DECAY MODES
42224 DO 140 ISC=0,26
42225
42226C...CHI+ -> NUBAR_I + LEPTON+_J + NU_K.
42227 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
42228 LKNT = LKNT+1
42229 IDLAM(LKNT,1) = -12 -2*MOD(ISC/9,3)
42230 IDLAM(LKNT,2) = -11 -2*MOD(ISC/3,3)
42231 IDLAM(LKNT,3) = 12 +2*MOD(ISC,3)
42232 XLAM(LKNT) = 0D0
42233C...Set coupling, and decay product masses on/off
42234 RVLAMC = GW2 * 5D-1 *
42235 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
42236 & **2
42237 DCMASS=.FALSE.
42238 IF (IDLAM(LKNT,2).EQ.-15) DCMASS = .TRUE.
42239C...Resonance KF codes (1=I,2=J,3=K).
42240 KFR(1) = 0
42241 KFR(2) = 0
42242 KFR(3) = -IDLAM(LKNT,3)+1
42243C...Calculate width.
42244 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42245 & IDLAM(LKNT,3),XLAM(LKNT))
42246 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42247C...KINEMATICS CHECK
42248 IF (XLAM(LKNT).EQ.0D0) THEN
42249 LKNT=LKNT-1
42250 ENDIF
42251
42252C * CHI+ -> NU_I + NU_J + LEPTON+_K. (NOTE: SYMM. IN I AND J)
42253 120 IF (MOD(ISC/9,3).LT.MOD(ISC/3,3)) THEN
42254 LKNT = LKNT+1
42255 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
42256 IDLAM(LKNT,2) = 12 +2*MOD(ISC/3,3)
42257 IDLAM(LKNT,3) =-11 -2*MOD(ISC,3)
42258 XLAM(LKNT) = 0D0
42259C...Set coupling, and decay product masses on/off
42260 RVLAMC = GW2 * 5D-1 *
42261 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
42262C...I,J SYMMETRY => FACTOR 2
42263 RVLAMC=2*RVLAMC
42264 DCMASS=.FALSE.
42265 IF (IDLAM(LKNT,3).EQ.-15) DCMASS = .TRUE.
42266C...Resonance KF codes (1=I,2=J,3=K)
42267 KFR(1)=IDLAM(LKNT,1)-1
42268 KFR(2)=IDLAM(LKNT,2)-1
42269 KFR(3)=0
42270C...Calculate width.
42271 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42272 & IDLAM(LKNT,3),XLAM(LKNT))
42273 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42274C...KINEMATICS CHECK
42275 IF (XLAM(LKNT).EQ.0D0) THEN
42276 LKNT=LKNT-1
42277 ENDIF
42278 130 ENDIF
42279
42280C * CHI+ -> LEPTON+_I + LEPTON+_J + LEPTON-_K
42281 LKNT = LKNT+1
42282 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
42283 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
42284 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
42285 XLAM(LKNT) = 0D0
42286C...Set coupling, and decay product masses on/off
42287 RVLAMC = GW2 * 5D-1 *
42288 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
42289C...I,J SYMMETRY => FACTOR 2
42290 RVLAMC=2*RVLAMC
42291 DCMASS=.FALSE.
42292 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-15
42293 & .OR.IDLAM(LKNT,3).EQ.15) DCMASS = .TRUE.
42294C...Resonance KF codes (1=I,2=J,3=K)
42295 KFR(1) =-IDLAM(LKNT,1)+1
42296 KFR(2) =-IDLAM(LKNT,2)+1
42297 KFR(3) = 0
42298C...Calculate width.
42299 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42300 & IDLAM(LKNT,3),XLAM(LKNT))
42301 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42302C...KINEMATICS CHECK
42303 IF (XLAM(LKNT).EQ.0D0) THEN
42304 LKNT=LKNT-1
42305 ENDIF
42306 ENDIF
42307 140 CONTINUE
42308 ENDIF
42309
42310C...LQD TYPE R-VIOLATION
42311 IF (IMSS(52).GE.1) THEN
42312C...LOOP OVER DECAY MODES
42313 DO 180 ISC=0,26
42314
42315C...CHI+ -> NUBAR_I + DBAR_J + U_K
42316 LKNT = LKNT+1
42317 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
42318 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
42319 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
42320 XLAM(LKNT) = 0D0
42321C...Set coupling, and decay product masses on/off
42322 RVLAMC = 3. * GW2 * 5D-1 *
42323 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
42324 DCMASS=.FALSE.
42325 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.6)
42326 & DCMASS = .TRUE.
42327C...Resonance KF codes (1=I,2=J,3=K)
42328 KFR(1)=0
42329 KFR(2)=0
42330 KFR(3)=-IDLAM(LKNT,3)+1
42331C...Calculate width.
42332 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42333 & ,XLAM(LKNT))
42334 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42335C...KINEMATICS CHECK
42336 IF (XLAM(LKNT).EQ.0D0) THEN
42337 LKNT=LKNT-1
42338 ENDIF
42339
42340C * CHI+ -> LEPTON+_I + UBAR_J + U_K.
42341 150 LKNT = LKNT+1
42342 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
42343 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
42344 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
42345 XLAM(LKNT) = 0D0
42346C...Set coupling, and decay product masses on/off
42347 RVLAMC = 3. * GW2 * 5D-1 *
42348 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
42349 DCMASS=.FALSE.
42350 IF (IDLAM(LKNT,1).EQ.-11.OR.IDLAM(LKNT,2).EQ.-6
42351 & .OR.IDLAM(LKNT,3).EQ.6) DCMASS = .TRUE.
42352C...Resonance KF codes (1=I,2=J,3=K)
42353 KFR(1)=0
42354 KFR(2)=0
42355 KFR(3)=-IDLAM(LKNT,3)+1
42356C...Calculate width.
42357 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42358 & ,XLAM(LKNT))
42359 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42360C...KINEMATICS CHECK
42361 IF (XLAM(LKNT).EQ.0D0) THEN
42362 LKNT=LKNT-1
42363 ENDIF
42364
42365C * CHI+ -> LEPTON+_I + DBAR_J + D_K.
42366 160 LKNT = LKNT+1
42367 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
42368 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
42369 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
42370 XLAM(LKNT) = 0D0
42371C...Set coupling, and decay product masses on/off
42372 RVLAMC = 3. * GW2 * 5D-1 *
42373 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
42374 DCMASS = .FALSE.
42375 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-5
42376 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
42377C...Resonance KF codes (1=I,2=J,3=K)
42378 KFR(1)=-IDLAM(LKNT,1)+1
42379 KFR(2)=-IDLAM(LKNT,2)+1
42380 KFR(3)=0
42381C...Calculate width.
42382 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42383 & ,XLAM(LKNT))
42384 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42385C...KINEMATICS CHECK
42386 IF (XLAM(LKNT).EQ.0D0) THEN
42387 LKNT=LKNT-1
42388 ENDIF
42389
42390C * CHI+ -> NU_I + U_J + DBAR_K.
42391 170 LKNT = LKNT+1
42392 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
42393 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
42394 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
42395 XLAM(LKNT) = 0D0
42396C...Set coupling, and decay product masses on/off
42397 DCMASS = .FALSE.
42398 RVLAMC = 3. * GW2 * 5D-1 *
42399 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
42400 IF (IDLAM(LKNT,2).EQ.6.OR.IDLAM(LKNT,3).EQ.-5)
42401 & DCMASS = .TRUE.
42402C...Resonance KF codes (1=I,2=J,3=K)
42403 KFR(1)=IDLAM(LKNT,1)-1
42404 KFR(2)=IDLAM(LKNT,2)-1
42405 KFR(3)=0
42406C...Calculate width.
42407 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42408 & ,XLAM(LKNT))
42409 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42410C...KINEMATICS CHECK
42411 IF (XLAM(LKNT).EQ.0D0) THEN
42412 LKNT=LKNT-1
42413 ENDIF
42414
42415 180 CONTINUE
42416 ENDIF
42417
42418C...UDD TYPE R-VIOLATION
42419C...These decays need special treatment since more than one BV coupling
42420C...contributes (with interference). Consider e.g. (symbolically)
42421C |M|^2 = |l''_{ijk}|^2*(PYRVI1(RES_I) + PYRVI2(RES_I))
42422C +|l''_{jik}|^2*(PYRVI1(RES_J) + PYRVI2(RES_J))
42423C +l''_{ijk}*l''_{jik}*PYRVI3(PYRVI4(RES_I,RES_J))
42424C...The problem is that a single call to PYRVGW would evaluate all
42425C...these terms and sum them, but without the different couplings. The
42426C...way out is to call PYRVGW three times, once for the first line, once
42427C...for the second line, and then once for all the lines (it is
42428C...impossible to get just the last line out) without multiplying by
42429C...couplings. The last line is then obtained as the result of the third
42430C...call minus the results of the two first calls. Each term is then
42431C...multiplied by its respective coupling before the whole thing is
42432C...summed up in XLAM.
42433C...Note that with three interfering resonances, this procedure becomes
42434C...more complicated, as can be seen in the CHI+ -> 3*DBAR mode.
42435
42436 IF (IMSS(53).GE.1) THEN
42437C...LOOP OVER DECAY MODES
42438 DO 190 ISC=1,25
42439
42440C...CHI+ -> U_I + U_J + D_K
42441C...Decay mode I<->J symmetric.
42442 IF (MOD(ISC/9,3).LE.MOD(ISC/3,3).AND.ISC.NE.13) THEN
42443 LKNT = LKNT+1
42444 IDLAM(LKNT,1) = 2 +2*MOD(ISC/9,3)
42445 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
42446 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
42447 XLAM(LKNT) = 0D0
42448C...Set coupling, and decay product masses on/off
42449 RVLAMC= 6. * GW2 * 5D-1
42450 RVLJIK= RVLAMB(MOD(ISC/3,3)+1,MOD(ISC/9,3)+1,MOD(ISC,3)
42451 & +1)
42452 RVLIJK= RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
42453 & +1)
42454 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3)) RVLAMC = 5D-1
42455 & * RVLAMC
42456 DCMASS=.FALSE.
42457 IF (IDLAM(LKNT,1).EQ.6.OR.IDLAM(LKNT,2).EQ.6
42458 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS =.TRUE.
42459C...Resonance KF codes (1=I,2=J,3=K)
42460 KFR(1) = -IDLAM(LKNT,1)+1
42461 KFR(2) = 0
42462 KFR(3) = 0
42463C...Calculate width.
42464 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42465 & IDLAM(LKNT,3),XRESI)
42466C...Resonance KF codes (1=I,2=J,3=K)
42467 KFR(1) = 0
42468 KFR(2) = -IDLAM(LKNT,2)+1
42469 KFR(3) = 0
42470C...Calculate width.
42471 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42472 & IDLAM(LKNT,3),XRESJ)
42473C...Resonance KF codes (1=I,2=J,3=K)
42474 KFR(1) = -IDLAM(LKNT,1)+1
42475 KFR(2) = -IDLAM(LKNT,2)+1
42476 KFR(3) = 0
42477C...Calculate width.
42478 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42479 & IDLAM(LKNT,3),XRESIJ)
42480 IF (ABS((XRESI+XRESJ)/XRESIJ-1.).GT.1D-4) THEN
42481 XRESIJ = XRESIJ-XRESI-XRESJ
42482 ELSE
42483 XRESIJ = 0D0
42484 ENDIF
42485C...CALCULATE TOTAL WIDTH
42486 XLAM(LKNT) = RVLJIK**2 * XRESI + RVLIJK**2 * XRESJ
42487 & + RVLJIK*RVLIJK * XRESIJ
42488 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42489C...KINEMATICS CHECK
42490 IF (XLAM(LKNT).EQ.0D0) THEN
42491 LKNT=LKNT-1
42492 ENDIF
42493 ENDIF
42494C...CHI+ -> DBAR_I + DBAR_J + DBAR_K
42495C...Symmetry I<->J<->K.
42496 IF ((MOD(ISC/9,3).LE.MOD(ISC/3,3)).AND.(MOD(ISC/3,3).LE
42497 & .MOD(ISC,3)).AND.ISC.NE.13) THEN
42498 LKNT = LKNT+1
42499 IDLAM(LKNT,1) = -1 -2*MOD(ISC/9,3)
42500 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
42501 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
42502 XLAM(LKNT) = 0D0
42503C...Set coupling, and decay product masses on/off
42504 RVLAMC = 6. * GW2 * 5D-1
42505 RVLIJK = RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
42506 & +1)
42507 RVLKIJ = RVLAMB(MOD(ISC,3)+1,MOD(ISC/9,3)+1,MOD(ISC/3,3)
42508 & +1)
42509 RVLJKI = RVLAMB(MOD(ISC/3,3)+1,MOD(ISC,3)+1,MOD(ISC/9,3)
42510 & +1)
42511 DCMASS = .FALSE.
42512 IF (IDLAM(LKNT,1).EQ.-5.OR.IDLAM(LKNT,2).EQ.-5
42513 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS = .TRUE.
42514C...Collect symmetry factors
42515 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3).OR.MOD(ISC/3,3).EQ
42516 & .MOD(ISC,3).OR.MOD(ISC/9,3).EQ.MOD(ISC,3))
42517 & RVLAMC = 5D-1 * RVLAMC
42518C...Resonance KF codes (1=I,2=J,3=K)
42519 KFR(1) = IDLAM(LKNT,1)-1
42520 KFR(2) = 0
42521 KFR(3) = 0
42522C...Calculate width.
42523 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42524 & IDLAM(LKNT,3),XRESI)
42525C...Resonance KF codes (1=I,2=J,3=K)
42526 KFR(1) = 0
42527 KFR(2) = IDLAM(LKNT,2)-1
42528 KFR(3) = 0
42529C...Calculate width.
42530 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42531 & IDLAM(LKNT,3),XRESJ)
42532C...Resonance KF codes (1=I,2=J,3=K)
42533 KFR(1) = 0
42534 KFR(2) = 0
42535 KFR(3) = IDLAM(LKNT,3)-1
42536C...Calculate width.
42537 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42538 & IDLAM(LKNT,3),XRESK)
42539C...Resonance KF codes (1=I,2=J,3=K)
42540 KFR(1) = IDLAM(LKNT,1)-1
42541 KFR(2) = IDLAM(LKNT,2)-1
42542 KFR(3) = 0
42543C...Calculate width.
42544 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42545 & IDLAM(LKNT,3),XRESIJ)
42546 IF (ABS(XRESIJ/(XRESI+XRESJ)-1.).GT.1D-4) THEN
42547 XRESIJ = XRESI+XRESJ-XRESIJ
42548 ELSE
42549 XRESIJ = 0D0
42550 ENDIF
42551C...Resonance KF codes (1=I,2=J,3=K)
42552 KFR(1) = 0
42553 KFR(2) = IDLAM(LKNT,2)-1
42554 KFR(3) = IDLAM(LKNT,3)-1
42555C...Calculate width.
42556 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42557 & IDLAM(LKNT,3),XRESJK)
42558 IF (ABS(XRESJK/(XRESJ+XRESK)-1.).GT.1D-4) THEN
42559 XRESJK = XRESJ+XRESK-XRESJK
42560 ELSE
42561 XRESJK = 0D0
42562 ENDIF
42563C...Resonance KF codes (1=I,2=J,3=K)
42564 KFR(1) = IDLAM(LKNT,1)-1
42565 KFR(2) = 0
42566 KFR(3) = IDLAM(LKNT,3)-1
42567C...Calculate width.
42568 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42569 & IDLAM(LKNT,3),XRESIK)
42570 IF (ABS(XRESIK/(XRESI+XRESK)-1.).GT.1D-4) THEN
42571 XRESIK = XRESI+XRESK-XRESIK
42572 ELSE
42573 XRESIK = 0D0
42574 ENDIF
42575C...CALCULATE TOTAL WIDTH
42576 XLAM(LKNT) =
42577 & RVLIJK**2 * XRESI
42578 & + RVLJKI**2 * XRESJ
42579 & + RVLKIJ**2 * XRESK
42580 & + RVLIJK*RVLJKI * XRESIJ
42581 & + RVLIJK*RVLKIJ * XRESIK
42582 & + RVLJKI*RVLKIJ * XRESJK
42583 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2.*PARU(1)*RMS(0))**3*32)
42584C...KINEMATICS CHECK
42585 IF (XLAM(LKNT).EQ.0D0) THEN
42586 LKNT=LKNT-1
42587 ENDIF
42588 ENDIF
42589 190 CONTINUE
42590 ENDIF
42591 ENDIF
42592 ENDIF
42593
42594 RETURN
42595 END
42596
42597C*********************************************************************
42598
42599C...PYRVGL
42600C...Calculates R-violating gluino decay widths.
42601C...See BV part of PYRVCH for comments about the way the BV decay width
42602C...is calculated. Same comments apply here.
42603C...P. Z. Skands
42604
42605 SUBROUTINE PYRVGL(KFIN,XLAM,IDLAM,LKNT)
42606
42607C...Double precision and integer declarations.
42608 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42609 IMPLICIT INTEGER(I-N)
42610C...Parameter statement to help give large particle numbers.
42611 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
42612 &KEXCIT=4000000,KDIMEN=5000000)
42613C...Commonblocks.
42614 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42615 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42616 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
42617 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
42618 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
42619 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
42620C...Local variables.
42621 DOUBLE PRECISION XLAM(0:400)
42622 INTEGER IDLAM(400,3), PYCOMP
42623C...Information from main routine to PYRVGW
42624 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
42625 & ,DCMASS,KFR(3)
42626C...Auxiliary variables needed for BV (RV Gauge STOre)
42627 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
42628 & ,RVLJKI,RVLJIK
42629C...Running quark masses
42630 DOUBLE PRECISION RMQ(6)
42631C...Decay product masses on/off
42632 LOGICAL DCMASS
42633 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
42634 & /RVGSTO/
42635
42636C...IF LQD OR UDD TYPE R-VIOLATION ON.
42637 IF (IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
42638 KFSM=KFIN-KSUSY1
42639
42640C... AB(x,y,z):
42641C x=1-2 : Select A or B coupling (1:A ; 2:B)
42642C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
42643C 11-16:e,nu_e,mu,... not used here)
42644C z=1-2 : Mass eigenstate number
42645 DO 100 I = 1,6
42646C...A Couplings
42647 AB(1,I,1) = SFMIX(I,2)
42648 AB(1,I,2) = SFMIX(I,4)
42649C...B Couplings
42650 AB(2,I,1) = -SFMIX(I,1)
42651 AB(2,I,2) = -SFMIX(I,3)
42652 100 CONTINUE
42653 GSTR2 = 4D0*PARU(1) * PYALPS(PMAS(PYCOMP(KFIN),1)**2)
42654C...LQD DECAYS.
42655 IF (IMSS(52).GE.1) THEN
42656C...STEP IN I,J,K USING SINGLE COUNTER
42657 DO 120 ISC=0,26
42658C * GLUINO -> NUBAR_I + DBAR_J + D_K.
42659 LKNT = LKNT+1
42660 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
42661 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
42662 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
42663 XLAM(LKNT)=0D0
42664C...Set coupling, and decay product masses on/off
42665 RVLAMC=RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
42666 & * 5D-1 * GSTR2
42667 DCMASS = .FALSE.
42668 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
42669C...Resonance KF codes (1=I,2=J,3=K)
42670 KFR(1) = 0
42671 KFR(2) = -IDLAM(LKNT,2)
42672 KFR(3) = -IDLAM(LKNT,3)
42673C...Calculate width.
42674 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42675 & ,XLAM(LKNT))
42676C...Normalize
42677 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42678C...Charge conjugate mode.
42679 110 LKNT = LKNT+1
42680 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
42681 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
42682 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
42683 XLAM(LKNT) = XLAM(LKNT-1)
42684C...KINEMATICS CHECK
42685 IF (XLAM(LKNT).EQ.0D0) THEN
42686 LKNT=LKNT-2
42687 ENDIF
42688
42689C * GLUINO -> LEPTON+_I + UBAR_J + D_K
42690 LKNT = LKNT+1
42691 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
42692 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
42693 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
42694 XLAM(LKNT)=0D0
42695C...Set coupling, and decay product masses on/off
42696 RVLAMC = RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
42697 & **2* 5D-1 * GSTR2
42698 DCMASS = .FALSE.
42699 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
42700 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
42701C...Resonance KF codes (1=I,2=J,3=K)
42702 KFR(1) = 0
42703 KFR(2) = -IDLAM(LKNT,2)
42704 KFR(3) = -IDLAM(LKNT,3)
42705C...Calculate width.
42706 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42707 & ,XLAM(LKNT))
42708 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42709C...Charge conjugate mode.
42710 LKNT=LKNT+1
42711 IDLAM(LKNT,1) = -IDLAM(LKNT-1,1)
42712 IDLAM(LKNT,2) = -IDLAM(LKNT-1,2)
42713 IDLAM(LKNT,3) = -IDLAM(LKNT-1,3)
42714 XLAM(LKNT) = XLAM(LKNT-1)
42715C...KINEMATICS CHECK
42716 IF (XLAM(LKNT).EQ.0D0) THEN
42717 LKNT=LKNT-2
42718 ENDIF
42719
42720 120 CONTINUE
42721 ENDIF
42722
42723C...UDD DECAYS.
42724 IF (IMSS(53).GE.1) THEN
42725C...STEP IN I,J,K USING SINGLE COUNTER
42726 DO 130 ISC=0,26
42727C * GLUINO -> UBAR_I + DBAR_J + DBAR_K.
42728 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
42729 LKNT = LKNT+1
42730 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
42731 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
42732 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
42733 XLAM(LKNT)=0D0
42734C...Set coupling, and decay product masses on/off. A factor of 2 for
42735C...(N_C-1) has been used to cancel a factor 0.5.
42736 RVLAMC=RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
42737 & **2 * GSTR2
42738 DCMASS = .FALSE.
42739 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
42740 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
42741C...Resonance KF codes (1=I,2=J,3=K)
42742 KFR(1) = IDLAM(LKNT,1)
42743 KFR(2) = 0
42744 KFR(3) = 0
42745C...Calculate width.
42746 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42747 & ,XRESI)
42748C...Resonance KF codes (1=I,2=J,3=K)
42749 KFR(1) = 0
42750 KFR(2) = IDLAM(LKNT,2)
42751 KFR(3) = 0
42752C...Calculate width.
42753 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42754 & ,XRESJ)
42755C...Resonance KF codes (1=I,2=J,3=K)
42756 KFR(1) = 0
42757 KFR(2) = 0
42758 KFR(3) = IDLAM(LKNT,3)
42759C...Calculate width.
42760 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42761 & ,XRESK)
42762C...Resonance KF codes (1=I,2=J,3=K)
42763 KFR(1) = IDLAM(LKNT,1)
42764 KFR(2) = IDLAM(LKNT,2)
42765 KFR(3) = 0
42766C...Calculate width.
42767 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42768 & ,XRESIJ)
42769C...Calculate interference function. (Factor -1/2 to make up for factor
42770C...-2 in PYRVGW.
42771 IF (ABS((XRESI+XRESJ)/XRESIJ-1D0).GT.1D-4) THEN
42772 XRESIJ = 5D-1 * (XRESI+XRESJ-XRESIJ)
42773 ELSE
42774 XRESIJ = 0D0
42775 ENDIF
42776C...Resonance KF codes (1=I,2=J,3=K)
42777 KFR(1) = 0
42778 KFR(2) = IDLAM(LKNT,2)
42779 KFR(3) = IDLAM(LKNT,3)
42780C...Calculate width.
42781 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42782 & ,XRESJK)
42783 IF (ABS((XRESJ+XRESK)/XRESJK-1).GT.1D-4) THEN
42784 XRESJK = 5D-1 * (XRESJ+XRESK-XRESJK)
42785 ELSE
42786 XRESJK = 0D0
42787 ENDIF
42788C...Resonance KF codes (1=I,2=J,3=K)
42789 KFR(1) = IDLAM(LKNT,1)
42790 KFR(2) = 0
42791 KFR(3) = IDLAM(LKNT,3)
42792C...Calculate width.
42793 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42794 & ,XRESIK)
42795 IF (ABS((XRESI+XRESK)/XRESIK-1).GT.1D-4) THEN
42796 XRESIK = 5D-1 * (XRESI+XRESK-XRESIK)
42797 ELSE
42798 XRESIK = 0D0
42799 ENDIF
42800C...Calculate total width (factor 1/2 from 1/(N_C-1))
42801 XLAM(LKNT) = XRESI + XRESJ + XRESK
42802 & + 5D-1 * (XRESIJ + XRESIK + XRESJK)
42803C...Normalize
42804 XLAM(LKNT) = XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42805C...Charge conjugate mode.
42806 LKNT = LKNT+1
42807 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
42808 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
42809 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
42810 XLAM(LKNT) = XLAM(LKNT-1)
42811C...KINEMATICS CHECK
42812 IF (XLAM(LKNT).EQ.0D0) THEN
42813 LKNT=LKNT-2
42814 ENDIF
42815 ENDIF
42816 130 CONTINUE
42817 ENDIF
42818 ENDIF
42819 RETURN
42820 END
42821
42822C*********************************************************************
42823
42824C...PYRVSB
42825C...Auxiliary function to PYRVSF for calculating R-Violating
42826C...sfermion widths. Though the decay products are most often treated
42827C...as massless in the calculation, the kinematical boundary of phase
42828C...space is tested using the true masses.
42829C...MODE = 1: All decay products massive
42830C...MODE = 2: Decay product 1 massless
42831C...MODE = 3: Decay product 2 massless
42832C...MODE = 4: All decay products massless
42833
42834 FUNCTION PYRVSB(KFIN,ID1,ID2,RM2,MODE)
42835
42836 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
42837 IMPLICIT INTEGER (I-N)
42838 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42839 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42840 SAVE /PYDAT1/,/PYDAT2/
42841 DOUBLE PRECISION SM(3)
42842 INTEGER PYCOMP, KC(3)
42843 KC(1)=PYCOMP(KFIN)
42844 KC(2)=PYCOMP(ID1)
42845 KC(3)=PYCOMP(ID2)
42846 SM(1)=PMAS(KC(1),1)**2
42847 SM(2)=PMAS(KC(2),1)**2
42848 SM(3)=PMAS(KC(3),1)**2
42849C...Kinematics check
42850 IF ((SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2).LE.0D0) THEN
42851 PYRVSB=0D0
42852 RETURN
42853 ENDIF
42854C...CM momenta squared
42855 IF (MODE.EQ.1) THEN
42856 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2)
42857 & * (SM(1)-(PMAS(KC(2),1)-PMAS(KC(3),1))**2)
42858 ELSE IF (MODE.EQ.2) THEN
42859 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(3),1))**2)**2
42860 ELSE IF (MODE.EQ.3) THEN
42861 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1))**2)**2
42862 ELSE
42863 P2CM=SM(1)/4.
42864 ENDIF
42865C...Calculate Width
42866 PYRVSB=RM2*SQRT(MAX(0D0,P2CM))/(8*PARU(1)*SM(1))
42867 RETURN
42868 END
42869
42870C*********************************************************************
42871
42872C...PYRVGW
42873C...Generalized Matrix Element for R-Violating 3-body widths.
42874C...P. Z. Skands
42875 SUBROUTINE PYRVGW(KFIN,ID1,ID2,ID3,XLAM)
42876
42877 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
42878 IMPLICIT INTEGER (I-N)
42879 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
42880 &KEXCIT=4000000,KDIMEN=5000000)
42881 PARAMETER (EPS=1D-4)
42882 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42883 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
42884 & ,DCMASS,KFR(3)
42885 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
42886 & SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
42887 DOUBLE PRECISION XLIM(3,3)
42888 INTEGER KC(0:3), PYCOMP
42889 LOGICAL DCMASS, DCHECK(6)
42890 SAVE /PYDAT2/,/PYRVNV/,/PYSSMT/
42891
42892 XLAM = 0D0
42893
42894 KC(0) = PYCOMP(KFIN)
42895 KC(1) = PYCOMP(ID1)
42896 KC(2) = PYCOMP(ID2)
42897 KC(3) = PYCOMP(ID3)
42898 RMS(0) = PMAS(KC(0),1)
42899 RMS(1) = PYMRUN(ID1,PMAS(KC(1),1)**2)
42900 RMS(2) = PYMRUN(ID2,PMAS(KC(2),1)**2)
42901 RMS(3) = PYMRUN(ID3,PMAS(KC(3),1)**2)
42902C...INITIALIZE OUTER INTEGRATION LIMITS AND KINEMATICS CHECK
42903 XLIM(1,1)=(RMS(1)+RMS(2))**2
42904 XLIM(1,2)=(RMS(0)-RMS(3))**2
42905 XLIM(1,3)=XLIM(1,2)-XLIM(1,1)
42906 XLIM(2,1)=(RMS(2)+RMS(3))**2
42907 XLIM(2,2)=(RMS(0)-RMS(1))**2
42908 XLIM(2,3)=XLIM(2,2)-XLIM(2,1)
42909 XLIM(3,1)=(RMS(1)+RMS(3))**2
42910 XLIM(3,2)=(RMS(0)-RMS(2))**2
42911 XLIM(3,3)=XLIM(3,2)-XLIM(3,1)
42912C...Check Phase Space
42913 IF (XLIM(1,3).LT.0D0.OR.XLIM(2,3).LT.0D0.OR.XLIM(3,3).LT.0D0) THEN
42914 RETURN
42915 ENDIF
42916
42917C...INITIALIZE RESONANCE INFORMATION
42918 DO 110 JRES = 1,3
42919 DO 100 IMASS = 1,2
42920 IRES = 2*(JRES-1)+IMASS
42921 INTRES(IRES,1) = 0
42922 DCHECK(IRES) =.FALSE.
42923C...NO RIGHT-HANDED NEUTRINOS
42924 IF (((IMASS.EQ.2).AND.((IABS(KFR(JRES)).EQ.12).OR
42925 & .(IABS(KFR(JRES)).EQ.14).OR.(IABS(KFR(JRES)).EQ.16))).OR
42926 & .KFR(JRES).EQ.0) GOTO 100
42927 RES(IRES,1) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),1)
42928 RES(IRES,2) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),2)
42929 INTRES(IRES,1) = IABS(KFR(JRES))
42930 INTRES(IRES,2) = IMASS
42931 IF (KFR(JRES).LT.0) INTRES(IRES,3) = 1
42932 IF (KFR(JRES).GT.0) INTRES(IRES,3) = 0
42933 100 CONTINUE
42934 110 CONTINUE
42935
42936C...SUM OVER DIAGRAMS AND INTEGRATE OVER PHASE SPACE
42937
42938C...RESONANCE CONTRIBUTIONS
42939C...(Only sum contributions where the resonance is off shell).
42940C...Store whether diagram on/off in DCHECK.
42941C...LOOP OVER MASS STATES
42942 DO 120 J=1,2
42943 IDR=J
42944 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
42945 IF ((RMS(0).LT.(RMS(1)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(2)
42946 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
42947 DCHECK(IDR) =.TRUE.
42948 XLAM = XLAM + TMIX * PYRVI1(2,3,1)
42949 ENDIF
42950
42951 IDR=J+2
42952 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
42953 IF ((RMS(0).LT.(RMS(2)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
42954 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
42955 DCHECK(IDR) =.TRUE.
42956 XLAM = XLAM + TMIX * PYRVI1(1,3,2)
42957 ENDIF
42958
42959 IDR=J+4
42960 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
42961 IF ((RMS(0).LT.(RMS(3)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
42962 & +RMS(2)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
42963 DCHECK(IDR) =.TRUE.
42964 XLAM = XLAM + TMIX * PYRVI1(1,2,3)
42965 ENDIF
42966 120 CONTINUE
42967C... L-R INTERFERENCES
42968C... (Only add contributions where both contributing diagrams
42969C... are non-resonant).
42970 IDR=1
42971 IF (DCHECK(1).AND.DCHECK(2)) THEN
42972C...Bug corrected 11/12 2001. Skands.
42973 XLAM = XLAM + 2D0 * PYRVI2(2,3,1)
42974 & * SFMIX(INTRES(1,1),2+INTRES(1,3)-1)
42975 & * SFMIX(INTRES(2,1),4+INTRES(2,3)-1)
42976 ENDIF
42977
42978 IDR=3
42979 IF (DCHECK(3).AND.DCHECK(4)) THEN
42980 XLAM = XLAM + 2D0 * PYRVI2(1,3,2)
42981 & * SFMIX(INTRES(3,1),2+INTRES(3,3)-1)
42982 & * SFMIX(INTRES(4,1),4+INTRES(4,3)-1)
42983 ENDIF
42984
42985 IDR=5
42986 IF (DCHECK(5).AND.DCHECK(6)) THEN
42987 XLAM = XLAM + 2D0 * PYRVI2(1,2,3)
42988 & * SFMIX(INTRES(5,1),2+INTRES(5,3)-1)
42989 & * SFMIX(INTRES(6,1),4+INTRES(6,3)-1)
42990 ENDIF
42991C... TRUE INTERFERENCES
42992C... (Only add contributions where both contributing diagrams
42993C... are non-resonant).
42994 PREF=-2D0
42995 IF ((KFIN-KSUSY1).EQ.24.OR.(KFIN-KSUSY1).EQ.37) PREF=2D0
42996 DO 140 IKR1 = 1,2
42997 DO 130 IKR2 = 1,2
42998 IDR = IKR1+2
42999 IDR2 = IKR2
43000 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
43001 XLAM = XLAM + PREF*PYRVI3(1,3,2) *
43002 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
43003 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
43004 ENDIF
43005
43006 IDR = IKR1+4
43007 IDR2 = IKR2
43008 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
43009 XLAM = XLAM + PREF*PYRVI3(1,2,3) *
43010 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
43011 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
43012 ENDIF
43013
43014 IDR = IKR1+4
43015 IDR2 = IKR2+2
43016 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
43017 XLAM = XLAM + PREF*PYRVI3(2,1,3) *
43018 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
43019 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
43020 ENDIF
43021 130 CONTINUE
43022 140 CONTINUE
43023
43024 RETURN
43025 END
43026
43027C*********************************************************************
43028
43029C...PYRVI1
43030C...Function to integrate resonance contributions
43031
43032 FUNCTION PYRVI1(ID1,ID2,ID3)
43033
43034 IMPLICIT NONE
43035 DOUBLE PRECISION LO,HI,PYRVI1,PYRVG1,PYGAUS
43036 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
43037 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
43038 LOGICAL MFLAG,DCMASS
43039 EXTERNAL PYRVG1,PYGAUS
43040 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
43041 & ,DCMASS,KFR(3)
43042 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
43043 SAVE/PYRVNV/,/PYRVPM/
43044C...Initialize mass and width information
43045 PYRVI1 = 0D0
43046 RM(0) = RMS(0)
43047 RM(1) = RMS(ID1)
43048 RM(2) = RMS(ID2)
43049 RM(3) = RMS(ID3)
43050 RESM(1)= RES(IDR,1)
43051 RESW(1)= RES(IDR,2)
43052C...A->B and B->A for antisparticles
43053 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
43054 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
43055C...Integration boundaries and mass flag
43056 LO = (RM(1)+RM(2))**2
43057 HI = (RM(0)-RM(3))**2
43058 MFLAG = DCMASS
43059 PYRVI1 = PYGAUS(PYRVG1,LO,HI,1D-3)
43060 RETURN
43061 END
43062
43063C*********************************************************************
43064
43065C...PYRVI2
43066C...Function to integrate L-R interference contributions
43067
43068 FUNCTION PYRVI2(ID1,ID2,ID3)
43069
43070 IMPLICIT NONE
43071 DOUBLE PRECISION LO,HI,PYRVI2, PYRVG2, PYGAUS
43072 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
43073 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
43074 LOGICAL MFLAG,DCMASS
43075 EXTERNAL PYRVG2,PYGAUS
43076 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
43077 & ,DCMASS,KFR(3)
43078 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
43079 SAVE/PYRVNV/,/PYRVPM/
43080C...Initialize mass and width information
43081 PYRVI2 = 0D0
43082 RM(0) = RMS(0)
43083 RM(1) = RMS(ID1)
43084 RM(2) = RMS(ID2)
43085 RM(3) = RMS(ID3)
43086 RESM(1)= RES(IDR,1)
43087 RESW(1)= RES(IDR,2)
43088 RESM(2)= RES(IDR+1,1)
43089 RESW(2)= RES(IDR+1,2)
43090C...A->B and B->A for antisparticles
43091 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
43092 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
43093 A(2) = AB(1+INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
43094 B(2) = AB(2-INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
43095C...Boundaries and mass flag
43096 LO = (RM(1)+RM(2))**2
43097 HI = (RM(0)-RM(3))**2
43098 MFLAG = DCMASS
43099 PYRVI2 = PYGAUS(PYRVG2,LO,HI,1D-3)
43100 RETURN
43101 END
43102
43103C*********************************************************************
43104
43105C...PYRVI3
43106C...Function to integrate true interference contributions
43107
43108 FUNCTION PYRVI3(ID1,ID2,ID3)
43109
43110 IMPLICIT NONE
43111 DOUBLE PRECISION LO,HI,PYRVI3, PYRVG3, PYGAUS
43112 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
43113 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
43114 LOGICAL MFLAG,DCMASS
43115 EXTERNAL PYRVG3,PYGAUS
43116 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
43117 & ,DCMASS,KFR(3)
43118 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
43119 SAVE/PYRVNV/,/PYRVPM/
43120C...Initialize mass and width information
43121 PYRVI3 = 0D0
43122 RM(0) = RMS(0)
43123 RM(1) = RMS(ID1)
43124 RM(2) = RMS(ID2)
43125 RM(3) = RMS(ID3)
43126 RESM(1)= RES(IDR,1)
43127 RESW(1)= RES(IDR,2)
43128 RESM(2)= RES(IDR2,1)
43129 RESW(2)= RES(IDR2,2)
43130C...A -> B and B -> A for antisparticles
43131 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
43132 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
43133 A(2) = AB(1+INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
43134 B(2) = AB(2-INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
43135C...Boundaries and mass flag
43136 LO = (RM(1)+RM(2))**2
43137 HI = (RM(0)-RM(3))**2
43138 MFLAG = DCMASS
43139 PYRVI3 = PYGAUS(PYRVG3,LO,HI,1D-3)
43140 RETURN
43141 END
43142
43143C*********************************************************************
43144
43145C...PYRVG1
43146C...Integrand for resonance contributions
43147
43148 FUNCTION PYRVG1(X)
43149
43150 IMPLICIT NONE
43151 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
43152 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY,PYRVR
43153 DOUBLE PRECISION RVR,PYRVG1,E2,E3,C1,SR1,SR2,A1,A2
43154 LOGICAL MFLAG
43155 SAVE/PYRVPM/
43156 RVR = PYRVR(X,RESM(1),RESW(1))
43157 C1 = 2D0*SQRT(MAX(0D0,X))
43158 IF (.NOT.MFLAG) THEN
43159 E2 = X/C1
43160 E3 = (RM(0)**2-X)/C1
43161 DELTAY = 4D0*E2*E3
43162 PYRVG1 = DELTAY*RVR*X*(A(1)**2+B(1)**2)*(RM(0)**2-X)
43163 ELSE
43164 E2 = (X-RM(1)**2+RM(2)**2)/C1
43165 E3 = (RM(0)**2-X-RM(3)**2)/C1
43166 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
43167 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
43168 DELTAY = 4D0*SR1*SR2
43169 A1 = 4.*A(1)*B(1)*RM(3)*RM(0)
43170 A2 = (A(1)**2+B(1)**2)*(RM(0)**2+RM(3)**2-X)
43171 PYRVG1 = DELTAY*RVR*(X-RM(1)**2-RM(2)**2)*(A1+A2)
43172 ENDIF
43173 RETURN
43174 END
43175
43176C*********************************************************************
43177
43178C...PYRVG2
43179C...Integrand for L-R interference contributions
43180
43181 FUNCTION PYRVG2(X)
43182
43183 IMPLICIT NONE
43184 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
43185 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY, PYRVS
43186 DOUBLE PRECISION RVS,PYRVG2,E2,E3,C1,SR1,SR2
43187 LOGICAL MFLAG
43188 SAVE/PYRVPM/
43189 C1 = 2D0*SQRT(MAX(0D0,X))
43190 RVS = PYRVS(X,X,RESM(1),RESW(1),RESM(2),RESW(2))
43191 IF (.NOT.MFLAG) THEN
43192 E2 = X/C1
43193 E3 = (RM(0)**2-X)/C1
43194 DELTAY = 4D0*E2*E3
43195 PYRVG2 = DELTAY*RVS*X*(A(1)*A(2)+B(1)*B(2))*(RM(0)**2-X)
43196 ELSE
43197 E2 = (X-RM(1)**2+RM(2)**2)/C1
43198 E3 = (RM(0)**2-X-RM(3)**2)/C1
43199 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
43200 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
43201 DELTAY = 4D0*SR1*SR2
43202 PYRVG2 = DELTAY*RVS*(X-RM(1)**2-RM(2)**2)*((A(1)*A(2)
43203 & + B(1)*B(2))*(RM(0)**2+RM(3)**2-X)
43204 & + 2D0*(A(1)*B(2)+A(2)*B(1))*RM(3)*RM(0))
43205 ENDIF
43206 RETURN
43207 END
43208
43209C*********************************************************************
43210
43211C...PYRVG3
43212C...Function to do Y integration over true interference contributions
43213
43214 FUNCTION PYRVG3(X)
43215
43216 IMPLICIT NONE
43217 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
43218C...Second Dalitz variable for PYRVG4
43219 COMMON/PYG2DX/X1
43220 DOUBLE PRECISION RM, A, B, RESM, RESW, X, X1
43221 DOUBLE PRECISION E2, E3, C1, SQ1, SR1, SR2, YMIN, YMAX
43222 DOUBLE PRECISION PYRVG3, PYRVG4, PYGAU2
43223 LOGICAL MFLAG
43224 EXTERNAL PYGAU2,PYRVG4
43225 SAVE/PYRVPM/,/PYG2DX/
43226 PYRVG3=0D0
43227 C1=2D0*SQRT(MAX(1D-9,X))
43228 X1=X
43229 IF (.NOT.MFLAG) THEN
43230 E2 = X/C1
43231 E3 = (RM(0)**2-X)/C1
43232 YMIN = 0D0
43233 YMAX = 4D0*E2*E3
43234 ELSE
43235 E2 = (X-RM(1)**2+RM(2)**2)/C1
43236 E3 = (RM(0)**2-X-RM(3)**2)/C1
43237 SQ1 = (E2+E3)**2
43238 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
43239 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
43240 YMIN = SQ1-(SR1+SR2)**2
43241 YMAX = SQ1-(SR1-SR2)**2
43242 ENDIF
43243 PYRVG3 = PYGAU2(PYRVG4,YMIN,YMAX,1D-3)
43244 RETURN
43245 END
43246
43247C*********************************************************************
43248
43249C...PYRVG4
43250C...Integrand for true intereference contributions
43251
43252 FUNCTION PYRVG4(Y)
43253
43254 IMPLICIT NONE
43255 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
43256 COMMON/PYG2DX/X
43257 DOUBLE PRECISION X, Y, PYRVG4, RM, A, B, RESM, RESW, RVS, PYRVS
43258 LOGICAL MFLAG
43259 SAVE /PYRVPM/,/PYG2DX/
43260 PYRVG4=0D0
43261 RVS=PYRVS(X,Y,RESM(1),RESW(1),RESM(2),RESW(2))
43262 IF (.NOT.MFLAG) THEN
43263 PYRVG4 = RVS*B(1)*B(2)*X*Y
43264 ELSE
43265 PYRVG4 = RVS*(RM(1)*RM(3)*A(1)*A(2)*(X+Y-RM(1)**2-RM(3)**2)
43266 & + RM(1)*RM(0)*B(1)*A(2)*(Y-RM(2)**2-RM(3)**2)
43267 & + RM(3)*RM(0)*A(1)*B(2)*(X-RM(1)**2-RM(2)**2)
43268 & + B(1)*B(2)*(X*Y-(RM(1)*RM(3))**2-(RM(0)*RM(2))**2))
43269 ENDIF
43270 RETURN
43271 END
43272
43273C*********************************************************************
43274
43275C...PYRVR
43276C...Breit-Wigner for resonance contributions
43277
43278 FUNCTION PYRVR(Mab2,RM,RW)
43279
43280 IMPLICIT NONE
43281 DOUBLE PRECISION Mab2,RM,RW,PYRVR
43282 PYRVR = 1D0/((Mab2-RM**2)**2+RM**2*RW**2)
43283 RETURN
43284 END
43285
43286C*********************************************************************
43287
43288C...PYRVS
43289C...Interference function
43290
43291 FUNCTION PYRVS(X,Y,M1,W1,M2,W2)
43292
43293 IMPLICIT NONE
43294 DOUBLE PRECISION X, Y, PYRVS, PYRVR, M1, M2, W1, W2
43295 PYRVS = PYRVR(X,M1,W1)*PYRVR(Y,M2,W2)*((X-M1**2)*(Y-M2**2)
43296 & +W1*W2*M1*M2)
43297 RETURN
43298 END
43299
43300C*********************************************************************
43301
43302C...PY1ENT
43303C...Stores one parton/particle in commonblock PYJETS.
43304
43305 SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
43306
43307C...Double precision and integer declarations.
43308 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43309 IMPLICIT INTEGER(I-N)
43310 INTEGER PYK,PYCHGE,PYCOMP
43311C...Commonblocks.
43312 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43313 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43314 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43315 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
43316
43317C...Standard checks.
43318 MSTU(28)=0
43319 IF(MSTU(12).GE.1) CALL PYLIST(0)
43320 IPA=MAX(1,IABS(IP))
43321 IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
43322 &'(PY1ENT:) writing outside PYJETS memory')
43323 KC=PYCOMP(KF)
43324 IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
43325
43326C...Find mass. Reset K, P and V vectors.
43327 PM=0D0
43328 IF(MSTU(10).EQ.1) PM=P(IPA,5)
43329 IF(MSTU(10).GE.2) PM=PYMASS(KF)
43330 DO 100 J=1,5
43331 K(IPA,J)=0
43332 P(IPA,J)=0D0
43333 V(IPA,J)=0D0
43334 100 CONTINUE
43335
43336C...Store parton/particle in K and P vectors.
43337 K(IPA,1)=1
43338 IF(IP.LT.0) K(IPA,1)=2
43339 K(IPA,2)=KF
43340 P(IPA,5)=PM
43341 P(IPA,4)=MAX(PE,PM)
43342 PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
43343 P(IPA,1)=PA*SIN(THE)*COS(PHI)
43344 P(IPA,2)=PA*SIN(THE)*SIN(PHI)
43345 P(IPA,3)=PA*COS(THE)
43346
43347C...Set N. Optionally fragment/decay.
43348 N=IPA
43349 IF(IP.EQ.0) CALL PYEXEC
43350
43351 RETURN
43352 END
43353
43354C*********************************************************************
43355
43356C...PY2ENT
43357C...Stores two partons/particles in their CM frame,
43358C...with the first along the +z axis.
43359
43360 SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
43361
43362C...Double precision and integer declarations.
43363 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43364 IMPLICIT INTEGER(I-N)
43365 INTEGER PYK,PYCHGE,PYCOMP
43366C...Commonblocks.
43367 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43368 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43369 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43370 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
43371
43372C...Standard checks.
43373 MSTU(28)=0
43374 IF(MSTU(12).GE.1) CALL PYLIST(0)
43375 IPA=MAX(1,IABS(IP))
43376 IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
43377 &'(PY2ENT:) writing outside PYJETS memory')
43378 KC1=PYCOMP(KF1)
43379 KC2=PYCOMP(KF2)
43380 IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
43381 &'(PY2ENT:) unknown flavour code')
43382
43383C...Find masses. Reset K, P and V vectors.
43384 PM1=0D0
43385 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
43386 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
43387 PM2=0D0
43388 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
43389 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
43390 DO 110 I=IPA,IPA+1
43391 DO 100 J=1,5
43392 K(I,J)=0
43393 P(I,J)=0D0
43394 V(I,J)=0D0
43395 100 CONTINUE
43396 110 CONTINUE
43397
43398C...Check flavours.
43399 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
43400 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
43401 IF(MSTU(19).EQ.1) THEN
43402 MSTU(19)=0
43403 ELSE
43404 IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
43405 & '(PY2ENT:) unphysical flavour combination')
43406 ENDIF
43407 K(IPA,2)=KF1
43408 K(IPA+1,2)=KF2
43409
43410C...Store partons/particles in K vectors for normal case.
43411 IF(IP.GE.0) THEN
43412 K(IPA,1)=1
43413 IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
43414 K(IPA+1,1)=1
43415
43416C...Store partons in K vectors for parton shower evolution.
43417 ELSE
43418 K(IPA,1)=3
43419 K(IPA+1,1)=3
43420 K(IPA,4)=MSTU(5)*(IPA+1)
43421 K(IPA,5)=K(IPA,4)
43422 K(IPA+1,4)=MSTU(5)*IPA
43423 K(IPA+1,5)=K(IPA+1,4)
43424 ENDIF
43425
43426C...Check kinematics and store partons/particles in P vectors.
43427 IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
43428 &'(PY2ENT:) energy smaller than sum of masses')
43429 PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/
43430 &(2D0*PECM)
43431 P(IPA,3)=PA
43432 P(IPA,4)=SQRT(PM1**2+PA**2)
43433 P(IPA,5)=PM1
43434 P(IPA+1,3)=-PA
43435 P(IPA+1,4)=SQRT(PM2**2+PA**2)
43436 P(IPA+1,5)=PM2
43437
43438C...Set N. Optionally fragment/decay.
43439 N=IPA+1
43440 IF(IP.EQ.0) CALL PYEXEC
43441
43442 RETURN
43443 END
43444
43445C*********************************************************************
43446
43447C...PY3ENT
43448C...Stores three partons or particles in their CM frame,
43449C...with the first along the +z axis and the third in the (x,z)
43450C...plane with x > 0.
43451
43452 SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
43453
43454C...Double precision and integer declarations.
43455 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43456 IMPLICIT INTEGER(I-N)
43457 INTEGER PYK,PYCHGE,PYCOMP
43458C...Commonblocks.
43459 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43460 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43461 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43462 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
43463
43464C...Standard checks.
43465 MSTU(28)=0
43466 IF(MSTU(12).GE.1) CALL PYLIST(0)
43467 IPA=MAX(1,IABS(IP))
43468 IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
43469 &'(PY3ENT:) writing outside PYJETS memory')
43470 KC1=PYCOMP(KF1)
43471 KC2=PYCOMP(KF2)
43472 KC3=PYCOMP(KF3)
43473 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
43474 &'(PY3ENT:) unknown flavour code')
43475
43476C...Find masses. Reset K, P and V vectors.
43477 PM1=0D0
43478 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
43479 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
43480 PM2=0D0
43481 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
43482 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
43483 PM3=0D0
43484 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
43485 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
43486 DO 110 I=IPA,IPA+2
43487 DO 100 J=1,5
43488 K(I,J)=0
43489 P(I,J)=0D0
43490 V(I,J)=0D0
43491 100 CONTINUE
43492 110 CONTINUE
43493
43494C...Check flavours.
43495 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
43496 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
43497 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
43498 IF(MSTU(19).EQ.1) THEN
43499 MSTU(19)=0
43500 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
43501 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
43502 & KQ1+KQ3.EQ.4)) THEN
43503 ELSE
43504 CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
43505 ENDIF
43506 K(IPA,2)=KF1
43507 K(IPA+1,2)=KF2
43508 K(IPA+2,2)=KF3
43509
43510C...Store partons/particles in K vectors for normal case.
43511 IF(IP.GE.0) THEN
43512 K(IPA,1)=1
43513 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
43514 K(IPA+1,1)=1
43515 IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
43516 K(IPA+2,1)=1
43517
43518C...Store partons in K vectors for parton shower evolution.
43519 ELSE
43520 K(IPA,1)=3
43521 K(IPA+1,1)=3
43522 K(IPA+2,1)=3
43523 KCS=4
43524 IF(KQ1.EQ.-1) KCS=5
43525 K(IPA,KCS)=MSTU(5)*(IPA+1)
43526 K(IPA,9-KCS)=MSTU(5)*(IPA+2)
43527 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
43528 K(IPA+1,9-KCS)=MSTU(5)*IPA
43529 K(IPA+2,KCS)=MSTU(5)*IPA
43530 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
43531 ENDIF
43532
43533C...Check kinematics.
43534 MKERR=0
43535 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR.
43536 &0.5D0*X3*PECM.LE.PM3) MKERR=1
43537 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
43538 PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2))
43539 PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2))
43540 CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2)
43541 CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3)
43542 IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1
43543 CTHE3=MAX(-1D0,MIN(1D0,CTHE3))
43544 IF(MKERR.NE.0) CALL PYERRM(13,
43545 &'(PY3ENT:) unphysical kinematical variable setup')
43546
43547C...Store partons/particles in P vectors.
43548 P(IPA,3)=PA1
43549 P(IPA,4)=SQRT(PA1**2+PM1**2)
43550 P(IPA,5)=PM1
43551 P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2)
43552 P(IPA+2,3)=PA3*CTHE3
43553 P(IPA+2,4)=SQRT(PA3**2+PM3**2)
43554 P(IPA+2,5)=PM3
43555 P(IPA+1,1)=-P(IPA+2,1)
43556 P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
43557 P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
43558 P(IPA+1,5)=PM2
43559
43560C...Set N. Optionally fragment/decay.
43561 N=IPA+2
43562 IF(IP.EQ.0) CALL PYEXEC
43563
43564 RETURN
43565 END
43566
43567C*********************************************************************
43568
43569C...PY4ENT
43570C...Stores four partons or particles in their CM frame, with
43571C...the first along the +z axis, the last in the xz plane with x > 0
43572C...and the second having y < 0 and y > 0 with equal probability.
43573
43574 SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
43575
43576C...Double precision and integer declarations.
43577 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43578 IMPLICIT INTEGER(I-N)
43579 INTEGER PYK,PYCHGE,PYCOMP
43580C...Commonblocks.
43581 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43582 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43583 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43584 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
43585
43586C...Standard checks.
43587 MSTU(28)=0
43588 IF(MSTU(12).GE.1) CALL PYLIST(0)
43589 IPA=MAX(1,IABS(IP))
43590 IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
43591 &'(PY4ENT:) writing outside PYJETS momory')
43592 KC1=PYCOMP(KF1)
43593 KC2=PYCOMP(KF2)
43594 KC3=PYCOMP(KF3)
43595 KC4=PYCOMP(KF4)
43596 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
43597 &'(PY4ENT:) unknown flavour code')
43598
43599C...Find masses. Reset K, P and V vectors.
43600 PM1=0D0
43601 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
43602 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
43603 PM2=0D0
43604 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
43605 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
43606 PM3=0D0
43607 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
43608 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
43609 PM4=0D0
43610 IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
43611 IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
43612 DO 110 I=IPA,IPA+3
43613 DO 100 J=1,5
43614 K(I,J)=0
43615 P(I,J)=0D0
43616 V(I,J)=0D0
43617 100 CONTINUE
43618 110 CONTINUE
43619
43620C...Check flavours.
43621 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
43622 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
43623 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
43624 KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
43625 IF(MSTU(19).EQ.1) THEN
43626 MSTU(19)=0
43627 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
43628 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
43629 & KQ1+KQ4.EQ.4)) THEN
43630 ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
43631 & THEN
43632 ELSE
43633 CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
43634 ENDIF
43635 K(IPA,2)=KF1
43636 K(IPA+1,2)=KF2
43637 K(IPA+2,2)=KF3
43638 K(IPA+3,2)=KF4
43639
43640C...Store partons/particles in K vectors for normal case.
43641 IF(IP.GE.0) THEN
43642 K(IPA,1)=1
43643 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
43644 K(IPA+1,1)=1
43645 IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
43646 & K(IPA+1,1)=2
43647 K(IPA+2,1)=1
43648 IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
43649 K(IPA+3,1)=1
43650
43651C...Store partons for parton shower evolution from q-g-g-qbar or
43652C...g-g-g-g event.
43653 ELSEIF(KQ1+KQ2.NE.0) THEN
43654 K(IPA,1)=3
43655 K(IPA+1,1)=3
43656 K(IPA+2,1)=3
43657 K(IPA+3,1)=3
43658 KCS=4
43659 IF(KQ1.EQ.-1) KCS=5
43660 K(IPA,KCS)=MSTU(5)*(IPA+1)
43661 K(IPA,9-KCS)=MSTU(5)*(IPA+3)
43662 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
43663 K(IPA+1,9-KCS)=MSTU(5)*IPA
43664 K(IPA+2,KCS)=MSTU(5)*(IPA+3)
43665 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
43666 K(IPA+3,KCS)=MSTU(5)*IPA
43667 K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
43668
43669C...Store partons for parton shower evolution from q-qbar-q-qbar event.
43670 ELSE
43671 K(IPA,1)=3
43672 K(IPA+1,1)=3
43673 K(IPA+2,1)=3
43674 K(IPA+3,1)=3
43675 K(IPA,4)=MSTU(5)*(IPA+1)
43676 K(IPA,5)=K(IPA,4)
43677 K(IPA+1,4)=MSTU(5)*IPA
43678 K(IPA+1,5)=K(IPA+1,4)
43679 K(IPA+2,4)=MSTU(5)*(IPA+3)
43680 K(IPA+2,5)=K(IPA+2,4)
43681 K(IPA+3,4)=MSTU(5)*(IPA+2)
43682 K(IPA+3,5)=K(IPA+3,4)
43683 ENDIF
43684
43685C...Check kinematics.
43686 MKERR=0
43687 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR.
43688 &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4)
43689 &MKERR=1
43690 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
43691 PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2))
43692 PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2))
43693 X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
43694 CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4)
43695 IF(ABS(CTHE4).GE.1.002D0) MKERR=1
43696 CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
43697 STHE4=SQRT(1D0-CTHE4**2)
43698 CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2)
43699 IF(ABS(CTHE2).GE.1.002D0) MKERR=1
43700 CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
43701 STHE2=SQRT(1D0-CTHE2**2)
43702 CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/
43703 &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4)
43704 IF(ABS(CPHI2).GE.1.05D0) MKERR=1
43705 CPHI2=MAX(-1D0,MIN(1D0,CPHI2))
43706 IF(MKERR.EQ.1) CALL PYERRM(13,
43707 &'(PY4ENT:) unphysical kinematical variable setup')
43708
43709C...Store partons/particles in P vectors.
43710 P(IPA,3)=PA1
43711 P(IPA,4)=SQRT(PA1**2+PM1**2)
43712 P(IPA,5)=PM1
43713 P(IPA+3,1)=PA4*STHE4
43714 P(IPA+3,3)=PA4*CTHE4
43715 P(IPA+3,4)=SQRT(PA4**2+PM4**2)
43716 P(IPA+3,5)=PM4
43717 P(IPA+1,1)=PA2*STHE2*CPHI2
43718 P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0)
43719 P(IPA+1,3)=PA2*CTHE2
43720 P(IPA+1,4)=SQRT(PA2**2+PM2**2)
43721 P(IPA+1,5)=PM2
43722 P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
43723 P(IPA+2,2)=-P(IPA+1,2)
43724 P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
43725 P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
43726 P(IPA+2,5)=PM3
43727
43728C...Set N. Optionally fragment/decay.
43729 N=IPA+3
43730 IF(IP.EQ.0) CALL PYEXEC
43731
43732 RETURN
43733 END
43734
43735C*********************************************************************
43736
43737C...PY2FRM
43738C...An interface from a two-fermion generator to include
43739C...parton showers and hadronization.
43740
43741 SUBROUTINE PY2FRM(IRAD,ITAU,ICOM)
43742
43743C...Double precision and integer declarations.
43744 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43745 IMPLICIT INTEGER(I-N)
43746 INTEGER PYK,PYCHGE,PYCOMP
43747C...Commonblocks.
43748 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43749 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43750 SAVE /PYJETS/,/PYDAT1/
43751C...Local arrays.
43752 DIMENSION IJOIN(2),INTAU(2)
43753
43754C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
43755 IF(ICOM.EQ.0) THEN
43756 MSTU(28)=0
43757 CALL PYHEPC(2)
43758 ENDIF
43759
43760C...Loop through entries and pick up all final fermions/antifermions.
43761 I1=0
43762 I2=0
43763 DO 100 I=1,N
43764 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
43765 KFA=IABS(K(I,2))
43766 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
43767 IF(K(I,2).GT.0) THEN
43768 IF(I1.EQ.0) THEN
43769 I1=I
43770 ELSE
43771 CALL PYERRM(16,'(PY2FRM:) more than one fermion')
43772 ENDIF
43773 ELSE
43774 IF(I2.EQ.0) THEN
43775 I2=I
43776 ELSE
43777 CALL PYERRM(16,'(PY2FRM:) more than one antifermion')
43778 ENDIF
43779 ENDIF
43780 ENDIF
43781 100 CONTINUE
43782
43783C...Check that event is arranged according to conventions.
43784 IF(I1.EQ.0.OR.I2.EQ.0) THEN
43785 CALL PYERRM(16,'(PY2FRM:) event contains too few fermions')
43786 ENDIF
43787 IF(I2.LT.I1) THEN
43788 CALL PYERRM(6,'(PY2FRM:) fermions arranged in wrong order')
43789 ENDIF
43790
43791C...Check whether fermion pair is quarks or leptons.
43792 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
43793 IQL12=1
43794 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
43795 IQL12=2
43796 ELSE
43797 CALL PYERRM(16,'(PY2FRM:) fermion pair inconsistent')
43798 ENDIF
43799
43800C...Decide whether to allow or not photon radiation in showers.
43801 MSTJ(41)=2
43802 IF(IRAD.EQ.0) MSTJ(41)=1
43803
43804C...Do colour joining and parton showers.
43805 IP1=I1
43806 IP2=I2
43807 IF(IQL12.EQ.1) THEN
43808 IJOIN(1)=IP1
43809 IJOIN(2)=IP2
43810 CALL PYJOIN(2,IJOIN)
43811 ENDIF
43812 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
43813 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
43814 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
43815 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
43816 ENDIF
43817
43818C...Do fragmentation and decays. Possibly except tau decay.
43819 IF(ITAU.EQ.0) THEN
43820 NTAU=0
43821 DO 110 I=1,N
43822 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
43823 NTAU=NTAU+1
43824 INTAU(NTAU)=I
43825 K(I,1)=11
43826 ENDIF
43827 110 CONTINUE
43828 ENDIF
43829 CALL PYEXEC
43830 IF(ITAU.EQ.0) THEN
43831 DO 120 I=1,NTAU
43832 K(INTAU(I),1)=1
43833 120 CONTINUE
43834 ENDIF
43835
43836C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
43837 IF(ICOM.EQ.0) THEN
43838 MSTU(28)=0
43839 CALL PYHEPC(1)
43840 ENDIF
43841
43842 END
43843
43844C*********************************************************************
43845
43846C...PY4FRM
43847C...An interface from a four-fermion generator to include
43848C...parton showers and hadronization.
43849
43850 SUBROUTINE PY4FRM(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)
43851
43852C...Double precision and integer declarations.
43853 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43854 IMPLICIT INTEGER(I-N)
43855 INTEGER PYK,PYCHGE,PYCOMP
43856C...Commonblocks.
43857 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43858 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43859 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
43860 COMMON/PYINT1/MINT(400),VINT(400)
43861 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
43862C...Local arrays.
43863 DIMENSION IJOIN(2),INTAU(4)
43864
43865C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
43866 IF(ICOM.EQ.0) THEN
43867 MSTU(28)=0
43868 CALL PYHEPC(2)
43869 ENDIF
43870
43871C...Loop through entries and pick up all final fermions/antifermions.
43872 I1=0
43873 I2=0
43874 I3=0
43875 I4=0
43876 DO 100 I=1,N
43877 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
43878 KFA=IABS(K(I,2))
43879 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
43880 IF(K(I,2).GT.0) THEN
43881 IF(I1.EQ.0) THEN
43882 I1=I
43883 ELSEIF(I3.EQ.0) THEN
43884 I3=I
43885 ELSE
43886 CALL PYERRM(16,'(PY4FRM:) more than two fermions')
43887 ENDIF
43888 ELSE
43889 IF(I2.EQ.0) THEN
43890 I2=I
43891 ELSEIF(I4.EQ.0) THEN
43892 I4=I
43893 ELSE
43894 CALL PYERRM(16,'(PY4FRM:) more than two antifermions')
43895 ENDIF
43896 ENDIF
43897 ENDIF
43898 100 CONTINUE
43899
43900C...Check that event is arranged according to conventions.
43901 IF(I3.EQ.0.OR.I4.EQ.0) THEN
43902 CALL PYERRM(16,'(PY4FRM:) event contains too few fermions')
43903 ENDIF
43904 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
43905 CALL PYERRM(6,'(PY4FRM:) fermions arranged in wrong order')
43906 ENDIF
43907
43908C...Check which fermion pairs are quarks and which leptons.
43909 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
43910 IQL12=1
43911 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
43912 IQL12=2
43913 ELSE
43914 CALL PYERRM(16,'(PY4FRM:) first fermion pair inconsistent')
43915 ENDIF
43916 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
43917 IQL34=1
43918 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
43919 IQL34=2
43920 ELSE
43921 CALL PYERRM(16,'(PY4FRM:) second fermion pair inconsistent')
43922 ENDIF
43923
43924C...Decide whether to allow or not photon radiation in showers.
43925 MSTJ(41)=2
43926 IF(IRAD.EQ.0) MSTJ(41)=1
43927
43928C...Decide on dipole pairing.
43929 IP1=I1
43930 IP2=I2
43931 IP3=I3
43932 IP4=I4
43933 IF(IQL12.EQ.IQL34) THEN
43934 R1SQ=A1SQ
43935 R2SQ=A2SQ
43936 DELTA=ATOTSQ-A1SQ-A2SQ
43937 IF(ISTRAT.EQ.1) THEN
43938 IF(DELTA.GT.0D0) R1SQ=R1SQ+DELTA
43939 IF(DELTA.LT.0D0) R2SQ=MAX(0D0,R2SQ+DELTA)
43940 ELSEIF(ISTRAT.EQ.2) THEN
43941 IF(DELTA.GT.0D0) R2SQ=R2SQ+DELTA
43942 IF(DELTA.LT.0D0) R1SQ=MAX(0D0,R1SQ+DELTA)
43943 ENDIF
43944 IF(R2SQ.GT.PYR(0)*(R1SQ+R2SQ)) THEN
43945 IP2=I4
43946 IP4=I2
43947 ENDIF
43948 ENDIF
43949
43950C...If colour reconnection then bookkeep W+W- or Z0Z0
43951C...and copy q qbar q qbar consecutively.
43952 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
43953 K(N+1,1)=11
43954 K(N+1,3)=IP1
43955 K(N+1,4)=N+3
43956 K(N+1,5)=N+4
43957 K(N+2,1)=11
43958 K(N+2,3)=IP3
43959 K(N+2,4)=N+5
43960 K(N+2,5)=N+6
43961 IF(K(IP1,2)+K(IP2,2).EQ.0) THEN
43962 K(N+1,2)=23
43963 K(N+2,2)=23
43964 MINT(1)=22
43965 ELSEIF(PYCHGE(K(IP1,2)).GT.0) THEN
43966 K(N+1,2)=24
43967 K(N+2,2)=-24
43968 MINT(1)=25
43969 ELSE
43970 K(N+1,2)=-24
43971 K(N+2,2)=24
43972 MINT(1)=25
43973 ENDIF
43974 DO 110 J=1,5
43975 K(N+3,J)=K(IP1,J)
43976 K(N+4,J)=K(IP2,J)
43977 K(N+5,J)=K(IP3,J)
43978 K(N+6,J)=K(IP4,J)
43979 P(N+1,J)=P(IP1,J)+P(IP2,J)
43980 P(N+2,J)=P(IP3,J)+P(IP4,J)
43981 P(N+3,J)=P(IP1,J)
43982 P(N+4,J)=P(IP2,J)
43983 P(N+5,J)=P(IP3,J)
43984 P(N+6,J)=P(IP4,J)
43985 V(N+1,J)=V(IP1,J)
43986 V(N+2,J)=V(IP3,J)
43987 V(N+3,J)=V(IP1,J)
43988 V(N+4,J)=V(IP2,J)
43989 V(N+5,J)=V(IP3,J)
43990 V(N+6,J)=V(IP4,J)
43991 110 CONTINUE
43992 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
43993 & P(N+1,3)**2))
43994 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
43995 & P(N+2,3)**2))
43996 K(N+3,3)=N+1
43997 K(N+4,3)=N+1
43998 K(N+5,3)=N+2
43999 K(N+6,3)=N+2
44000C...Remove original q qbar q qbar and update counters.
44001 K(IP1,1)=K(IP1,1)+10
44002 K(IP2,1)=K(IP2,1)+10
44003 K(IP3,1)=K(IP3,1)+10
44004 K(IP4,1)=K(IP4,1)+10
44005 IW1=N+1
44006 IW2=N+2
44007 NSD1=N+2
44008 IP1=N+3
44009 IP2=N+4
44010 IP3=N+5
44011 IP4=N+6
44012 N=N+6
44013 ENDIF
44014
44015C...Do colour joinings and parton showers.
44016 IF(IQL12.EQ.1) THEN
44017 IJOIN(1)=IP1
44018 IJOIN(2)=IP2
44019 CALL PYJOIN(2,IJOIN)
44020 ENDIF
44021 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
44022 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
44023 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
44024 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
44025 ENDIF
44026 NAFT1=N
44027 IF(IQL34.EQ.1) THEN
44028 IJOIN(1)=IP3
44029 IJOIN(2)=IP4
44030 CALL PYJOIN(2,IJOIN)
44031 ENDIF
44032 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
44033 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
44034 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
44035 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
44036 ENDIF
44037
44038C...Optionally do colour reconnection.
44039 MINT(32)=0
44040 MSTI(32)=0
44041 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
44042 CALL PYRECO(IW1,IW2,NSD1,NAFT1)
44043 MSTI(32)=MINT(32)
44044 ENDIF
44045
44046C...Do fragmentation and decays. Possibly except tau decay.
44047 IF(ITAU.EQ.0) THEN
44048 NTAU=0
44049 DO 120 I=1,N
44050 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
44051 NTAU=NTAU+1
44052 INTAU(NTAU)=I
44053 K(I,1)=11
44054 ENDIF
44055 120 CONTINUE
44056 ENDIF
44057 CALL PYEXEC
44058 IF(ITAU.EQ.0) THEN
44059 DO 130 I=1,NTAU
44060 K(INTAU(I),1)=1
44061 130 CONTINUE
44062 ENDIF
44063
44064C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
44065 IF(ICOM.EQ.0) THEN
44066 MSTU(28)=0
44067 CALL PYHEPC(1)
44068 ENDIF
44069
44070 END
44071
44072C*********************************************************************
44073
44074C...PY6FRM
44075C...An interface from a six-fermion generator to include
44076C...parton showers and hadronization.
44077
44078 SUBROUTINE PY6FRM(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)
44079
44080C...Double precision and integer declarations.
44081 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44082 IMPLICIT INTEGER(I-N)
44083 INTEGER PYK,PYCHGE,PYCOMP
44084C...Commonblocks.
44085 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
44086 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44087 SAVE /PYJETS/,/PYDAT1/
44088C...Local arrays.
44089 DIMENSION IJOIN(2),INTAU(6),BETA(3),BETAO(3),BETAN(3)
44090
44091C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
44092 IF(ICOM.EQ.0) THEN
44093 MSTU(28)=0
44094 CALL PYHEPC(2)
44095 ENDIF
44096
44097C...Loop through entries and pick up all final fermions/antifermions.
44098 I1=0
44099 I2=0
44100 I3=0
44101 I4=0
44102 I5=0
44103 I6=0
44104 DO 100 I=1,N
44105 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
44106 KFA=IABS(K(I,2))
44107 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
44108 IF(K(I,2).GT.0) THEN
44109 IF(I1.EQ.0) THEN
44110 I1=I
44111 ELSEIF(I3.EQ.0) THEN
44112 I3=I
44113 ELSEIF(I5.EQ.0) THEN
44114 I5=I
44115 ELSE
44116 CALL PYERRM(16,'(PY6FRM:) more than three fermions')
44117 ENDIF
44118 ELSE
44119 IF(I2.EQ.0) THEN
44120 I2=I
44121 ELSEIF(I4.EQ.0) THEN
44122 I4=I
44123 ELSEIF(I6.EQ.0) THEN
44124 I6=I
44125 ELSE
44126 CALL PYERRM(16,'(PY6FRM:) more than three antifermions')
44127 ENDIF
44128 ENDIF
44129 ENDIF
44130 100 CONTINUE
44131
44132C...Check that event is arranged according to conventions.
44133 IF(I5.EQ.0.OR.I6.EQ.0) THEN
44134 CALL PYERRM(16,'(PY6FRM:) event contains too few fermions')
44135 ENDIF
44136 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3.OR.I5.LT.I4.OR.I6.LT.I5) THEN
44137 CALL PYERRM(6,'(PY6FRM:) fermions arranged in wrong order')
44138 ENDIF
44139
44140C...Check which fermion pairs are quarks and which leptons.
44141 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
44142 IQL12=1
44143 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
44144 IQL12=2
44145 ELSE
44146 CALL PYERRM(16,'(PY6FRM:) first fermion pair inconsistent')
44147 ENDIF
44148 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
44149 IQL34=1
44150 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
44151 IQL34=2
44152 ELSE
44153 CALL PYERRM(16,'(PY6FRM:) second fermion pair inconsistent')
44154 ENDIF
44155 IF(IABS(K(I5,2)).LT.10.AND.IABS(K(I6,2)).LT.10) THEN
44156 IQL56=1
44157 ELSEIF(IABS(K(I5,2)).GT.10.AND.IABS(K(I6,2)).GT.10) THEN
44158 IQL56=2
44159 ELSE
44160 CALL PYERRM(16,'(PY6FRM:) third fermion pair inconsistent')
44161 ENDIF
44162
44163C...Decide whether to allow or not photon radiation in showers.
44164 MSTJ(41)=2
44165 IF(IRAD.EQ.0) MSTJ(41)=1
44166
44167C...Allow dipole pairings only among leptons and quarks separately.
44168 P12D=P12
44169 P13D=0D0
44170 IF(IQL34.EQ.IQL56) P13D=P13
44171 P21D=0D0
44172 IF(IQL12.EQ.IQL34) P21D=P21
44173 P23D=0D0
44174 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P23D=P23
44175 P31D=0D0
44176 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P31D=P31
44177 P32D=0D0
44178 IF(IQL12.EQ.IQL56) P32D=P32
44179
44180C...Decide whether t+tbar.
44181 ITOP=0
44182 IF(PYR(0).LT.PTOP) THEN
44183 ITOP=1
44184
44185C...If t+tbar: reconstruct t's.
44186 IT=N+1
44187 ITB=N+2
44188 DO 110 J=1,5
44189 K(IT,J)=0
44190 K(ITB,J)=0
44191 P(IT,J)=P(I1,J)+P(I3,J)+P(I4,J)
44192 P(ITB,J)=P(I2,J)+P(I5,J)+P(I6,J)
44193 V(IT,J)=0D0
44194 V(ITB,J)=0D0
44195 110 CONTINUE
44196 K(IT,1)=1
44197 K(ITB,1)=1
44198 K(IT,2)=6
44199 K(ITB,2)=-6
44200 P(IT,5)=SQRT(MAX(0D0,P(IT,4)**2-P(IT,1)**2-P(IT,2)**2-
44201 & P(IT,3)**2))
44202 P(ITB,5)=SQRT(MAX(0D0,P(ITB,4)**2-P(ITB,1)**2-P(ITB,2)**2-
44203 & P(ITB,3)**2))
44204 N=N+2
44205
44206C...If t+tbar: colour join t's and let them shower.
44207 IJOIN(1)=IT
44208 IJOIN(2)=ITB
44209 CALL PYJOIN(2,IJOIN)
44210 PMTTS=(P(IT,4)+P(ITB,4))**2-(P(IT,1)+P(ITB,1))**2-
44211 & (P(IT,2)+P(ITB,2))**2-(P(IT,3)+P(ITB,3))**2
44212 CALL PYSHOW(IT,ITB,SQRT(MAX(0D0,PMTTS)))
44213
44214C...If t+tbar: pick up the t's after shower.
44215 ITNEW=IT
44216 ITBNEW=ITB
44217 DO 120 I=ITB+1,N
44218 IF(K(I,2).EQ.6) ITNEW=I
44219 IF(K(I,2).EQ.-6) ITBNEW=I
44220 120 CONTINUE
44221
44222C...If t+tbar: loop over two top systems.
44223 DO 200 IT1=1,2
44224 IF(IT1.EQ.1) THEN
44225 ITO=IT
44226 ITN=ITNEW
44227 IBO=I1
44228 IW1=I3
44229 IW2=I4
44230 ELSE
44231 ITO=ITB
44232 ITN=ITBNEW
44233 IBO=I2
44234 IW1=I5
44235 IW2=I6
44236 ENDIF
44237 IF(IABS(K(IBO,2)).NE.5) CALL PYERRM(6,
44238 & '(PY6FRM:) not b in t decay')
44239
44240C...If t+tbar: find boost from original to new top frame.
44241 DO 130 J=1,3
44242 BETAO(J)=P(ITO,J)/P(ITO,4)
44243 BETAN(J)=P(ITN,J)/P(ITN,4)
44244 130 CONTINUE
44245
44246C...If t+tbar: boost copy of b by t shower and connect it in colour.
44247 N=N+1
44248 IB=N
44249 K(IB,1)=3
44250 K(IB,2)=K(IBO,2)
44251 K(IB,3)=ITN
44252 DO 140 J=1,5
44253 P(IB,J)=P(IBO,J)
44254 V(IB,J)=0D0
44255 140 CONTINUE
44256 CALL PYROBO(IB,IB,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
44257 CALL PYROBO(IB,IB,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
44258 K(IB,4)=MSTU(5)*ITN
44259 K(IB,5)=MSTU(5)*ITN
44260 K(ITN,4)=K(ITN,4)+IB
44261 K(ITN,5)=K(ITN,5)+IB
44262 K(ITN,1)=K(ITN,1)+10
44263 K(IBO,1)=K(IBO,1)+10
44264
44265C...If t+tbar: construct W recoiling against b.
44266 N=N+1
44267 IW=N
44268 DO 150 J=1,5
44269 K(IW,J)=0
44270 V(IW,J)=0D0
44271 150 CONTINUE
44272 K(IW,1)=1
44273 KCHW=PYCHGE(K(IW1,2))+PYCHGE(K(IW2,2))
44274 IF(IABS(KCHW).EQ.3) THEN
44275 K(IW,2)=ISIGN(24,KCHW)
44276 ELSE
44277 CALL PYERRM(16,'(PY6FRM:) fermion pair inconsistent with W')
44278 ENDIF
44279 K(IW,3)=IW1
44280
44281C...If t+tbar: construct W momentum, including boost by t shower.
44282 DO 160 J=1,4
44283 P(IW,J)=P(IW1,J)+P(IW2,J)
44284 160 CONTINUE
44285 P(IW,5)=SQRT(MAX(0D0,P(IW,4)**2-P(IW,1)**2-P(IW,2)**2-
44286 & P(IW,3)**2))
44287 CALL PYROBO(IW,IW,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
44288 CALL PYROBO(IW,IW,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
44289
44290C...If t+tbar: boost b and W to top rest frame.
44291 DO 170 J=1,3
44292 BETA(J)=(P(IB,J)+P(IW,J))/(P(IB,4)+P(IW,4))
44293 170 CONTINUE
44294 CALL PYROBO(IB,IB,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
44295 CALL PYROBO(IW,IW,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
44296
44297C...If t+tbar: let b shower and pick up modified W.
44298 PMTS=(P(IB,4)+P(IW,4))**2-(P(IB,1)+P(IW,1))**2-
44299 & (P(IB,2)+P(IW,2))**2-(P(IB,3)+P(IW,3))**2
44300 CALL PYSHOW(IB,IW,SQRT(MAX(0D0,PMTS)))
44301 DO 180 I=IW,N
44302 IF(IABS(K(I,2)).EQ.24) IWM=I
44303 180 CONTINUE
44304
44305C...If t+tbar: take copy of W decay products.
44306 DO 190 J=1,5
44307 K(N+1,J)=K(IW1,J)
44308 P(N+1,J)=P(IW1,J)
44309 V(N+1,J)=V(IW1,J)
44310 K(N+2,J)=K(IW2,J)
44311 P(N+2,J)=P(IW2,J)
44312 V(N+2,J)=V(IW2,J)
44313 190 CONTINUE
44314 K(IW1,1)=K(IW1,1)+10
44315 K(IW2,1)=K(IW2,1)+10
44316 K(IWM,1)=K(IWM,1)+10
44317 K(IWM,4)=N+1
44318 K(IWM,5)=N+2
44319 K(N+1,3)=IWM
44320 K(N+2,3)=IWM
44321 IF(IT1.EQ.1) THEN
44322 I3=N+1
44323 I4=N+2
44324 ELSE
44325 I5=N+1
44326 I6=N+2
44327 ENDIF
44328 N=N+2
44329
44330C...If t+tbar: boost W decay products, first by effects of t shower,
44331C...then by those of b shower. b and its shower simple boost back.
44332 CALL PYROBO(N-1,N,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
44333 CALL PYROBO(N-1,N,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
44334 CALL PYROBO(N-1,N,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
44335 CALL PYROBO(N-1,N,0D0,0D0,-P(IW,1)/P(IW,4),
44336 & -P(IW,2)/P(IW,4),-P(IW,3)/P(IW,4))
44337 CALL PYROBO(N-1,N,0D0,0D0,P(IWM,1)/P(IWM,4),
44338 & P(IWM,2)/P(IWM,4),P(IWM,3)/P(IWM,4))
44339 CALL PYROBO(IB,IB,0D0,0D0,BETA(1),BETA(2),BETA(3))
44340 CALL PYROBO(IW,N,0D0,0D0,BETA(1),BETA(2),BETA(3))
44341 200 CONTINUE
44342 ENDIF
44343
44344C...Decide on dipole pairing.
44345 IP1=I1
44346 IP3=I3
44347 IP5=I5
44348 PRN=PYR(0)*(P12D+P13D+P21D+P23D+P31D+P32D)
44349 IF(ITOP.EQ.1.OR.PRN.LT.P12D) THEN
44350 IP2=I2
44351 IP4=I4
44352 IP6=I6
44353 ELSEIF(PRN.LT.P12D+P13D) THEN
44354 IP2=I2
44355 IP4=I6
44356 IP6=I4
44357 ELSEIF(PRN.LT.P12D+P13D+P21D) THEN
44358 IP2=I4
44359 IP4=I2
44360 IP6=I6
44361 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D) THEN
44362 IP2=I4
44363 IP4=I6
44364 IP6=I2
44365 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D+P31D) THEN
44366 IP2=I6
44367 IP4=I2
44368 IP6=I4
44369 ELSE
44370 IP2=I6
44371 IP4=I4
44372 IP6=I2
44373 ENDIF
44374
44375C...Do colour joinings and parton showers
44376C...(except ones already made for t+tbar).
44377 IF(ITOP.EQ.0) THEN
44378 IF(IQL12.EQ.1) THEN
44379 IJOIN(1)=IP1
44380 IJOIN(2)=IP2
44381 CALL PYJOIN(2,IJOIN)
44382 ENDIF
44383 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
44384 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
44385 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
44386 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
44387 ENDIF
44388 ENDIF
44389 IF(IQL34.EQ.1) THEN
44390 IJOIN(1)=IP3
44391 IJOIN(2)=IP4
44392 CALL PYJOIN(2,IJOIN)
44393 ENDIF
44394 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
44395 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
44396 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
44397 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
44398 ENDIF
44399 IF(IQL56.EQ.1) THEN
44400 IJOIN(1)=IP5
44401 IJOIN(2)=IP6
44402 CALL PYJOIN(2,IJOIN)
44403 ENDIF
44404 IF(IQL56.EQ.1.OR.IRAD.EQ.1) THEN
44405 PM56S=(P(IP5,4)+P(IP6,4))**2-(P(IP5,1)+P(IP6,1))**2-
44406 & (P(IP5,2)+P(IP6,2))**2-(P(IP5,3)+P(IP6,3))**2
44407 CALL PYSHOW(IP5,IP6,SQRT(MAX(0D0,PM56S)))
44408 ENDIF
44409
44410C...Do fragmentation and decays. Possibly except tau decay.
44411 IF(ITAU.EQ.0) THEN
44412 NTAU=0
44413 DO 210 I=1,N
44414 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
44415 NTAU=NTAU+1
44416 INTAU(NTAU)=I
44417 K(I,1)=11
44418 ENDIF
44419 210 CONTINUE
44420 ENDIF
44421 CALL PYEXEC
44422 IF(ITAU.EQ.0) THEN
44423 DO 220 I=1,NTAU
44424 K(INTAU(I),1)=1
44425 220 CONTINUE
44426 ENDIF
44427
44428C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
44429 IF(ICOM.EQ.0) THEN
44430 MSTU(28)=0
44431 CALL PYHEPC(1)
44432 ENDIF
44433
44434 END
44435
44436C*********************************************************************
44437
44438C...PY4JET
44439C...An interface from a four-parton generator to include
44440C...parton showers and hadronization.
44441
44442 SUBROUTINE PY4JET(PMAX,IRAD,ICOM)
44443
44444C...Double precision and integer declarations.
44445 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44446 IMPLICIT INTEGER(I-N)
44447 INTEGER PYK,PYCHGE,PYCOMP
44448C...Commonblocks.
44449 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
44450 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44451 SAVE /PYJETS/,/PYDAT1/
44452C...Local arrays.
44453 DIMENSION IJOIN(2),PTOT(4),BETA(3)
44454
44455C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
44456 IF(ICOM.EQ.0) THEN
44457 MSTU(28)=0
44458 CALL PYHEPC(2)
44459 ENDIF
44460
44461C...Loop through entries and pick up all final partons.
44462 I1=0
44463 I2=0
44464 I3=0
44465 I4=0
44466 DO 100 I=1,N
44467 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
44468 KFA=IABS(K(I,2))
44469 IF((KFA.GE.1.AND.KFA.LE.6).OR.KFA.EQ.21) THEN
44470 IF(K(I,2).GT.0.AND.K(I,2).LE.6) THEN
44471 IF(I1.EQ.0) THEN
44472 I1=I
44473 ELSEIF(I3.EQ.0) THEN
44474 I3=I
44475 ELSE
44476 CALL PYERRM(16,'(PY4JET:) more than two quarks')
44477 ENDIF
44478 ELSEIF(K(I,2).LT.0) THEN
44479 IF(I2.EQ.0) THEN
44480 I2=I
44481 ELSEIF(I4.EQ.0) THEN
44482 I4=I
44483 ELSE
44484 CALL PYERRM(16,'(PY4JET:) more than two antiquarks')
44485 ENDIF
44486 ELSE
44487 IF(I3.EQ.0) THEN
44488 I3=I
44489 ELSEIF(I4.EQ.0) THEN
44490 I4=I
44491 ELSE
44492 CALL PYERRM(16,'(PY4JET:) more than two gluons')
44493 ENDIF
44494 ENDIF
44495 ENDIF
44496 100 CONTINUE
44497
44498C...Check that event is arranged according to conventions.
44499 IF(I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0.OR.I4.EQ.0) THEN
44500 CALL PYERRM(16,'(PY4JET:) event contains too few partons')
44501 ENDIF
44502 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
44503 CALL PYERRM(6,'(PY4JET:) partons arranged in wrong order')
44504 ENDIF
44505
44506C...Check whether second pair are quarks or gluons.
44507 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
44508 IQG34=1
44509 ELSEIF(K(I3,2).EQ.21.AND.K(I4,2).EQ.21) THEN
44510 IQG34=2
44511 ELSE
44512 CALL PYERRM(16,'(PY4JET:) second parton pair inconsistent')
44513 ENDIF
44514
44515C...Boost partons to their cm frame.
44516 DO 110 J=1,4
44517 PTOT(J)=P(I1,J)+P(I2,J)+P(I3,J)+P(I4,J)
44518 110 CONTINUE
44519 ECM=SQRT(MAX(0D0,PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2))
44520 DO 120 J=1,3
44521 BETA(J)=PTOT(J)/PTOT(4)
44522 120 CONTINUE
44523 CALL PYROBO(I1,I1,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
44524 CALL PYROBO(I2,I2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
44525 CALL PYROBO(I3,I3,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
44526 CALL PYROBO(I4,I4,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
44527 NSAV=N
44528
44529C...Decide and set up shower history for q qbar q' qbar' events.
44530 IF(IQG34.EQ.1) THEN
44531 W1=PY4JTW(0,I1,I3,I4)
44532 W2=PY4JTW(0,I2,I3,I4)
44533 IF(W1.GT.PYR(0)*(W1+W2)) THEN
44534 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
44535 ELSE
44536 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
44537 ENDIF
44538
44539C...Decide and set up shower history for q qbar g g events.
44540 ELSE
44541 W1=PY4JTW(I1,I3,I2,I4)
44542 W2=PY4JTW(I1,I4,I2,I3)
44543 W3=PY4JTW(0,I3,I1,I4)
44544 W4=PY4JTW(0,I4,I1,I3)
44545 W5=PY4JTW(0,I3,I2,I4)
44546 W6=PY4JTW(0,I4,I2,I3)
44547 W7=PY4JTW(0,I1,I3,I4)
44548 W8=PY4JTW(0,I2,I3,I4)
44549 WR=(W1+W2+W3+W4+W5+W6+W7+W8)*PYR(0)
44550 IF(W1.GT.WR) THEN
44551 CALL PY4JTS(I1,I3,I2,I4,0,QMAX)
44552 ELSEIF(W1+W2.GT.WR) THEN
44553 CALL PY4JTS(I1,I4,I2,I3,0,QMAX)
44554 ELSEIF(W1+W2+W3.GT.WR) THEN
44555 CALL PY4JTS(0,I3,I1,I4,I2,QMAX)
44556 ELSEIF(W1+W2+W3+W4.GT.WR) THEN
44557 CALL PY4JTS(0,I4,I1,I3,I2,QMAX)
44558 ELSEIF(W1+W2+W3+W4+W5.GT.WR) THEN
44559 CALL PY4JTS(0,I3,I2,I4,I1,QMAX)
44560 ELSEIF(W1+W2+W3+W4+W5+W6.GT.WR) THEN
44561 CALL PY4JTS(0,I4,I2,I3,I1,QMAX)
44562 ELSEIF(W1+W2+W3+W4+W5+W6+W7.GT.WR) THEN
44563 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
44564 ELSE
44565 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
44566 ENDIF
44567 ENDIF
44568
44569C...Boost back original partons and mark them as deleted.
44570 CALL PYROBO(I1,I1,0D0,0D0,BETA(1),BETA(2),BETA(3))
44571 CALL PYROBO(I2,I2,0D0,0D0,BETA(1),BETA(2),BETA(3))
44572 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
44573 CALL PYROBO(I4,I4,0D0,0D0,BETA(1),BETA(2),BETA(3))
44574 K(I1,1)=K(I1,1)+10
44575 K(I2,1)=K(I2,1)+10
44576 K(I3,1)=K(I3,1)+10
44577 K(I4,1)=K(I4,1)+10
44578
44579C...Rotate shower initiating partons to be along z axis.
44580 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
44581 CALL PYROBO(NSAV+1,NSAV+6,0D0,-PHI,0D0,0D0,0D0)
44582 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
44583 CALL PYROBO(NSAV+1,NSAV+6,-THE,0D0,0D0,0D0,0D0)
44584
44585C...Set up copy of shower initiating partons as on mass shell.
44586 DO 140 I=N+1,N+2
44587 DO 130 J=1,5
44588 K(I,J)=0
44589 P(I,J)=0D0
44590 V(I,J)=V(I1,J)
44591 130 CONTINUE
44592 K(I,1)=1
44593 K(I,2)=K(I-6,2)
44594 140 CONTINUE
44595 IF(K(NSAV+1,2).EQ.K(I1,2)) THEN
44596 K(N+1,3)=I1
44597 P(N+1,5)=P(I1,5)
44598 K(N+2,3)=I2
44599 P(N+2,5)=P(I2,5)
44600 ELSE
44601 K(N+1,3)=I2
44602 P(N+1,5)=P(I2,5)
44603 K(N+2,3)=I1
44604 P(N+2,5)=P(I1,5)
44605 ENDIF
44606 PABS=SQRT(MAX(0D0,(ECM**2-P(N+1,5)**2-P(N+2,5)**2)**2-
44607 &(2D0*P(N+1,5)*P(N+2,5))**2))/(2D0*ECM)
44608 P(N+1,3)=PABS
44609 P(N+1,4)=SQRT(PABS**2+P(N+1,5)**2)
44610 P(N+2,3)=-PABS
44611 P(N+2,4)=SQRT(PABS**2+P(N+2,5)**2)
44612 N=N+2
44613
44614C...Decide whether to allow or not photon radiation in showers.
44615C...Connect up colours.
44616 MSTJ(41)=2
44617 IF(IRAD.EQ.0) MSTJ(41)=1
44618 IJOIN(1)=N-1
44619 IJOIN(2)=N
44620 CALL PYJOIN(2,IJOIN)
44621
44622C...Decide on maximum virtuality and do parton shower.
44623 IF(PMAX.LT.PARJ(82)) THEN
44624 PQMAX=QMAX
44625 ELSE
44626 PQMAX=PMAX
44627 ENDIF
44628 CALL PYSHOW(NSAV+1,-8,PQMAX)
44629
44630C...Rotate and boost back system.
44631 CALL PYROBO(NSAV+1,N,THE,PHI,BETA(1),BETA(2),BETA(3))
44632
44633C...Do fragmentation and decays.
44634 CALL PYEXEC
44635
44636C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
44637 IF(ICOM.EQ.0) THEN
44638 MSTU(28)=0
44639 CALL PYHEPC(1)
44640 ENDIF
44641
44642 RETURN
44643 END
44644
44645C*********************************************************************
44646
44647C...PY4JTW
44648C...Auxiliary to PY4JET, to evaluate weight of configuration.
44649
44650 FUNCTION PY4JTW(IA1,IA2,IA3,IA4)
44651
44652C...Double precision and integer declarations.
44653 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44654 IMPLICIT INTEGER(I-N)
44655 INTEGER PYK,PYCHGE,PYCOMP
44656C...Commonblocks.
44657 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
44658 SAVE /PYJETS/
44659
44660C...First case: when both original partons radiate.
44661C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4.
44662 IF(IA1.NE.0) THEN
44663 DO 100 J=1,4
44664 P(N+1,J)=P(IA1,J)+P(IA2,J)
44665 P(N+2,J)=P(IA3,J)+P(IA4,J)
44666 100 CONTINUE
44667 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
44668 & P(N+1,3)**2))
44669 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
44670 & P(N+2,3)**2))
44671 Z1=P(IA1,4)/P(N+1,4)
44672 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-P(IA1,5)**2)
44673 Z2=P(IA3,4)/P(N+2,4)
44674 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-P(IA3,5)**2)
44675
44676C...Second case: when one original parton radiates to three.
44677C...IA1 = 0: N+1 -> IA2 + N+2, N+2 -> IA3 + IA4.
44678 ELSE
44679 DO 110 J=1,4
44680 P(N+2,J)=P(IA3,J)+P(IA4,J)
44681 P(N+1,J)=P(N+2,J)+P(IA2,J)
44682 110 CONTINUE
44683 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
44684 & P(N+1,3)**2))
44685 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
44686 & P(N+2,3)**2))
44687 IF(K(IA2,2).EQ.21) THEN
44688 Z1=P(N+2,4)/P(N+1,4)
44689 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
44690 & P(IA3,5)**2)
44691 ELSE
44692 Z1=P(IA2,4)/P(N+1,4)
44693 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
44694 & P(IA2,5)**2)
44695 ENDIF
44696 Z2=P(IA3,4)/P(N+2,4)
44697 IF(K(IA2,2).EQ.21) THEN
44698 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-
44699 & P(IA3,5)**2)
44700 ELSEIF(K(IA3,2).EQ.21) THEN
44701 WT2=3D0*((1D0-Z2*(1D0-Z2))**2/(Z2*(1D0-Z2)))/P(N+2,5)**2
44702 ELSE
44703 WT2=0.5D0*(Z2**2+(1D0-Z2)**2)
44704 ENDIF
44705 ENDIF
44706
44707C...Total weight.
44708 PY4JTW=WT1*WT2
44709
44710 RETURN
44711 END
44712
44713C*********************************************************************
44714
44715C...PY4JTS
44716C...Auxiliary to PY4JET, to set up chosen configuration.
44717
44718 SUBROUTINE PY4JTS(IA1,IA2,IA3,IA4,IA5,QMAX)
44719
44720C...Double precision and integer declarations.
44721 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44722 IMPLICIT INTEGER(I-N)
44723 INTEGER PYK,PYCHGE,PYCOMP
44724C...Commonblocks.
44725 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
44726 SAVE /PYJETS/
44727
44728C...Reset info.
44729 DO 110 I=N+1,N+6
44730 DO 100 J=1,5
44731 K(I,J)=0
44732 V(I,J)=V(IA2,J)
44733 100 CONTINUE
44734 K(I,1)=16
44735 110 CONTINUE
44736
44737C...First case: when both original partons radiate.
44738C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
44739 IF(IA1.NE.0) THEN
44740
44741C...Set up flavour and history pointers for new partons.
44742 K(N+1,2)=K(IA1,2)
44743 K(N+2,2)=K(IA3,2)
44744 K(N+3,2)=K(IA1,2)
44745 K(N+4,2)=K(IA2,2)
44746 K(N+5,2)=K(IA3,2)
44747 K(N+6,2)=K(IA4,2)
44748 K(N+1,3)=IA1
44749 K(N+1,4)=N+3
44750 K(N+1,5)=N+4
44751 K(N+2,3)=IA3
44752 K(N+2,4)=N+5
44753 K(N+2,5)=N+6
44754 K(N+3,3)=N+1
44755 K(N+4,3)=N+1
44756 K(N+5,3)=N+2
44757 K(N+6,3)=N+2
44758
44759C...Set up momenta for new partons.
44760 DO 120 J=1,5
44761 P(N+1,J)=P(IA1,J)+P(IA2,J)
44762 P(N+2,J)=P(IA3,J)+P(IA4,J)
44763 P(N+3,J)=P(IA1,J)
44764 P(N+4,J)=P(IA2,J)
44765 P(N+5,J)=P(IA3,J)
44766 P(N+6,J)=P(IA4,J)
44767 120 CONTINUE
44768 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
44769 & P(N+1,3)**2))
44770 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
44771 & P(N+2,3)**2))
44772 QMAX=MIN(P(N+1,5),P(N+2,5))
44773
44774C...Second case: q radiates twice.
44775C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
44776C...IA5=N+2 does not radiate.
44777 ELSEIF(K(IA2,2).EQ.21) THEN
44778
44779C...Set up flavour and history pointers for new partons.
44780 K(N+1,2)=K(IA3,2)
44781 K(N+2,2)=K(IA5,2)
44782 K(N+3,2)=K(IA3,2)
44783 K(N+4,2)=K(IA2,2)
44784 K(N+5,2)=K(IA3,2)
44785 K(N+6,2)=K(IA4,2)
44786 K(N+1,3)=IA3
44787 K(N+1,4)=N+3
44788 K(N+1,5)=N+4
44789 K(N+2,3)=IA5
44790 K(N+3,3)=N+1
44791 K(N+3,4)=N+5
44792 K(N+3,5)=N+6
44793 K(N+4,3)=N+1
44794 K(N+5,3)=N+3
44795 K(N+6,3)=N+3
44796
44797C...Set up momenta for new partons.
44798 DO 130 J=1,5
44799 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
44800 P(N+2,J)=P(IA5,J)
44801 P(N+3,J)=P(IA3,J)+P(IA4,J)
44802 P(N+4,J)=P(IA2,J)
44803 P(N+5,J)=P(IA3,J)
44804 P(N+6,J)=P(IA4,J)
44805 130 CONTINUE
44806 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
44807 & P(N+1,3)**2))
44808 P(N+3,5)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,1)**2-P(N+3,2)**2-
44809 & P(N+3,3)**2))
44810 QMAX=P(N+3,5)
44811
44812C...Third case: q radiates g, g branches.
44813C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
44814C...IA5=N+2 does not radiate.
44815 ELSE
44816
44817C...Set up flavour and history pointers for new partons.
44818 K(N+1,2)=K(IA2,2)
44819 K(N+2,2)=K(IA5,2)
44820 K(N+3,2)=K(IA2,2)
44821 K(N+4,2)=21
44822 K(N+5,2)=K(IA3,2)
44823 K(N+6,2)=K(IA4,2)
44824 K(N+1,3)=IA2
44825 K(N+1,4)=N+3
44826 K(N+1,5)=N+4
44827 K(N+2,3)=IA5
44828 K(N+3,3)=N+1
44829 K(N+4,3)=N+1
44830 K(N+4,4)=N+5
44831 K(N+4,5)=N+6
44832 K(N+5,3)=N+4
44833 K(N+6,3)=N+4
44834
44835C...Set up momenta for new partons.
44836 DO 140 J=1,5
44837 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
44838 P(N+2,J)=P(IA5,J)
44839 P(N+3,J)=P(IA2,J)
44840 P(N+4,J)=P(IA3,J)+P(IA4,J)
44841 P(N+5,J)=P(IA3,J)
44842 P(N+6,J)=P(IA4,J)
44843 140 CONTINUE
44844 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
44845 & P(N+1,3)**2))
44846 P(N+4,5)=SQRT(MAX(0D0,P(N+4,4)**2-P(N+4,1)**2-P(N+4,2)**2-
44847 & P(N+4,3)**2))
44848 QMAX=P(N+4,5)
44849
44850 ENDIF
44851 N=N+6
44852
44853 RETURN
44854 END
44855
44856C*********************************************************************
44857
44858C...PYJOIN
44859C...Connects a sequence of partons with colour flow indices,
44860C...as required for subsequent shower evolution (or other operations).
44861
44862 SUBROUTINE PYJOIN(NJOIN,IJOIN)
44863
44864C...Double precision and integer declarations.
44865 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44866 IMPLICIT INTEGER(I-N)
44867 INTEGER PYK,PYCHGE,PYCOMP
44868C...Commonblocks.
44869 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
44870 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44871 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
44872 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
44873C...Local array.
44874 DIMENSION IJOIN(*)
44875
44876C...Check that partons are of right types to be connected.
44877 IF(NJOIN.LT.2) GOTO 120
44878 KQSUM=0
44879 DO 100 IJN=1,NJOIN
44880 I=IJOIN(IJN)
44881 IF(I.LE.0.OR.I.GT.N) GOTO 120
44882 IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
44883 KC=PYCOMP(K(I,2))
44884 IF(KC.EQ.0) GOTO 120
44885 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
44886 IF(KQ.EQ.0) GOTO 120
44887 IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
44888 IF(KQ.NE.2) KQSUM=KQSUM+KQ
44889 IF(IJN.EQ.1) KQS=KQ
44890 100 CONTINUE
44891 IF(KQSUM.NE.0) GOTO 120
44892
44893C...Connect the partons sequentially (closing for gluon loop).
44894 KCS=(9-KQS)/2
44895 IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
44896 DO 110 IJN=1,NJOIN
44897 I=IJOIN(IJN)
44898 K(I,1)=3
44899 IF(IJN.NE.1) IP=IJOIN(IJN-1)
44900 IF(IJN.EQ.1) IP=IJOIN(NJOIN)
44901 IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
44902 IF(IJN.EQ.NJOIN) IN=IJOIN(1)
44903 K(I,KCS)=MSTU(5)*IN
44904 K(I,9-KCS)=MSTU(5)*IP
44905 IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
44906 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
44907 110 CONTINUE
44908
44909C...Error exit: no action taken.
44910 RETURN
44911 120 CALL PYERRM(12,
44912 &'(PYJOIN:) given entries can not be joined by one string')
44913
44914 RETURN
44915 END
44916
44917C*********************************************************************
44918
44919C...PYGIVE
44920C...Sets values of commonblock variables.
44921
44922 SUBROUTINE PYGIVE(CHIN)
44923
44924C...Double precision and integer declarations.
44925 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44926 IMPLICIT INTEGER(I-N)
44927 INTEGER PYK,PYCHGE,PYCOMP
44928C...Commonblocks.
44929 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
44930 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44931 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
44932 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
44933 COMMON/PYDAT4/CHAF(500,2)
44934 CHARACTER CHAF*16
44935 COMMON/PYDATR/MRPY(6),RRPY(100)
44936 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
44937 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
44938 COMMON/PYINT1/MINT(400),VINT(400)
44939 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
44940 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
44941 COMMON/PYINT4/MWID(500),WIDS(500,5)
44942 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
44943 COMMON/PYINT6/PROC(0:500)
44944 CHARACTER PROC*28
44945 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
44946 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
44947 &XPDIR(-6:6)
44948 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
44949 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
44950 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
44951 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
44952 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,
44953 &/PYINT5/,/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/,/PYMSRV/,/PYTCSM/
44954C...Local arrays and character variables.
44955 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
44956 &CHNEW2*28,CHNAM*6,CHVAR(54)*6,CHALP(2)*26,CHIND*8,CHINI*10,
44957 &CHINR*16
44958 DIMENSION MSVAR(54,8)
44959
44960C...For each variable to be translated give: name,
44961C...integer/real/character, no. of indices, lower&upper index bounds.
44962 DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
44963 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
44964 &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
44965 &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
44966 &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
44967 &'XPANH','XPBEH','XPDIR','IMSS','RMSS','RVLAM','RVLAMP','RVLAMB',
44968 &'ITCM','RTCM'/
44969 DATA ((MSVAR(I,J),J=1,8),I=1,54)/ 1,7*0, 1,2,1,4000,1,5,2*0,
44970 &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
44971 &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
44972 &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
44973 &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,8000,1,2,2*0,
44974 &2,1,1,8000,4*0, 1,2,1,8000,1,5,2*0, 3,2,1,500,1,2,2*0,
44975 &1,1,1,6,4*0, 2,1,1,100,4*0,
44976 &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
44977 &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
44978 &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
44979 &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
44980 &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
44981 &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
44982 &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
44983 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
44984 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0,
44985 &2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3,
44986 &1,1,0,99,4*0, 2,1,0,99,4*0/
44987 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
44988 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
44989
44990C...Length of character variable. Subdivide it into instructions.
44991 IF(MSTU(12).GE.1) CALL PYLIST(0)
44992 CHBIT=CHIN//' '
44993 LBIT=101
44994 100 LBIT=LBIT-1
44995 IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
44996 LTOT=0
44997 DO 110 LCOM=1,LBIT
44998 IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
44999 LTOT=LTOT+1
45000 CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
45001 110 CONTINUE
45002 LLOW=0
45003 120 LHIG=LLOW+1
45004 130 LHIG=LHIG+1
45005 IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
45006 LBIT=LHIG-LLOW-1
45007 CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
45008
45009C...Peel off any text following exclamation mark.
45010 LHIG2=LBIT
45011 DO 140 LLOW2=LHIG2,1,-1
45012 IF(CHBIT(LLOW2:LLOW2).EQ.'!') LBIT=LLOW2-1
45013 140 CONTINUE
45014 IF(LBIT.EQ.0) RETURN
45015
45016C...Identify commonblock variable.
45017 LNAM=1
45018 150 LNAM=LNAM+1
45019 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
45020 &LNAM.LE.6) GOTO 150
45021 CHNAM=CHBIT(1:LNAM-1)//' '
45022 DO 170 LCOM=1,LNAM-1
45023 DO 160 LALP=1,26
45024 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
45025 & CHALP(2)(LALP:LALP)
45026 160 CONTINUE
45027 170 CONTINUE
45028 IVAR=0
45029 DO 180 IV=1,54
45030 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
45031 180 CONTINUE
45032 IF(IVAR.EQ.0) THEN
45033 CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM)
45034 LLOW=LHIG
45035 IF(LLOW.LT.LTOT) GOTO 120
45036 RETURN
45037 ENDIF
45038
45039C...Identify any indices.
45040 I1=0
45041 I2=0
45042 I3=0
45043 NINDX=0
45044 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
45045 LIND=LNAM
45046 190 LIND=LIND+1
45047 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
45048 CHIND=' '
45049 IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c')
45050 & .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17.OR.
45051 & IVAR.EQ.37)) THEN
45052 CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
45053 READ(CHIND,'(I8)') KF
45054 I1=PYCOMP(KF)
45055 ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
45056 & 'c') THEN
45057 CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '//
45058 & CHNAM)
45059 LLOW=LHIG
45060 IF(LLOW.LT.LTOT) GOTO 120
45061 RETURN
45062 ELSE
45063 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
45064 READ(CHIND,'(I8)') I1
45065 ENDIF
45066 LNAM=LIND
45067 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
45068 NINDX=1
45069 ENDIF
45070 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
45071 LIND=LNAM
45072 200 LIND=LIND+1
45073 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
45074 CHIND=' '
45075 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
45076 READ(CHIND,'(I8)') I2
45077 LNAM=LIND
45078 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
45079 NINDX=2
45080 ENDIF
45081 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
45082 LIND=LNAM
45083 210 LIND=LIND+1
45084 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 210
45085 CHIND=' '
45086 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
45087 READ(CHIND,'(I8)') I3
45088 LNAM=LIND+1
45089 NINDX=3
45090 ENDIF
45091
45092C...Check that indices allowed.
45093 IERR=0
45094 IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
45095 IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
45096 &IERR=2
45097 IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
45098 &IERR=3
45099 IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
45100 &IERR=4
45101 IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
45102 IF(IERR.GE.1) THEN
45103 CALL PYERRM(18,'(PYGIVE:) unallowed indices for '//
45104 & CHBIT(1:LNAM-1))
45105 LLOW=LHIG
45106 IF(LLOW.LT.LTOT) GOTO 120
45107 RETURN
45108 ENDIF
45109
45110C...Save old value of variable.
45111 IF(IVAR.EQ.1) THEN
45112 IOLD=N
45113 ELSEIF(IVAR.EQ.2) THEN
45114 IOLD=K(I1,I2)
45115 ELSEIF(IVAR.EQ.3) THEN
45116 ROLD=P(I1,I2)
45117 ELSEIF(IVAR.EQ.4) THEN
45118 ROLD=V(I1,I2)
45119 ELSEIF(IVAR.EQ.5) THEN
45120 IOLD=MSTU(I1)
45121 ELSEIF(IVAR.EQ.6) THEN
45122 ROLD=PARU(I1)
45123 ELSEIF(IVAR.EQ.7) THEN
45124 IOLD=MSTJ(I1)
45125 ELSEIF(IVAR.EQ.8) THEN
45126 ROLD=PARJ(I1)
45127 ELSEIF(IVAR.EQ.9) THEN
45128 IOLD=KCHG(I1,I2)
45129 ELSEIF(IVAR.EQ.10) THEN
45130 ROLD=PMAS(I1,I2)
45131 ELSEIF(IVAR.EQ.11) THEN
45132 ROLD=PARF(I1)
45133 ELSEIF(IVAR.EQ.12) THEN
45134 ROLD=VCKM(I1,I2)
45135 ELSEIF(IVAR.EQ.13) THEN
45136 IOLD=MDCY(I1,I2)
45137 ELSEIF(IVAR.EQ.14) THEN
45138 IOLD=MDME(I1,I2)
45139 ELSEIF(IVAR.EQ.15) THEN
45140 ROLD=BRAT(I1)
45141 ELSEIF(IVAR.EQ.16) THEN
45142 IOLD=KFDP(I1,I2)
45143 ELSEIF(IVAR.EQ.17) THEN
45144 CHOLD=CHAF(I1,I2)
45145 ELSEIF(IVAR.EQ.18) THEN
45146 IOLD=MRPY(I1)
45147 ELSEIF(IVAR.EQ.19) THEN
45148 ROLD=RRPY(I1)
45149 ELSEIF(IVAR.EQ.20) THEN
45150 IOLD=MSEL
45151 ELSEIF(IVAR.EQ.21) THEN
45152 IOLD=MSUB(I1)
45153 ELSEIF(IVAR.EQ.22) THEN
45154 IOLD=KFIN(I1,I2)
45155 ELSEIF(IVAR.EQ.23) THEN
45156 ROLD=CKIN(I1)
45157 ELSEIF(IVAR.EQ.24) THEN
45158 IOLD=MSTP(I1)
45159 ELSEIF(IVAR.EQ.25) THEN
45160 ROLD=PARP(I1)
45161 ELSEIF(IVAR.EQ.26) THEN
45162 IOLD=MSTI(I1)
45163 ELSEIF(IVAR.EQ.27) THEN
45164 ROLD=PARI(I1)
45165 ELSEIF(IVAR.EQ.28) THEN
45166 IOLD=MINT(I1)
45167 ELSEIF(IVAR.EQ.29) THEN
45168 ROLD=VINT(I1)
45169 ELSEIF(IVAR.EQ.30) THEN
45170 IOLD=ISET(I1)
45171 ELSEIF(IVAR.EQ.31) THEN
45172 IOLD=KFPR(I1,I2)
45173 ELSEIF(IVAR.EQ.32) THEN
45174 ROLD=COEF(I1,I2)
45175 ELSEIF(IVAR.EQ.33) THEN
45176 IOLD=ICOL(I1,I2,I3)
45177 ELSEIF(IVAR.EQ.34) THEN
45178 ROLD=XSFX(I1,I2)
45179 ELSEIF(IVAR.EQ.35) THEN
45180 IOLD=ISIG(I1,I2)
45181 ELSEIF(IVAR.EQ.36) THEN
45182 ROLD=SIGH(I1)
45183 ELSEIF(IVAR.EQ.37) THEN
45184 IOLD=MWID(I1)
45185 ELSEIF(IVAR.EQ.38) THEN
45186 ROLD=WIDS(I1,I2)
45187 ELSEIF(IVAR.EQ.39) THEN
45188 IOLD=NGEN(I1,I2)
45189 ELSEIF(IVAR.EQ.40) THEN
45190 ROLD=XSEC(I1,I2)
45191 ELSEIF(IVAR.EQ.41) THEN
45192 CHOLD2=PROC(I1)
45193 ELSEIF(IVAR.EQ.42) THEN
45194 ROLD=SIGT(I1,I2,I3)
45195 ELSEIF(IVAR.EQ.43) THEN
45196 ROLD=XPVMD(I1)
45197 ELSEIF(IVAR.EQ.44) THEN
45198 ROLD=XPANL(I1)
45199 ELSEIF(IVAR.EQ.45) THEN
45200 ROLD=XPANH(I1)
45201 ELSEIF(IVAR.EQ.46) THEN
45202 ROLD=XPBEH(I1)
45203 ELSEIF(IVAR.EQ.47) THEN
45204 ROLD=XPDIR(I1)
45205 ELSEIF(IVAR.EQ.48) THEN
45206 IOLD=IMSS(I1)
45207 ELSEIF(IVAR.EQ.49) THEN
45208 ROLD=RMSS(I1)
45209 ELSEIF(IVAR.EQ.50) THEN
45210 ROLD=RVLAM(I1,I2,I3)
45211 ELSEIF(IVAR.EQ.51) THEN
45212 ROLD=RVLAMP(I1,I2,I3)
45213 ELSEIF(IVAR.EQ.52) THEN
45214 ROLD=RVLAMB(I1,I2,I3)
45215 ELSEIF(IVAR.EQ.53) THEN
45216 IOLD=ITCM(I1)
45217 ELSEIF(IVAR.EQ.54) THEN
45218 ROLD=RTCM(I1)
45219 ENDIF
45220
45221C...Print current value of variable. Loop back.
45222 IF(LNAM.GE.LBIT) THEN
45223 CHBIT(LNAM:14)=' '
45224 CHBIT(15:60)=' has the value '
45225 IF(MSVAR(IVAR,1).EQ.1) THEN
45226 WRITE(CHBIT(51:60),'(I10)') IOLD
45227 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
45228 WRITE(CHBIT(47:60),'(F14.5)') ROLD
45229 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
45230 CHBIT(53:60)=CHOLD
45231 ELSE
45232 CHBIT(33:60)=CHOLD
45233 ENDIF
45234 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
45235 LLOW=LHIG
45236 IF(LLOW.LT.LTOT) GOTO 120
45237 RETURN
45238 ENDIF
45239
45240C...Read in new variable value.
45241 IF(MSVAR(IVAR,1).EQ.1) THEN
45242 CHINI=' '
45243 CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
45244 READ(CHINI,'(I10)') INEW
45245 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
45246 CHINR=' '
45247 CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
45248 READ(CHINR,*) RNEW
45249 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
45250 CHNEW=CHBIT(LNAM+1:LBIT)//' '
45251 ELSE
45252 CHNEW2=CHBIT(LNAM+1:LBIT)//' '
45253 ENDIF
45254
45255C...Store new variable value.
45256 IF(IVAR.EQ.1) THEN
45257 N=INEW
45258 ELSEIF(IVAR.EQ.2) THEN
45259 K(I1,I2)=INEW
45260 ELSEIF(IVAR.EQ.3) THEN
45261 P(I1,I2)=RNEW
45262 ELSEIF(IVAR.EQ.4) THEN
45263 V(I1,I2)=RNEW
45264 ELSEIF(IVAR.EQ.5) THEN
45265 MSTU(I1)=INEW
45266 ELSEIF(IVAR.EQ.6) THEN
45267 PARU(I1)=RNEW
45268 ELSEIF(IVAR.EQ.7) THEN
45269 MSTJ(I1)=INEW
45270 ELSEIF(IVAR.EQ.8) THEN
45271 PARJ(I1)=RNEW
45272 ELSEIF(IVAR.EQ.9) THEN
45273 KCHG(I1,I2)=INEW
45274 ELSEIF(IVAR.EQ.10) THEN
45275 PMAS(I1,I2)=RNEW
45276 ELSEIF(IVAR.EQ.11) THEN
45277 PARF(I1)=RNEW
45278 ELSEIF(IVAR.EQ.12) THEN
45279 VCKM(I1,I2)=RNEW
45280 ELSEIF(IVAR.EQ.13) THEN
45281 MDCY(I1,I2)=INEW
45282 ELSEIF(IVAR.EQ.14) THEN
45283 MDME(I1,I2)=INEW
45284 ELSEIF(IVAR.EQ.15) THEN
45285 BRAT(I1)=RNEW
45286 ELSEIF(IVAR.EQ.16) THEN
45287 KFDP(I1,I2)=INEW
45288 ELSEIF(IVAR.EQ.17) THEN
45289 CHAF(I1,I2)=CHNEW
45290 ELSEIF(IVAR.EQ.18) THEN
45291 MRPY(I1)=INEW
45292 ELSEIF(IVAR.EQ.19) THEN
45293 RRPY(I1)=RNEW
45294 ELSEIF(IVAR.EQ.20) THEN
45295 MSEL=INEW
45296 ELSEIF(IVAR.EQ.21) THEN
45297 MSUB(I1)=INEW
45298 ELSEIF(IVAR.EQ.22) THEN
45299 KFIN(I1,I2)=INEW
45300 ELSEIF(IVAR.EQ.23) THEN
45301 CKIN(I1)=RNEW
45302 ELSEIF(IVAR.EQ.24) THEN
45303 MSTP(I1)=INEW
45304 ELSEIF(IVAR.EQ.25) THEN
45305 PARP(I1)=RNEW
45306 ELSEIF(IVAR.EQ.26) THEN
45307 MSTI(I1)=INEW
45308 ELSEIF(IVAR.EQ.27) THEN
45309 PARI(I1)=RNEW
45310 ELSEIF(IVAR.EQ.28) THEN
45311 MINT(I1)=INEW
45312 ELSEIF(IVAR.EQ.29) THEN
45313 VINT(I1)=RNEW
45314 ELSEIF(IVAR.EQ.30) THEN
45315 ISET(I1)=INEW
45316 ELSEIF(IVAR.EQ.31) THEN
45317 KFPR(I1,I2)=INEW
45318 ELSEIF(IVAR.EQ.32) THEN
45319 COEF(I1,I2)=RNEW
45320 ELSEIF(IVAR.EQ.33) THEN
45321 ICOL(I1,I2,I3)=INEW
45322 ELSEIF(IVAR.EQ.34) THEN
45323 XSFX(I1,I2)=RNEW
45324 ELSEIF(IVAR.EQ.35) THEN
45325 ISIG(I1,I2)=INEW
45326 ELSEIF(IVAR.EQ.36) THEN
45327 SIGH(I1)=RNEW
45328 ELSEIF(IVAR.EQ.37) THEN
45329 MWID(I1)=INEW
45330 ELSEIF(IVAR.EQ.38) THEN
45331 WIDS(I1,I2)=RNEW
45332 ELSEIF(IVAR.EQ.39) THEN
45333 NGEN(I1,I2)=INEW
45334 ELSEIF(IVAR.EQ.40) THEN
45335 XSEC(I1,I2)=RNEW
45336 ELSEIF(IVAR.EQ.41) THEN
45337 PROC(I1)=CHNEW2
45338 ELSEIF(IVAR.EQ.42) THEN
45339 SIGT(I1,I2,I3)=RNEW
45340 ELSEIF(IVAR.EQ.43) THEN
45341 XPVMD(I1)=RNEW
45342 ELSEIF(IVAR.EQ.44) THEN
45343 XPANL(I1)=RNEW
45344 ELSEIF(IVAR.EQ.45) THEN
45345 XPANH(I1)=RNEW
45346 ELSEIF(IVAR.EQ.46) THEN
45347 XPBEH(I1)=RNEW
45348 ELSEIF(IVAR.EQ.47) THEN
45349 XPDIR(I1)=RNEW
45350 ELSEIF(IVAR.EQ.48) THEN
45351 IMSS(I1)=INEW
45352 ELSEIF(IVAR.EQ.49) THEN
45353 RMSS(I1)=RNEW
45354 ELSEIF(IVAR.EQ.50) THEN
45355 RVLAM(I1,I2,I3)=RNEW
45356 ELSEIF(IVAR.EQ.51) THEN
45357 RVLAMP(I1,I2,I3)=RNEW
45358 ELSEIF(IVAR.EQ.52) THEN
45359 RVLAMB(I1,I2,I3)=RNEW
45360 ELSEIF(IVAR.EQ.53) THEN
45361 ITCM(I1)=INEW
45362 ELSEIF(IVAR.EQ.54) THEN
45363 RTCM(I1)=RNEW
45364 ENDIF
45365
45366C...Write old and new value. Loop back.
45367 CHBIT(LNAM:14)=' '
45368 CHBIT(15:60)=' changed from to '
45369 IF(MSVAR(IVAR,1).EQ.1) THEN
45370 WRITE(CHBIT(33:42),'(I10)') IOLD
45371 WRITE(CHBIT(51:60),'(I10)') INEW
45372 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
45373 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
45374 WRITE(CHBIT(29:42),'(F14.5)') ROLD
45375 WRITE(CHBIT(47:60),'(F14.5)') RNEW
45376 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
45377 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
45378 CHBIT(35:42)=CHOLD
45379 CHBIT(53:60)=CHNEW
45380 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
45381 ELSE
45382 CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
45383 IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
45384 ENDIF
45385 LLOW=LHIG
45386 IF(LLOW.LT.LTOT) GOTO 120
45387
45388C...Format statement for output on unit MSTU(11) (by default 6).
45389 5000 FORMAT(5X,A60)
45390 5100 FORMAT(5X,A88)
45391
45392 RETURN
45393 END
45394
45395C*********************************************************************
45396
45397C...PYEXEC
45398C...Administrates the fragmentation and decay chain.
45399
45400 SUBROUTINE PYEXEC
45401
45402C...Double precision and integer declarations.
45403 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45404 IMPLICIT INTEGER(I-N)
45405 INTEGER PYK,PYCHGE,PYCOMP
45406C...Commonblocks.
45407 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
45408 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45409 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45410 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
45411 COMMON/PYINT4/MWID(500),WIDS(500,5)
45412 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT4/
45413C...Local array.
45414 DIMENSION PS(2,6),IJOIN(100)
2dfa57d1 45415C...Initialize and reset.
45416 MSTU(24)=0
45417 IF(MSTU(12).GE.1) CALL PYLIST(0)
45418 MSTU(29)=0
45419 MSTU(31)=MSTU(31)+1
45420 MSTU(1)=0
45421 MSTU(2)=0
45422 MSTU(3)=0
45423 IF(MSTU(17).LE.0) MSTU(90)=0
45424 MCONS=1
45425
45426C...Sum up momentum, energy and charge for starting entries.
45427 NSAV=N
45428 DO 110 I=1,2
45429 DO 100 J=1,6
45430 PS(I,J)=0D0
45431 100 CONTINUE
45432 110 CONTINUE
45433 DO 130 I=1,N
45434 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
45435 DO 120 J=1,4
45436 PS(1,J)=PS(1,J)+P(I,J)
45437 120 CONTINUE
45438 PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
45439 130 CONTINUE
45440 PARU(21)=PS(1,4)
45441
45442C...Start by all decays of coloured resonances involved in shower.
45443 NORIG=N
45444 DO 140 I=1,NORIG
45445 IF(K(I,1).EQ.3) THEN
45446 KC=PYCOMP(K(I,2))
45447 IF(MWID(KC).NE.0.AND.KCHG(KC,2).NE.0) CALL PYRESD(I)
45448 ENDIF
45449 140 CONTINUE
45450
45451C...Prepare system for subsequent fragmentation/decay.
45452 CALL PYPREP(0)
45453
45454C...Loop through jet fragmentation and particle decays.
45455 MBE=0
45456 150 MBE=MBE+1
45457 IP=0
45458 160 IP=IP+1
45459 KC=0
45460 IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
45461 IF(KC.EQ.0) THEN
45462
45463C...Deal with any remaining undecayed resonance
45464C...(normally the task of PYEVNT, so seldom used).
45465 ELSEIF(MWID(KC).NE.0) THEN
45466 IBEG=IP
45467 IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
45468 IBEG=IP+1
45469 170 IBEG=IBEG-1
45470 IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 170
45471 IF(K(IBEG,1).NE.2) IBEG=IBEG+1
45472 IEND=IP-1
45473 180 IEND=IEND+1
45474 IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 180
45475 IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 180
45476 NJOIN=0
45477 DO 190 I=IBEG,IEND
45478 IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
45479 NJOIN=NJOIN+1
45480 IJOIN(NJOIN)=I
45481 ENDIF
45482 190 CONTINUE
45483 ENDIF
45484 CALL PYRESD(IP)
45485 CALL PYPREP(IBEG)
45486
45487C...Particle decay if unstable and allowed. Save long-lived particle
45488C...decays until second pass after Bose-Einstein effects.
45489 ELSEIF(KCHG(KC,2).EQ.0) THEN
45490 IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
45491 & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
45492 & CALL PYDECY(IP)
45493
45494C...Decay products may develop a shower.
45495 IF(MSTJ(92).GT.0) THEN
45496 IP1=MSTJ(92)
45497 QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
45498 & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
45499 CALL PYSHOW(IP1,IP1+1,QMAX)
45500 CALL PYPREP(IP1)
45501 MSTJ(92)=0
45502 ELSEIF(MSTJ(92).LT.0) THEN
45503 IP1=-MSTJ(92)
45504 CALL PYSHOW(IP1,-3,P(IP,5))
45505 CALL PYPREP(IP1)
45506 MSTJ(92)=0
45507 ENDIF
45508
45509C...Jet fragmentation: string or independent fragmentation.
45510 ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
45511 MFRAG=MSTJ(1)
45512 IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
45513 IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
45514 IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
45515 & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
45516 IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
45517 ENDIF
45518 ENDIF
45519 IF(MFRAG.EQ.1) CALL PYSTRF(IP)
45520 IF(MFRAG.EQ.2) CALL PYINDF(IP)
45521 IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
45522 IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
45523 ENDIF
45524
45525C...Loop back if enough space left in PYJETS and no error abort.
45526 IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
45527 ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
45528 GOTO 160
45529 ELSEIF(IP.LT.N) THEN
45530 CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
45531 ENDIF
45532
45533C...Include simple Bose-Einstein effect parametrization if desired.
45534 IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
45535 CALL PYBOEI(NSAV)
45536 GOTO 150
45537 ENDIF
45538
45539C...Check that momentum, energy and charge were conserved.
45540 DO 210 I=1,N
45541 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 210
45542 DO 200 J=1,4
45543 PS(2,J)=PS(2,J)+P(I,J)
45544 200 CONTINUE
45545 PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
45546 210 CONTINUE
45547 PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
45548 &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
45549 IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
45550 &'(PYEXEC:) four-momentum was not conserved')
45551 IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
45552 &'(PYEXEC:) charge was not conserved')
45553
45554 RETURN
45555 END
45556
45557C*********************************************************************
45558
45559C...PYPREP
45560C...Rearranges partons along strings.
45561C...Special considerations for systems with junctions, with
45562C...possibility of junction-antijunction annihilation.
45563C...Allows small systems to collapse into one or two particles.
45564C...Checks flavours and colour singlet invariant masses.
45565
45566 SUBROUTINE PYPREP(IP)
45567
45568C...Double precision and integer declarations.
45569 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45570 INTEGER PYK,PYCHGE,PYCOMP
45571C...Commonblocks.
45572 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
45573 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45574 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45575 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
45576 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
45577C...Local arrays.
45578 DIMENSION DPS(5),DPC(5),UE(3),PG(5),E1(3),E2(3),E3(3),E4(3),
45579 &ECL(3),IJUNC(10,0:4),IPIECE(30,0:4),KFEND(4),KFQ(4),
45580 &IJUR(4),PJU(4,6),IRNG(4,2),TJJ(2,5),T(5),PUL(3,5),
45581 &IJCP(0:6),TJUOLD(5)
45582
45583C...Function to give four-product.
45584 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)
45585
45586C...Rearrange parton shower product listing along strings: begin loop.
45587 NOLD=N
45588 I1=N
45589 NJUNC=0
45590 NPIECE=0
45591 NJJSTR=0
45592 MSTU32=MSTU(32)+1
45593 DO 170 MQGST=1,3
45594 DO 160 I=MAX(1,IP),N
45595
45596C...Special treatment for junctions
45597 IF(K(I,1).EQ.42) THEN
45598C...First, just store positions
45599 IF (MQGST.EQ.1) THEN
45600 NJUNC=NJUNC+1
45601 IJUNC(NJUNC,0)=I
45602 IJUNC(NJUNC,4)=0
45603C...Then look for junction-junction strings (not detected in the
45604C...main search below).
45605 ELSE IF (MQGST.EQ.2.AND.NPIECE.NE.3*NJUNC) THEN
45606 IF (NJJSTR.EQ.0) THEN
45607 NJJSTR = (3*NJUNC-NPIECE)/2
45608 ENDIF
45609C...Check how many already identified strings end on this junction
45610 ILC=0
45611 DO 100 J=1,NPIECE
45612 IF (IPIECE(J,4).EQ.I) ILC=ILC+1
45613 100 CONTINUE
45614C...If only 2, third one must be to another junction
45615 IF (ILC.EQ.2) THEN
45616C...The colour information in the junction is unreadable for the
45617C...colour space search further down in this routine, so we must
45618C...start on the colour mother of this junction and then "artificially"
45619C...prevent the colour mother from connecting here again.
45620 IA=MOD(K(I,4),MSTU(5))
45621 KCS=4
45622 IF (MOD(MOD(K(I,4)/MSTU(5),MSTU(5)),2).EQ.1) KCS=5
45623 K(IA,KCS) = K(IA,KCS) + MSTU(5)**2
45624 K(I,KCS) = K(I,KCS) + 2*MSTU(5)**2
45625 I1BEG = I1
45626 NSTP = 0
45627 GOTO 150
45628 ELSE IF (ILC.NE.3) THEN
45629C...This could happen if 2 legs of a junction connect to other
45630C...junctions.
45631 CALL PYERRM(12,
45632 & '(PYPREP:) Too many junction-junction strings.')
45633 ENDIF
45634 ENDIF
45635 ENDIF
45636
45637C...Look for coloured string endpoint, or (later) leftover gluon.
45638 IF(K(I,1).NE.3) GOTO 160
45639 KC=PYCOMP(K(I,2))
45640 IF(KC.EQ.0) GOTO 160
45641 KQ=KCHG(KC,2)
45642 IF(KQ.EQ.0.OR.(MQGST.LE.2.AND.KQ.EQ.2)) GOTO 160
45643
45644C...Pick up loose string end.
45645 KCS=4
45646 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
45647 IA=I
45648 IB=I
45649 I1BEG=I1
45650 NSTP=0
45651 110 NSTP=NSTP+1
45652 IF(NSTP.GT.4*N) THEN
45653 CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
45654 RETURN
45655 ENDIF
45656
45657C...Copy undecayed parton. Finished if reached string endpoint.
45658 IF(K(IA,1).EQ.3) THEN
45659 IF(I1.GE.MSTU(4)-MSTU32-5) THEN
45660 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
45661 RETURN
45662 ENDIF
45663 I1=I1+1
45664 K(I1,1)=2
45665 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1
45666 K(I1,2)=K(IA,2)
45667 K(I1,3)=IA
45668 K(I1,4)=0
45669 K(I1,5)=0
45670 DO 120 J=1,5
45671 P(I1,J)=P(IA,J)
45672 V(I1,J)=V(IA,J)
45673 120 CONTINUE
45674 K(IA,1)=K(IA,1)+10
45675 IF(K(I1,1).EQ.1) GOTO 160
45676 ENDIF
45677
45678C...Also finished (for now) if reached junction; then copy to end.
45679 IF(K(IA,1).EQ.42) THEN
45680 NCOPY=I1-I1BEG
45681 IF(I1.GE.MSTU(4)-MSTU32-NCOPY-5) THEN
45682 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
45683 RETURN
45684 ENDIF
45685 IF (MQGST.LE.2.AND.NCOPY.NE.0) THEN
45686 DO 140 ICOPY=1,NCOPY
45687 DO 130 J=1,5
45688 K(MSTU(4)-MSTU32-ICOPY,J)=K(I1BEG+ICOPY,J)
45689 P(MSTU(4)-MSTU32-ICOPY,J)=P(I1BEG+ICOPY,J)
45690 V(MSTU(4)-MSTU32-ICOPY,J)=V(I1BEG+ICOPY,J)
45691 130 CONTINUE
45692 140 CONTINUE
45693 ENDIF
45694 NPIECE=NPIECE+1
45695 IPIECE(NPIECE,0)=I
45696 IPIECE(NPIECE,1)=MSTU32+1
45697 IPIECE(NPIECE,2)=MSTU32+NCOPY
45698 IPIECE(NPIECE,3)=IB
45699 IPIECE(NPIECE,4)=IA
45700 MSTU32=MSTU32+NCOPY
45701 I1=I1BEG
45702 GOTO 160
45703 ENDIF
45704
45705C...GOTO next parton in colour space.
45706 150 IB=IA
45707 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
45708 & .NE.0) THEN
45709 IA=MOD(K(IB,KCS),MSTU(5))
45710 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
45711 MREV=0
45712 ELSE
45713 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
45714 & MSTU(5)).EQ.0) KCS=9-KCS
45715 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
45716 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
45717 MREV=1
45718 ENDIF
45719 IF(IA.LE.0.OR.IA.GT.N) THEN
45720 CALL PYERRM(12,'(PYPREP:) colour rearrangement failed')
45721 RETURN
45722 ENDIF
45723 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
45724 & MSTU(5)).EQ.IB) THEN
45725 IF(MREV.EQ.1) KCS=9-KCS
45726 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
45727 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
45728 ELSE
45729 IF(MREV.EQ.0) KCS=9-KCS
45730 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
45731 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
45732 ENDIF
45733 IF(IA.NE.I) GOTO 110
45734 K(I1,1)=1
45735 160 CONTINUE
45736 170 CONTINUE
45737
45738C...Junction systems remain.
45739 IJU=0
45740 IJUS=0
45741 IJUCNT=0
45742 MREV=0
45743 IJJSTR=0
45744 180 IJUCNT=IJUCNT+1
45745 IF (IJUCNT.LE.NJUNC) THEN
45746C...If we are not processing a j-j string, treat this junction as new.
45747 IF (IJJSTR.EQ.0) THEN
45748 IJU=IJUNC(IJUCNT,0)
45749 MREV=0
45750C...If junction has already been read, ignore it.
45751 IF (IJUNC(IJUCNT,4).EQ.1) GOTO 180
45752C...If we are on a j-j string, goto second j-j junction.
45753 ELSE
45754 IJUCNT=IJUCNT-1
45755 IJU=IJUS
45756 ENDIF
45757C...Mark selected junction read.
45758 DO 190 J=1,NJUNC
45759 IF (IJUNC(J,0).EQ.IJU) IJUNC(J,4)=1
45760 190 CONTINUE
45761
45762C...Determine junction type
45763 ITJUNC = MOD(K(IJU,4)/MSTU(5),MSTU(5))
45764C...Type 1 and 2 junctions: ~chi -> q q q, ~chi -> qbar,qbar,qbar
45765C...Type 3 and 4 junctions: ~qbar -> q q , ~q -> qbar qbar
45766C...Type 5 and 6 junctions: ~g -> q q q, ~g -> qbar qbar qbar
45767 IF (ITJUNC.GE.1.AND.ITJUNC.LE.6) THEN
45768 IHK=0
45769 200 IHK=IHK+1
45770C...Find which quarks belong to given junction.
45771 IF(IHK.EQ.1) IEND=MOD(K(IJU,5),MSTU(5))
45772 IF(IHK.EQ.2) IEND=MOD(K(IJU,5)/MSTU(5),MSTU(5))
45773C...IHK = 3 is special. Either normal string piece, or j-j string.
45774 IF(IHK.EQ.3) THEN
45775 IEND=MOD(K(IJU,4),MSTU(5))
45776 IF (MREV.NE.1) THEN
45777 DO 210 IPC=1,NPIECE
45778C...If there is a j-j string starting on the present junction which has
45779C...zero length, insert next junction immediately.
45780 IF (IPIECE(IPC,0).EQ.IJU.AND.K(IPIECE(IPC,4),1)
45781 & .EQ.42.AND.IPIECE(IPC,1)-1-IPIECE(IPC,2).EQ.0) THEN
45782 IJJSTR = 1
45783 GOTO 250
45784 ENDIF
45785 210 CONTINUE
45786 MREV = 1
45787C...If MREV is 1 and IHK is 3 we are finished with this system.
45788 ELSE
45789 MREV=0
45790 GOTO 180
45791 ENDIF
45792 ENDIF
45793
45794C...If we've gotten this far, then either IHK < 3, or
45795C...an interjunction string exists, or just a third normal string.
45796 IJUNC(IJUCNT,IHK)=0
45797 IJJSTR = 0
45798C..Order pieces belonging to this junction. Also look for j-j.
45799 DO 220 IPC=1,NPIECE
45800 IF (IPIECE(IPC,3).EQ.IEND) IJUNC(IJUCNT,IHK)=IPC
45801 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJUNC(IJUCNT,0)
45802 & .AND.K(IPIECE(IPC,4),1).EQ.42) THEN
45803 IJUNC(IJUCNT,IHK)=IPC
45804 IJJSTR = 1
45805 MREV = 0
45806 ENDIF
45807 220 CONTINUE
45808C...Copy back chains in proper order. MREV=0/1 : descending/ascending
45809 IPC=IJUNC(IJUCNT,IHK)
45810 DO 240 ICP=IPIECE(IPC,1+MREV),IPIECE(IPC,2-MREV),1-2*MREV
45811 I1=I1+1
45812 DO 230 J=1,5
45813 K(I1,J)=K(MSTU(4)-ICP,J)
45814 P(I1,J)=P(MSTU(4)-ICP,J)
45815 V(I1,J)=V(MSTU(4)-ICP,J)
45816 230 CONTINUE
45817 240 CONTINUE
45818 K(I1,1)=2
45819C...Mark last quark.
45820 IF (MREV.EQ.1.AND.IHK.GE.2) K(I1,1)=1
45821C...Do not insert junctions at wrong places.
45822 IF(IHK.LT.2.OR.MREV.NE.0) GOTO 270
45823C...Insert junction.
45824 250 IJUS = IJU
45825 IF (IHK.EQ.3) THEN
45826C...Shift to end junction if a j-j string has been processed.
45827 IF (IJJSTR.NE.0) IJUS = IPIECE(IPC,4)
45828 MREV= 1
45829 ENDIF
45830 I1=I1+1
45831 DO 260 J=1,5
45832 K(I1,J)=0
45833 P(I1,J)=0.
45834 V(I1,J)=0.
45835 260 CONTINUE
45836 K(I1,1)=41
45837 K(IJUS,1)=K(IJUS,1)+10
45838 K(I1,2)=K(IJUS,2)
45839 K(I1,3)=K(IJUS,3)
45840 270 IF (IHK.LT.3) GOTO 200
45841 ELSE
45842 CALL PYERRM(12,'(PYPREP:) Unknown junction type')
45843 ENDIF
45844 IF (IJUCNT.NE.NJUNC) GOTO 180
45845 ENDIF
45846 N=I1
45847
45848C...Rearrange three strings from junction, e.g. in case one has been
45849C...shortened by shower, so the last is the largest-energy one.
45850 IF(NJUNC.GE.1) THEN
45851C...Find systems with exactly one junction.
45852 MJUN1=0
45853 NBEG=NOLD+1
45854 DO 380 I=NOLD+1,N
45855 IF(K(I,1).NE.1.AND.K(I,1).NE.41) THEN
45856 ELSEIF(K(I,1).EQ.41) THEN
45857 MJUN1=MJUN1+1
45858 ELSEIF(K(I,1).EQ.1.AND.MJUN1.NE.1) THEN
45859 MJUN1=0
45860 NBEG=I+1
45861 ELSE
45862 NEND=I
45863C...Sum up energy-momentum in each junction string.
45864 DO 280 J=1,5
45865 PJU(1,J)=0D0
45866 PJU(2,J)=0D0
45867 PJU(3,J)=0D0
45868 280 CONTINUE
45869 NJU=0
45870 DO 300 I1=NBEG,NEND
45871 IF(K(I1,2).NE.21) THEN
45872 NJU=NJU+1
45873 IJUR(NJU)=I1
45874 ENDIF
45875 DO 290 J=1,5
45876 PJU(MIN(NJU,3),J)=PJU(MIN(NJU,3),J)+P(I1,J)
45877 290 CONTINUE
45878 300 CONTINUE
45879C...Find which of them has highest energy (minus mass) in rest frame.
45880 DO 310 J=1,5
45881 PJU(4,J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
45882 310 CONTINUE
45883 PMJU=SQRT(MAX(0D0,PJU(4,4)**2-PJU(4,1)**2-PJU(4,2)**2-
45884 & PJU(4,3)**2))
45885 DO 320 I2=1,3
45886 PJU(I2,6)=(PJU(4,4)*PJU(I2,4)-PJU(4,1)*PJU(I2,1)-
45887 & PJU(4,2)*PJU(I2,2)-PJU(4,3)*PJU(I2,3))/PMJU-PJU(I2,5)
45888 320 CONTINUE
45889 IF(PJU(3,6).LT.MIN(PJU(1,6),PJU(2,6))) THEN
45890C...Decide how to rearrange so that new last has highest energy.
45891 IF(PJU(1,6).LT.PJU(2,6)) THEN
45892 IRNG(1,1)=IJUR(1)
45893 IRNG(1,2)=IJUR(2)-1
45894 IRNG(2,1)=IJUR(4)
45895 IRNG(2,2)=IJUR(3)+1
45896 IRNG(4,1)=IJUR(3)-1
45897 IRNG(4,2)=IJUR(2)
45898 ELSE
45899 IRNG(1,1)=IJUR(4)
45900 IRNG(1,2)=IJUR(3)+1
45901 IRNG(2,1)=IJUR(2)
45902 IRNG(2,2)=IJUR(3)-1
45903 IRNG(4,1)=IJUR(2)-1
45904 IRNG(4,2)=IJUR(1)
45905 ENDIF
45906 IRNG(3,1)=IJUR(3)
45907 IRNG(3,2)=IJUR(3)
45908C...Copy in correct order below bottom of current event record.
45909 I2=N
45910 DO 350 II=1,4
45911 DO 340 I1=IRNG(II,1),IRNG(II,2),
45912 & ISIGN(1,IRNG(II,2)-IRNG(II,1))
45913 I2=I2+1
45914 DO 330 J=1,5
45915 K(I2,J)=K(I1,J)
45916 P(I2,J)=P(I1,J)
45917 V(I2,J)=V(I1,J)
45918 330 CONTINUE
45919 IF(K(I2,1).EQ.1) K(I2,1)=2
45920 340 CONTINUE
45921 350 CONTINUE
45922 K(I2,1)=1
45923C...Copy back up, overwriting but now in correct order.
45924 DO 370 I1=NBEG,NEND
45925 I2=I1-NBEG+N+1
45926 DO 360 J=1,5
45927 K(I1,J)=K(I2,J)
45928 P(I1,J)=P(I2,J)
45929 V(I1,J)=V(I2,J)
45930 360 CONTINUE
45931 370 CONTINUE
45932 ENDIF
45933 MJUN1=0
45934 NBEG=I+1
45935 ENDIF
45936 380 CONTINUE
45937C++SKANDS
45938C...Check whether q-q-j-j-qbar-qbar systems should be collapsed
45939C...to two q-qbar systems.
45940C...(MSTJ(19)=1 forces q-q-j-j-qbar-qbar.)
45941 IF (MSTJ(19).NE.1) THEN
45942 MJUN1 = 0
45943 JJGLUE = 0
45944 NBEG = NOLD+1
45945C...Force collapse when MSTJ(19)=2.
45946 IF (MSTJ(19).EQ.2) THEN
45947 DELMJJ = 1D9
45948 DELMQQ = 0D0
45949 ENDIF
45950C...Find systems with exactly two junctions.
45951 DO 610 I=NOLD+1,N
45952C...Count junctions
45953 IF (K(I,1).EQ.41) THEN
45954 MJUN1 = MJUN1+1
45955C...Check for interjunction gluons
45956 IF (MJUN1.EQ.2.AND.K(I-1,1).NE.41) THEN
45957 JJGLUE = 1
45958 ENDIF
45959 ELSEIF(K(I,1).EQ.1.AND.(MJUN1.NE.2)) THEN
45960C...If end of system reached with either zero or one junction, restart
45961C...with next system.
45962 MJUN1 = 0
45963 JJGLUE = 0
45964 NBEG = I+1
45965 ELSEIF(K(I,1).EQ.1) THEN
45966C...If end of system reached with exactly two junctions, compute string
45967C...length measure for the (q-q-j-j-qbar-qbar) topology and compare with
45968C...length measure for the (q-qbar)(q-qbar) topology.
45969 NEND=I
45970C...Loop down through chain.
45971 ISID=0
45972 DO 390 I1=NBEG,NEND
45973C...Store string piece division locations in event record
45974 IF (K(I1,2).NE.21) THEN
45975 ISID = ISID+1
45976 IJCP(ISID) = I1
45977 ENDIF
45978 390 CONTINUE
45979C...Randomly choose between (1,3)(2,4) and (1,4)(2,3) topologies.
45980 ISW=0
45981 IF (PYR(0).LT.0.5D0) ISW=1
45982C...Randomly choose which qqbar string gets the jj gluons.
45983 IGS=1
45984 IF (PYR(0).GT.0.5D0) IGS=2
45985C...Only compute string lengths when no topology forced.
45986 IF (MSTJ(19).EQ.0) THEN
45987C...Repeat following for each junction
45988 DO 480 IJU=1,2
45989C...Initialize iterative procedure for finding JRF
45990 IJRFIT=0
45991 DO 400 IX=1,3
45992 TJUOLD(IX)=0D0
45993 400 CONTINUE
45994 TJUOLD(4)=1D0
45995C...Start iteration. Sum up momenta in string pieces
45996 410 DO 450 IJS=1,3
45997C...JD=-1 for first junction, +1 for second junction.
45998C...Find out where piece starts and ends and which direction to go.
45999 JD=2*IJU-3
46000 IF (IJS.LE.2) THEN
46001 IA = IJCP((IJU-1)*7 - JD*(IJS+1)) + JD
46002 IB = IJCP((IJU-1)*7 - JD*IJS)
46003 ELSEIF (IJS.EQ.3) THEN
46004 JD =-JD
46005 IA = IJCP((IJU-1)*7 + JD*(IJS)) + JD
46006 IB = IJCP((IJU-1)*7 + JD*(IJS+3))
46007 ENDIF
46008C...Initialize junction pull 4-vector.
46009 DO 420 J=1,5
46010 PUL(IJS,J)=0D0
46011 420 CONTINUE
46012C...Initialize weight
46013 PWT = 0D0
46014 PWTOLD = 0D0
46015C...Sum up (weighted) momenta along each string piece
46016 DO 440 ISP=IA,IB,JD
46017C...If present parton not last in chain
46018 IF (ISP.NE.IA.AND.ISP.NE.IB) THEN
46019C...If last parton was a junction, store present weight
46020 IF (K(ISP-JD,2).EQ.88) THEN
46021 PWTOLD = PWT
46022C...If last parton was a quark, reset to stored weight.
46023 ELSEIF (K(ISP-JD,2).NE.21) THEN
46024 PWT = PWTOLD
46025 ENDIF
46026 ENDIF
46027C...Skip next parton if weight already large
46028 IF (PWT.GT.10D0) GOTO 440
46029C...Compute momentum in TJUOLD frame:
46030 TDP=TJUOLD(1)*P(ISP,1)+TJUOLD(2)*P(ISP,2)+TJUOLD(3
46031 & )*P(ISP,3)
46032 BFC=TDP/(1D0+TJUOLD(4))+P(ISP,4)
46033 DO 430 J=1,3
46034 TMP=P(ISP,J)+TJUOLD(J)*BFC
46035 PUL(IJS,J)=PUL(IJS,J)+TMP*EXP(-PWT)
46036 430 CONTINUE
46037C...Boosted energy
46038 TMP=TJUOLD(4)*P(ISP,4)+TDP
46039 PUL(IJS,4)=PUL(IJS,J)+TMP*EXP(-PWT)
46040C...Update weight
46041 PWT=PWT+TMP/PARJ(48)
46042C...Put |p| rather than m in 5th slot
46043 PUL(IJS,5)=SQRT(PUL(IJS,1)**2+PUL(IJS,2)**2
46044 & +PUL(IJS,3)**2)
46045 440 CONTINUE
46046 450 CONTINUE
46047C...Compute boost
46048 IJRFIT=IJRFIT+1
46049 CALL PYJURF(PUL,T)
46050C...Combine new boost (T) with old boost (TJUOLD)
46051 TMP=T(1)*TJUOLD(1)+T(2)*TJUOLD(2)+T(3)*TJUOLD(3)
46052 DO 460 IX=1,3
46053 TJUOLD(IX)=T(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+T(4
46054 & ))
46055 460 CONTINUE
46056 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)
46057 & **2)
46058C...If last boost small, accept JRF, else iterate.
46059C...Also prevent possibility of infinite loop.
46060 IF (ABS((T(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
46061 & IJRFIT.LT.MSTJ(18))THEN
46062 GOTO 410
46063 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
46064 CALL PYERRM(1,'(PYPREP:) failed to converge on JRF')
46065 ENDIF
46066C...Store final boost, with change of sign since TJJ motion vector.
46067 DO 470 IX=1,3
46068 TJJ(IJU,IX)=-TJUOLD(IX)
46069 470 CONTINUE
46070 TJJ(IJU,4)=SQRT(1D0+TJJ(IJU,1)**2+TJJ(IJU,2)**2
46071 & +TJJ(IJU,3)**2)
46072 480 CONTINUE
46073C...String length measure for (q-qbar)(q-qbar) topology.
46074C...Note only momenta of nearest partons used (since rest of system
46075C...identical).
46076 IF (JJGLUE.EQ.0) THEN
46077 DELMQQ=4D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)*FOUR(IJCP(3)
46078 & -1,IJCP(5-ISW)+1)
46079 ELSE
46080C...Put jj gluons on selected string (IGS selected randomly above).
46081 IF (IGS.EQ.1) THEN
46082 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
46083 & ,IJCP(4+ISW)+1)*FOUR(IJCP(3)-1,IJCP(5-ISW)+1)
46084 ELSE
46085 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)
46086 & *FOUR(IJCP(3)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
46087 & ,IJCP(5-ISW)+1)
46088 ENDIF
46089 ENDIF
46090C...String length measure for q-q-j-j-q-q topology.
46091 T1G1=0D0
46092 T2G2=0D0
46093 T1T2=0D0
46094 T1P1=0D0
46095 T1P2=0D0
46096 T2P3=0D0
46097 T2P4=0D0
46098 ISGN=-1
46099C...Note only momenta of nearest partons used (since rest of system
46100C...identical).
46101 DO 490 IX=1,4
46102 IF (IX.EQ.4) ISGN=1
46103 T1P1=T1P1+ISGN*TJJ(1,IX)*P(IJCP(2)-1,IX)
46104 T1P2=T1P2+ISGN*TJJ(1,IX)*P(IJCP(3)-1,IX)
46105 T2P3=T2P3+ISGN*TJJ(2,IX)*P(IJCP(4)+1,IX)
46106 T2P4=T2P4+ISGN*TJJ(2,IX)*P(IJCP(5)+1,IX)
46107 IF (JJGLUE.EQ.0) THEN
46108C...Junction motion vector dot product gives length when inter-junction
46109C...gluons absent.
46110 T1T2=T1T2+ISGN*TJJ(1,IX)*TJJ(2,IX)
46111 ELSE
46112C...Junction motion vector dot products with gluon momenta give length
46113C...when inter-junction gluons present.
46114 T1G1=T1G1+ISGN*TJJ(1,IX)*P(IJCP(3)+1,IX)
46115 T2G2=T2G2+ISGN*TJJ(2,IX)*P(IJCP(4)-1,IX)
46116 ENDIF
46117 490 CONTINUE
46118 DELMJJ=16D0*T1P1*T1P2*T2P3*T2P4
46119 IF (JJGLUE.EQ.0) THEN
46120 DELMJJ=DELMJJ*(T1T2+SQRT(T1T2**2-1))
46121 ELSE
46122 DELMJJ=DELMJJ*4D0*T1G1*T2G2
46123 ENDIF
46124 ENDIF
46125C...If delmjj > delmqq collapse string system to q-qbar q-qbar
46126C...(Always the case for MSTJ(19)=2 due to initialization above)
46127 IF (DELMJJ.GT.DELMQQ) THEN
46128C...Put new system at end of event record
46129 NCOP=N
46130 DO 560 IST=1,2
46131 DO 510 ICOP=IJCP(IST),IJCP(IST+1)-1
46132 NCOP=NCOP+1
46133 DO 500 IX=1,5
46134 P(NCOP,IX)=P(ICOP,IX)
46135 K(NCOP,IX)=K(ICOP,IX)
46136 500 CONTINUE
46137 510 CONTINUE
46138 IF (JJGLUE.NE.0.AND.IST.EQ.IGS) THEN
46139C...Insert inter-junction gluon string piece (reversed)
46140 NJJGL=0
46141 DO 530 ICOP=IJCP(4)-1,IJCP(3)+1,-1
46142 NJJGL=NJJGL+1
46143 NCOP=NCOP+1
46144 DO 520 IX=1,5
46145 P(NCOP,IX)=P(ICOP,IX)
46146 K(NCOP,IX)=K(ICOP,IX)
46147 520 CONTINUE
46148 530 CONTINUE
46149 ENDIF
46150 IFC=-2*IST+3
46151 DO 550 ICOP=IJCP(IST+IFC*ISW+3)+1,IJCP(IST+IFC*ISW+4)
46152 NCOP=NCOP+1
46153 DO 540 IX=1,5
46154 P(NCOP,IX)=P(ICOP,IX)
46155 K(NCOP,IX)=K(ICOP,IX)
46156 540 CONTINUE
46157 550 CONTINUE
46158 K(NCOP,1)=1
46159 560 CONTINUE
46160C...Copy system back in right order
46161 DO 580 ICOP=NBEG,NEND-2
46162 DO 570 IX=1,5
46163 P(ICOP,IX)=P(N+ICOP-NBEG+1,IX)
46164 K(ICOP,IX)=K(N+ICOP-NBEG+1,IX)
46165 570 CONTINUE
46166 580 CONTINUE
46167C...Shift down rest of event record
46168 DO 600 ICOP=NEND+1,N
46169 DO 590 IX=1,5
46170 P(ICOP-2,IX)=P(ICOP,IX)
46171 K(ICOP-2,IX)=K(ICOP,IX)
46172 590 CONTINUE
46173 600 CONTINUE
46174C...Update length of event record.
46175 N=N-2
46176 ENDIF
46177 MJUN1=0
46178 NBEG=I+1
46179 ENDIF
46180 610 CONTINUE
46181 ENDIF
46182 ENDIF
46183
46184C...Done if no checks on small-mass systems.
46185 IF(MSTJ(14).LT.0) RETURN
46186 IF(MSTJ(14).EQ.0) GOTO 1050
46187
46188C...Find lowest-mass colour singlet jet system.
46189 NS=N
46190 620 NSIN=N-NS
46191 PDMIN=1D0+PARJ(32)
46192 IC=0
46193 DO 680 I=MAX(1,IP),N
46194 IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
46195 ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
46196 NSIN=NSIN+1
46197 IC=I
46198 DO 630 J=1,4
46199 DPS(J)=P(I,J)
46200 630 CONTINUE
46201 MSTJ(93)=1
46202 DPS(5)=PYMASS(K(I,2))
46203 ELSEIF(K(I,1).EQ.2.AND.K(I,2).NE.21) THEN
46204 DO 640 J=1,4
46205 DPS(J)=DPS(J)+P(I,J)
46206 640 CONTINUE
46207 MSTJ(93)=1
46208 DPS(5)=DPS(5)+PYMASS(K(I,2))
46209 ELSEIF(K(I,1).EQ.2) THEN
46210 DO 650 J=1,4
46211 DPS(J)=DPS(J)+P(I,J)
46212 650 CONTINUE
46213 ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
46214 DO 660 J=1,4
46215 DPS(J)=DPS(J)+P(I,J)
46216 660 CONTINUE
46217 MSTJ(93)=1
46218 DPS(5)=DPS(5)+PYMASS(K(I,2))
46219 PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-
46220 & DPS(5)
46221 IF(PD.LT.PDMIN) THEN
46222 PDMIN=PD
46223 DO 670 J=1,5
46224 DPC(J)=DPS(J)
46225 670 CONTINUE
46226 IC1=IC
46227 IC2=I
46228 ENDIF
46229 IC=0
46230 ELSE
46231 NSIN=NSIN+1
46232 ENDIF
46233 680 CONTINUE
46234
46235C...Done if lowest-mass system above threshold for string frag.
46236 IF(PDMIN.GE.PARJ(32)) GOTO 1050
46237
46238C...Fill small-mass system as cluster.
46239 NSAV=N
46240 PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
46241 K(N+1,1)=11
46242 K(N+1,2)=91
46243 K(N+1,3)=IC1
46244 P(N+1,1)=DPC(1)
46245 P(N+1,2)=DPC(2)
46246 P(N+1,3)=DPC(3)
46247 P(N+1,4)=DPC(4)
46248 P(N+1,5)=PECM
46249
46250C...Set up history, assuming cluster -> 2 hadrons.
46251 NBODY=2
46252 K(N+1,4)=N+2
46253 K(N+1,5)=N+3
46254 K(N+2,1)=1
46255 K(N+3,1)=1
46256 IF(MSTU(16).NE.2) THEN
46257 K(N+2,3)=N+1
46258 K(N+3,3)=N+1
46259 ELSE
46260 K(N+2,3)=IC1
46261 K(N+3,3)=IC2
46262 ENDIF
46263 K(N+2,4)=0
46264 K(N+3,4)=0
46265 K(N+2,5)=0
46266 K(N+3,5)=0
46267 V(N+1,5)=0D0
46268 V(N+2,5)=0D0
46269 V(N+3,5)=0D0
46270
46271C...Find total flavour content - complicated by presence of junctions.
46272 NQ=0
46273 NDIQ=0
46274 DO 690 I=IC1,IC2
46275 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.K(I,2).NE.21) THEN
46276 NQ=NQ+1
46277 KFQ(NQ)=K(I,2)
46278 IF(IABS(K(I,2)).GT.1000) NDIQ=NDIQ+1
46279 ENDIF
46280 690 CONTINUE
46281
46282C...If several diquarks, split up one to give even number of flavours.
46283 IF(NQ.EQ.3.AND.NDIQ.GE.2) THEN
46284 I1=3
46285 IF(IABS(KFQ(3)).LT.1000) I1=1
46286 KFQ(4)=ISIGN(MOD(IABS(KFQ(I1))/100,10),KFQ(I1))
46287 KFQ(I1)=KFQ(I1)/1000
46288 NQ=4
46289 NDIQ=NDIQ-1
46290 ENDIF
46291
46292C...If four quark ends, join two to diquark.
46293 IF(NQ.EQ.4.AND.NDIQ.EQ.0) THEN
46294 I1=1
46295 I2=2
46296 IF(KFQ(I1)*KFQ(I2).LT.0) I2=3
46297 IF(I2.EQ.3.AND.KFQ(I1)*KFQ(I2).LT.0) I2=4
46298 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
46299 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
46300 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
46301 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
46302 KFQ(I2)=KFQ(4)
46303 NQ=3
46304 NDIQ=1
46305 ENDIF
46306
46307C...If two quark ends, plus quark or diquark, join quarks to diquark.
46308 IF(NQ.EQ.3) THEN
46309 I1=1
46310 I2=2
46311 IF(IABS(KFQ(I1)).GT.1000) I1=3
46312 IF(IABS(KFQ(I2)).GT.1000) I2=3
46313 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
46314 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
46315 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
46316 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
46317 KFQ(I2)=KFQ(3)
46318 NQ=2
46319 NDIQ=NDIQ+1
46320 ENDIF
46321
46322C...Form two particles from flavours of lowest-mass system, if feasible.
46323 NTRY = 0
46324 700 NTRY = NTRY + 1
46325
46326C...Open string with two specified endpoint flavours.
46327 IF(NQ.EQ.2) THEN
46328 KC1=PYCOMP(KFQ(1))
46329 KC2=PYCOMP(KFQ(2))
46330 IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 1050
46331 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
46332 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
46333 IF(KQ1+KQ2.NE.0) GOTO 1050
46334C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
46335 710 K1=KFQ(1)
46336 IF(IABS(KFQ(2)).GT.1000) K1=KFQ(2)
46337 MSTU(125)=0
46338 CALL PYDCYK(K1,0,KFLN,K(N+2,2))
46339 CALL PYDCYK(KFQ(1)+KFQ(2)-K1,-KFLN,KFLDMP,K(N+3,2))
46340 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 710
46341
46342C...Open string with four specified flavours.
46343 ELSEIF(NQ.EQ.4) THEN
46344 KC1=PYCOMP(KFQ(1))
46345 KC2=PYCOMP(KFQ(2))
46346 KC3=PYCOMP(KFQ(3))
46347 KC4=PYCOMP(KFQ(4))
46348 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) GOTO 1050
46349 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
46350 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
46351 KQ3=KCHG(KC3,2)*ISIGN(1,KFQ(3))
46352 KQ4=KCHG(KC4,2)*ISIGN(1,KFQ(4))
46353 IF(KQ1+KQ2+KQ3+KQ4.NE.0) GOTO 1050
46354C...Combine flavours pairwise to form two hadrons.
46355 720 I1=1
46356 I2=2
46357 IF(KQ1*KQ2.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
46358 & IABS(KFQ(2)).GT.1000)) I2=3
46359 IF(I2.EQ.3.AND.(KQ1*KQ3.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
46360 & IABS(KFQ(3)).GT.1000))) I2=4
46361 I3=3
46362 IF(I2.EQ.3) I3=2
46363 I4=10-I1-I2-I3
46364 CALL PYDCYK(KFQ(I1),KFQ(I2),KFLDMP,K(N+2,2))
46365 CALL PYDCYK(KFQ(I3),KFQ(I4),KFLDMP,K(N+3,2))
46366 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 720
46367
46368C...Closed string.
46369 ELSE
46370 IF(IABS(K(IC2,2)).NE.21) GOTO 1050
46371C...No room for popcorn mesons in closed string -> 2 hadrons.
46372 MSTU(125)=0
46373 730 CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
46374 CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
46375 CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
46376 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 730
46377 ENDIF
46378 P(N+2,5)=PYMASS(K(N+2,2))
46379 P(N+3,5)=PYMASS(K(N+3,2))
46380
46381C...If it does not work: try again (a number of times), give up (if no
46382C...place to shuffle momentum or too many flavours), or form one hadron.
46383 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) THEN
46384 IF(NTRY.LT.MSTJ(17).OR.(NQ.EQ.4.AND.NTRY.LT.5*MSTJ(17))) THEN
46385 GOTO 700
46386 ELSEIF(NSIN.EQ.1.OR.NQ.EQ.4) THEN
46387 GOTO 1050
46388 ELSE
46389 GOTO 800
46390 END IF
46391 END IF
46392
46393C...Perform two-particle decay of jet system.
46394C...First step: find reference axis in decaying system rest frame.
46395C...(Borrow slot N+2 for temporary direction.)
46396 DO 740 J=1,4
46397 P(N+2,J)=P(IC1,J)
46398 740 CONTINUE
46399 DO 760 I=IC1+1,IC2-1
46400 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
46401 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
46402 FRAC1=FOUR(IC2,I)/(FOUR(IC1,I)+FOUR(IC2,I))
46403 DO 750 J=1,4
46404 P(N+2,J)=P(N+2,J)+FRAC1*P(I,J)
46405 750 CONTINUE
46406 ENDIF
46407 760 CONTINUE
46408 CALL PYROBO(N+2,N+2,0D0,0D0,-DPC(1)/DPC(4),-DPC(2)/DPC(4),
46409 &-DPC(3)/DPC(4))
46410 THE1=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
46411 PHI1=PYANGL(P(N+2,1),P(N+2,2))
46412
46413C...Second step: generate isotropic/anisotropic decay.
46414 PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
46415 &(P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
46416 770 UE(3)=PYR(0)
46417 IF(PARJ(21).LE.0.01D0) UE(3)=1D0
46418 PT2=(1D0-UE(3)**2)*PA**2
46419 IF(MSTJ(16).LE.0) THEN
46420 PREV=0.5D0
46421 ELSE
46422 IF(EXP(-PT2/(2D0*MAX(0.01D0,PARJ(21))**2)).LT.PYR(0)) GOTO 770
46423 PR1=P(N+2,5)**2+PT2
46424 PR2=P(N+3,5)**2+PT2
46425 ALAMBD=SQRT(MAX(0D0,(PECM**2-PR1-PR2)**2-4D0*PR1*PR2))
46426 PREVCF=PARJ(42)
46427 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
46428 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*ALAMBD*PARJ(40))))
46429 ENDIF
46430 IF(PYR(0).LT.PREV) UE(3)=-UE(3)
46431 PHI=PARU(2)*PYR(0)
46432 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
46433 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
46434 DO 780 J=1,3
46435 P(N+2,J)=PA*UE(J)
46436 P(N+3,J)=-PA*UE(J)
46437 780 CONTINUE
46438 P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
46439 P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
46440
46441C...Third step: move back to event frame and set production vertex.
46442 CALL PYROBO(N+2,N+3,THE1,PHI1,DPC(1)/DPC(4),DPC(2)/DPC(4),
46443 &DPC(3)/DPC(4))
46444 DO 790 J=1,4
46445 V(N+1,J)=V(IC1,J)
46446 V(N+2,J)=V(IC1,J)
46447 V(N+3,J)=V(IC2,J)
46448 790 CONTINUE
46449 N=N+3
46450 GOTO 1030
46451
46452C...Else form one particle, if possible.
46453 800 NBODY=1
46454 K(N+1,5)=N+2
46455 DO 810 J=1,4
46456 V(N+1,J)=V(IC1,J)
46457 V(N+2,J)=V(IC1,J)
46458 810 CONTINUE
46459
46460C...Select hadron flavour from available quark flavours.
46461 820 IF(NQ.EQ.2.AND.IABS(KFQ(1)).GT.100.AND.IABS(KFQ(2)).GT.100) THEN
46462 GOTO 1050
46463 ELSEIF(NQ.EQ.2) THEN
46464 CALL PYKFDI(KFQ(1),KFQ(2),KFLDMP,K(N+2,2))
46465 ELSE
46466 KFLN=1+INT((2D0+PARJ(2))*PYR(0))
46467 CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
46468 ENDIF
46469 IF(K(N+2,2).EQ.0) GOTO 820
46470 P(N+2,5)=PYMASS(K(N+2,2))
46471
46472C...Use old algorithm for E/p conservation? (EN)
46473 IF (MSTJ(16).LE.0) GOTO 990
46474
46475C...Find the string piece closest to the cluster by a loop
46476C...over the undecayed partons not in present cluster. (EN)
46477 DGLOMI=1D30
46478 IBEG=0
46479 I0=0
46480 NJUNC=0
46481 DO 850 I1=MAX(1,IP),N-1
46482 IF(K(I,1).EQ.1) NJUNC=0
46483 IF(K(I,1).EQ.41) NJUNC=NJUNC+1
46484 IF(I1.GE.IC1-1.AND.I1.LE.IC2) THEN
46485 I0=0
46486 ELSEIF(K(I1,1).EQ.2) THEN
46487 IF(I0.EQ.0) I0=I1
46488 I2=I1
46489 830 I2=I2+1
46490 IF(K(I2,1).EQ.41) GOTO 850
46491 IF(K(I2,1).GT.10) GOTO 830
46492 IF(KCHG(PYCOMP(K(I2,2)),2).EQ.0) GOTO 830
46493 IF(K(I1,2).EQ.21.AND.K(I2,2).NE.21.AND.K(I2,1).NE.1.AND.
46494 & NJUNC.EQ.0) GOTO 850
46495 IF(K(I1,2).NE.21.AND.K(I2,2).EQ.21.AND.NJUNC.NE.0) GOTO 850
46496
46497C...Define velocity vectors e1, e2, ecl and differences e3, e4.
46498 DO 840 J=1,3
46499 E1(J)=P(I1,J)/P(I1,4)
46500 E2(J)=P(I2,J)/P(I2,4)
46501 ECL(J)=P(N+1,J)/P(N+1,4)
46502 E3(J)=E2(J)-E1(J)
46503 E4(J)=ECL(J)-E1(J)
46504 840 CONTINUE
46505
46506C...Calculate minimal D=(e4-alpha*e3)**2 for 0<alpha<1.
46507 E3S=E3(1)**2+E3(2)**2+E3(3)**2
46508 E4S=E4(1)**2+E4(2)**2+E4(3)**2
46509 E34=E3(1)*E4(1)+E3(2)*E4(2)+E3(3)*E4(3)
46510 IF(E34.LE.0D0) THEN
46511 DDMIN=E4S
46512 ELSEIF(E34.LT.E3S) THEN
46513 DDMIN=E4S-E34**2/E3S
46514 ELSE
46515 DDMIN=E4S-2D0*E34+E3S
46516 ENDIF
46517
46518C...Is this the smallest so far?
46519 IF(DDMIN.LT.DGLOMI) THEN
46520 DGLOMI=DDMIN
46521 IBEG=I0
46522 IPCS=I1
46523 ENDIF
46524 ELSEIF(K(I1,1).EQ.1.AND.KCHG(PYCOMP(K(I1,2)),2).NE.0) THEN
46525 I0=0
46526 ENDIF
46527 850 CONTINUE
46528
46529C... Check if there are any strings to connect to the new gluon. (EN)
46530 IF (IBEG.EQ.0) GOTO 990
46531
46532C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
46533 IF (P(N+1,5).GE.P(N+2,5)) THEN
46534
46535C...Construct 'gluon' that is needed to put hadron on the mass shell.
46536 FRAC=P(N+2,5)/P(N+1,5)
46537 DO 860 J=1,5
46538 P(N+2,J)=FRAC*P(N+1,J)
46539 PG(J)=(1D0-FRAC)*P(N+1,J)
46540 860 CONTINUE
46541
46542C... Copy string with new gluon put in.
46543 N=N+2
46544 I=IBEG-1
46545 870 I=I+1
46546 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 870
46547 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 870
46548 N=N+1
46549 DO 880 J=1,5
46550 K(N,J)=K(I,J)
46551 P(N,J)=P(I,J)
46552 V(N,J)=V(I,J)
46553 880 CONTINUE
46554 K(I,1)=K(I,1)+10
46555 K(I,4)=N
46556 K(I,5)=N
46557 K(N,3)=I
46558 IF(I.EQ.IPCS) THEN
46559 N=N+1
46560 DO 890 J=1,5
46561 K(N,J)=K(N-1,J)
46562 P(N,J)=PG(J)
46563 V(N,J)=V(N-1,J)
46564 890 CONTINUE
46565 K(N,2)=21
46566 K(N,3)=NSAV+1
46567 ENDIF
46568 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 870
46569 GOTO 1030
46570
46571C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
46572C...from string piece endpoints.
46573 ELSE
46574
46575C...Begin by copying string that should give energy to cluster.
46576 N=N+2
46577 I=IBEG-1
46578 900 I=I+1
46579 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 900
46580 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 900
46581 N=N+1
46582 DO 910 J=1,5
46583 K(N,J)=K(I,J)
46584 P(N,J)=P(I,J)
46585 V(N,J)=V(I,J)
46586 910 CONTINUE
46587 K(I,1)=K(I,1)+10
46588 K(I,4)=N
46589 K(I,5)=N
46590 K(N,3)=I
46591 IF(I.EQ.IPCS) I1=N
46592 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 900
46593 I2=I1+1
46594
46595C...Set initial Phad.
46596 DO 920 J=1,4
46597 P(NSAV+2,J)=P(NSAV+1,J)
46598 920 CONTINUE
46599
46600C...Calculate Pg, a part of which will be added to Phad later. (EN)
46601 930 IF(MSTJ(16).EQ.1) THEN
46602 ALPHA=1D0
46603 BETA=1D0
46604 ELSE
46605 ALPHA=FOUR(NSAV+1,I2)/FOUR(I1,I2)
46606 BETA=FOUR(NSAV+1,I1)/FOUR(I1,I2)
46607 ENDIF
46608 DO 940 J=1,4
46609 PG(J)=ALPHA*P(I1,J)+BETA*P(I2,J)
46610 940 CONTINUE
46611 PG(5)=SQRT(MAX(1D-20,PG(4)**2-PG(1)**2-PG(2)**2-PG(3)**2))
46612
46613C..Solve 2nd order equation, use the best (smallest) solution. (EN)
46614 PMSCOL=P(NSAV+2,4)**2-P(NSAV+2,1)**2-P(NSAV+2,2)**2-
46615 & P(NSAV+2,3)**2
46616 PCLPG=(P(NSAV+2,4)*PG(4)-P(NSAV+2,1)*PG(1)-
46617 & P(NSAV+2,2)*PG(2)-P(NSAV+2,3)*PG(3))/PG(5)**2
46618 DELTA=SQRT(PCLPG**2+(P(NSAV+2,5)**2-PMSCOL)/PG(5)**2)-PCLPG
46619
46620C...If all gluon energy eaten, zero it and take a step back.
46621 ITER=0
46622 IF(DELTA*ALPHA.GT.1D0.AND.I1.GT.NSAV+3) THEN
46623 ITER=1
46624 DO 950 J=1,4
46625 P(NSAV+2,J)=P(NSAV+2,J)+P(I1,J)
46626 P(I1,J)=0D0
46627 950 CONTINUE
46628 P(I1,5)=0D0
46629 K(I1,1)=K(I1,1)+10
46630 I1=I1-1
46631 IF(K(I1,1).EQ.41) ITER=-1
46632 ENDIF
46633 IF(DELTA*BETA.GT.1D0.AND.I2.LT.N) THEN
46634 ITER=1
46635 DO 960 J=1,4
46636 P(NSAV+2,J)=P(NSAV+2,J)+P(I2,J)
46637 P(I2,J)=0D0
46638 960 CONTINUE
46639 P(I2,5)=0D0
46640 K(I2,1)=K(I2,1)+10
46641 I2=I2+1
46642 IF(K(I2,1).EQ.41) ITER=-1
46643 ENDIF
46644 IF(ITER.EQ.1) GOTO 930
46645
46646C...If also all endpoint energy eaten, revert to old procedure.
46647 IF((1D0-DELTA*ALPHA)*P(I1,4).LT.P(I1,5).OR.
46648 & (1D0-DELTA*BETA)*P(I2,4).LT.P(I2,5).OR.ITER.EQ.-1) THEN
46649 DO 970 I=NSAV+3,N
46650 IM=K(I,3)
46651 K(IM,1)=K(IM,1)-10
46652 K(IM,4)=0
46653 K(IM,5)=0
46654 970 CONTINUE
46655 N=NSAV
46656 GOTO 990
46657 ENDIF
46658
46659C... Construct the collapsed hadron and modified string partons.
46660 DO 980 J=1,4
46661 P(NSAV+2,J)=P(NSAV+2,J)+DELTA*PG(J)
46662 P(I1,J)=(1D0-DELTA*ALPHA)*P(I1,J)
46663 P(I2,J)=(1D0-DELTA*BETA)*P(I2,J)
46664 980 CONTINUE
46665 P(I1,5)=(1D0-DELTA*ALPHA)*P(I1,5)
46666 P(I2,5)=(1D0-DELTA*BETA)*P(I2,5)
46667
46668C...Finished with string collapse in new scheme.
46669 GOTO 1030
46670 ENDIF
46671
46672C... Use old algorithm; by choice or when in trouble.
46673 990 CONTINUE
46674C...Find parton/particle which combines to largest extra mass.
46675 IR=0
46676 HA=0D0
46677 HSM=0D0
46678 DO 1010 MCOMB=1,3
46679 IF(IR.NE.0) GOTO 1010
46680 DO 1000 I=MAX(1,IP),N
46681 IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
46682 & .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 1000
46683 IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
46684 IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 1000
46685 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 1000
46686 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
46687 & GOTO 1000
46688 HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
46689 HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5)
46690 IF(HSR.GT.HSM) THEN
46691 IR=I
46692 HA=HCR
46693 HSM=HSR
46694 ENDIF
46695 1000 CONTINUE
46696 1010 CONTINUE
46697
46698C...Shuffle energy and momentum to put new particle on mass shell.
46699 IF(IR.NE.0) THEN
46700 HB=PECM**2+HA
46701 HC=P(N+2,5)**2+HA
46702 HD=P(IR,5)**2+HA
46703 HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/
46704 & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
46705 HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
46706 DO 1020 J=1,4
46707 P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J)
46708 P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J)
46709 1020 CONTINUE
46710 N=N+2
46711 ELSE
46712 CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
46713 RETURN
46714 ENDIF
46715
46716C...Mark collapsed system and store daughter pointers. Iterate.
46717 1030 DO 1040 I=IC1,IC2
46718 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
46719 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
46720 K(I,1)=K(I,1)+10
46721 IF(MSTU(16).NE.2) THEN
46722 K(I,4)=NSAV+1
46723 K(I,5)=NSAV+1
46724 ELSE
46725 K(I,4)=NSAV+2
46726 K(I,5)=NSAV+1+NBODY
46727 ENDIF
46728 ENDIF
46729 IF(K(I,1).EQ.41) K(I,1)=K(I,1)+10
46730 1040 CONTINUE
46731 IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 620
46732
46733C...Check flavours and invariant masses in parton systems.
46734 1050 NP=0
46735 KFN=0
46736 KQS=0
46737 NJU=0
46738 DO 1060 J=1,5
46739 DPS(J)=0D0
46740 1060 CONTINUE
46741 DO 1090 I=MAX(1,IP),N
46742 IF(K(I,1).EQ.41) NJU=NJU+1
46743 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 1090
46744 KC=PYCOMP(K(I,2))
46745 IF(KC.EQ.0) GOTO 1090
46746 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
46747 IF(KQ.EQ.0) GOTO 1090
46748 NP=NP+1
46749 IF(KQ.NE.2) THEN
46750 KFN=KFN+1
46751 KQS=KQS+KQ
46752 MSTJ(93)=1
46753 DPS(5)=DPS(5)+PYMASS(K(I,2))
46754 ENDIF
46755 DO 1070 J=1,4
46756 DPS(J)=DPS(J)+P(I,J)
46757 1070 CONTINUE
46758 IF(K(I,1).EQ.1) THEN
46759 NFERR=0
46760 IF(NJU.EQ.0.AND.NP.NE.1) THEN
46761 IF(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0) NFERR=1
46762 ELSEIF(NJU.EQ.1) THEN
46763 IF(KFN.NE.3.OR.IABS(KQS).NE.3) NFERR=1
46764 ELSEIF(NJU.EQ.2) THEN
46765 IF(KFN.NE.4.OR.KQS.NE.0) NFERR=1
46766 ELSEIF(NJU.GE.3) THEN
46767 NFERR=1
46768 ENDIF
46769 IF(NFERR.EQ.1) CALL
46770 & PYERRM(2,'(PYPREP:) unphysical flavour combination')
46771 IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
46772 & (0.9D0*PARJ(32)+DPS(5))**2) CALL PYERRM(3,
46773 & '(PYPREP:) too small mass in jet system')
46774 NP=0
46775 KFN=0
46776 KQS=0
46777 NJU=0
46778 DO 1080 J=1,5
46779 DPS(J)=0D0
46780 1080 CONTINUE
46781 ENDIF
46782 1090 CONTINUE
46783
46784 RETURN
46785 END
46786
46787C*********************************************************************
46788
46789C...PYSTRF
46790C...Handles the fragmentation of an arbitrary colour singlet
46791C...jet system according to the Lund string fragmentation model.
46792
46793 SUBROUTINE PYSTRF(IP)
46794
46795C...Double precision and integer declarations.
46796 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46797 IMPLICIT INTEGER(I-N)
46798 INTEGER PYK,PYCHGE,PYCOMP
46799C...Commonblocks.
46800 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
46801 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46802 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46803 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
46804C...Local arrays. All MOPS variables ends with MO
46805 DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
46806 &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(6),PJU(5,5),
46807 &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
46808 &INMO(9),PM2QMO(2),XTMO(2),EJSTR(2),IJUORI(2),IBARRK(2),
46809 &PBST(3,5),TJUOLD(5)
46810
46811C...Function: four-product of two vectors.
46812 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)
46813 DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
46814 &DP(I,3)*DP(J,3)
46815
46816C...Reset counters.
46817 MSTJ(91)=0
46818 NSAV=N
46819 MSTU90=MSTU(90)
46820 NP=0
46821 KQSUM=0
46822 DO 100 J=1,5
46823 DPS(J)=0D0
46824 100 CONTINUE
46825 MJU(1)=0
46826 MJU(2)=0
46827 NTRYFN=0
46828 IJUORI(1)=0
46829 IJUORI(2)=0
46830
46831C...Identify parton system.
46832 I=IP-1
46833 110 I=I+1
46834 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
46835 CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
46836 IF(MSTU(21).GE.1) RETURN
46837 ENDIF
46838 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
46839 KC=PYCOMP(K(I,2))
46840 IF(KC.EQ.0) GOTO 110
46841 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
46842 IF(KQ.EQ.0.AND.K(I,1).NE.41) GOTO 110
46843 IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
46844 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
46845 IF(MSTU(21).GE.1) RETURN
46846 ENDIF
46847
46848C...Take copy of partons to be considered. Check flavour sum.
46849 NP=NP+1
46850 DO 120 J=1,5
46851 K(N+NP,J)=K(I,J)
46852 P(N+NP,J)=P(I,J)
46853 IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
46854 120 CONTINUE
46855 DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
46856 K(N+NP,3)=I
46857 IF(KQ.NE.2) KQSUM=KQSUM+KQ
46858 IF(K(I,1).EQ.41) THEN
46859 IF(MOD(KQSUM,2).EQ.0.AND.MJU(1).EQ.0) THEN
46860 MJU(1)=N+NP
46861 IJUORI(1)=I
46862 ELSE
46863 MJU(2)=N+NP
46864 IJUORI(2)=I
46865 ENDIF
46866 ENDIF
46867 IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
46868 IF(MOD(KQSUM,3).NE.0) THEN
46869 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
46870 IF(MSTU(21).GE.1) RETURN
46871 ENDIF
46872 IF(MJU(1).GT.0.OR.MJU(2).GT.0) MSTU(29)=1
46873
46874C...Boost copied system to CM frame (for better numerical precision).
46875 IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
46876 MBST=0
46877 MSTU(33)=1
46878 CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
46879 & -DPS(3)/DPS(4))
46880 ELSE
46881 MBST=1
46882 HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
46883 DO 130 I=N+1,N+NP
46884 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
46885 IF(P(I,3).GT.0D0) THEN
46886 HHPEZ=MAX(1D-10,(P(I,4)+P(I,3))/HHBZ)
46887 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
46888 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
46889 ELSE
46890 HHPEZ=MAX(1D-10,(P(I,4)-P(I,3))*HHBZ)
46891 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
46892 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
46893 ENDIF
46894 130 CONTINUE
46895 ENDIF
46896
46897C...Search for very nearby partons that may be recombined.
46898 NTRYR=0
46899 NTRYWR=0
46900 PARU12=PARU(12)
46901 PARU13=PARU(13)
46902 MJU(3)=MJU(1)
46903 MJU(4)=MJU(2)
46904 NR=NP
46905 140 IF(NR.GE.3) THEN
46906 PDRMIN=2D0*PARU12
46907 DO 150 I=N+1,N+NR
46908 IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
46909 I1=I+1
46910 IF(I.EQ.N+NR) I1=N+1
46911 IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
46912 IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
46913 & GOTO 150
46914 IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
46915 & GOTO 150
46916 PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
46917 & P(I1,2)**2+P(I1,3)**2))
46918 PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
46919 PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP))
46920 IF(PDR.LT.PDRMIN) THEN
46921 IR=I
46922 PDRMIN=PDR
46923 ENDIF
46924 150 CONTINUE
46925
46926C...Recombine very nearby partons to avoid machine precision problems.
46927 IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
46928 DO 160 J=1,4
46929 P(N+1,J)=P(N+1,J)+P(N+NR,J)
46930 160 CONTINUE
46931 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
46932 & P(N+1,3)**2))
46933 NR=NR-1
46934 GOTO 140
46935 ELSEIF(PDRMIN.LT.PARU12) THEN
46936 DO 170 J=1,4
46937 P(IR,J)=P(IR,J)+P(IR+1,J)
46938 170 CONTINUE
46939 P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
46940 & P(IR,3)**2))
46941 IF(MJU(2).NE.0.AND.IR.GT.MJU(2)) K(IR,2)=K(IR+1,2)
46942 DO 190 I=IR+1,N+NR-1
46943 K(I,1)=K(I+1,1)
46944 K(I,2)=K(I+1,2)
46945 DO 180 J=1,5
46946 P(I,J)=P(I+1,J)
46947 180 CONTINUE
46948 190 CONTINUE
46949 IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
46950 NR=NR-1
46951 IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
46952 IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
46953 GOTO 140
46954 ENDIF
46955 ENDIF
46956 NTRYR=NTRYR+1
46957
46958C...Reset particle counter. Skip ahead if no junctions are present;
46959C...this is usually the case!
46960 NRS=MAX(5*NR+11,NP)
46961 NTRY=0
46962 200 NTRY=NTRY+1
46963 IF(NTRY.GT.100.AND.NTRYR.LE.8) THEN
46964 PARU12=4D0*PARU12
46965 PARU13=2D0*PARU13
46966 GOTO 140
46967 ELSEIF(NTRY.GT.100) THEN
46968 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
46969 IF(MSTU(21).GE.1) RETURN
46970 ENDIF
46971 I=N+NRS
46972 MSTU(90)=MSTU90
46973 IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 640
46974 IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
46975 & ' junction strings not handled by MSTJ(12)>3 options')
46976 DO 630 JT=1,2
46977 NJS(JT)=0
46978 IF(MJU(JT).EQ.0) GOTO 630
46979 JS=3-2*JT
46980
46981C++SKANDS
46982C...Find and sum up momentum on three sides of junction.
46983C...Begin with previous boost = zero.
46984 IJRFIT=0
46985 DO 210 IX=1,3
46986 TJUOLD(IX)=0D0
46987 210 CONTINUE
46988 TJUOLD(4)=1D0
46989 220 IU=0
46990C...Beginning and end of string system in event record.
46991 I1BEG=N+1+(JT-1)*(NR-1)
46992 I1END=N+NR+(JT-1)*(1-NR)
46993C...Look for junction string piece end points
46994 DO 230 I1=I1BEG,I1END,JS
46995 IF(K(I1,2).NE.21.AND.IU.LE.5.AND.IJRFIT.EQ.0) THEN
46996C...Store junction string piece end points.
46997C 1-junction systems 2-junction systems
46998C IU : 1 2 3 4 1 2 3 4 5 6
46999C 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
47000 IU=IU+1
47001 IJU(IU)=I1
47002 ENDIF
47003C...Sum over momenta, from junction outwards.
47004 230 CONTINUE
47005 DO 280 IU=1,3
47006 PWT=0D0
47007C...Initialize junction drag and string piece 4-vectors.
47008 DO 240 J=1,5
47009 PBST(IU,J)=0D0
47010 PJU(IU,J)=0D0
47011 240 CONTINUE
47012C...First two branches. Inwards out means opposite direction to JS.
47013C...(JS is 1 for JT=1, -1 for JT=2)
47014 IF (IU.LT.3) THEN
47015 I1A=IJU(IU+1)-JS
47016 I1B=IJU(IU)
47017 IDIR=-JS
47018C...Last branch (gq or gjgqgq). Direction now reversed.
47019 ELSE
47020 I1A=IJU(IU)+JS
47021 I1B=I1END
47022 IDIR=JS
47023 ENDIF
47024 DO 270 I1=I1A,I1B,IDIR
47025C...Sum up momentum directions with exponential suppression
47026C...for use in finding junction rest frame below.
47027 IF (K(I1,2).EQ.88) THEN
47028C...gjgqgq type system encountered. Use current PWT as start
47029C...for both strings.
47030 PWTOLD=PWT
47031 ELSE
47032 IF (I1.EQ.IJU(5)+IDIR) PWT=PWTOLD
47033C...Sum up string piece (boosted) 4-momenta.
47034 DO 250 J=1,4
47035 PJU(IU,J)=PJU(IU,J)+P(I1,J)
47036 250 CONTINUE
47037C...Compute "junction drag" vectors from (boosted) 4-momenta (initial
47038C...boost is zero, see above). Skip parton if suppression factor large.
47039 IF (PWT.GT.10D0) GOTO 270
47040C...Compute momentum in current frame:
47041 TDP=TJUOLD(1)*P(I1,1)+TJUOLD(2)*P(I1,2)+TJUOLD(3)*P(I1,3)
47042 BFC=TDP/(1D0+TJUOLD(4))+P(I1,4)
47043 DO 260 J=1,3
47044 PTMP=P(I1,J)+TJUOLD(J)*BFC
47045 PBST(IU,J)=PBST(IU,J)+PTMP*EXP(-PWT)
47046 260 CONTINUE
47047C...Boosted energy
47048 PTMP=TJUOLD(4)*P(I1,4)+TDP
47049 PBST(IU,4)=PBST(IU,J)+PTMP*EXP(-PWT)
47050 PWT=PWT+PTMP/PARJ(48)
47051 ENDIF
47052 270 CONTINUE
47053C...Put |p| rather than m in 5th slot.
47054 PBST(IU,5)=SQRT(PBST(IU,1)**2+PBST(IU,2)**2+PBST(IU,3)**2)
47055 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
47056 280 CONTINUE
47057
47058C...Calculate boost from present frame to next JRF candidate.
47059 IJRFIT=IJRFIT+1
47060 CALL PYJURF(PBST,TJU)
47061
47062C...Combine new boost (TJU) with old boost (TJUOLD)
47063 TMP=TJU(1)*TJUOLD(1)+TJU(2)*TJUOLD(2)+TJU(3)*TJUOLD(3)
47064 DO 290 IX=1,3
47065 TJUOLD(IX)=TJU(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+TJU(4))
47066 290 CONTINUE
47067 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)**2)
47068
47069C...If last boost small, accept JRF, else iterate.
47070C...Also prevent possibility of infinite loop.
47071 IF (ABS((TJU(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
47072 & IJRFIT.LT.MSTJ(18)) THEN
47073 GOTO 220
47074 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
47075 CALL PYERRM(1,'(PYSTRF:) failed to converge on JRF')
47076 ENDIF
47077
47078C...Now store total boost in TJU and change perception.
47079C...TJUOLD = boost vector from CM of string syst -> JRF. Henceforth,
47080C...TJU = junction motion vector in string CM, so the sign changes.
47081 DO 300 J=1,3
47082 TJU(J)=-TJUOLD(J)
47083 300 CONTINUE
47084 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
47085
47086C--SKANDS
47087
47088C...Calculate string piece energies in junction rest frame.
47089 DO 310 IU=1,3
47090 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
47091 & TJU(3)*PJU(IU,3)
47092 PBST(IU,5)=TJU(4)*PBST(IU,4)-TJU(1)*PBST(IU,1)-
47093 & TJU(2)*PBST(IU,2)-TJU(3)*PBST(IU,3)
47094 310 CONTINUE
47095
47096C...Start preparing for fragmentation of two strings from junction.
47097 ISTA=I
47098 NTRYER=0
47099 320 NTRYER=NTRYER+1
47100 I=ISTA
47101 DO 610 IU=1,2
47102 NS=IABS(IJU(IU+1)-IJU(IU))
47103
47104C...Junction strings: find longitudinal string directions.
47105 DO 350 IS=1,NS
47106 IS1=IJU(IU)+JS*(IS-1)
47107 IS2=IJU(IU)+JS*IS
47108 DO 330 J=1,5
47109 DP(1,J)=0.5D0*P(IS1,J)
47110 IF(IS.EQ.1) DP(1,J)=P(IS1,J)
47111 DP(2,J)=0.5D0*P(IS2,J)
47112 IF(IS.EQ.NS) DP(2,J)=(-PBST(IU,J)+2D0*PBST(IU,5)*TJU(J))*
47113 & (PJU(IU,5)/PBST(IU,5))
47114 330 CONTINUE
47115 IF(IS.EQ.NS) DP(2,5)=SQRT(MAX(0D0,PJU(IU,4)**2-
47116 & PJU(IU,1)**2-PJU(IU,2)**2-PJU(IU,3)**2))
47117 DP(3,5)=DFOUR(1,1)
47118 DP(4,5)=DFOUR(2,2)
47119 DHKC=DFOUR(1,2)
47120 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
47121 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
47122 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
47123 DP(3,5)=0D0
47124 DP(4,5)=0D0
47125 DHKC=DFOUR(1,2)
47126 ENDIF
47127 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
47128 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
47129 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
47130 IN1=N+NR+4*IS-3
47131 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
47132 DO 340 J=1,4
47133 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
47134 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
47135 340 CONTINUE
47136 350 CONTINUE
47137
47138C...Junction strings: initialize flavour, momentum and starting pos.
47139 ISAV=I
47140 MSTU91=MSTU(90)
47141 360 NTRY=NTRY+1
47142 IF(NTRY.GT.100.AND.NTRYR.LE.8) THEN
47143 PARU12=4D0*PARU12
47144 PARU13=2D0*PARU13
47145 GOTO 140
47146 ELSEIF(NTRY.GT.100) THEN
47147 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
47148 IF(MSTU(21).GE.1) RETURN
47149 ENDIF
47150 I=ISAV
47151 MSTU(90)=MSTU91
47152 IRANKJ=0
47153 IE(1)=K(N+1+(JT/2)*(NP-1),3)
47154 IN(4)=N+NR+1
47155 IN(5)=IN(4)+1
47156 IN(6)=N+NR+4*NS+1
47157 DO 380 JQ=1,2
47158 DO 370 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
47159 P(IN1,1)=2-JQ
47160 P(IN1,2)=JQ-1
47161 P(IN1,3)=1D0
47162 370 CONTINUE
47163 380 CONTINUE
47164 KFL(1)=K(IJU(IU),2)
47165 PX(1)=0D0
47166 PY(1)=0D0
47167 GAM(1)=0D0
47168 DO 390 J=1,5
47169 PJU(IU+3,J)=0D0
47170 390 CONTINUE
47171
47172C...Junction strings: find initial transverse directions.
47173 DO 400 J=1,4
47174 DP(1,J)=P(IN(4),J)
47175 DP(2,J)=P(IN(4)+1,J)
47176 DP(3,J)=0D0
47177 DP(4,J)=0D0
47178 400 CONTINUE
47179 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
47180 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
47181 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
47182 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
47183 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
47184 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
47185 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
47186 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
47187 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
47188 DHC12=DFOUR(1,2)
47189 DHCX1=DFOUR(3,1)/DHC12
47190 DHCX2=DFOUR(3,2)/DHC12
47191 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
47192 DHCY1=DFOUR(4,1)/DHC12
47193 DHCY2=DFOUR(4,2)/DHC12
47194 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
47195 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
47196 DO 410 J=1,4
47197 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
47198 P(IN(6),J)=DP(3,J)
47199 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
47200 & DHCYX*DP(3,J))
47201 410 CONTINUE
47202
47203C...Junction strings: produce new particle, origin.
47204 420 I=I+1
47205 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
47206 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
47207 IF(MSTU(21).GE.1) RETURN
47208 ENDIF
47209 IRANKJ=IRANKJ+1
47210 K(I,1)=1
47211 K(I,3)=IE(1)
47212 K(I,4)=0
47213 K(I,5)=0
47214
47215C...Junction strings: generate flavour, hadron, pT, z and Gamma.
47216 430 CALL PYKFDI(KFL(1),0,KFL(3),K(I,2))
47217 IF(K(I,2).EQ.0) GOTO 360
47218 IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
47219 & IABS(KFL(3)).GT.10) THEN
47220 IF(PYR(0).GT.PARJ(19)) GOTO 430
47221 ENDIF
47222 P(I,5)=PYMASS(K(I,2))
47223 CALL PYPTDI(KFL(1),PX(3),PY(3))
47224 PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
47225 CALL PYZDIS(KFL(1),KFL(3),PR(1),Z)
47226 IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
47227 & MSTU(90).LT.8) THEN
47228 MSTU(90)=MSTU(90)+1
47229 MSTU(90+MSTU(90))=I
47230 PARU(90+MSTU(90))=Z
47231 ENDIF
47232 GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z)
47233 DO 440 J=1,3
47234 IN(J)=IN(3+J)
47235 440 CONTINUE
47236
47237C...Junction strings: stepping within 'low' string region.
47238 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
47239 & P(IN(1),5)**2.GE.PR(1)) THEN
47240 P(IN(1)+2,4)=Z*P(IN(1)+2,3)
47241 P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
47242 DO 450 J=1,4
47243 P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
47244 450 CONTINUE
47245 GOTO 550
47246C...Has used up energy of junction string, i.e. no more hadrons in it.
47247 ELSEIF(IN(1)+1.EQ.IN(2).AND.IN(1).EQ.N+NR+4*NS-3) THEN
47248 DO 460 J=1,5
47249 P(I,J)=0D0
47250 460 CONTINUE
47251 GOTO 590
47252C...Stepping from 'low' string region
47253 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
47254 P(IN(2)+2,4)=P(IN(2)+2,3)
47255 P(IN(2)+2,1)=1D0
47256 IN(2)=IN(2)+4
47257 IF(IN(2).GT.N+NR+4*NS) GOTO 360
47258 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
47259 P(IN(1)+2,4)=P(IN(1)+2,3)
47260 P(IN(1)+2,1)=0D0
47261 IN(1)=IN(1)+4
47262 ENDIF
47263 ENDIF
47264
47265C...Junction strings: find new transverse directions.
47266 470 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
47267 & IN(1).GT.IN(2)) GOTO 360
47268 IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
47269 DO 480 J=1,4
47270 DP(1,J)=P(IN(1),J)
47271 DP(2,J)=P(IN(2),J)
47272 DP(3,J)=0D0
47273 DP(4,J)=0D0
47274 480 CONTINUE
47275 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
47276 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
47277 DHC12=DFOUR(1,2)
47278 IF(DHC12.LE.1D-2) THEN
47279 P(IN(1)+2,4)=P(IN(1)+2,3)
47280 P(IN(1)+2,1)=0D0
47281 IN(1)=IN(1)+4
47282 GOTO 470
47283 ENDIF
47284 IN(3)=N+NR+4*NS+5
47285 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
47286 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
47287 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
47288 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
47289 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
47290 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
47291 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
47292 DHCX1=DFOUR(3,1)/DHC12
47293 DHCX2=DFOUR(3,2)/DHC12
47294 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
47295 DHCY1=DFOUR(4,1)/DHC12
47296 DHCY2=DFOUR(4,2)/DHC12
47297 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
47298 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
47299 DO 490 J=1,4
47300 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
47301 P(IN(3),J)=DP(3,J)
47302 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
47303 & DHCYX*DP(3,J))
47304 490 CONTINUE
47305C...Express pT with respect to new axes, if sensible.
47306 PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
47307 PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
47308 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
47309 PX(3)=PXP
47310 PY(3)=PYP
47311 ENDIF
47312 ENDIF
47313
47314C...Junction strings: sum up known four-momentum, coefficients for m2.
47315 DO 520 J=1,4
47316 DHG(J)=0D0
47317 P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
47318 & PY(3)*P(IN(3)+1,J)
47319 DO 500 IN1=IN(4),IN(1)-4,4
47320 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
47321 500 CONTINUE
47322 DO 510 IN2=IN(5),IN(2)-4,4
47323 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
47324 510 CONTINUE
47325 520 CONTINUE
47326 DHM(1)=FOUR(I,I)
47327 DHM(2)=2D0*FOUR(I,IN(1))
47328 DHM(3)=2D0*FOUR(I,IN(2))
47329 DHM(4)=2D0*FOUR(IN(1),IN(2))
47330
47331C...Junction strings: find coefficients for Gamma expression.
47332 DO 540 IN2=IN(1)+1,IN(2),4
47333 DO 530 IN1=IN(1),IN2-1,4
47334 DHC=2D0*FOUR(IN1,IN2)
47335 DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
47336 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
47337 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
47338 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
47339 530 CONTINUE
47340 540 CONTINUE
47341
47342C...Junction strings: solve (m2, Gamma) equation system for energies.
47343 DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
47344 IF(ABS(DHS1).LT.1D-4) GOTO 360
47345 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
47346 & (P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
47347 DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
47348 P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
47349 & ABS(DHS1)-DHS2/DHS1)
47350 IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 360
47351 P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
47352 & (DHM(2)+DHM(4)*P(IN(2)+2,4))
47353
47354C...Junction strings: step to new region if necessary.
47355 IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
47356 P(IN(2)+2,4)=P(IN(2)+2,3)
47357 P(IN(2)+2,1)=1D0
47358 IN(2)=IN(2)+4
47359 IF(IN(2).GT.N+NR+4*NS) GOTO 360
47360 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
47361 P(IN(1)+2,4)=P(IN(1)+2,3)
47362 P(IN(1)+2,1)=0D0
47363 IN(1)=IN(1)+4
47364 ENDIF
47365 GOTO 470
47366 ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
47367 P(IN(1)+2,4)=P(IN(1)+2,3)
47368 P(IN(1)+2,1)=0D0
47369 IN(1)=IN(1)+4
47370 GOTO 470
47371 ENDIF
47372
47373C...Junction strings: particle four-momentum, remainder, loop back.
47374 550 DO 560 J=1,4
47375 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+
47376 & P(IN(2)+2,4)*P(IN(2),J)
47377 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
47378 560 CONTINUE
47379 IF(P(I,4).LT.P(I,5)) GOTO 360
47380 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
47381 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
47382 IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
47383 KFL(1)=-KFL(3)
47384 PX(1)=-PX(3)
47385 PY(1)=-PY(3)
47386 GAM(1)=GAM(3)
47387 IF(IN(3).NE.IN(6)) THEN
47388 DO 570 J=1,4
47389 P(IN(6),J)=P(IN(3),J)
47390 P(IN(6)+1,J)=P(IN(3)+1,J)
47391 570 CONTINUE
47392 ENDIF
47393 DO 580 JQ=1,2
47394 IN(3+JQ)=IN(JQ)
47395 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
47396 P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
47397 580 CONTINUE
47398 GOTO 420
47399 ENDIF
47400
47401C...Junction strings: save quantities left after each string.
47402 IF(IABS(KFL(1)).GT.10) GOTO 360
47403 590 I=I-1
47404 KFJH(IU)=KFL(1)
47405 DO 600 J=1,4
47406 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
47407 600 CONTINUE
47408
47409C...Junction strings: loopback if much unused energy in both strings.
47410 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
47411 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
47412 EJSTR(IU)=PJU(IU,5)-PJU(IU+3,5)
47413 610 CONTINUE
47414 IF((MIN(EJSTR(1),EJSTR(2)).GT.PARJ(49).OR.
47415 & EJSTR(1).GT.PARJ(49)+PYR(0)*PARJ(50).OR.
47416 & EJSTR(2).GT.PARJ(49)+PYR(0)*PARJ(50))
47417 & .AND.NTRYER.LT.10) GOTO 320
47418
47419C...Junction strings: put together to new effective string endpoint.
47420 NJS(JT)=I-ISTA
47421 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
47422 IF(KFJH(1).EQ.KFJH(2)) KFLS=3
47423 KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),IABS(KFJH(2)))+
47424 & 100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+KFLS,KFJH(1))
47425 DO 620 J=1,4
47426 PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
47427 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
47428 620 CONTINUE
47429 PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
47430 & PJS(JT,3)**2))
47431 PJS(JT+2,5)=0D0
47432 630 CONTINUE
47433
47434C...Open versus closed strings. Choose breakup region for latter.
47435 640 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
47436 NS=MJU(2)-MJU(1)
47437 NB=MJU(1)-N
47438 ELSEIF(MJU(1).NE.0) THEN
47439 NS=N+NR-MJU(1)
47440 NB=MJU(1)-N
47441 ELSEIF(MJU(2).NE.0) THEN
47442 NS=MJU(2)-N
47443 NB=1
47444 ELSEIF(IABS(K(N+1,2)).NE.21) THEN
47445 NS=NR-1
47446 NB=1
47447 ELSE
47448 NS=NR+1
47449 W2SUM=0D0
47450 DO 650 IS=1,NR
47451 P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR))
47452 W2SUM=W2SUM+P(N+NR+IS,1)
47453 650 CONTINUE
47454 W2RAN=PYR(0)*W2SUM
47455 NB=0
47456 660 NB=NB+1
47457 W2SUM=W2SUM-P(N+NR+NB,1)
47458 IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 660
47459 ENDIF
47460
47461C...Find longitudinal string directions (i.e. lightlike four-vectors).
47462 DO 690 IS=1,NS
47463 IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
47464 IS2=N+IS+NB-NR*((IS+NB-1)/NR)
47465 DO 670 J=1,5
47466 DP(1,J)=P(IS1,J)
47467 IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J)
47468 IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
47469 DP(2,J)=P(IS2,J)
47470 IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J)
47471 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
47472 670 CONTINUE
47473 IF(IS1.EQ.MJU(1)) DP(1,5)=SQRT(MAX(0D0,DP(1,4)**2-DP(1,1)**2-
47474 & DP(1,2)**2-DP(1,3)**2))
47475 IF(IS2.EQ.MJU(2)) DP(2,5)=SQRT(MAX(0D0,DP(2,4)**2-DP(2,1)**2-
47476 & DP(2,2)**2-DP(2,3)**2))
47477 DP(3,5)=DFOUR(1,1)
47478 DP(4,5)=DFOUR(2,2)
47479 DHKC=DFOUR(1,2)
47480 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) GOTO 200
47481 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
47482 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
47483 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
47484 IN1=N+NR+4*IS-3
47485 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
47486 DO 680 J=1,4
47487 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
47488 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
47489 680 CONTINUE
47490 690 CONTINUE
47491
47492C...Begin initialization: sum up energy, set starting position.
47493 ISAV=I
47494 MSTU91=MSTU(90)
47495 700 NTRY=NTRY+1
47496 IF(NTRY.GT.100.AND.NTRYR.LE.8) THEN
47497 PARU12=4D0*PARU12
47498 PARU13=2D0*PARU13
47499 GOTO 140
47500 ELSEIF(NTRY.GT.100) THEN
47501 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
47502 IF(MSTU(21).GE.1) RETURN
47503 ENDIF
47504 I=ISAV
47505 MSTU(90)=MSTU91
47506 DO 720 J=1,4
47507 P(N+NRS,J)=0D0
47508 DO 710 IS=1,NR
47509 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
47510 710 CONTINUE
47511 720 CONTINUE
47512 DO 740 JT=1,2
47513 IRANK(JT)=0
47514 IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
47515 IF(NS.GT.NR) IRANK(JT)=1
47516 IBARRK(JT)=0
47517 IE(JT)=K(N+1+(JT/2)*(NP-1),3)
47518 IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
47519 IN(3*JT+2)=IN(3*JT+1)+1
47520 IN(3*JT+3)=N+NR+4*NS+2*JT-1
47521 DO 730 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
47522 P(IN1,1)=2-JT
47523 P(IN1,2)=JT-1
47524 P(IN1,3)=1D0
47525 730 CONTINUE
47526 740 CONTINUE
47527
47528C.. MOPS variables and switches
47529 NRVMO=0
47530 XBMO=1D0
47531 MSTU(121)=0
47532 MSTU(122)=0
47533
47534C...Initialize flavour and pT variables for open string.
47535 IF(NS.LT.NR) THEN
47536 PX(1)=0D0
47537 PY(1)=0D0
47538 IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1))
47539 PX(2)=-PX(1)
47540 PY(2)=-PY(1)
47541 DO 750 JT=1,2
47542 KFL(JT)=K(IE(JT),2)
47543 IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
47544 IF(MJU(JT).NE.0.AND.IABS(KFL(JT)).GT.1000) IBARRK(JT)=1
47545 MSTJ(93)=1
47546 PMQ(JT)=PYMASS(KFL(JT))
47547 GAM(JT)=0D0
47548 750 CONTINUE
47549
47550C...Closed string: random initial breakup flavour, pT and vertex.
47551 ELSE
47552 KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
47553 IBMO=0
47554 760 CALL PYKFDI(KFL(3),0,KFL(1),KDUMP)
47555C.. Closed string: first vertex diq attempt => enforced second
47556C.. vertex diq
47557 IF(IABS(KFL(1)).GT.10)THEN
47558 IBMO=1
47559 MSTU(121)=0
47560 GOTO 760
47561 ENDIF
47562 IF(IBMO.EQ.1) MSTU(121)=-1
47563 KFL(2)=-KFL(1)
47564 CALL PYPTDI(KFL(1),PX(1),PY(1))
47565 PX(2)=-PX(1)
47566 PY(2)=-PY(1)
47567 PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2)
47568 770 CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
47569 ZR=PR3/(Z*P(N+NR+1,5)**2)
47570 IF(ZR.GE.1D0) GOTO 770
47571 DO 780 JT=1,2
47572 MSTJ(93)=1
47573 PMQ(JT)=PYMASS(KFL(JT))
47574 GAM(JT)=PR3*(1D0-Z)/Z
47575 IN1=N+NR+3+4*(JT/2)*(NS-1)
47576 P(IN1,JT)=1D0-Z
47577 P(IN1,3-JT)=JT-1
47578 P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z
47579 P(IN1+1,JT)=ZR
47580 P(IN1+1,3-JT)=2-JT
47581 P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR
47582 780 CONTINUE
47583 ENDIF
47584C.. MOPS variables
47585 DO 790 JT=1,2
47586 XTMO(JT)=1D0
47587 PM2QMO(JT)=PMQ(JT)**2
47588 IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
47589 790 CONTINUE
47590
47591C...Find initial transverse directions (i.e. spacelike four-vectors).
47592 DO 830 JT=1,2
47593 IF(JT.EQ.1.OR.NS.EQ.NR-1.OR.MJU(1)+MJU(2).NE.0) THEN
47594 IN1=IN(3*JT+1)
47595 IN3=IN(3*JT+3)
47596 DO 800 J=1,4
47597 DP(1,J)=P(IN1,J)
47598 DP(2,J)=P(IN1+1,J)
47599 DP(3,J)=0D0
47600 DP(4,J)=0D0
47601 800 CONTINUE
47602 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
47603 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
47604 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
47605 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
47606 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
47607 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
47608 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
47609 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
47610 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
47611 DHC12=DFOUR(1,2)
47612 DHCX1=DFOUR(3,1)/DHC12
47613 DHCX2=DFOUR(3,2)/DHC12
47614 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
47615 DHCY1=DFOUR(4,1)/DHC12
47616 DHCY2=DFOUR(4,2)/DHC12
47617 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
47618 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
47619 DO 810 J=1,4
47620 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
47621 P(IN3,J)=DP(3,J)
47622 P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
47623 & DHCYX*DP(3,J))
47624 810 CONTINUE
47625 ELSE
47626 DO 820 J=1,4
47627 P(IN3+2,J)=P(IN3,J)
47628 P(IN3+3,J)=P(IN3+1,J)
47629 820 CONTINUE
47630 ENDIF
47631 830 CONTINUE
47632
47633C...Remove energy used up in junction string fragmentation.
47634 IF(MJU(1)+MJU(2).GT.0) THEN
47635 DO 850 JT=1,2
47636 IF(NJS(JT).EQ.0) GOTO 850
47637 DO 840 J=1,4
47638 P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
47639 840 CONTINUE
47640 850 CONTINUE
47641 PARJST=PARJ(33)
47642 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
47643 WMIN=PARJST+PMQ(1)+PMQ(2)
47644 WREM2=FOUR(N+NRS,N+NRS)
47645 IF(P(N+NRS,4).LT.0D0.OR.WREM2.LT.WMIN**2) THEN
47646 NTRYWR=NTRYWR+1
47647 IF(MOD(NTRYWR,20).NE.0) NTRYR=NTRYR-1
47648 GOTO 140
47649 ENDIF
47650 ENDIF
47651
47652C...Produce new particle: side, origin.
47653 860 I=I+1
47654 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
47655 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
47656 IF(MSTU(21).GE.1) RETURN
47657 ENDIF
47658C.. New side priority for popcorn systems
47659 IF(MSTU(121).LE.0)THEN
47660 JT=1.5D0+PYR(0)
47661 IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
47662 IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
47663 ENDIF
47664 JR=3-JT
47665 JS=3-2*JT
47666 IRANK(JT)=IRANK(JT)+1
47667 K(I,1)=1
47668 K(I,4)=0
47669 K(I,5)=0
47670
47671C...Generate flavour, hadron and pT.
47672 870 K(I,3)=IE(JT)
47673 CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
47674 IF(K(I,2).EQ.0) GOTO 700
47675 MU90MO=MSTU(90)
47676 IF(MSTU(121).EQ.-1) GOTO 900
47677 IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
47678 &IABS(KFL(3)).GT.10) THEN
47679 IF(PYR(0).GT.PARJ(19)) GOTO 870
47680 ENDIF
47681 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
47682 &K(I,3)=IJUORI(JT)
47683 P(I,5)=PYMASS(K(I,2))
47684 CALL PYPTDI(KFL(JT),PX(3),PY(3))
47685 PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
47686
47687C...Final hadrons for small invariant mass.
47688 MSTJ(93)=1
47689 PMQ(3)=PYMASS(KFL(3))
47690 PARJST=PARJ(33)
47691 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
47692 WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
47693 IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
47694 &WMIN-0.5D0*PARJ(36)*PMQ(3)
47695 WREM2=FOUR(N+NRS,N+NRS)
47696 IF(WREM2.LT.0.10D0) GOTO 700
47697 IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)),
47698 &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1070
47699
47700C...Choose z, which gives Gamma. Shift z for heavy flavours.
47701 CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z)
47702 IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
47703 &MSTU(90).LT.8) THEN
47704 MSTU(90)=MSTU(90)+1
47705 MSTU(90+MSTU(90))=I
47706 PARU(90+MSTU(90))=Z
47707 ENDIF
47708 KFL1A=IABS(KFL(1))
47709 KFL2A=IABS(KFL(2))
47710 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
47711 &MOD(KFL2A/1000,10)).GE.4) THEN
47712 PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
47713 PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2)))
47714 Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2)
47715 PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
47716 IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1070
47717 ENDIF
47718 GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z)
47719
47720C.. MOPS baryon model modification
47721 XTMO3=(1D0-Z)*XTMO(JT)
47722 IF(IABS(KFL(3)).LE.10) NRVMO=0
47723 IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN
47724 GTSTMO=1D0
47725 PTSTMO=1D0
47726 RTSTMO=PYR(0)
47727 IF(IABS(KFL(JT)).LE.10)THEN
47728 XBMO=MIN(XTMO3,1D0-(2D-10))
47729 GBMO=GAM(3)
47730 PMMO=0D0
47731 PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT)
47732 GTSTMO=1D0-PARF(192)**PGMO
47733 ELSE
47734 IF(IRANK(JT).EQ.1) THEN
47735 GBMO=GAM(JT)
47736 PMMO=0D0
47737 XBMO=1D0
47738 ENDIF
47739 IF(XBMO.LT.1D0-(1D-10))THEN
47740 PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3)
47741 GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO)
47742 PGMO=PGNMO
47743 ENDIF
47744 IF(MSTJ(12).GE.5)THEN
47745 PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO))
47746 PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3)
47747 PTSTMO=EXP((PMMO-PMNMO)*PARF(193))
47748 PMMO=PMNMO
47749 ENDIF
47750 ENDIF
47751
47752C.. MOPS Accepting popcorn system hadron.
47753 IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN
47754 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN
47755 NRVMO=I-N-NR
47756 IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN
47757 CALL PYERRM(11,
47758 & '(PYSTRF:) no more memory left in PYJETS')
47759 IF(MSTU(21).GE.1) RETURN
47760 ENDIF
47761 IMO=I
47762 KFLMO=KFL(JT)
47763 PMQMO=PMQ(JT)
47764 PXMO=PX(JT)
47765 PYMO=PY(JT)
47766 GAMMO=GAM(JT)
47767 IRMO=IRANK(JT)
47768 XMO=XTMO(JT)
47769 DO 890 J=1,9
47770 IF(J.LE.5) THEN
47771 DO 880 LINE=1,I-N-NR
47772 P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J)
47773 K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J)
47774 880 CONTINUE
47775 ENDIF
47776 INMO(J)=IN(J)
47777 890 CONTINUE
47778 ENDIF
47779 ELSE
47780C..Reject popcorn system, flag=-1 if enforcing new one
47781 MSTU(121)=-1
47782 IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2
47783 ENDIF
47784 ENDIF
47785
47786
47787C..Lift restoring string outside MOPS block
47788 900 IF(MSTU(121).LT.0) THEN
47789 IF(MSTU(121).EQ.-2) MSTU(121)=0
47790 MSTU(90)=MU90MO
47791 NRVMO=0
47792 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 870
47793 I=IMO
47794 KFL(JT)=KFLMO
47795 PMQ(JT)=PMQMO
47796 PX(JT)=PXMO
47797 PY(JT)=PYMO
47798 GAM(JT)=GAMMO
47799 IRANK(JT)=IRMO
47800 XTMO(JT)=XMO
47801 DO 920 J=1,9
47802 IF(J.LE.5) THEN
47803 DO 910 LINE=1,I-N-NR
47804 P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J)
47805 K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J)
47806 910 CONTINUE
47807 ENDIF
47808 IN(J)=INMO(J)
47809 920 CONTINUE
47810 GOTO 870
47811 ENDIF
47812 XTMO(JT)=XTMO3
47813C.. MOPS end of modification
47814
47815 DO 930 J=1,3
47816 IN(J)=IN(3*JT+J)
47817 930 CONTINUE
47818
47819C...Stepping within or from 'low' string region easy.
47820 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
47821 &P(IN(1),5)**2.GE.PR(JT)) THEN
47822 P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
47823 P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
47824 DO 940 J=1,4
47825 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
47826 940 CONTINUE
47827 GOTO 1030
47828 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
47829 P(IN(JR)+2,4)=P(IN(JR)+2,3)
47830 P(IN(JR)+2,JT)=1D0
47831 IN(JR)=IN(JR)+4*JS
47832 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 700
47833 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
47834 P(IN(JT)+2,4)=P(IN(JT)+2,3)
47835 P(IN(JT)+2,JT)=0D0
47836 IN(JT)=IN(JT)+4*JS
47837 ENDIF
47838 ENDIF
47839
47840C...Find new transverse directions (i.e. spacelike string vectors).
47841 950 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
47842 &IN(1).GT.IN(2)) GOTO 700
47843 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
47844 DO 960 J=1,4
47845 DP(1,J)=P(IN(1),J)
47846 DP(2,J)=P(IN(2),J)
47847 DP(3,J)=0D0
47848 DP(4,J)=0D0
47849 960 CONTINUE
47850 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
47851 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
47852 DHC12=DFOUR(1,2)
47853 IF(DHC12.LE.1D-2) THEN
47854 P(IN(JT)+2,4)=P(IN(JT)+2,3)
47855 P(IN(JT)+2,JT)=0D0
47856 IN(JT)=IN(JT)+4*JS
47857 GOTO 950
47858 ENDIF
47859 IN(3)=N+NR+4*NS+5
47860 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
47861 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
47862 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
47863 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
47864 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
47865 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
47866 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
47867 DHCX1=DFOUR(3,1)/DHC12
47868 DHCX2=DFOUR(3,2)/DHC12
47869 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
47870 DHCY1=DFOUR(4,1)/DHC12
47871 DHCY2=DFOUR(4,2)/DHC12
47872 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
47873 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
47874 DO 970 J=1,4
47875 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
47876 P(IN(3),J)=DP(3,J)
47877 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
47878 & DHCYX*DP(3,J))
47879 970 CONTINUE
47880C...Express pT with respect to new axes, if sensible.
47881 PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
47882 & FOUR(IN(3*JT+3)+1,IN(3)))
47883 PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
47884 & FOUR(IN(3*JT+3)+1,IN(3)+1))
47885 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
47886 PX(3)=PXP
47887 PY(3)=PYP
47888 ENDIF
47889 ENDIF
47890
47891C...Sum up known four-momentum. Gives coefficients for m2 expression.
47892 DO 1000 J=1,4
47893 DHG(J)=0D0
47894 P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
47895 & PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
47896 DO 980 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
47897 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
47898 980 CONTINUE
47899 DO 990 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
47900 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
47901 990 CONTINUE
47902 1000 CONTINUE
47903 DHM(1)=FOUR(I,I)
47904 DHM(2)=2D0*FOUR(I,IN(1))
47905 DHM(3)=2D0*FOUR(I,IN(2))
47906 DHM(4)=2D0*FOUR(IN(1),IN(2))
47907
47908C...Find coefficients for Gamma expression.
47909 DO 1020 IN2=IN(1)+1,IN(2),4
47910 DO 1010 IN1=IN(1),IN2-1,4
47911 DHC=2D0*FOUR(IN1,IN2)
47912 DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
47913 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
47914 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
47915 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
47916 1010 CONTINUE
47917 1020 CONTINUE
47918
47919C...Solve (m2, Gamma) equation system for energies taken.
47920 DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
47921 IF(ABS(DHS1).LT.1D-4) GOTO 700
47922 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
47923 &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
47924 DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
47925 P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
47926 &ABS(DHS1)-DHS2/DHS1)
47927 IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 700
47928 P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
47929 &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
47930
47931C...Step to new region if necessary.
47932 IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
47933 P(IN(JR)+2,4)=P(IN(JR)+2,3)
47934 P(IN(JR)+2,JT)=1D0
47935 IN(JR)=IN(JR)+4*JS
47936 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 700
47937 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
47938 P(IN(JT)+2,4)=P(IN(JT)+2,3)
47939 P(IN(JT)+2,JT)=0D0
47940 IN(JT)=IN(JT)+4*JS
47941 ENDIF
47942 GOTO 950
47943 ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
47944 P(IN(JT)+2,4)=P(IN(JT)+2,3)
47945 P(IN(JT)+2,JT)=0D0
47946 IN(JT)=IN(JT)+4*JS
47947 GOTO 950
47948 ENDIF
47949
47950C...Four-momentum of particle. Remaining quantities. Loop back.
47951 1030 DO 1040 J=1,4
47952 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
47953 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
47954 1040 CONTINUE
47955 IF(P(I,4).LT.P(I,5)) GOTO 700
47956 KFL(JT)=-KFL(3)
47957 PMQ(JT)=PMQ(3)
47958 PX(JT)=-PX(3)
47959 PY(JT)=-PY(3)
47960 GAM(JT)=GAM(3)
47961 IF(IN(3).NE.IN(3*JT+3)) THEN
47962 DO 1050 J=1,4
47963 P(IN(3*JT+3),J)=P(IN(3),J)
47964 P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
47965 1050 CONTINUE
47966 ENDIF
47967 DO 1060 JQ=1,2
47968 IN(3*JT+JQ)=IN(JQ)
47969 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
47970 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
47971 1060 CONTINUE
47972 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
47973 &IBARRK(JT)=0
47974 GOTO 860
47975
47976C...Final hadron: side, flavour, hadron, mass.
47977 1070 I=I+1
47978 K(I,1)=1
47979 K(I,3)=IE(JR)
47980 K(I,4)=0
47981 K(I,5)=0
47982 CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
47983 IF(K(I,2).EQ.0) GOTO 700
47984 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I-1,2)),10000).GT.1000)
47985 &IBARRK(JT)=0
47986 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
47987 &K(I,3)=IJUORI(JT)
47988 IF(IBARRK(JR).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
47989 &K(I,3)=IJUORI(JR)
47990 P(I,5)=PYMASS(K(I,2))
47991 PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
47992
47993C...Final two hadrons: find common setup of four-vectors.
47994 JQ=1
47995 IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.
47996 &P(IN(7)+2,3)*P(IN(8)+2,3)*FOUR(IN(7),IN(8))) JQ=2
47997 DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
47998 DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
47999 DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
48000 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
48001 PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
48002 PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
48003 PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
48004 & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
48005 ENDIF
48006
48007C...Solve kinematics for final two hadrons, if possible.
48008 WREM2=2D0*DHR1*DHR2*DHC12
48009 FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
48010 IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200
48011 IF(FD.GE.1D0) GOTO 700
48012 FA=WREM2+PR(JT)-PR(JR)
48013 FB=SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT)))
48014 PREVCF=PARJ(42)
48015 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
48016 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*FB*PARJ(40))))
48017 FB=SIGN(FB,JS*(PYR(0)-PREV))
48018 KFL1A=IABS(KFL(1))
48019 KFL2A=IABS(KFL(2))
48020 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
48021 &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2-
48022 &4D0*WREM2*PR(JT))),DBLE(JS))
48023 DO 1080 J=1,4
48024 P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
48025 & P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
48026 & DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
48027 P(I,J)=P(N+NRS,J)-P(I-1,J)
48028 1080 CONTINUE
48029 IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 700
48030 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
48031 DM2F2=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
48032 IF(DM2F1.GT.1D-10*P(I-1,4)**2.OR.DM2F2.GT.1D-10*P(I,4)**2) THEN
48033 NTRYFN=NTRYFN+1
48034 IF(NTRYFN.LT.100) GOTO 140
48035 CALL PYERRM(13,'(PYSTRF:) bad energies for final two hadrons')
48036 ENDIF
48037
48038C...Mark jets as fragmented and give daughter pointers.
48039 N=I-NRS+1
48040 DO 1090 I=NSAV+1,NSAV+NP
48041 IM=K(I,3)
48042 K(IM,1)=K(IM,1)+10
48043 IF(MSTU(16).NE.2) THEN
48044 K(IM,4)=NSAV+1
48045 K(IM,5)=NSAV+1
48046 ELSE
48047 K(IM,4)=NSAV+2
48048 K(IM,5)=N
48049 ENDIF
48050 1090 CONTINUE
48051
48052C...Document string system. Move up particles.
48053 NSAV=NSAV+1
48054 K(NSAV,1)=11
48055 K(NSAV,2)=92
48056 K(NSAV,3)=IP
48057 K(NSAV,4)=NSAV+1
48058 K(NSAV,5)=N
48059 DO 1100 J=1,4
48060 P(NSAV,J)=DPS(J)
48061 V(NSAV,J)=V(IP,J)
48062 1100 CONTINUE
48063 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
48064 V(NSAV,5)=0D0
48065 DO 1120 I=NSAV+1,N
48066 DO 1110 J=1,5
48067 K(I,J)=K(I+NRS-1,J)
48068 P(I,J)=P(I+NRS-1,J)
48069 V(I,J)=0D0
48070 1110 CONTINUE
48071 1120 CONTINUE
48072 MSTU91=MSTU(90)
48073 DO 1130 IZ=MSTU90+1,MSTU91
48074 MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
48075 PARU9T(IZ)=PARU(90+IZ)
48076 1130 CONTINUE
48077 MSTU(90)=MSTU90
48078
48079C...Order particles in rank along the chain. Update mother pointer.
48080 DO 1150 I=NSAV+1,N
48081 DO 1140 J=1,5
48082 K(I-NSAV+N,J)=K(I,J)
48083 P(I-NSAV+N,J)=P(I,J)
48084 1140 CONTINUE
48085 1150 CONTINUE
48086 I1=NSAV
48087 DO 1180 I=N+1,2*N-NSAV
48088 IF(K(I,3).NE.IE(1).AND.K(I,3).NE.IJUORI(1)) GOTO 1180
48089 I1=I1+1
48090 DO 1160 J=1,5
48091 K(I1,J)=K(I,J)
48092 P(I1,J)=P(I,J)
48093 1160 CONTINUE
48094 IF(MSTU(16).NE.2) K(I1,3)=NSAV
48095 DO 1170 IZ=MSTU90+1,MSTU91
48096 IF(MSTU9T(IZ).EQ.I) THEN
48097 MSTU(90)=MSTU(90)+1
48098 MSTU(90+MSTU(90))=I1
48099 PARU(90+MSTU(90))=PARU9T(IZ)
48100 ENDIF
48101 1170 CONTINUE
48102 1180 CONTINUE
48103 DO 1210 I=2*N-NSAV,N+1,-1
48104 IF(K(I,3).EQ.IE(1).OR.K(I,3).EQ.IJUORI(1)) GOTO 1210
48105 I1=I1+1
48106 DO 1190 J=1,5
48107 K(I1,J)=K(I,J)
48108 P(I1,J)=P(I,J)
48109 1190 CONTINUE
48110 IF(MSTU(16).NE.2) K(I1,3)=NSAV
48111 DO 1200 IZ=MSTU90+1,MSTU91
48112 IF(MSTU9T(IZ).EQ.I) THEN
48113 MSTU(90)=MSTU(90)+1
48114 MSTU(90+MSTU(90))=I1
48115 PARU(90+MSTU(90))=PARU9T(IZ)
48116 ENDIF
48117 1200 CONTINUE
48118 1210 CONTINUE
48119
48120C...Boost back particle system. Set production vertices.
48121 IF(MBST.EQ.0) THEN
48122 MSTU(33)=1
48123 CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),
48124 & DPS(3)/DPS(4))
48125 ELSE
48126 DO 1220 I=NSAV+1,N
48127 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
48128 IF(P(I,3).GT.0D0) THEN
48129 HHPEZ=(P(I,4)+P(I,3))*HHBZ
48130 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
48131 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
48132 ELSE
48133 HHPEZ=(P(I,4)-P(I,3))/HHBZ
48134 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
48135 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
48136 ENDIF
48137 1220 CONTINUE
48138 ENDIF
48139 DO 1240 I=NSAV+1,N
48140 DO 1230 J=1,4
48141 V(I,J)=V(IP,J)
48142 1230 CONTINUE
48143 1240 CONTINUE
48144
48145 RETURN
48146 END
48147
48148C*********************************************************************
48149
48150C...PYJURF
48151C...From three given input vectors in PJU the boost VJU from
48152C...the "lab frame" to the junction rest frame is constructed.
48153
48154 SUBROUTINE PYJURF(PJU,VJU)
48155
48156C...Double precision and integer declarations.
48157 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48158 IMPLICIT INTEGER(I-N)
48159
48160C...Input, output and local arrays.
48161 DIMENSION PJU(3,5),VJU(5),PSUM(5),A(3,3),PENEW(3),PCM(5,5)
48162 DATA TWOPI/6.283186D0/
48163
48164C...Calculate masses and other invariants.
48165 DO 100 J=1,4
48166 PSUM(J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
48167 100 CONTINUE
48168 PSUM2=PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2
48169 PSUM(5)=SQRT(PSUM2)
48170 DO 120 I=1,3
48171 DO 110 J=1,3
48172 A(I,J)=PJU(I,4)*PJU(J,4)-PJU(I,1)*PJU(J,1)-
48173 & PJU(I,2)*PJU(J,2)-PJU(I,3)*PJU(J,3)
48174 110 CONTINUE
48175 120 CONTINUE
48176
48177C...Pick I to be most massive parton and J to be the one closest to I.
48178 ITRY=0
48179 I=1
48180 IF(A(2,2).GT.A(1,1)) I=2
48181 IF(A(3,3).GT.MAX(A(1,1),A(2,2))) I=3
48182 130 ITRY=ITRY+1
48183 J=1+MOD(I,3)
48184 K=1+MOD(J,3)
48185 IF(A(I,K)**2*A(J,J).LT.A(I,J)**2*A(K,K)) THEN
48186 K=1+MOD(I,3)
48187 J=1+MOD(K,3)
48188 ENDIF
48189 PMI2=A(I,I)
48190 PMJ2=A(J,J)
48191 PMK2=A(K,K)
48192 AIJ=A(I,J)
48193 AIK=A(I,K)
48194 AJK=A(J,K)
48195
48196C...Trivial find new parton energies if all three partons are massless.
48197 IF(PMI2.LT.1D-4) THEN
48198 PEI=SQRT(2D0*AIK*AIJ/(3D0*AJK))
48199 PEJ=SQRT(2D0*AJK*AIJ/(3D0*AIK))
48200 PEK=SQRT(2D0*AIK*AJK/(3D0*AIJ))
48201
48202C...Else find momentum range for parton I and values at extremes.
48203 ELSE
48204 PAIMIN=0D0
48205 PEIMIN=SQRT(PMI2)
48206 PEJMIN=AIJ/PEIMIN
48207 PEKMIN=AIK/PEIMIN
48208 PAJMIN=SQRT(MAX(0D0,PEJMIN**2-PMJ2))
48209 PAKMIN=SQRT(MAX(0D0,PEKMIN**2-PMK2))
48210 FMIN=PEJMIN*PEKMIN+0.5D0*PAJMIN*PAKMIN-AJK
48211 PEIMAX=(AIJ+AIK)/SQRT(PMJ2+PMK2+2D0*AJK)
48212 IF(PMJ2.GT.1D-4) PEIMAX=AIJ/SQRT(PMJ2)
48213 PAIMAX=SQRT(MAX(0D0,PEIMAX**2-PMI2))
48214 HI=PEIMAX**2-0.25D0*PAIMAX**2
48215 PAJMAX=(PEIMAX*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-
48216 & 0.5D0*PAIMAX*AIJ)/HI
48217 PAKMAX=(PEIMAX*SQRT(MAX(0D0,AIK**2-PMK2*HI))-
48218 & 0.5D0*PAIMAX*AIK)/HI
48219 PEJMAX=SQRT(PAJMAX**2+PMJ2)
48220 PEKMAX=SQRT(PAKMAX**2+PMK2)
48221 FMAX=PEJMAX*PEKMAX+0.5D0*PAJMAX*PAKMAX-AJK
48222
48223C...If unexpected values at upper endpoint then pick another parton.
48224 IF(FMAX.GT.0D0.AND.ITRY.LE.2) THEN
48225 I1=1+MOD(I,3)
48226 IF(A(I1,I1).GE.1D-4) THEN
48227 I=I1
48228 GOTO 130
48229 ENDIF
48230 ITRY=ITRY+1
48231 I1=1+MOD(I,3)
48232 IF(ITRY.LE.2.AND.A(I1,I1).GE.1D-4) THEN
48233 I=I1
48234 GOTO 130
48235 ENDIF
48236 ENDIF
48237
48238C..Start binary + linear search to find solution inside range.
48239 ITER=0
48240 ITMIN=0
48241 ITMAX=0
48242 PAI=0.5D0*(PAIMIN+PAIMAX)
48243 140 ITER=ITER+1
48244
48245C...Derive momentum of other two partons and distance to root.
48246 PEI=SQRT(PAI**2+PMI2)
48247 HI=PEI**2-0.25D0*PAI**2
48248 PAJ=(PEI*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-0.5D0*PAI*AIJ)/HI
48249 PEJ=SQRT(PAJ**2+PMJ2)
48250 PAK=(PEI*SQRT(MAX(0D0,AIK**2-PMK2*HI))-0.5D0*PAI*AIK)/HI
48251 PEK=SQRT(PAK**2+PMK2)
48252 FNOW=PEJ*PEK+0.5D0*PAJ*PAK-AJK
48253
48254C...Pick next I momentum to explore, hopefully closer to root.
48255 IF(FNOW.GT.0D0) THEN
48256 PAIMIN=PAI
48257 FMIN=FNOW
48258 ITMIN=ITMIN+1
48259 ELSE
48260 PAIMAX=PAI
48261 FMAX=FNOW
48262 ITMAX=ITMAX+1
48263 ENDIF
48264 IF((ITER.LT.10.OR.ITMIN.LE.1.OR.ITMAX.LE.1).AND.ITER.LT.20)
48265 & THEN
48266 PAI=0.5D0*(PAIMIN+PAIMAX)
48267 GOTO 140
48268 ELSEIF(ITER.LT.40.AND.FMIN.GT.0D0.AND.FMAX.LT.0D0.AND.
48269 & ABS(FNOW).GT.1D-12*PSUM2) THEN
48270 PAI=PAIMIN+(PAIMAX-PAIMIN)*FMIN/(FMIN-FMAX)
48271 GOTO 140
48272 ENDIF
48273 ENDIF
48274
48275C...Now know energies in junction rest frame.
48276 PENEW(I)=PEI
48277 PENEW(J)=PEJ
48278 PENEW(K)=PEK
48279
48280C...Boost (copy of) partons to their rest frame.
48281 VXCM=-PSUM(1)/PSUM(5)
48282 VYCM=-PSUM(2)/PSUM(5)
48283 VZCM=-PSUM(3)/PSUM(5)
48284 GAMCM=SQRT(1D0+VXCM**2+VYCM**2+VZCM**2)
48285 DO 150 I=1,3
48286 FAC1=PJU(I,1)*VXCM+PJU(I,2)*VYCM+PJU(I,3)*VZCM
48287 FAC2=FAC1/(1D0+GAMCM)+PJU(I,4)
48288 PCM(I,1)=PJU(I,1)+FAC2*VXCM
48289 PCM(I,2)=PJU(I,2)+FAC2*VYCM
48290 PCM(I,3)=PJU(I,3)+FAC2*VZCM
48291 PCM(I,4)=PJU(I,4)*GAMCM+FAC1
48292 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
48293 150 CONTINUE
48294
48295C...Construct difference vectors and boost to junction rest frame.
48296 DO 160 J=1,3
48297 PCM(4,J)=PCM(1,J)/PCM(1,4)-PCM(2,J)/PCM(2,4)
48298 PCM(5,J)=PCM(1,J)/PCM(1,4)-PCM(3,J)/PCM(3,4)
48299 160 CONTINUE
48300 PCM(4,4)=PENEW(1)/PCM(1,4)-PENEW(2)/PCM(2,4)
48301 PCM(5,4)=PENEW(1)/PCM(1,4)-PENEW(3)/PCM(3,4)
48302 PCM4S=PCM(4,1)**2+PCM(4,2)**2+PCM(4,3)**2
48303 PCM5S=PCM(5,1)**2+PCM(5,2)**2+PCM(5,3)**2
48304 PCM45=PCM(4,1)*PCM(5,1)+PCM(4,2)*PCM(5,2)+PCM(4,3)*PCM(5,3)
48305 C4=(PCM5S*PCM(4,4)-PCM45*PCM(5,4))/(PCM4S*PCM5S-PCM45**2)
48306 C5=(PCM4S*PCM(5,4)-PCM45*PCM(4,4))/(PCM4S*PCM5S-PCM45**2)
48307 VXJU=C4*PCM(4,1)+C5*PCM(5,1)
48308 VYJU=C4*PCM(4,2)+C5*PCM(5,2)
48309 VZJU=C4*PCM(4,3)+C5*PCM(5,3)
48310 GAMJU=SQRT(1D0+VXJU**2+VYJU**2+VZJU**2)
48311
48312C...Add two boosts, giving final result.
48313 FCM=(VXJU*VXCM+VYJU*VYCM+VZJU*VZCM)/(1+GAMCM)+GAMJU
48314 VJU(1)=VXJU+FCM*VXCM
48315 VJU(2)=VYJU+FCM*VYCM
48316 VJU(3)=VZJU+FCM*VZCM
48317 VJU(4)=SQRT(1D0+VJU(1)**2+VJU(2)**2+VJU(3)**2)
48318 VJU(5)=1D0
48319
48320C...In case of error in reconstruction: revert to CM frame of system.
48321 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
48322 &(PCM(1,5)*PCM(2,5))
48323 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
48324 &(PCM(1,5)*PCM(3,5))
48325 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
48326 &(PCM(2,5)*PCM(3,5))
48327 ERRCCM=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
48328 ERRTCM=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
48329 DO 170 I=1,3
48330 FAC1=PJU(I,1)*VJU(1)+PJU(I,2)*VJU(2)+PJU(I,3)*VJU(3)
48331 FAC2=FAC1/(1D0+VJU(4))+PJU(I,4)
48332 PCM(I,1)=PJU(I,1)+FAC2*VJU(1)
48333 PCM(I,2)=PJU(I,2)+FAC2*VJU(2)
48334 PCM(I,3)=PJU(I,3)+FAC2*VJU(3)
48335 PCM(I,4)=PJU(I,4)*VJU(4)+FAC1
48336 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
48337 170 CONTINUE
48338 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
48339 &(PCM(1,5)*PCM(2,5))
48340 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
48341 &(PCM(1,5)*PCM(3,5))
48342 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
48343 &(PCM(2,5)*PCM(3,5))
48344 ERRCJU=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
48345 ERRTJU=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
48346 IF(ERRCJU+ERRTJU.GT.ERRCCM+ERRTCM) THEN
48347 VJU(1)=VXCM
48348 VJU(2)=VYCM
48349 VJU(3)=VZCM
48350 VJU(4)=GAMCM
48351 ENDIF
48352
48353 RETURN
48354 END
48355
48356C*********************************************************************
48357
48358C...PYINDF
48359C...Handles the fragmentation of a jet system (or a single
48360C...jet) according to independent fragmentation models.
48361
48362 SUBROUTINE PYINDF(IP)
48363
48364C...Double precision and integer declarations.
48365 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48366 IMPLICIT INTEGER(I-N)
48367 INTEGER PYK,PYCHGE,PYCOMP
48368C...Commonblocks.
48369 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
48370 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48371 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48372 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
48373C...Local arrays.
48374 DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
48375 &KFLO(2),PXO(2),PYO(2),WO(2)
48376
48377C.. MOPS error message
48378 IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
48379 &' are not treated as expected in independent fragmentation')
48380
48381C...Reset counters. Identify parton system and take copy. Check flavour.
48382 NSAV=N
48383 MSTU90=MSTU(90)
48384 NJET=0
48385 KQSUM=0
48386 DO 100 J=1,5
48387 DPS(J)=0D0
48388 100 CONTINUE
48389 I=IP-1
48390 110 I=I+1
48391 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
48392 CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
48393 IF(MSTU(21).GE.1) RETURN
48394 ENDIF
48395 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
48396 KC=PYCOMP(K(I,2))
48397 IF(KC.EQ.0) GOTO 110
48398 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
48399 IF(KQ.EQ.0) GOTO 110
48400 NJET=NJET+1
48401 IF(KQ.NE.2) KQSUM=KQSUM+KQ
48402 DO 120 J=1,5
48403 K(NSAV+NJET,J)=K(I,J)
48404 P(NSAV+NJET,J)=P(I,J)
48405 DPS(J)=DPS(J)+P(I,J)
48406 120 CONTINUE
48407 K(NSAV+NJET,3)=I
48408 IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
48409 &K(I+1,1).EQ.2)) GOTO 110
48410 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
48411 CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
48412 IF(MSTU(21).GE.1) RETURN
48413 ENDIF
48414
48415C...Boost copied system to CM frame. Find CM energy and sum flavours.
48416 IF(NJET.NE.1) THEN
48417 MSTU(33)=1
48418 CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
48419 & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
48420 ENDIF
48421 PECM=0D0
48422 DO 130 J=1,3
48423 NFI(J)=0
48424 130 CONTINUE
48425 DO 140 I=NSAV+1,NSAV+NJET
48426 PECM=PECM+P(I,4)
48427 KFA=IABS(K(I,2))
48428 IF(KFA.LE.3) THEN
48429 NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
48430 ELSEIF(KFA.GT.1000) THEN
48431 KFLA=MOD(KFA/1000,10)
48432 KFLB=MOD(KFA/100,10)
48433 IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
48434 IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
48435 ENDIF
48436 140 CONTINUE
48437
48438C...Loop over attempts made. Reset counters.
48439 NTRY=0
48440 150 NTRY=NTRY+1
48441 IF(NTRY.GT.200) THEN
48442 CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
48443 IF(MSTU(21).GE.1) RETURN
48444 ENDIF
48445 N=NSAV+NJET
48446 MSTU(90)=MSTU90
48447 DO 160 J=1,3
48448 NFL(J)=NFI(J)
48449 IFET(J)=0
48450 KFLF(J)=0
48451 160 CONTINUE
48452
48453C...Loop over jets to be fragmented.
48454 DO 230 IP1=NSAV+1,NSAV+NJET
48455 MSTJ(91)=0
48456 NSAV1=N
48457 MSTU91=MSTU(90)
48458
48459C...Initial flavour and momentum values. Jet along +z axis.
48460 KFLH=IABS(K(IP1,2))
48461 IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
48462 KFLO(2)=0
48463 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
48464
48465C...Initial values for quark or diquark jet.
48466 170 IF(IABS(K(IP1,2)).NE.21) THEN
48467 NSTR=1
48468 KFLO(1)=K(IP1,2)
48469 CALL PYPTDI(0,PXO(1),PYO(1))
48470 WO(1)=WF
48471
48472C...Initial values for gluon treated like random quark jet.
48473 ELSEIF(MSTJ(2).LE.2) THEN
48474 NSTR=1
48475 IF(MSTJ(2).EQ.2) MSTJ(91)=1
48476 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
48477 CALL PYPTDI(0,PXO(1),PYO(1))
48478 WO(1)=WF
48479
48480C...Initial values for gluon treated like quark-antiquark jet pair,
48481C...sharing energy according to Altarelli-Parisi splitting function.
48482 ELSE
48483 NSTR=2
48484 IF(MSTJ(2).EQ.4) MSTJ(91)=1
48485 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
48486 KFLO(2)=-KFLO(1)
48487 CALL PYPTDI(0,PXO(1),PYO(1))
48488 PXO(2)=-PXO(1)
48489 PYO(2)=-PYO(1)
48490 WO(1)=WF*PYR(0)**(1D0/3D0)
48491 WO(2)=WF-WO(1)
48492 ENDIF
48493
48494C...Initial values for rank, flavour, pT and W+.
48495 DO 220 ISTR=1,NSTR
48496 180 I=N
48497 MSTU(90)=MSTU91
48498 IRANK=0
48499 KFL1=KFLO(ISTR)
48500 PX1=PXO(ISTR)
48501 PY1=PYO(ISTR)
48502 W=WO(ISTR)
48503
48504C...New hadron. Generate flavour and hadron species.
48505 190 I=I+1
48506 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
48507 CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS')
48508 IF(MSTU(21).GE.1) RETURN
48509 ENDIF
48510 IRANK=IRANK+1
48511 K(I,1)=1
48512 K(I,3)=IP1
48513 K(I,4)=0
48514 K(I,5)=0
48515 200 CALL PYKFDI(KFL1,0,KFL2,K(I,2))
48516 IF(K(I,2).EQ.0) GOTO 180
48517 IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN
48518 IF(PYR(0).GT.PARJ(19)) GOTO 200
48519 ENDIF
48520
48521C...Find hadron mass. Generate four-momentum.
48522 P(I,5)=PYMASS(K(I,2))
48523 CALL PYPTDI(KFL1,PX2,PY2)
48524 P(I,1)=PX1+PX2
48525 P(I,2)=PY1+PY2
48526 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
48527 CALL PYZDIS(KFL1,KFL2,PR,Z)
48528 MZSAV=0
48529 IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
48530 MZSAV=1
48531 MSTU(90)=MSTU(90)+1
48532 MSTU(90+MSTU(90))=I
48533 PARU(90+MSTU(90))=Z
48534 ENDIF
48535 P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W))
48536 P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W))
48537 IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
48538 & P(I,3).LE.0.001D0) THEN
48539 IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180
48540 P(I,3)=0.0001D0
48541 P(I,4)=SQRT(PR)
48542 Z=P(I,4)/W
48543 ENDIF
48544
48545C...Remaining flavour and momentum.
48546 KFL1=-KFL2
48547 PX1=-PX2
48548 PY1=-PY2
48549 W=(1D0-Z)*W
48550 DO 210 J=1,5
48551 V(I,J)=0D0
48552 210 CONTINUE
48553
48554C...Check if pL acceptable. Go back for new hadron if enough energy.
48555 IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN
48556 I=I-1
48557 IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
48558 ENDIF
48559 IF(W.GT.PARJ(31)) GOTO 190
48560 N=I
48561 220 CONTINUE
48562 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32)
48563 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
48564
48565C...Rotate jet to new direction.
48566 THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
48567 PHI=PYANGL(P(IP1,1),P(IP1,2))
48568 MSTU(33)=1
48569 CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
48570 K(K(IP1,3),4)=NSAV1+1
48571 K(K(IP1,3),5)=N
48572
48573C...End of jet generation loop. Skip conservation in some cases.
48574 230 CONTINUE
48575 IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
48576 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
48577
48578C...Subtract off produced hadron flavours, finished if zero.
48579 DO 240 I=NSAV+NJET+1,N
48580 KFA=IABS(K(I,2))
48581 KFLA=MOD(KFA/1000,10)
48582 KFLB=MOD(KFA/100,10)
48583 KFLC=MOD(KFA/10,10)
48584 IF(KFLA.EQ.0) THEN
48585 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
48586 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
48587 ELSE
48588 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
48589 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
48590 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
48591 ENDIF
48592 240 CONTINUE
48593 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
48594 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
48595 IF(NREQ.EQ.0) GOTO 320
48596
48597C...Take away flavour of low-momentum particles until enough freedom.
48598 NREM=0
48599 250 IREM=0
48600 P2MIN=PECM**2
48601 DO 260 I=NSAV+NJET+1,N
48602 P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
48603 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
48604 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
48605 260 CONTINUE
48606 IF(IREM.EQ.0) GOTO 150
48607 K(IREM,1)=7
48608 KFA=IABS(K(IREM,2))
48609 KFLA=MOD(KFA/1000,10)
48610 KFLB=MOD(KFA/100,10)
48611 KFLC=MOD(KFA/10,10)
48612 IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
48613 IF(K(IREM,1).EQ.8) GOTO 250
48614 IF(KFLA.EQ.0) THEN
48615 ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
48616 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
48617 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
48618 ELSE
48619 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
48620 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
48621 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
48622 ENDIF
48623 NREM=NREM+1
48624 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
48625 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
48626 IF(NREQ.GT.NREM) GOTO 250
48627 DO 270 I=NSAV+NJET+1,N
48628 IF(K(I,1).EQ.8) K(I,1)=1
48629 270 CONTINUE
48630
48631C...Find combination of existing and new flavours for hadron.
48632 280 NFET=2
48633 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
48634 IF(NREQ.LT.NREM) NFET=1
48635 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
48636 DO 290 J=1,NFET
48637 IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0)
48638 KFLF(J)=ISIGN(1,NFL(1))
48639 IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
48640 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
48641 290 CONTINUE
48642 IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
48643 &GOTO 280
48644 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
48645 &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
48646 &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
48647 IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0))
48648 IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
48649 IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1))
48650 IF(NFET.LE.2) KFLF(3)=0
48651 IF(KFLF(3).NE.0) THEN
48652 KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
48653 & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
48654 IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0)
48655 & KFLFC=KFLFC+ISIGN(2,KFLFC)
48656 ELSE
48657 KFLFC=KFLF(1)
48658 ENDIF
48659 CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
48660 IF(KF.EQ.0) GOTO 280
48661 DO 300 J=1,MAX(2,NFET)
48662 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
48663 300 CONTINUE
48664
48665C...Store hadron at random among free positions.
48666 NPOS=MIN(1+INT(PYR(0)*NREM),NREM)
48667 DO 310 I=NSAV+NJET+1,N
48668 IF(K(I,1).EQ.7) NPOS=NPOS-1
48669 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
48670 K(I,1)=1
48671 K(I,2)=KF
48672 P(I,5)=PYMASS(K(I,2))
48673 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
48674 310 CONTINUE
48675 NREM=NREM-1
48676 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
48677 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
48678 IF(NREM.GT.0) GOTO 280
48679
48680C...Compensate for missing momentum in global scheme (3 options).
48681 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
48682 DO 340 J=1,3
48683 PSI(J)=0D0
48684 DO 330 I=NSAV+NJET+1,N
48685 PSI(J)=PSI(J)+P(I,J)
48686 330 CONTINUE
48687 340 CONTINUE
48688 PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
48689 PWS=0D0
48690 DO 350 I=NSAV+NJET+1,N
48691 IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
48692 IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
48693 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
48694 IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0
48695 350 CONTINUE
48696 DO 370 I=NSAV+NJET+1,N
48697 IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
48698 IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
48699 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
48700 IF(MOD(MSTJ(3),5).EQ.3) PW=1D0
48701 DO 360 J=1,3
48702 P(I,J)=P(I,J)-PSI(J)*PW/PWS
48703 360 CONTINUE
48704 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
48705 370 CONTINUE
48706
48707C...Compensate for missing momentum withing each jet separately.
48708 ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
48709 DO 390 I=N+1,N+NJET
48710 K(I,1)=0
48711 DO 380 J=1,5
48712 P(I,J)=0D0
48713 380 CONTINUE
48714 390 CONTINUE
48715 DO 410 I=NSAV+NJET+1,N
48716 IR1=K(I,3)
48717 IR2=N+IR1-NSAV
48718 K(IR2,1)=K(IR2,1)+1
48719 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
48720 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
48721 DO 400 J=1,3
48722 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
48723 400 CONTINUE
48724 P(IR2,4)=P(IR2,4)+P(I,4)
48725 P(IR2,5)=P(IR2,5)+PLS
48726 410 CONTINUE
48727 PSS=0D0
48728 DO 420 I=N+1,N+NJET
48729 IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0))
48730 420 CONTINUE
48731 DO 440 I=NSAV+NJET+1,N
48732 IR1=K(I,3)
48733 IR2=N+IR1-NSAV
48734 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
48735 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
48736 DO 430 J=1,3
48737 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)*
48738 & PLS*P(IR1,J)
48739 430 CONTINUE
48740 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
48741 440 CONTINUE
48742 ENDIF
48743
48744C...Scale momenta for energy conservation.
48745 IF(MOD(MSTJ(3),5).NE.0) THEN
48746 PMS=0D0
48747 PES=0D0
48748 PQS=0D0
48749 DO 450 I=NSAV+NJET+1,N
48750 PMS=PMS+P(I,5)
48751 PES=PES+P(I,4)
48752 PQS=PQS+P(I,5)**2/P(I,4)
48753 450 CONTINUE
48754 IF(PMS.GE.PECM) GOTO 150
48755 NECO=0
48756 460 NECO=NECO+1
48757 PFAC=(PECM-PQS)/(PES-PQS)
48758 PES=0D0
48759 PQS=0D0
48760 DO 480 I=NSAV+NJET+1,N
48761 DO 470 J=1,3
48762 P(I,J)=PFAC*P(I,J)
48763 470 CONTINUE
48764 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
48765 PES=PES+P(I,4)
48766 PQS=PQS+P(I,5)**2/P(I,4)
48767 480 CONTINUE
48768 IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
48769 ENDIF
48770
48771C...Origin of produced particles and parton daughter pointers.
48772 490 DO 500 I=NSAV+NJET+1,N
48773 IF(MSTU(16).NE.2) K(I,3)=NSAV+1
48774 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
48775 500 CONTINUE
48776 DO 510 I=NSAV+1,NSAV+NJET
48777 I1=K(I,3)
48778 K(I1,1)=K(I1,1)+10
48779 IF(MSTU(16).NE.2) THEN
48780 K(I1,4)=NSAV+1
48781 K(I1,5)=NSAV+1
48782 ELSE
48783 K(I1,4)=K(I1,4)-NJET+1
48784 K(I1,5)=K(I1,5)-NJET+1
48785 IF(K(I1,5).LT.K(I1,4)) THEN
48786 K(I1,4)=0
48787 K(I1,5)=0
48788 ENDIF
48789 ENDIF
48790 510 CONTINUE
48791
48792C...Document independent fragmentation system. Remove copy of jets.
48793 NSAV=NSAV+1
48794 K(NSAV,1)=11
48795 K(NSAV,2)=93
48796 K(NSAV,3)=IP
48797 K(NSAV,4)=NSAV+1
48798 K(NSAV,5)=N-NJET+1
48799 DO 520 J=1,4
48800 P(NSAV,J)=DPS(J)
48801 V(NSAV,J)=V(IP,J)
48802 520 CONTINUE
48803 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
48804 V(NSAV,5)=0D0
48805 DO 540 I=NSAV+NJET,N
48806 DO 530 J=1,5
48807 K(I-NJET+1,J)=K(I,J)
48808 P(I-NJET+1,J)=P(I,J)
48809 V(I-NJET+1,J)=V(I,J)
48810 530 CONTINUE
48811 540 CONTINUE
48812 N=N-NJET+1
48813 DO 550 IZ=MSTU90+1,MSTU(90)
48814 MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
48815 550 CONTINUE
48816
48817C...Boost back particle system. Set production vertices.
48818 IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
48819 &DPS(2)/DPS(4),DPS(3)/DPS(4))
48820 DO 570 I=NSAV+1,N
48821 DO 560 J=1,4
48822 V(I,J)=V(IP,J)
48823 560 CONTINUE
48824 570 CONTINUE
48825
48826 RETURN
48827 END
48828
48829C*********************************************************************
48830
48831C...PYDECY
48832C...Handles the decay of unstable particles.
48833
48834 SUBROUTINE PYDECY(IP)
48835
48836C...Double precision and integer declarations.
48837 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48838 IMPLICIT INTEGER(I-N)
48839 INTEGER PYK,PYCHGE,PYCOMP
48840C...Commonblocks.
48841 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
48842 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48843 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48844 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
48845 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
48846C...Local arrays.
48847 DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
48848 &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
48849 CHARACTER CIDC*4
48850 DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
48851
48852C...Functions: momentum in two-particle decays and four-product.
48853 PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
48854 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)
48855
48856C...Initial values.
48857 NTRY=0
48858 NSAV=N
48859 KFA=IABS(K(IP,2))
48860 KFS=ISIGN(1,K(IP,2))
48861 KC=PYCOMP(KFA)
48862 MSTJ(92)=0
48863
48864C...Choose lifetime and determine decay vertex.
48865 IF(K(IP,1).EQ.5) THEN
48866 V(IP,5)=0D0
48867 ELSEIF(K(IP,1).NE.4) THEN
48868 V(IP,5)=-PMAS(KC,4)*LOG(PYR(0))
48869 ENDIF
48870 DO 100 J=1,4
48871 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
48872 100 CONTINUE
48873
48874C...Determine whether decay allowed or not.
48875 MOUT=0
48876 IF(MSTJ(22).EQ.2) THEN
48877 IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
48878 ELSEIF(MSTJ(22).EQ.3) THEN
48879 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
48880 ELSEIF(MSTJ(22).EQ.4) THEN
48881 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
48882 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
48883 ENDIF
48884 IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
48885 K(IP,1)=4
48886 RETURN
48887 ENDIF
48888
48889C...Interface to external tau decay library (for tau polarization).
48890 IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
48891
48892C...Starting values for pointers and momenta.
48893 ITAU=IP
48894 DO 110 J=1,4
48895 PTAU(J)=P(ITAU,J)
48896 PCMTAU(J)=P(ITAU,J)
48897 110 CONTINUE
48898
48899C...Iterate to find position and code of mother of tau.
48900 IMTAU=ITAU
48901 120 IMTAU=K(IMTAU,3)
48902
48903 IF(IMTAU.EQ.0) THEN
48904C...If no known origin then impossible to do anything further.
48905 KFORIG=0
48906 IORIG=0
48907
48908 ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
48909C...If tau -> tau + gamma then add gamma energy and loop.
48910 IF(K(K(IMTAU,4),2).EQ.22) THEN
48911 DO 130 J=1,4
48912 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
48913 130 CONTINUE
48914 ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
48915 DO 140 J=1,4
48916 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
48917 140 CONTINUE
48918 ENDIF
48919 GOTO 120
48920
48921 ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
48922C...If coming from weak decay of hadron then W is not stored in record,
48923C...but can be reconstructed by adding neutrino momentum.
48924 KFORIG=-ISIGN(24,K(ITAU,2))
48925 IORIG=0
48926 DO 160 II=K(IMTAU,4),K(IMTAU,5)
48927 IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
48928 DO 150 J=1,4
48929 PCMTAU(J)=PCMTAU(J)+P(II,J)
48930 150 CONTINUE
48931 ENDIF
48932 160 CONTINUE
48933
48934 ELSE
48935C...If coming from resonance decay then find latest copy of this
48936C...resonance (may not completely agree).
48937 KFORIG=K(IMTAU,2)
48938 IORIG=IMTAU
48939 DO 170 II=IMTAU+1,IP-1
48940 IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
48941 & ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II
48942 170 CONTINUE
48943 DO 180 J=1,4
48944 PCMTAU(J)=P(IORIG,J)
48945 180 CONTINUE
48946 ENDIF
48947
48948C...Boost tau to rest frame of production process (where known)
48949C...and rotate it to sit along +z axis.
48950 DO 190 J=1,3
48951 DBETAU(J)=PCMTAU(J)/PCMTAU(4)
48952 190 CONTINUE
48953 IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1),
48954 & -DBETAU(2),-DBETAU(3))
48955 PHITAU=PYANGL(P(ITAU,1),P(ITAU,2))
48956 CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0)
48957 THETAU=PYANGL(P(ITAU,3),P(ITAU,1))
48958 CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0)
48959
48960C...Call tau decay routine (if meaningful) and fill extra info.
48961 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
48962 CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
48963 DO 200 II=NSAV+1,NSAV+NDECAY
48964 K(II,1)=1
48965 K(II,3)=IP
48966 K(II,4)=0
48967 K(II,5)=0
48968 200 CONTINUE
48969 N=NSAV+NDECAY
48970 ENDIF
48971
48972C...Boost back decay tau and decay products.
48973 DO 210 J=1,4
48974 P(ITAU,J)=PTAU(J)
48975 210 CONTINUE
48976 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
48977 CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
48978 IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1),
48979 & DBETAU(2),DBETAU(3))
48980
48981C...Skip past ordinary tau decay treatment.
48982 MMAT=0
48983 MBST=0
48984 ND=0
48985 GOTO 630
48986 ENDIF
48987 ENDIF
48988
48989C...B-Bbar mixing: flip sign of meson appropriately.
48990 MMIX=0
48991 IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
48992 XBBMIX=PARJ(76)
48993 IF(KFA.EQ.531) XBBMIX=PARJ(77)
48994 IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1
48995 IF(MMIX.EQ.1) KFS=-KFS
48996 ENDIF
48997
48998C...Check existence of decay channels. Particle/antiparticle rules.
48999 KCA=KC
49000 IF(MDCY(KC,2).GT.0) THEN
49001 MDMDCY=MDME(MDCY(KC,2),2)
49002 IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
49003 ENDIF
49004 IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
49005 CALL PYERRM(9,'(PYDECY:) no decay channel defined')
49006 RETURN
49007 ENDIF
49008 IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS
49009 IF(KCHG(KC,3).EQ.0) THEN
49010 KFSP=1
49011 KFSN=0
49012 IF(PYR(0).GT.0.5D0) KFS=-KFS
49013 ELSEIF(KFS.GT.0) THEN
49014 KFSP=1
49015 KFSN=0
49016 ELSE
49017 KFSP=0
49018 KFSN=1
49019 ENDIF
49020
49021C...Sum branching ratios of allowed decay channels.
49022 220 NOPE=0
49023 BRSU=0D0
49024 DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
49025 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
49026 & KFSN*MDME(IDL,1).NE.3) GOTO 230
49027 IF(MDME(IDL,2).GT.100) GOTO 230
49028 NOPE=NOPE+1
49029 BRSU=BRSU+BRAT(IDL)
49030 230 CONTINUE
49031 IF(NOPE.EQ.0) THEN
49032 CALL PYERRM(2,'(PYDECY:) all decay channels closed by user')
49033 RETURN
49034 ENDIF
49035
49036C...Select decay channel among allowed ones.
49037 240 RBR=BRSU*PYR(0)
49038 IDL=MDCY(KCA,2)-1
49039 250 IDL=IDL+1
49040 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
49041 &KFSN*MDME(IDL,1).NE.3) THEN
49042 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
49043 ELSEIF(MDME(IDL,2).GT.100) THEN
49044 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
49045 ELSE
49046 IDC=IDL
49047 RBR=RBR-BRAT(IDL)
49048 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250
49049 ENDIF
49050
49051C...Start readout of decay channel: matrix element, reset counters.
49052 MMAT=MDME(IDC,2)
49053 260 NTRY=NTRY+1
49054 IF(MOD(NTRY,200).EQ.0) THEN
49055 WRITE(CIDC,'(I4)') IDC
49056C...Do not print warning for some well-known special cases.
49057 IF(KFA.NE.113.AND.KFA.NE.115.AND.KFA.NE.215)
49058 & CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'//
49059 & CIDC)
49060 GOTO 240
49061 ENDIF
49062 IF(NTRY.GT.1000) THEN
49063 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
49064 IF(MSTU(21).GE.1) RETURN
49065 ENDIF
49066 I=N
49067 NP=0
49068 NQ=0
49069 MBST=0
49070 IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1
49071 DO 270 J=1,4
49072 PV(1,J)=0D0
49073 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
49074 270 CONTINUE
49075 IF(MBST.EQ.1) PV(1,4)=P(IP,5)
49076 PV(1,5)=P(IP,5)
49077 PS=0D0
49078 PSQ=0D0
49079 MREM=0
49080 MHADDY=0
49081 IF(KFA.GT.80) MHADDY=1
49082C.. Random flavour and popcorn system memory.
49083 IRNDMO=0
49084 JTMO=0
49085 MSTU(121)=0
49086 MSTU(125)=10
49087
49088C...Read out decay products. Convert to standard flavour code.
49089 JTMAX=5
49090 IF(MDME(IDC+1,2).EQ.101) JTMAX=10
49091 DO 280 JT=1,JTMAX
49092 IF(JT.LE.5) KP=KFDP(IDC,JT)
49093 IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
49094 IF(KP.EQ.0) GOTO 280
49095 KPA=IABS(KP)
49096 KCP=PYCOMP(KPA)
49097 IF(KPA.GT.80) MHADDY=1
49098 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
49099 KFP=KP
49100 ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
49101 KFP=KFS*KP
49102 ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
49103 KFP=-KFS*MOD(KFA/10,10)
49104 ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
49105 KFP=KFS*(100*MOD(KFA/10,100)+3)
49106 ELSEIF(KPA.EQ.81) THEN
49107 KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
49108 ELSEIF(KP.EQ.82) THEN
49109 CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP)
49110 IF(KFP.EQ.0) GOTO 260
49111 KFP=-KFP
49112 IRNDMO=1
49113 MSTJ(93)=1
49114 IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260
49115 ELSEIF(KP.EQ.-82) THEN
49116 KFP=MSTU(124)
49117 ENDIF
49118 IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP)
49119
49120C...Add decay product to event record or to quark flavour list.
49121 KFPA=IABS(KFP)
49122 KQP=KCHG(KCP,2)
49123 IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
49124 NQ=NQ+1
49125 KFLO(NQ)=KFP
49126C...set rndmflav popcorn system pointer
49127 IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ
49128 MSTJ(93)=2
49129 PSQ=PSQ+PYMASS(KFLO(NQ))
49130 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
49131 & MOD(NQ,2).EQ.1) THEN
49132 NQ=NQ-1
49133 PS=PS-P(I,5)
49134 K(I,1)=1
49135 KFI=K(I,2)
49136 CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2))
49137 IF(K(I,2).EQ.0) GOTO 260
49138 MSTJ(93)=1
49139 P(I,5)=PYMASS(K(I,2))
49140 PS=PS+P(I,5)
49141 ELSE
49142 I=I+1
49143 NP=NP+1
49144 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
49145 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
49146 K(I,1)=1+MOD(NQ,2)
49147 IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
49148 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
49149 K(I,2)=KFP
49150 K(I,3)=IP
49151 K(I,4)=0
49152 K(I,5)=0
49153 P(I,5)=PYMASS(KFP)
49154 PS=PS+P(I,5)
49155 ENDIF
49156 280 CONTINUE
49157
49158C...Check masses for resonance decays.
49159 IF(MHADDY.EQ.0) THEN
49160 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
49161 ENDIF
49162
49163C...Choose decay multiplicity in phase space model.
49164 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
49165 PSP=PS
49166 CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0))
49167 IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
49168 300 NTRY=NTRY+1
49169C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
49170 IF(IRNDMO.EQ.0) THEN
49171 MSTU(121)=0
49172 JTMO=0
49173 ELSEIF(IRNDMO.EQ.1) THEN
49174 IRNDMO=2
49175 ELSE
49176 GOTO 260
49177 ENDIF
49178 IF(NTRY.GT.1000) THEN
49179 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
49180 IF(MSTU(21).GE.1) RETURN
49181 ENDIF
49182 IF(MMAT.LE.20) THEN
49183 GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))*
49184 & SIN(PARU(2)*PYR(0))
49185 ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS
49186 IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
49187 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
49188 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
49189 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
49190 ELSE
49191 ND=MMAT-20
49192 ENDIF
49193C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
49194 MSTU(125)=ND-NQ/2
49195 IF(MSTU(121).GT.MSTU(125)) GOTO 300
49196
49197C...Form hadrons from flavour content.
49198 DO 310 JT=1,NQ
49199 KFL1(JT)=KFLO(JT)
49200 310 CONTINUE
49201 IF(ND.EQ.NP+NQ/2) GOTO 330
49202 DO 320 I=N+NP+1,N+ND-NQ/2
49203C.. Stick to started popcorn system, else pick side at random
49204 JT=JTMO
49205 IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0))
49206 CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2))
49207 IF(K(I,2).EQ.0) GOTO 300
49208 MSTU(125)=MSTU(125)-1
49209 JTMO=0
49210 IF(MSTU(121).GT.0) JTMO=JT
49211 KFL1(JT)=-KFL2
49212 320 CONTINUE
49213 330 JT=2
49214 JT2=3
49215 JT3=4
49216 IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4
49217 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
49218 & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
49219 IF(JT.EQ.3) JT2=2
49220 IF(JT.EQ.4) JT3=2
49221 CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
49222 IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
49223 IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
49224 IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
49225
49226C...Check that sum of decay product masses not too large.
49227 PS=PSP
49228 DO 340 I=N+NP+1,N+ND
49229 K(I,1)=1
49230 K(I,3)=IP
49231 K(I,4)=0
49232 K(I,5)=0
49233 P(I,5)=PYMASS(K(I,2))
49234 PS=PS+P(I,5)
49235 340 CONTINUE
49236 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
49237
49238C...Rescale energy to subtract off spectator quark mass.
49239 ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44)
49240 & .AND.NP.GE.3) THEN
49241 PS=PS-P(N+NP,5)
49242 PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
49243 DO 350 J=1,5
49244 P(N+NP,J)=PQT*PV(1,J)
49245 PV(1,J)=(1D0-PQT)*PV(1,J)
49246 350 CONTINUE
49247 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
49248 ND=NP-1
49249 MREM=1
49250
49251C...Fully specified final state: check mass broadening effects.
49252 ELSE
49253 IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
49254 ND=NP
49255 ENDIF
49256
49257C...Determine position of grandmother, number of sisters.
49258 NM=0
49259 KFAS=0
49260 MSGN=0
49261 IF(MMAT.EQ.3) THEN
49262 IM=K(IP,3)
49263 IF(IM.LT.0.OR.IM.GE.IP) IM=0
49264 IF(IM.NE.0) KFAM=IABS(K(IM,2))
49265 IF(IM.NE.0) THEN
49266 DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
49267 IF(K(IL,3).EQ.IM) NM=NM+1
49268 IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
49269 360 CONTINUE
49270 IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
49271 & MOD(KFAM/1000,10).NE.0) NM=0
49272 IF(NM.EQ.2) THEN
49273 KFAS=IABS(K(ISIS,2))
49274 IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
49275 & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
49276 ENDIF
49277 ENDIF
49278 ENDIF
49279
49280C...Kinematics of one-particle decays.
49281 IF(ND.EQ.1) THEN
49282 DO 370 J=1,4
49283 P(N+1,J)=P(IP,J)
49284 370 CONTINUE
49285 GOTO 630
49286 ENDIF
49287
49288C...Calculate maximum weight ND-particle decay.
49289 PV(ND,5)=P(N+ND,5)
49290 IF(ND.GE.3) THEN
49291 WTMAX=1D0/WTCOR(ND-2)
49292 PMAX=PV(1,5)-PS+P(N+ND,5)
49293 PMIN=0D0
49294 DO 380 IL=ND-1,1,-1
49295 PMAX=PMAX+P(N+IL,5)
49296 PMIN=PMIN+P(N+IL+1,5)
49297 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
49298 380 CONTINUE
49299 ENDIF
49300
49301C...Find virtual gamma mass in Dalitz decay.
49302 390 IF(ND.EQ.2) THEN
49303 ELSEIF(MMAT.EQ.2) THEN
49304 PMES=4D0*PMAS(11,1)**2
49305 PMRHO2=PMAS(131,1)**2
49306 PGRHO2=PMAS(131,2)**2
49307 400 PMST=PMES*(P(IP,5)**2/PMES)**PYR(0)
49308 WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))*
49309 & (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/
49310 & ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
49311 IF(WT.LT.PYR(0)) GOTO 400
49312 PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST))
49313
49314C...M-generator gives weight. If rejected, try again.
49315 ELSE
49316 410 RORD(1)=1D0
49317 DO 440 IL1=2,ND-1
49318 RSAV=PYR(0)
49319 DO 420 IL2=IL1-1,1,-1
49320 IF(RSAV.LE.RORD(IL2)) GOTO 430
49321 RORD(IL2+1)=RORD(IL2)
49322 420 CONTINUE
49323 430 RORD(IL2+1)=RSAV
49324 440 CONTINUE
49325 RORD(ND)=0D0
49326 WT=1D0
49327 DO 450 IL=ND-1,1,-1
49328 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
49329 & (PV(1,5)-PS)
49330 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
49331 450 CONTINUE
49332 IF(WT.LT.PYR(0)*WTMAX) GOTO 410
49333 ENDIF
49334
49335C...Perform two-particle decays in respective CM frame.
49336 460 DO 480 IL=1,ND-1
49337 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
49338 UE(3)=2D0*PYR(0)-1D0
49339 PHI=PARU(2)*PYR(0)
49340 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
49341 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
49342 DO 470 J=1,3
49343 P(N+IL,J)=PA*UE(J)
49344 PV(IL+1,J)=-PA*UE(J)
49345 470 CONTINUE
49346 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
49347 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
49348 480 CONTINUE
49349
49350C...Lorentz transform decay products to lab frame.
49351 DO 490 J=1,4
49352 P(N+ND,J)=PV(ND,J)
49353 490 CONTINUE
49354 DO 530 IL=ND-1,1,-1
49355 DO 500 J=1,3
49356 BE(J)=PV(IL,J)/PV(IL,4)
49357 500 CONTINUE
49358 GA=PV(IL,4)/PV(IL,5)
49359 DO 520 I=N+IL,N+ND
49360 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
49361 DO 510 J=1,3
49362 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
49363 510 CONTINUE
49364 P(I,4)=GA*(P(I,4)+BEP)
49365 520 CONTINUE
49366 530 CONTINUE
49367
49368C...Check that no infinite loop in matrix element weight.
49369 NTRY=NTRY+1
49370 IF(NTRY.GT.800) GOTO 560
49371
49372C...Matrix elements for omega and phi decays.
49373 IF(MMAT.EQ.1) THEN
49374 WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
49375 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
49376 & +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
49377 IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390
49378
49379C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
49380 ELSEIF(MMAT.EQ.2) THEN
49381 FOUR12=FOUR(N+1,N+2)
49382 FOUR13=FOUR(N+1,N+3)
49383 WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+
49384 & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
49385 IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460
49386
49387C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
49388C...V vector), of form cos**2(theta02) in V1 rest frame, and for
49389C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
49390 ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
49391 FOUR10=FOUR(IP,IM)
49392 FOUR12=FOUR(IP,N+1)
49393 FOUR02=FOUR(IM,N+1)
49394 PMS1=P(IP,5)**2
49395 PMS0=P(IM,5)**2
49396 PMS2=P(N+1,5)**2
49397 IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
49398 IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02-
49399 & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
49400 HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM)
49401 HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
49402 IF(HNUM.LT.PYR(0)*HDEN) GOTO 460
49403
49404C...Matrix element for "onium" -> g + g + g or gamma + g + g.
49405 ELSEIF(MMAT.EQ.4) THEN
49406 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
49407 HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2
49408 HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2
49409 WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+
49410 & ((1D0-HX3)/(HX1*HX2))**2
49411 IF(WT.LT.2D0*PYR(0)) GOTO 390
49412 IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2)
49413 & GOTO 390
49414
49415C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
49416 ELSEIF(MMAT.EQ.41) THEN
49417 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
49418 HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5)))
49419 IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390
49420
49421C...Matrix elements for weak decays (only semileptonic for c and b)
49422 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
49423 & .AND.ND.EQ.3) THEN
49424 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
49425 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
49426 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
49427 ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN
49428 DO 550 J=1,4
49429 P(N+NP+1,J)=0D0
49430 DO 540 IS=N+3,N+NP
49431 P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
49432 540 CONTINUE
49433 550 CONTINUE
49434 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
49435 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
49436 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
49437 ENDIF
49438
49439C...Scale back energy and reattach spectator.
49440 560 IF(MREM.EQ.1) THEN
49441 DO 570 J=1,5
49442 PV(1,J)=PV(1,J)/(1D0-PQT)
49443 570 CONTINUE
49444 ND=ND+1
49445 MREM=0
49446 ENDIF
49447
49448C...Low invariant mass for system with spectator quark gives particle,
49449C...not two jets. Readjust momenta accordingly.
49450 IF(MMAT.EQ.31.AND.ND.EQ.3) THEN
49451 MSTJ(93)=1
49452 PM2=PYMASS(K(N+2,2))
49453 MSTJ(93)=1
49454 PM3=PYMASS(K(N+3,2))
49455 IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE.
49456 & (PARJ(32)+PM2+PM3)**2) GOTO 630
49457 K(N+2,1)=1
49458 KFTEMP=K(N+2,2)
49459 CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
49460 IF(K(N+2,2).EQ.0) GOTO 260
49461 P(N+2,5)=PYMASS(K(N+2,2))
49462 PS=P(N+1,5)+P(N+2,5)
49463 PV(2,5)=P(N+2,5)
49464 MMAT=0
49465 ND=2
49466 GOTO 460
49467 ELSEIF(MMAT.EQ.44) THEN
49468 MSTJ(93)=1
49469 PM3=PYMASS(K(N+3,2))
49470 MSTJ(93)=1
49471 PM4=PYMASS(K(N+4,2))
49472 IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE.
49473 & (PARJ(32)+PM3+PM4)**2) GOTO 600
49474 K(N+3,1)=1
49475 KFTEMP=K(N+3,2)
49476 CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
49477 IF(K(N+3,2).EQ.0) GOTO 260
49478 P(N+3,5)=PYMASS(K(N+3,2))
49479 DO 580 J=1,3
49480 P(N+3,J)=P(N+3,J)+P(N+4,J)
49481 580 CONTINUE
49482 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)
49483 HA=P(N+1,4)**2-P(N+2,4)**2
49484 HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
49485 HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
49486 & (P(N+1,3)-P(N+2,3))**2
49487 HD=(PV(1,4)-P(N+3,4))**2
49488 HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
49489 HF=HD*HC-HB**2
49490 HG=HD*HC-HA*HB
49491 HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF)
49492 DO 590 J=1,3
49493 PCOR=HH*(P(N+1,J)-P(N+2,J))
49494 P(N+1,J)=P(N+1,J)+PCOR
49495 P(N+2,J)=P(N+2,J)-PCOR
49496 590 CONTINUE
49497 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)
49498 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)
49499 ND=ND-1
49500 ENDIF
49501
49502C...Check invariant mass of W jets. May give one particle or start over.
49503 600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
49504 &.AND.IABS(K(N+1,2)).LT.10) THEN
49505 PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2)))
49506 MSTJ(93)=1
49507 PM1=PYMASS(K(N+1,2))
49508 MSTJ(93)=1
49509 PM2=PYMASS(K(N+2,2))
49510 IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610
49511 KFLDUM=INT(1.5D0+PYR(0))
49512 CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
49513 CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
49514 IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260
49515 PSM=PYMASS(KF1)+PYMASS(KF2)
49516 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610
49517 IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610
49518 IF(MMAT.EQ.48) GOTO 390
49519 IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260
49520 K(N+1,1)=1
49521 KFTEMP=K(N+1,2)
49522 CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
49523 IF(K(N+1,2).EQ.0) GOTO 260
49524 P(N+1,5)=PYMASS(K(N+1,2))
49525 K(N+2,2)=K(N+3,2)
49526 P(N+2,5)=P(N+3,5)
49527 PS=P(N+1,5)+P(N+2,5)
49528 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
49529 PV(2,5)=P(N+3,5)
49530 MMAT=0
49531 ND=2
49532 GOTO 460
49533 ENDIF
49534
49535C...Phase space decay of partons from W decay.
49536 610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN
49537 KFLO(1)=K(N+1,2)
49538 KFLO(2)=K(N+2,2)
49539 K(N+1,1)=K(N+3,1)
49540 K(N+1,2)=K(N+3,2)
49541 DO 620 J=1,5
49542 PV(1,J)=P(N+1,J)+P(N+2,J)
49543 P(N+1,J)=P(N+3,J)
49544 620 CONTINUE
49545 PV(1,5)=PMR
49546 N=N+1
49547 NP=0
49548 NQ=2
49549 PS=0D0
49550 MSTJ(93)=2
49551 PSQ=PYMASS(KFLO(1))
49552 MSTJ(93)=2
49553 PSQ=PSQ+PYMASS(KFLO(2))
49554 MMAT=11
49555 GOTO 290
49556 ENDIF
49557
49558C...Boost back for rapidly moving particle.
49559 630 N=N+ND
49560 IF(MBST.EQ.1) THEN
49561 DO 640 J=1,3
49562 BE(J)=P(IP,J)/P(IP,4)
49563 640 CONTINUE
49564 GA=P(IP,4)/P(IP,5)
49565 DO 660 I=NSAV+1,N
49566 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
49567 DO 650 J=1,3
49568 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
49569 650 CONTINUE
49570 P(I,4)=GA*(P(I,4)+BEP)
49571 660 CONTINUE
49572 ENDIF
49573
49574C...Fill in position of decay vertex.
49575 DO 680 I=NSAV+1,N
49576 DO 670 J=1,4
49577 V(I,J)=VDCY(J)
49578 670 CONTINUE
49579 V(I,5)=0D0
49580 680 CONTINUE
49581
49582C...Set up for parton shower evolution from jets.
49583 IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
49584 K(NSAV+1,1)=3
49585 K(NSAV+2,1)=3
49586 K(NSAV+3,1)=3
49587 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
49588 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
49589 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
49590 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
49591 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
49592 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
49593 MSTJ(92)=-(NSAV+1)
49594 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
49595 K(NSAV+2,1)=3
49596 K(NSAV+3,1)=3
49597 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
49598 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
49599 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
49600 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
49601 MSTJ(92)=NSAV+2
49602 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
49603 & IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
49604 K(NSAV+1,1)=3
49605 K(NSAV+2,1)=3
49606 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
49607 K(NSAV+1,5)=MSTU(5)*(NSAV+2)
49608 K(NSAV+2,4)=MSTU(5)*(NSAV+1)
49609 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
49610 MSTJ(92)=NSAV+1
49611 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
49612 & IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
49613 MSTJ(92)=NSAV+1
49614 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
49615 & THEN
49616 K(NSAV+1,1)=3
49617 K(NSAV+2,1)=3
49618 K(NSAV+3,1)=3
49619 KCP=PYCOMP(K(NSAV+1,2))
49620 KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
49621 JCON=4
49622 IF(KQP.LT.0) JCON=5
49623 K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
49624 K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
49625 K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
49626 K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
49627 MSTJ(92)=NSAV+1
49628 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
49629 K(NSAV+1,1)=3
49630 K(NSAV+3,1)=3
49631 K(NSAV+1,4)=MSTU(5)*(NSAV+3)
49632 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
49633 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
49634 K(NSAV+3,5)=MSTU(5)*(NSAV+1)
49635 MSTJ(92)=NSAV+1
49636 ENDIF
49637
49638C...Mark decayed particle; special option for B-Bbar mixing.
49639 IF(K(IP,1).EQ.5) K(IP,1)=15
49640 IF(K(IP,1).LE.10) K(IP,1)=11
49641 IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
49642 K(IP,4)=NSAV+1
49643 K(IP,5)=N
49644
49645 RETURN
49646 END
49647
49648
49649C*********************************************************************
49650
49651C...PYDCYK
49652C...Handles flavour production in the decay of unstable particles
49653C...and small string clusters.
49654
49655 SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF)
49656
49657C...Double precision and integer declarations.
49658 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49659 IMPLICIT INTEGER(I-N)
49660 INTEGER PYK,PYCHGE,PYCOMP
49661C...Commonblocks.
49662 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49663 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49664 SAVE /PYDAT1/,/PYDAT2/
49665
49666
49667C.. Call PYKFDI directly if no popcorn option is on
49668 IF(MSTJ(12).LT.2) THEN
49669 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
49670 MSTU(124)=KFL3
49671 RETURN
49672 ENDIF
49673
49674 KFL3=0
49675 KF=0
49676 IF(KFL1.EQ.0) RETURN
49677 KF1A=IABS(KFL1)
49678 KF2A=IABS(KFL2)
49679
49680 NSTO=130
49681 NMAX=MIN(MSTU(125),10)
49682
49683C.. Identify rank 0 cluster qq
49684 IRANK=1
49685 IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0
49686
49687 IF(KF2A.GT.0)THEN
49688C.. Join jets: Fails if store not empty
49689 IF(MSTU(121).GT.0) THEN
49690 MSTU(121)=0
49691 RETURN
49692 ENDIF
49693 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
49694 ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN
49695C.. Pick popcorn meson from store, return same qq, decrease store
49696 KF=MSTU(NSTO+MSTU(121))
49697 KFL3=-KFL1
49698 MSTU(121)=MSTU(121)-1
49699 ELSE
49700C.. Generate new flavour. Then done if no diquark is generated
49701 100 CALL PYKFDI(KFL1,0,KFL3,KF)
49702 IF(MSTU(121).EQ.-1) GOTO 100
49703 MSTU(124)=KFL3
49704 IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN
49705
49706C.. Simple case if no dynamical popcorn suppressions are considered
49707 IF(MSTJ(12).LT.4) THEN
49708 IF(MSTU(121).EQ.0) RETURN
49709 NMES=1
49710 KFPREV=-KFL3
49711 CALL PYKFDI(KFPREV,0,KFL3,KFM)
49712C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
49713 IF(IABS(KFL3).LE.10)THEN
49714 KFL3=-KFPREV
49715 RETURN
49716 ENDIF
49717 GOTO 120
49718 ENDIF
49719
49720C test output qq against fake Gamma, then return if no popcorn.
49721 GB=2D0
49722 IF(IRANK.NE.0)THEN
49723 CALL PYZDIS(1,2103,5D0,Z)
49724 GB=5D0*(1D0-Z)/Z
49725 IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN
49726 MSTU(121)=0
49727 GOTO 100
49728 ENDIF
49729 ENDIF
49730 IF(MSTU(121).EQ.0) RETURN
49731
49732C..Set store size memory. Pick fake dynamical variables of qq.
49733 NMES=MSTU(121)
49734 CALL PYPTDI(1,PX3,PY3)
49735 X=1D0
49736 POPM=0D0
49737 G=GB
49738 POPG=GB
49739
49740C.. Pick next popcorn meson, test with fake dynamical variables
49741 110 KFPREV=-KFL3
49742 PX1=-PX3
49743 PY1=-PY3
49744 CALL PYKFDI(KFPREV,0,KFL3,KFM)
49745 IF(MSTU(121).EQ.-1) GOTO 100
49746 CALL PYPTDI(KFL3,PX3,PY3)
49747 PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2
49748 CALL PYZDIS(KFPREV,KFL3,PM,Z)
49749 G=(1D0-Z)*(G+PM/Z)
49750 X=(1D0-Z)*X
49751
49752 PTST=1D0
49753 GTST=1D0
49754 RTST=PYR(0)
49755 IF(MSTJ(12).GT.4)THEN
49756 POPMN=SQRT((1D0-X)*(G/X-GB))
49757 POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
49758 PTST=EXP((POPM-POPMN)*PARF(193))
49759 POPM=POPMN
49760 ENDIF
49761 IF(IRANK.NE.0)THEN
49762 POPGN=X*GB
49763 GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG)
49764 POPG=POPGN
49765 ENDIF
49766 IF(RTST.GT.PTST*GTST)THEN
49767 MSTU(121)=0
49768 IF(RTST.GT.PTST) MSTU(121)=-1
49769 GOTO 100
49770 ENDIF
49771
49772C.. Store meson
49773 120 IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM
49774 IF(MSTU(121).GT.0) GOTO 110
49775
49776C.. Test accepted system size. If OK set global popcorn size variable.
49777 IF(NMES.GT.NMAX)THEN
49778 KF=0
49779 KFL3=0
49780 RETURN
49781 ENDIF
49782 MSTU(121)=NMES
49783 ENDIF
49784
49785 RETURN
49786 END
49787
49788C********************************************************************
49789
49790C...PYKFDI
49791C...Generates a new flavour pair and combines off a hadron
49792
49793 SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF)
49794
49795C...Double precision and integer declarations.
49796 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49797 IMPLICIT INTEGER(I-N)
49798 INTEGER PYK,PYCHGE,PYCOMP
49799C...Commonblocks.
49800 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49801 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49802 SAVE /PYDAT1/,/PYDAT2/
49803C...Local arrays.
49804 DIMENSION PD(7)
49805
49806 IF(MSTU(123).EQ.0.AND.MSTJ(12).GE.0) CALL PYKFIN
49807
49808C...Default flavour values. Input consistency checks.
49809 KF1A=IABS(KFL1)
49810 KF2A=IABS(KFL2)
49811 KFL3=0
49812 KF=0
49813 IF(KF1A.EQ.0) RETURN
49814 IF(KF2A.NE.0)THEN
49815 IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
49816 IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
49817 IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
49818 ENDIF
49819
49820C...Check if tabulated flavour probabilities are to be used.
49821 IF(MSTJ(15).EQ.1) THEN
49822 IF(MSTJ(12).GE.5) CALL PYERRM(29,
49823 & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
49824 & ' together with MSTJ(12)>=5 modification')
49825 KTAB1=-1
49826 IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
49827 KFL1A=MOD(KF1A/1000,10)
49828 KFL1B=MOD(KF1A/100,10)
49829 KFL1S=MOD(KF1A,10)
49830 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
49831 & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
49832 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
49833 IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
49834 KTAB2=0
49835 IF(KF2A.NE.0) THEN
49836 KTAB2=-1
49837 IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
49838 KFL2A=MOD(KF2A/1000,10)
49839 KFL2B=MOD(KF2A/100,10)
49840 KFL2S=MOD(KF2A,10)
49841 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
49842 & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
49843 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
49844 ENDIF
49845 IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
49846 ENDIF
49847
49848C.. Recognize rank 0 diquark case
49849 100 IRANK=1
49850 KFDIQ=MAX(KF1A,KF2A)
49851 IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0
49852
49853C.. Join two flavours to meson or baryon. Test for popcorn.
49854 IF(KF2A.GT.0)THEN
49855 MBARY=0
49856 IF(KFDIQ.GT.10) THEN
49857 IF(IRANK.EQ.0.AND.MSTJ(12).LT.5)
49858 & CALL PYNMES(KFDIQ)
49859 IF(MSTU(121).NE.0) THEN
49860 MSTU(121)=0
49861 RETURN
49862 ENDIF
49863 MBARY=2
49864 ENDIF
49865 KFQOLD=KF1A
49866 KFQVER=KF2A
49867 GOTO 130
49868 ENDIF
49869
49870C.. Separate incoming flavours, curtain flavour consistency check
49871 KFIN=KFL1
49872 KFQOLD=KF1A
49873 KFQPOP=KF1A/10000
49874 IF(KF1A.GT.10)THEN
49875 KFIN=-KFL1
49876 KFL1A=MOD(KF1A/1000,10)
49877 KFL1B=MOD(KF1A/100,10)
49878 IF(IRANK.EQ.0)THEN
49879 QAWT=1D0
49880 IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4)
49881 IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4)
49882 KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0))
49883 ENDIF
49884 IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) THEN
49885 MSTU(121)=0
49886 RETURN
49887 ENDIF
49888 KFQOLD=KFL1A+KFL1B-KFQPOP
49889 ENDIF
49890
49891C...Meson/baryon choice. Set number of mesons if starting a popcorn
49892C...system.
49893 110 MBARY=0
49894 IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN
49895 IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN
49896 MBARY=1
49897 CALL PYNMES(0)
49898 ENDIF
49899 ELSEIF(KF1A.GT.10)THEN
49900 MBARY=2
49901 IF(IRANK.EQ.0) CALL PYNMES(KF1A)
49902 IF(MSTU(121).GT.0) MBARY=-1
49903 ENDIF
49904
49905C..x->H+q: Choose single vertex quark. Jump to form hadron.
49906 IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN
49907 KFQVER=1+INT((2D0+PARJ(2))*PYR(0))
49908 KFL3=ISIGN(KFQVER,-KFIN)
49909 GOTO 130
49910 ENDIF
49911
49912C..x->H+qq: (IDW=proper PARF position for diquark weights)
49913 IDW=160
49914 IF(MBARY.EQ.1)THEN
49915 IF(MSTU(121).EQ.0) IDW=150
49916 SQWT=PARF(IDW+1)
49917 IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121)
49918 KFQPOP=1+INT((2D0+SQWT)*PYR(0))
49919C.. Shift to s-curtain parameters if needed
49920 IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN
49921 PARF(194)=PARF(138)*PARF(139)
49922 PARF(193)=PARJ(8)+PARJ(9)
49923 ENDIF
49924 ENDIF
49925
49926C.. x->H+qq: Get vertex quark
49927 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
49928 IDW=MSTU(122)
49929 MSTU(121)=MSTU(121)-1
49930 IF(IDW.EQ.170) THEN
49931 IF(MSTU(121).EQ.0)THEN
49932 IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2)
49933 ELSE
49934 IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
49935 ENDIF
49936 ELSE
49937 IF(MSTU(121).EQ.0)THEN
49938 IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
49939 ELSE
49940 IPOS=3*5+5*4+MIN(KFQOLD-1,4)
49941 ENDIF
49942 ENDIF
49943 IPOS=200+30*IPOS+1
49944
49945 IMES=-1
49946 RMES=PYR(0)*PARF(194)
49947 120 IMES=IMES+1
49948 RMES=RMES-PARF(IPOS+IMES)
49949 IF(IMES.EQ.30) THEN
49950 MSTU(121)=-1
49951 KF=-111
49952 RETURN
49953 ENDIF
49954 IF(RMES.GT.0D0) GOTO 120
49955 KMUL=IMES/5
49956 KFJ=2*KMUL+1
49957 IF(KMUL.EQ.2) KFJ=10003
49958 IF(KMUL.EQ.3) KFJ=10001
49959 IF(KMUL.EQ.4) KFJ=20003
49960 IF(KMUL.EQ.5) KFJ=5
49961 IDIAG=0
49962 KFQVER=MOD(IMES,5)+1
49963 IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1
49964 IF(KFQVER.GT.3)THEN
49965 IDIAG=KFQVER-3
49966 KFQVER=KFQOLD
49967 ENDIF
49968 ELSE
49969 IF(MBARY.EQ.-1) IDW=170
49970 SQWT=PARF(IDW+2)
49971 IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3)
49972 IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0
49973 KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0)))
49974 IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN
49975 KFQVER=KFQPOP
49976 IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP
49977 ENDIF
49978 ENDIF
49979
49980C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
49981 KFLDS=3
49982 IF(KFQPOP.NE.KFQVER)THEN
49983 SWT=PARF(IDW+7)
49984 IF(KFQVER.EQ.3) SWT=PARF(IDW+6)
49985 IF(KFQPOP.GE.3) SWT=PARF(IDW+5)
49986 IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1
49987 ENDIF
49988 KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS
49989 & +10000*KFQPOP
49990 KFL3=ISIGN(KFDIQ,KFIN)
49991
49992C..x->M+y: flavour for meson.
49993 130 IF(MBARY.LE.0)THEN
49994 KFLA=MAX(KFQOLD,KFQVER)
49995 KFLB=MIN(KFQOLD,KFQVER)
49996 KFS=ISIGN(1,KFL1)
49997 IF(KFLA.NE.KFQOLD) KFS=-KFS
49998C... Form meson, with spin and flavour mixing for diagonal states.
49999 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
50000 IF(IDIAG.GT.0) KF=110*IDIAG+KFJ
50001 IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA
50002 RETURN
50003 ENDIF
50004 IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0))
50005 IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0))
50006 IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0))
50007 IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN
50008 IF(PYR(0).LT.PARJ(14)) KMUL=2
50009 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN
50010 RMUL=PYR(0)
50011 IF(RMUL.LT.PARJ(15)) KMUL=3
50012 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
50013 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
50014 ENDIF
50015 KFLS=3
50016 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
50017 IF(KMUL.EQ.5) KFLS=5
50018 IF(KFLA.NE.KFLB)THEN
50019 KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
50020 ELSE
50021 RMIX=PYR(0)
50022 IMIX=2*KFLA+10*KMUL
50023 IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
50024 & INT(RMIX+PARF(IMIX)))+KFLS
50025 IF(KFLA.GE.4) KF=110*KFLA+KFLS
50026 ENDIF
50027 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
50028 IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
50029
50030C..Optional extra suppression of eta and eta'.
50031C..Allow shift to qq->B+q in old version (set IRANK to 0)
50032 IF(KF.EQ.221.OR.KF.EQ.331)THEN
50033 IF(PYR(0).GT.PARJ(25+KF/300))THEN
50034 IF(KF2A.GT.0) GOTO 130
50035 IF(MSTJ(12).LT.4) IRANK=0
50036 GOTO 110
50037 ENDIF
50038 ENDIF
50039 MSTU(121)=0
50040
50041C.. x->B+y: Flavour for baryon
50042 ELSE
50043 KFLA=KFQVER
50044 IF(KF1A.LE.10) KFLA=KFQOLD
50045 KFLB=MOD(KFDIQ/1000,10)
50046 KFLC=MOD(KFDIQ/100,10)
50047 KFLDS=MOD(KFDIQ,10)
50048 KFLD=MAX(KFLA,KFLB,KFLC)
50049 KFLF=MIN(KFLA,KFLB,KFLC)
50050 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
50051
50052C... SU(6) factors for formation of baryon.
50053 KBARY=3
50054 KDMAX=5
50055 KFLG=KFLB
50056 IF(KFLB.NE.KFLC)THEN
50057 KBARY=2*KFLDS-1
50058 KDMAX=1+KFLDS/2
50059 IF(KFLB.GT.2) KDMAX=KDMAX+2
50060 ENDIF
50061 IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN
50062 KBARY=KBARY+1
50063 KFLG=KFLA
50064 ENDIF
50065
50066 SU6MAX=PARF(140+KDMAX)
50067 SU6DEC=PARJ(18)
50068 SU6S =PARF(146)
50069 IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN
50070 SU6MAX=1D0
50071 SU6DEC=1D0
50072 SU6S =1D0
50073 ENDIF
50074 SU6OCT=PARF(60+KBARY)
50075 IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN
50076 SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1)
50077 IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1)
50078 ELSE
50079 IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1)
50080 ENDIF
50081 SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY)
50082
50083C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
50084 IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN
50085 MSTU(121)=0
50086 IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1
50087 GOTO 110
50088 ENDIF
50089
50090C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
50091 KSIG=1
50092 KFLS=2
50093 IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4
50094 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN
50095 KSIG=KFLDS/3
50096 IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0))
50097 ENDIF
50098 KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
50099 IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
50100 ENDIF
aabcdb29 50101C -------------------------------------------------------------------------
50102C Extracted from a private e-mail exchange with Torbjorn Sjostrand
50103C
50104C No, Lambda(1520) is not included and not foreseen.
50105C So if you want it in Pythia, it would have to be a hack.
50106C What you could do is:
50107C 1) In PYKFDI, just before the RETURN above label 140, you could check if
50108C a Lambda, Sigma0 or Sigma*0 has been produced, and with some small
50109C probability switch such a particle to the Lambda(1520) code. That is,
50110C if KF = 3122, 3212, or 3214 and a random number below some number, switch
50111C to KF = 3124. (And correspondingly for anticparticles.)
50112C 2) Use the PYUPDA routine (see manual) to include particle and decay data
50113C for the Lambda(1520).
50114C -------------------------------------------------------------------------
50115
bf6cd108 50116 IF (IABS(KF).EQ.3122) THEN
aabcdb29 50117C Converting a fraction (0.20) of Lambda0 to Lambda(1520) + c.c.
50118C This fraction is based on the experimental measurement at ISR
50119C Bobbink 83, NP B217,11 (1983)
50120C The region 0.5 < XF < 1.0 has been extrapolated to XF=0
bf6cd108 50121 IF(PYR(0).LE.0.20) KF=ISIGN(3124,KF)
50122 ENDIF
aabcdb29 50123
bf6cd108 50124 IF(IABS(KF).EQ.3212) THEN
aabcdb29 50125C Converting a fraction (0.20) of Sigma0 to Lambda(1520) + c.c.
50126C We suppose the same fraction as for Lambda0
bf6cd108 50127 IF(PYR(0).LE.0.20) KF=ISIGN(3124,KF)
50128 ENDIF
aabcdb29 50129
bf6cd108 50130 IF (IABS(KF).EQ.3214) THEN
aabcdb29 50131C Converting a fraction (0.30) of Sigma0(1385) to Lambda(1520) + c.c.
50132C This is conservative extimate supposing that the ratio
50133C scales as (M_Sigma1385/M_Lambda0)^2 ~ 1.5
bf6cd108 50134 IF(PYR(0).LE.0.30) KF=ISIGN(3124,KF)
50135 ENDIF
2dfa57d1 50136 RETURN
50137
50138C...Use tabulated probabilities to select new flavour and hadron.
50139 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
50140 KT3L=1
50141 KT3U=6
50142 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
50143 KT3L=1
50144 KT3U=6
50145 ELSEIF(KTAB2.EQ.0) THEN
50146 KT3L=1
50147 KT3U=22
50148 ELSE
50149 KT3L=KTAB2
50150 KT3U=KTAB2
50151 ENDIF
50152 RFL=0D0
50153 DO 160 KTS=0,2
50154 DO 150 KT3=KT3L,KT3U
50155 RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
50156 150 CONTINUE
50157 160 CONTINUE
50158 RFL=PYR(0)*RFL
50159 DO 180 KTS=0,2
50160 KTABS=KTS
50161 DO 170 KT3=KT3L,KT3U
50162 KTAB3=KT3
50163 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
50164 IF(RFL.LE.0D0) GOTO 190
50165 170 CONTINUE
50166 180 CONTINUE
50167 190 CONTINUE
50168
50169C...Reconstruct flavour of produced quark/diquark.
50170 IF(KTAB3.LE.6) THEN
50171 KFL3A=KTAB3
50172 KFL3B=0
50173 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
50174 ELSE
50175 KFL3A=1
50176 IF(KTAB3.GE.8) KFL3A=2
50177 IF(KTAB3.GE.11) KFL3A=3
50178 IF(KTAB3.GE.16) KFL3A=4
50179 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
50180 KFL3=1000*KFL3A+100*KFL3B+1
50181 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
50182 & KFL3+2
50183 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
50184 ENDIF
50185
50186C...Reconstruct meson code.
50187 IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
50188 &KFL3B.NE.0)) THEN
50189 RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
50190 & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
50191 KF=110+2*KTABS+1
50192 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
50193 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
50194 & 25*KTABS)) KF=330+2*KTABS+1
50195 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
50196 KFLA=MAX(KTAB1,KTAB3)
50197 KFLB=MIN(KTAB1,KTAB3)
50198 KFS=ISIGN(1,KFL1)
50199 IF(KFLA.NE.KF1A) KFS=-KFS
50200 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
50201 ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
50202 KFS=ISIGN(1,KFL1)
50203 IF(KFL1A.EQ.KFL3A) THEN
50204 KFLA=MAX(KFL1B,KFL3B)
50205 KFLB=MIN(KFL1B,KFL3B)
50206 IF(KFLA.NE.KFL1B) KFS=-KFS
50207 ELSEIF(KFL1A.EQ.KFL3B) THEN
50208 KFLA=KFL3A
50209 KFLB=KFL1B
50210 KFS=-KFS
50211 ELSEIF(KFL1B.EQ.KFL3A) THEN
50212 KFLA=KFL1A
50213 KFLB=KFL3B
50214 ELSEIF(KFL1B.EQ.KFL3B) THEN
50215 KFLA=MAX(KFL1A,KFL3A)
50216 KFLB=MIN(KFL1A,KFL3A)
50217 IF(KFLA.NE.KFL1A) KFS=-KFS
50218 ELSE
50219 CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq')
50220 GOTO 100
50221 ENDIF
50222 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
50223
50224C...Reconstruct baryon code.
50225 ELSE
50226 IF(KTAB1.GE.7) THEN
50227 KFLA=KFL3A
50228 KFLB=KFL1A
50229 KFLC=KFL1B
50230 ELSE
50231 KFLA=KFL1A
50232 KFLB=KFL3A
50233 KFLC=KFL3B
50234 ENDIF
50235 KFLD=MAX(KFLA,KFLB,KFLC)
50236 KFLF=MIN(KFLA,KFLB,KFLC)
50237 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
50238 IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
50239 IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
50240 ENDIF
50241
50242C...Check that constructed flavour code is an allowed one.
50243 IF(KFL2.NE.0) KFL3=0
50244 KC=PYCOMP(KF)
50245 IF(KC.EQ.0) THEN
50246 CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '//
50247 & 'failed')
50248 GOTO 100
50249 ENDIF
50250
50251 RETURN
50252 END
50253
50254C*********************************************************************
50255
50256C...PYNMES
50257C...Generates number of popcorn mesons and stores some relevant
50258C...parameters.
50259
50260 SUBROUTINE PYNMES(KFDIQ)
50261
50262C...Double precision and integer declarations.
50263 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50264 IMPLICIT INTEGER(I-N)
50265 INTEGER PYK,PYCHGE,PYCOMP
50266C...Commonblocks.
50267 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50268 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50269 SAVE /PYDAT1/,/PYDAT2/
50270
50271 MSTU(121)=0
50272 IF(MSTJ(12).LT.2) RETURN
50273
50274C..Old version: Get 1 or 0 popcorn mesons
50275 IF(MSTJ(12).LT.5)THEN
50276 POPWT=PARF(131)
50277 IF(KFDIQ.NE.0) THEN
50278 KFDIQA=IABS(KFDIQ)
50279 KFA=MOD(KFDIQA/1000,10)
50280 KFB=MOD(KFDIQA/100,10)
50281 KFS=MOD(KFDIQA,10)
50282 POPWT=PARF(132)
50283 IF(KFA.EQ.3) POPWT=PARF(133)
50284 IF(KFB.EQ.3) POPWT=PARF(134)
50285 IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4))
50286 ENDIF
50287 MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0))
50288 RETURN
50289 ENDIF
50290
50291C..New version: Store popcorn- or rank 0 diquark parameters
50292 MSTU(122)=170
50293 PARF(193)=PARJ(8)
50294 PARF(194)=PARF(139)
50295 IF(KFDIQ.NE.0) THEN
50296 MSTU(122)=180
50297 PARF(193)=PARJ(10)
50298 PARF(194)=PARF(140)
50299 ENDIF
50300 IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN
50301 IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9,
50302 & '(PYNMES:) Neglecting too large popcorn possibility')
50303 RETURN
50304 ENDIF
50305
50306C..New version: Get number of popcorn mesons
50307 100 RTST=PYR(0)
50308 MSTU(121)=-1
50309 110 MSTU(121)=MSTU(121)+1
50310 RTST=RTST/PARF(194)
50311 IF(RTST.LT.1D0) GOTO 110
50312 IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)*PARF(161)).GT.
50313 & (2D0+PARF(135)*PARF(161)*PARF(138)**MSTU(121))) GOTO 100
50314 RETURN
50315 END
50316
50317C***************************************************************
50318
50319C...PYKFIN
50320C...Precalculates a set of diquark and popcorn weights.
50321
50322 SUBROUTINE PYKFIN
50323
50324C...Double precision and integer declarations.
50325 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50326 IMPLICIT INTEGER(I-N)
50327 INTEGER PYK,PYCHGE,PYCOMP
50328C...Commonblocks.
50329 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50330 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50331 SAVE /PYDAT1/,/PYDAT2/
50332
50333 DIMENSION SU6(12),SU6M(7),QBB(7),QBM(7),DMB(14)
50334
50335
50336 MSTU(123)=1
50337C..Diquark indices for dimensional variables
50338 IUD1=1
50339 IUU1=2
50340 IUS0=3
50341 ISU0=4
50342 IUS1=5
50343 ISU1=6
50344 ISS1=7
50345
50346C.. *** SU(6) factors **
50347C..Modify with decuplet- (and Sigma/Lambda-) suppression.
50348 PARF(146)=1D0
50349 IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0)
50350 IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9,
50351 & '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
50352 DO 100 I=1,6
50353 SU6(I)=PARF(60+I)
50354 SU6(6+I)=SU6(I)*4*PARF(146)/(3*PARF(146)+1)
50355 100 CONTINUE
50356 SU6(8)=SU6(2)*4/(3*PARF(146)+1)
50357 SU6(6)=SU6(6)*(3+PARF(146))/(3*PARF(146)+1)
50358 DO 110 I=1,6
50359 SU6(I)=SU6(I)+PARJ(18)*PARF(70+I)
50360 SU6(6+I)=SU6(6+I)+PARJ(18)*PARF(70+I)
50361 110 CONTINUE
50362
50363C..SU(6)max q q' s,c,b
50364 SU6MUD =MAX(SU6(1) , SU6(8) )
50365 SU6M(IUD1)=MAX(SU6(5) , SU6(12))
50366 SU6M(ISU0)=MAX(SU6(7) ,SU6(2),SU6MUD )
50367 SU6M(IUU1)=MAX(SU6(3) ,SU6(4),SU6(10))
50368 SU6M(ISU1)=MAX(SU6(11),SU6(6),SU6M(IUD1))
50369 SU6M(IUS0)=SU6M(ISU0)
50370 SU6M(ISS1)=SU6M(IUU1)
50371 SU6M(IUS1)=SU6M(ISU1)
50372
50373C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
50374 PARF(141)=SU6MUD
50375 PARF(142)=SU6M(IUD1)
50376 PARF(143)=SU6M(ISU0)
50377 PARF(144)=SU6M(ISU1)
50378 PARF(145)=SU6M(ISS1)
50379
50380C..diquark SU(6) survival =
50381C..sum over quark (quark tunnel weight)*(SU(6)).
50382 PUD0=(2D0*SU6(1)+PARJ(2)*SU6(8))
50383 DMB(ISU0)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
50384 DMB(IUS0)=DMB(ISU0)
50385 DMB(ISS1)=(2D0*SU6(4)+PARJ(2)*SU6(3))/PUD0
50386 DMB(IUU1)=(SU6(3)+SU6(4)+PARJ(2)*SU6(10))/PUD0
50387 DMB(ISU1)=(SU6(11)+SU6(6)+PARJ(2)*SU6(5))/PUD0
50388 DMB(IUS1)=DMB(ISU1)
50389 DMB(IUD1)=(2D0*SU6(5)+PARJ(2)*SU6(12))/PUD0
50390
50391C.. *** Tunneling factors for Diquark production***
50392C.. T: half a curtain pair = sqrt(curtain pair factor)
50393 IF(MSTJ(12).GE.5) THEN
50394 PMUD0=PYMASS(2101)
50395 PMUD1=PYMASS(2103)-PMUD0
50396 PMUS0=PYMASS(3201)-PMUD0
50397 PMUS1=PYMASS(3203)-PMUS0-PMUD0
50398 PMSS1=PYMASS(3303)-PMUS0-PMUD0
50399 QBB(ISU0)=EXP(-(PARJ(9)+PARJ(8))*PMUS0-PARJ(9)*PARF(191))
50400 QBB(IUS0)=EXP(-PARJ(8)*PMUS0)
50401 QBB(ISS1)=EXP(-(PARJ(9)+PARJ(8))*PMSS1)*QBB(ISU0)
50402 QBB(IUU1)=EXP(-PARJ(8)*PMUD1)
50403 QBB(ISU1)=EXP(-(PARJ(9)+PARJ(8))*PMUS1)*QBB(ISU0)
50404 QBB(IUS1)=EXP(-PARJ(8)*PMUS1)*QBB(IUS0)
50405 QBB(IUD1)=QBB(IUU1)
50406 ELSE
50407 PAR2M=SQRT(PARJ(2))
50408 PAR3M=SQRT(PARJ(3))
50409 PAR4M=SQRT(PARJ(4))
50410 QBB(ISU0)=PAR2M*PAR3M
50411 QBB(IUS0)=PAR3M
50412 QBB(ISS1)=PAR2M*PARJ(3)*PAR4M
50413 QBB(IUU1)=PAR4M
50414 QBB(ISU1)=PAR4M*QBB(ISU0)
50415 QBB(IUS1)=PAR4M*QBB(IUS0)
50416 QBB(IUD1)=PAR4M
50417 ENDIF
50418
50419C.. tau: spin*(vertex factor)*(T = half-curtain factor)
50420 QBM(ISU0)=QBB(ISU0)
50421 QBM(IUS0)=PARJ(2)*QBB(IUS0)
50422 QBM(ISS1)=PARJ(2)*6D0*QBB(ISS1)
50423 QBM(IUU1)=6D0*QBB(IUU1)
50424 QBM(ISU1)=3D0*QBB(ISU1)
50425 QBM(IUS1)=PARJ(2)*3D0*QBB(IUS1)
50426 QBM(IUD1)=3D0*QBB(IUD1)
50427
50428C.. Combine T and tau to diquark weight for q-> B+B+..
50429 DO 120 I=1,7
50430 QBB(I)=QBB(I)*QBM(I)
50431 120 CONTINUE
50432
50433 IF(MSTJ(12).GE.5)THEN
50434C..New version: tau for rank 0 diquark.
50435 DMB(7+ISU0)=EXP(-PARJ(10)*PMUS0)
50436 DMB(7+IUS0)=PARJ(2)*DMB(7+ISU0)
50437 DMB(7+ISS1)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*DMB(7+ISU0)
50438 DMB(7+IUU1)=6D0*EXP(-PARJ(10)*PMUD1)
50439 DMB(7+ISU1)=3D0*EXP(-PARJ(10)*PMUS1)*DMB(7+ISU0)
50440 DMB(7+IUS1)=PARJ(2)*DMB(7+ISU1)
50441 DMB(7+IUD1)=DMB(7+IUU1)/2D0
50442
50443C..New version: curtain flavour ratios.
50444C.. s/u for q->B+M+...
50445C.. s/u for rank 0 diquark: su -> ...M+B+...
50446C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
50447 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
50448 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
50449 WU=1D0+DMB(7+IUD1)+DMB(7+IUS0)+DMB(7+IUS1)+DMB(7+IUU1)
50450 PARF(136)=(2D0*(DMB(7+ISU0)+DMB(7+ISU1))+DMB(7+ISS1))/WU
50451 PARF(137)=(DMB(7+ISU0)+DMB(7+ISU1))*
50452 & (2D0+DMB(7+ISS1)/(2D0*DMB(7+ISU1)))/WU
50453 ELSE
50454C..Old version: reset unused rank 0 diquark weights and
50455C.. unused diquark SU(6) survival weights
50456 DO 130 I=1,7
50457 IF(MSTJ(12).LT.3) DMB(I)=1D0
50458 DMB(7+I)=1D0
50459 130 CONTINUE
50460
50461C..Old version: Shuffle PARJ(7) into tau
50462 QBM(IUS0)=QBM(IUS0)*PARJ(7)
50463 QBM(ISS1)=QBM(ISS1)*PARJ(7)
50464 QBM(IUS1)=QBM(IUS1)*PARJ(7)
50465
50466C..Old version: curtain flavour ratios.
50467C.. s/u for q->B+M+...
50468C.. s/u for rank 0 diquark: su -> ...M+B+...
50469C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
50470 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
50471 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
50472 PARF(136)=PARF(135)*PARJ(6)*QBM(ISU0)/QBM(IUS0)
50473 PARF(137)=(1D0+QBM(IUD1))*(2D0+QBM(IUS0))/WU
50474 ENDIF
50475
50476C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for:
50477C.. rank0 D->M+B+..; D->M+B+..; q->B+M+..; q->B+B..
50478 DO 140 I=1,7
50479 DMB(7+I)=DMB(7+I)*DMB(I)
50480 DMB(I)=DMB(I)*QBM(I)
50481 QBM(I)=QBM(I)*SU6M(I)/SU6MUD
50482 QBB(I)=QBB(I)*SU6M(I)/SU6MUD
50483 140 CONTINUE
50484
50485C.. *** Popcorn factors ***
50486
50487 IF(MSTJ(12).LT.5)THEN
50488C.. Old version: Resulting popcorn weights.
50489 PARF(138)=PARJ(6)
50490 WS=PARF(135)*PARF(138)
50491 WQ=WU*PARJ(5)/3D0
50492 PARF(132)=WQ*QBM(IUD1)/QBB(IUD1)
50493 PARF(133)=WQ*
50494 & (QBM(IUS1)/QBB(IUS1)+WS*QBM(ISU1)/QBB(ISU1))/2D0
50495 PARF(134)=WQ*WS*QBM(ISS1)/QBB(ISS1)
50496 PARF(131)=WQ*(1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1)+
50497 & WS*(QBM(ISU0)+QBM(ISU1)+QBM(ISS1)/2D0))/
50498 & (1D0+QBB(IUD1)+QBB(IUU1)+
50499 & 2D0*(QBB(IUS0)+QBB(IUS1))+QBB(ISS1)/2D0)
50500 ELSE
50501C..New version: Store weights for popcorn mesons,
50502C..get prel. popcorn weights.
50503 DO 150 IPOS=201,1400
50504 PARF(IPOS)=0D0
50505 150 CONTINUE
50506 DO 160 I=138,140
50507 PARF(I)=0D0
50508 160 CONTINUE
50509 IPOS=200
50510 PARF(193)=PARJ(8)
50511 DO 240 MR=0,7,7
50512 IF(MR.EQ.7) PARF(193)=PARJ(10)
50513 SQWT=2D0*(DMB(MR+IUS0)+DMB(MR+IUS1))/
50514 & (1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
50515 QQWT=DMB(MR+IUU1)/(1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
50516 DO 230 NMES=0,1
50517 IF(NMES.EQ.1) SQWT=PARJ(2)
50518 DO 220 KFQPOP=1,4
50519 IF(MR.EQ.0.AND.KFQPOP.GT.3) GOTO 220
50520 IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN
50521 SQWT=DMB(MR+ISS1)/(DMB(MR+ISU0)+DMB(MR+ISU1))
50522 QQWT=0.5D0
50523 IF(MR.EQ.0) PARF(193)=PARJ(8)+PARJ(9)
50524 IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/DMB(7+ISU1)+1D0)/2D0
50525 ENDIF
50526 DO 210 KFQOLD =1,5
50527 IF(MR.EQ.0.AND.KFQOLD.GT.3) GOTO 210
50528 IF(NMES.EQ.1) THEN
50529 IF(MR.EQ.0.AND.KFQPOP.EQ.1) GOTO 210
50530 IF(MR.EQ.7.AND.KFQPOP.NE.1) GOTO 210
50531 ENDIF
50532 WTTOT=0D0
50533 WTFAIL=0D0
50534 DO 190 KMUL=0,5
50535 PJWT=PARJ(12+KMUL)
50536 IF(KMUL.EQ.0) PJWT=1D0-PARJ(14)
50537 IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17)
50538 IF(PJWT.LE.0D0) GOTO 190
50539 IF(PJWT.GT.1D0) PJWT=1D0
50540 IMES=5*KMUL
50541 IMIX=2*KFQOLD+10*KMUL
50542 KFJ=2*KMUL+1
50543 IF(KMUL.EQ.2) KFJ=10003
50544 IF(KMUL.EQ.3) KFJ=10001
50545 IF(KMUL.EQ.4) KFJ=20003
50546 IF(KMUL.EQ.5) KFJ=5
50547 DO 180 KFQVER =1,3
50548 KFLA=MAX(KFQOLD,KFQVER)
50549 KFLB=MIN(KFQOLD,KFQVER)
50550 SWT=PARJ(11+KFLA/3+KFLA/4)
50551 IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT
50552 SWT=SWT*PJWT
50553 QWT=SQWT/(2D0+SQWT)
50554 IF(KFQVER.LT.3)THEN
50555 IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT
50556 IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT)
50557 ENDIF
50558 IF(KFQVER.NE.KFQOLD)THEN
50559 IMES=IMES+1
50560 KFM=100*KFLA+10*KFLB+KFJ
50561 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
50562 PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM)
50563 WTTOT=WTTOT+PARF(IPOS+IMES)
50564 ELSE
50565 DO 170 ID=3,5
50566 IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1)
50567 IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX)
50568 IF(ID.EQ.5) DWT=PARF(IMIX)
50569 KFM=110*(ID-2)+KFJ
50570 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
50571 PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM)
50572 IF(KMUL.EQ.0.AND.ID.GT.3) THEN
50573 WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID))
50574 PARF(IPOS+5*KMUL+ID)=
50575 & PARF(IPOS+5*KMUL+ID)*PARJ(21+ID)
50576 ENDIF
50577 WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID)
50578 170 CONTINUE
50579 ENDIF
50580 180 CONTINUE
50581 190 CONTINUE
50582 DO 200 IMES=1,30
50583 PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL)
50584 200 CONTINUE
50585 IF(MR.EQ.7) PARF(140)=
50586 & MAX(PARF(140),WTTOT/(1D0-WTFAIL))
50587 IF(MR.EQ.0) PARF(139-KFQPOP/3)=
50588 & MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL))
50589 IPOS=IPOS+30
50590 210 CONTINUE
50591 220 CONTINUE
50592 230 CONTINUE
50593 240 CONTINUE
50594 IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139)
50595 MSTU(121)=0
50596
50597 ENDIF
50598
50599C..Recombine diquark weights to flavour and spin ratios
50600 PARF(151)=(2D0*(QBB(ISU0)+QBB(ISU1))+QBB(ISS1))/
50601 & (1D0+QBB(IUD1)+QBB(IUU1)+QBB(IUS0)+QBB(IUS1))
50602 PARF(152)=2D0*(QBB(IUS0)+QBB(IUS1))/(1D0+QBB(IUD1)+QBB(IUU1))
50603 PARF(153)=QBB(ISS1)/(QBB(ISU0)+QBB(ISU1))
50604 PARF(154)=QBB(IUU1)/(1D0+QBB(IUD1)+QBB(IUU1))
50605 PARF(155)=QBB(ISU1)/QBB(ISU0)
50606 PARF(156)=QBB(IUS1)/QBB(IUS0)
50607 PARF(157)=QBB(IUD1)
50608
50609 PARF(161)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/
50610 & (1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1))
50611 PARF(162)=2D0*(QBM(IUS0)+QBM(IUS1))/(1D0+QBM(IUD1)+QBM(IUU1))
50612 PARF(163)=QBM(ISS1)/(QBM(ISU0)+QBM(ISU1))
50613 PARF(164)=QBM(IUU1)/(1D0+QBM(IUD1)+QBM(IUU1))
50614 PARF(165)=QBM(ISU1)/QBM(ISU0)
50615 PARF(166)=QBM(IUS1)/QBM(IUS0)
50616 PARF(167)=QBM(IUD1)
50617
50618 PARF(171)=(2D0*(DMB(ISU0)+DMB(ISU1))+DMB(ISS1))/
50619 & (1D0+DMB(IUD1)+DMB(IUU1)+DMB(IUS0)+DMB(IUS1))
50620 PARF(172)=2D0*(DMB(IUS0)+DMB(IUS1))/(1D0+DMB(IUD1)+DMB(IUU1))
50621 PARF(173)=DMB(ISS1)/(DMB(ISU0)+DMB(ISU1))
50622 PARF(174)=DMB(IUU1)/(1D0+DMB(IUD1)+DMB(IUU1))
50623 PARF(175)=DMB(ISU1)/DMB(ISU0)
50624 PARF(176)=DMB(IUS1)/DMB(IUS0)
50625 PARF(177)=DMB(IUD1)
50626
50627 PARF(185)=DMB(7+ISU1)/DMB(7+ISU0)
50628 PARF(186)=DMB(7+IUS1)/DMB(7+IUS0)
50629 PARF(187)=DMB(7+IUD1)
50630
50631 RETURN
50632 END
50633
50634
50635C*********************************************************************
50636
50637C...PYPTDI
50638C...Generates transverse momentum according to a Gaussian.
50639
50640 SUBROUTINE PYPTDI(KFL,PX,PY)
50641
50642C...Double precision and integer declarations.
50643 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50644 IMPLICIT INTEGER(I-N)
50645 INTEGER PYK,PYCHGE,PYCOMP
50646C...Commonblocks.
50647 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50648 SAVE /PYDAT1/
50649
50650C...Generate p_T and azimuthal angle, gives p_x and p_y.
50651 KFLA=IABS(KFL)
50652 PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0))))
50653 IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT
50654 IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
50655 IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0
50656 PHI=PARU(2)*PYR(0)
50657 PX=PT*COS(PHI)
50658 PY=PT*SIN(PHI)
50659
50660 RETURN
50661 END
50662
50663C*********************************************************************
50664
50665C...PYZDIS
50666C...Generates the longitudinal splitting variable z.
50667
50668 SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z)
50669
50670C...Double precision and integer declarations.
50671 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50672 IMPLICIT INTEGER(I-N)
50673 INTEGER PYK,PYCHGE,PYCOMP
50674C...Commonblocks.
50675 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50676 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50677 SAVE /PYDAT1/,/PYDAT2/
50678
50679C...Check if heavy flavour fragmentation.
50680 KFLA=IABS(KFL1)
50681 KFLB=IABS(KFL2)
50682 KFLH=KFLA
50683 IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
50684
50685C...Lund symmetric scaling function: determine parameters of shape.
50686 IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
50687 &MSTJ(11).GE.4) THEN
50688 FA=PARJ(41)
50689 IF(MSTJ(91).EQ.1) FA=PARJ(43)
50690 IF(KFLB.GE.10) FA=FA+PARJ(45)
50691 FBB=PARJ(42)
50692 IF(MSTJ(91).EQ.1) FBB=PARJ(44)
50693 FB=FBB*PR
50694 FC=1D0
50695 IF(KFLA.GE.10) FC=FC-PARJ(45)
50696 IF(KFLB.GE.10) FC=FC+PARJ(45)
50697 IF(MSTJ(11).GE.4.AND.(KFLH.EQ.4.OR.KFLH.EQ.5)) THEN
50698 FRED=PARJ(46)
50699 IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
50700 FC=FC+FRED*FBB*PARF(100+KFLH)**2
50701 ENDIF
50702 MC=1
50703 IF(ABS(FC-1D0).GT.0.01D0) MC=2
50704
50705C...Determine position of maximum. Special cases for a = 0 or a = c.
50706 IF(FA.LT.0.02D0) THEN
50707 MA=1
50708 ZMAX=1D0
50709 IF(FC.GT.FB) ZMAX=FB/FC
50710 ELSEIF(ABS(FC-FA).LT.0.01D0) THEN
50711 MA=2
50712 ZMAX=FB/(FB+FC)
50713 ELSE
50714 MA=3
50715 ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA)
50716 IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB)
50717 ENDIF
50718
50719C...Subdivide z range if distribution very peaked near endpoint.
50720 MMAX=2
50721 IF(ZMAX.LT.0.1D0) THEN
50722 MMAX=1
50723 ZDIV=2.75D0*ZMAX
50724 IF(MC.EQ.1) THEN
50725 FINT=1D0-LOG(ZDIV)
50726 ELSE
50727 ZDIVC=ZDIV**(1D0-FC)
50728 FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0)
50729 ENDIF
50730 ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN
50731 MMAX=3
50732 FSCB=SQRT(4D0+(FC/FB)**2)
50733 ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB))
50734 IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX)
50735 ZDIV=MIN(ZMAX,MAX(0D0,ZDIV))
50736 FINT=1D0+FB*(1D0-ZDIV)
50737 ENDIF
50738
50739C...Choice of z, preweighted for peaks at low or high z.
50740 100 Z=PYR(0)
50741 FPRE=1D0
50742 IF(MMAX.EQ.1) THEN
50743 IF(FINT*PYR(0).LE.1D0) THEN
50744 Z=ZDIV*Z
50745 ELSEIF(MC.EQ.1) THEN
50746 Z=ZDIV**Z
50747 FPRE=ZDIV/Z
50748 ELSE
50749 Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC))
50750 FPRE=(ZDIV/Z)**FC
50751 ENDIF
50752 ELSEIF(MMAX.EQ.3) THEN
50753 IF(FINT*PYR(0).LE.1D0) THEN
50754 Z=ZDIV+LOG(Z)/FB
50755 FPRE=EXP(FB*(Z-ZDIV))
50756 ELSE
50757 Z=ZDIV+Z*(1D0-ZDIV)
50758 ENDIF
50759 ENDIF
50760
50761C...Weighting according to correct formula.
50762 IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100
50763 FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z)
50764 IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX))
50765 FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP)))
50766 IF(FVAL.LT.PYR(0)*FPRE) GOTO 100
50767
50768C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
50769 ELSE
50770 FC=PARJ(50+MAX(1,KFLH))
50771 IF(MSTJ(91).EQ.1) FC=PARJ(59)
50772 110 Z=PYR(0)
50773 IF(FC.GE.0D0.AND.FC.LE.1D0) THEN
50774 IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0)
50775 ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN
50776 IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2)
50777 & GOTO 110
50778 ELSE
50779 IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
50780 IF(FC.LT.0D0) Z=Z**(-1D0/FC)
50781 ENDIF
50782 ENDIF
50783
50784 RETURN
50785 END
50786
50787C*********************************************************************
50788
50789C...PYSHOW
50790C...Generates timelike parton showers from given partons.
50791
50792 SUBROUTINE PYSHOW(IP1,IP2,QMAX)
50793
50794C...Double precision and integer declarations.
50795 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50796 IMPLICIT INTEGER(I-N)
50797 INTEGER PYK,PYCHGE,PYCOMP
50798C...Parameter statement to help give large particle numbers.
50799 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50800 &KEXCIT=4000000,KDIMEN=5000000)
50801C...Commonblocks.
50802 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
50803 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50804 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50805 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
50806C...Local arrays.
50807 DIMENSION PMTH(5,50),PS(5),PMA(19),PMSD(10),IEP(10),IPA(10),
50808 &KFLA(10),KFLD(10),KFL(10),ITRY(10),ISI(10),ISL(10),DP(10),
50809 &DPT(5,4),KSH(0:40),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),
50810 &PHIIIS(2,2),ISII(2),ISSET(3),ISCOL(0:40),ISCHG(0:40),
50811 &IREF(1000)
50812
50813C...Check that QMAX not too low.
50814 IF(MSTJ(41).LE.0) THEN
50815 RETURN
50816 ELSEIF(MSTJ(41).EQ.1) THEN
50817 IF(QMAX.LE.PARJ(82).AND.IP2.GT.-8) RETURN
50818 ELSE
50819 IF(QMAX.LE.MIN(PARJ(82),PARJ(83),PARJ(90)).AND.IP2.GT.-8)
50820 & RETURN
50821 ENDIF
50822
50823C...Initialization of cutoff masses etc.
50824 DO 100 IFL=0,40
50825 ISCOL(IFL)=0
50826 ISCHG(IFL)=0
50827 KSH(IFL)=0
50828 100 CONTINUE
50829 ISCOL(21)=1
50830 KSH(21)=1
50831 PMTH(1,21)=PYMASS(21)
50832 PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2)
50833 PMTH(3,21)=2D0*PMTH(2,21)
50834 PMTH(4,21)=PMTH(3,21)
50835 PMTH(5,21)=PMTH(3,21)
50836 PMTH(1,22)=PYMASS(22)
50837 PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2)
50838 PMTH(3,22)=2D0*PMTH(2,22)
50839 PMTH(4,22)=PMTH(3,22)
50840 PMTH(5,22)=PMTH(3,22)
50841 PMQTH1=PARJ(82)
50842 IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
50843 PMQT1E=MIN(PMQTH1,PARJ(90))
50844 PMQTH2=PMTH(2,21)
50845 IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
50846 PMQT2E=MIN(PMQTH2,0.5D0*PARJ(90))
50847 DO 110 IFL=1,5
50848 ISCOL(IFL)=1
50849 IF(MSTJ(41).GE.2) ISCHG(IFL)=1
50850 KSH(IFL)=1
50851 PMTH(1,IFL)=PYMASS(IFL)
50852 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2)
50853 PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
50854 PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
50855 PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
50856 110 CONTINUE
50857 DO 120 IFL=11,15,2
50858 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IFL)=1
50859 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) KSH(IFL)=1
50860 PMTH(1,IFL)=PYMASS(IFL)
50861 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(90)**2)
50862 PMTH(3,IFL)=PMTH(2,IFL)+0.5D0*PARJ(90)
50863 PMTH(4,IFL)=PMTH(3,IFL)
50864 PMTH(5,IFL)=PMTH(3,IFL)
50865 120 CONTINUE
50866 PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2
50867 ALAMS=PARJ(81)**2
50868 ALFM=LOG(PT2MIN/ALAMS)
50869
50870C...Store positions of shower initiating partons.
50871 MPSPD=0
50872 IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
50873 NPA=1
50874 IPA(1)=IP1
50875 ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
50876 & MSTU(32))) THEN
50877 NPA=2
50878 IPA(1)=IP1
50879 IPA(2)=IP2
50880 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
50881 & .AND.IP2.GE.-7) THEN
50882 NPA=IABS(IP2)
50883 DO 130 I=1,NPA
50884 IPA(I)=IP1+I-1
50885 130 CONTINUE
50886 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.
50887 &IP2.EQ.-8) THEN
50888 MPSPD=1
50889 NPA=2
50890 IPA(1)=IP1+6
50891 IPA(2)=IP1+7
50892 ELSE
50893 CALL PYERRM(12,
50894 & '(PYSHOW:) failed to reconstruct showering system')
50895 IF(MSTU(21).GE.1) RETURN
50896 ENDIF
50897
50898C...Check on phase space available for emission.
50899 IREJ=0
50900 DO 140 J=1,5
50901 PS(J)=0D0
50902 140 CONTINUE
50903 PM=0D0
50904 KFLA(2)=0
50905 DO 160 I=1,NPA
50906 KFLA(I)=IABS(K(IPA(I),2))
50907 PMA(I)=P(IPA(I),5)
50908C...Special cutoff masses for initial partons (may be a heavy quark,
50909C...squark, ..., and need not be on the mass shell).
50910 IR=30+I
50911 IF(NPA.LE.1) IREF(I)=IR
50912 IF(NPA.GE.2) IREF(I+1)=IR
50913 IF(KFLA(I).LE.8) THEN
50914 ISCOL(IR)=1
50915 IF(MSTJ(41).GE.2) ISCHG(IR)=1
50916 ELSEIF(KFLA(I).EQ.11.OR.KFLA(I).EQ.13.OR.KFLA(I).EQ.15.OR.
50917 & KFLA(I).EQ.17) THEN
50918 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IR)=1
50919 ELSEIF(KFLA(I).EQ.21) THEN
50920 ISCOL(IR)=1
50921 ELSEIF((KFLA(I).GE.KSUSY1+1.AND.KFLA(I).LE.KSUSY1+8).OR.
50922 & (KFLA(I).GE.KSUSY2+1.AND.KFLA(I).LE.KSUSY2+8)) THEN
50923 ISCOL(IR)=1
50924 ELSEIF(KFLA(I).EQ.KSUSY1+21) THEN
50925 ISCOL(IR)=1
50926 ENDIF
50927 IF(ISCOL(IR).EQ.1.OR.ISCHG(IR).EQ.1) KSH(IR)=1
50928 PMTH(1,IR)=PMA(I)
50929 IF(ISCOL(IR).EQ.1.AND.ISCHG(IR).EQ.1) THEN
50930 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PMQTH1**2)
50931 PMTH(3,IR)=PMTH(2,IR)+PMQTH2
50932 PMTH(4,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
50933 PMTH(5,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
50934 ELSEIF(ISCOL(IR).EQ.1) THEN
50935 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)
50936 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(82)
50937 PMTH(4,IR)=PMTH(3,IR)
50938 PMTH(5,IR)=PMTH(3,IR)
50939 ELSEIF(ISCHG(IR).EQ.1) THEN
50940 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(90)**2)
50941 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(90)
50942 PMTH(4,IR)=PMTH(3,IR)
50943 PMTH(5,IR)=PMTH(3,IR)
50944 ENDIF
50945 IF(KSH(IR).EQ.1) PMA(I)=PMTH(3,IR)
50946 PM=PM+PMA(I)
50947 IF(KSH(IR).EQ.0.OR.PMA(I).GT.10D0*QMAX) IREJ=IREJ+1
50948 DO 150 J=1,4
50949 PS(J)=PS(J)+P(IPA(I),J)
50950 150 CONTINUE
50951 160 CONTINUE
50952 IF(IREJ.EQ.NPA.AND.IP2.GE.-7) RETURN
50953 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
50954 IF(NPA.EQ.1) PS(5)=PS(4)
50955 IF(PS(5).LE.PM+PMQT1E) RETURN
50956
50957C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
50958 KFSRCE=0
50959 IF(IP2.LE.0) THEN
50960 ELSEIF(K(IP1,3).EQ.K(IP2,3).AND.K(IP1,3).GT.0) THEN
50961 KFSRCE=IABS(K(K(IP1,3),2))
50962 ELSE
50963 IPAR1=MAX(1,K(IP1,3))
50964 IPAR2=MAX(1,K(IP2,3))
50965 IF(K(IPAR1,3).EQ.K(IPAR2,3).AND.K(IPAR1,3).GT.0)
50966 & KFSRCE=IABS(K(K(IPAR1,3),2))
50967 ENDIF
50968 ITYPES=0
50969 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
50970 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
50971 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
50972 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
50973 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
50974 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
50975 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
50976 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
50977
50978C...Identify two primary showerers.
50979 ITYPE1=0
50980 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8) ITYPE1=1
50981 IF(KFLA(1).GE.KSUSY1+1.AND.KFLA(1).LE.KSUSY1+8) ITYPE1=2
50982 IF(KFLA(1).GE.KSUSY2+1.AND.KFLA(1).LE.KSUSY2+8) ITYPE1=2
50983 IF(KFLA(1).GE.21.AND.KFLA(1).LE.24) ITYPE1=3
50984 IF(KFLA(1).GE.32.AND.KFLA(1).LE.34) ITYPE1=3
50985 IF(KFLA(1).EQ.25.OR.(KFLA(1).GE.35.AND.KFLA(1).LE.37)) ITYPE1=4
50986 IF(KFLA(1).GE.KSUSY1+22.AND.KFLA(1).LE.KSUSY1+37) ITYPE1=5
50987 IF(KFLA(1).EQ.KSUSY1+21) ITYPE1=6
50988 ITYPE2=0
50989 IF(KFLA(2).GE.1.AND.KFLA(2).LE.8) ITYPE2=1
50990 IF(KFLA(2).GE.KSUSY1+1.AND.KFLA(2).LE.KSUSY1+8) ITYPE2=2
50991 IF(KFLA(2).GE.KSUSY2+1.AND.KFLA(2).LE.KSUSY2+8) ITYPE2=2
50992 IF(KFLA(2).GE.21.AND.KFLA(2).LE.24) ITYPE2=3
50993 IF(KFLA(2).GE.32.AND.KFLA(2).LE.34) ITYPE2=3
50994 IF(KFLA(2).EQ.25.OR.(KFLA(2).GE.35.AND.KFLA(2).LE.37)) ITYPE2=4
50995 IF(KFLA(2).GE.KSUSY1+22.AND.KFLA(2).LE.KSUSY1+37) ITYPE2=5
50996 IF(KFLA(2).EQ.KSUSY1+21) ITYPE2=6
50997
50998C...Order of showerers. Presence of gluino.
50999 ITYPMN=MIN(ITYPE1,ITYPE2)
51000 ITYPMX=MAX(ITYPE1,ITYPE2)
51001 IORD=1
51002 IF(ITYPE1.GT.ITYPE2) IORD=2
51003 IGLUI=0
51004 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
51005
51006C...Check if 3-jet matrix elements to be used.
51007 M3JC=0
51008 ALPHA=0.5D0
51009 IF(NPA.EQ.2.AND.MSTJ(47).GE.1.AND.MPSPD.EQ.0) THEN
51010 IF(MSTJ(38).NE.0) THEN
51011 M3JC=MSTJ(38)
51012 ALPHA=PARJ(80)
51013 MSTJ(38)=0
51014 ELSEIF(MSTJ(47).GE.6) THEN
51015 M3JC=MSTJ(47)
51016 ELSE
51017 ICLASS=1
51018 ICOMBI=4
51019
51020C...Vector/axial vector -> q + qbar; q -> q + V.
51021 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
51022 & ITYPES.EQ.3)) THEN
51023 ICLASS=2
51024 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
51025 ICOMBI=1
51026 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
51027 & K(IP1,2)+K(IP2,2).EQ.0)) THEN
51028C...gamma*/Z0: assume e+e- initial state if unknown.
51029 EI=-1D0
51030 IF(KFSRCE.EQ.23) THEN
51031 IANNFL=K(K(IP1,3),3)
51032 IF(IANNFL.NE.0) THEN
51033 KANNFL=IABS(K(IANNFL,2))
51034 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
51035 ENDIF
51036 ENDIF
51037 AI=SIGN(1D0,EI+0.1D0)
51038 VI=AI-4D0*EI*PARU(102)
51039 EF=KCHG(KFLA(1),1)/3D0
51040 AF=SIGN(1D0,EF+0.1D0)
51041 VF=AF-4D0*EF*PARU(102)
51042 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
51043 SH=PS(5)**2
51044 SQMZ=PMAS(23,1)**2
51045 SQWZ=PS(5)*PMAS(23,2)
51046 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
51047 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
51048 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
51049 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
51050 ICOMBI=3
51051 ALPHA=VECT/(VECT+AXIV)
51052 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
51053 ICOMBI=4
51054 ENDIF
51055C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
51056 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
51057 ICLASS=2
51058 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
51059 & ITYPES.EQ.1)) THEN
51060 ICLASS=3
51061
51062C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
51063 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
51064 ICLASS=4
51065 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
51066 ICOMBI=1
51067 ELSEIF(KFSRCE.EQ.36) THEN
51068 ICOMBI=2
51069 ENDIF
51070 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
51071 & ITYPES.EQ.1)) THEN
51072 ICLASS=5
51073
51074C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
51075 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
51076 & ITYPES.EQ.3)) THEN
51077 ICLASS=6
51078 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
51079 & ITYPES.EQ.2)) THEN
51080 ICLASS=7
51081 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
51082 ICLASS=8
51083 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
51084 & ITYPES.EQ.2)) THEN
51085 ICLASS=9
51086
51087C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
51088 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
51089 & ITYPES.EQ.5)) THEN
51090 ICLASS=10
51091 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
51092 & ITYPES.EQ.2)) THEN
51093 ICLASS=11
51094 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
51095 & ITYPES.EQ.1)) THEN
51096 ICLASS=12
51097
51098C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
51099 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
51100 ICLASS=13
51101 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
51102 & ITYPES.EQ.2)) THEN
51103 ICLASS=14
51104 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
51105 & ITYPES.EQ.1)) THEN
51106 ICLASS=15
51107
51108C...g -> ~g + ~g (eikonal approximation).
51109 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
51110 ICLASS=16
51111 ENDIF
51112 M3JC=5*ICLASS+ICOMBI
51113 ENDIF
51114 ENDIF
51115
51116C...Find if interference with initial state partons.
51117 MIIS=0
51118 IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2.AND.KFSRCE.EQ.0
51119 &.AND.MPSPD.EQ.0) MIIS=MSTJ(50)
51120 IF(MSTJ(50).GE.4.AND.MSTJ(50).LE.6.AND.NPA.EQ.2.AND.MPSPD.EQ.0)
51121 &MIIS=MSTJ(50)-3
51122 IF(MIIS.NE.0) THEN
51123 DO 180 I=1,2
51124 KCII(I)=0
51125 KCA=PYCOMP(KFLA(I))
51126 IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
51127 NIIS(I)=0
51128 IF(KCII(I).NE.0) THEN
51129 DO 170 J=1,2
51130 ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5))
51131 IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND.
51132 & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN
51133 NIIS(I)=NIIS(I)+1
51134 IIIS(I,NIIS(I))=ICSI
51135 ENDIF
51136 170 CONTINUE
51137 ENDIF
51138 180 CONTINUE
51139 IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
51140 ENDIF
51141
51142C...Boost interfering initial partons to rest frame
51143C...and reconstruct their polar and azimuthal angles.
51144 IF(MIIS.NE.0) THEN
51145 DO 200 I=1,2
51146 DO 190 J=1,5
51147 K(N+I,J)=K(IPA(I),J)
51148 P(N+I,J)=P(IPA(I),J)
51149 V(N+I,J)=0D0
51150 190 CONTINUE
51151 200 CONTINUE
51152 DO 220 I=3,2+NIIS(1)
51153 DO 210 J=1,5
51154 K(N+I,J)=K(IIIS(1,I-2),J)
51155 P(N+I,J)=P(IIIS(1,I-2),J)
51156 V(N+I,J)=0D0
51157 210 CONTINUE
51158 220 CONTINUE
51159 DO 240 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
51160 DO 230 J=1,5
51161 K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J)
51162 P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J)
51163 V(N+I,J)=0D0
51164 230 CONTINUE
51165 240 CONTINUE
51166 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4),
51167 & -PS(2)/PS(4),-PS(3)/PS(4))
51168 PHI=PYANGL(P(N+1,1),P(N+1,2))
51169 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0)
51170 THE=PYANGL(P(N+1,3),P(N+1,1))
51171 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0)
51172 DO 250 I=3,2+NIIS(1)
51173 THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2))
51174 PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2))
51175 250 CONTINUE
51176 DO 260 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
51177 THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3),
51178 & SQRT(P(N+I,1)**2+P(N+I,2)**2))
51179 PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2))
51180 260 CONTINUE
51181 ENDIF
51182
51183C...Boost 3 or more partons to their rest frame.
51184 IF(NPA.GE.3) CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,-PS(1)/PS(4),
51185 &-PS(2)/PS(4),-PS(3)/PS(4))
51186
51187C...Define imagined single initiator of shower for parton system.
51188 NS=N
51189 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
51190 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
51191 IF(MSTU(21).GE.1) RETURN
51192 ENDIF
51193 270 N=NS
51194 IF(NPA.GE.2) THEN
51195 K(N+1,1)=11
51196 K(N+1,2)=21
51197 K(N+1,3)=0
51198 K(N+1,4)=0
51199 K(N+1,5)=0
51200 P(N+1,1)=0D0
51201 P(N+1,2)=0D0
51202 P(N+1,3)=0D0
51203 P(N+1,4)=PS(5)
51204 P(N+1,5)=PS(5)
51205 V(N+1,5)=PS(5)**2
51206 N=N+1
51207 IREF(1)=21
51208 ENDIF
51209
51210C...Loop over partons that may branch.
51211 NEP=NPA
51212 IM=NS
51213 IF(NPA.EQ.1) IM=NS-1
51214 280 IM=IM+1
51215 IF(N.GT.NS) THEN
51216 IF(IM.GT.N) GOTO 590
51217 KFLM=IABS(K(IM,2))
51218 IR=IREF(IM-NS)
51219 IF(KSH(IR).EQ.0) GOTO 280
51220 IF(P(IM,5).LT.PMTH(2,IR)) GOTO 280
51221 IGM=K(IM,3)
51222 ELSE
51223 IGM=-1
51224 ENDIF
51225 IF(N+NEP.GT.MSTU(4)-MSTU(32)-10) THEN
51226 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
51227 IF(MSTU(21).GE.1) RETURN
51228 ENDIF
51229
51230C...Position of aunt (sister to branching parton).
51231C...Origin and flavour of daughters.
51232 IAU=0
51233 IF(IGM.GT.0) THEN
51234 IF(K(IM-1,3).EQ.IGM) IAU=IM-1
51235 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
51236 ENDIF
51237 IF(IGM.GE.0) THEN
51238 K(IM,4)=N+1
51239 DO 290 I=1,NEP
51240 K(N+I,3)=IM
51241 290 CONTINUE
51242 ELSE
51243 K(N+1,3)=IPA(1)
51244 ENDIF
51245 IF(IGM.LE.0) THEN
51246 DO 300 I=1,NEP
51247 K(N+I,2)=K(IPA(I),2)
51248 300 CONTINUE
51249 ELSEIF(KFLM.NE.21) THEN
51250 K(N+1,2)=K(IM,2)
51251 K(N+2,2)=K(IM,5)
51252 IREF(N+1-NS)=IREF(IM-NS)
51253 IREF(N+2-NS)=IABS(K(N+2,2))
51254 ELSEIF(K(IM,5).EQ.21) THEN
51255 K(N+1,2)=21
51256 K(N+2,2)=21
51257 IREF(N+1-NS)=21
51258 IREF(N+2-NS)=21
51259 ELSE
51260 K(N+1,2)=K(IM,5)
51261 K(N+2,2)=-K(IM,5)
51262 IREF(N+1-NS)=IABS(K(N+1,2))
51263 IREF(N+2-NS)=IABS(K(N+2,2))
51264 ENDIF
51265
51266C...Reset flags on daughters and tries made.
51267 DO 310 IP=1,NEP
51268 K(N+IP,1)=3
51269 K(N+IP,4)=0
51270 K(N+IP,5)=0
51271 KFLD(IP)=IABS(K(N+IP,2))
51272 IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
51273 ITRY(IP)=0
51274 ISL(IP)=0
51275 ISI(IP)=0
51276 IF(KSH(IREF(N+IP-NS)).EQ.1) ISI(IP)=1
51277 310 CONTINUE
51278 ISLM=0
51279
51280C...Maximum virtuality of daughters.
51281 IF(IGM.LE.0) THEN
51282 DO 320 I=1,NPA
51283 IF(NPA.GE.3) P(N+I,4)=P(IPA(I),4)
51284 P(N+I,5)=MIN(QMAX,PS(5))
51285 IR=IREF(N+I-NS)
51286 IF(IP2.LE.-8) P(N+I,5)=MAX(P(N+I,5),2D0*PMTH(3,IR))
51287 IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
51288 320 CONTINUE
51289 ELSE
51290 IF(MSTJ(43).LE.2) PEM=V(IM,2)
51291 IF(MSTJ(43).GE.3) PEM=P(IM,4)
51292 P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
51293 P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM)
51294 IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
51295 ENDIF
51296 DO 330 I=1,NEP
51297 PMSD(I)=P(N+I,5)
51298 IF(ISI(I).EQ.1) THEN
51299 IR=IREF(N+I-NS)
51300 IF(P(N+I,5).LE.PMTH(3,IR)) P(N+I,5)=PMTH(1,IR)
51301 ENDIF
51302 V(N+I,5)=P(N+I,5)**2
51303 330 CONTINUE
51304
51305C...Choose one of the daughters for evolution.
51306 340 INUM=0
51307 IF(NEP.EQ.1) INUM=1
51308 DO 350 I=1,NEP
51309 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
51310 350 CONTINUE
51311 DO 360 I=1,NEP
51312 IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
51313 IR=IREF(N+I-NS)
51314 IF(P(N+I,5).GE.PMTH(2,IR)) INUM=I
51315 ENDIF
51316 360 CONTINUE
51317 IF(INUM.EQ.0) THEN
51318 RMAX=0D0
51319 DO 370 I=1,NEP
51320 IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQT2E) THEN
51321 RPM=P(N+I,5)/PMSD(I)
51322 IR=IREF(N+I-NS)
51323 IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IR)) THEN
51324 RMAX=RPM
51325 INUM=I
51326 ENDIF
51327 ENDIF
51328 370 CONTINUE
51329 ENDIF
51330
51331C...Cancel choice of predetermined daughter already treated.
51332 INUM=MAX(1,INUM)
51333 INUMT=INUM
51334 IF(MPSPD.EQ.1.AND.IGM.EQ.0.AND.ITRY(INUMT).GE.1) THEN
51335 IF(K(IP1-1+INUM,4).GT.0) INUM=3-INUM
51336 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2.AND.ITRY(INUMT).GE.1) THEN
51337 IF(KFLD(INUMT).NE.21.AND.K(IP1+2,4).GT.0) INUM=3-INUM
51338 IF(KFLD(INUMT).EQ.21.AND.K(IP1+3,4).GT.0) INUM=3-INUM
51339 ENDIF
51340
51341C...Store information on choice of evolving daughter.
51342 IEP(1)=N+INUM
51343 DO 380 I=2,NEP
51344 IEP(I)=IEP(I-1)+1
51345 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
51346 380 CONTINUE
51347 DO 390 I=1,NEP
51348 KFL(I)=IABS(K(IEP(I),2))
51349 390 CONTINUE
51350 ITRY(INUM)=ITRY(INUM)+1
51351 IF(ITRY(INUM).GT.200) THEN
51352 CALL PYERRM(14,'(PYSHOW:) caught in infinite loop')
51353 IF(MSTU(21).GE.1) RETURN
51354 ENDIF
51355 Z=0.5D0
51356 IR=IREF(IEP(1)-NS)
51357 IF(KSH(IR).EQ.0) GOTO 440
51358 IF(P(IEP(1),5).LT.PMTH(2,IR)) GOTO 440
51359
51360C...Check if evolution already predetermined for daughter.
51361 IPSPD=0
51362 IF(MPSPD.EQ.1.AND.IGM.EQ.0) THEN
51363 IF(K(IP1-1+INUM,4).GT.0) IPSPD=IP1-1+INUM
51364 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2) THEN
51365 IF(KFL(1).NE.21.AND.K(IP1+2,4).GT.0) IPSPD=IP1+2
51366 IF(KFL(1).EQ.21.AND.K(IP1+3,4).GT.0) IPSPD=IP1+3
51367 ENDIF
51368 ISSET(INUM)=0
51369 IF(IPSPD.NE.0) ISSET(INUM)=1
51370
51371C...Select side for interference with initial state partons.
51372 IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
51373 III=IEP(1)-NS-1
51374 ISII(III)=0
51375 IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
51376 ISII(III)=1
51377 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
51378 IF(PYR(0).GT.0.5D0) ISII(III)=1
51379 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
51380 ISII(III)=1
51381 IF(PYR(0).GT.0.5D0) ISII(III)=2
51382 ENDIF
51383 ENDIF
51384
51385C...Calculate allowed z range.
51386 IF(NEP.EQ.1) THEN
51387 PMED=PS(4)
51388 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
51389 PMED=P(IM,5)
51390 ELSE
51391 IF(INUM.EQ.1) PMED=V(IM,1)*PEM
51392 IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM
51393 ENDIF
51394 IF(MOD(MSTJ(43),2).EQ.1) THEN
51395 ZC=PMTH(2,21)/PMED
51396 ZCE=PMTH(2,22)/PMED
51397 IF(ISCOL(IR).EQ.0) ZCE=0.5D0*PARJ(90)/PMED
51398 ELSE
51399 ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2)))
51400 IF(ZC.LT.1D-6) ZC=(PMTH(2,21)/PMED)**2
51401 PMTMPE=PMTH(2,22)
51402 IF(ISCOL(IR).EQ.0) PMTMPE=0.5D0*PARJ(90)
51403 ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTMPE/PMED)**2)))
51404 IF(ZCE.LT.1D-6) ZCE=(PMTMPE/PMED)**2
51405 ENDIF
51406 ZC=MIN(ZC,0.491D0)
51407 ZCE=MIN(ZCE,0.49991D0)
51408 IF(((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND.
51409 &MIN(ZC,ZCE).GT.0.4999D0)).AND.IPSPD.EQ.0) THEN
51410 P(IEP(1),5)=PMTH(1,IR)
51411 V(IEP(1),5)=P(IEP(1),5)**2
51412 GOTO 440
51413 ENDIF
51414
51415C...Integral of Altarelli-Parisi z kernel for QCD.
51416C...(Includes squark and gluino; with factor N_C/C_F extra for latter).
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